chore(letter): generalizing letter sending (WIP)

models/users.model

@@ -15,7 +15,7 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     surname        UserSurname              -- Display user names always through 'nameWidget displayName surname'
     displayName    UserDisplayName
     displayEmail   UserEmail
-    email          UserEmail                -- Case-insensitive eMail address -- TODO: make this nullable
+    email          UserEmail                -- Case-insensitive eMail address, used for sending  TODO: make this nullable
     ident          UserIdent                -- Case-insensitive user-identifier
     authentication AuthenticationMode       -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
     lastAuthentication UTCTime Maybe        -- last login date

src/Handler/PrintCenter.hs

@@ -45,7 +45,7 @@ single :: (k,a) -> Map k a
 single = uncurry Map.singleton
 
 data MetaPinRenewal = MetaPinRenewal
-      { mppRecipient :: Text
+      { mppExaminee :: Text
       , mppAddress   :: StoredMarkup
       , mppLogin     :: Text
       , mppPin       :: Text
@@ -60,7 +60,7 @@ data MetaPinRenewal = MetaPinRenewal
 -- TODO: just for testing, remove in production
 instance Default MetaPinRenewal where
   def = MetaPinRenewal
-          { mppRecipient = "Papa Schlumpf"
+          { mppExaminee = "Papa Schlumpf"
           , mppAddress   = plaintextToStoredMarkup ("Erdbeerweg 42\n98726 Schlumpfhausen"::Text)
           , mppLogin     = "keiner123"
           , mppPin       = "89998a"
@@ -75,7 +75,7 @@ makeRenewalForm :: Maybe MetaPinRenewal -> Form MetaPinRenewal
 makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateMetaPinRenewal $ \html -> do
   now_day <- utctDay <$> liftIO getCurrentTime
   flip (renderAForm FormStandard) html $ MetaPinRenewal
-    <$> areq textField        (fslI MsgMppRecipient)         (mppRecipient <$> tmpl)
+    <$> areq textField        (fslI MsgMppRecipient)         (mppExaminee <$> tmpl)
     <*> areq htmlField        (fslI MsgMppAddress)           (mppAddress   <$> tmpl)
     <*> areq textField        (fslI MsgMppLogin)             (mppLogin     <$> tmpl)
     <*> areq textField        (fslI MsgMppPin)               (mppPin       <$> tmpl)
@@ -93,9 +93,9 @@ validateMetaPinRenewal = do
 
 mprToMeta :: MetaPinRenewal -> P.Meta
 mprToMeta MetaPinRenewal{..} = mkMeta
-  --  formatTimeUser SelFormatDate mppDate mppRecipient
+  --  formatTimeUser SelFormatDate mppDate mppExaminee
-  [ toMeta "recipient"  mppRecipient
+  [ toMeta "examinee"  mppExaminee
-  , toMeta "address"   (mppRecipient : (mppAddress & html2textlines))
+  , toMeta "address"   (mppExaminee : (mppAddress & html2textlines))
   , toMeta "login"      mppLogin
   , toMeta "pin"        mppPin
   , mbMeta "url"       (mppURL  <&> tshow)
@@ -112,7 +112,7 @@ mprToMeta MetaPinRenewal{..} = mkMeta
 mprToMetaUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity User -> MetaPinRenewal -> m P.Meta
 mprToMetaUser entUser@Entity{entityVal = u} mpr = do
   let userLang = userLanguages u >>= (listToMaybe . view _Wrapped) -- auch möglich `op Languages` statt `view _Wrapped`
-      meta = mprToMeta mpr{ mppRecipient = userDisplayName u
+      meta = mprToMeta mpr{ mppExaminee = userDisplayName u
                            -- , mppAddress = userDisplayName u : html2textlines userAddress --TODO once we have User addresses within the DB
                           , mppLang = fromMaybe (mppLang mpr) userLang -- check if this is the desired behaviour!
                           }
@@ -304,7 +304,7 @@ postPrintSendR = do
   let procFormSend mpr = do
         receivers <- runDB $ Ex.select $ do
           user <- Ex.from $ Ex.table @User
-          Ex.where_ $ E.val (mppRecipient mpr) `E.isInfixOf` (user E.^. UserIdent)
+          Ex.where_ $ E.val (mppExaminee mpr) `E.isInfixOf` (user E.^. UserIdent)
           pure user
         letters <- case receivers of
           [] -> pure . (Nothing ,) <$> pdfRenewal (mprToMeta mpr)
@@ -317,7 +317,7 @@ postPrintSendR = do
             -- liftIO $ LBS.writeFile "/tmp/generated.pdf" bs -- DEBUGGING ONLY
             -- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf"
             uID <- maybeAuthId
-            runDB (sendLetter "Test-Brief" bs (mbRecipient, uID) Nothing Nothing Nothing) >>= \case -- calls lpr
+            runDB (sendLetter' "Test-Brief" bs (mbRecipient, uID) Nothing Nothing Nothing) >>= \case -- calls lpr
               Left err -> do
                 let msg = "PDF printing failed with error: " <> err
                 $logErrorS "LPR" msg
@@ -447,4 +447,4 @@ postPrintAckDirectR = do
       let msg = "Error: Only a single file may be uploaded for print job acknowlegement; all ignored."
       $logErrorS "APC" msg
       return (badRequest400, msg)
-  sendResponseStatus status msg -- must be outside of runDB; otherweise transaction is rolled back
+  sendResponseStatus status msg -- must be outside of runDB; otherwise transaction is rolled back

src/Handler/Utils/DateTime.hs

@@ -13,8 +13,9 @@ module Handler.Utils.DateTime
   , formatTime'
   , formatTime, formatTimeUser, formatTimeW, formatTimeMail
   , formatTimeRange, formatTimeRangeW, formatTimeRangeMail
-  , getTimeLocale, getDateTimeFormat
+  , getTimeLocale
-  , getDateTimeFormatter, getDateTimeFormatterUser
+  , getDateTimeFormat   , getDateTimeFormatUser   , getDateTimeFormatUser'
+  , getDateTimeFormatter, getDateTimeFormatterUser, getDateTimeFormatterUser'
   , validDateTimeFormats, dateTimeFormatOptions
   , addLocalDays
   , addDiffDaysClip, addDiffDaysRollOver
@@ -127,6 +128,11 @@ getDateTimeFormatUser sel mUser = do
           SelFormatTime     -> userDefaultTimeFormat
   return fmt
 
+getDateTimeFormatUser' :: SelDateTimeFormat -> User -> DateTimeFormat
+getDateTimeFormatUser' SelFormatDateTime usr = usr & userDateTimeFormat
+getDateTimeFormatUser' SelFormatDate     usr = usr & userDateFormat 
+getDateTimeFormatUser' SelFormatTime     usr = usr & userTimeFormat   
+
 getDateTimeFormatter :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => m DateTimeFormatter
 getDateTimeFormatter = do
   locale <- getTimeLocale
@@ -139,6 +145,13 @@ getDateTimeFormatterUser mUser = do
   formatMap <- traverse (`getDateTimeFormatUser` mUser) id
   return $ mkDateTimeFormatter locale formatMap appTZ
 
+getDateTimeFormatterUser' :: (MonadHandler m) => User -> m DateTimeFormatter
+getDateTimeFormatterUser' usr = do 
+  locale <- getTimeLocale
+  let formatMap = flip getDateTimeFormatUser' usr
+  return $ mkDateTimeFormatter locale formatMap appTZ
+
+
 validDateTimeFormats :: TimeLocale -> SelDateTimeFormat -> Set DateTimeFormat
 -- ^ We use a whitelist instead of just letting the user specify their own format string since vulnerabilities in printf-like functions are not uncommon
 validDateTimeFormats tl SelFormatDateTime = Set.fromList $

src/Handler/Utils/Mail.hs

@@ -5,7 +5,7 @@
 module Handler.Utils.Mail
   ( addRecipientsDB
   , userAddress, userAddressFrom
-  , userMailT
+  , userMailT, userMailTdirect
   , addFileDB
   , addHtmlMarkdownAlternatives
   , addHtmlMarkdownAlternatives'
@@ -50,6 +50,7 @@ userAddress :: User -> Address
 userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userEmail
 
 
+-- |Send an email to the given UserId or to all registered Supervisor with rerouteNotifications == True
 userMailT :: ( MonadHandler m
              , HandlerSite m ~ UniWorX
              , MonadThrow m
@@ -108,13 +109,13 @@ userMailT uid mAct = do
           addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
 
 
-
+-- | like userMailT, but always sends a single mail to the given UserId, ignoring supervisors
-_userMailTdirect :: ( MonadHandler m
+userMailTdirect :: ( MonadHandler m
              , HandlerSite m ~ UniWorX
              , MonadThrow m
              , MonadUnliftIO m
              ) => UserId -> MailT m a -> m a
-_userMailTdirect uid mAct = do
+userMailTdirect uid mAct = do
   user@User
     { userLanguages
     , userDateTimeFormat

src/Handler/Utils/Users.hs

@@ -13,6 +13,7 @@ module Handler.Utils.Users
   , UserAssimilateException(..), UserAssimilateExceptionReason(..)
   , assimilateUser
   , userPrefersEmail, userPrefersLetter
+  , getPostalAddress, getPostalPreferenceAndAddress
   , abbrvName
   , getReceivers
   ) where
@@ -59,17 +60,36 @@ abbrvName User{userDisplayName, userFirstName, userSurname} =
     assemble = Text.intercalate "."
 
 
+-- deprecated, used getPostalAddressIfPreferred
 userPrefersLetter :: User -> Bool
-userPrefersLetter User{..} 
+userPrefersLetter = fst . getPostalPreferenceAndAddress
-  = isJust userPostAddress &&
-    ( userPrefersPostal || 
-      isNothing userPinPassword ||
-      Text.null (CI.original userEmail)
-    )
 
+-- deprecated, used getPostalAddressIfPreferred
 userPrefersEmail :: User -> Bool
 userPrefersEmail = not . userPrefersLetter
 
+-- | result (True, Nothing) indicates that neither userEmail nor userPostAddress is known
+getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text])
+getPostalPreferenceAndAddress usr@User{..} =
+    (((userPrefersPostal || isNothing userPinPassword) && postPossible) || emailImpossible, pa)
+  where 
+    orgEmail        = CI.original userEmail
+    emailImpossible = not ('@' `textElem` orgEmail  &&  '.' `textElem` orgEmail)
+    postPossible    = isJust pa
+    pa = getPostalAddress usr    
+
+getPostalAddress :: User -> Maybe [Text]
+getPostalAddress User{..}
+  | Just pa <- userPostAddress
+    = Just $ userDisplayName : html2textlines pa
+  | Just abt <- userCompanyDepartment
+    = Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"]
+                | otherwise              -> [userDisplayName, abt, "Hausbriefkasten"     ]
+  | otherwise 
+    = Nothing
+
+-- | Return Entity User and all Supervisors with rerouteNotifications as well as 
+--   a boolean indicating if the user is own supervisor with rerouteNotifications
 getReceivers :: UserId -> DB (Entity User, [Entity User], Bool)
 getReceivers uid = do
   underling <- getJustEntity uid

src/Jobs/Handler/SendNotification/Qualification.hs

@@ -98,8 +98,8 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
                   , toMeta "lang"          (selectDeEn userLanguages)    -- select either German or English only, see Utils.Lang
                   , toMeta "login"          lmsIdent
                   , toMeta "pin"            lmsUserPin
-                  , toMeta "recipient"      userDisplayName
+                  , toMeta "examinee"       userDisplayName
-                  , mbMeta "address"       (prepAddress <$> userPostAddress)
+                  , mbMeta "address"       (prepAddress <$> userPostAddress) -- TODO: this is buggy if there is no address set!
                   , toMeta "expiry"         expiryDate
                   , mbMeta "validduration" (show <$> qualificationValidDuration)
                   , toMeta "url-text"       lmsUrl
@@ -126,7 +126,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
   notifyOk <- pdfRenewal pdfMeta >>= \case
     Right pdf | userPrefersLetter recipient ->          -- userPrefersLetter is false if both userEmail and userPostAddress are null
       let printSender  = Nothing
-      in runDB (sendLetter printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification) (Just lmsUserIdent)) >>= \case
+      in runDB (sendLetter' printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification) (Just lmsUserIdent)) >>= \case
         Left err -> do
           let msg = "Notify " <> tshow encRecipient <> ": PDF printing to send letter failed with error " <> cropText err
           $logErrorS "LMS" msg

src/Utils.hs

@@ -275,6 +275,10 @@ addAttrsClass cl attrs = ("class", cl') : noClAttrs
 -- tickmark :: IsString a => a
 -- tickmark = fromString "✔"
 
+-- | Deprecated, replace with Data.Text.elem, once a newer version of Data.Text is available
+textElem :: Char -> Text -> Bool
+textElem c = Text.any (c ==)
+
 -- | remove all whitespace from Text
 -- whereas Text.strip only removes leading and trailing whitespace
 stripAll :: Text -> Text

src/Utils/Print.hs

@@ -6,12 +6,12 @@
 
 module Utils.Print
   ( pdfRenewal
-  , sendLetter   
+  , sendLetter, sendLetter'
   , encryptPDF
   , sanitizeCmdArg, validCmdArgument
   , templateDIN5008
   , templateRenewal
-  -- , compileTemplate, makePDF  
+  -- , compileTemplate, makePDF
   , _Meta, addMeta
   , toMeta, mbMeta                           -- single values
   , mkMeta, appMeta, applyMetas              -- multiple values
@@ -32,10 +32,15 @@ import qualified Text.Pandoc         as P
 import qualified Text.Pandoc.PDF     as P
 import qualified Text.Pandoc.Builder as P
 
+import Text.Hamlet
+
 import System.Exit
 import System.Process.Typed -- for calling pdftk for pdf encryption
 
-import Handler.Utils.Users (abbrvName)
+import Handler.Utils.Users
+import Handler.Utils.DateTime
+import Handler.Utils.Mail
+import Jobs.Handler.SendNotification.Utils
 
 -- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly?
 
@@ -105,14 +110,14 @@ appMeta f (P.Pandoc m bs) = P.Pandoc (f m) bs
 
 -- TODO: applyMetas is inconvenient since we cannot have an instance
 --         ToMetaValue a => ToMetaValue (Maybe a)
---       so apply Metas 
+--       so apply Metas
 
 -- For tests see module PandocSpec
 applyMetas :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, Maybe a) -> p -> p
 applyMetas metas doc = Fold.foldr act doc metas
-  where 
+  where
-    act (_, Nothing) acc = acc 
+    act (_, Nothing) acc = acc
-    act (k, Just v ) acc = P.setMeta k v acc 
+    act (k, Just v ) acc = P.setMeta k v acc
 
 
 -- | Add meta to pandoc. Existing variables will be overwritten.
@@ -151,7 +156,7 @@ defWriterOpts t = def { P.writerExtensions = P.pandocExtensions, P.writerTemplat
 --   An alternative Route would be to use Builders, but this prevents User-edited Markup Templates
 reTemplateLetter :: P.PandocMonad m => P.Meta -> StoredMarkup -> m Text
 reTemplateLetter meta StoredMarkup{..}  = do
-    tmpl <- compileTemplate    strictMarkupInput
+    tmpl <- compileTemplate   strictMarkupInput
     doc <- areader readerOpts strictMarkupInput
     let writerOpts = def { P.writerExtensions = P.pandocExtensions
                          , P.writerTemplate = Just tmpl }
@@ -183,6 +188,18 @@ reTemplateLetter' meta md  = do
                      , P.readerStripComments = True
                      }
 
+mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either P.PandocError Text)
+mdTemplating template meta = runExceptT $ do
+  let readerOpts = def  { P.readerExtensions    = P.pandocExtensions
+                        , P.readerStripComments = True
+                        }
+  doc  <- ExceptT $ $cachedHereBinary ("pandoc: \n"   <> template) (pure . P.runPure $ P.readMarkdown readerOpts template)
+  tmpl <- ExceptT $ $cachedHereBinary ("template: \n" <> template) (pure . P.runPure $ compileTemplate template)
+  let writerOpts = def { P.writerExtensions = P.pandocExtensions
+                       , P.writerTemplate = Just tmpl
+                       }
+  ExceptT . pure . P.runPure $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang
+                                                          $ addMeta meta doc
 
 --pdfDIN5008 :: P.PandocMonad m => Text -> m LBS.ByteString -- for pandoc > 2.18
 pdfDIN5008' :: P.Meta -> Text -> P.PandocIO LBS.ByteString
@@ -263,13 +280,42 @@ pdfRenewal' meta = do
   pdfDIN5008' meta doc
 
 
+-- Generic Version
+pdfLetter :: Text -> P.Meta -> HandlerFor UniWorX (Either Text LBS.ByteString)
+pdfLetter md meta = do
+  e_txt <- mdTemplating md meta
+  result <- actRight e_txt $ pdfDIN5008 meta
+  return $ over _Left P.renderError result
+
 
 ---------------
 -- PrintJobs --
 ---------------
 
-sendLetter :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> Maybe LmsIdent -> DB (Either Text (Text, FilePath))
+data PrintJobIdentification = PrintJobIdentification
-sendLetter printJobName pdf (printJobRecipient, printJobSender) printJobCourse printJobQualification printJobLmsUser = do
+      { pjiName           :: Text
+      , pjiRecipient      :: Maybe UserId
+      , pjiSender         :: Maybe UserId
+      , pjiCourse         :: Maybe CourseId
+      , pjiQualification  :: Maybe QualificationId
+      , pjiLmsUser        :: Maybe LmsIdent
+      }
+  deriving (Eq, Show)
+
+-- DEPRECATED
+sendLetter' :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> Maybe LmsIdent -> DB (Either Text (Text, FilePath))
+sendLetter' printJobName pdf (printJobRecipient, printJobSender) printJobCourse printJobQualification printJobLmsUser =
+  sendLetter pdf PrintJobIdentification
+    { pjiName = printJobName
+    , pjiRecipient = printJobRecipient
+    , pjiSender = printJobSender
+    , pjiCourse = printJobCourse
+    , pjiQualification = printJobQualification
+    , pjiLmsUser = printJobLmsUser
+    }
+
+sendLetter :: LBS.ByteString -> PrintJobIdentification -> DB (Either Text (Text, FilePath))
+sendLetter pdf PrintJobIdentification{pjiName = printJobName, pjiRecipient = printJobRecipient, pjiSender = printJobSender, pjiCourse = printJobCourse, pjiQualification = printJobQualification, pjiLmsUser = printJobLmsUser} = do
   recipient <- join <$> mapM get printJobRecipient
   sender    <- join <$> mapM get printJobSender
   course    <- join <$> mapM get printJobCourse
@@ -278,24 +324,24 @@ sendLetter printJobName pdf (printJobRecipient, printJobSender) printJobCourse p
       nameSender    = abbrvName <$> sender
       nameCourse    = CI.original . courseShorthand        <$> course
       nameQuali     = CI.original . qualificationShorthand <$> quali
-  let jobFullName          = text2asciiAlphaNum $ 
+  let jobFullName          = text2asciiAlphaNum $
-                             T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) 
+                             T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient])
       printJobFilename     = T.unpack $ jobFullName <> ".pdf"
       -- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf   -- for PrintJobFile :: FileContentReference use this code
-      printJobFile = LBS.toStrict pdf  
+      printJobFile = LBS.toStrict pdf
       printJobAcknowledged = Nothing
-  lprPDF jobFullName pdf >>= \case  
+  lprPDF jobFullName pdf >>= \case
-    Left err -> do       
+    Left err -> do
       return $ Left err
-    Right ok -> do      
+    Right ok -> do
       printJobCreated <- liftIO getCurrentTime
       -- updateWhere [PrintJobLmsUser ==. printJobLmsUser] [PrintJobLmsUser =. Nothing] -- only one printJob per LmsUser is allowed, since otherwise the qualification table contains double rows
       insert_ PrintJob {..}
       return $ Right (ok, printJobFilename)
 
 {-
-sendLetter' :: _ -> DB PureFile
+sendLetter'' :: _ -> DB PureFile
-sendLetter' _ = do
+sendLetter'' _ = do
   ...
   return $ File { fileTitle = printJobFilename
                 , fileModified = printJobCreated
@@ -308,47 +354,117 @@ sendLetter' _ = do
 data SomeUserTime where
   SomeUserTime :: HasLocalTime t => SelDateTimeFormat -> t -> SomeUserTime
 
-data ProtoMeta = IsMeta P.MetaValue 
+data ProtoMeta = IsMeta P.MetaValue
-               | IsTime SomeUserTime               
+               | IsTime SomeUserTime
 
 convertProto :: DateTimeFormatter -> ProtoMeta -> P.MetaValue
 convertProto _ (IsMeta v) = v
 convertProto f (IsTime t) = P.toMetaValue $ f t
--} 
+-}
 
-class MDLetter l where   
+class MDLetter l where
-  letterMeta  :: l -> Languages -> DateTimeFormatter -> P.Meta
+  getTemplate :: Proxy l -> Text
-  getTemplate :: Proxy l -> Text -- l -> Text might actually be easier to handle?
+  getSubject  :: Proxy l -> SomeMessage UniWorX
+  letterMeta  :: l -> Lang -> DateTimeFormatter -> P.Meta
+  getPJId     :: l -> PrintJobIdentification  
 
-data LetterRenewQualification = LetterRenewQualification 
+data LetterRenewQualificationF = LetterRenewQualificationF
-    { lmsLogin      :: LmsIdent  
+    { lmsLogin      :: LmsIdent
     , lmsPin        :: Text
+    , qualId        :: QualificationId
+    , qualHolder    :: Text
     , qualExpiry    :: Day
     , qualDuration  :: Maybe Int
     }
   deriving (Eq, Show)
 
-instance MDLetter LetterRenewQualification where
+instance MDLetter LetterRenewQualificationF where
   getTemplate _ = templateRenewal
-  letterMeta LetterRenewQualification{..} _langs DateTimeFormatter{..} = mkMeta
+  getSubject  _ = SomeMessage $ MsgMailSubjectQualificationRenewal "F"
+  letterMeta LetterRenewQualificationF{..} _lang DateTimeFormatter{ format } = mkMeta
       [ toMeta "login"          lmsIdent
       , toMeta "pin"            lmsPin
+      , toMeta "examinee"       qualHolder
       , toMeta "expiry"         (format SelFormatDate qualExpiry)
       , mbMeta "validduration"  (show <$> qualDuration)
       , toMeta "url-text"       lmsUrl
       , toMeta "url"            lmsUrlLogin
       ]
-    where       
+    where
       lmsUrl      = "https://drive.fraport.de"
       lmsUrlLogin = lmsUrl <> "/?login=" <> lmsIdent
       lmsIdent    = getLmsIdent lmsLogin
+  getPJId LetterRenewQualificationF{..} =
+    PrintJobIdentification
+      { pjiName             = "Renewal"
+      , pjiRecipient        = Nothing       -- to be filled later
+      , pjiSender           = Nothing
+      , pjiCourse           = Nothing
+      , pjiQualification    = Just qualId
+      , pjiLmsUser          = Just lmsLogin
+      }
 
-{-
+sendEmailOrLetter :: (MDLetter l) => UserId -> l -> m Bool
--- sendEmailOrLetter :: (MDLetter l) => UserId -> l -> m (?)
+sendEmailOrLetter recipient letter = do
-sendEmailOrLetter recipient letter = do 
+  (underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers recipient
-  (underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid
+  let tmpl = getTemplate $ pure letter
-  forM receivers $ \Entity
+      pjid = getPJId letter
--}
+  now <- liftIO getCurrentTime
+  oks <- forM receivers $ \rcvr@Entity{ entityKey = svr, entityVal = rcvrUsr } -> do
+    formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvrUsr
+    let (preferPost,postal) = getPostalPreferenceAndAddress rcvrUsr
+        -- continue here, since post = Nothing might happen here?!
+        lang  = selectDeEn $ rcvrUsr & userLanguages   -- select either German or English only, default de; see Utils.Lang
+        lMeta = letterMeta letter lang formatter <> mkMeta
+                  [ toMeta "lang"      lang
+                  , toMeta "date"    $ format SelFormatDate now
+                  , toMeta "address" $ fromMaybe (rcvrUsr & userDisplayName) postal
+                  ]
+    pdfLetter tmpl lMeta >>= \case
+      _ | preferPost, isNothing postal -> do -- neither email nor postal is known
+        encRecipient :: CryptoUUIDUser <- encrypt svr
+        let msg = "Notification failed for " <> tshow encRecipient <> ", who has neither a known email nor postal address. Notfication: " <> tshow pjid
+        $logErrorS "LETTER" msg
+        return False
+      Left err -> do -- pdf generation failed
+        encRecipient :: CryptoUUIDUser <- encrypt svr
+        let msg = "Notification failed for " <> tshow encRecipient <> ". PDF generation failed. Notfication: " <> tshow pjid
+        $logErrorS "LETTER" msg
+        return False
+      Right pdf | preferPost -> -- send letter
+        runDB (sendLetter pdf pjid{ pjiRecipient = Just svr}) >>= \case
+          Left err -> do
+            encRecipient :: CryptoUUIDUser <- encrypt svr
+            let msg = "Notification failed for " <> tshow encRecipient <> ". PDF printing failed. The print job could not be sent: " <> cropText err
+            $logErrorS "LETTER" msg
+            return False
+          Right (msg,_)
+            | null msg  -> return True
+            | otherwise -> do
+                $logWarnS "LETTER" $ "PDF printing to send letter with lpr returned ExitSuccess and the following message: " <> msg
+                return True
+      Right pdf -> do -- send email
+        attachment <- case userPinPassword rcvrUsr of
+          Nothing     -> return pdf
+          Just passwd -> encryptPDF passwd pdf >>= \case
+            Right encPdf -> return encPdf
+            Left err -> do 
+              encRecipient :: CryptoUUIDUser <- encrypt svr
+              let msg = "Notification for " <> tshow encRecipient <> " has unencrypted attachment. Encrypting PDF failed: " <> cropText err
+              $logWarnS "LETTER" msg
+              return pdf
+        userMailTdirect svr $ do
+          replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+          setSubjectI $ getSubject $ pure letter 
+          editNotifications <- mkEditNotifications svr
+          -- TODO: create generic template 
+          addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet")
+          addPart (File { fileTitle     = T.unpack $ pjiName pjid
+                        , fileModified  = now
+                        , fileContent   = Just $ yield $ LBS.toStrict attachment
+                        } :: PureFile)
+          return True
+  return $ or oks
 
 
 -----------------------------
@@ -371,10 +487,10 @@ readProcess' pc = do
   return (ec, st_err, st_out)
 
 
-sanitizeCmdArg :: Text -> Text 
+sanitizeCmdArg :: Text -> Text
 sanitizeCmdArg =  T.filter (\c -> c /= '\'' && c /= '"' && c/= '\\' && not (isSeparator c))
 -- | Returns Nothing if ok, otherwise the first mismatching character
---   Pin Password is used as a commandline argument in Utils.Print.encryptPDF and hence poses a security risk 
+--   Pin Password is used as a commandline argument in Utils.Print.encryptPDF and hence poses a security risk
 validCmdArgument :: Text -> Maybe Char
 validCmdArgument t = t `textDiff` sanitizeCmdArg t
 
@@ -418,11 +534,11 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read
 
 -- | Internal only, use `sendLetter` instead
 lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => Text -> LBS.ByteString -> m (Either Text Text)
-lprPDF jb bs = do 
+lprPDF jb bs = do
-    lprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg 
+    lprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg
     let pc = setStdin (byteStringInput bs) $
-              proc "lpr" $ 
+              proc "lpr" $
-                jobname ++                                      -- -J jobname -- a name for job identification at printing site      
+                jobname ++                                      -- -J jobname -- a name for job identification at printing site
                 [ lprServerArg                                  -- -P queue@hostname:port
                 , "-"                                           -- read from stdin
                 ]
@@ -430,15 +546,15 @@ lprPDF jb bs = do
                 | otherwise = ["-J " <> jb']
         jb' = T.unpack $ sanitizeCmdArg jb
     exit2either <$> readProcess' pc
-  where 
+  where
-    getLprServerArg = do 
+    getLprServerArg = do
       LprConf{..} <- getsYesod $ view _appLprConf
       return $ "-P " <> lprQueue <> "@" <> lprHost <> ":" <> show lprPort
 
 
 {- -- Variant without caching
 lprPDF' :: (MonadHandler m, HasAppSettings (HandlerSite m)) => String -> LBS.ByteString -> m (Either Text Text)
-lprPDF' jb bs = do 
+lprPDF' jb bs = do
   LprConf{..} <- getsYesod $ view _appLprConf
   let lprServer = lprQueue <> "@" <> lprHost <> ":" <> show lprPort
       pc =  setStdin (byteStringInput bs) $

templates/letter/fraport_renewal.md

@@ -9,7 +9,7 @@ email: fahrerausbildung@fraport.de
 place: Frankfurt am Main
 return-address: 
  - 60547 Frankfurt
-de-opening: Sehr geehrte Damen und Herren,
+de-opening: Liebe Fahrer,
 en-opening: Dear driver,
 de-closing: |
   Mit freundlichen Grüßen,
@@ -30,7 +30,7 @@ is-de: true
 login: 123456
 pin: abcdef
 # Emfpänger
-recipient: E. M. Pfänger
+examinee: E. M. Pfänger
 address:
  - Musterfirma GmbH
  - E. M. Pfänger
@@ -53,17 +53,21 @@ $endfor$
 $if(is-de)$
 
 <!-- deutsche Version des Briefes  -->
-die Gültigkeit Ihres Vorfeldführerscheins läuft demnächst ab, am $expiry$.
+die Gültigkeit des Vorfeldführerscheins läuft demnächst ab.
-Durch die erfolgreiche Teilnahme an einem E-Learning können Sie die Gültigkeit
+Durch die erfolgreiche Teilnahme an einem E-Learning kann die Gültigkeit
 $if(validduration)$
   um $validduration$ Monate
 $endif$
-verlängern. Verwenden Sie dazu die
+verlängert werden. Dazu bitte die Login-Daten 
-Login-Daten aus dem geschützen Sichtfenster weiter unten.
+aus dem geschützen Sichtfenster weiter unten verwenden.
 
 Prüfling
 
-  : $recipient$
+  : $examinee$
+
+Ablaufdatum
+
+  : $expiry$
 
 URL
 
@@ -71,7 +75,7 @@ URL
 
 
 Sobald die Frist abgelaufen ist, muss zur Wiedererlangung der Fahrberechtigung "F"
-erneut der Grundkurs bei der Fahrerausbildung absolviert werden.
+erneut der komplette Grundkurs bei der Fahrerausbildung absolviert werden.
 
 
 Bei Fragen können Sie sich gerne an das Team der Fahrerausbildung wenden.
@@ -80,8 +84,8 @@ $else$
 
 <!-- englische Version des Briefes  -->
 
-your apron diving license is about to expire soon, on $expiry$.
+the apron diving license is about to expire soon.
-You can extend the validity
+The validity may be extended
 $if(validduration)$
   by $validduration$ months
 $endif$
@@ -90,15 +94,19 @@ an e-learning. Please use the login data from the protected area below.
 
 Examinee
 
-  : $recipient$
+  : $examinee$
+
+Expiry
+
+  : $expiry$
 
 URL
 
   :[$url-text$]($url$)
 
 
-Should your apron driving license expire before completing this 
+Should the apron driving license expire before completing this 
-e-learning course, then a renewal requires your full participation
+e-learning, a later renewal then requires full participation
 of the basic training course again.
 
 

testdata/test_letters.hs

@@ -28,7 +28,7 @@ mdTmpl = "---\nfoo: fooOrg\nbar: barOrg\n---\nHere is some text\n - foo: $foo$\n
 -- Current Function found in Handler.PrintCenter, but is no longer exported!
 mprToMeta :: MetaPinRenewal -> P.Meta
 mprToMeta MetaPinRenewal{..} = P.Meta $ mconcat
-  [ toMeta "recipient"  mppRecipient
+  [ toMeta "examinee"  mppExaminee
   , toMeta "address"   (mppAddress & html2textlines)
   , toMeta "login"      mppLogin
   , toMeta "pin"        mppPin