Monadic construction of mime emails

config/settings.yml

@@ -8,6 +8,10 @@ host:           "_env:HOST:*4" # any IPv4 host
 port:           "_env:PORT:3000"
 ip-from-header: "_env:IP_FROM_HEADER:false"
 approot:        "_env:APPROOT:http://localhost:3000"
+mail-from:
+  name:         "_env:MAILFROM_NAME:Uni2Work"
+  email:        "_env:MAILFROM_EMAIL:uniworx@localhost"
+mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost"
 
 detailed-logging:  "_env:DETAILED_LOGGING:false"
 should-log-all:    "_env:LOG_ALL:false"

package.yaml

@@ -99,6 +99,7 @@ dependencies:
 - HaskellNet-SSL
 - network
 - resource-pool
+- mime-mail
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

src/Foundation.hs

@@ -140,6 +140,7 @@ mkYesodData "UniWorX" $(parseRoutesFile "routes")
 type DB a = YesodDB UniWorX a
 type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
 type MsgRenderer = MsgRendererS UniWorX -- see Utils
+type MailM a = MailT (HandlerT UniWorX IO) a
 
 -- Pattern Synonyms for convenience
 pattern CSheetR tid ssh csh shn ptn
@@ -1288,6 +1289,11 @@ unsafeHandler :: UniWorX -> Handler a -> IO a
 unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 
 
+instance YesodMail UniWorX where
+  defaultFromAddress = getsYesod $ appMailFrom . appSettings
+  mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings
+
+
 instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
   type MonadCryptoKey m = CryptoIDKey
   cryptoIDKey f = getsYesod appCryptoIDKey >>= f

src/Import/NoFoundation.hs

@@ -27,3 +27,5 @@ import Text.Shakespeare.Text  as Import hiding (text, stext)
 import Data.Universe          as Import
 import Data.Pool              as Import (Pool)
 import Network.HaskellNet.SMTP as Import (SMTPConnection)
+
+import Mail                   as Import

src/Jobs.hs

@@ -24,10 +24,15 @@ import Jobs.Types
 import Data.Conduit.TMChan
 import qualified Data.Conduit.List as C
 
+import qualified Data.Text.Lazy as LT
+
 import Data.Aeson (fromJSON, toJSON)
 import qualified Data.Aeson as Aeson
 import Database.Persist.Sql (executeQQ, fromSqlKey)
 
+import Data.Monoid (Last(..))
+import Control.Monad.Trans.Writer (WriterT(..), execWriterT)
+
   
 data JobQueueException = JInvalid QueuedJobId QueuedJob
                        | JLocked QueuedJobId InstanceId UTCTime
@@ -44,26 +49,29 @@ handleJobs :: UniWorX -> IO ()
 -- Handling commands in `HandlerT` provides us with the facilities to render urls, unifies logging, provides a value of the foundation type, ...
 handleJobs foundation@UniWorX{..} = unsafeHandler foundation . bracket_ logStart logStop . runConduit $ sourceTMChan appJobCtl .| handleJobs'
   where
-    logStart = $(logDebugS) "Jobs" "Started"
+    logStart = $logDebugS "Jobs" "Started"
-    logStop = $(logDebugS) "Jobs" "Shutting down"
+    logStop = $logDebugS "Jobs" "Shutting down"
 
 handleJobs' :: Sink JobCtl Handler ()
-handleJobs' = C.mapM_ $ void . handleAny ($(logErrorS) "Jobs" . tshow) . handleCmd
+handleJobs' = C.mapM_ $ void . handleAny ($logErrorS "Jobs" . tshow) . handleCmd
   where
     handleQueueException :: MonadLogger m => JobQueueException -> m ()
-    handleQueueException (JInvalid jId j) = $(logWarnS) "Jobs" $ "Invalid QueuedJob (#" ++ tshow (fromSqlKey jId) ++ "): " ++ tshow j
+    handleQueueException (JInvalid jId j) = $logWarnS "Jobs" $ "Invalid QueuedJob (#" ++ tshow (fromSqlKey jId) ++ "): " ++ tshow j
-    handleQueueException (JNonexistant jId) = $(logInfoS) "Jobs" $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId)
+    handleQueueException (JNonexistant jId) = $logInfoS "Jobs" $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId)
-    handleQueueException (JLocked jId lInstance lTime)  = $(logDebugS) "Jobs" $ "Saw locked QueuedJob: " ++ tshow (fromSqlKey jId, lInstance, lTime)
+    handleQueueException (JLocked jId lInstance lTime)  = $logDebugS "Jobs" $ "Saw locked QueuedJob: " ++ tshow (fromSqlKey jId, lInstance, lTime)
     
