chore(lpr): add manual print-ack csv upload

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -147,6 +147,7 @@ MenuApc: Druckerei
 MenuPrintSend: Manueller Briefversand
 MenuPrintDownload: Brief herunterladen
 MenuPrintLog: LPR Schnittstelle
+MenuPrintAck: Druckbestätigung
 
 MenuApiDocs: API-Dokumentation (Englisch)
 MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -147,6 +147,7 @@ MenuApc: Printing
 MenuPrintSend: Send Letter
 MenuPrintDownload: Download Letter
 MenuPrintLog: LPR Interface
+MenuPrintAck: Acknowledge Printing
 
 MenuApiDocs: API documentation
 MenuSwagger: OpenAPI 2.0 (Swagger)

routes

@@ -79,7 +79,7 @@
 
 /print                                PrintCenterR    GET POST  !system-printer
 /print/acknowledge/#Day/#Int/#Int     PrintAckR       GET POST  !system-printer
-/print/acknowledge/direct             PrintAckDirectR     POST  !system-printer
+/print/acknowledge/direct             PrintAckDirectR GET POST  !system-printer
 /print/send                           PrintSendR      GET POST
 /print/download/#CryptoUUIDPrintJob   PrintDownloadR  GET       !system-printer
 /print/log                            PrintLogR       GET       !system-printer

src/Foundation/Navigation.hs

@@ -127,13 +127,13 @@ breadcrumb FirmAllR         = i18nCrumb MsgMenuFirms              Nothing
 breadcrumb FirmsCommR{}     = i18nCrumb MsgMenuFirmsComm        $ Just   FirmAllR
 breadcrumb FirmUsersR{}     = i18nCrumb MsgMenuFirmUsers        $ Just   FirmAllR
 breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors  $ Just $ FirmUsersR fsh
-breadcrumb (FirmCommR   fsh)= i18nCrumb MsgMenuFirmsComm        $ Just $ FirmUsersR fsh                       
+breadcrumb (FirmCommR   fsh)= i18nCrumb MsgMenuFirmsComm        $ Just $ FirmUsersR fsh
 
 breadcrumb PrintCenterR     = i18nCrumb MsgMenuApc              Nothing
 breadcrumb PrintSendR       = i18nCrumb MsgMenuPrintSend      $ Just PrintCenterR
 breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload  $ Just PrintCenterR
 breadcrumb PrintAckR{}      = i18nCrumb MsgMenuPrintSend      $ Just PrintCenterR -- never displayed
-breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintSend      $ Just PrintCenterR -- never displayed
+breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintAck       $ Just PrintCenterR
 breadcrumb PrintLogR        = i18nCrumb MsgMenuPrintLog       $ Just PrintCenterR
 
 breadcrumb SchoolListR      = i18nCrumb MsgMenuSchoolList       $ Just AdminR
@@ -193,7 +193,7 @@ breadcrumb (LmsLearnersDirectR  ssh  qsh) = i18nCrumb MsgMenuLmsLearners   $ Jus
 breadcrumb (LmsReportR          ssh  qsh) = i18nCrumb MsgMenuLmsReport     $ Just $ LmsR          ssh qsh
 breadcrumb (LmsReportUploadR    ssh  qsh) = i18nCrumb MsgMenuLmsUpload     $ Just $ LmsReportR    ssh qsh
 breadcrumb (LmsReportDirectR    ssh  qsh) = i18nCrumb MsgMenuLmsUpload     $ Just $ LmsReportR    ssh qsh -- never displayed
--- 
+--
 breadcrumb (LmsIdentR           ssh  qsh _ ) = breadcrumb $ LmsR ssh qsh -- just a redirect
 breadcrumb (LmsUserR            ssh _qsh u ) = i18nCrumb MsgMenuLmsUser       $ Just $ LmsUserSchoolR u ssh
 breadcrumb (LmsUserSchoolR    u _          ) = i18nCrumb MsgMenuLmsUserSchool $ Just $ LmsUserAllR u
@@ -294,7 +294,7 @@ breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of
   TUsersR  -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do
     guardM . lift . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR
     return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR)
-  TAddUserR   -> i18nCrumb MsgMenuTutorialAddMembers      . Just $ CTutorialR tid ssh csh tutn TUsersR 
+  TAddUserR   -> i18nCrumb MsgMenuTutorialAddMembers      . Just $ CTutorialR tid ssh csh tutn TUsersR
   TEditR      -> i18nCrumb MsgMenuTutorialEdit            . Just $ CTutorialR tid ssh csh tutn TUsersR
   TDeleteR    -> i18nCrumb MsgMenuTutorialDelete          . Just $ CTutorialR tid ssh csh tutn TUsersR
   TCommR      -> i18nCrumb MsgMenuTutorialComm            . Just $ CTutorialR tid ssh csh tutn TUsersR
