From 1beeea5aa6a0c4c733b10f13b1aba8dec21f9275 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 4 Oct 2018 19:48:07 +0200 Subject: [PATCH] Working mail test --- src/Foundation.hs | 9 +++++++ src/Handler/Admin.hs | 33 +++++++++++++++---------- src/Jobs.hs | 9 +++---- src/Mail.hs | 36 ++++++++++++++++++++++++++-- src/Utils/Form.hs | 36 +++++++++++++++++++++++++++- templates/adminTest.hamlet | 3 +++ templates/widgets/permutation.hamlet | 7 ++++++ templates/widgets/permutation.lucius | 3 +++ 8 files changed, 117 insertions(+), 19 deletions(-) create mode 100644 templates/widgets/permutation.hamlet create mode 100644 templates/widgets/permutation.lucius diff --git a/src/Foundation.hs b/src/Foundation.hs index cc238e7ff..f9b9e8825 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1318,10 +1318,19 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger instance YesodMail UniWorX where defaultFromAddress = getsYesod $ appMailFrom . appSettings mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings + mailVerp = getsYesod $ appMailVerp . appSettings mailDateTZ = return appTZ mailSmtp act = do pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool withResource pool act + defaultMailAction ls mail = mailT ls $ do + setMailObjectId + setDateCurrent + + ret <- mail + + setMailSmtpData + return ret instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 619687daa..f73d95348 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -12,6 +12,7 @@ module Handler.Admin where import Import import Handler.Utils +import Jobs -- import Data.Time -- import qualified Data.Text as T @@ -20,6 +21,8 @@ import Handler.Utils import Web.PathPieces (showToPathPiece, readFromPathPiece) +import Database.Persist.Sql (fromSqlKey) + -- import Colonnade hiding (fromMaybe) -- import Yesod.Colonnade @@ -41,28 +44,34 @@ instance Button UniWorX CreateButton where cssClass CreateInf = BCPrimary -- END Button needed here -emailTestForm :: AForm (HandlerT UniWorX IO) (Email, [Lang]) +emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailLanguages) emailTestForm = (,) <$> areq emailField (fslI MsgMailTestFormEmail) Nothing - <*> areq (reorderField appLanguages) (fslI MsgMailTestFormLanguages) Nothing + <*> (MailLanguages <$> areq (reorderField appLanguages) (fslI MsgMailTestFormLanguages) Nothing) <* submitButton -getAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden! -getAdminTestR = do - (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form CreateButton) - defaultLayout $ do - -- setTitle "Uni2work Admin Testpage" - $(widgetFile "adminTest") - -postAdminTestR :: Handler Html +getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden! +getAdminTestR = postAdminTestR postAdminTestR = do - ((btnResult,_), _) <- runFormPost $ buttonForm + ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form CreateButton) case btnResult of (FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt" (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt" + FormMissing -> return () _other -> addMessage Warning "KEIN Knopf erkannt" - getAdminTestR + + ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm "email" $ renderAForm FormStandard emailTestForm + case emailResult of + (FormSuccess (email, ls)) -> runDB $ do + (fromSqlKey -> jId) <- queueJob $ JobSendTestEmail email ls + addMessage Success [shamlet|Email-test gestartet (Job ##{tshow jId})|] + FormMissing -> return () + (FormFailure errs) -> forM_ errs $ addMessage Error . toHtml + + defaultLayout $ do + -- setTitle "Uni2work Admin Testpage" + $(widgetFile "adminTest") getAdminUserR :: CryptoUUIDUser -> Handler Html diff --git a/src/Jobs.hs b/src/Jobs.hs index bc18a700a..bba0261d4 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -103,9 +103,6 @@ jLocked jId act = do , QueuedJobLockTime =. Nothing ] - setSerializable = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] - - writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m () writeJobCtl cmd = do chan <- getsYesod appJobCtl @@ -113,6 +110,7 @@ writeJobCtl cmd = do queueJob :: Job -> YesodDB UniWorX QueuedJobId queueJob job = do + setSerializable now <- liftIO getCurrentTime self <- getsYesod appInstanceID jId <- insert QueuedJob @@ -125,13 +123,16 @@ queueJob job = do writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something) return jId +setSerializable :: DB () +setSerializable = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] + 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 + defaultMailAction jLanguages $ do _mailTo .= [Address Nothing jEmail] setSubjectI MsgMailTestSubject addPart (($ MsgMailTestContent) :: (UniWorXMessage -> Text) -> Text) -- FIXME diff --git a/src/Mail.hs b/src/Mail.hs index 2a1388934..b618061ec 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -12,6 +12,7 @@ , TypeFamilies , ViewPatterns , NamedFieldPuns + , MultiWayIf #-} module Mail @@ -37,6 +38,7 @@ module Mail , replaceMailHeaderI, addMailHeaderI , setSubjectI, setMailObjectId, setMailObjectId' , setDateCurrent + , setMailSmtpData , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts , _partType, _partEncoding, _partFilename, _partHeaders, _partContent ) where @@ -63,6 +65,8 @@ import qualified Data.Sequence as Seq import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.Text as Text + import qualified Data.Foldable as Foldable import qualified Data.Text.Lazy as LT @@ -177,10 +181,16 @@ class YesodMail site where ) => (SMTPConnection -> m a) -> m a mailSmtp _ = throwM MailNotAvailable - mailVERP :: ( MonadHandler m + mailVerp :: ( MonadHandler m , HandlerSite m ~ site ) => m VerpMode - mailVERP = return VerpNone + mailVerp = return VerpNone + + defaultMailAction :: ( MonadHandler m + , HandlerSite m ~ site + , MonadBaseControl IO m + ) => MailLanguages -> MailT m a -> m a + defaultMailAction = mailT mailT :: ( MonadHandler m , YesodMail (HandlerSite m) @@ -353,3 +363,25 @@ setDateCurrent = do tz <- mailDateTZ let timeStr = formatTime defaultTimeLocale "%a, %d %b %Y %T %z" $ ZonedTime (utcToLocalTimeTZ tz now) (timeZoneForUTCTime tz now) replaceMailHeader "Date" . Just $ pack timeStr + + +setMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m () +setMailSmtpData = do + Address _ from <- use _mailFrom + recps <- Set.fromList . map addressEmail . concat <$> forM [_mailTo, _mailCc, _mailBcc] use + + tell $ mempty { smtpRecipients = recps } + + verpMode <- mailVerp + if + | Verp{..} <- verpMode + , [recp] <- Set.toList recps + -> let doVerp (Text.breakOn "@" -> (user, domain)) recp = mconcat + [ user + , Text.singleton verpSeparator + , Text.replace "@" (Text.singleton verpAtReplacement) recp + , domain + ] + in tell $ mempty { smtpEnvelopeFrom = Last . Just $ doVerp from recp } + | otherwise + -> tell $ mempty { smtpEnvelopeFrom = Last $ Just from } diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index a1c3fd573..ed359d3cf 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -9,6 +9,8 @@ , FlexibleContexts , NamedFieldPuns , ScopedTypeVariables + , MultiWayIf + , RecordWildCards #-} module Utils.Form where @@ -23,6 +25,12 @@ import qualified Data.Char as Char import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI +import Data.Map.Lazy ((!)) +import qualified Data.Map.Lazy as Map +import qualified Data.Set as Set + +import Data.List ((!!)) + import Web.PathPieces ------------------- @@ -220,6 +228,32 @@ ciField = convertField (CI.mk . fromList . unpack) (pack . toList . CI.original) reorderField :: ( MonadHandler m , HandlerSite m ~ site , Eq a + , Show 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 +reorderField optList = Field{..} + where + fieldEnctype = UrlEncoded + fieldParse [] _ = return $ Right Nothing + fieldParse optlist _ = do + OptionList{..} <- liftHandlerT optList + let + olNum = fromIntegral $ length olOptions + selOptions = traceShowId . Map.fromList $ do + i <- [1..olNum] + (readMay -> Just (n :: Word), ('.' : extVal)) <- break (== '.') . unpack <$> optlist + guard $ i == n + Just val <- return . olReadExternal $ pack extVal + return (i, val) + return $ if + | Map.keysSet selOptions == Set.fromList [1..olNum] + -> Right . Just $ map (selOptions !) [1..fromIntegral olNum] + | otherwise + -> Left "Not a valid permutation" + fieldView theId name attrs val isReq = do + OptionList{..} <- liftHandlerT optList + let + isSel n = (==) (either (const $ map optionInternalValue olOptions) id val !! pred n) . optionInternalValue + nums = map (id &&& withNum theId) [1..length olOptions] + withNum t n = tshow n <> "." <> t + $(widgetFile "widgets/permutation") diff --git a/templates/adminTest.hamlet b/templates/adminTest.hamlet index ea27a3906..5b9947314 100644 --- a/templates/adminTest.hamlet +++ b/templates/adminTest.hamlet @@ -39,3 +39,6 @@ ^{modal ".toggler2" (Just "Test Inhalt für Modal")}
Klick mich für Content-Test +
  • +
    + ^{emailWidget} diff --git a/templates/widgets/permutation.hamlet b/templates/widgets/permutation.hamlet new file mode 100644 index 000000000..ac5ee008a --- /dev/null +++ b/templates/widgets/permutation.hamlet @@ -0,0 +1,7 @@ +$newline never +
      + $forall (n, selId) <- nums +
    • +