Framework for email-test
This commit is contained in:
Gregor Kleen
parent
7553182cf9
commit
74222dbcc8
@ -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"
|
||||
|
||||
@ -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)
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
10
src/Jobs.hs
10
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
|
||||
|
||||
@ -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)
|
||||
|
||||
138
src/Mail.hs
138
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user