Framework for email-test

config/settings.yml

@@ -12,6 +12,9 @@ mail-from:
   name:         "_env:MAILFROM_NAME:Uni2Work"
   email:        "_env:MAILFROM_EMAIL:uniworx@localhost"
 mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost"
+mail-verp:
+  separator:    "+"
+  at-replacement: "="
 
 detailed-logging:  "_env:DETAILED_LOGGING:false"
 should-log-all:    "_env:LOG_ALL:false"

messages/uniworx/de.msg

@@ -308,3 +308,12 @@ SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.
 
 FieldPrimary: Hauptfach
 FieldSecondary: Nebenfach
+
+MailTestFormEmail: Email-Addresse
+MailTestFormLanguages: Spracheinstellungen
+
+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)

src/Foundation.hs

@@ -59,6 +59,7 @@ import qualified Data.Map as Map
 
 import Data.Monoid (Any(..))
 
+import Data.Pool
 
 import Data.Conduit (($$))
 import Data.Conduit.List (sourceList)
@@ -228,6 +229,15 @@ instance RenderMessage UniWorX Load where
       (Load {byTutorial=Just False, byProportion=p}) -> renderMessage' $ MsgCorByProportionExcludingTutorial p
     where renderMessage' = renderMessage foundation ls
 
+newtype MsgLanguage = MsgLanguage Lang
+  deriving (Eq, Ord, Show, Read)
+instance RenderMessage UniWorX MsgLanguage where
+  renderMessage foundation ls (MsgLanguage lang)
+    | lang == "de-DE" = mr MsgGermanGermany
+    | "de" `isPrefixOf` lang = mr MsgGerman
+    where
+      mr = renderMessage foundation ls
+
 
 instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
   renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)
@@ -248,6 +258,22 @@ getTimeLocale' = $(timeLocaleMap [("de", "de_DE.utf8")])
 appTZ :: TZ
 appTZ = $(includeSystemTZ "Europe/Berlin")
 
+appLanguages :: ( MonadHandler m
+                , HandlerSite m ~ UniWorX
+                ) => m (OptionList Lang)
+-- ^ Authoritive list of supported Languages
+appLanguages = do
+  mr <- getsYesod renderMessage
+  let mkOption l = Option
+        { optionDisplay = mr (l : filter (/= l) (optionInternalValue <$> langOptions)) (MsgLanguage l)
+        , optionInternalValue = l
+        , optionExternalValue = l
+        }
+      langOptions = map mkOption
+        [ "de-DE"
+        ]
+  return $ mkOptionList langOptions
+
 
 -- Access Control
 data AccessPredicate
@@ -1293,6 +1319,9 @@ instance YesodMail UniWorX where
   defaultFromAddress = getsYesod $ appMailFrom . appSettings
   mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings
   mailDateTZ = return appTZ
+  mailSmtp act = do
+    pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
+    withResource pool act
 
 
 instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where

src/Handler/Admin.hs

@@ -41,6 +41,12 @@ instance Button UniWorX CreateButton where
   cssClass CreateInf  = BCPrimary
 -- END Button needed here
 
+emailTestForm :: AForm (HandlerT UniWorX IO) (Email, [Lang])
+emailTestForm = (,)
+            <$> areq emailField (fslI MsgMailTestFormEmail) Nothing
+            <*> areq (reorderField appLanguages) (fslI MsgMailTestFormLanguages) Nothing
+            <*  submitButton
+
 
 getAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
 getAdminTestR = do

src/Jobs.hs

@@ -17,7 +17,7 @@ module Jobs
   , handleJobs
   ) where
 
-import Import
+import Import hiding ((.=))
 
 import Jobs.Types
 
@@ -33,6 +33,8 @@ import Database.Persist.Sql (executeQQ, fromSqlKey)
 import Data.Monoid (Last(..))
 import Control.Monad.Trans.Writer (WriterT(..), execWriterT)
 
