git.gnu.io has moved to IP address 209.51.188.249 -- please double check where you are logging in.

Remove Notifications, Events, Mechanism, and SnowdriftEamilDaemon

parent b3c3f6f4
......@@ -59,13 +59,11 @@ library
Handler.JsLicenses
Handler.MarkdownTutorial
Handler.NewDesign
Handler.Notification
Handler.PostLogin
Handler.Project
Handler.ProjectBlog
Handler.ResetPassphrase
Handler.Simple
Handler.SnowdriftEvent
Handler.TH
Handler.User
Handler.User.Balance
......@@ -74,11 +72,7 @@ library
Handler.User.Delete
Handler.User.Edit
Handler.User.EstEligible
Handler.User.Notifications
Handler.User.Pledges
Handler.User.ProjectNotifications
Handler.User.ResetPassphrase
Handler.User.SelectProject
Handler.User.User
Handler.User.Users
Handler.User.Utils
......@@ -92,7 +86,6 @@ library
Local.Esqueleto
Local.Github
Local.Ord
Mechanism
Model
Model.Application
Model.Blog
......@@ -105,8 +98,6 @@ library
Model.License.Internal
Model.Markdown
Model.Markdown.Diff
Model.Notification
Model.Notification.Internal
Model.Permission.Internal
Model.Project
Model.Project.Signup
......@@ -116,8 +107,6 @@ library
Model.Role
Model.Settings
Model.Shares
Model.SnowdriftEvent
Model.SnowdriftEvent.Internal
Model.TH
Model.Tag
Model.Transaction
......@@ -130,12 +119,10 @@ library
Settings
Settings.Development
Settings.StaticFiles
SnowdriftEventHandler
Version
View.Project
View.Project.Signup
View.ResetPassphrase
View.SnowdriftEvent
View.Time
View.User
Widgets.Doc
......@@ -309,91 +296,6 @@ executable SnowdriftProcessPayments
DeriveDataTypeable
ScopedTypeVariables
-- executable SnowdriftEmailDaemon {{{1
executable SnowdriftEmailDaemon
if flag(dev)
ghc-options: -Wall -O0 -fobject-code
if flag(merge)
ghc-options: -Wall -Werror -O0 -fobject-code
if flag(library-only)
Buildable: False
-- Building on Windows is broken. See
-- https://github.com/commercialhaskell/stack/issues/466
if os(windows)
Buildable: False
default-language: Haskell2010
hs-source-dirs: app
main-is: SnowdriftEmailDaemon.hs
-- build-depends {{{2
build-depends: base
, authenticate
, blaze-builder
, blaze-html
, blaze-markup
, bytestring
, containers
, cmdargs
, data-default
, Diff
, directory
, esqueleto
, email-validate
, fast-logger
, hjsmin
, hourglass
, http-conduit
, lens
, lifted-base
, mime-mail
, monad-logger
, mtl
, path-pieces
, persistent
, persistent-postgresql
, persistent-template
, random
, resourcet
, semigroups
, shakespeare
, Snowdrift
, stm
, template-haskell
, text
, time
, titlecase
, transformers
, yaml
, yesod
, yesod-auth
, yesod-auth-hashdb
, yesod-core
, yesod-form
, yesod-markdown
, yesod-static
-- default-extensions {{{2
default-extensions: BangPatterns
ConstraintKinds
DeriveDataTypeable
EmptyDataDecls
ExistentialQuantification
FlexibleContexts
FlexibleInstances
GeneralizedNewtypeDeriving
LambdaCase
MultiParamTypeClasses
MultiWayIf
NoImplicitPrelude
QuasiQuotes
OverloadedStrings
RankNTypes
RecordWildCards
ScopedTypeVariables
TemplateHaskell
TupleSections
TypeFamilies
ViewPatterns
-- executable sendmail-mock {{{1
executable sendmail-mock
if flag(dev)
......
......@@ -7,7 +7,6 @@ import Yesod.Default.Config
import qualified Database.Persist.Sql
import Settings
import qualified Mechanism as Mech
runDB :: (PersistConfig c, MonadBaseControl IO m, MonadIO m)
=> c
......
......@@ -28,8 +28,6 @@ User
statement Markdown Maybe
ircNick Text Maybe
languages [Language]
readNotifications UTCTime default=now()
-- ^ The last time the user visited /notifications
readApplications UTCTime default=now()
established Established default='EstUnestablished'
......@@ -62,29 +60,6 @@ DeleteConfirmation
UniqueDeleteConfirmation user email uri
-- A single notification preference. If some NotificationType does not appear
-- in any row for a particular user, that means the user does not wish to be
-- notified of those notifications.
--
-- Notifications that "must" be delivered (e.g. administrative notifications
-- directly from Snowdrift) don't need an entry in this table, as the code that
-- sends such notifications needn't query it.
UserNotificationPref
user UserId
type UserNotificationType
delivery UserNotificationDelivery
UniqueUserNotificationPref user type
-- Preferences for projects watched by a user.
ProjectNotificationPref
user UserId
project ProjectId
type ProjectNotificationType
delivery ProjectNotificationDelivery
UniqueProjectNotificationPref user project type
-- User-watching-project relation
UserWatchingProject
user UserId
......@@ -220,52 +195,6 @@ VolunteerInterest
volunteer VolunteerApplicationId
interest InterestId
UserNotification
createdTs UTCTime
type UserNotificationType
to UserId
content Markdown
archived Bool
UniqueUserNotification createdTs type to
deriving Eq
-- Notifications by projects watched by a user.
ProjectNotification
createdTs UTCTime
type ProjectNotificationType
to UserId
project ProjectId -- An "associated" project.
content Markdown
archived Bool
UniqueProjectNotification createdTs type to project
deriving Eq
-- Notification emails that are sent by the email daemon. 'UserId's
-- are used instead of email addresses to "force" the daemon to look
-- up the actual email address. If a user changes it, anything queued
-- up goes to the right place.
UserNotificationEmail
createdTs UTCTime
type UserNotificationType
to UserId
content Markdown
UniqueUserNotificationEmail createdTs type to
-- Email notifications by projects watched by a user.
ProjectNotificationEmail
createdTs UTCTime
type ProjectNotificationType
to UserId
project ProjectId
content Markdown
UniqueProjectNotificationEmail createdTs type to project
Tag
name Text
UniqueTag name
......@@ -309,13 +238,6 @@ DefaultTagColor
UniqueDefaultTag tag
RoleEvent
ts UTCTime
user UserId
role Role
project ProjectId
added Bool
DatabaseVersion
lastMigration Int
......@@ -332,33 +254,6 @@ SharesPledged
shares Int64
render PledgeFormRenderedId
-------------------------------------------------------------------------------
-- Snowdrift events. These are all combined into a single sum time in
-- Model.SnowdriftEvent.
EventUserNotificationSent
ts UTCTime
notification UserNotificationId
EventProjectNotificationSent
ts UTCTime
notification ProjectNotificationId
EventNewPledge
ts UTCTime
sharesPledged SharesPledgedId
EventUpdatedPledge
ts UTCTime
oldShares Int64
sharesPledged SharesPledgedId
EventDeletedPledge
ts UTCTime
user UserId
project ProjectId
shares Int64
Image
ts UTCTime
uploader UserId
......
......@@ -53,7 +53,6 @@
-- Note that for logged-out users, / ("HomeR") is the simple welcome page.
/ HomeR GET
/transactions UTransactionsR GET
/notifications UNotificationsR GET
/pledges UPledgesR GET
/roles URolesR GET
......@@ -107,18 +106,9 @@
/u/#UserId/confirm-delete/#Text UserConfirmDeleteR GET POST
/u/#UserId/edit EditUserR GET POST
/u/#UserId/elig UserEstEligibleR POST
/u/#UserId/user-notifications UserNotificationsR GET POST
/u/#UserId/pledges UserPledgesR GET
/u/#UserId/project-notifications/#ProjectId ProjectNotificationsR GET POST
/u/#UserId/reset-passphrase/#Text UserResetPassphraseR GET POST
/u/#UserId/select-project UserSelectProjectR GET POST
/u/#UserId/verify-email/#Text UserVerifyEmailR GET
-- Notifications
/notificationsp NotificationsProxyR GET
/notifications/archivedp ArchivedNotificationsProxyR GET
-- Project
/p/#Text/applications ApplicationsR GET
......@@ -137,10 +127,6 @@
/p/#ProjectId/watch WatchProjectR POST
/p/#ProjectId/unwatch UnwatchProjectR POST
/ev/newpledge/#EventNewPledgeId EventNewPledgeR GET
/ev/updatedpledge/#EventUpdatedPledgeId EventUpdatedPledgeR GET
/ev/deletedpledge/#EventDeletedPledgeId EventDeletedPledgeR GET
-- Devs only!
/dev/build BuildFeedR GET
......@@ -9,8 +9,6 @@ module Application
import Import
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM (atomically, newTChanIO, tryReadTChan)
import Control.Monad.Logger (runLoggingT, runStderrLoggingT)
import Control.Monad.Reader
import Control.Monad.Trans.Resource
......@@ -33,7 +31,6 @@ import qualified Data.List as L
import qualified Database.Persist
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
import SnowdriftEventHandler
import Version
import Migrations
import Widgets.Navbar
......@@ -47,12 +44,10 @@ import Handler.Invitation
import Handler.JsLicenses
import Handler.MarkdownTutorial
import Handler.NewDesign
import Handler.Notification
import Handler.PostLogin
import Handler.Project
import Handler.ResetPassphrase
import Handler.Simple
import Handler.SnowdriftEvent
import Handler.User
import Handler.Volunteer
import Handler.Who
......@@ -116,7 +111,6 @@ makeFoundation conf = do
loggerSet' <- newStdoutLoggerSet defaultBufSize
(getter, _) <- clockDateCacher
event_chan <- newTChanIO
let logger = Yesod.Core.Types.Logger loggerSet' getter
foundation = App
{ appNavbar = navbar
......@@ -126,8 +120,6 @@ makeFoundation conf = do
, appHttpManager = manager
, persistConfig = dbconf
, appLogger = logger
, appEventChan = event_chan
, appEventHandlers = snowdriftEventHandlers
}
-- Database setup
......@@ -167,8 +159,6 @@ makeFoundation conf = do
migration
(messageLoggerSource foundation logger)
forkEventHandler foundation
return foundation
-- for yesod devel
......@@ -179,19 +169,3 @@ getApplicationDev =
loader = Yesod.Default.Config.loadConfig (configSettings Development)
{ csParseExtra = parseExtra
}
--------------------------------------------------------------------------------
-- SnowdriftEvent handling
forkEventHandler :: App -> IO ()
forkEventHandler app@App{..} = void . forkIO . forever $ do
threadDelay 1000000 -- Sleep for one second in between runs.
handleNEvents 10 -- Handle up to 10 events per run.
where
handleNEvents :: Int -> IO ()
handleNEvents 0 = return ()
handleNEvents n = atomically (tryReadTChan appEventChan) >>= \case
Nothing -> return ()
Just event -> do
mapM_ (runDaemon app) (appEventHandlers appSettings <*> [event])
handleNEvents (n-1)
......@@ -3,12 +3,10 @@ module Foundation where
import Import.NoFoundation
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
import Control.Concurrent.STM
import Control.Exception.Lifted (throwIO, handle)
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Control.Monad.Writer.Strict (WriterT, runWriterT)
import Data.Char (isSpace)
import Data.Text as T
import Network.HTTP.Conduit (Manager)
......@@ -50,9 +48,6 @@ data App = App
, appHttpManager :: Manager
, persistConfig :: Settings.PersistConf
, appLogger :: Logger
, appEventChan :: TChan SnowdriftEvent
, appEventHandlers :: AppConfig DefaultEnv Extra
-> [SnowdriftEvent -> Daemon ()]
}
plural :: Integral i => i -> Text -> Text -> Text
......@@ -300,16 +295,6 @@ createUser ident passph name newEmail avatar nick = do
forM_ default_tag_colors $ \(Entity _ (DefaultTagColor tag color)) -> insert $ TagColor tag user_id color
--
insertDefaultNotificationPrefs user_id
let welcome_route = "#"
let notif_text = Markdown $ T.unlines
[ "Thanks for registering!"
, "<br> Please read our [**welcome message**](" <>
welcome_route <>
"), and let us know any questions."
]
insert_ $ UserNotification now NotifWelcome user_id notif_text False
return $ Just user_id
Nothing -> do
lift $ addAlert "danger" "Handle already in use."
......@@ -329,25 +314,10 @@ createUser ident passph name newEmail avatar nick = do
, userStatement = Nothing
, userIrcNick = nick
, userLanguages = langs
, userReadNotifications = now
, userReadApplications = now
, userEstablished = EstUnestablished
}
insertDefaultNotificationPrefs :: UserId -> DB ()
insertDefaultNotificationPrefs user_id =
void . insertMany $ uncurry (UserNotificationPref user_id) <$>
-- 'NotifWelcome' is not set since it is delivered when a
-- user is created.
[ (NotifBalanceLow, UserNotifDeliverWebsiteAndEmail)
, (NotifUnapprovedComment, UserNotifDeliverEmail)
, (NotifRethreadedComment, UserNotifDeliverWebsite)
, (NotifReply, UserNotifDeliverEmail)
, (NotifEditConflict, UserNotifDeliverWebsite)
, (NotifFlag, UserNotifDeliverWebsiteAndEmail)
, (NotifFlagRepost, UserNotifDeliverWebsite)
]
instance YesodJquery App
instance (MonadBaseControl IO m, MonadIO m, MonadThrow m) => HasGithubRepo (HandlerT App m) where
......@@ -405,10 +375,6 @@ getAlert = do
deleteSession alertKey
return mmsg
-- | Write a list of SnowdriftEvent to the event channel.
pushEvents :: (MonadIO m, MonadReader App m) => [SnowdriftEvent] -> m ()
pushEvents events = ask >>= liftIO . atomically . forM_ events . writeTChan . appEventChan
--------------------------------------------------------------------------------
-- There are FOUR different kinds of database actions, each with a different run function.
......@@ -444,24 +410,6 @@ type YDB a = SqlPersistT Handler a
runYDB :: YDB a -> Handler a
runYDB = Y.runDB
-- A database action that writes [SnowdriftEvent], to be run after the transaction is complete.
type SDB a = forall m. DBConstraint m => WriterT [SnowdriftEvent] (SqlPersistT m) a
runSDB :: DBConstraint m => SDB a -> m a
runSDB w = do
(a, events) <- runDB (runWriterT w)
pushEvents events
return a
-- A combination of YDB and SDB (writes events, requires inner Handler).
type SYDB a = WriterT [SnowdriftEvent] (SqlPersistT Handler) a
runSYDB :: SYDB a -> Handler a
runSYDB w = do
(a, events) <- runYDB (runWriterT w)
pushEvents events
return a
-- from http://stackoverflow.com/questions/8066850/why-doesnt-haskells-prelude-read-return-a-maybe
readMaybe :: (Read a) => String -> Maybe a
readMaybe s = case [x | (x,t) <- reads s, ("","") <- lex t] of
......
......@@ -10,27 +10,14 @@ import Import
-- | Using explicit imports for now. It feels good to treat existing code
-- as a 3rd-party library.
import Dev
import Handler.Notification
( buildNotificationsList
, Notification(..)
)
import Handler.TH
import Handler.User.Utils (startEmailVerification)
import Handler.Utils
import Model.Project
( fetchPublicProjectsDB
, projectNameWidget
)
import Model.Project ( fetchPublicProjectsDB)
import Model.User
( fetchArchivedProjectNotificationsDB
, fetchArchivedUserNotificationsDB
, fetchProjectNotificationsDB
, fetchUserNotificationsDB
, fetchUserProjectsAndRolesDB
( fetchUserProjectsAndRolesDB
, userDisplayName
, userReadNotificationsDB
)
import View.Time (renderTime)
import View.User (renderUser, createUserForm)
getSearchR :: Handler Html
......@@ -193,20 +180,3 @@ getUserR user_id = do
userDisplayName (Entity user_id user)
alphaRewriteNotice
renderUser mviewer_id user_id user projects_and_roles
getUNotificationsR :: Handler Html
getUNotificationsR = do
showArchived <- lookupGetParam "state"
user_id <- requireAuthId
notifs <- runDB $ do
case showArchived of
Just "archived" -> do
user_notifs <- fetchArchivedUserNotificationsDB user_id
project_notifs <- fetchArchivedProjectNotificationsDB user_id
return $ buildNotificationsList user_notifs project_notifs
_ -> do
userReadNotificationsDB user_id
user_notifs <- fetchUserNotificationsDB user_id
project_notifs <- fetchProjectNotificationsDB user_id
return $ buildNotificationsList user_notifs project_notifs
$(widget "dashboard/notifications" "Notifications")
......@@ -4,12 +4,8 @@ module Handler.Project where
import Import
import Data.List (sortBy)
import System.Random (randomIO)
import Text.Cassius (cassiusFile)
import Text.Printf
import Yesod.AtomFeed
import Yesod.RssFeed
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
......@@ -21,13 +17,9 @@ import Model.Application
import Model.Currency
import Model.Project
import Model.Role
import Model.Shares
import Model.SnowdriftEvent
import Model.User
import View.Project
import View.SnowdriftEvent
import View.Time
import qualified Mechanism as Mech
--------------------------------------------------------------------------------
-- Utility functions
......@@ -68,7 +60,6 @@ getApplicationsR project_handle = do
lift (permissionDenied "You don't have permission to view this page.")
applications <- fetchProjectVolunteerApplicationsDB project_id
userReadVolunteerApplicationsDB viewer_id
return (project, applications)
defaultLayoutNew "applications" $ do
......@@ -126,97 +117,7 @@ getEditProjectR project_handle = do
-- | This function is responsible for hitting every relevant event table. Nothing
-- statically guarantees that.
getProjectFeedR :: Text -> Handler TypedContent
getProjectFeedR project_handle = do
let lim = 26 -- limit 'lim' from each table, then take 'lim - 1'
muser <- maybeAuth
let muser_id = entityKey <$> muser
before <- lookupGetUTCTimeDefaultNow "before"
(
project_id, project,
is_watching,
new_pledge_events,
updated_pledge_events, deleted_pledge_events,
user_map
) <- runYDB $ do
Entity project_id project <- getBy404 (UniqueProjectHandle project_handle)
is_watching <- maybe (pure False) (flip userIsWatchingProjectDB project_id) muser_id
( new_pledge_events
, updated_pledge_events
, deleted_pledge_events
, pledging_users
, unpledging_users) <- Mech.projectEvents project_id before lim
-- Suplementary maps for displaying the data. If something above requires extra
-- data to display the project feed row, it MUST be used to fetch the data below!
let -- All users: comment posters, wiki page creators, etc.
user_ids = S.toList $ mconcat
[ S.fromList pledging_users
, S.fromList unpledging_users
]
user_map <- entitiesMap <$> selectList [UserId <-. user_ids] []
return
(
project_id, project,
is_watching,
new_pledge_events, updated_pledge_events, deleted_pledge_events,
user_map
)
let all_unsorted_events :: [(Route App, SnowdriftEvent)]
all_unsorted_events = mconcat
[ map (EventNewPledgeR *** onEntity ENewPledge) new_pledge_events
, map (\(eid, shares, pledge)
-> (EventUpdatedPledgeR eid, eup2se shares pledge)) updated_pledge_events
, map (EventDeletedPledgeR *** edp2se) deleted_pledge_events
]
(events, more_events) = splitAt (lim-1) (sortBy (snowdriftEventNewestToOldest `on` snd) all_unsorted_events)
-- For pagination: Nothing means no more pages, Just time means set the 'before'
-- GET param to that time. Note that this means 'before' should be a <= relation,
-- rather than a <.
mnext_before :: Maybe Text
mnext_before = case more_events of
[] -> Nothing
((_, next_event):_) -> (Just . T.pack . show . snowdriftEventTime) next_event
now <- liftIO getCurrentTime
Just route <- getCurrentRoute
render <- getUrlRender
let feed = Feed "project feed" route HomeR "Snowdrift Community" "" "en" now Nothing $
mapMaybe (uncurry $ snowdriftEventToFeedEntry
render
project_handle
user_map) events
selectRep $ do
provideRep $ atomFeed feed
provideRep $ rssFeed feed
provideRep $ defaultLayout $ do
snowdriftDashTitle (projectName project) "Feed"
$(widgetFile "project_feed")
toWidget $(cassiusFile "templates/comment.cassius")
where
-- "event updated pledge to snowdrift event"
eup2se :: Int64 -> Entity SharesPledged -> SnowdriftEvent
eup2se old_shares (Entity shares_pledged_id shares_pledged) = EUpdatedPledge old_shares shares_pledged_id shares_pledged
-- "event deleted pledge to snowdrift event"
edp2se :: EventDeletedPledge -> SnowdriftEvent
edp2se (EventDeletedPledge a b c d) = EDeletedPledge a b c d
getProjectFeedR _project_handle = selectRep $ provideRep $ defaultLayout $ return ()
--------------------------------------------------------------------------------
-- /invite
......@@ -334,74 +235,10 @@ getProjectPatronsR project_handle = do
-- /pledge
getUpdatePledgeR :: Text -> Handler Html
getUpdatePledgeR project_handle = do
_ <- requireAuthId
Entity project_id project <- runYDB $ getBy404 $ UniqueProjectHandle project_handle
((result, _), _) <- runFormGet $ pledgeForm project_id
let dangerRedirect msg = do
alertDanger msg
redirect $ PHomeR project_handle
case result of
FormSuccess (SharesPurchaseOrder new_user_shares) -> do
user_id <- requireAuthId
(confirm_form, _) <-
generateFormPost
(projectConfirmPledgeForm (Just new_user_shares))
(mpledge
, old_user_amount
, new_user_amount
, old_project_amount
, new_project_amount
, numPatrons
) <- runDB (Mech.potentialPledge user_id project_id new_user_shares)
let new_user_mills = millMilray new_user_shares
case mpledge of
Just (Entity _ pledge) | pledgeShares pledge == new_user_shares -> do
alertWarning $ T.unwords
[ "Your pledge was already at"
, T.pack (show new_user_mills) <> "."
, "Thank you for your support!"
]
redirect (PHomeR project_handle)
_ -> do
let user_decrease = old_user_amount - new_user_amount
user_increase = new_user_amount - old_user_amount
project_decrease = old_project_amount - new_project_amount
project_increase = new_project_amount - old_project_amount
matching_drop = project_decrease - user_decrease
matched_extra = project_increase - new_user_amount
-- Standins added during mechanism split-out
old_user_mills = 0xdeadbeef :: Int64
old_user_shares = 0xbaff1ed :: Int64
defaultLayout $ do
snowdriftDashTitle
(projectName project)
"update pledge"
$(widgetFile "update_pledge")
FormMissing -> dangerRedirect "Form missing."
FormFailure errors ->
dangerRedirect $ T.snoc (T.intercalate "; " errors) '.'
getUpdatePledgeR _project_handle = return ""
postUpdatePledgeR :: Text -> Handler Html
postUpdatePledgeR project_handle = do
((result, _), _) <- runFormPost $ projectConfirmPledgeForm Nothing
isConfirmed <- maybe False (T.isPrefixOf "yes") <$> lookupPostParam "confirm"
case result of
FormSuccess (SharesPurchaseOrder shares) -> do