Wire in NotificationSubmissionRated
This commit is contained in:
Gregor Kleen
parent
ee08b641bb
commit
f98939885b
5
db.hs
5
db.hs
@ -83,6 +83,7 @@ fillDb = do
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userNotificationSettings = def
|
||||
}
|
||||
fhamann <- insert User
|
||||
{ userIdent = "felix.hamann@campus.lmu.de"
|
||||
@ -97,6 +98,7 @@ fillDb = do
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userNotificationSettings = def
|
||||
}
|
||||
jost <- insert User
|
||||
{ userIdent = "jost@tcs.ifi.lmu.de"
|
||||
@ -111,6 +113,7 @@ fillDb = do
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userNotificationSettings = def
|
||||
}
|
||||
void . insert $ User
|
||||
{ userIdent = "max@campus.lmu.de"
|
||||
@ -125,6 +128,7 @@ fillDb = do
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userNotificationSettings = def
|
||||
}
|
||||
void . insert $ User
|
||||
{ userIdent = "tester@campus.lmu.de"
|
||||
@ -139,6 +143,7 @@ fillDb = do
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userNotificationSettings = def
|
||||
}
|
||||
void . repsert (TermKey summer2017) $ Term
|
||||
{ termName = summer2017
|
||||
|
||||
@ -316,4 +316,7 @@ MailTestSubject: Uni2Work Test-Email
|
||||
MailTestContent: Dies ist eine Test-Email versandt von Uni2Work. Von Ihrer Seite ist keine Handlung notwendig.
|
||||
|
||||
German: Deutsch
|
||||
GermanGermany: Deutsch (Deutschland)
|
||||
GermanGermany: Deutsch (Deutschland)
|
||||
|
||||
MailSubjectSubmissionRated csh@CourseShorthand: Ihre #{csh}-Abgabe wurde bewertet
|
||||
MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{courseName} (#{termDesc}) wurde bewertet.
|
||||
4
models
4
models
@ -11,6 +11,8 @@ User json
|
||||
dateFormat DateTimeFormat "default='%d.%m.%Y'"
|
||||
timeFormat DateTimeFormat "default='%R'"
|
||||
downloadFiles Bool default=false
|
||||
mailLanguages MailLanguages "default='[]'"
|
||||
notificationSettings NotificationSettings
|
||||
UniqueAuthentication ident
|
||||
UniqueEmail email
|
||||
deriving Show
|
||||
@ -227,4 +229,4 @@ QueuedJob
|
||||
creationTime UTCTime
|
||||
lockInstance InstanceId Maybe
|
||||
lockTime UTCTime Maybe
|
||||
deriving Eq Read Show Generic Typeable
|
||||
deriving Eq Read Show Generic Typeable
|
||||
@ -101,6 +101,7 @@ dependencies:
|
||||
- resource-pool
|
||||
- mime-mail
|
||||
- hashable
|
||||
- aeson-pretty
|
||||
|
||||
# The library contains all of our application code. The executable
|
||||
# defined below is just a thin wrapper.
|
||||
|
||||
@ -1255,12 +1255,14 @@ instance YesodAuth UniWorX where
|
||||
|
||||
let
|
||||
newUser = User
|
||||
{ userMaxFavourites = userDefaultMaxFavourites
|
||||
, userTheme = userDefaultTheme
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
{ userMaxFavourites = userDefaultMaxFavourites
|
||||
, userTheme = userDefaultTheme
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userNotificationSettings = def
|
||||
, userMailLanguages = def
|
||||
, ..
|
||||
}
|
||||
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
|
||||
|
||||
@ -63,9 +63,12 @@ postAdminTestR = do
|
||||
|
||||
((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm "email" $ renderAForm FormStandard emailTestForm
|
||||
case emailResult of
|
||||
(FormSuccess (email, ls)) -> runDB $ do
|
||||
(fromSqlKey -> jId) <- queueJob $ JobSendTestEmail email ls
|
||||
addMessage Success [shamlet|Email-test gestartet (Job ##{tshow jId})|]
|
||||
(FormSuccess (email, ls)) -> do
|
||||
jId <- runDB $ do
|
||||
jId <- queueJob $ JobSendTestEmail email ls
|
||||
addMessage Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|]
|
||||
return jId
|
||||
writeJobCtl $ JobCtlPerform jId
|
||||
FormMissing -> return ()
|
||||
(FormFailure errs) -> forM_ errs $ addMessage Error . toHtml
|
||||
|
||||
|
||||
@ -21,6 +21,7 @@ module Handler.Corrections where
|
||||
import Import
|
||||
-- import System.FilePath (takeFileName)
|
||||
|
||||
import Jobs
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Submission
|
||||
import Handler.Utils.Table.Cells
|
||||
@ -463,11 +464,13 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
FormMissing -> return ()
|
||||
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
|
||||
FormSuccess (ratingPoints, ratingComment) -> do
|
||||
runDB $ do
|
||||
notify <- runDB $ do
|
||||
uid <- liftHandlerT requireAuthId
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
let rated = isJust $ void ratingPoints <|> void ratingComment
|
||||
let rated = isJust $ void ratingPoints -- <|> void ratingComment -- Comment shouldn't cause rating
|
||||
|
||||
Submission{submissionRatingTime} <- getJust sub
|
||||
|
||||
update sub [ SubmissionRatingBy =. (uid <$ guard rated)
|
||||
-- SJ: I don't think we need to update AssignedTime here, since this is just for correction upload
|
||||
@ -478,6 +481,12 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
]
|
||||
|
||||
addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated
|
||||
|
||||
return $ rated && isNothing submissionRatingTime
|
||||
|
||||
when notify $
|
||||
queueJob' . JobQueueNotification $ NotificationSubmissionRated sub
|
||||
|
||||
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||||
|
||||
case uploadResult of
|
||||
@ -486,7 +495,8 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
FormSuccess fileSource -> do
|
||||
uid <- requireAuthId
|
||||
|
||||
runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
|
||||
(_, mjId) <- runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
|
||||
traverse (writeJobCtl . JobCtlPerform) mjId
|
||||
|
||||
addMessageI Success MsgRatingFilesUpdated
|
||||
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||||
@ -521,7 +531,8 @@ postCorrectionsUploadR = do
|
||||
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
|
||||
FormSuccess files -> do
|
||||
uid <- requireAuthId
|
||||
subs <- runDB . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkMultiSubmission uid True
|
||||
(subs, jobs) <- runDB . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkMultiSubmission uid True
|
||||
forM_ jobs $ writeJobCtl . JobCtlPerform
|
||||
if
|
||||
| null subs -> addMessageI Warning MsgNoCorrectionsUploaded
|
||||
| otherwise -> do
|
||||
|
||||
@ -232,8 +232,8 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
|
||||
smid <- case (mFiles, msmid) of
|
||||
(Nothing, Just smid) -- no new files, existing submission partners updated
|
||||
-> return smid
|
||||
(Just files, _) -- new files
|
||||
-> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
|
||||
(Just files, _) -> -- new files
|
||||
fmap fst . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
|
||||
(Nothing, Nothing) -- new submission, no file upload requested
|
||||
-> insert Submission
|
||||
{ submissionSheet = shid
|
||||
|
||||
@ -25,6 +25,7 @@ import Handler.Utils.Rating as Handler.Utils hiding (extractRatings)
|
||||
import Handler.Utils.Submission as Handler.Utils
|
||||
import Handler.Utils.Sheet as Handler.Utils
|
||||
import Handler.Utils.Templates as Handler.Utils
|
||||
import Handler.Utils.Mail as Handler.Utils
|
||||
|
||||
|
||||
downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
|
||||
|
||||
64
src/Handler/Utils/Mail.hs
Normal file
64
src/Handler/Utils/Mail.hs
Normal file
@ -0,0 +1,64 @@
|
||||
{-# LANGUAGE NoImplicitPrelude
|
||||
, NamedFieldPuns
|
||||
, TypeFamilies
|
||||
, FlexibleContexts
|
||||
, ViewPatterns
|
||||
#-}
|
||||
|
||||
module Handler.Utils.Mail
|
||||
( addRecipientsDB
|
||||
, userMailT
|
||||
, addFileDB
|
||||
) where
|
||||
|
||||
import Import hiding ((.=))
|
||||
|
||||
import Utils.Lens hiding (snoc)
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import System.FilePath (takeBaseName)
|
||||
import Network.Mime (defaultMimeLookup)
|
||||
|
||||
import Control.Monad.Trans.State (StateT)
|
||||
|
||||
|
||||
addRecipientsDB :: ( MonadMail m
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
) => [Filter User] -> m ()
|
||||
-- ^ @setRecipientId uid@ throws an exception if @uid@ does not refer to an existing user
|
||||
addRecipientsDB uFilter = runConduit $ transPipe (liftHandlerT . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient
|
||||
where
|
||||
addRecipient (Entity _ User{userEmail, userDisplayName}) = do
|
||||
let addr = Address (Just userDisplayName) $ CI.original userEmail
|
||||
_mailTo %= flip snoc addr
|
||||
|
||||
userMailT :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadBaseControl IO m
|
||||
, MonadLogger m
|
||||
) => UserId -> MailT m a -> m a
|
||||
userMailT uid mAct = do
|
||||
User{userEmail, userDisplayName, userMailLanguages} <- liftHandlerT . runDB $ getJust uid
|
||||
let addr = Address (Just userDisplayName) $ CI.original userEmail
|
||||
mailT userMailLanguages $ do
|
||||
_mailTo .= pure addr
|
||||
mAct
|
||||
|
||||
addFileDB :: ( MonadMail m
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
) => FileId -> m MailObjectId
|
||||
addFileDB fId = do
|
||||
File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- liftHandlerT . runDB $ getJust fId
|
||||
addPart $ do
|
||||
_partType .= decodeUtf8 (defaultMimeLookup fileName)
|
||||
_partEncoding .= Base64
|
||||
_partFilename .= Just fileName
|
||||
_partContent .= LBS.fromStrict fileContent
|
||||
setMailObjectId' fId :: StateT Part (HandlerT UniWorX IO) MailObjectId
|
||||
@ -11,6 +11,7 @@
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
|
||||
|
||||
module Handler.Utils.Submission
|
||||
@ -25,6 +26,7 @@ module Handler.Utils.Submission
|
||||
) where
|
||||
|
||||
import Import hiding ((.=), joinPath)
|
||||
import Jobs
|
||||
import Prelude (lcm)
|
||||
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
||||
|
||||
@ -38,7 +40,7 @@ import Control.Monad.RWS.Lazy (RWST)
|
||||
import qualified Control.Monad.Random as Rand
|
||||
import qualified System.Random.Shuffle as Rand (shuffleM)
|
||||
|
||||
import Data.Maybe
|
||||
import Data.Maybe ()
|
||||
|
||||
import qualified Data.List as List
|
||||
import Data.Set (Set)
|
||||
@ -279,6 +281,7 @@ submissionMultiArchive (Set.toList -> ids) = do
|
||||
data SubmissionSinkState = SubmissionSinkState
|
||||
{ sinkSeenRating :: Any
|
||||
, sinkSubmissionTouched :: Any
|
||||
, sinkSubmissionNotifyRating :: Any
|
||||
, sinkFilenames :: Set FilePath
|
||||
} deriving (Show, Eq, Generic, Typeable)
|
||||
|
||||
@ -333,7 +336,7 @@ extractRatingsMsg = do
|
||||
sinkSubmission :: UserId
|
||||
-> Either SheetId SubmissionId
|
||||
-> Bool -- ^ Is this a correction
|
||||
-> Sink SubmissionContent (YesodDB UniWorX) SubmissionId
|
||||
-> Sink SubmissionContent (YesodDB UniWorX) (SubmissionId, Maybe QueuedJobId)
|
||||
-- ^ Replace the currently saved files for the given submission (either
|
||||
-- corrected files or original ones, depending on arguments) with the supplied
|
||||
-- 'SubmissionContent'.
|
||||
@ -359,13 +362,13 @@ sinkSubmission userId mExists isUpdate = do
|
||||
return sId
|
||||
Right sId -> return sId
|
||||
|
||||
sId <$ sinkSubmission' sId isUpdate
|
||||
(,) <$> pure sId <*> sinkSubmission' sId isUpdate
|
||||
where
|
||||
tell = modify . mappend
|
||||
|
||||
sinkSubmission' :: SubmissionId
|
||||
-> Bool -- ^ Is this a correction
|
||||
-> Sink SubmissionContent (YesodDB UniWorX) ()
|
||||
-> Sink SubmissionContent (YesodDB UniWorX) (Maybe QueuedJobId)
|
||||
sinkSubmission' submissionId isUpdate = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
|
||||
Left file@(File{..}) -> do
|
||||
$logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle)
|
||||
@ -468,13 +471,16 @@ sinkSubmission userId mExists isUpdate = do
|
||||
alreadyTouched <- gets $ getAny . sinkSubmissionTouched
|
||||
when (not alreadyTouched) $ do
|
||||
now <- liftIO getCurrentTime
|
||||
lift $ case isUpdate of
|
||||
False -> insert_ $ SubmissionEdit userId now submissionId
|
||||
True -> update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
|
||||
-- TODO: Should submissionRatingAssigned change here if userId changes?
|
||||
case isUpdate of
|
||||
False -> lift . insert_ $ SubmissionEdit userId now submissionId
|
||||
True -> do
|
||||
Submission{submissionRatingTime} <- lift $ getJust submissionId
|
||||
when (isNothing submissionRatingTime) $ tell mempty { sinkSubmissionNotifyRating = Any True }
|
||||
lift $ update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
|
||||
-- TODO: Should submissionRatingAssigned change here if userId changes?
|
||||
tell $ mempty{ sinkSubmissionTouched = Any True }
|
||||
|
||||
finalize :: SubmissionSinkState -> YesodDB UniWorX ()
|
||||
finalize :: SubmissionSinkState -> YesodDB UniWorX (Maybe QueuedJobId)
|
||||
finalize SubmissionSinkState{..} = do
|
||||
missingFiles <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
|
||||
E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
|
||||
@ -509,13 +515,19 @@ sinkSubmission userId mExists isUpdate = do
|
||||
update sfId [ SubmissionFileFile =. f, SubmissionFileIsDeletion =. True ]
|
||||
deleteCascade fileId
|
||||
|
||||
when (isUpdate && not (getAny sinkSeenRating)) $
|
||||
update submissionId
|
||||
if
|
||||
| isUpdate
|
||||
, not $ getAny sinkSeenRating
|
||||
-> Nothing <$ update submissionId
|
||||
[ SubmissionRatingTime =. Nothing
|
||||
, SubmissionRatingPoints =. Nothing
|
||||
, SubmissionRatingBy =. Nothing
|
||||
, SubmissionRatingComment =. Nothing
|
||||
]
|
||||
| isUpdate
|
||||
, getAny sinkSubmissionNotifyRating
|
||||
-> fmap Just . queueJob . JobQueueNotification $ NotificationSubmissionRated submissionId
|
||||
| otherwise -> return Nothing
|
||||
|
||||
data SubmissionMultiSinkException
|
||||
= SubmissionSinkException
|
||||
@ -529,7 +541,7 @@ instance Exception SubmissionMultiSinkException
|
||||
|
||||
sinkMultiSubmission :: UserId
|
||||
-> Bool {-^ Are these corrections -}
|
||||
-> Sink SubmissionContent (YesodDB UniWorX) (Set SubmissionId)
|
||||
-> Sink SubmissionContent (YesodDB UniWorX) (Set SubmissionId, Set QueuedJobId)
|
||||
|
||||
-- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'.
|
||||
--
|
||||
@ -543,7 +555,7 @@ sinkMultiSubmission userId isUpdate = do
|
||||
-> RWST
|
||||
()
|
||||
_
|
||||
(Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId))
|
||||
(Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) (SubmissionId, Maybe QueuedJobId)))
|
||||
(YesodDB UniWorX)
|
||||
()
|
||||
feed sId val = do
|
||||
@ -593,10 +605,10 @@ sinkMultiSubmission userId isUpdate = do
|
||||
when (not $ null ignored) $ do
|
||||
mr <- (toHtml .) <$> getMessageRender
|
||||
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
|
||||
fmap Map.keysSet . lift . sequence $ flip Map.mapWithKey sinks $ \sId sink -> do
|
||||
lift . fmap (bimap Set.fromList (Set.fromList . catMaybes) . unzip) . forM (Map.toList sinks) $ \(sId, sink) -> do
|
||||
cID <- encrypt sId
|
||||
handle (throwM . SubmissionSinkException cID Nothing) $
|
||||
void $ closeResumableSink sink
|
||||
closeResumableSink sink
|
||||
where
|
||||
handleHCError :: Either CryptoFileNameSubmission FilePath -> HandlerContents -> _ (Maybe a)
|
||||
handleHCError ident (HCError NotFound) = Nothing <$ tell (Set.singleton ident)
|
||||
|
||||
113
src/Jobs.hs
113
src/Jobs.hs
@ -8,16 +8,18 @@
|
||||
, DeriveGeneric
|
||||
, DeriveDataTypeable
|
||||
, QuasiQuotes
|
||||
, NamedFieldPuns
|
||||
#-}
|
||||
|
||||
module Jobs
|
||||
( module Jobs.Types
|
||||
, writeJobCtl
|
||||
, queueJob
|
||||
, queueJob, queueJob'
|
||||
, handleJobs
|
||||
) where
|
||||
|
||||
import Import hiding ((.=))
|
||||
import Handler.Utils.Mail
|
||||
|
||||
import Jobs.Types
|
||||
|
||||
@ -37,6 +39,12 @@ import Utils.Lens
|
||||
|
||||
import Control.Monad.Random (evalRand, uniform, mkStdGen)
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Text.Hamlet
|
||||
|
||||
|
||||
data JobQueueException = JInvalid QueuedJobId QueuedJob
|
||||
| JLocked QueuedJobId InstanceId UTCTime
|
||||
@ -77,10 +85,10 @@ handleJobs' wNum = C.mapM_ $ void . handleAny ($logErrorS logIdent . tshow) . ha
|
||||
|
||||
$logDebugS logIdent . LT.toStrict . decodeUtf8 $ Aeson.encode content
|
||||
|
||||
Last jobDone <- execWriterT $ performJob content
|
||||
performJob content
|
||||
|
||||
when (fromMaybe True jobDone) $
|
||||
runDB $ delete jId
|
||||
-- `performJob` is expected to throw a notification if it detects that the job was not done
|
||||
runDB $ delete jId
|
||||
|
||||
jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a
|
||||
jLocked jId act = do
|
||||
@ -112,34 +120,75 @@ writeJobCtl cmd = do
|
||||
chan <- flip evalRand (mkStdGen (hash tid `hashWithSalt` cmd)) . uniform <$> getsYesod appJobCtl
|
||||
liftIO . atomically $ writeTMChan chan cmd
|
||||
|
||||
queueJob :: Job -> YesodDB UniWorX QueuedJobId
|
||||
queueJob job = do
|
||||
jId <- setSerializable $ do
|
||||
now <- liftIO getCurrentTime
|
||||
self <- getsYesod appInstanceID
|
||||
insert QueuedJob
|
||||
{ queuedJobContent = toJSON job
|
||||
, queuedJobCreationInstance = self
|
||||
, queuedJobCreationTime = now
|
||||
, queuedJobLockInstance = Nothing
|
||||
, queuedJobLockTime = Nothing
|
||||
}
|
||||
writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something)
|
||||
return jId
|
||||
queueJobUnsafe :: Job -> YesodDB UniWorX QueuedJobId
|
||||
queueJobUnsafe job = do
|
||||
now <- liftIO getCurrentTime
|
||||
self <- getsYesod appInstanceID
|
||||
insert QueuedJob
|
||||
{ queuedJobContent = toJSON job
|
||||
, queuedJobCreationInstance = self
|
||||
, queuedJobCreationTime = now
|
||||
, queuedJobLockInstance = Nothing
|
||||
, queuedJobLockTime = Nothing
|
||||
}
|
||||
-- We should not immediately notify a worker; instead wait for the transaction to finish first
|
||||
-- writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something)
|
||||
-- return jId
|
||||
|
||||
queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m QueuedJobId
|
||||
queueJob = liftHandlerT . runDB . setSerializable . queueJobUnsafe
|
||||
|
||||
queueJob' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m ()
|
||||
-- ^ `queueJob` followed by `JobCtlPerform`
|
||||
queueJob' job = queueJob job >>= writeJobCtl . JobCtlPerform
|
||||
|
||||
setSerializable :: DB a -> DB a
|
||||
setSerializable act = do
|
||||
transactionSave
|
||||
[executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|]
|
||||
act <* transactionSave
|
||||
setSerializable = ([executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *>)
|
||||
|
||||
performJob :: Job -> WriterT (Last Bool) (HandlerT UniWorX IO) ()
|
||||
performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..}, .. } = do
|
||||
$logDebugS "Jobs" "NotificationSubmissionRated"
|
||||
fail "NotificationSubmissionRated not implemented yet" -- TODO
|
||||
performJob JobSendTestEmail{..} = do
|
||||
$logInfoS "Jobs" $ "Sending test-email to " <> jEmail
|
||||
mailT jLanguages $ do
|
||||
_mailTo .= [Address Nothing jEmail]
|
||||
setSubjectI MsgMailTestSubject
|
||||
addPart $ \(MsgRenderer mr) -> mr MsgMailTestContent
|
||||
performJob :: Job -> HandlerT UniWorX IO ()
|
||||
performJob JobQueueNotification{ jNotification = n@NotificationSubmissionRated{..} } = do
|
||||
jIds <- runDB . setSerializable $ do
|
||||
Submission{submissionSheet} <- getJust nSubmission
|
||||
isGraded <- (/= NotGraded) . sheetType <$> getJust submissionSheet
|
||||
res <- E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do
|
||||
E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
|
||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
|
||||
return (user E.^. UserId, user E.^. UserNotificationSettings)
|
||||
let recipients = do
|
||||
(E.Value uid, E.Value nSettings) <- res
|
||||
guard . notificationAllowed nSettings $ bool NTSubmissionRated NTSubmissionRatedGraded isGraded
|
||||
return uid
|
||||
forM recipients $ queueJobUnsafe . flip JobSendNotification n
|
||||
forM_ jIds $ writeJobCtl . JobCtlPerform
|
||||
performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..}, jRecipient } = userMailT jRecipient $ do
|
||||
(Course{..}, Sheet{..}, Submission{..}) <- liftHandlerT . runDB $ do
|
||||
submission <- getJust nSubmission
|
||||
sheet <- belongsToJust submissionSheet submission
|
||||
course <- belongsToJust sheetCourse sheet
|
||||
return (course, sheet, submission)
|
||||
csId <- encrypt nSubmission
|
||||
setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand
|
||||
|
||||
MsgRenderer mr <- getMailMsgRenderer
|
||||
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
|
||||
|
||||
-- TODO: provide convienience template-haskell for `addAlternatives`
|
||||
addAlternatives $ do
|
||||
provideAlternative $ Aeson.object
|
||||
[ "submission" Aeson..= (ciphertext csId :: UUID)
|
||||
, "submission-rating-points" Aeson..= submissionRatingPoints
|
||||
, "submission-rating-comment" Aeson..= submissionRatingComment
|
||||
, "submission-rating-time" Aeson..= submissionRatingTime
|
||||
, "sheet-name" Aeson..= sheetName
|
||||
, "sheet-type" Aeson..= sheetType
|
||||
, "course-name" Aeson..= courseName
|
||||
, "course-shorthand" Aeson..= courseShorthand
|
||||
, "course-term" Aeson..= courseTerm
|
||||
, "course-school" Aeson..= courseSchool
|
||||
]
|
||||
provideAlternative $ \(MsgRenderer mr) -> ($(textFile "templates/mail/submissionRated.txt") :: TextUrl (Route UniWorX))
|
||||
providePreferredAlternative $ \(MsgRenderer mr) -> ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
performJob JobSendTestEmail{..} = mailT jLanguages $ do
|
||||
_mailTo .= [Address Nothing jEmail]
|
||||
setSubjectI MsgMailTestSubject
|
||||
addPart $ \(MsgRenderer mr) -> mr MsgMailTestContent
|
||||
|
||||
@ -17,6 +17,7 @@ import Data.Aeson.TH (deriveJSON)
|
||||
|
||||
data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
|
||||
| JobSendTestEmail { jEmail :: Text, jLanguages :: MailLanguages }
|
||||
| JobQueueNotification { jNotification :: Notification }
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
|
||||
123
src/Mail.hs
123
src/Mail.hs
@ -13,6 +13,9 @@
|
||||
, ViewPatterns
|
||||
, NamedFieldPuns
|
||||
, MultiWayIf
|
||||
, QuasiQuotes
|
||||
, RankNTypes
|
||||
, ScopedTypeVariables
|
||||
#-}
|
||||
|
||||
module Mail
|
||||
@ -22,6 +25,7 @@ module Mail
|
||||
, MailT, defMailT
|
||||
, MailSmtpData(..), MailLanguages(..)
|
||||
, MonadMail(..)
|
||||
, getMailMessageRender, getMailMsgRenderer
|
||||
-- * YesodMail
|
||||
, VerpMode(..)
|
||||
, YesodMail(..)
|
||||
@ -72,8 +76,10 @@ import qualified Data.Foldable as Foldable
|
||||
import Data.Hashable
|
||||
|
||||
import qualified Data.Text.Lazy as LT
|
||||
import qualified Data.Text.Lazy.Builder as LTB
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
|
||||
import Utils (MsgRendererS(..))
|
||||
import Utils.Lens.TH
|
||||
import Control.Lens
|
||||
|
||||
@ -97,11 +103,14 @@ import Data.Time.Format
|
||||
import Network.HaskellNet.SMTP (SMTPConnection)
|
||||
import qualified Network.HaskellNet.SMTP as SMTP
|
||||
|
||||
import qualified Text.Hamlet as Shakespeare (Translate, Render)
|
||||
import qualified Text.Hamlet as Hamlet (Translate)
|
||||
import qualified Text.Shakespeare as Shakespeare (RenderUrl)
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Encode.Pretty as Aeson
|
||||
import Data.Aeson (Options(..))
|
||||
import Data.Aeson.TH
|
||||
import Utils (MsgRendererS, getMsgRenderer)
|
||||
import Utils (MsgRendererS(..))
|
||||
import Utils.PathPiece (splitCamel)
|
||||
|
||||
|
||||
@ -115,7 +124,7 @@ newtype MailT m a = MailT { unMailT :: RWST MailLanguages MailSmtpData Mail m a
|
||||
, MonadState Mail, MonadWriter MailSmtpData, MonadReader MailLanguages
|
||||
)
|
||||
|
||||
instance (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => MonadCrypto (MailT m) where
|
||||
instance {-# OVERLAPPING #-} (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => MonadCrypto (MailT m) where
|
||||
type MonadCryptoKey (MailT m) = CryptoIDKey
|
||||
cryptoIDKey f = lift (cryptoIDKey return) >>= f
|
||||
|
||||
@ -155,11 +164,19 @@ deriveJSON defaultOptions
|
||||
, sumEncoding = UntaggedValue
|
||||
} ''VerpMode
|
||||
|
||||
getMessageRender :: ( MonadMail m
|
||||
, HandlerSite m ~ site
|
||||
, RenderMessage site msg
|
||||
) => m (msg -> Text)
|
||||
getMessageRender = renderMessage <$> getYesod <*> (mailLanguages <$> askMailLanguages)
|
||||
getMailMessageRender :: ( MonadMail m
|
||||
, HandlerSite m ~ site
|
||||
, RenderMessage site msg
|
||||
) => m (msg -> Text)
|
||||
getMailMessageRender = renderMessage <$> getYesod <*> (mailLanguages <$> askMailLanguages)
|
||||
|
||||
getMailMsgRenderer :: forall site m.
|
||||
( MonadMail m
|
||||
, HandlerSite m ~ site
|
||||
) => m (MsgRendererS site)
|
||||
getMailMsgRenderer = do
|
||||
mr <- getMailMessageRender
|
||||
return $ MsgRenderer (mr . SomeMessage :: RenderMessage site msg => msg -> Text)
|
||||
|
||||
|
||||
data MailException = MailNotAvailable
|
||||
@ -170,7 +187,7 @@ data MailException = MailNotAvailable
|
||||
instance Exception MailException
|
||||
|
||||
|
||||
class YesodMail site where
|
||||
class Yesod site => YesodMail site where
|
||||
defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
|
||||
defaultFromAddress = (Address Nothing . ("yesod@" <>) . pack) <$> liftIO getHostName
|
||||
|
||||
@ -198,6 +215,25 @@ class YesodMail site where
|
||||
) => MailLanguages -> MailT m a -> m a
|
||||
mailT = defMailT
|
||||
|
||||
defaultMailLayout :: ( MonadHandler m
|
||||
, HandlerSite m ~ site
|
||||
) => WidgetT site IO () -> m Html
|
||||
defaultMailLayout wgt = do
|
||||
PageContent{..} <- liftHandlerT $ widgetToPageContent wgt
|
||||
msgs <- getMessages
|
||||
withUrlRenderer [hamlet|
|
||||
$newline never
|
||||
$doctype 5
|
||||
<html>
|
||||
<head>
|
||||
<title>#{pageTitle}
|
||||
^{pageHead}
|
||||
<body>
|
||||
$forall (status, msg) <- msgs
|
||||
<p class="message #{status}">#{msg}
|
||||
^{pageBody}
|
||||
|]
|
||||
|
||||
defMailT :: ( MonadHandler m
|
||||
, YesodMail (HandlerSite m)
|
||||
, MonadBaseControl IO m
|
||||
@ -234,62 +270,81 @@ instance Monoid (PrioritisedAlternatives m) where
|
||||
mempty = memptydefault
|
||||
mappend = mappenddefault
|
||||
|
||||
class ToMailPart site a where
|
||||
toMailPart :: (MonadHandler m, HandlerSite m ~ site) => a -> StateT Part m ()
|
||||
class YesodMail site => ToMailPart site a where
|
||||
type MailPartReturn site a :: *
|
||||
type MailPartReturn site a = ()
|
||||
toMailPart :: (MonadMail m, HandlerSite m ~ site) => a -> StateT Part m (MailPartReturn site a)
|
||||
|
||||
instance ToMailPart site (StateT Part (HandlerT site IO) ()) where
|
||||
instance YesodMail site => ToMailPart site (StateT Part (HandlerT site IO) a) where
|
||||
type MailPartReturn site (StateT Part (HandlerT site IO) a) = a
|
||||
toMailPart = mapStateT liftHandlerT
|
||||
|
||||
instance ToMailPart site LT.Text where
|
||||
instance YesodMail site => ToMailPart site LT.Text where
|
||||
toMailPart text = do
|
||||
_partType .= "text/plain"
|
||||
_partEncoding .= QuotedPrintableText
|
||||
_partContent .= encodeUtf8 text
|
||||
|
||||
instance ToMailPart site Text where
|
||||
instance YesodMail site => ToMailPart site Text where
|
||||
toMailPart = toMailPart . LT.fromStrict
|
||||
|
||||
instance ToMailPart site Html where
|
||||
instance YesodMail site => ToMailPart site LTB.Builder where
|
||||
toMailPart = toMailPart . LTB.toLazyText
|
||||
|
||||
instance YesodMail site => ToMailPart site Html where
|
||||
toMailPart html = do
|
||||
_partType .= "text/html"
|
||||
_partEncoding .= QuotedPrintableText
|
||||
_partContent .= renderMarkup html
|
||||
|
||||
instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site (Shakespeare.Translate msg -> a) where
|
||||
instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site (Hamlet.Translate msg -> a) where
|
||||
type MailPartReturn site (Hamlet.Translate msg -> a) = MailPartReturn site a
|
||||
toMailPart act = do
|
||||
mr <- Yesod.getMessageRender
|
||||
mr <- lift getMailMessageRender
|
||||
toMailPart $ act (toHtml . mr)
|
||||
|
||||
instance (ToMailPart site a, site ~ site') => ToMailPart site (MsgRendererS site' -> a) where
|
||||
type MailPartReturn site (MsgRendererS site' -> a) = MailPartReturn site a
|
||||
toMailPart act = do
|
||||
mr <- getMsgRenderer
|
||||
mr <- lift getMailMsgRenderer
|
||||
toMailPart $ act mr
|
||||
|
||||
instance ToMailPart site a => ToMailPart site (Shakespeare.Render (Route site) -> a) where
|
||||
instance ToMailPart site a => ToMailPart site (Shakespeare.RenderUrl (Route site) -> a) where
|
||||
type MailPartReturn site (Shakespeare.RenderUrl (Route site) -> a) = MailPartReturn site a
|
||||
toMailPart act = do
|
||||
ur <- getUrlRenderParams
|
||||
toMailPart $ act ur
|
||||
|
||||
instance YesodMail site => ToMailPart site Aeson.Value where
|
||||
toMailPart val = do
|
||||
_partType .= "application/json"
|
||||
_partEncoding .= QuotedPrintableText
|
||||
_partContent .= Aeson.encodePretty val
|
||||
|
||||
addAlternatives :: Monad m
|
||||
|
||||
addAlternatives :: (MonadMail m)
|
||||
=> Writer (PrioritisedAlternatives m) ()
|
||||
-> MailT m ()
|
||||
addAlternatives provided = MailT $ do
|
||||
-> m ()
|
||||
addAlternatives provided = do
|
||||
let PrioritisedAlternatives{..} = execWriter provided
|
||||
alternatives <- lift . sequence . Foldable.toList $ maybe id (flip (Seq.|>)) (getLast preferredAlternative) otherAlternatives
|
||||
alternatives <- sequence . Foldable.toList $ maybe id (flip (Seq.|>)) (getLast preferredAlternative) otherAlternatives
|
||||
modify $ Mime.addPart alternatives
|
||||
|
||||
provideAlternative, providePreferredAlternative
|
||||
:: (MonadHandler m, HandlerSite m ~ site, ToMailPart site a)
|
||||
:: (MonadMail m, HandlerSite m ~ site, ToMailPart site a)
|
||||
=> a
|
||||
-> Writer (PrioritisedAlternatives m) ()
|
||||
provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT (toMailPart part) initialPart }
|
||||
providePreferredAlternative part = tell $ mempty { preferredAlternative = Last . Just $ execStateT (toMailPart part) initialPart }
|
||||
|
||||
addPart :: (MonadHandler m, HandlerSite m ~ site, ToMailPart site a) => a -> MailT m ()
|
||||
addPart part = MailT $ do
|
||||
part' <- lift $ execStateT (toMailPart part) initialPart
|
||||
addPart :: ( MonadMail m
|
||||
, HandlerSite m ~ site
|
||||
, ToMailPart site a
|
||||
) => a -> m (MailPartReturn site a)
|
||||
addPart part = do
|
||||
(ret, part') <- runStateT (toMailPart part) initialPart
|
||||
modify . Mime.addPart $ pure part'
|
||||
return ret
|
||||
|
||||
initialPart :: Part
|
||||
initialPart = Part
|
||||
@ -340,13 +395,15 @@ addMailHeaderI :: ( RenderMessage site msg
|
||||
, HandlerSite m ~ site
|
||||
, MonadHeader m
|
||||
) => MailHeader -> msg -> m ()
|
||||
addMailHeaderI header msg = addMailHeader header =<< (getMessageRender <*> pure msg)
|
||||
addMailHeaderI header msg = addMailHeader header =<< (getMailMessageRender <*> pure msg)
|
||||
|
||||
|
||||
setSubjectI :: (RenderMessage site msg, MonadHandler m, HandlerSite m ~ site) => msg -> MailT m ()
|
||||
setSubjectI = replaceMailHeaderI "Subject"
|
||||
|
||||
setMailObjectUUID :: (MonadHandler m, YesodMail (HandlerSite m)) => UUID -> MailT m MailObjectId
|
||||
setMailObjectUUID :: ( MonadHeader m
|
||||
, YesodMail (HandlerSite m)
|
||||
) => UUID -> m MailObjectId
|
||||
setMailObjectUUID uuid = do
|
||||
domain <- mailObjectIdDomain
|
||||
oidHeader <- objectIdHeader
|
||||
@ -354,17 +411,19 @@ setMailObjectUUID uuid = do
|
||||
replaceMailHeader oidHeader . Just $ "<" <> objectId <> ">"
|
||||
return objectId
|
||||
|
||||
setMailObjectId :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m MailObjectId
|
||||
setMailObjectId :: ( MonadHeader m
|
||||
, YesodMail (HandlerSite m)
|
||||
) => m MailObjectId
|
||||
setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom
|
||||
|
||||
setMailObjectId' :: ( MonadHandler m
|
||||
setMailObjectId' :: ( MonadHeader m
|
||||
, YesodMail (HandlerSite m)
|
||||
, MonadCrypto m
|
||||
, HasCryptoUUID plain m
|
||||
, MonadCryptoKey m ~ CryptoIDKey
|
||||
, KnownSymbol (CryptoIDNamespace UUID plain)
|
||||
, Binary plain
|
||||
) => plain -> MailT m MailObjectId
|
||||
) => plain -> m MailObjectId
|
||||
setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid
|
||||
|
||||
|
||||
|
||||
@ -189,6 +189,13 @@ customMigrations = Map.fromListWith (>>)
|
||||
ALTER TABLE "user" ADD COLUMN "authentication" json DEFAULT '"ldap"';
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|]
|
||||
, whenM (tableExists "user") $ do
|
||||
[executeQQ|
|
||||
ALTER TABLE "user" ADD COLUMN "notification_settings" json DEFAULT null;
|
||||
UPDATE "user" SET "notification_settings" = (#{def :: NotificationSettings} :: json) WHERE "notification_settings" is null;
|
||||
|]
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
|
||||
@ -7,10 +7,14 @@
|
||||
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-- # LANGUAGE ExistentialQuantification #-} -- for DA type
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
|
||||
|
||||
module Model.Types where
|
||||
module Model.Types
|
||||
( module Model.Types
|
||||
, module Mail
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Utils
|
||||
@ -26,6 +30,8 @@ import Data.Universe
|
||||
import Data.Universe.Helpers
|
||||
import Data.UUID.Types
|
||||
|
||||
import Data.Default
|
||||
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
import Database.Persist.TH hiding (derivePersistFieldJSON)
|
||||
@ -40,20 +46,29 @@ import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Lens as Text
|
||||
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Data.CaseInsensitive.Instances ()
|
||||
|
||||
import Yesod.Core.Dispatch (PathPiece(..))
|
||||
import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..))
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withText, withObject, Value())
|
||||
import Data.Aeson.Types (toJSONKeyText)
|
||||
import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
|
||||
|
||||
import GHC.Generics (Generic)
|
||||
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
||||
import Data.Typeable (Typeable)
|
||||
|
||||
import Data.Universe.Instances.Reverse ()
|
||||
|
||||
import qualified Yesod.Auth.Util.PasswordStore as PWStore
|
||||
|
||||
import Mail (MailLanguages(..))
|
||||
|
||||
|
||||
instance PathPiece UUID where
|
||||
fromPathPiece = Data.UUID.Types.fromString . unpack
|
||||
@ -332,7 +347,7 @@ instance PathPiece TermIdentifier where
|
||||
toPathPiece = termToText
|
||||
|
||||
instance ToJSON TermIdentifier where
|
||||
toJSON = String . termToText
|
||||
toJSON = Aeson.String . termToText
|
||||
|
||||
instance FromJSON TermIdentifier where
|
||||
parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText
|
||||
@ -443,13 +458,48 @@ derivePersistFieldJSON ''AuthenticationMode
|
||||
derivePersistFieldJSON ''Value
|
||||
|
||||
|
||||
data NotificationSettings = NotificationSettings
|
||||
{
|
||||
} deriving (Eq, Ord, Read, Show)
|
||||
-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
|
||||
--
|
||||
-- Could maybe be replaced with `Structure Notification` in the long term
|
||||
data NotificationTrigger = NTSubmissionRatedGraded
|
||||
| NTSubmissionRated
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
|
||||
instance Universe NotificationTrigger
|
||||
instance Finite NotificationTrigger
|
||||
|
||||
instance Hashable NotificationTrigger
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
||||
} ''NotificationSettings
|
||||
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
||||
} ''NotificationTrigger
|
||||
|
||||
instance ToJSONKey NotificationTrigger where
|
||||
toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t
|
||||
|
||||
instance FromJSONKey NotificationTrigger where
|
||||
fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
|
||||
|
||||
|
||||
newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool }
|
||||
deriving (Generic, Typeable)
|
||||
deriving newtype (Eq, Ord, Read, Show)
|
||||
|
||||
instance Default NotificationSettings where
|
||||
def = NotificationSettings $ \case
|
||||
NTSubmissionRatedGraded -> True
|
||||
NTSubmissionRated -> False
|
||||
|
||||
instance ToJSON NotificationSettings where
|
||||
toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF
|
||||
|
||||
instance FromJSON NotificationSettings where
|
||||
parseJSON = withObject "NotificationSettings" $ \o -> do
|
||||
o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool)
|
||||
return . NotificationSettings $ \n -> case HashMap.lookup n o' of
|
||||
Nothing -> notificationAllowed def n
|
||||
Just b -> b
|
||||
|
||||
derivePersistFieldJSON ''NotificationSettings
|
||||
|
||||
|
||||
@ -457,6 +507,9 @@ instance ToBackendKey SqlBackend record => Hashable (Key record) where
|
||||
hashWithSalt s key = s `hashWithSalt` fromSqlKey key
|
||||
|
||||
|
||||
derivePersistFieldJSON ''MailLanguages
|
||||
|
||||
|
||||
-- Type synonyms
|
||||
|
||||
type Email = Text
|
||||
|
||||
4
templates/mail/submissionRated.hamlet
Normal file
4
templates/mail/submissionRated.hamlet
Normal file
@ -0,0 +1,4 @@
|
||||
<html>
|
||||
<body>
|
||||
<h1>
|
||||
_{MsgMailSubmissionRatedIntro (CI.original courseName) termDesc}
|
||||
1
templates/mail/submissionRated.txt
Normal file
1
templates/mail/submissionRated.txt
Normal file
@ -0,0 +1 @@
|
||||
#{mr (MsgMailSubmissionRatedIntro (CI.original courseName) termDesc)}
|
||||
Loading…
Reference in New Issue
Block a user