@@ -2380,7 +2380,7 @@ pageActions (LmsR sid qsh) = return
         [ defNavLink MsgMenuLmsUpload       $ LmsReportUploadR sid qsh
         , defNavLink MsgMenuLmsDirectUpload $ LmsReportDirectR sid qsh
         ]
-    }  
+    }
   , NavPageActionSecondary {
       navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh
     }
@@ -2405,7 +2405,7 @@ pageActions (FirmUsersR fsh) = return
   [ NavPageActionPrimary
     { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh
     , navChildren = []
-    }  
+    }
   ]
 pageActions (FirmSupersR fsh) = return
   [ NavPageActionPrimary
@@ -2458,10 +2458,20 @@ pageActions PrintCenterR = do
                       , navForceActive = False
                       }
                     }
+      printAck = NavPageActionSecondary
+                    { navLink = NavLink
+                      { navLabel       = MsgMenuPrintAck
+                      , navRoute       = PrintAckDirectR
+                      , navAccess'     = NavAccessTrue
+                      , navType        = NavTypeLink { navModal = False }
+                      , navQuick'      = mempty
+                      , navForceActive = False
+                      }
+                    }
   dayLinks <- mapM toDayAck $ Map.toAscList dayMap
-  return $ manualSend : printLog : take 9 dayLinks
+  return $ manualSend : printLog : printAck : take 9 dayLinks
 
