chore(letter): test printing with new ident strings working again

models/print.model

@@ -4,7 +4,7 @@
 
 PrintJob  
   name            Text
-  apcAcknowledge  Text                  default='unknown'
+  apcIdent        Text                  default='unknown'
   filename        FilePath
   file            ByteString      -- stores plain pdf; otherwise use FileContentReference Maybe
   created         UTCTime
@@ -15,5 +15,5 @@ PrintJob
   qualification   QualificationId Maybe OnDeleteCascade OnUpdateCascade
   lmsUser         LmsIdent        Maybe OnDeleteCascade OnUpdateCascade   -- allows tracking if recipient has been notified; must be unique  
   -- UniquePrintJobLmsUser lmsUser -- Note that in fact multiple print jobs per LMS user are possible!
-  -- UniquePrintJobApcAcknowledge apcAcknowledge -- TODO: not yet enforced, since LmsIdent is currently used
+  -- UniquePrintJobApcIdent apcIdent -- TODO: not yet enforced, since LmsIdent is currently used
   deriving Generic

src/Handler/Admin/Test.hs

@@ -302,6 +302,7 @@ getAdminTestPdfR = do
   qual <- fromMaybeM
             (addMessage Error "Keine Qualifikation in der Datenbank zur Erzeugung eines Test-PDFs gefunden." >> redirect AdminTestR)
             (runDB $ selectFirst [] [Asc QualificationAvsLicence, Asc QualificationShorthand])
+  encRecipient :: CryptoUUIDUser <- encrypt $ usr ^. _entityKey
   now <- liftIO getCurrentTime
   let nowaday = utctDay now
       letter  = LetterRenewQualificationF
@@ -316,8 +317,9 @@ getAdminTestPdfR = do
         , qualShort     = qual ^. _qualificationShorthand . _CI
         , qualSchool    = qual ^. _qualificationSchool
         , qualDuration  = qual ^. _qualificationValidDuration
-        }
+        }  
-  renderLetter usr letter >>= \case
+  apcIdent <- letterApcIdent letter encRecipient now
+  renderLetter usr letter apcIdent >>= \case
     Left err  -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
     Right pdf -> do
       liftIO $ LBS.writeFile "/tmp/generated.pdf" pdf

src/Handler/PrintCenter.hs

@@ -170,8 +170,8 @@ mkPJTable = do
       , sortable (Just "filename")     (i18nCell MsgPrintPDF)  $ \r -> let k = r ^. resultPrintJob . _entityKey
                                                                            t = r ^. resultPrintJob . _entityVal . _printJobFilename
                                                                        in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t)
-      , sortable (Just "apcid")        (i18nCell MsgPrintJobApcAcknowledge)$ \(   view $ resultPrintJob . _entityVal . _printJobApcAcknowledge -> t) -> textCell t
+      , sortable (Just "apcid")        (i18nCell MsgPrintJobApcAcknowledge)$ \(   view $ resultPrintJob . _entityVal . _printJobApcIdent  -> t) -> textCell t
-      , sortable (Just "name")         (i18nCell MsgPrintJobName)          $ \(   view $ resultPrintJob . _entityVal . _printJobName         -> n) -> textCell n
+      , sortable (Just "name")         (i18nCell MsgPrintJobName)          $ \(   view $ resultPrintJob . _entityVal . _printJobName      -> n) -> textCell n
       , sortable (Just "recipient")    (i18nCell MsgPrintRecipient)        $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
       , sortable (Just "sender")       (i18nCell MsgPrintSender)           $ \(preview resultSender    -> u) -> maybeCell u $ cellHasUserLink AdminUserR
       , sortable (Just "course")       (i18nCell MsgPrintCourse)           $ \(preview $ resultCourse        . _entityVal -> c) -> maybeCell c courseCell
