398 lines
20 KiB
Haskell
398 lines
20 KiB
Haskell
{-# LANGUAGE TypeApplications #-}
|
|
|
|
module Handler.PrintCenter
|
|
( getPrintCenterR, postPrintCenterR
|
|
, getPrintAcknowR, postPrintAcknowR
|
|
, getPrintSendR , postPrintSendR
|
|
, getPrintDownloadR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
|
|
-- import qualified Data.Text as T
|
|
-- import qualified Data.Text.Lazy as LT
|
|
-- import qualified Data.ByteString.Lazy as LBS
|
|
import qualified Text.Pandoc as P
|
|
import qualified Text.Pandoc.Builder as P
|
|
|
|
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 qualified Control.Monad.State.Class as State
|
|
import Utils.Print
|
|
-- import Data.Aeson (encode)
|
|
-- import qualified Data.Text as Text
|
|
-- import qualified Data.Set as Set
|
|
|
|
import Handler.Utils
|
|
|
|
-- avoids repetition of local definitions
|
|
single :: (k,a) -> Map k a
|
|
single = uncurry Map.singleton
|
|
|
|
data MetaPinRenewal = MetaPinRenewal
|
|
{ mppRecipient :: Text
|
|
, mppAddress :: StoredMarkup
|
|
, mppLogin :: Text
|
|
, mppPin :: Text
|
|
, mppURL :: Maybe URI
|
|
, mppDate :: Day
|
|
, mppLang :: Lang
|
|
, mppOpening :: Maybe Text
|
|
, mppClosing :: Maybe Text
|
|
}
|
|
deriving (Eq, Ord, Show, Generic, Typeable)
|
|
|
|
-- TODO: just for testing, remove in production
|
|
instance Default MetaPinRenewal where
|
|
def = MetaPinRenewal
|
|
{ mppRecipient = "Papa Schlumpf"
|
|
, mppAddress = plaintextToStoredMarkup ("Erdbeerweg 42\n98726 Schlumpfhausen"::Text)
|
|
, mppLogin = "keiner123"
|
|
, mppPin = "89998a"
|
|
, mppURL = Nothing
|
|
, mppDate = fromGregorian 2022 07 27
|
|
, mppLang = "de-de"
|
|
, mppOpening = Just "Lieber Schlumpfi,"
|
|
, mppClosing = Nothing
|
|
}
|
|
|
|
makeRenewalForm :: Maybe MetaPinRenewal -> Form MetaPinRenewal
|
|
makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateMetaPinRenewal $ \html -> do
|
|
now_day <- utctDay <$> liftIO getCurrentTime
|
|
flip (renderAForm FormStandard) html $ MetaPinRenewal
|
|
<$> areq textField (fslI MsgMppRecipient) (mppRecipient <$> tmpl)
|
|
<*> areq htmlField (fslI MsgMppAddress) (mppAddress <$> tmpl)
|
|
<*> areq textField (fslI MsgMppLogin) (mppLogin <$> tmpl)
|
|
<*> areq textField (fslI MsgMppPin) (mppPin <$> tmpl)
|
|
<*> aopt urlField (fslI MsgMppURL) (mppURL <$> tmpl)
|
|
<*> areq dayField (fslI MsgMppDate) ((mppDate <$> tmpl) <|> Just now_day)
|
|
<*> areq (langField True) (fslI MsgMppLang) ((mppLang <$> tmpl) <|> Just "de-de")
|
|
<*> aopt textField (fslI MsgMppOpening) (mppOpening <$> tmpl)
|
|
<*> aopt textField (fslI MsgMppClosing) (mppClosing <$> tmpl)
|
|
|
|
validateMetaPinRenewal :: FormValidator MetaPinRenewal Handler ()
|
|
validateMetaPinRenewal = do
|
|
MetaPinRenewal{..} <- State.get
|
|
guardValidation MsgMppBadLanguage $ isDe mppLang || isEn mppLang
|
|
|
|
|
|
mprToMeta :: MetaPinRenewal -> P.Meta
|
|
mprToMeta MetaPinRenewal{..} = mkMeta
|
|
-- formatTimeUser SelFormatDate mppDate mppRecipient
|
|
[ toMeta "recipient" mppRecipient
|
|
, toMeta "address" (mppRecipient : (mppAddress & html2textlines))
|
|
, toMeta "login" mppLogin
|
|
, toMeta "pin" mppPin
|
|
, mbMeta "url" (mppURL <&> tshow)
|
|
, toMeta "date" (mppDate & tshow) -- rendering according to user preference requires Handler Monad; deferred to Post-processing of P.Meta
|
|
, toMeta "lang" mppLang
|
|
, mbMeta keyOpening mppOpening
|
|
, mbMeta keyClosing mppClosing
|
|
]
|
|
where
|
|
deOrEn = if isDe mppLang then "de" else "en"
|
|
keyOpening = deOrEn <> "-opening"
|
|
keyClosing = deOrEn <> "-closing"
|
|
|
|
mprToMetaUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity User -> MetaPinRenewal -> m P.Meta
|
|
mprToMetaUser entUser@Entity{entityVal = u} mpr = do
|
|
let userLang = userLanguages u >>= (listToMaybe . view _Wrapped) -- auch möglich `op Languages` statt `view _Wrapped`
|
|
meta = mprToMeta mpr{ mppRecipient = userDisplayName u
|
|
-- , mppAddress = userDisplayName u : html2textlines userAddress --TODO once we have User addresses within the DB
|
|
, mppLang = fromMaybe (mppLang mpr) userLang -- check if this is the desired behaviour!
|
|
}
|
|
userDate <- formatTimeUser SelFormatDate (mppDate mpr) (Just entUser)
|
|
return $ P.setMeta "date" userDate meta
|
|
|
|
|
|
data PJTableAction = PJActAcknowledge
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
|
|
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
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
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
|
|
currentRoute <- fromMaybe (error "mkPJTable called from 404-handler") <$> liftHandler getCurrentRoute -- albeit we do know the route here
|
|
let
|
|
dbtSQLQuery = pjTableQuery
|
|
dbtRowKey = queryPrintJob >>> (E.^. PrintJobId)
|
|
dbtProj = dbtProjFilteredPostId
|
|
dbtColonnade = mconcat
|
|
[ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged)
|
|
, sortable (Just "pj-created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t
|
|
, sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t
|
|
, sortable (Just "pj-filename") (i18nCell MsgPrintPDF) $ \r -> let k = r ^. resultPrintJob . _entityKey
|
|
t = r ^. resultPrintJob . _entityVal . _printJobFilename
|
|
in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t)
|
|
, sortable (Just "pj-name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n
|
|
, sortable (Just "pj-recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
|
|
, sortable (Just "pj-sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR
|
|
, sortable (Just "pj-course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell
|
|
, sortable (Just "pj-qualification")(i18nCell MsgPrintQualification) $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell
|
|
, sortable (Just "pj-lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> q) -> ifIconCell (isJust q) IconMenuLms
|
|
]
|
|
dbtSorting = mconcat
|
|
[ single ("pj-name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName))
|
|
, single ("pj-filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename))
|
|
, single ("pj-created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated))
|
|
, single ("pj-acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged))
|
|
, single ("pj-recipient" , sortUserNameBareM queryRecipient)
|
|
, single ("pj-sender" , sortUserNameBareM querySender )
|
|
, single ("pj-course" , SortColumn $ queryCourse >>> (E.?. CourseName))
|
|
, single ("pj-qualification", SortColumn $ queryQualification >>> (E.?. QualificationName))
|
|
, single ("pj-lmsid" , SortColumn $ queryPrintJob >>> (E.isJust . (E.^. PrintJobLmsUser)))
|
|
]
|
|
dbtFilter = mconcat
|
|
[ single ("pj-name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName))
|
|
, single ("pj-filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename))
|
|
, single ("pj-created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
|
|
--, single ("pj-created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
|
|
, single ("pj-recipient" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient) (E.?. UserDisplayName))
|
|
, single ("pj-sender" , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender) (E.?. UserDisplayName))
|
|
, single ("pj-course" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse) (E.?. CourseName))
|
|
, single ("pj-qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName))
|
|
, single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
|
|
]
|
|
dbtFilterUI mPrev = mconcat
|
|
[ prismAForm (singletonFilter "pj-name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName)
|
|
, prismAForm (singletonFilter "pj-filename" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobFilename)
|
|
, prismAForm (singletonFilter "pj-created" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated)
|
|
--, prismAForm (singletonFilter "pj-created" . maybePrism _PathPiece) mPrev ((,) <$> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated)
|
|
-- <*> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated)
|
|
-- )
|
|
, prismAForm (singletonFilter "pj-recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient)
|
|
, prismAForm (singletonFilter "pj-sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender)
|
|
, prismAForm (singletonFilter "pj-course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse)
|
|
, prismAForm (singletonFilter "pj-qualification". maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintQualification)
|
|
, 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 = Just $ SomeRoute currentRoute
|
|
, dbParamsFormAttrs = []
|
|
, dbParamsFormSubmit = FormSubmit
|
|
, dbParamsFormAdditional
|
|
= let acts :: Map PJTableAction (AForm Handler PJTableActionData)
|
|
acts = mconcat
|
|
[ singletonMap PJActAcknowledge $ pure PJActAcknowledgeData
|
|
]
|
|
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 [SortAscBy "pj-created"]
|
|
& defaultFilter (singletonMap "acknowledged" [toPathPiece False])
|
|
over _1 postprocess <$> dbTable psValidator DBTable{..}
|
|
|
|
getPrintCenterR, postPrintCenterR :: Handler Html
|
|
getPrintCenterR = postPrintCenterR
|
|
postPrintCenterR = do
|
|
currentRoute <- fromMaybe (error "printCenterR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
|
|
(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
|
|
redirect currentRoute
|
|
|
|
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
|
|
((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm $ Just def
|
|
let procFormSend mpr = do
|
|
receivers <- runDB $ Ex.select $ do
|
|
user <- Ex.from $ Ex.table @User
|
|
Ex.where_ $ E.val (mppRecipient mpr) `E.isInfixOf` (user E.^. UserIdent)
|
|
pure user
|
|
letters <- case receivers of
|
|
[] -> pure . (Nothing ,) <$> pdfRenewal (mprToMeta mpr)
|
|
_ -> forM receivers $ \usr -> do
|
|
meta <- mprToMetaUser usr mpr
|
|
pdf <- pdfRenewal meta
|
|
return (Just $ entityKey usr, pdf)
|
|
oks <- forM letters $ \case
|
|
(mbRecipient, Right bs) -> do
|
|
-- liftIO $ LBS.writeFile "/tmp/generated.pdf" bs -- DEBUGGING ONLY
|
|
-- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf"
|
|
uID <- maybeAuthId
|
|
runDB (sendLetter "Test-Brief" bs (mbRecipient, uID) Nothing Nothing Nothing) >>= \case -- calls lpr
|
|
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
|
|
(Nothing, Left err) -> do
|
|
addMessage Error $ toHtml err
|
|
pure False
|
|
(Just uid, Left err) -> do
|
|
addMessage Error . toHtml $ "For uid " <> tshow uid <> ": " <> err
|
|
pure False
|
|
when (or oks) $ 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
|
|
-}
|
|
|
|
|
|
getPrintAcknowR, postPrintAcknowR :: Day -> Int -> Int -> Handler Html
|
|
getPrintAcknowR = postPrintAcknowR
|
|
postPrintAcknowR ackDay numAck chksm = do
|
|
((ackRes, ackWgt), ackEnctype) <- runFormPost (identifyForm FIDPrintAcknowledge buttonForm :: Form ButtonConfirm)
|
|
let ackForm = wrapForm ackWgt def
|
|
{ formAction = Just $ SomeRoute $ PrintAcknowR 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.just (E.val 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
|
|
|