From 6d44f36e2ac2fce716a53e2b40b8b7f142e1062b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Feb 2024 13:06:39 +0100 Subject: [PATCH] chore(lpr): add manual print-ack csv upload --- .../utils/navigation/menu/de-de-formal.msg | 1 + .../uniworx/utils/navigation/menu/en-eu.msg | 1 + routes | 2 +- src/Foundation/Navigation.hs | 26 +++-- src/Handler/PrintCenter.hs | 107 ++++++++++-------- 5 files changed, 82 insertions(+), 55 deletions(-) diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index c94663cfc..eab4f204e 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/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) diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index e09c56ef1..526c6d871 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/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) diff --git a/routes b/routes index 41f6d1f90..34ad73505 100644 --- a/routes +++ b/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 diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 72095a86d..008e68e08 100644 --- a/src/Foundation/Navigation.hs +++ b/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 = [] diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index bdc6e4572..084cc74d6 100644 --- a/src/Handler/PrintCenter.hs +++ b/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 - { lrqfLetter :: Text +data LRQF = LRQF + { 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{..} - | lrqfLetter == "r" = do +lrqf2letter LRQF{..} + | 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}
$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 - pjs <- Ex.select $ do + numNew <- runDB $ 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 - (MsgPrintJobAcknowledgeQuestion numAck ackDayText) + siteLayoutMsg + (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 --- parseRecord v +-- instance Csv.FromRecord Text where +-- 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 +
+ ^{widget} + + |] + postPrintAckDirectR :: Handler Html postPrintAckDirectR = do now <- liftIO getCurrentTime (_params, files) <- runRequestBody (status, msg) <- case files of - [(_fhead,file)] -> do - runDBJobs $ do + [(_fhead,file)] -> 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}|]