@@ -183,7 +183,7 @@ mkPJTable = do
       , single ("filename"     , SortColumn $ queryPrintJob      >>> (E.^. PrintJobFilename))
       , single ("created"      , SortColumn $ queryPrintJob      >>> (E.^. PrintJobCreated))
       , single ("acknowledged" , SortColumn $ queryPrintJob      >>> (E.^. PrintJobAcknowledged))
-      , single ("apcid"        , SortColumn $ queryPrintJob   >>> (E.^. PrintJobApcAcknowledge))
+      , single ("apcid"        , SortColumn $ queryPrintJob      >>> (E.^. PrintJobApcIdent))
       , single ("recipient"    , sortUserNameBareM queryRecipient)
       , single ("sender"       , sortUserNameBareM querySender   )
       , single ("course"       , SortColumn $ queryCourse        >>> (E.?. CourseName))
@@ -192,7 +192,7 @@ mkPJTable = do
       ]
     dbtFilter = mconcat
       [ single ("name"         , FilterColumn . E.mkContainsFilter          $ views (to queryPrintJob)      (E.^. PrintJobName))
-      , single ("apcid"        , FilterColumn . E.mkContainsFilter          $ views (to queryPrintJob)      (E.^. PrintJobApcAcknowledge))
+      , single ("apcid"        , FilterColumn . E.mkContainsFilter          $ views (to queryPrintJob)      (E.^. PrintJobApcIdent))
       , single ("filename"     , FilterColumn . E.mkContainsFilter          $ views (to queryPrintJob)      (E.^. PrintJobFilename))      
       , single ("created"      , FilterColumn . E.mkDayFilter               $ views (to queryPrintJob)      (E.^. PrintJobCreated))
       --, single ("created"      , FilterColumn . E.mkDayBetweenFilter               $ views (to queryPrintJob)      (E.^. PrintJobCreated))
@@ -273,12 +273,13 @@ postPrintCenterR = do
 getPrintSendR, postPrintSendR :: Handler Html
 getPrintSendR = postPrintSendR
 postPrintSendR = do
-  usr  <- requireAuth -- to determine language and recipient for test 
+  usr  <- requireAuth -- to determine language and recipient for test   
   mbQual <- runDB $ selectFirst [] [Asc QualificationAvsLicence, Asc QualificationShorthand]
   now <- liftIO getCurrentTime
   let nowaday = utctDay now
+      uid = usr ^. _entityKey
       mkLetter qual = LRQF
-        { lrqfUser      = Right $ usr ^. _entityKey
+        { lrqfUser      = Right uid
         , lrqfSuper     = Nothing
         , lrqfQuali     = qual
         , lrqfIdent     = LmsIdent  "stuvwxyz"
@@ -289,7 +290,7 @@ postPrintSendR = do
 
   ((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm def_lrqf
   let procFormSend lrqf = do
-        ok <- (runDB (lrqf2letter lrqf) >>= printLetter) >>= \case 
+        ok <- (runDB (lrqf2letter lrqf) >>= printLetter (Just uid)) >>= \case 
           Left err -> do
             let msg = "PDF printing failed with error: " <> err
             $logErrorS "LPR" msg

src/Model/Types/Lms.hs

@@ -134,10 +134,10 @@ _lmsDay = iso LmsDay lms2day
 
 -- | Format for day for LMS interface
 lmsDayFormat :: String 
-lmsDayFormat = "%d-%m-%Y"
+lmsDayFormat = "%d-%m-%Y" -- fixed in LMS interface desctiption, due defaultTimeLocale, should not use named entities like weekdays or month names
 
 instance Csv.ToField LmsDay where 
-  toField (LmsDay d) = Csv.toField $ Time.formatTime Time.defaultTimeLocale lmsDayFormat d -- TimeLocale should not matter; getTimeLocale requires MonadHandler
+  toField (LmsDay d) = Csv.toField $ Time.formatTime Time.defaultTimeLocale lmsDayFormat d -- TimeLocale should not matter since format string does not use names; getTimeLocale requires MonadHandler
 
 instance Csv.FromField LmsDay where 
 --  parseField = fmap LmsDay . parseLmsDay <=< Csv.parseField

src/Utils/Print.hs

@@ -7,7 +7,8 @@
 module Utils.Print
   ( renderLetter        -- used for generating letter pdfs
   , sendEmailOrLetter   -- directly print or sends by email
-  , printLetter          -- always send a letter
+  , printLetter         -- always send a letter
+  , letterApcIdent      -- create acknowledge string for APC
   , encryptPDF
   , sanitizeCmdArg, validCmdArgument
   -- , compileTemplate, makePDF
@@ -129,15 +130,14 @@ pdfLaTeX lk meta md = do
         $ addMeta meta doc
 
 
-renderLetter :: (MDLetter l) => Entity User -> l -> Handler (Either Text LBS.ByteString)
+renderLetter :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString)
-renderLetter rcvrEnt@Entity{entityKey=uid, entityVal=rcvr} mdl = do
+renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do
-  now <- liftIO getCurrentTime
+  now <- liftIO getCurrentTime  
-  uuid :: CryptoUUIDUser <- encrypt uid
   formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr
   let lang = selectDeEn $ rcvr & userLanguages   -- select either German or English only, default de; see Utils.Lang
       kind = getLetterKind $ pure mdl
       tmpl = getTemplate   $ pure mdl
-      meta = letterApcIdent uuid mdl
+      meta = addApcIdent apcIdent
           <> letterMeta mdl formatter lang rcvrEnt
           <> mkMeta
             [ toMeta "lang"         lang
@@ -157,13 +157,19 @@ renderLetter rcvrEnt@Entity{entityKey=uid, entityVal=rcvr} mdl = do
 ---------------
 
 -- Only used in print-test-handler for PrintSendR
-printLetter :: (MDLetter l) => (Entity User, l) -> Handler (Either Text (Text, FilePath))
+printLetter :: (MDLetter l) => Maybe UserId -> (Entity User, l) -> Handler (Either Text (Text, FilePath))
-printLetter (rcvr, letter) = do 
+printLetter senderId (rcvr, letter) = do
-  pdf <- renderLetter rcvr letter
+  let rcvrId = rcvr ^. _entityKey
+  encRecipient :: CryptoUUIDUser <- encrypt rcvrId
+  now <- liftIO getCurrentTime
+  apcIdent <- letterApcIdent letter encRecipient now
+  pdf <- renderLetter rcvr letter apcIdent
   let protoPji = getPJId letter 
       pji = protoPji 
-              { pjiRecipient = Just $ entityKey rcvr
+              { pjiRecipient = Just rcvrId
+              , pjiSender = senderId
               , pjiName = "TEST_" <> pjiName protoPji
+              , pjiApcAcknowledge = apcIdent
               }
   actRight pdf $ runDB . printLetter' pji
 
@@ -171,7 +177,7 @@ printLetter' :: PrintJobIdentification -> LBS.ByteString -> DB (Either Text (Tex
 printLetter' pji pdf = do
   let PrintJobIdentification
         { pjiName           = printJobName
-        , pjiApcAcknowledge = printJobApcAcknowledge
+        , pjiApcAcknowledge = printJobApcIdent
         , pjiRecipient      = printJobRecipient
         , pjiSender         = printJobSender
         , pjiCourse         = printJobCourse
@@ -214,29 +220,28 @@ printLetter'' _ = do
 sendEmailOrLetter :: (MDLetter l) => UserId -> l -> Handler Bool
 sendEmailOrLetter recipient letter = do
   (underling, receivers, undercopy) <- updateReceivers recipient -- TODO: check to avoid this almost circular dependency
+  now <- liftIO getCurrentTime
   let pjid = getPJId letter
       mailSubject = getMailSubject letter       -- these are only needed if sent by email, but we're lazy anyway
       undername = underling ^. _userDisplayName -- nameHtml' underling
       undermail = CI.original $ underling ^. _userEmail
-  now <- liftIO getCurrentTime
   oks <- forM receivers $ \rcvrEnt@Entity{ entityKey = svr, entityVal = rcvrUsr } -> do
-    let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr
+    encRecipient :: CryptoUUIDUser <- encrypt svr
+    apcIdent <- letterApcIdent letter encRecipient now
+    let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr        
     -- mailBody = getMailBody letter formatter
-    renderLetter rcvrEnt letter >>= \case
+    renderLetter rcvrEnt letter apcIdent >>= \case
-      _ | preferPost, isNothing postal -> do -- neither email nor postal is known
+      _ | 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. Notification: " <> tshow pjid
         $logErrorS "LETTER" msg
         return False
-      Left err -> do -- pdf generation failed
+      Left err -> do -- pdf generation failed        
-        encRecipient :: CryptoUUIDUser <- encrypt svr
         let msg = "Notification failed for " <> tshow encRecipient <> ". PDF generation failed: "<> cropText err <> "For Notification: " <> tshow pjid
         $logErrorS "LETTER" msg
         return False
       Right pdf | preferPost -> -- send printed letter
-        runDB (printLetter' pjid{pjiRecipient = Just svr} pdf) >>= \case
+        runDB (printLetter' pjid{pjiRecipient = Just svr, pjiApcAcknowledge = apcIdent} pdf) >>= \case
-          Left err -> do
+          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
@@ -250,8 +255,7 @@ sendEmailOrLetter recipient letter = do
           Nothing     -> return pdf
           Just passwd -> encryptPDF passwd pdf >>= \case
             Right encPdf -> return encPdf
-            Left err -> do
+            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

src/Utils/Print/Letters.hs

@@ -7,15 +7,15 @@
 module Utils.Print.Letters where
 
 -- import Import.NoModel
+import Import hiding (embedFile)
+import Data.FileEmbed (embedFile)
 import           Data.Char as Char
 import qualified Data.Text as Text
 -- import qualified Data.CaseInsensitive as CI
 import qualified Data.Foldable as Fold
-
 import qualified Data.ByteString.Lazy as LBS
+
 import Control.Monad.Except
-import Import hiding (embedFile)
-import Data.FileEmbed (embedFile)
 
 import qualified Text.Pandoc         as P
 import qualified Text.Pandoc.PDF     as P
@@ -27,7 +27,7 @@ import Text.Hamlet
 -- import System.Process.Typed -- for calling pdftk for pdf encryption
 
 -- import Handler.Utils.Users
--- import Handler.Utils.DateTime
+import Handler.Utils.DateTime
 -- import Handler.Utils.Mail
 -- import Handler.Utils.Widgets (nameHtml, nameHtml')
 -- import Handler.Utils.Avs (updateReceivers)
@@ -159,6 +159,9 @@ paperKind PlainLogo = "a4logo"
 -- PrintJobs --
 ---------------
 
+apcIdentSeparator :: Text  
+apcIdentSeparator = "___"
+
 data PrintJobIdentification = PrintJobIdentification
       { pjiName           :: Text
       , pjiApcAcknowledge :: Text
@@ -172,16 +175,14 @@ data PrintJobIdentification = PrintJobIdentification
 
 -- | create an identifier for printing with apc; which must always be place in the same position for all letters, printed in white on white
 --   Note that all letters to the same UUID within 24h are collated in one envelope
-mkApcIdent :: CryptoUUIDUser -> Char -> LetterKind -> Text -> P.Meta
+mkApcIdent :: CryptoUUIDUser -> Char -> LetterKind -> Text -> Text -> Text
-mkApcIdent uuid envelope lk apcAck = P.Meta $ toMeta "apc-ident" apcIdent
+mkApcIdent uuid envelope lk tnow apcAck = Text.filter apcAcceptedChars $ Text.intercalate apcIdentSeparator
-  where
-    apcSep = "___"
-    apcIdent = Text.filter apcAcceptedChars $ Text.intercalate apcSep
       [ tshow (ciphertext uuid) <> Text.cons '-' (Text.singleton envelope)
       , paperKind lk
+      , tnow
       , apcAck
       ]
-
+      
 -- | Character allowed to be included in the APC identifier string printed in white in the header of all printed letters      
 apcAcceptedChars :: Char -> Bool
 apcAcceptedChars '-' = True
@@ -215,5 +216,15 @@ class MDLetter l where
   getLetterKind     :: Proxy l -> LetterKind
   getTemplate       :: Proxy l -> Text  
 
-letterApcIdent :: MDLetter l => CryptoUUIDUser -> l -> P.Meta
+letterApcIdent :: (MDLetter l, MonadHandler m) => l -> CryptoUUIDUser -> UTCTime -> m Text
-letterApcIdent uuid l = mkApcIdent uuid (getLetterEnvelope l) (getLetterKind $ pure l) (pjiApcAcknowledge $ getPJId l)
+letterApcIdent l uuid now = do
+  -- now  <- liftIO getCurrentTime
+  tnow <- formatTime' "%y%m%d-%H" now
+  return $ mkApcIdent uuid (getLetterEnvelope l) (getLetterKind $ pure l) tnow (pjiApcAcknowledge $ getPJId l)
+
+addApcIdent :: Text -> P.Meta
+addApcIdent = P.Meta . toMeta "apc-ident"
+
+getApcIdent :: P.Meta -> Maybe Text
+getApcIdent (P.lookupMeta "apc-ident" -> Just (P.MetaString t)) = Just t
+getApcIdent _ = Nothing

templates/letter/din5008.latex

@@ -80,7 +80,7 @@ $endif$
 
 %\usepackage[a4paper, bottom=8cm, top=3cm]{geometry} %%% THIS HAD NO EFFECT AT ALL
 
-%\usepackage{parskip}% might be useful for pandoc tightlist
+\usepackage{parskip}% might be useful for pandoc tightlist
 
 \usepackage{graphics}
 \usepackage{xcolor}

templates/letter/din5008with_pin.latex

@@ -80,7 +80,7 @@ $endif$
 
 %\usepackage[a4paper, bottom=8cm, top=3cm]{geometry} %%% THIS HAD NO EFFECT AT ALL
 
-%\usepackage{parskip}% might be useful for pandoc tightlist
+\usepackage{parskip}% might be useful for pandoc tightlist
 
 \usepackage{graphics}
 \usepackage{xcolor}

templates/letter/plain_article.latex

@@ -72,7 +72,7 @@ $endif$
 
 %\usepackage[a4paper, bottom=8cm, top=3cm]{geometry} %%% THIS HAD NO EFFECT AT ALL
 
-%\usepackage{parskip}% might be useful for pandoc tightlist
+\usepackage{parskip}% might be useful for pandoc tightlist
 
 \usepackage{graphics}
 \usepackage{xcolor}

test/Database/Fill.hs

@@ -106,9 +106,9 @@ fillDb = do
     , userCompanyPersonalNumber = Just "00000"
     , userCompanyDepartment = Nothing
     , userPinPassword = Nothing
-    , userPostAddress = Nothing
+    , userPostAddress = Just $ markdownToStoredMarkup ("Büro 127   \nMathematisches Institut der Ludwig-Maximilians-Universität München   \nTheresienstr. 39   \nD-80333 München"::Text)
     , userPostLastUpdate = Nothing
-    , userPrefersPostal = False
+    , userPrefersPostal = True
     , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
     , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
     }
@@ -145,10 +145,10 @@ fillDb = do
     , userTelephone = Nothing
     , userCompanyPersonalNumber = Nothing
     , userCompanyDepartment = Nothing
-    , userPinPassword = Nothing
+    , userPinPassword = Just "tomatenmarmelade"
-    , userPostAddress = Nothing
+    , userPostAddress = Just $ markdownToStoredMarkup ("Erdbeerweg 24  \n12345 **Schlumpf**hausen  \nTraumland"::Text)
     , userPostLastUpdate = Nothing
-    , userPrefersPostal = False
+    , userPrefersPostal = True
     , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
     , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
     }