From 74222dbcc8491e996875c86f2273e0338506f346 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 4 Oct 2018 14:53:36 +0200 Subject: [PATCH] Framework for email-test --- config/settings.yml | 3 + messages/uniworx/de.msg | 9 +++ src/Foundation.hs | 29 +++++++++ src/Handler/Admin.hs | 6 ++ src/Jobs.hs | 10 ++- src/Jobs/Types.hs | 1 + src/Mail.hs | 138 ++++++++++++++++++++++++++++++++++------ src/Model/Types.hs | 4 +- src/Settings.hs | 4 ++ src/Utils/Form.hs | 7 ++ 10 files changed, 188 insertions(+), 23 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 8c34e8265..cd68a3261 100644 --- a/config/settings.yml +++ b/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" diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index c1b8fcca7..d4559a612 100644 --- a/messages/uniworx/de.msg +++ b/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) \ No newline at end of file diff --git a/src/Foundation.hs b/src/Foundation.hs index c8ed085f6..cc238e7ff 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 156961629..619687daa 100644 --- a/src/Handler/Admin.hs +++ b/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 diff --git a/src/Jobs.hs b/src/Jobs.hs index f9681be10..bc18a700a 100644 --- a/src/Jobs.hs +++ b/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 diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 00621ae0a..552d37211 100644 --- a/src/Jobs/Types.hs +++ b/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) diff --git a/src/Mail.hs b/src/Mail.hs index d289f1ac9..2a1388934 100644 --- a/src/Mail.hs +++ b/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 - mailLanguages :: m [Text] +data MailSmtpData = MailSmtpData + { 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 - toMailPart :: a -> State Part () +class ToMailPart site a where + 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 - => StateT Part m () + :: (MonadHandler m, HandlerSite m ~ site, ToMailPart site a) + => a -> Writer (PrioritisedAlternatives m) () -provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT part initialPart } -providePreferredAlternative part = tell $ mempty { preferredAlternative = Last . Just $ execStateT part initialPart } +provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT (toMailPart 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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index cd76390cb..701659dff 100644 --- a/src/Model/Types.hs +++ b/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 diff --git a/src/Settings.hs b/src/Settings.hs index 33de49dcc..2e3ac1eec 100644 --- a/src/Settings.hs +++ b/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 diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 939169e9b..a1c3fd573 100644 --- a/src/Utils/Form.hs +++ b/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