-pageActions AdminCrontabR = return 
+pageActions AdminCrontabR = return
   [ NavPageActionPrimary
     { navLink = defNavLink MsgMenuAdminJobs AdminJobsR
     , navChildren = []

src/Handler/PrintCenter.hs

@@ -7,10 +7,10 @@
 
 module Handler.PrintCenter
   ( getPrintDownloadR
-  , getPrintCenterR, postPrintCenterR  
+  , getPrintCenterR, postPrintCenterR
   , getPrintSendR  , postPrintSendR
   , getPrintAckR   , postPrintAckR
-  , postPrintAckDirectR  
+  , getPrintAckDirectR, postPrintAckDirectR
   , getPrintLogR
   ) where
 
@@ -44,11 +44,11 @@ single :: (k,a) -> Map k a
 single = uncurry Map.singleton
 
 
-data LRQF = LRQF 
+data LRQF = LRQF
-    { lrqfLetter    :: Text 
+    { lrqfLetter    :: Text
     , lrqfUser      :: Either UserEmail UserId
     , lrqfSuper     :: Maybe (Either UserEmail UserId)
-    , lrqfQuali     :: Entity Qualification 
+    , lrqfQuali     :: Entity Qualification
     , lrqfIdent     :: LmsIdent
     , lrqfPin       :: Text
     , lrqfExpiry    :: Maybe Day
@@ -63,12 +63,12 @@ makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRe
     <*> areq (userField False Nothing)  (fslI MsgLmsUser)                      (lrqfUser      <$> tmpl)
     <*> aopt (userField False Nothing)  (fslI MsgTableSupervisor)              (lrqfSuper     <$> tmpl)
     <*> areq qualificationFieldEnt      (fslI MsgQualificationName)            (lrqfQuali     <$> tmpl)
-    <*> areq lmsField                   (fslI MsgTableLmsIdent)                (lrqfIdent     <$> tmpl) 
+    <*> areq lmsField                   (fslI MsgTableLmsIdent)                (lrqfIdent     <$> tmpl)
     <*> areq textField                  (fslI MsgTableLmsPin)                  (lrqfPin       <$> tmpl)
     <*> aopt dayField                   (fslI MsgLmsQualificationValidUntil)   (lrqfExpiry    <$> tmpl)
-    <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) 
+    <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant)
                                         (fslI MsgLmsRenewalReminder)           (lrqfReminder  <$> tmpl)
-  where 
+  where
     lmsField = convertField LmsIdent getLmsIdent textField
 
 validateLetterRenewQualificationF :: FormValidator LRQF Handler ()
@@ -77,12 +77,12 @@ validateLetterRenewQualificationF = -- do
   return ()
 
 lrqf2letter :: LRQF -> DB (Entity User, SomeLetter)
-lrqf2letter LRQF{..} 
+lrqf2letter LRQF{..}
-  | lrqfLetter == "r" = do 
+  | lrqfLetter == "r" = do
     usr   <-      getUser lrqfUser
     rcvr  <- mapM getUser lrqfSuper
     now   <- liftIO getCurrentTime
-    let letter = LetterRenewQualificationF 
+    let letter = LetterRenewQualificationF
           { lmsLogin      = lrqfIdent
           , lmsPin        = lrqfPin
           , qualHolderID  = usr ^. _entityKey
@@ -97,13 +97,13 @@ lrqf2letter LRQF{..}
           , isReminder    = lrqfReminder
           }
     return (fromMaybe usr rcvr, SomeLetter letter)
-  | lrqfLetter == "e" || lrqfLetter == "E" = do 
+  | lrqfLetter == "e" || lrqfLetter == "E" = do
     rcvr    <- mapM getUser lrqfSuper
     usr     <-      getUser lrqfUser
     usrShrt <- encrypt $ entityKey usr
     usrUuid <- encrypt $ entityKey usr
     urender <- liftHandler getUrlRender
-    let letter = LetterExpireQualification 
+    let letter = LetterExpireQualification
           { leqHolderCFN   = usrShrt
           , leqHolderID    = usr ^. _entityKey
           , leqHolderDN    = usr ^. _userDisplayName
@@ -112,15 +112,15 @@ lrqf2letter LRQF{..}
           , leqId          = lrqfQuali ^. _entityKey
           , leqName        = lrqfQuali ^. _qualificationName      . _CI
           , leqShort       = lrqfQuali ^. _qualificationShorthand . _CI
-          , leqSchool      = lrqfQuali ^. _qualificationSchool          
+          , leqSchool      = lrqfQuali ^. _qualificationSchool
           , leqUrl         = pure . urender $ ForProfileDataR usrUuid
           }
     return (fromMaybe usr rcvr, SomeLetter letter)
   | otherwise = error "Unknown Letter Type encountered. Use 'e' or 'r' only."
-  where 
+  where
     getUser :: Either UserEmail UserId -> DB (Entity User)
     getUser (Right uid) = getEntity404 uid
-    getUser (Left mail) = getBy404 $ UniqueEmail mail 
+    getUser (Left mail) = getBy404 $ UniqueEmail mail
 
 
 data PJTableAction = PJActAcknowledge | PJActReprint
@@ -191,7 +191,7 @@ pjTableQuery (printJob `E.LeftOuterJoin` recipient
   return (printJob, recipient, sender, course, quali)
 
 mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget)
-mkPJTable = do  
+mkPJTable = do
   let
     dbtSQLQuery = pjTableQuery
     dbtRowKey = queryPrintJob >>> (E.^. PrintJobId)
@@ -226,7 +226,7 @@ mkPJTable = do
     dbtFilter = mconcat
       [ single ("name"         , FilterColumn . E.mkContainsFilterWithCommaPlus id                $ views (to queryPrintJob)      (E.^. PrintJobName))
       , single ("apcid"        , FilterColumn . E.mkContainsFilterWithComma     id                $ views (to queryPrintJob)      (E.^. PrintJobApcIdent))
-      , single ("filename"     , FilterColumn . E.mkContainsFilter                                $ views (to queryPrintJob)      (E.^. PrintJobFilename))      
+      , 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))
       , single ("recipient"    , FilterColumn . E.mkContainsFilterWithCommaPlus Just              $ views (to queryRecipient)     (E.?. UserDisplayName))
@@ -234,7 +234,7 @@ mkPJTable = do
       , single ("course"       , FilterColumn . E.mkContainsFilterWith          (Just . CI.mk)    $ views (to queryCourse)        (E.?. CourseName))
       , single ("qualification", FilterColumn . E.mkContainsFilterWith          (Just . CI.mk)    $ views (to queryQualification) (E.?. QualificationName))
       , single ("lmsid"        , FilterColumn . E.mkContainsFilterWithCommaPlus (Just . LmsIdent) $ views (to queryPrintJob)      (E.^. PrintJobLmsUser))
-      
+
       , single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
       ]
     dbtFilterUI mPrev = mconcat
@@ -289,7 +289,7 @@ mkPJTable = do
 
 getPrintCenterR,  postPrintCenterR :: Handler Html
 getPrintCenterR = postPrintCenterR
-postPrintCenterR = do  
+postPrintCenterR = do
   (pjRes, pjTable) <- runDB mkPJTable
 
   formResult pjRes $ \case
