diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index a809cde7e..569697d3f 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -516,6 +516,8 @@ MailEditNotifications: Benachrichtigungen ein-/ausschalten MailSubjectSupport: Supportanfrage MailSubjectSupportCustom customSubject@Text: [Support] #{customSubject} +CommCourseSubject: Kursmitteilung + SheetGrading: Bewertung SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten @@ -670,6 +672,7 @@ MenuLogin: Login MenuLogout: Logout MenuCourseList: Kurse MenuCourseMembers: Kursteilnehmer +MenuCourseCommunication: Kursmitteilung MenuTermShow: Semester MenuSubmissionDelete: Abgabe löschen MenuUsers: Benutzer @@ -740,7 +743,9 @@ NavigationFavourites: Favoriten CommSubject: Betreff CommBody: Nachricht CommRecipients: Empfänger +CommRecipientsTip: Sie können die Liste von Empfängern beliebig bearbeiten, bevor Sie die Nachricht verschicken. Sie selbst erhalten immer eine Kopie der Nachricht. CommRecipientsSelectBy: Auswahl nach +CommRecipientsSelectByTip: Mögliche Empfänger sind in verschiedene Gruppen unterteilt; sie können sowohl ganze Empfängergruppen als auch einzelne Mitglieder von Empfängergruppen hinzufügen CommDuplicateRecipients n@Int: #{tshow n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert CommSuccess n@Int: Nachricht wurde an #{tshow n} Empfänger versandt @@ -752,3 +757,6 @@ AddRecipientCustom: Weitere Empfänger RGCourseParticipants: Kursteilnehmer RGCourseLecturers: Kursverwalter RGCourseCorrectors: Korrektoren + +MultiSelectFieldTip: Mehrfach-Auswahl ist möglich (Umschalt bzw. Strg) +MultiEmailFieldTip: Je nach Browser sind mehrere komma-separierte E-Mail-Addressen möglich \ No newline at end of file diff --git a/src/Foundation.hs b/src/Foundation.hs index d7b14c2f9..8623fd45a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1172,6 +1172,7 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu", Just $ CourseR tid ssh csh SheetListR) + breadcrumb (CourseR tid ssh csh CCommR ) = return ("Kursmitteilung", Just $ CourseR tid ssh csh CShowR) breadcrumb (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR) breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Edit", Just $ CSheetR tid ssh csh shn SShowR) @@ -1539,6 +1540,14 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemModal = False , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuCourseCommunication + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCommR + , menuItemModal = False + , menuItemAccessCallback' = return True + } , MenuItem { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseEdit @@ -2227,11 +2236,15 @@ instance YesodMail UniWorX where pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool withResource pool act mailT ctx mail = defMailT ctx $ do - void setMailObjectId + void setMailObjectIdRandom setDateCurrent replaceMailHeader "Sender" . Just . addressEmail =<< getsYesod (appMailFrom . appSettings) - mail <* setMailSmtpData + (mRes, smtpData) <- listen mail + unless (view _MailSmtpDataSet smtpData) + setMailSmtpData + + return mRes instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 0a780b9ad..6984e6e57 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -1049,12 +1049,23 @@ postCNotesR = error "CNotesR: Not implemented" getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCCommR = postCCommR postCCommR tid ssh csh = do - cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + jSender <- requireAuthId + cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh commR CommunicationRoute { crHeading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading , crUltDest = SomeRoute $ CourseR tid ssh csh CCommR - , crJob = error "job undefined" + , crJobs = \Communication{..} -> do + let jSubject = cSubject + jMailContent = cBody + jCourse = cid + allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients + jMailObjectUUID <- liftIO getRandom + jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case + Left email -> return . Address Nothing $ CI.original email + Right rid -> userAddress <$> getJust rid + forM_ allRecipients $ \jRecipientEmail -> + yield JobSendCourseCommunication{..} , crRecipients = Map.fromList [ ( RGCourseParticipants , E.from $ \(user `E.InnerJoin` participant) -> do diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs index 788310888..f79d36b92 100644 --- a/src/Handler/Help.hs +++ b/src/Handler/Help.hs @@ -53,8 +53,8 @@ postHelpR = do now <- liftIO getCurrentTime hfReferer' <- traverse toTextUrl hfReferer queueJob' JobHelpRequest - { jSender = hfUserId - , jHelpSubject = hfSubject + { jHelpSender = hfUserId + , jSubject = hfSubject , jHelpRequest = hfRequest , jRequestTime = now , jReferer = hfReferer' diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index abc9d4ed0..88dbccf55 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -1,4 +1,11 @@ -module Handler.Utils.Communication where +module Handler.Utils.Communication + ( RecipientGroup(..) + , CommunicationRoute(..) + , Communication(..) + , commR + -- * Re-Exports + , Job(..) + ) where import Import import Handler.Utils @@ -56,23 +63,32 @@ instance RenderMessage UniWorX RecipientAddOption where data CommunicationRoute = CommunicationRoute { crRecipients :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User))) - , crJob :: Communication -> DB Job + , crJobs :: Communication -> Source (YesodDB UniWorX) Job , crHeading :: SomeMessage UniWorX , crUltDest :: SomeRoute UniWorX } --- `Communication` is defined in `Jobs.Types` + +data Communication = Communication + { cRecipients :: Set (Either UserEmail UserId) + , cSubject :: Maybe Text + , cBody :: Html + } commR :: CommunicationRoute -> Handler Html commR CommunicationRoute{..} = do + uid <- maybeAuthId + MsgRenderer mr <- getMsgRenderer mbCurrentRoute <- getCurrentRoute suggestedRecipients' <- runDB $ traverse E.select crRecipients suggestedRecipients <- forM suggestedRecipients' . mapM $ \ent@(Entity rid _) -> (,) <$> (encrypt rid :: Handler CryptoUUIDUser) <*> pure ent + chosenRecipients <- fmap (maybe id cons uid) $ mapM (decrypt :: CryptoUUIDUser -> Handler UserId) =<< lookupGlobalGetParams GetRecipient + let recipientAForm :: AForm Handler (Set (Either UserEmail UserId)) - recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients) True (Nothing {- TODO -}) + recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just . Map.fromList . zip [0..] $ map ((, ()) . Right) chosenRecipients) where miAdd _ _ nudge submitView = Just $ \csrf -> do let addOptions :: Map RecipientAddOption (AForm Handler (Set (Either UserEmail UserId))) @@ -80,19 +96,20 @@ commR CommunicationRoute{..} = do [ pure ( AddRecipientGroups , Set.unions <$> apreq (multiSelectField . return $ mkOptionList [ Option (mr g) (Set.fromList $ map (Right . entityKey . snd) recs) (toPathPiece g) | (g,recs) <- Map.toList suggestedRecipients ] - ) (fslI AddRecipientGroups & addName (nudge . toPathPiece $ AddRecipientGroups)) Nothing + ) (fslI AddRecipientGroups & addName (nudge . toPathPiece $ AddRecipientGroups) & setTooltip MsgMultiSelectFieldTip) Nothing ) , do - (g,recs) <- Map.toList suggestedRecipients + (g, recs) <- Map.toList suggestedRecipients + guard . not $ null recs return ( AddRecipientGroup g , Set.unions <$> apreq (multiSelectField . return $ mkOptionList [ Option userDisplayName (Set.singleton $ Right rid) (toPathPiece cid) | (cid, Entity rid User{..}) <- recs ] - ) (fslI (AddRecipientGroup g) & addName (nudge . toPathPiece $ AddRecipientGroup g)) Nothing + ) (fslI (AddRecipientGroup g) & addName (nudge . toPathPiece $ AddRecipientGroup g) & setTooltip MsgMultiSelectFieldTip) Nothing ) , pure ( AddRecipientCustom - , Set.fromList . map (Left . CI.mk) <$> apreq multiEmailField (fslI AddRecipientCustom & addName (nudge $ toPathPiece AddRecipientCustom)) Nothing ) + , Set.fromList . map (Left . CI.mk) <$> apreq multiEmailField (fslI AddRecipientCustom & addName (nudge $ toPathPiece AddRecipientCustom) & setTooltip MsgMultiEmailFieldTip) Nothing ) ] - (addRes, addWdgt) <- multiActionM addOptions (fslI MsgCommRecipientsSelectBy & addName (nudge "select")) Nothing csrf + (addRes, addWdgt) <- multiActionM addOptions (fslI MsgCommRecipientsSelectBy & addName (nudge "select") & setTooltip MsgCommRecipientsSelectByTip) Nothing csrf let addRes' = addRes <&> \newSet oldMap -> let freshSet = newSet `Set.difference` Set.fromList (Map.elems oldMap) in FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) (Map.lookupMax oldMap)..] $ Set.toList freshSet @@ -117,7 +134,7 @@ commR CommunicationRoute{..} = do <*> aopt textField (fslI MsgCommSubject) Nothing <*> areq htmlField (fslI MsgCommBody) Nothing formResult commRes $ \comm -> do - runDBJobs $ queueDBJob =<< mapReaderT lift (crJob comm) + runDBJobs . runConduit $ hoist (mapReaderT lift) (crJobs comm) .| sinkDBJobs addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm redirect crUltDest @@ -127,4 +144,6 @@ commR CommunicationRoute{..} = do , formAction = SomeRoute <$> mbCurrentRoute , formEncoding = commEncoding } - siteLayoutMsg crHeading formWdgt + siteLayoutMsg crHeading $ do + setTitleI crHeading + formWdgt diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 61f4b5f1a..c37007add 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -10,7 +10,7 @@ import Handler.Utils.Form.Types import Handler.Utils.DateTime -import Import hiding (cons) +import Import import qualified Data.Char as Char import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 5c35dd4aa..02af114b7 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -1,5 +1,6 @@ module Handler.Utils.Mail ( addRecipientsDB + , userAddress , userMailT , addFileDB ) where @@ -31,22 +32,22 @@ addRecipientsDB uFilter = runConduit $ transPipe (liftHandlerT . runDB) (selectS let addr = Address (Just userDisplayName) $ CI.original userEmail _mailTo %= flip snoc addr +userAddress :: User -> Address +userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userEmail + 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 + user@User + { userMailLanguages , userDateTimeFormat , userDateFormat , userTimeFormat } <- liftHandlerT . runDB $ getJust uid let - addr = Address (Just userDisplayName) $ CI.original userEmail ctx = MailContext { mcLanguages = userMailLanguages , mcDateTimeFormat = \case @@ -55,7 +56,7 @@ userMailT uid mAct = do SelFormatTime -> userTimeFormat } mailT ctx $ do - _mailTo .= pure addr + _mailTo .= pure (userAddress user) mAct addFileDB :: ( MonadMail m @@ -69,4 +70,4 @@ addFileDB fId = do _partEncoding .= Base64 _partFilename .= Just fileName _partContent .= LBS.fromStrict fileContent - setMailObjectId' fId :: StateT Part (HandlerT UniWorX IO) MailObjectId + setMailObjectIdCrypto fId :: StateT Part (HandlerT UniWorX IO) MailObjectId diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 767067ba1..416547c54 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -3,7 +3,7 @@ module Import.NoFoundation , MForm ) where -import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm) +import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons) import Model as Import import Model.Types.JSON as Import import Model.Migration as Import diff --git a/src/Jobs.hs b/src/Jobs.hs index 2a9a42556..5f4895a29 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -58,6 +58,7 @@ import Jobs.Handler.QueueNotification import Jobs.Handler.HelpRequest import Jobs.Handler.SetLogSettings import Jobs.Handler.DistributeCorrections +import Jobs.Handler.SendCourseCommunication data JobQueueException = JInvalid QueuedJobId QueuedJob diff --git a/src/Jobs/Handler/HelpRequest.hs b/src/Jobs/Handler/HelpRequest.hs index 2b92c0e2b..a792b22b6 100644 --- a/src/Jobs/Handler/HelpRequest.hs +++ b/src/Jobs/Handler/HelpRequest.hs @@ -23,13 +23,13 @@ dispatchJobHelpRequest :: Either (Maybe Address) UserId dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer = do supportAddress <- getsYesod $ appMailSupport . appSettings userInfo <- bitraverse return (runDB . getEntity) jSender - let userAddress = either + let senderAddress = either id (fmap $ \(Entity _ User{..}) -> Address (Just userDisplayName) (CI.original userEmail)) userInfo mailT def $ do _mailTo .= [supportAddress] - whenIsJust userAddress (_mailFrom .=) + whenIsJust senderAddress (_mailFrom .=) replaceMailHeader "Auto-Submitted" $ Just "no" setSubjectI $ maybe MsgMailSubjectSupport MsgMailSubjectSupportCustom jHelpSubject setDate jRequestTime diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs new file mode 100644 index 000000000..734612c43 --- /dev/null +++ b/src/Jobs/Handler/SendCourseCommunication.hs @@ -0,0 +1,37 @@ +module Jobs.Handler.SendCourseCommunication + ( dispatchJobSendCourseCommunication + ) where + +import Import + +import Utils.Lens +import Handler.Utils + +import qualified Data.Set as Set + +import qualified Data.CaseInsensitive as CI + + +dispatchJobSendCourseCommunication :: Either UserEmail UserId + -> Set Address + -> CourseId + -> UserId + -> UUID + -> Maybe Text + -> Html + -> Handler () +dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCourse jSender jMailObjectUUID jSubject jMailContent = do + (sender, Course{..}) <- runDB $ (,) + <$> getJust jSender + <*> getJust jCourse + either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do + void $ setMailObjectUUID jMailObjectUUID + _mailFrom .= userAddress sender + if -- Use `addMailHeader` instead of `_mailCc` to make `mailT` ignore the additional recipients + | jRecipientEmail == Right jSender + -> addMailHeader "Cc" . intercalate ", " . map renderAddress $ Set.toAscList (Set.delete (userAddress sender) jAllRecipientAddresses) + | otherwise + -> addMailHeader "Cc" "Undisclosed Recipients:;" + addMailHeader "Auto-Submitted" "no" + setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage jSubject + void $ addPart jMailContent diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs index a9d701ec4..b91a51d1d 100644 --- a/src/Jobs/Queue.hs +++ b/src/Jobs/Queue.hs @@ -2,7 +2,7 @@ module Jobs.Queue ( writeJobCtl, writeJobCtlBlock , queueJob, queueJob' , YesodJobDB - , runDBJobs, queueDBJob + , runDBJobs, queueDBJob, sinkDBJobs , module Jobs.Types ) where @@ -21,6 +21,8 @@ import qualified Data.HashMap.Strict as HashMap import Control.Monad.Random (evalRand, mkStdGen, uniform) +import qualified Data.Conduit.List as C + data JobQueueException = JobQueuePoolEmpty deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) @@ -29,6 +31,10 @@ instance Exception JobQueueException writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m () +-- | Pass an instruction to the `Job`-Workers +-- +-- Instructions are assigned deterministically and pseudo-randomly to one specific worker. +-- While this means that they might be executed later than desireable, rouge threads that queue the same instruction many times do not deny service to others writeJobCtl cmd = do tid <- liftIO myThreadId wMap <- getsYesod appJobCtl >>= liftIO . readTVarIO @@ -39,6 +45,7 @@ writeJobCtl cmd = do liftIO . atomically $ writeTMChan chan cmd writeJobCtlBlock :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> ReaderT JobContext m () +-- | Pass an instruction to the `Job`-Workers and block until it was acted upon writeJobCtlBlock cmd = do getResVar <- asks jobConfirm resVar <- liftIO . atomically $ do @@ -67,19 +74,30 @@ queueJobUnsafe job = do -- return jId queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m QueuedJobId +-- ^ Queue a job for later execution +-- +-- Makes no guarantees as to when it will be executed (`queueJob'`) and does not interact with any running database transactions (`runDBJobs`) queueJob = liftHandlerT . runDB . setSerializable . queueJobUnsafe queueJob' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m () --- ^ `queueJob` followed by `JobCtlPerform` +-- ^ `queueJob` followed by `writeJobCtl` `JobCtlPerform` to ensure, that it is executed asap queueJob' job = queueJob job >>= writeJobCtl . JobCtlPerform +-- | Slightly modified Version of `YesodDB` for `runDBJobs` type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerT site IO)) -queueDBJob :: Job -> ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) () +queueDBJob :: Job -> YesodJobDB UniWorX () +-- | Queue a job as part of a database transaction and execute it after the transaction succeeds queueDBJob job = mapReaderT lift (queueJobUnsafe job) >>= tell . Set.singleton -runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) - => ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a +sinkDBJobs :: Sink Job (YesodJobDB UniWorX) () +-- | Queue many jobs as part of a database transaction and execute them after the transaction passes +sinkDBJobs = C.mapM_ queueDBJob + +runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) => YesodJobDB UniWorX a -> m a +-- | Replacement for/Wrapper around `runDB` when jobs need to be queued as part of a database transaction +-- +-- Jobs get immediately executed if the transaction succeeds runDBJobs act = do (ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act forM_ jIds $ writeJobCtl . JobCtlPerform diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index a7b1c7c27..58fa39e48 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -1,6 +1,5 @@ module Jobs.Types ( Job(..), Notification(..) - , Communication(..) , JobCtl(..) , JobContext(..) ) where @@ -16,14 +15,22 @@ import Data.List.NonEmpty (NonEmpty) data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification } | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext } | JobQueueNotification { jNotification :: Notification } - | JobHelpRequest { jSender :: Either (Maybe Address) UserId + | JobHelpRequest { jHelpSender :: Either (Maybe Address) UserId , jRequestTime :: UTCTime - , jHelpSubject :: Maybe Text + , jSubject :: Maybe Text , jHelpRequest :: Text , jReferer :: Maybe Text } | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings } | JobDistributeCorrections { jSheet :: SheetId } + | JobSendCourseCommunication { jRecipientEmail :: Either UserEmail UserId + , jAllRecipientAddresses :: Set Address + , jCourse :: CourseId + , jSender :: UserId + , jMailObjectUUID :: UUID + , jSubject :: Maybe Text + , jMailContent :: Html + } deriving (Eq, Ord, Show, Read, Generic, Typeable) data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } | NotificationSheetActive { nSheet :: SheetId } @@ -52,19 +59,6 @@ deriveJSON defaultOptions } ''Notification -data Communication = Communication - { cRecipients :: Set (Either UserEmail UserId) - , cSubject :: Maybe Text - , cBody :: Html - } deriving (Eq, Ord, Read, Show, Generic, Typeable) - -instance Hashable Communication - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - } ''Communication - - data JobCtl = JobCtlFlush | JobCtlPerform QueuedJobId | JobCtlDetermineCrontab diff --git a/src/Mail.hs b/src/Mail.hs index 008af9987..68d798336 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -7,7 +7,9 @@ module Mail module Network.Mail.Mime -- * MailT , MailT, defMailT - , MailSmtpData(..), MailContext(..), MailLanguages(..) + , MailSmtpData(..) + , _MailSmtpDataSet + , MailContext(..), MailLanguages(..) , MonadMail(..) , getMailMessageRender, getMailMsgRenderer -- * YesodMail @@ -24,7 +26,8 @@ module Mail , MailObjectId , replaceMailHeader, addMailHeader, removeMailHeader , replaceMailHeaderI, addMailHeaderI - , setSubjectI, setMailObjectId, setMailObjectId' + , setSubjectI + , setMailObjectUUID, setMailObjectIdRandom, setMailObjectIdCrypto, setMailObjectIdPseudorandom , setDate, setDateCurrent , setMailSmtpData , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailHeader, _mailParts @@ -60,18 +63,19 @@ 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 (MsgRendererS(..), MonadSecretBox(..)) import Utils.Lens.TH import Control.Lens hiding (from) +import Control.Lens.Extras (is) import Text.Blaze.Renderer.Utf8 import Data.UUID (UUID) import qualified Data.UUID as UUID -import qualified Data.UUID.V4 as UUID import Data.UUID.Cryptographic.ImplicitNamespace import Data.Binary (Binary) +import qualified Data.Binary as Binary import GHC.TypeLits (KnownSymbol) @@ -104,6 +108,12 @@ import Control.Monad.Trans.Maybe (MaybeT(..)) import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI +import Control.Monad.Random (MonadRandom(..), evalRand, mkStdGen) +import qualified Crypto.Saltine.Class as Saltine (IsEncoding(..)) +import qualified Data.ByteArray as ByteArray (convert) +import Crypto.MAC.HMAC (hmac, HMAC) +import Crypto.Hash.Algorithms (SHAKE128) + makeLenses_ ''Mail makeLenses_ ''Part @@ -131,6 +141,13 @@ instance Monoid (MailSmtpData) where mempty = memptydefault mappend = mappenddefault +_MailSmtpDataSet :: Getter MailSmtpData Bool +_MailSmtpDataSet = to $ \MailSmtpData{..} -> none id + [ is (_Wrapped . _Nothing) smtpEnvelopeFrom + , Set.null smtpRecipients + ] + + newtype MailLanguages = MailLanguages { mailLanguages :: [Lang] } deriving (Eq, Ord, Show, Read, Generic, Typeable) deriving newtype (FromJSON, ToJSON, IsList) @@ -424,20 +441,33 @@ setMailObjectUUID uuid = do replaceMailHeader oidHeader . Just $ "<" <> objectId <> ">" return objectId -setMailObjectId :: ( MonadHeader m - , YesodMail (HandlerSite m) - ) => m MailObjectId -setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom +setMailObjectIdRandom :: ( MonadHeader m + , YesodMail (HandlerSite m) + ) => m MailObjectId +setMailObjectIdRandom = setMailObjectUUID =<< liftIO getRandom -setMailObjectId' :: ( MonadHeader m - , YesodMail (HandlerSite m) - , MonadCrypto m - , HasCryptoUUID plain m - , MonadCryptoKey m ~ CryptoIDKey - , KnownSymbol (CryptoIDNamespace UUID plain) - , Binary plain - ) => plain -> m MailObjectId -setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid +setMailObjectIdCrypto :: ( MonadHeader m + , YesodMail (HandlerSite m) + , MonadCrypto m + , HasCryptoUUID plain m + , MonadCryptoKey m ~ CryptoIDKey + , KnownSymbol (CryptoIDNamespace UUID plain) + , Binary plain + ) => plain -> m MailObjectId +setMailObjectIdCrypto oid = setMailObjectUUID . ciphertext =<< encrypt oid + +setMailObjectIdPseudorandom :: ( MonadHeader m + , YesodMail (HandlerSite m) + , Binary obj + , MonadSecretBox m + ) => obj -> m MailObjectId +-- | Designed to leak no information about the `secretBoxKey` or the given object +setMailObjectIdPseudorandom obj = do + sbKey <- secretBoxKey + let + seed :: HMAC (SHAKE128 64) + seed = hmac (Saltine.encode sbKey) . toStrict $ Binary.encode obj + setMailObjectUUID . evalRand getRandom . mkStdGen $ hash (ByteArray.convert seed :: ByteString) setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m () diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs index 5d5335a98..727dfa04f 100644 --- a/src/Utils/Parameters.hs +++ b/src/Utils/Parameters.hs @@ -1,10 +1,10 @@ module Utils.Parameters ( GlobalGetParam(..) - , lookupGlobalGetParam, hasGlobalGetParam + , lookupGlobalGetParam, hasGlobalGetParam, lookupGlobalGetParams , lookupGlobalGetParamForm, hasGlobalGetParamForm , globalGetParamField , GlobalPostParam(..) - , lookupGlobalPostParam, hasGlobalPostParam + , lookupGlobalPostParam, hasGlobalPostParam, lookupGlobalPostParams , lookupGlobalPostParamForm, hasGlobalPostParamForm , globalPostParamField ) where @@ -33,6 +33,9 @@ lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool hasGlobalGetParam ident = isJust <$> lookupGetParam (toPathPiece ident) +lookupGlobalGetParams :: (MonadHandler m, PathPiece result) => GlobalGetParam -> m [result] +lookupGlobalGetParams ident = mapMaybe fromPathPiece <$> lookupGetParams (toPathPiece ident) + lookupGlobalGetParamForm :: (Monad m, PathPiece result) => GlobalGetParam -> MForm m (Maybe result) lookupGlobalGetParamForm ident = runMaybeT $ do @@ -42,7 +45,7 @@ lookupGlobalGetParamForm ident = runMaybeT $ do hasGlobalGetParamForm :: Monad m => GlobalGetParam -> MForm m Bool hasGlobalGetParamForm ident = maybe False (Map.member $ toPathPiece ident) <$> askParams -globalGetParamField :: Monad m => GlobalPostParam -> Field m a -> MForm m (Maybe a) +globalGetParamField :: Monad m => GlobalGetParam -> Field m a -> MForm m (Maybe a) globalGetParamField ident Field{fieldParse} = runMaybeT $ do ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles @@ -62,7 +65,11 @@ lookupGlobalPostParam ident = (>>= fromPathPiece) <$> lookupPostParam (toPathPie hasGlobalPostParam :: MonadHandler m => GlobalPostParam -> m Bool hasGlobalPostParam ident = isJust <$> lookupPostParam (toPathPiece ident) + +lookupGlobalPostParams :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m [result] +lookupGlobalPostParams ident = mapMaybe fromPathPiece <$> lookupPostParams (toPathPiece ident) + lookupGlobalPostParamForm :: (Monad m, PathPiece result) => GlobalPostParam -> MForm m (Maybe result) lookupGlobalPostParamForm ident = runMaybeT $ do ps <- MaybeT askParams