+import Utils.Lens
+
   
 data JobQueueException = JInvalid QueuedJobId QueuedJob
                        | JLocked QueuedJobId InstanceId UTCTime
@@ -127,3 +129,9 @@ queueJob job = do
 performJob :: Job -> WriterT (Last Bool) (HandlerT UniWorX IO) ()
 performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..}, .. } = do
   $logDebugS "Jobs" "NotificationSubmissionRated" -- FIXME
+performJob JobSendTestEmail{..} = do
+  $logInfoS "Jobs" $ "Sending test-email to " <> jEmail
+  mailT jLanguages $ do
+    _mailTo .= [Address Nothing jEmail]
+    setSubjectI MsgMailTestSubject
+    addPart (($ MsgMailTestContent) :: (UniWorXMessage -> Text) -> Text) -- FIXME

src/Jobs/Types.hs

@@ -14,6 +14,7 @@ import Data.Aeson.TH (deriveJSON)
 
 
 data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
+         | JobSendTestEmail { jEmail :: Text, jLanguages :: MailLanguages }
   deriving (Eq, Ord, Show, Read)
 data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId, nTimestamp :: UTCTime }
   deriving (Eq, Ord, Show, Read)

src/Mail.hs

@@ -10,6 +10,8 @@
            , RecordWildCards
            , FlexibleContexts
            , TypeFamilies
+           , ViewPatterns
+           , NamedFieldPuns
   #-}
 
 module Mail
@@ -17,9 +19,12 @@ module Mail
     module Network.Mail.Mime
     -- * MailT
   , MailT, mailT
+  , MailSmtpData(..), MailLanguages(..)
   , MonadMail(..)
     -- * YesodMail
+  , VerpMode(..)
   , YesodMail(..)
+  , MailException(..)
     -- * Monadically constructing Mail
   , PrioritisedAlternatives
   , ToMailPart(..)
@@ -37,13 +42,14 @@ module Mail
   ) where
 
 import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender)
+import qualified ClassyPrelude.Yesod as Yesod (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.State (StateT(..), execStateT, State, mapStateT)
 import Control.Monad.Trans.Writer (execWriter, Writer)
 import Control.Monad.RWS.Class (MonadWriter(..), MonadReader(..), MonadState(..), modify)
 import Control.Monad.Fail
@@ -54,9 +60,13 @@ import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 import Data.Sequence (Seq)
 import qualified Data.Sequence as Seq
 
+import Data.Set (Set)
+import qualified Data.Set as Set
+
 import qualified Data.Foldable as Foldable
 
 import qualified Data.Text.Lazy as LT
+import qualified Data.ByteString.Lazy as LBS
 
 import Utils.Lens.TH
 import Control.Lens
@@ -78,32 +88,77 @@ import Data.Time.Zones (TZ, utcTZ, utcToLocalTimeTZ, timeZoneForUTCTime)
 import Data.Time.LocalTime (ZonedTime(..))
 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 Data.Aeson (Options(..))
+import Data.Aeson.TH
+import Utils.PathPiece (splitCamel)
+
 
 makeLenses_ ''Mail
 makeLenses_ ''Part
 
 
-newtype MailT m a = MailT { unMailT :: RWST [Text] () Mail m a }
+newtype MailT m a = MailT { unMailT :: RWST MailLanguages MailSmtpData Mail m a }
   deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus
                    , MonadIO, MonadHandler, MonadCatch, MonadThrow, MonadMask, MonadResource, MonadBase b
-                   , MonadState Mail
+                   , MonadState Mail, MonadWriter MailSmtpData, MonadReader MailLanguages
                    )
 
 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