-    handleCmd JobCtlFlush = void . fork . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (writeJobCtl . JobCtlPerform)
+    handleCmd JobCtlFlush = void . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (writeJobCtl . JobCtlPerform)
     handleCmd (JobCtlPerform jId) = handle handleQueueException . jLocked jId $ \QueuedJob{..} -> do
       let
         content :: Job
-        Aeson.Success content = fromJSON queuedJobContent
+        Aeson.Success content = fromJSON queuedJobContent -- `jLocked` ensures that `queuedJobContent` parses
       
-      $(logDebugS) "Jobs" $ "Would do: " <> tshow content -- FIXME
+      $logDebugS "Jobs" . LT.toStrict . decodeUtf8 $ Aeson.encode content
 
-      runDB $ delete jId
+      Last jobDone <- execWriterT $ performJob content
+
+      when (fromMaybe False jobDone) $ 
+        runDB $ delete jId
 
 jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a
 jLocked jId act = do
@@ -93,9 +101,7 @@ jLocked jId act = do
                  , QueuedJobLockTime =. Nothing
                  ]
 
-    setSerializable = [executeQQ|
+    setSerializable = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|]
-        SET TRANSACTION ISOLATION LEVEL SERIALIZABLE
-      |]
 
 
 writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m ()
@@ -117,3 +123,7 @@ queueJob job = do
   writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something)
   return jId
 
+
+performJob :: Job -> WriterT (Last Bool) (HandlerT UniWorX IO) ()
+performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..}, .. } = do
+  $logDebugS "Jobs" "NotificationSubmissionRated" -- FIXME

src/Mail.hs

