diff --git a/routes b/routes index 5b5e5db07..2264a008f 100644 --- a/routes +++ b/routes @@ -67,8 +67,8 @@ /admin/tokens AdminTokensR GET POST /admin/crontab AdminCrontabR GET /admin/avs AdminAvsR GET POST -/admin/ldap AdminLdapR GET POST -/admin/problems AdminProblemsR GET +/admin/ldap AdminLdapR GET POST +/admin/problems AdminProblemsR GET /admin/problems/no-contact ProblemUnreachableR GET /admin/problems/no-avs-id ProblemWithoutAvsId GET /admin/problems/r-without-f ProblemFbutNoR GET @@ -259,18 +259,13 @@ !/#UUID CryptoUUIDDispatchR GET !free -- just redirect -- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists --- for users -/qualification QualificationAllR GET !free -/qualification/#SchoolId QualificationSchoolR GET !free -/qualification/#SchoolId/#QualificationShorthand QualificationR GET !free --- /qualification/#CryptoUUIDUser/ -- maybe distingquish via URL? -- SAP export /qualifications/sap/direct QualificationSAPDirectR GET -- !token -- OSIS CSV Export Demo -/lms LmsAllR GET POST -/lms/#SchoolId LmsSchoolR GET -/lms/#SchoolId/#QualificationShorthand LmsR GET POST +/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 @@ -282,6 +277,13 @@ /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 + + /api ApiDocsR GET !free /swagger SwaggerR GET !free /swagger.json SwaggerJsonR GET !free diff --git a/src/Application.hs b/src/Application.hs index 6592a8342..7be8775ac 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 7c7aac815..9e66a6ded 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 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 LmsAllR -- TODO: 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/LMS.hs b/src/Handler/LMS.hs index 8e53bdba8..6b7b67b71 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -11,7 +11,7 @@ module Handler.LMS , getLmsSchoolR , getLmsR , postLmsR , getLmsLSR , postLmsLSR - -- , getLmsEditR , postLmsEditR + , getLmsEditR , postLmsEditR , getLmsUsersR , getLmsUsersDirectR , getLmsUserlistR , postLmsUserlistR , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR @@ -188,9 +188,9 @@ mkLmsAllTable isAdmin = do --- getLmsEditR, postLmsEditR :: SchoolId -> QualificationShorthand -> Handler Html --- getLmsEditR = postLmsEditR --- postLmsEditR = error "TODO" +getLmsEditR, postLmsEditR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsEditR = postLmsEditR +postLmsEditR = error "TODO: STUB" data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index d8a76807f..bb7b0b213 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -15,21 +15,21 @@ module Handler.Qualification import Import -import Jobs +-- import Jobs import Handler.Utils -- import Handler.Utils.Csv -import Handler.Utils.LMS +-- import Handler.Utils.LMS 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 (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)]) +getQualificationSchoolR ssh = redirect (LmsAllR, [("qualification-overview-school", toPathPiece ssh)]) --TODO: revert URL 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 (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh + anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qsh --TODO: revert URL , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> let qsh = qualificationShorthand quali qnm = qualificationName quali - in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm + in anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qnm --TODO: revert URL , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) -> maybeCell (qualificationDescription quali) markupCellLargeModal , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ @@ -149,416 +149,419 @@ mkQualificationAllTable = do -- getQualificationEditR = postQualificationEditR -- postQualificationEditR = error "TODO" - -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 - -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.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) - ] - - -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) - -queryUser :: LmsTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1) - -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])) - -resultQualUser :: Lens' LmsTableData (Entity QualificationUser) -resultQualUser = _dbrOutput . _1 - -resultUser :: Lens' LmsTableData (Entity User) -resultUser = _dbrOutput . _2 - -resultLmsUser :: Traversal' LmsTableData (Entity LmsUser) -resultLmsUser = _dbrOutput . _3 . _Just - -resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime] -resultPrintAck = _dbrOutput . _4 . _unValue . _Just - -instance HasEntity LmsTableData User where - hasEntity = resultUser - -instance HasUser LmsTableData where - hasUser = resultUser . _entityVal - -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 - --- 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 - -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) - - -newtype LmsTableFilterProj = LmsTableFilterProj { ltProjFilterMayAccess :: Maybe Bool } - -instance Default LmsTableFilterProj where - def = LmsTableFilterProj - { ltProjFilterMayAccess = Nothing } - -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) - - 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 - } - - -- 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{..} - 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} -