Working CCommR

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

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

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

src/Handler/Help.hs

@@ -53,8 +53,8 @@ postHelpR = do
     now <- liftIO getCurrentTime
     hfReferer' <- traverse toTextUrl hfReferer
     queueJob' JobHelpRequest
-      { jSender      = hfUserId
+      { jHelpSender  = hfUserId
-      , jHelpSubject = hfSubject
+      , jSubject     = hfSubject
       , jHelpRequest = hfRequest
       , jRequestTime = now
       , jReferer     = hfReferer'

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

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

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
+  user@User
-    { userEmail
+    { userMailLanguages
-    , userDisplayName
-    , 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

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

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

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

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

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)
+sinkDBJobs :: Sink Job (YesodJobDB UniWorX) ()
- => ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a
+-- | 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

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

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
+setMailObjectIdRandom :: ( MonadHeader m
-                   , YesodMail (HandlerSite m)
+                         , YesodMail (HandlerSite m)
-                   ) => m MailObjectId
+                         ) => m MailObjectId
-setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom
+setMailObjectIdRandom = setMailObjectUUID =<< liftIO getRandom
 
-setMailObjectId' :: ( MonadHeader m
+setMailObjectIdCrypto :: ( MonadHeader m
-                    , YesodMail (HandlerSite m)
+                         , YesodMail (HandlerSite m)
-                    , MonadCrypto m
+                         , MonadCrypto m
-                    , HasCryptoUUID plain m
+                         , HasCryptoUUID plain m
-                    , MonadCryptoKey m ~ CryptoIDKey
+                         , MonadCryptoKey m ~ CryptoIDKey
-                    , KnownSymbol (CryptoIDNamespace UUID plain)
+                         , KnownSymbol (CryptoIDNamespace UUID plain)
-                    , Binary plain
+                         , Binary plain
-                    ) => plain -> m MailObjectId
+                         ) => plain -> m MailObjectId
-setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid
+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 ()

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