+data MailSmtpData = MailSmtpData
-  mailLanguages :: m [Text]
+  { smtpEnvelopeFrom :: Last Text
+  , smtpRecipients :: Set Text
+  } deriving (Eq, Ord, Show, Read, Generic)
+
+instance Monoid (MailSmtpData) where
+  mempty = memptydefault
+  mappend = mappenddefault
+
+newtype MailLanguages = MailLanguages { mailLanguages :: [Lang] }
+  deriving (Eq, Ord, Show, Read)
+  deriving newtype (FromJSON, ToJSON)
+
+instance Default MailLanguages where
+  def = MailLanguages []
+
+class (MonadHandler m, MonadState Mail m) => MonadMail m where
+  askMailLanguages :: m MailLanguages
+  tellMailSmtpData :: MailSmtpData -> m ()
 
 instance MonadHandler m => MonadMail (MailT m) where
-  mailLanguages = MailT ask
+  askMailLanguages = ask
+  tellMailSmtpData = tell
+
+data VerpMode = VerpNone
+              | Verp { verpSeparator, verpAtReplacement :: Char }
+  deriving (Eq, Show, Read)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , sumEncoding = UntaggedValue
+  } ''VerpMode
 
 getMessageRender :: ( MonadMail m
                     , HandlerSite m ~ site
                     , RenderMessage site msg
                     ) => m (msg -> Text)
-getMessageRender = renderMessage <$> getYesod <*> mailLanguages 
+getMessageRender = renderMessage <$> getYesod <*> (mailLanguages <$> askMailLanguages)
+
+
+data MailException = MailNotAvailable
+                   | MailNoSenderSpecified
+                   | MailNoRecipientsSpecified
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance Exception MailException
   
 
 class YesodMail site where
@@ -116,14 +171,37 @@ class YesodMail site where
   mailDateTZ :: (MonadHandler m, HandlerSite m ~ site) => m TZ
   mailDateTZ = return utcTZ
 
+  mailSmtp :: ( MonadHandler m
+              , HandlerSite m ~ site
+              , MonadBaseControl IO m
+              ) => (SMTPConnection -> m a) -> m a
+  mailSmtp _ = throwM MailNotAvailable
+
+  mailVERP :: ( MonadHandler m
+              , HandlerSite m ~ site
+              ) => m VerpMode
+  mailVERP = return VerpNone
+
 mailT :: ( MonadHandler m
          , YesodMail (HandlerSite m)
-         ) => [Text] -- ^ Languages in priority order
+         , MonadBaseControl IO m
+         ) => MailLanguages -- ^ Languages in priority order
            -> MailT m a
-           -> m Mail
+           -> m a
 mailT ls (MailT mail) = do
   fromAddress <- defaultFromAddress
-  fst <$> execRWST mail ls (emptyMail fromAddress)
+  (ret, mail, smtpData) <- runRWST mail ls (emptyMail fromAddress)
+  mail' <- liftIO $ LBS.toStrict <$> renderMail' mail
+  ret <$ case smtpData of
+    MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified
+    MailSmtpData{ smtpRecipients }
+      | Set.null smtpRecipients -> throwM MailNoRecipientsSpecified
+    MailSmtpData{ smtpEnvelopeFrom = Last (Just (unpack -> returnPath))
+                , smtpRecipients = (map unpack . toList -> recipients)
+                } -> mailSmtp $ liftIO . SMTP.sendMail
+                       returnPath
+                       recipients
+                       mail'
 
 
 data PrioritisedAlternatives m = PrioritisedAlternatives
@@ -135,24 +213,42 @@ instance Monoid (PrioritisedAlternatives m) where
   mempty = memptydefault
   mappend = mappenddefault
 
-class ToMailPart a where
+class ToMailPart site a where
-  toMailPart :: a -> State Part ()
+  toMailPart :: (MonadHandler m, HandlerSite m ~ site) => a -> StateT Part m ()
 
-instance ToMailPart LT.Text where
+instance ToMailPart site (StateT Part (HandlerT site IO) ()) where
+  toMailPart = mapStateT liftHandlerT
+
+instance ToMailPart site LT.Text where
   toMailPart text = do
     _partType .= "text/plain"
     _partEncoding .= QuotedPrintableText
     _partContent .= encodeUtf8 text
 
