chore(letter): sending of multiple user letter with proper language interpolation

messages/uniworx/categories/print/de-de-formal.msg

@@ -9,3 +9,4 @@ PrintSender !ident-ok: Sender
 PrintCourse: Kurse
 PrintQualification: Qualifikation
 PrintPDF !ident-ok: PDF
+PrintManualRenewal: Vorfeldführerschein Renewal-Brief testweise versenden

messages/uniworx/categories/print/en-eu.msg

@@ -9,3 +9,4 @@ PrintSender: Sender
 PrintCourse: Course
 PrintQualification: Qualification
 PrintPDF: PDF
+PrintManualRenewal: Manual sending of an apron driving licence renewal letter

src/Handler/PrintCenter.hs

@@ -1,11 +1,9 @@
-{-# OPTIONS -Wno-unused-top-binds #-}      -- TODO: remove me, for debugging only
+{-# LANGUAGE TypeApplications #-}
 
 module Handler.PrintCenter
   ( getPrintCenterR, postPrintCenterR
   , getPrintSendR  , postPrintSendR
   , getPrintDownloadR
-  -- TODO: for testing only, remove exports
-  , mprToMeta
   ) where
 
 import Import
@@ -20,6 +18,7 @@ import qualified Text.Pandoc          as P
 import qualified Text.Pandoc.Builder  as P
 
 import Database.Persist.Sql (updateWhereCount)
+import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
 import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
@@ -55,11 +54,11 @@ instance Default MetaPinRenewal where
           { mppRecipient = "Papa Schlumpf"
           , mppAddress   = plaintextToStoredMarkup ("Erdbeerweg 42\n98726 Schlumpfhausen"::Text)
           , mppLogin     = "keiner123"
-          , mppPin       = "898989"
+          , mppPin       = "89998a"
           , mppURL       = Nothing
           , mppDate      = fromGregorian 2022 07 27
           , mppLang      = "de-de"
-          , mppOpening   = Just "Lieber $recipient$ Schlumpfi,"
+          , mppOpening   = Just "Lieber Schlumpfi,"
           , mppClosing   = Nothing
           }
 
@@ -82,8 +81,12 @@ validateMetaPinRenewal = do
   MetaPinRenewal{..} <- State.get
   guardValidation MsgMppBadLanguage $ isDe mppLang || isEn mppLang
 
+
+-- TODO: formatTimeUser SelFormatDate now (Entity <$> printJobRecipient recipient)
+
 mprToMeta :: MetaPinRenewal -> P.Meta
 mprToMeta MetaPinRenewal{..} = P.Meta $ mconcat
+  --  formatTimeUser SelFormatDate mppDate mppRecipient
   [ toMeta "recipient"  mppRecipient
   , toMeta "address"   (mppAddress & html2textlines)
   , toMeta "login"      mppLogin
@@ -106,6 +109,7 @@ mprToMeta MetaPinRenewal{..} = P.Meta $ mconcat
     html2textlines sm = T.lines . LT.toStrict $ markupInput sm
 
 
+
 data PJTableAction = PJActAcknowledge
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
@@ -189,11 +193,11 @@ mkPJTable = do
     dbtProj = dbtProjFilteredPostId
     dbtColonnade = mconcat
       [ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged)
-      , sortable (Just "pj-name")         (i18nCell MsgPrintJobName)          $ \(   view $ resultPrintJob . _entityVal . _printJobName         -> n) -> textCell n
+      , sortable (Just "pj-created")      (i18nCell MsgPrintJobCreated)       $ \(   view $ resultPrintJob . _entityVal . _printJobCreated      -> t) ->      dateTimeCell t
       , sortable (toNothingS "pdf")       (i18nCell MsgPrintPDF)              $ \(   view $ resultPrintJob . _entityKey -> k) -> anchorCellM (PrintDownloadR <$> encrypt k)  (showId k)
       -- , sortable (Just "pj-id")           (i18nCell MsgPrintJobId)            $ \(   view $ resultPrintJob . _entityKey                         -> k) -> textCell (tshow . E.unSqlBackendKey $ unPrintJobKey k)
       -- , sortable (Just "pj-id")           (i18nCell MsgPrintJobId)            $ \(   view $ resultPrintJob . _entityKey                         -> k) -> cell (showId k)
-      , sortable (Just "pj-created")      (i18nCell MsgPrintJobCreated)       $ \(   view $ resultPrintJob . _entityVal . _printJobCreated      -> t) ->      dateTimeCell t
+      , sortable (Just "pj-name")         (i18nCell MsgPrintJobName)          $ \(   view $ resultPrintJob . _entityVal . _printJobName         -> n) -> textCell n
       , sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged)  $ \(   view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t
       , sortable (Just "pj-recipient")    (i18nCell MsgPrintRecipient)        $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
       , sortable (Just "pj-sender")       (i18nCell MsgPrintSender)           $ \(preview resultSender    -> u) -> maybeCell u $ cellHasUserLink AdminUserR
@@ -211,14 +215,20 @@ mkPJTable = do
       , single ("pj-qualification", SortColumn $ queryQualification >>> (E.?. QualificationName))
       ]
     dbtFilter = mconcat
-      [ single ("pj-name"        , FilterColumn . E.mkContainsFilter  $ views (to queryPrintJob) (E.^. PrintJobName))
+      [ single ("pj-name"         , FilterColumn . E.mkContainsFilter          $ views (to queryPrintJob)      (E.^. PrintJobName))
-      , single ("acknowledged"   , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
+      , single ("pj-recipient"    , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient)     (E.?. UserDisplayName))
-        -- TODO: continue here 
+      , single ("pj-sender"       , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender)        (E.?. UserDisplayName))
+      , single ("pj-course"       , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse)        (E.?. CourseName))
+      , single ("pj-qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName))
+      , single ("acknowledged"    , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
       ]
     dbtFilterUI mPrev = mconcat
-      [ prismAForm (singletonFilter "pj-name"      . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintJobName)
+      [ prismAForm (singletonFilter "pj-name"         . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintJobName)
-      , prismAForm (singletonFilter "acknowledged" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgPrintJobAcknowledged)
+      , prismAForm (singletonFilter "pj-recipient"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintRecipient)
-        -- TODO: continue here
+      , prismAForm (singletonFilter "pj-sender"       . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintSender)
+      , prismAForm (singletonFilter "pj-course"       . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintCourse)
+      , prismAForm (singletonFilter "pj-qualification". maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintQualification)
+      , prismAForm (singletonFilter "acknowledged"    . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgPrintJobAcknowledged)
       ]
     dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
     dbtIdent :: Text
@@ -249,7 +259,9 @@ mkPJTable = do
         (First (Just act), jobMap) <- inp
         let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
         return (act, jobSet)
-  over _1 postprocess <$> dbTable def DBTable{..}
+    psValidator = def & defaultSorting [SortAscBy "pj-created"]
+                      & defaultFilter (singletonMap "acknowledged" [toPathPiece False])
+  over _1 postprocess <$> dbTable psValidator DBTable{..}
 
 getPrintCenterR,  postPrintCenterR :: Handler Html
 getPrintCenterR = postPrintCenterR
@@ -267,7 +279,7 @@ postPrintCenterR = do
 
   siteLayoutMsg MsgMenuApc $ do
     setTitleI MsgMenuApc
-    $(widgetFile "print-center")
+    $(widgetFile "print-center") --  i18nWidgetFile? Currently no text contained; displays just the table only
 
 
 getPrintSendR, postPrintSendR :: Handler Html
@@ -276,29 +288,50 @@ postPrintSendR = do
   ((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm $ Just def
   let procFormSend mpr = do
         -- addMessage Info . toHtml $ "Brief wird gesendet an " <> mppRecipient
-        e_pdf <- pdfRenewal $ mprToMeta mpr
+        let meta = mprToMeta mpr
-        -- now <- liftIO getCurrentTime
+        receivers <- runDB $ Ex.select $ do
-        case e_pdf of
+          user <- Ex.from $ Ex.table @User
-          Right bs -> do
+          Ex.where_ $ E.val (mppRecipient mpr) `E.isInfixOf` (user E.^. UserIdent)
+          pure user
+        letters <- case receivers of
+          [] -> pure . (Nothing ,) <$> pdfRenewal meta
+          _  -> forM receivers $ \usr -> do
+                  mDate <- formatTimeUser SelFormatDate (mppDate mpr) (Just usr)
+                  let u = entityVal usr
+                      paras = [(k,v) | (k, Just v) <- [
+                                ("lang"      , userLanguages u >>= (listToMaybe . view _Wrapped)) -- auch möglich `op Languages` statt `view _Wrapped`
+                              ]] ++
+                              [ ("date"      , mDate)
+                              , ("recipient" , userDisplayName u)
+                              ]
+                  pdf <- pdfRenewal $ applyMetas paras meta
+                  return (Just $ entityKey usr, pdf)
+        oks <- forM letters $ \case
+          (mbRecipient, Right bs) -> do
             -- liftIO $ LBS.writeFile "/tmp/generated.pdf" bs -- DEBUGGING ONLY
             -- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf"
             uID <- maybeAuthId
-            filepath <- runDB $ sendLetter "Test-Brief" bs Nothing uID Nothing Nothing
+            filepath <- runDB $ sendLetter "Test-Brief" bs mbRecipient uID Nothing Nothing
             addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> filepath
-            redirect PrintCenterR
+            -- TODO: continue here with acutal letter sending!
-          Left err -> addMessage Error . toHtml $ P.renderError err
+            pure True
-        -- TODO: continue here with acutal letter sending!
+          (Nothing, Left err) -> do
-        return $ Just ()
+            addMessage Error . toHtml $ P.renderError err
-  mbPdfLink <- formResultMaybe sendResult procFormSend
+            pure False
+          (Just uid, Left err) -> do
+            addMessage Error . toHtml $ "For uid " <> tshow uid <> ": " <> P.renderError err
+            pure False
+        when (or oks) $ redirect PrintCenterR
+  formResult sendResult procFormSend
   -- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute 
-  siteLayoutMsg MsgMenuPrintSend $ do
+  siteLayoutMsg MsgPrintManualRenewal $ do
     setTitleI MsgMenuPrintSend
     let sendForm = wrapForm sendWidget def
                     { formEncoding = sendEnctype
                     -- , formAction = Just $ SomeRoute actionUrl
                     }
-    -- TODO: use i18nWidgetFile instead if this is to become permanent
+    $(widgetFile "print-send") -- i18nWidgetFile? Currently no text contained; displays just the form only
-    $(widgetFile "print-send")
+
 
 getPrintDownloadR :: CryptoUUIDPrintJob -> Handler TypedContent
 getPrintDownloadR cupj = do

src/Utils/Print.hs

@@ -16,8 +16,12 @@ import qualified Text.Pandoc.Builder as P
 
 -- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly?
 
--- TODO: Handler.Utils.Pandoc and this module need to be sorted.
+{- Recall: 
---       Some stuff might be moved vice versa; maybe rename to Utils.Pandoc?!
+  Funktionen außerhalb der Hanlder-Monade gehören in Utils-Module;
+  ansonsten drohen zyklische Abhängikeiten, d.h. 
+  ggf. Funktionen in der HandlerFor-Monade nach Handler.Utils.Print verschieben!
+-}
+
 
 
 -------------------------
@@ -223,13 +227,17 @@ pdfRenewal' meta = do
 
 sendLetter :: Text -> LBS.ByteString -> Maybe UserId -> Maybe UserId -> Maybe CourseId -> Maybe QualificationId -> DB FilePath
 sendLetter printJobName pdf printJobRecipient printJobSender printJobCourse printJobQualification = do 
-  recipient <- fmap userDisplayName . join <$> mapM get printJobRecipient
+  recipient <- join <$> mapM get printJobRecipient
-  sender    <- fmap userDisplayName . join <$> mapM get printJobRecipient
+  sender    <- join <$> mapM get printJobSender
-  course    <- fmap (CI.original . courseShorthand       ) . join <$> mapM get printJobCourse
+  course    <- join <$> mapM get printJobCourse
-  quali     <- fmap (CI.original . qualificationShorthand) . join <$> mapM get printJobQualification
+  quali     <- join <$> mapM get printJobQualification
+  let nameRecipient = userDisplayName <$> recipient
+      nameSender    = userDisplayName <$> sender
+      nameCourse    = CI.original . courseShorthand        <$> course 
+      nameQuali     = CI.original . qualificationShorthand <$> quali
   let printJobAcknowledged = Nothing
-      printJobFilename = unpack $ (T.intercalate "_" . catMaybes $ [Just printJobName, quali, course, sender, recipient]) <> ".pdf"
+      printJobFilename = unpack $ (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) <> ".pdf"
-      -- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code
+      -- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf   -- for PrintJobFile :: FileContentReference use this code
       printJobFile = LBS.toStrict pdf
   -- TODO: system call to lpr here!
   printJobCreated <- liftIO getCurrentTime

templates/print-send.hamlet

@@ -1,12 +1,3 @@
 <section>
-  <h2>
-    Vorfeldführerschein Renewal-Briefes versenden
   <p> 
     ^{sendForm}
-$maybe pdfLink <- mbPdfLink
-  <section>
-    <h2>Soeben versendeter Brief
-    <p>
-      #{show pdfLink}
-    <p>
-      TODO: Hier Link auf generiertem Brief anzeigen

testdata/test_letters.hs

@@ -21,6 +21,29 @@ import Handler.PrintCenter
 mdTmpl :: Text 
 mdTmpl = "---\nfoo: fooOrg\nbar: barOrg\n---\nHere is some text\n - foo: $foo$\n - bar: $bar$\nbody\n$body$\nend\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 "address"   (mppAddress & html2textlines)
+  , toMeta "login"      mppLogin
+  , toMeta "pin"        mppPin
+  , mbMeta "url"       (mppURL  <&> tshow)
+  , toMeta "date"      (mppDate  &  tshow) -- TODO: render according to user preference
+  , toMeta "lang"       mppLang
+  , mbMeta keyOpening   mppOpening
+  , mbMeta keyClosing   mppClosing
+  ]
+  where
+    deOrEn     = if isDe mppLang then "de" else "en"
+    keyOpening = deOrEn <> "-opening"
+    keyClosing = deOrEn <> "-closing"
+    mbMeta :: P.ToMetaValue a => Text -> Maybe a -> Map Text P.MetaValue
+    mbMeta   = foldMap . toMeta
+    toMeta :: P.ToMetaValue a => Text ->       a -> Map Text P.MetaValue
+    toMeta k = singletonMap k . P.toMetaValue
+    html2textlines :: StoredMarkup -> [Text]
+    html2textlines sm = T.lines . LT.toStrict $ markupInput sm
 
 test :: IO T.Text
 test = do