@@ -299,21 +299,21 @@ postPrintCenterR = do
       addMessageI Success $ MsgPrintJobAcknowledge num
       reloadKeepGetParams PrintCenterR
     (PJActReprintData{ignoreReroute}, Set.toList -> pjIds) -> do
-      let countOk = either (const $ Sum 0) (const $ Sum 1)          
+      let countOk = either (const $ Sum 0) (const $ Sum 1)
       oks <- runDB $ forM pjIds $ fmap countOk . reprintPDF (fromMaybe False ignoreReroute)
       let nr_oks = getSum $ mconcat oks
           nr_tot = length pjIds
           mstat  = bool Warning Success $ nr_oks == nr_tot
       addMessageI mstat $ MsgPrintJobReprint nr_oks nr_tot
       reloadKeepGetParams PrintCenterR
-  siteConf <- getYesod  
+  siteConf <- getYesod
   let lprConf = siteConf ^. _appLprConf
       reroute = siteConf ^. _appMailRerouteTo
       lprWgt  = [whamlet|
           LPR Konfiguration ist #{lprQueue lprConf}@#{lprHost lprConf}:#{lprPort lprConf}
           <div>
             $maybe _ <- reroute
-              Mail-reroute-to ist gesetzt, somit werden alle lpr Kommandos unterdrückt!          
+              Mail-reroute-to ist gesetzt, somit werden alle lpr Kommandos unterdrückt!
         |]
   siteLayoutMsg MsgMenuApc $ do
     setTitleI MsgMenuApc
@@ -323,7 +323,7 @@ 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
@@ -341,7 +341,7 @@ postPrintSendR = do
       def_lrqf = mkLetter <$> mbQual
 
   ((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm def_lrqf
-  let procFormSend lrqf = case lrqfLetter lrqf of 
+  let procFormSend lrqf = case lrqfLetter lrqf of
         "E" -> (runDB (lrqf2letter lrqf) >>= printHtml (Just uid)) >>= \case
             Right html -> sendResponse $ toTypedContent html
             Left err -> do
@@ -349,7 +349,7 @@ postPrintSendR = do
               $logErrorS "LPR" msg
               addMessage Error $ toHtml msg
               pure ()
-        _ -> do 
+        _ -> do
             ok <- (runDB (lrqf2letter lrqf) >>= printLetter (Just uid)) >>= \case
               Left err -> do
                 let msg = "PDF printing failed with error: " <> err
@@ -400,26 +400,26 @@ postPrintAckR ackDay numAck chksm = do
         , formSubmit   = FormNoSubmit
         }
   formResult ackRes $ \BtnConfirm -> do
-    numNew <- runDB $ do 
+    numNew <- runDB $ do
-      pjs <- Ex.select $ do 
+      pjs <- Ex.select $ do
         pj <- Ex.from $ Ex.table @PrintJob
-        let pjDay = E.day $ pj Ex.^. PrintJobCreated 
+        let pjDay = E.day $ pj Ex.^. PrintJobCreated
         Ex.where_ $  Ex.isNothing (pj Ex.^. PrintJobAcknowledged)
-              Ex.&&. (pjDay Ex.==. Ex.val ackDay)      
+              Ex.&&. (pjDay Ex.==. Ex.val ackDay)
         return $ pj Ex.^. PrintJobId
       let changed = numAck /= length pjs || chksm /= hash (Set.fromList (Ex.unValue <$> pjs))
       if changed
         then return (-1)
-        else do 
+        else do
           now <- liftIO getCurrentTime
           E.updateCount $ \pj -> do
-            let pjDay = E.day $ pj E.^. PrintJobCreated 
+            let pjDay = E.day $ pj E.^. PrintJobCreated
             E.set pj [ PrintJobAcknowledged E.=. E.justVal now ]
             E.where_ $ E.isNothing (pj E.^. PrintJobAcknowledged)
                   E.&&. (pjDay E.==. E.val ackDay)
           --  Ex.updateCount $ do
             --  pj <- Ex.from $ Ex.table @PrintJob
-            --  let pjDay = E.day $ pj Ex.^. PrintJobCreated 
+            --  let pjDay = E.day $ pj Ex.^. PrintJobCreated
             --  Ex.set pj [ PrintJobAcknowledged Ex.=. Ex.just (Ex.val now) ]
             --  Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged)
                   -- Ex.&&. (pjDay Ex.==. Ex.val ackDay)
@@ -428,29 +428,44 @@ postPrintAckR ackDay numAck chksm = do
       else addMessageI Error     MsgPrintJobAcknowledgeFailed
     redirect PrintCenterR
   ackDayText <- formatTime SelFormatDate ackDay
