542 lines
27 KiB
Haskell
542 lines
27 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- 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
|
|
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 validateLetterRenewQualificationF $ \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
|
|
|
|
validateLetterRenewQualificationF :: FormValidator LRQF Handler ()
|
|
validateLetterRenewQualificationF = -- 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 = LetterRenewQualificationF
|
|
{ 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
|
|
, 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
|
|
|
|
-- Not yet needed, since there is no additional data for now:
|
|
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 Course))
|
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Qualification))
|
|
)
|
|
|
|
queryPrintJob :: PJTableExpr -> E.SqlExpr (Entity PrintJob)
|
|
queryPrintJob = $(sqlLOJproj 5 1)
|
|
|
|
queryRecipient :: PJTableExpr -> E.SqlExpr (Maybe (Entity User))
|
|
queryRecipient = $(sqlLOJproj 5 2)
|
|
|
|
querySender :: PJTableExpr -> E.SqlExpr (Maybe (Entity User))
|
|
querySender = $(sqlLOJproj 5 3)
|
|
|
|
queryCourse :: PJTableExpr -> E.SqlExpr (Maybe (Entity Course))
|
|
queryCourse = $(sqlLOJproj 5 4)
|
|
|
|
queryQualification :: PJTableExpr -> E.SqlExpr (Maybe (Entity Qualification))
|
|
queryQualification = $(sqlLOJproj 5 5)
|
|
|
|
type PJTableData = DBRow (Entity PrintJob, 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
|
|
|
|
resultSender :: Traversal' PJTableData (Entity User)
|
|
resultSender = _dbrOutput . _3 . _Just
|
|
|
|
resultCourse :: Traversal' PJTableData (Entity Course)
|
|
resultCourse = _dbrOutput . _4 . _Just
|
|
|
|
resultQualification :: Traversal' PJTableData (Entity Qualification)
|
|
resultQualification = _dbrOutput . _5 . _Just
|
|
|
|
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
|
|
`E.LeftOuterJoin` course
|
|
`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
|
|
E.on $ printJob E.^. PrintJobQualification E.==. quali E.?. QualificationId
|
|
return (printJob, recipient, 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 "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 ("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 ("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 MsgTableFilterCommaPlus)
|
|
, prismAForm (singletonFilter "sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender & setTooltip MsgTableFilterCommaPlus)
|
|
, 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 MsgTableFilterCommaPlus)
|
|
, 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}
|
|
<div>
|
|
$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
|
|
<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
|
|
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}|]
|