-instance ToMailPart Text where
+instance ToMailPart site Text where
   toMailPart = toMailPart . LT.fromStrict
 
-instance ToMailPart Html where
+instance 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
+  toMailPart act = do
+    mr <- Yesod.getMessageRender
+    toMailPart $ act (toHtml . mr)
+
+instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site ((msg -> Text) -> a) where
+  toMailPart act = do
+    mr <- Yesod.getMessageRender
+    toMailPart $ act mr
+
+instance ToMailPart site a => ToMailPart site (Shakespeare.Render (Route site) -> a) where
+  toMailPart act = do
+    ur <- getUrlRenderParams
+    toMailPart $ act ur
+
 
 addAlternatives :: Monad m
                 => Writer (PrioritisedAlternatives m) ()
@@ -163,15 +259,15 @@ addAlternatives provided = MailT $ do
   modify $ Mime.addPart alternatives
 
 provideAlternative, providePreferredAlternative
-  :: Monad m
+  :: (MonadHandler m, HandlerSite m ~ site, ToMailPart site a)
-  => StateT Part m ()
+  => a
   -> Writer (PrioritisedAlternatives m) ()
-provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT part initialPart }
+provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT (toMailPart part) initialPart }
-providePreferredAlternative part = tell $ mempty { preferredAlternative = Last . Just $ execStateT part initialPart }
+providePreferredAlternative part = tell $ mempty { preferredAlternative = Last . Just $ execStateT (toMailPart part) initialPart }
 
-addPart :: Monad m => StateT Part m () -> MailT m ()
+addPart :: (MonadHandler m, HandlerSite m ~ site, ToMailPart site a) => a -> MailT m ()
 addPart part = MailT $ do
-  part' <- lift $ execStateT part initialPart
+  part' <- lift $ execStateT (toMailPart part) initialPart
   modify . Mime.addPart $ pure part'
 
 initialPart :: Part

src/Model/Types.hs

@@ -455,12 +455,14 @@ derivePersistFieldJSON ''NotificationSettings
   
 -- Type synonyms
 
+type Email           = Text
+
 type SchoolName      = CI Text
 type SchoolShorthand = CI Text
 type CourseName      = CI Text
 type CourseShorthand = CI Text
 type SheetName       = CI Text
-type UserEmail       = CI Text
+type UserEmail       = CI Email
 
 type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
 type InstanceId      = UUID

src/Settings.hs

@@ -53,6 +53,8 @@ import qualified Network.Socket as HaskellNet (PortNumber(..), HostName)
 
 import Network.Mail.Mime (Address)
 
+import Mail (VerpMode)
+
 import Model
 
 -- | Runtime settings to configure this application. These settings can be
@@ -79,6 +81,7 @@ data AppSettings = AppSettings
     -- behind a reverse proxy.
     , appMailFrom               :: Address
     , appMailObjectDomain       :: Text
+    , appMailVerp               :: VerpMode
 
     , appDetailedRequestLogging :: Bool
     -- ^ Use detailed request logging system
@@ -259,6 +262,7 @@ instance FromJSON AppSettings where
 
         appMailFrom               <- o .: "mail-from"
         appMailObjectDomain       <- o .: "mail-object-domain"
+        appMailVerp               <- o .: "mail-verp"
 
         appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
         appShouldLogAll           <- o .:? "should-log-all"   .!= defaultDev

src/Utils/Form.hs

@@ -216,3 +216,10 @@ ciField :: ( Textual t
            , RenderMessage (HandlerSite m) FormMessage
            ) => Field m (CI t)
 ciField = convertField (CI.mk . fromList . unpack) (pack . toList . CI.original) textField
+
+reorderField :: ( MonadHandler m
+                , HandlerSite m ~ site
+                , Eq a
+                ) => HandlerT site IO (OptionList a) -> Field m [a] 
+-- ^ Allow the user to enter a /permutation/ of the given options (every option must occur exactly once in the result)
+reorderField = undefined