-  siteLayoutMsg 
+  siteLayoutMsg
-    (MsgPrintJobAcknowledgeQuestion numAck ackDayText) 
+    (MsgPrintJobAcknowledgeQuestion numAck ackDayText)
     ackForm
 
 -- no header csv, containing a single column of lms identifiers (logins)
 -- instance Csv.FromRecord LmsIdent -- default suffices
--- instance Csv.FromRecord Text where 
+-- instance Csv.FromRecord Text where
---   parseRecord v 
+--   parseRecord v
 --     | length v >= 1 = v Csv..! 0
 --     | otherwise     = pure "ERROR"
 
 saveApcident :: UTCTime -> Natural -> Text -> JobDB Natural
 saveApcident t i apci = insert_ (PrintAcknowledge apci t False) >> return (succ i)
 
+
+makeAckUploadForm :: Form FileInfo
+makeAckUploadForm = renderAForm FormStandard $ fileAFormReq "Acknowledge APC-Ident CSV"
+
+getPrintAckDirectR :: Handler Html
+getPrintAckDirectR = do
+  (widget, enctype) <- generateFormPost makeAckUploadForm
+  siteLayoutMsg MsgMenuPrintAck $ do
+    setTitleI MsgMenuPrintAck
+    [whamlet|$newline never
+      <form method=post enctype=#{enctype}>
+        ^{widget}
+        <input type=submit>
+    |]
+
 postPrintAckDirectR :: Handler Html
 postPrintAckDirectR = do
   now <- liftIO getCurrentTime
   (_params, files) <- runRequestBody
   (status, msg) <- case files of
-    [(_fhead,file)] -> do      
+    [(_fhead,file)] -> do
-      runDBJobs $ do        
+      runDBJobs $ do
         enr <- try $ runConduit $ fileSource file
-                -- .| decodeCsvPositional Csv.NoHeader -- decode by separator position                
+                -- .| decodeCsvPositional Csv.NoHeader -- decode by separator position
                 .| decodeUtf8C      -- no CSV, just convert each line to a single text
                 .| linesUnboundedC
                 .| foldMC (saveApcident now) 0
@@ -462,7 +477,7 @@ postPrintAckDirectR = do
             let msg = "Success: received " <> tshow nr <> " APC identifiers to be processed later."
             $logInfoS "LMS" msg
             when (nr > 0) $ queueDBJob JobPrintAck
-            return (ok200, msg)      
+            return (ok200, msg)
     []     -> do
       let msg = "Error: No file received. A file of lms identifiers must be supplied for print job acknowledging."
       $logWarnS "APC" msg
@@ -476,7 +491,7 @@ postPrintAckDirectR = do
 
 getPrintLogR :: Handler Html
 getPrintLogR = do
-  let 
+  let
     logDBTable = DBTable{..}
       where
         resultLog :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) TransactionLog
@@ -485,9 +500,9 @@ getPrintLogR = do
         resultTrans :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) (Aeson.Result Transaction)
         resultTrans = _dbrOutput . _2
 
-        tCell' err c dbr = case view resultTrans dbr of 
+        tCell' err c dbr = case view resultTrans dbr of
           (Aeson.Error msg) -> err msg -- should not happen, due to query filter
-          (Aeson.Success t) -> c t         
+          (Aeson.Success t) -> c t
         tCellErr = tCell' stringCell
         tCell    = tCell' $ const mempty
 
@@ -497,7 +512,7 @@ getPrintLogR = do
             -- E.&&. E.val "interface" E.==. l E.^. TransactionLogInfo E.->>. "transaction" -- not necessary
           return l
         dbtRowKey = (E.^. TransactionLogId)
-        dbtProj = dbtProjSimple $ \(Entity _ l) -> do 
+        dbtProj = dbtProjSimple $ \(Entity _ l) -> do
           return (l, Aeson.fromJSON $ transactionLogInfo l)
         dbtColonnade = dbColonnade $ mconcat
           [ sortable (Just "time")    (i18nCell MsgSystemMessageTimestamp) $ \(view $ resultLog . to transactionLogTime -> t) -> dateTimeCell t
@@ -521,6 +536,6 @@ getPrintLogR = do
         dbtExtraReps = []
     validator = def & defaultSorting [ SortDescBy "time" ]
   tbl <- runDB $ dbTableDB' validator logDBTable
-  siteLayoutMsg MsgMenuPrintLog $ do 
+  siteLayoutMsg MsgMenuPrintLog $ do
     setTitleI MsgMenuPrintLog
     [whamlet|^{tbl}|]