chore(mail): supervisor email reroute working

src/Handler/Utils/Mail.hs

@@ -14,7 +14,7 @@ module Handler.Utils.Mail
 import Import
 import Handler.Utils.Pandoc
 import Handler.Utils.Files
-import Handler.Utils.Widgets (nameHtml')
+import Handler.Utils.Widgets (nameHtml') -- TODO: how to use name widget here?
 
 import qualified Data.CaseInsensitive as CI
 
@@ -22,9 +22,8 @@ import qualified Data.Conduit.Combinators as C
 
 import qualified Text.Pandoc as P
 
-import qualified Text.Hamlet as Hamlet (Translate)
+import qualified Text.Hamlet as Hamlet
 import qualified Text.Shakespeare as Shakespeare (RenderUrl)
-import qualified Text.CI as CI
 
 
 addRecipientsDB :: ( MonadMail m
@@ -56,42 +55,43 @@ userMailT :: ( MonadHandler m
              , MonadUnliftIO m
              ) => UserId -> MailT m () -> m ()
 userMailT uid mAct = do
-  -- now <- liftIO getCurrentTime
-  underling <- liftHandler . runDB $ getJust uid
-  superVs <- liftHandler . runDB $ selectList [UserSupervisorUser ==. uid, UserSupervisorRerouteNotifications ==. True] []
-  let receivers = if null superVs
-                    then [uid]
-                    else userSupervisorSupervisor . entityVal <$> superVs
-      undercopy = uid `elem` receivers
+  (underling, receivers) <- liftHandler . runDB $ do 
+    underling <- getJustEntity uid
+    superVs <- selectList [UserSupervisorUser ==. uid, UserSupervisorRerouteNotifications ==. True] []
+    let superIds = userSupervisorSupervisor . entityVal <$> superVs
+    supers <- if null superIds then pure [underling] else selectList [UserId <-. superIds] []    
+    return (underling, if null supers then [underling] else supers)
+  let undercopy = uid `elem` (entityKey <$> receivers)
       undername = underling ^. _userDisplayName -- nameHtml' underling
       undermail = CI.original $ underling ^. _userEmail
-      infoSupervised = \(MsgRenderer mr) -> [shamlet|
-            <h2>#{mr MsgMailSupervisedNote}
+      infoSupervised :: Hamlet.HtmlUrlI18n UniWorXSendMessage (Route UniWorX) = [ihamlet|
+            <h2>_{MsgMailSupervisedNote}
             <p>
-              #{mr MsgMailSupervisedBody}
+              _{MsgMailSupervisedBody}
               <ul>
-                $forall svr <- superVs
+                $forall svr <- receivers
                   <li>
                     #{nameHtml' svr}
           |]
-  forM_ receivers $ \svr -> do
-    supervisor@User
-      { userLanguages
-      , userDateTimeFormat
-      , userDateFormat
-      , userTimeFormat
-      , userCsvOptions
-      } <- liftHandler . runDB $ getJust svr
+  forM_ receivers $ \Entity
+      { entityKey = svr
+      , entityVal = supervisor@User{ userLanguages
+                                 , userDateTimeFormat
+                                 , userDateFormat
+                                 , userTimeFormat
+                                 , userCsvOptions
+                                 } 
+      } -> do
     let ctx = MailContext
                 { mcLanguages = fromMaybe def userLanguages
                 , mcDateTimeFormat = \case
                     SelFormatDateTime -> userDateTimeFormat
-                    SelFormatDate -> userDateFormat
-                    SelFormatTime -> userTimeFormat
+                    SelFormatDate     -> userDateFormat
+                    SelFormatTime     -> userTimeFormat
                 , mcCsvOptions = userCsvOptions
                 }
         supername = supervisor ^. _userDisplayName -- nameHtml' supervisor
-        infoSupervisor =  [ihamlet|
+        infoSupervisor :: Hamlet.HtmlUrlI18n UniWorXSendMessage (Route UniWorX) = [ihamlet|
             <h2>_{MsgMailSupervisorNote}
             <p>
               _{MsgMailSupervisorBody undername supername} #

src/Jobs/Handler/SendTestEmail.hs

@@ -36,10 +36,9 @@ dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMail
   addHtmlMarkdownAlternatives' "part2" $ \(MsgRenderer _mr) -> [shamlet|
     <h2>Second part, just for testing
     <p>
-      Please ignore this part of the message send by 
-        <a href=@{NewsR}>
-          FRADrive
+      Please ignore this part of the message.
     |]
+  -- Compiles as well: let trdmsg :: HtmlUrlI18n _ (Route UniWorX) = [ihamlet|
   let trdmsg :: HtmlUrlI18n UniWorXJobsHandlerMessage (Route UniWorX) = [ihamlet|
     <h2>Third part, again only for tests
     <p>
@@ -48,6 +47,10 @@ dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMail
         <li>#{nDT}
         <li>#{nD}
         <li>#{nT}
+    <p>
+      Message was sent to you by
+        <a href=@{NewsR}>
+          FRADrive
     |]
   addHtmlMarkdownAlternatives' "part3" trdmsg
   -- let test = $(i18nHamletFile "test")