@@ -0,0 +1,244 @@
+{-# LANGUAGE NoImplicitPrelude
+           , GeneralizedNewtypeDeriving
+           , DerivingStrategies
+           , FlexibleInstances
+           , MultiParamTypeClasses
+           , UndecidableInstances
+           , DeriveGeneric
+           , TemplateHaskell
+           , OverloadedStrings
+           , RecordWildCards
+           , FlexibleContexts
+           , TypeFamilies
+  #-}
+
+module Mail
+  ( -- * Structured MIME emails
+    module Network.Mail.Mime
+    -- * MailT
+  , MailT, mailT
+  , MonadMail(..)
+    -- * YesodMail
+  , YesodMail(..)
+    -- * Monadically constructing Mail
+  , MonadState(..)
+  , PrioritisedAlternatives
+  , ToMailPart(..)
+  , addAlternatives, provideAlternative, providePreferredAlternative
+  , addPart
+  , MonadHeader(..)
+  , MailHeader
+  , MailObjectId
+  , replaceMailHeader, addMailHeader, removeMailHeader
+  , replaceMailHeaderI, addMailHeaderI
+  , setSubjectI, setMailObjectId, setMailObjectId'
+  , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts
+  , _partType, _partEncoding, _partFilename, _partHeaders, _partContent
+  ) where
+
+import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender)
+
+import Network.Mail.Mime hiding (addPart, addAttachment)
+import qualified Network.Mail.Mime as Mime (addPart)
+
+import Data.Monoid (Last(..))
+import Control.Monad.Trans.RWS (RWST(..), execRWST)
+import Control.Monad.Trans.State (StateT(..), execStateT, State)
+import Control.Monad.Trans.Writer (execWriter, Writer)
+import Control.Monad.RWS.Class (MonadWriter(..), MonadReader(..), MonadState(..), modify)
+import Control.Monad.Fail
+
+import GHC.Generics (Generic)
+import Generics.Deriving.Monoid (memptydefault, mappenddefault)
+
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
+
+import qualified Data.Foldable as Foldable
+
+import qualified Data.Text.Lazy as LT
+
+import Utils.Lens.TH
+import Control.Lens
+
+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 GHC.TypeLits (KnownSymbol)
+
+import Network.BSD (getHostName)
+
+
+makeLenses_ ''Mail
+makeLenses_ ''Part
+
+
+newtype MailT m a = MailT { unMailT :: RWST [Text] () Mail m a }
+  deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus
+                   , MonadIO, MonadHandler, MonadCatch, MonadThrow, MonadMask, MonadResource, MonadBase b
+                   , MonadState Mail
+                   )
+
+instance (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => MonadCrypto (MailT m) where
+  type MonadCryptoKey (MailT m) = CryptoIDKey
+  cryptoIDKey f = lift (cryptoIDKey return) >>= f
+
+class MonadHandler m => MonadMail m where
+  mailLanguages :: m [Text]
+
+instance MonadHandler m => MonadMail (MailT m) where
+  mailLanguages = MailT ask
+
+getMessageRender :: ( MonadMail m
+                    , HandlerSite m ~ site
+                    , RenderMessage site msg
+                    ) => m (msg -> Text)
+getMessageRender = renderMessage <$> getYesod <*> mailLanguages 
+  
+
+class YesodMail site where
+  defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
+  defaultFromAddress = (Address Nothing . ("yesod@" <>) . pack) <$> liftIO getHostName
+
+  mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text
+  mailObjectIdDomain = pack <$> liftIO getHostName
+
+mailT :: ( MonadHandler m
+         , YesodMail (HandlerSite m)
+         ) => [Text] -- ^ Languages in priority order
+           -> MailT m a
+           -> m Mail
+mailT ls (MailT mail) = do
+  fromAddress <- defaultFromAddress
+  fst <$> execRWST mail ls (emptyMail fromAddress)
+
+
+data PrioritisedAlternatives m = PrioritisedAlternatives
+  { preferredAlternative :: Last (m Part)
+  , otherAlternatives :: Seq (m Part)
+  } deriving (Generic)
+
+instance Monoid (PrioritisedAlternatives m) where
+  mempty = memptydefault
+  mappend = mappenddefault
+
+class ToMailPart a where
+  toMailPart :: a -> State Part ()
+
+instance ToMailPart LT.Text where
+  toMailPart text = do
+    _partType .= "text/plain"
+    _partEncoding .= QuotedPrintableText
+    _partContent .= encodeUtf8 text
+
+instance ToMailPart Text where
+  toMailPart = toMailPart . LT.fromStrict
+
+instance ToMailPart Html where
+  toMailPart html = do
+    _partType .= "text/html"
+    _partEncoding .= QuotedPrintableText
+    _partContent .= renderMarkup html
+
+
+addAlternatives :: Monad m
+                => Writer (PrioritisedAlternatives m) ()
+                -> MailT m ()
+addAlternatives provided = MailT $ do
+  let PrioritisedAlternatives{..} = execWriter provided
+  alternatives <- lift . sequence . Foldable.toList $ maybe id (flip (Seq.|>)) (getLast preferredAlternative) otherAlternatives
+  modify $ Mime.addPart alternatives
+
+provideAlternative, providePreferredAlternative
+  :: Monad m
+  => StateT Part m ()
+  -> Writer (PrioritisedAlternatives m) ()
+provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT part initialPart }
+providePreferredAlternative part = tell $ mempty { preferredAlternative = Last . Just $ execStateT part initialPart }
+
+addPart :: Monad m => StateT Part m () -> MailT m ()
+addPart part = MailT $ do
+  part' <- lift $ execStateT part initialPart
+  modify . Mime.addPart $ pure part'
+
+initialPart :: Part
+initialPart = Part
+  { partType = "text/plain"
+  , partEncoding = None
+  , partFilename = Nothing
+  , partHeaders = []
+  , partContent = mempty
+  }
+
+
+class MonadHandler m => MonadHeader m where
+  modifyHeaders :: (Headers -> Headers) -> m ()
+  objectIdHeader :: m MailHeader
+
+instance MonadHandler m => MonadHeader (MailT m) where
+  modifyHeaders f = MailT . modify $ over _mailHeaders f
+  objectIdHeader = return "Message-ID"
+
+instance MonadHandler m => MonadHeader (StateT Part m) where
+  modifyHeaders f = _partHeaders %= f
+  objectIdHeader = return "Content-ID"
+
+
+type MailHeader = ByteString
+type MailObjectId = Text
+
+
+replaceMailHeader :: MonadHeader m => MailHeader -> Maybe Text -> m ()
+replaceMailHeader header mC = removeMailHeader header >> maybe (return ()) (addMailHeader header) mC
+
+addMailHeader :: MonadHeader m => MailHeader -> Text -> m ()
+addMailHeader header c = modifyHeaders $ \mailHeaders -> mailHeaders `snoc` (header, c)
+
+removeMailHeader :: MonadHeader m => MailHeader -> m ()
+removeMailHeader header = modifyHeaders $ \mailHeaders -> filter ((/= header) . fst) mailHeaders
+
+
+replaceMailHeaderI :: ( RenderMessage site msg
+                      , MonadMail m
+                      , HandlerSite m ~ site
+                      , MonadHeader m
+                      ) => MailHeader -> msg -> m ()
+replaceMailHeaderI header msg = removeMailHeader header >> addMailHeaderI header msg
+  
+addMailHeaderI :: ( RenderMessage site msg
+                  , MonadMail m
+                  , HandlerSite m ~ site
+                  , MonadHeader m
+                  ) => MailHeader -> msg -> m ()
+addMailHeaderI header msg = addMailHeader header =<< (getMessageRender <*> 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 uuid = do
+  domain <- mailObjectIdDomain
+  oidHeader <- objectIdHeader
+  let objectId = UUID.toText uuid <> "@" <> domain
+  replaceMailHeader oidHeader . Just $ "<" <> objectId <> ">"
+  return objectId
+
+setMailObjectId :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m MailObjectId
+setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom
+
+setMailObjectId' :: ( MonadHandler m
+                    , YesodMail (HandlerSite m)
+                    , MonadCrypto m
+                    , HasCryptoUUID plain m
+                    , MonadCryptoKey m ~ CryptoIDKey
+                    , KnownSymbol (CryptoIDNamespace UUID plain)
+                    , Binary plain
+                    ) => plain -> MailT m MailObjectId
+setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid

