From cc070ed21b7d81829339a1ab81e010996bfe0bd9 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 6 Feb 2023 16:10:56 +0100 Subject: [PATCH] chore(super): split view compiles again --- routes | 25 +- src/Application.hs | 2 +- src/Foundation/Navigation.hs | 40 +- src/Handler/Admin/Avs.hs | 2 +- src/Handler/Qualification.hs | 769 +++++++++++++++---------------- src/Handler/Utils/Table/Cells.hs | 10 +- 6 files changed, 423 insertions(+), 425 deletions(-) diff --git a/routes b/routes index 2264a008f..3cf767103 100644 --- a/routes +++ b/routes @@ -259,29 +259,26 @@ !/#UUID CryptoUUIDDispatchR GET !free -- just redirect -- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists +/qualification QualificationAllR GET !free +/qualification/#SchoolId QualificationSchoolR GET !free +/qualification/#SchoolId/#QualificationShorthand QualificationR GET !free +/qualifications/sap/direct QualificationSAPDirectR GET -- !token -- SAP EXPORT -- TODO reinstate token requirement +-- /qualification/CryptoUUIDUser/ -- maybe distingquish via URL --- SAP export -/qualifications/sap/direct QualificationSAPDirectR GET -- !token --- OSIS CSV Export Demo +-- LMS /lms LmsAllR GET POST /lms/#SchoolId LmsSchoolR GET /lms/#SchoolId/#QualificationShorthand LmsR GET POST /lms/#SchoolId/#QualificationShorthand/limit/#Int64/skip/#Int64 LmsLSR GET POST -- FIXME Pagination does not work here somehow /lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST /lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET -/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET -- development only +/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS /lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST -/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST -- development only -/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token +/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development +/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS /lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST -/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST -- development only -/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token - --- for users --- /qualification QualificationAllR GET !free --- /qualification/#SchoolId/#QualificationShorthand QualificationR GET !free --- /qualification/#SchoolId QualificationSchoolR GET !free --- /qualification/CryptoUUIDUser/ -- maybe distingquish via URL +/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development +/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS /api ApiDocsR GET !free diff --git a/src/Application.hs b/src/Application.hs index 7be8775ac..6592a8342 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -153,7 +153,7 @@ import Handler.Participants import Handler.StorageKey import Handler.Error import Handler.Upload --- import Handler.Qualification +import Handler.Qualification import Handler.LMS import Handler.SAP import Handler.PrintCenter diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 9e66a6ded..7c7aac815 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -159,14 +159,14 @@ breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed --- breadcrumb QualificationAllR = i18nCrumb MsgMenuQualifications Nothing --- breadcrumb (QualificationSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs --- guardM . lift . existsBy . UniqueSchoolShorthand $ unSchoolKey ssh --- return (CI.original $ unSchoolKey ssh, Just QualificationAllR) --- breadcrumb (QualificationR ssh qsh) =useRunDB . maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ QualificationSchoolR ssh) $ do --- guardM . lift . existsBy $ SchoolQualificationShort ssh qsh --- return (CI.original qsh, Just $ QualificationSchoolR ssh) -breadcrumb QualificationSAPDirectR = i18nCrumb MsgMenuSap $ Just LmsAllR -- TODO: QualificationAllR -- never displayed +breadcrumb QualificationAllR = i18nCrumb MsgMenuQualifications Nothing +breadcrumb (QualificationSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs + guardM . lift . existsBy . UniqueSchoolShorthand $ unSchoolKey ssh + return (CI.original $ unSchoolKey ssh, Just QualificationAllR) +breadcrumb (QualificationR ssh qsh) =useRunDB . maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ QualificationSchoolR ssh) $ do + guardM . lift . existsBy $ SchoolQualificationShort ssh qsh + return (CI.original qsh, Just $ QualificationSchoolR ssh) +breadcrumb QualificationSAPDirectR = i18nCrumb MsgMenuSap $ Just QualificationAllR -- never displayed breadcrumb LmsAllR = i18nCrumb MsgMenuLms Nothing breadcrumb (LmsSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs @@ -711,18 +711,18 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navForceActive = False } } - -- , return NavHeader - -- { navHeaderRole = NavHeaderPrimary - -- , navIcon = IconMenuQualification - -- , navLink = NavLink - -- { navLabel = MsgMenuQualifications - -- , navRoute = QualificationAllR - -- , navAccess' = NavAccessHandler $ is _Just <$> maybeAuthId - -- , navType = NavTypeLink { navModal = False } - -- , navQuick' = mempty - -- , navForceActive = False - -- } - -- } + , return NavHeader + { navHeaderRole = NavHeaderPrimary + , navIcon = IconMenuQualification + , navLink = NavLink + { navLabel = MsgMenuQualifications + , navRoute = QualificationAllR + , navAccess' = NavAccessHandler $ is _Just <$> maybeAuthId + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } , return NavHeader { navHeaderRole = NavHeaderPrimary , navIcon = IconMenuLms diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 3ab112505..9b4daf552 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -525,7 +525,7 @@ mkLicenceTable PaginationParameters{..} dbtIdent aLic apids = do (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' icnSuper = text2markup " " <> icon IconSupervisor pure $ toWgt $ mconcat companies - , sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe qualificationShortCell q + , sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> cellMaybe dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index bb7b0b213..8690f8cae 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -15,7 +15,7 @@ module Handler.Qualification import Import --- import Jobs +import Jobs import Handler.Utils -- import Handler.Utils.Csv -- import Handler.Utils.LMS @@ -23,13 +23,13 @@ import Handler.Utils import qualified Data.Set as Set import qualified Data.Map as Map --- import qualified Data.Csv as Csv +import qualified Data.Csv as Csv import qualified Data.Text as T --- import qualified Data.CaseInsensitive as CI --- import qualified Data.Conduit.List as C +import qualified Data.CaseInsensitive as CI +import qualified Data.Conduit.List as C import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Legacy as E --- import qualified Database.Esqueleto.PostgreSQL as E +import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -42,7 +42,7 @@ single = uncurry Map.singleton getQualificationSchoolR :: SchoolId -> Handler Html -getQualificationSchoolR ssh = redirect (LmsAllR, [("qualification-overview-school", toPathPiece ssh)]) --TODO: revert URL +getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)]) getQualificationAllR :: Handler Html getQualificationAllR = do -- TODO just a stub @@ -92,11 +92,11 @@ mkQualificationAllTable = do [ colSchool $ resultAllQualification . _qualificationSchool , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> let qsh = qualificationShorthand quali in - anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qsh --TODO: revert URL + anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> let qsh = qualificationShorthand quali qnm = qualificationName quali - in anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qnm --TODO: revert URL + in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) -> maybeCell (qualificationDescription quali) markupCellLargeModal , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ @@ -149,419 +149,414 @@ mkQualificationAllTable = do -- getQualificationEditR = postQualificationEditR -- postQualificationEditR = error "TODO" -getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html -getQualificationR = postQualificationR -postQualificationR = error "TODO: STUB" +data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. + { ltcDisplayName :: UserDisplayName + , ltcEmail :: UserEmail + , ltcValidUntil :: Day + , ltcLastRefresh :: Day + , ltcFirstHeld :: Day + , ltcBlockedDue :: Maybe QualificationBlocked + , ltcLmsIdent :: Maybe LmsIdent + , ltcLmsStatus :: Maybe LmsStatus + , ltcLmsStarted :: Maybe UTCTime + , ltcLmsDatePin :: Maybe UTCTime + , ltcLmsReceived :: Maybe UTCTime + , ltcLmsNotified :: Maybe UTCTime + , ltcLmsEnded :: Maybe UTCTime + } + deriving Generic +makeLenses_ ''LmsTableCsv --- data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. --- { ltcDisplayName :: UserDisplayName --- , ltcEmail :: UserEmail --- , ltcValidUntil :: Day --- , ltcLastRefresh :: Day --- , ltcFirstHeld :: Day --- , ltcBlockedDue :: Maybe QualificationBlocked --- , ltcLmsIdent :: Maybe LmsIdent --- , ltcLmsStatus :: Maybe LmsStatus --- , ltcLmsStarted :: Maybe UTCTime --- , ltcLmsDatePin :: Maybe UTCTime --- , ltcLmsReceived :: Maybe UTCTime --- , ltcLmsNotified :: Maybe UTCTime --- , ltcLmsEnded :: Maybe UTCTime --- } --- deriving Generic --- makeLenses_ ''LmsTableCsv +ltcExample :: LmsTableCsv +ltcExample = LmsTableCsv + { ltcDisplayName = "Max Mustermann" + , ltcEmail = "m.mustermann@does.not.exist" + , ltcValidUntil = compDay + , ltcLastRefresh = compDay + , ltcFirstHeld = compDay + , ltcBlockedDue = Nothing + , ltcLmsIdent = Nothing + , ltcLmsStatus = Nothing + , ltcLmsStarted = Just compTime + , ltcLmsDatePin = Nothing + , ltcLmsReceived = Nothing + , ltcLmsNotified = Nothing + , ltcLmsEnded = Nothing + } + where + compTime :: UTCTime + compTime = $compileTime + compDay :: Day + compDay = utctDay compTime --- ltcExample :: LmsTableCsv --- ltcExample = LmsTableCsv --- { ltcDisplayName = "Max Mustermann" --- , ltcEmail = "m.mustermann@does.not.exist" --- , ltcValidUntil = compDay --- , ltcLastRefresh = compDay --- , ltcFirstHeld = compDay --- , ltcBlockedDue = Nothing --- , ltcLmsIdent = Nothing --- , ltcLmsStatus = Nothing --- , ltcLmsStarted = Just compTime --- , ltcLmsDatePin = Nothing --- , ltcLmsReceived = Nothing --- , ltcLmsNotified = Nothing --- , ltcLmsEnded = Nothing --- } --- where --- compTime :: UTCTime --- compTime = $compileTime --- compDay :: Day --- compDay = utctDay compTime +ltcOptions :: Csv.Options +ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc } + where + renameLtc "ltcDisplayName" = "licensee" + renameLtc "ltcLmsDatePin" = prefixLms "pin-created" + renameLtc "ltcLmsReceived" = prefixLms "last-update" + renameLtc other = replaceLtc $ camelToPathPiece' 1 other + replaceLtc ('l':'m':'s':'-':t) = prefixLms t + replaceLtc other = other + prefixLms = ("e-learn-" <>) --- ltcOptions :: Csv.Options --- ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc } --- where --- renameLtc "ltcDisplayName" = "licensee" --- renameLtc "ltcLmsDatePin" = prefixLms "pin-created" --- renameLtc "ltcLmsReceived" = prefixLms "last-update" --- renameLtc other = replaceLtc $ camelToPathPiece' 1 other --- replaceLtc ('l':'m':'s':'-':t) = prefixLms t --- replaceLtc other = other --- prefixLms = ("e-learn-" <>) +instance Csv.ToNamedRecord LmsTableCsv where + toNamedRecord = Csv.genericToNamedRecord ltcOptions --- instance Csv.ToNamedRecord LmsTableCsv where --- toNamedRecord = Csv.genericToNamedRecord ltcOptions +instance Csv.DefaultOrdered LmsTableCsv where + headerOrder = Csv.genericHeaderOrder ltcOptions --- instance Csv.DefaultOrdered LmsTableCsv where --- headerOrder = Csv.genericHeaderOrder ltcOptions - --- instance CsvColumnsExplained LmsTableCsv where --- csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList --- [ ('ltcDisplayName, MsgLmsUser) --- , ('ltcEmail , MsgTableLmsEmail) --- , ('ltcValidUntil , MsgLmsQualificationValidUntil) --- , ('ltcLastRefresh, MsgTableQualificationLastRefresh) --- , ('ltcFirstHeld , MsgTableQualificationFirstHeld) --- , ('ltcLmsIdent , MsgTableLmsIdent) --- , ('ltcLmsStatus , MsgTableLmsStatus) --- , ('ltcLmsStarted , MsgTableLmsStarted) --- , ('ltcLmsDatePin , MsgTableLmsDatePin) --- , ('ltcLmsReceived, MsgTableLmsReceived) --- , ('ltcLmsEnded , MsgTableLmsEnded) --- ] +instance CsvColumnsExplained LmsTableCsv where + csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList + [ ('ltcDisplayName, MsgLmsUser) + , ('ltcEmail , MsgTableLmsEmail) + , ('ltcValidUntil , MsgLmsQualificationValidUntil) + , ('ltcLastRefresh, MsgTableQualificationLastRefresh) + , ('ltcFirstHeld , MsgTableQualificationFirstHeld) + , ('ltcLmsIdent , MsgTableLmsIdent) + , ('ltcLmsStatus , MsgTableLmsStatus) + , ('ltcLmsStarted , MsgTableLmsStarted) + , ('ltcLmsDatePin , MsgTableLmsDatePin) + , ('ltcLmsReceived, MsgTableLmsReceived) + , ('ltcLmsEnded , MsgTableLmsEnded) + ] --- type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) --- `E.InnerJoin` E.SqlExpr (Entity User) --- ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) +type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) + `E.InnerJoin` E.SqlExpr (Entity User) + ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) --- queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser) --- queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) +queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser) +queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) --- queryUser :: LmsTableExpr -> E.SqlExpr (Entity User) --- queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1) +queryUser :: LmsTableExpr -> E.SqlExpr (Entity User) +queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1) --- queryLmsUser :: LmsTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) --- queryLmsUser = $(sqlLOJproj 2 2) +queryLmsUser :: LmsTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) +queryLmsUser = $(sqlLOJproj 2 2) --- type LmsTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), E.Value (Maybe [Maybe UTCTime])) +type LmsTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), E.Value (Maybe [Maybe UTCTime])) --- resultQualUser :: Lens' LmsTableData (Entity QualificationUser) --- resultQualUser = _dbrOutput . _1 +resultQualUser :: Lens' LmsTableData (Entity QualificationUser) +resultQualUser = _dbrOutput . _1 --- resultUser :: Lens' LmsTableData (Entity User) --- resultUser = _dbrOutput . _2 +resultUser :: Lens' LmsTableData (Entity User) +resultUser = _dbrOutput . _2 --- resultLmsUser :: Traversal' LmsTableData (Entity LmsUser) --- resultLmsUser = _dbrOutput . _3 . _Just +resultLmsUser :: Traversal' LmsTableData (Entity LmsUser) +resultLmsUser = _dbrOutput . _3 . _Just --- resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime] --- resultPrintAck = _dbrOutput . _4 . _unValue . _Just +resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime] +resultPrintAck = _dbrOutput . _4 . _unValue . _Just --- instance HasEntity LmsTableData User where --- hasEntity = resultUser +instance HasEntity LmsTableData User where + hasEntity = resultUser --- instance HasUser LmsTableData where --- hasUser = resultUser . _entityVal +instance HasUser LmsTableData where + hasUser = resultUser . _entityVal --- data LmsTableAction = LmsActNotify --- | LmsActRenewNotify --- | LmsActRenewPin --- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) +data LmsTableAction = LmsActNotify + | LmsActRenewNotify + | LmsActRenewPin + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) --- instance Universe LmsTableAction --- instance Finite LmsTableAction --- nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2 --- embedRenderMessage ''UniWorX ''LmsTableAction id +instance Universe LmsTableAction +instance Finite LmsTableAction +nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''LmsTableAction id --- -- Not yet needed, since there is no additional data for now: --- data LmsTableActionData = LmsActNotifyData --- | LmsActRenewNotifyData --- | LmsActRenewPinData -- no longer used --- deriving (Eq, Ord, Read, Show, Generic) +-- Not yet needed, since there is no additional data for now: +data LmsTableActionData = LmsActNotifyData + | LmsActRenewNotifyData + | LmsActRenewPinData -- no longer used + deriving (Eq, Ord, Read, Show, Generic) --- isNotifyAct :: LmsTableActionData -> Bool --- isNotifyAct LmsActNotifyData = True --- isNotifyAct LmsActRenewNotifyData = True --- isNotifyAct LmsActRenewPinData = False +isNotifyAct :: LmsTableActionData -> Bool +isNotifyAct LmsActNotifyData = True +isNotifyAct LmsActRenewNotifyData = True +isNotifyAct LmsActRenewPinData = False --- isRenewPinAct :: LmsTableActionData -> Bool --- isRenewPinAct LmsActNotifyData = False --- isRenewPinAct LmsActRenewNotifyData = True --- isRenewPinAct LmsActRenewPinData = True +isRenewPinAct :: LmsTableActionData -> Bool +isRenewPinAct LmsActNotifyData = False +isRenewPinAct LmsActRenewNotifyData = True +isRenewPinAct LmsActRenewPinData = True --- lmsTableQuery :: QualificationId -> LmsTableExpr -> Int64 -> Int64 --- -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) --- , E.SqlExpr (Entity User) --- , E.SqlExpr (Maybe (Entity LmsUser)) --- , E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs --- ) --- lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) nlimit noffset = do --- -- RECALL: another outer join on PrintJob did not work out well, since --- -- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting; --- -- - using noExsists on printJob join condition works, but only deliver single value; --- -- experiments with separate sub-query showed that we would need two subsqueries to learn whether the request was indeed the latest --- E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser --- E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work --- E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser --- E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification --- when (nlimit > 0) $ E.limit nlimit >> E.offset (nlimit * noffset) -- FIXME Pagination does not work here somehow --- -- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other! --- -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken! --- let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do --- E.where_ $ E.isJust (pj E.^. PrintJobLmsUser) --- E.&&. ((lmsUser E.?. LmsUserIdent) E.==. (pj E.^. PrintJobLmsUser)) --- let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on! --- pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this! --- E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder --- return (qualUser, user, lmsUser, printAcknowledged) +lmsTableQuery :: QualificationId -> LmsTableExpr -> Int64 -> Int64 + -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) + , E.SqlExpr (Entity User) + , E.SqlExpr (Maybe (Entity LmsUser)) + , E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs + ) +lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) nlimit noffset = do + -- RECALL: another outer join on PrintJob did not work out well, since + -- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting; + -- - using noExsists on printJob join condition works, but only deliver single value; + -- experiments with separate sub-query showed that we would need two subsqueries to learn whether the request was indeed the latest + E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser + E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work + E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser + E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification + when (nlimit > 0) $ E.limit nlimit >> E.offset (nlimit * noffset) -- FIXME Pagination does not work here somehow + -- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other! + -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken! + let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do + E.where_ $ E.isJust (pj E.^. PrintJobLmsUser) + E.&&. ((lmsUser E.?. LmsUserIdent) E.==. (pj E.^. PrintJobLmsUser)) + let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on! + pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this! + E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder + return (qualUser, user, lmsUser, printAcknowledged) --- newtype LmsTableFilterProj = LmsTableFilterProj { ltProjFilterMayAccess :: Maybe Bool } +newtype LmsTableFilterProj = LmsTableFilterProj { ltProjFilterMayAccess :: Maybe Bool } --- instance Default LmsTableFilterProj where --- def = LmsTableFilterProj --- { ltProjFilterMayAccess = Nothing } +instance Default LmsTableFilterProj where + def = LmsTableFilterProj + { ltProjFilterMayAccess = Nothing } --- makeLenses_ ''LmsTableFilterProj +makeLenses_ ''LmsTableFilterProj --- mkLmsTable :: forall h p cols act act'. --- ( Functor h, ToSortable h --- , Ord act, PathPiece act, RenderMessage UniWorX act --- , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols --- ) --- => Int64 -> Int64 --- -> Bool --- -> Entity Qualification --- -> Map act (AForm Handler act') --- -> cols --- -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData)) --- -> DB (FormResult (act', Set UserId), Widget) --- mkLmsTable nlimit noffset isAdmin (Entity qid quali) acts cols psValidator = do --- now <- liftIO getCurrentTime --- -- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route here --- let --- currentRoute = QualificationR (qualificationSchool quali) (qualificationShorthand quali) --- nowaday = utctDay now --- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday --- csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) --- dbtIdent :: Text --- dbtIdent = "qualification" --- dbtSQLQuery q = lmsTableQuery qid q nlimit noffset --- dbtRowKey = queryUser >>> (E.^. UserId) --- --dbtProj = dbtProjFilteredPostId --- dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do --- qusr <- view $ _dbtProjRow . resultQualUser --- user <- view $ _dbtProjRow . resultUser --- lusr <- preview $ _dbtProjRow . resultLmsUser --- pjac <- preview $ _dbtProjRow . resultPrintAck --- forMM_ (view $ _dbtProjFilter . _ltProjFilterMayAccess) $ \b -> do --- euid <- encrypt $ user ^. _entityKey --- guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ ForProfileDataR euid -- TODO create a page with proper rights; this is only for admins! --- return (qusr,user,lusr,E.Value pjac) +mkLmsTable :: forall h p cols act act'. + ( Functor h, ToSortable h + , Ord act, PathPiece act, RenderMessage UniWorX act + , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols + ) + => Int64 -> Int64 + -> Bool + -> Entity Qualification + -> Map act (AForm Handler act') + -> cols + -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData)) + -> DB (FormResult (act', Set UserId), Widget) +mkLmsTable nlimit noffset isAdmin (Entity qid quali) acts cols psValidator = do + now <- liftIO getCurrentTime + -- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route here + let + currentRoute = QualificationR (qualificationSchool quali) (qualificationShorthand quali) + nowaday = utctDay now + mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday + csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) + dbtIdent :: Text + dbtIdent = "qualification" + dbtSQLQuery q = lmsTableQuery qid q nlimit noffset + dbtRowKey = queryUser >>> (E.^. UserId) + --dbtProj = dbtProjFilteredPostId + dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do + qusr <- view $ _dbtProjRow . resultQualUser + user <- view $ _dbtProjRow . resultUser + lusr <- preview $ _dbtProjRow . resultLmsUser + pjac <- preview $ _dbtProjRow . resultPrintAck + forMM_ (view $ _dbtProjFilter . _ltProjFilterMayAccess) $ \b -> do + euid <- encrypt $ user ^. _entityKey + guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ ForProfileDataR euid -- TODO create a page with proper rights; this is only for admins! + return (qusr,user,lusr,E.Value pjac) --- dbtColonnade = cols --- dbtSorting = mconcat --- [ single $ sortUserNameLink queryUser --- , single $ sortUserEmail queryUser --- , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) --- , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) --- , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) --- , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) --- , single ("schedule-renew", SortColumn $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) --- , single ("lms-ident" , SortColumn $ queryLmsUser >>> (E.?. LmsUserIdent)) --- , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) --- , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted)) --- , single ("lms-datepin" , SortColumn $ queryLmsUser >>> (E.?. LmsUserDatePin)) --- , single ("lms-received" , SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived)) --- , single ("lms-notified" , SortColumn $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date --- , single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded)) + dbtColonnade = cols + dbtSorting = mconcat + [ single $ sortUserNameLink queryUser + , single $ sortUserEmail queryUser + , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) + , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) + , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) + , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) + , single ("schedule-renew", SortColumn $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) + , single ("lms-ident" , SortColumn $ queryLmsUser >>> (E.?. LmsUserIdent)) + , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) + , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted)) + , single ("lms-datepin" , SortColumn $ queryLmsUser >>> (E.?. LmsUserDatePin)) + , single ("lms-received" , SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived)) + , single ("lms-notified" , SortColumn $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date + , single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded)) --- ] --- dbtFilter = mconcat --- [ single ("may-access" , FilterProjected $ (_ltProjFilterMayAccess ?~) . getAny) --- , single $ fltrUserNameEmail queryUser --- , single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent)) --- -- , single ("lms-status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB --- -- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) --- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) --- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> --- if | Just renewal <- mbRenewal --- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal --- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday --- | otherwise -> E.true --- ) --- , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified))) --- ] --- dbtFilterUI mPrev = mconcat --- [ fltrUserNameEmailHdrUI MsgLmsUser mPrev --- , prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) --- -- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus) --- , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) --- , prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified) --- , if isNothing mbRenewal then mempty --- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) --- ] --- dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } --- dbtCsvEncode = Just DBTCsvEncode --- { dbtCsvExportForm = pure () --- , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) --- , dbtCsvName = csvName --- , dbtCsvSheetName = csvName --- , dbtCsvNoExportData = Just id --- , dbtCsvHeader = const $ return $ Csv.headerOrder ltcExample --- , dbtCsvExampleData = Just [ltcExample] --- } --- where --- doEncode' :: LmsTableData -> LmsTableCsv --- doEncode' = LmsTableCsv --- <$> view (resultUser . _entityVal . _userDisplayName) --- <*> view (resultUser . _entityVal . _userEmail) --- <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) --- <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) --- <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) --- <*> view (resultQualUser . _entityVal . _qualificationUserBlockedDue) --- <*> preview (resultLmsUser . _entityVal . _lmsUserIdent) --- <*> (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) --- <*> preview (resultLmsUser . _entityVal . _lmsUserStarted) --- <*> preview (resultLmsUser . _entityVal . _lmsUserDatePin) --- <*> (join . preview (resultLmsUser . _entityVal . _lmsUserReceived)) --- <*> (join . preview (resultLmsUser . _entityVal . _lmsUserNotified)) -- TODO: only exports last email date / print job sending date, not print acknowledge --- <*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded)) --- dbtCsvDecode = Nothing --- dbtExtraReps = [] --- dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else --- DBParamsForm --- { dbParamsFormMethod = POST --- , dbParamsFormAction = Just $ SomeRoute currentRoute --- , dbParamsFormAttrs = [] --- , dbParamsFormSubmit = FormSubmit --- , dbParamsFormAdditional --- = renderAForm FormStandard --- $ (, mempty) . First . Just --- <$> multiActionA acts (fslI MsgTableAction) Nothing --- , dbParamsFormEvaluate = liftHandler . runFormPost --- , dbParamsFormResult = id --- , dbParamsFormIdent = def --- } + ] + dbtFilter = mconcat + [ single ("may-access" , FilterProjected $ (_ltProjFilterMayAccess ?~) . getAny) + , single $ fltrUserNameEmail queryUser + , single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent)) + -- , single ("lms-status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB + -- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) + , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) + , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> + if | Just renewal <- mbRenewal + , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal + E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday + | otherwise -> E.true + ) + , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified))) + ] + dbtFilterUI mPrev = mconcat + [ fltrUserNameEmailHdrUI MsgLmsUser mPrev + , prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) + -- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus) + , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) + , prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified) + , if isNothing mbRenewal then mempty + else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtCsvEncode = Just DBTCsvEncode + { dbtCsvExportForm = pure () + , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) + , dbtCsvName = csvName + , dbtCsvSheetName = csvName + , dbtCsvNoExportData = Just id + , dbtCsvHeader = const $ return $ Csv.headerOrder ltcExample + , dbtCsvExampleData = Just [ltcExample] + } + where + doEncode' :: LmsTableData -> LmsTableCsv + doEncode' = LmsTableCsv + <$> view (resultUser . _entityVal . _userDisplayName) + <*> view (resultUser . _entityVal . _userEmail) + <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) + <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) + <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) + <*> view (resultQualUser . _entityVal . _qualificationUserBlockedDue) + <*> preview (resultLmsUser . _entityVal . _lmsUserIdent) + <*> (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) + <*> preview (resultLmsUser . _entityVal . _lmsUserStarted) + <*> preview (resultLmsUser . _entityVal . _lmsUserDatePin) + <*> (join . preview (resultLmsUser . _entityVal . _lmsUserReceived)) + <*> (join . preview (resultLmsUser . _entityVal . _lmsUserNotified)) -- TODO: only exports last email date / print job sending date, not print acknowledge + <*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded)) + dbtCsvDecode = Nothing + dbtExtraReps = [] + dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else + DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Just $ SomeRoute currentRoute + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional + = renderAForm FormStandard + $ (, mempty) . First . Just + <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormEvaluate = liftHandler . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } --- -- acts :: Map LmsTableAction (AForm Handler LmsTableActionData) --- -- acts = mconcat --- -- [ singletonMap LmsActNotify $ pure LmsActNotifyData --- -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData --- -- ] --- postprocess :: FormResult (First act', DBFormResult UserId Bool LmsTableData) --- -> FormResult ( act', Set UserId) --- postprocess inp = do --- (First (Just act), usrMap) <- inp --- let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap --- return (act, usrSet) + -- acts :: Map LmsTableAction (AForm Handler LmsTableActionData) + -- acts = mconcat + -- [ singletonMap LmsActNotify $ pure LmsActNotifyData + -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData + -- ] + postprocess :: FormResult (First act', DBFormResult UserId Bool LmsTableData) + -> FormResult ( act', Set UserId) + postprocess inp = do + (First (Just act), usrMap) <- inp + let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap + return (act, usrSet) --- -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableActionData)) --- -- resultDBTableValidator = def --- -- & defaultSorting [SortAscBy csvLmsIdent] --- over _1 postprocess <$> dbTable psValidator DBTable{..} + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableActionData)) + -- resultDBTableValidator = def + -- & defaultSorting [SortAscBy csvLmsIdent] + over _1 postprocess <$> dbTable psValidator DBTable{..} --- getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html --- getQualificationR = postQualificationR --- postQualificationR sid qsh = do --- let nlimit = 5000 -- TODO: remove me --- noffset = 0 --- isAdmin <- hasReadAccessTo AdminR --- currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler --- ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do --- qent <- getBy404 $ SchoolQualificationShort sid qsh --- let acts :: Map LmsTableAction (AForm Handler LmsTableActionData) --- acts = mconcat --- [ singletonMap LmsActNotify $ pure LmsActNotifyData --- , singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData --- -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData --- ] --- colChoices = mconcat --- [ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" --- , colUserNameLinkHdr MsgLmsUser AdminUserR --- , colUserEmail --- , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d --- , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d --- , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d --- , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip --- ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b --- , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip --- ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification --- , sortable (Just "lms-ident") (i18nLms MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid --- , sortable (Just "lms-status") (i18nLms MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status --- , sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d --- , sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(preview $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> foldMap dateTimeCell d --- , sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d --- --, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(preview $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d --- , sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row -> --- -- 4 Cases: --- -- - No notification: LmsUserNotified == Nothing --- -- - Email sent : LmsUserNotified == Just _ && PrintJobId == Nothing --- -- - Letter printed : LmsUserNotified == Just _ && PrintJobId == Just _ --- -- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _ --- let notifyDate = join $ row ^? resultLmsUser . _entityVal . _lmsUserNotified --- lmsident = row ^? resultLmsUser . _entityVal . _lmsUserIdent --- recipient = row ^. hasUser --- letterDates = row ^? resultPrintAck --- lastLetterDate = headDef Nothing =<< letterDates --- letterSent = isJust letterDates && (isNothing lastLetterDate || lastLetterDate >= notifyDate) -- was a letter attempted to send last (not 100% safe, if an email is sent after an unacknowledged letter) --- notNotified = isNothing notifyDate --- cIcon = iconFixedCell $ iconLetterOrEmail letterSent --- cDate = if | not letterSent -> foldMap dateTimeCell notifyDate --- | Just d <- lastLetterDate -> dateTimeCell d --- | otherwise -> i18nCell MsgPrintJobUnacknowledged --- lprLink :: Maybe (Route UniWorX) = lmsident <&> (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)])) --- cAckDates = case letterDates of --- Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet| ---

--- _{MsgPrintJobAcknowledgements} ^{userWidget recipient} ---