Working mail test

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

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

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

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 }

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")

templates/adminTest.hamlet

@@ -39,3 +39,6 @@
       ^{modal ".toggler2" (Just "Test Inhalt für Modal")}
       <div .btn.toggler2>Klick mich für Content-Test
         <noscript>(Für Modals bitte JS aktivieren)</noscript>
+    <li>
+      <form method=post action=@{AdminTestR} enctype=#{emailEnctype}>
+        ^{emailWidget}

templates/widgets/permutation.hamlet

@@ -0,0 +1,7 @@
+$newline never
+<ul ##{theId}>
+  $forall (n, selId) <- nums
+    <li>
+      <select ##{selId} name=#{name} :isReq:required *{attrs}>
+        $forall opt <- olOptions
+          <option value=#{withNum (optionExternalValue opt) n} :isSel n opt:selected>#{optionDisplay opt}

templates/widgets/permutation.lucius

@@ -0,0 +1,3 @@
+##{theId} {
+    list-style-type: none;
+}