src/Model/Types.hs

@@ -442,6 +442,16 @@ derivePersistFieldJSON ''AuthenticationMode
 
 derivePersistFieldJSON ''Value
 
+
+data NotificationSettings = NotificationSettings
+  {
+  } deriving (Eq, Ord, Read, Show)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  } ''NotificationSettings
+derivePersistFieldJSON ''NotificationSettings
+
   
 -- Type synonyms
 

src/Settings.hs

@@ -51,6 +51,8 @@ import qualified Data.Char as Char
 import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
 import qualified Network.Socket as HaskellNet (PortNumber(..), HostName)
 
+import Network.Mail.Mime (Address)
+
 import Model
 
 -- | Runtime settings to configure this application. These settings can be
@@ -75,6 +77,8 @@ data AppSettings = AppSettings
     , appIpFromHeader           :: Bool
     -- ^ Get the IP address from the header when logging. Useful when sitting
     -- behind a reverse proxy.
+    , appMailFrom               :: Address
+    , appMailObjectDomain       :: Text
 
     , appDetailedRequestLogging :: Bool
     -- ^ Use detailed request logging system
@@ -225,6 +229,12 @@ deriveFromJSON
     }
   ''SmtpAuthConf
 
+deriveFromJSON
+  defaultOptions
+    { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+    }
+  ''Address
+
 
 
 instance FromJSON AppSettings where
@@ -247,6 +257,9 @@ instance FromJSON AppSettings where
         appPort                   <- o .: "port"
         appIpFromHeader           <- o .: "ip-from-header"
 
+        appMailFrom               <- o .: "mail-from"
+        appMailObjectDomain       <- o .: "mail-object-domain"
+
         appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
         appShouldLogAll           <- o .:? "should-log-all"   .!= defaultDev
         appMinimumLogLevel        <- o .:  "minimum-log-level"

src/index.md

@@ -96,3 +96,13 @@ CryptoID
   
 Model.Migration
   : Manuelle Datenbank-Migration
+
+Jobs
+  : `handleJobs` worker thread handling background jobs
+    `JobQueueException`
+    
+Jobs.Types
+  : `Job`, `Notification`, `JobCtl` Types of Jobs
+
+Mail
+  : Monadically constructing MIME emails