-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.PrintCenter ( getPrintDownloadR , getPrintCenterR, postPrintCenterR , getPrintSendR , postPrintSendR , getPrintAckR , postPrintAckR , getPrintAckDirectR, postPrintAckDirectR , getPrintLogR ) where import Import import qualified Data.Set as Set import qualified Data.Map as Map import Database.Persist.Sql (updateWhereCount) import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Legacy as E -- needed for dbTable using Esqueleto.Legacy import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import Utils.Print import qualified Data.Aeson as Aeson -- import qualified Data.Text as Text -- import qualified Data.Set as Set import Handler.Utils -- import Handler.Utils.Csv -- import qualified Data.Csv as Csv import qualified Data.CaseInsensitive as CI import Jobs.Queue -- avoids repetition of local definitions single :: (k,a) -> Map k a single = uncurry Map.singleton data LRQF = LRQF { lrqfLetter :: Text , lrqfUser :: Either UserEmail UserId , lrqfSuper :: Maybe (Either UserEmail UserId) , lrqfQuali :: Entity Qualification , lrqfIdent :: LmsIdent , lrqfPin :: Text , lrqfExpiry :: Maybe Day , lrqfReminder :: Bool } deriving (Eq, Generic) makeRenewalForm :: Maybe LRQF -> Form LRQF makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRenewQualification $ \html -> do -- now_day <- utctDay <$> liftIO getCurrentTime flip (renderAForm FormStandard) html $ LRQF <$> areq textField (fslI MsgPrintLetterType) (lrqfLetter <$> tmpl) <*> 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 textField (fslI MsgTableLmsPin) (lrqfPin <$> tmpl) <*> aopt dayField (fslI MsgLmsQualificationValidUntil) (lrqfExpiry <$> tmpl) <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgLmsRenewalReminder) (lrqfReminder <$> tmpl) where lmsField = convertField LmsIdent getLmsIdent textField validateLetterRenewQualification :: FormValidator LRQF Handler () validateLetterRenewQualification = -- do -- LRQF{..} <- State.get return () lrqf2letter :: LRQF -> DB (Entity User, SomeLetter) lrqf2letter LRQF{..} | lrqfLetter == "r" = do usr <- getUser lrqfUser rcvr <- mapM getUser lrqfSuper now <- liftIO getCurrentTime let letter = LetterRenewQualification { lmsLogin = lrqfIdent , lmsPin = lrqfPin , qualHolderID = usr ^. _entityKey , qualHolderDN = usr ^. _userDisplayName , qualHolderSN = usr ^. _userSurname , qualExpiry = fromMaybe (utctDay now) lrqfExpiry , qualId = lrqfQuali ^. _entityKey , qualName = lrqfQuali ^. _qualificationName . _CI , qualShort = lrqfQuali ^. _qualificationShorthand . _CI , qualSchool = lrqfQuali ^. _qualificationSchool , qualDuration = lrqfQuali ^. _qualificationValidDuration , qualRenewAuto = lrqfQuali ^. _qualificationElearningRenews , qualELimit = lrqfQuali ^. _qualificationElearningLimit , isReminder = lrqfReminder } return (fromMaybe usr rcvr, SomeLetter letter) | 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 { leqHolderCFN = usrShrt , leqHolderID = usr ^. _entityKey , leqHolderDN = usr ^. _userDisplayName , leqHolderSN = usr ^. _userSurname , leqExpiry = lrqfExpiry , leqId = lrqfQuali ^. _entityKey , leqName = lrqfQuali ^. _qualificationName . _CI , leqShort = lrqfQuali ^. _qualificationShorthand . _CI , 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 getUser :: Either UserEmail UserId -> DB (Entity User) getUser (Right uid) = getEntity404 uid getUser (Left mail) = getBy404 $ UniqueEmail mail data PJTableAction = PJActAcknowledge | PJActReprint deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe PJTableAction instance Finite PJTableAction nullaryPathPiece ''PJTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''PJTableAction id data PJTableActionData = PJActAcknowledgeData | PJActReprintData { ignoreReroute :: Maybe Bool } deriving (Eq, Ord, Read, Show, Generic) type PJTableExpr = ( E.SqlExpr (Entity PrintJob) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Course)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Qualification)) ) queryPrintJob :: PJTableExpr -> E.SqlExpr (Entity PrintJob) queryPrintJob = $(sqlLOJproj 6 1) queryRecipient :: PJTableExpr -> E.SqlExpr (Maybe (Entity User)) queryRecipient = $(sqlLOJproj 6 2) queryAffected :: PJTableExpr -> E.SqlExpr (Maybe (Entity User)) queryAffected = $(sqlLOJproj 6 3) querySender :: PJTableExpr -> E.SqlExpr (Maybe (Entity User)) querySender = $(sqlLOJproj 6 4) queryCourse :: PJTableExpr -> E.SqlExpr (Maybe (Entity Course)) queryCourse = $(sqlLOJproj 6 5) queryQualification :: PJTableExpr -> E.SqlExpr (Maybe (Entity Qualification)) queryQualification = $(sqlLOJproj 6 6) type PJTableData = DBRow (Entity PrintJob, Maybe (Entity User), Maybe (Entity User), Maybe (Entity User), Maybe (Entity Course), Maybe (Entity Qualification)) resultPrintJob :: Lens' PJTableData (Entity PrintJob) resultPrintJob = _dbrOutput . _1 resultRecipient :: Traversal' PJTableData (Entity User) resultRecipient = _dbrOutput . _2 . _Just resultAffected :: Traversal' PJTableData (Entity User) resultAffected = _dbrOutput . _3 . _Just resultSender :: Traversal' PJTableData (Entity User) resultSender = _dbrOutput . _4 . _Just resultCourse :: Traversal' PJTableData (Entity Course) resultCourse = _dbrOutput . _5 . _Just resultQualification :: Traversal' PJTableData (Entity Qualification) resultQualification = _dbrOutput . _6 . _Just pjTableQuery :: PJTableExpr -> E.SqlQuery ( E.SqlExpr (Entity PrintJob) , E.SqlExpr (Maybe (Entity User)) , 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` affected `E.LeftOuterJoin` sender `E.LeftOuterJoin` course `E.LeftOuterJoin` quali ) = do E.on $ printJob E.^. PrintJobRecipient E.==. recipient E.?. UserId E.on $ printJob E.^. PrintJobAffected E.==. affected E.?. UserId E.on $ printJob E.^. PrintJobSender E.==. sender E.?. UserId E.on $ printJob E.^. PrintJobCourse E.==. course E.?. CourseId E.on $ printJob E.^. PrintJobQualification E.==. quali E.?. QualificationId return (printJob, recipient, affected, sender, course, quali) mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget) mkPJTable = do let dbtSQLQuery = pjTableQuery dbtRowKey = queryPrintJob >>> (E.^. PrintJobId) dbtProj = dbtProjId dbtColonnade = mconcat [ dbSelect (applying _2) id (return . view (resultPrintJob . _entityKey)) -- condition for dbSelectIf: (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged) , sortable (Just "created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t , sortable (Just "acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t , 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 . _printJobApcIdent -> t) -> textCell t , 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 "affected") (i18nCell MsgPrintAffected) $ \(preview resultAffected -> 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 , sortable (Just "qualification")(i18nCell MsgPrintQualification) $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell , sortable (Just "lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap (textCell . getLmsIdent) l ] dbtSorting = mconcat [ single ("name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName)) , single ("filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename)) , single ("created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated)) , single ("acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged)) , single ("apcid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobApcIdent)) , single ("recipient" , sortUserNameBareM queryRecipient) , single ("affected" , sortUserNameBareM queryAffected) , single ("sender" , sortUserNameBareM querySender ) , single ("course" , SortColumn $ queryCourse >>> (E.?. CourseName)) , single ("qualification", SortColumn $ queryQualification >>> (E.?. QualificationName)) , single ("lmsid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobLmsUser)) ] 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 ("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)) , single ("affected" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryAffected) (E.?. UserDisplayName)) , single ("sender" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySender) (E.?. UserDisplayName)) , 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 [ prismAForm (singletonFilter "name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName & setTooltip MsgTableFilterCommaPlus) , prismAForm (singletonFilter "filename" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobFilename) , prismAForm (singletonFilter "created" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) --, prismAForm (singletonFilter "created" . maybePrism _PathPiece) mPrev ((,) <$> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) -- <*> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) -- ) , prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlusShort) , prismAForm (singletonFilter "affected" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintAffected & setTooltip MsgTableFilterCommaPlusShort) , prismAForm (singletonFilter "sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender & setTooltip MsgTableFilterCommaPlusShort) , prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse) , prismAForm (singletonFilter "qualification". maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintQualification) , prismAForm (singletonFilter "lmsid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintLmsUser & setTooltip MsgTableFilterCommaPlusShort) , prismAForm (singletonFilter "apcid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobApcAcknowledge & setTooltip MsgTableFilterComma) , prismAForm (singletonFilter "acknowledged" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgPrintJobAcknowledged) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout} dbtIdent :: Text dbtIdent = "print-job" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional = let acts :: Map PJTableAction (AForm Handler PJTableActionData) acts = mconcat [ singletonMap PJActAcknowledge $ pure PJActAcknowledgeData , singletonMap PJActReprint $ PJActReprintData <$> aopt checkBoxField (fslI MsgPJActReprintIgnoreReroute) Nothing ] in renderAForm FormStandard $ (, mempty) . First . Just <$> multiActionA acts (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def } postprocess :: FormResult (First PJTableActionData, DBFormResult PrintJobId Bool PJTableData) -> FormResult ( PJTableActionData, Set PrintJobId) postprocess inp = do (First (Just act), jobMap) <- inp let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap return (act, jobSet) psValidator = def & defaultSorting [SortDescBy "acknowledged", SortDescBy "created"] -- & defaultFilter (singletonMap "acknowledged" [toPathPiece False]) -- TODO: sorting with Nothing restores this filter over _1 postprocess <$> dbTable psValidator DBTable{..} getPrintCenterR, postPrintCenterR :: Handler Html getPrintCenterR = postPrintCenterR postPrintCenterR = do (pjRes, pjTable) <- runDB mkPJTable formResult pjRes $ \case (PJActAcknowledgeData, Set.toList -> pjIds) -> do now <- liftIO getCurrentTime num <- runDB $ updateWhereCount [PrintJobAcknowledged ==. Nothing, PrintJobId <-. pjIds] [PrintJobAcknowledged =. Just now] addMessageI Success $ MsgPrintJobAcknowledge num reloadKeepGetParams PrintCenterR (PJActReprintData{ignoreReroute}, Set.toList -> pjIds) -> do 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 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! |] siteLayoutMsg MsgMenuApc $ do setTitleI MsgMenuApc $(widgetFile "print-center") -- i18nWidgetFile? Currently no text contained; displays just the table only getPrintSendR, postPrintSendR :: Handler Html getPrintSendR = postPrintSendR postPrintSendR = do 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 { lrqfLetter = "r" , lrqfUser = Right uid , lrqfSuper = Nothing , lrqfQuali = qual , lrqfIdent = LmsIdent "stuvwxyz" , lrqfPin = "76543210" , lrqfExpiry = Just $ succ nowaday , lrqfReminder = False } def_lrqf = mkLetter <$> mbQual ((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm def_lrqf let procFormSend lrqf = case lrqfLetter lrqf of "E" -> (runDB (lrqf2letter lrqf) >>= printHtml (Just uid)) >>= \case Right html -> sendResponse $ toTypedContent html Left err -> do let msg = "PDF printing failed with error: " <> err $logErrorS "LPR" msg addMessage Error $ toHtml msg pure () _ -> do ok <- (runDB (lrqf2letter lrqf) >>= printLetter (Just uid)) >>= \case Left err -> do let msg = "PDF printing failed with error: " <> err $logErrorS "LPR" msg addMessage Error $ toHtml msg pure False Right (ok, fpath) -> do let response = if null ok then mempty else " Response: " <> ok addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> pack fpath <> response pure True when ok $ 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 } $(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 sendByteStringAsFile printJobFilename printJobFile printJobCreated {- for PrintJobFile :: FileContentReference use this code, however, requires instances HasFileReference PrintJob and IsFileReference PrintJob which seemed to complicated... :( serveOneFile $ fileQuery .| C.map entityVal where fileQuery = E.selectSource $ E.from $ \pj -> do -- filter to requested file E.where_ (pj E.^. PrintJobId E.==. E.val pjId) -- return file entity return pj -} getPrintAckR, postPrintAckR :: Day -> Int -> Int -> Handler Html getPrintAckR = postPrintAckR postPrintAckR ackDay numAck chksm = do ((ackRes, ackWgt), ackEnctype) <- runFormPost (identifyForm FIDPrintAcknowledge buttonForm :: Form ButtonConfirm) let ackForm = wrapForm ackWgt def { formAction = Just $ SomeRoute $ PrintAckR ackDay numAck chksm , formEncoding = ackEnctype , formSubmit = FormNoSubmit } formResult ackRes $ \BtnConfirm -> do numNew <- runDB $ do pjs <- Ex.select $ do pj <- Ex.from $ Ex.table @PrintJob let pjDay = E.day $ pj Ex.^. PrintJobCreated Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged) 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 now <- liftIO getCurrentTime E.updateCount $ \pj -> do 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 -- Ex.set pj [ PrintJobAcknowledged Ex.=. Ex.just (Ex.val now) ] -- Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged) -- Ex.&&. (pjDay Ex.==. Ex.val ackDay) if numNew > 0 then addMessageI Success $ MsgPrintJobAcknowledge numNew else addMessageI Error MsgPrintJobAcknowledgeFailed redirect PrintCenterR ackDayText <- formatTime SelFormatDate ackDay 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 -- | 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 enr <- try $ runConduit $ fileSource file -- .| decodeCsvPositional Csv.NoHeader -- decode by separator position .| decodeUtf8C -- no CSV, just convert each line to a single text .| linesUnboundedC .| foldMC (saveApcident now) 0 case enr of Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error $logWarnS "APC" $ "Result upload failed parsing: " <> tshow e return (badRequest400, "Error: " <> tshow e) Right nr -> do let msg = "Success: received " <> tshow nr <> " APC identifiers to be processed later." $logInfoS "LMS" msg when (nr > 0) $ queueDBJob JobPrintAck 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 return (badRequest400, msg) _other -> do let msg = "Error: Only a single file may be uploaded for print job acknowlegement; all ignored." $logErrorS "APC" msg return (badRequest400, msg) sendResponseStatus status msg -- must be outside of runDB; otherwise transaction is rolled back getPrintLogR :: Handler Html getPrintLogR = do let logDBTable = DBTable{..} where resultLog :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) TransactionLog resultLog = _dbrOutput . _1 resultTrans :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) (Aeson.Result Transaction) resultTrans = _dbrOutput . _2 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 tCellErr = tCell' stringCell tCell = tCell' $ const mempty dbtIdent = "lpr-log" :: Text dbtSQLQuery l = do E.where_ $ E.val "LPR" E.==. l E.^. TransactionLogInfo E.->>. "interface-name" -- E.&&. E.val "interface" E.==. l E.^. TransactionLogInfo E.->>. "transaction" -- not necessary return l dbtRowKey = (E.^. TransactionLogId) 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 , sortable (Just "status") (textCell "Status") $ tCell (cellMaybe iconBoolCell . transactionInterfaceSuccess) , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype) $ tCell ( textCell . transactionInterfaceSubtype) , sortable (Just "info") (i18nCell MsgSystemMessageContent) $ tCellErr ( textCell . transactionInterfaceInfo) ] dbtSorting = mconcat [ singletonMap "time" $ SortColumn (E.^. TransactionLogTime) , singletonMap "status" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-success") , singletonMap "subtype" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-subtype") , singletonMap "info" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-info" ) ] dbtFilter = mempty dbtFilterUI = mempty dbtStyle = def dbtParams = def dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] validator = def & defaultSorting [ SortDescBy "time" ] tbl <- runDB $ dbTableDB' validator logDBTable siteLayoutMsg MsgMenuPrintLog $ do setTitleI MsgMenuPrintLog [whamlet|^{tbl}|]