From 94feda10c2bdd5c5a9b81e29d568477e4058b986 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 18 Jul 2022 16:28:05 +0200 Subject: [PATCH] chore(letter): sending of multiple user letter with proper language interpolation --- .../uniworx/categories/print/de-de-formal.msg | 3 +- messages/uniworx/categories/print/en-eu.msg | 3 +- src/Handler/PrintCenter.hs | 145 +++++++++++------- src/Utils/Print.hs | 24 ++- templates/print-send.hamlet | 9 -- testdata/test_letters.hs | 23 +++ 6 files changed, 132 insertions(+), 75 deletions(-) diff --git a/messages/uniworx/categories/print/de-de-formal.msg b/messages/uniworx/categories/print/de-de-formal.msg index 8916728ec..2327b2661 100644 --- a/messages/uniworx/categories/print/de-de-formal.msg +++ b/messages/uniworx/categories/print/de-de-formal.msg @@ -8,4 +8,5 @@ PrintRecipient: Empfänger PrintSender !ident-ok: Sender PrintCourse: Kurse PrintQualification: Qualifikation -PrintPDF !ident-ok: PDF \ No newline at end of file +PrintPDF !ident-ok: PDF +PrintManualRenewal: Vorfeldführerschein Renewal-Brief testweise versenden \ No newline at end of file diff --git a/messages/uniworx/categories/print/en-eu.msg b/messages/uniworx/categories/print/en-eu.msg index b4e98234e..97102165e 100644 --- a/messages/uniworx/categories/print/en-eu.msg +++ b/messages/uniworx/categories/print/en-eu.msg @@ -8,4 +8,5 @@ PrintRecipient: Recipient PrintSender: Sender PrintCourse: Course PrintQualification: Qualification -PrintPDF: PDF \ No newline at end of file +PrintPDF: PDF +PrintManualRenewal: Manual sending of an apron driving licence renewal letter \ No newline at end of file diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index ac7bb8515..9c2d90bb5 100644 --- a/src/Handler/PrintCenter.hs +++ b/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,7 +109,8 @@ mprToMeta MetaPinRenewal{..} = P.Meta $ mconcat html2textlines sm = T.lines . LT.toStrict $ markupInput sm -data PJTableAction = PJActAcknowledge + +data PJTableAction = PJActAcknowledge deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) @@ -158,16 +162,16 @@ resultCourse = _dbrOutput . _4 . _Just resultQualification :: Traversal' PJTableData (Entity Qualification) resultQualification = _dbrOutput . _5 . _Just -pjTableQuery :: PJTableExpr -> E.SqlQuery +pjTableQuery :: PJTableExpr -> E.SqlQuery ( E.SqlExpr (Entity PrintJob) , E.SqlExpr (Maybe (Entity User)) , E.SqlExpr (Maybe (Entity User)) , E.SqlExpr (Maybe (Entity Course)) , E.SqlExpr (Maybe (Entity Qualification))) -pjTableQuery (printJob `E.LeftOuterJoin` recipient - `E.LeftOuterJoin` sender +pjTableQuery (printJob `E.LeftOuterJoin` recipient + `E.LeftOuterJoin` sender `E.LeftOuterJoin` course - `E.LeftOuterJoin` quali ) = do + `E.LeftOuterJoin` quali ) = do E.on $ printJob E.^. PrintJobRecipient E.==. recipient E.?. UserId E.on $ printJob E.^. PrintJobSender E.==. sender E.?. UserId E.on $ printJob E.^. PrintJobCourse E.==. course E.?. CourseId @@ -175,25 +179,25 @@ pjTableQuery (printJob `E.LeftOuterJoin` recipient return (printJob, recipient, sender, course, quali) mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget) -mkPJTable = do +mkPJTable = do currentRoute <- fromMaybe (error "mkPJTable called from 404-handler") <$> liftHandler getCurrentRoute -- albeit we do know the route here - let + let showId :: PrintJobId -> Widget - showId k = do + showId k = do c <- encrypt k - let f :: CryptoUUIDPrintJob -> Text - f x = toPathPiece x + let f :: CryptoUUIDPrintJob -> Text + f x = toPathPiece x [whamlet|#{f c}|] dbtSQLQuery = pjTableQuery dbtRowKey = queryPrintJob >>> (E.^. PrintJobId) dbtProj = dbtProjFilteredPostId - dbtColonnade = mconcat + 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-id") (i18nCell MsgPrintJobId) $ \( view $ resultPrintJob . _entityKey -> k) -> cell (showId k) + , 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 @@ -202,26 +206,32 @@ mkPJTable = do ] dbtSorting = mconcat [ single ("pj-name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName)) - -- , single ("pj-id" , SortColumn $ queryPrintJob >>> (E.^. PrintJobId)) - , single ("pj-created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated)) - , single ("pj-acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged)) + -- , single ("pj-id" , SortColumn $ queryPrintJob >>> (E.^. PrintJobId)) + , single ("pj-created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated)) + , single ("pj-acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged)) , single ("pj-recipient" , sortUserNameBareM queryRecipient) , single ("pj-sender" , sortUserNameBareM querySender ) - , single ("pj-course" , SortColumn $ queryCourse >>> (E.?. CourseName)) - , single ("pj-qualification", SortColumn $ queryQualification >>> (E.?. QualificationName)) + , single ("pj-course" , SortColumn $ queryCourse >>> (E.?. CourseName)) + , single ("pj-qualification", SortColumn $ queryQualification >>> (E.?. QualificationName)) ] dbtFilter = mconcat - [ single ("pj-name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName)) - , single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged))) - -- TODO: continue here + [ single ("pj-name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName)) + , single ("pj-recipient" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient) (E.?. UserDisplayName)) + , 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 "acknowledged" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgPrintJobAcknowledged) - -- TODO: continue here + [ prismAForm (singletonFilter "pj-name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName) + , prismAForm (singletonFilter "pj-recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient) + , 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 + dbtIdent :: Text dbtIdent = "print-job" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing @@ -233,7 +243,7 @@ mkPJTable = do , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional = let acts :: Map PJTableAction (AForm Handler PJTableActionData) - acts = mconcat + acts = mconcat [ singletonMap PJActAcknowledge $ pure PJActAcknowledgeData ] in renderAForm FormStandard @@ -249,25 +259,27 @@ 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 postPrintCenterR = do currentRoute <- fromMaybe (error "printCenterR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler - (pjRes, pjTable) <- runDB mkPJTable + (pjRes, pjTable) <- runDB mkPJTable - formResult pjRes $ \case + formResult pjRes $ \case (PJActAcknowledgeData, pjIds) -> do let setPJIds = Set.toList pjIds now <- liftIO getCurrentTime - num <- runDB $ updateWhereCount [PrintJobAcknowledged ==. Nothing, PrintJobId <-. setPJIds] [PrintJobAcknowledged =. Just now] + num <- runDB $ updateWhereCount [PrintJobAcknowledged ==. Nothing, PrintJobId <-. setPJIds] [PrintJobAcknowledged =. Just now] addMessageI Success $ MsgPrintJobAcknowledge num redirect currentRoute 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,34 +288,55 @@ 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 - -- now <- liftIO getCurrentTime - case e_pdf of - Right bs -> do + let meta = mprToMeta mpr + receivers <- runDB $ Ex.select $ do + user <- Ex.from $ Ex.table @User + 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 - addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> filepath - redirect PrintCenterR - Left err -> addMessage Error . toHtml $ P.renderError err - -- TODO: continue here with acutal letter sending! - return $ Just () - mbPdfLink <- formResultMaybe sendResult procFormSend - -- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute - siteLayoutMsg MsgMenuPrintSend $ do + filepath <- runDB $ sendLetter "Test-Brief" bs mbRecipient uID Nothing Nothing + addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> filepath + -- TODO: continue here with acutal letter sending! + pure True + (Nothing, Left err) -> do + addMessage Error . toHtml $ P.renderError err + 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 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") + $(widgetFile "print-send") -- i18nWidgetFile? Currently no text contained; displays just the form only + getPrintDownloadR :: CryptoUUIDPrintJob -> Handler TypedContent -getPrintDownloadR cupj = do - pjId <- decrypt cupj - PrintJob {..} <- runDB $ get404 pjId +getPrintDownloadR cupj = do + pjId <- decrypt cupj + PrintJob {..} <- runDB $ get404 pjId sendByteStringAsFile printJobFilename printJobFile printJobCreated {- for PrintJobFile :: FileContentReference use this code, however, requires instances HasFileReference PrintJob and IsFileReference PrintJob which seemed to complicated... :( @@ -315,4 +348,4 @@ getPrintDownloadR cupj = do E.where_ (pj E.^. PrintJobId E.==. E.val pjId) -- return file entity return pj --} \ No newline at end of file +-} \ No newline at end of file diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index c469eea93..3d3af0622 100644 --- a/src/Utils/Print.hs +++ b/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. --- Some stuff might be moved vice versa; maybe rename to Utils.Pandoc?! +{- Recall: + 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 - sender <- fmap userDisplayName . join <$> mapM get printJobRecipient - course <- fmap (CI.original . courseShorthand ) . join <$> mapM get printJobCourse - quali <- fmap (CI.original . qualificationShorthand) . join <$> mapM get printJobQualification + recipient <- join <$> mapM get printJobRecipient + sender <- join <$> mapM get printJobSender + course <- join <$> mapM get printJobCourse + 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" - -- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code + 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 = LBS.toStrict pdf -- TODO: system call to lpr here! printJobCreated <- liftIO getCurrentTime diff --git a/templates/print-send.hamlet b/templates/print-send.hamlet index 1ce1521f6..7f44ae996 100644 --- a/templates/print-send.hamlet +++ b/templates/print-send.hamlet @@ -1,12 +1,3 @@
-

- Vorfeldführerschein Renewal-Briefes versenden

^{sendForm} -$maybe pdfLink <- mbPdfLink -

-

Soeben versendeter Brief -

- #{show pdfLink} -

- TODO: Hier Link auf generiertem Brief anzeigen \ No newline at end of file diff --git a/testdata/test_letters.hs b/testdata/test_letters.hs index 5ead70537..edabf4192 100644 --- a/testdata/test_letters.hs +++ b/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