fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(super): split view compiles again

Browse Source
This commit is contained in:
Steffen Jost 2023-02-06 16:10:56 +01:00
parent 2de8ee0ee6
commit cc070ed21b
6 changed files with 423 additions and 425 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
routes
View File

@ -259,29 +259,26 @@
!/#UUID CryptoUUIDDispatchR GET !free -- just redirect !/#UUID CryptoUUIDDispatchR GET !free -- just redirect
-- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists -- !/*{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 -- LMS
/qualifications/sap/direct QualificationSAPDirectR GET -- !token
-- OSIS CSV Export Demo
/lms LmsAllR GET POST /lms LmsAllR GET POST
/lms/#SchoolId LmsSchoolR GET /lms/#SchoolId LmsSchoolR GET
/lms/#SchoolId/#QualificationShorthand LmsR GET POST /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/limit/#Int64/skip/#Int64 LmsLSR GET POST -- FIXME Pagination does not work here somehow
/lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST /lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST
/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET /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 LmsUserlistR GET POST
/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST -- development only /lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development
/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token /lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS
/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST /lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST
/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST -- development only /lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development
/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token /lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS
-- 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 /api ApiDocsR GET !free

2
src/Application.hs
View File

@ -153,7 +153,7 @@ import Handler.Participants
import Handler.StorageKey import Handler.StorageKey
import Handler.Error import Handler.Error
import Handler.Upload import Handler.Upload
-- import Handler.Qualification import Handler.Qualification
import Handler.LMS import Handler.LMS
import Handler.SAP import Handler.SAP
import Handler.PrintCenter import Handler.PrintCenter

40
src/Foundation/Navigation.hs
View File

@ -159,14 +159,14 @@ breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing
breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing
breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed
-- breadcrumb QualificationAllR = i18nCrumb MsgMenuQualifications Nothing breadcrumb QualificationAllR = i18nCrumb MsgMenuQualifications Nothing
-- breadcrumb (QualificationSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs breadcrumb (QualificationSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs
-- guardM . lift . existsBy . UniqueSchoolShorthand $ unSchoolKey ssh guardM . lift . existsBy . UniqueSchoolShorthand $ unSchoolKey ssh
-- return (CI.original $ unSchoolKey ssh, Just QualificationAllR) return (CI.original $ unSchoolKey ssh, Just QualificationAllR)
-- breadcrumb (QualificationR ssh qsh) =useRunDB . maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ QualificationSchoolR ssh) $ do breadcrumb (QualificationR ssh qsh) =useRunDB . maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ QualificationSchoolR ssh) $ do
-- guardM . lift . existsBy $ SchoolQualificationShort ssh qsh guardM . lift . existsBy $ SchoolQualificationShort ssh qsh
-- return (CI.original qsh, Just $ QualificationSchoolR ssh) return (CI.original qsh, Just $ QualificationSchoolR ssh)
breadcrumb QualificationSAPDirectR = i18nCrumb MsgMenuSap $ Just LmsAllR -- TODO: QualificationAllR -- never displayed breadcrumb QualificationSAPDirectR = i18nCrumb MsgMenuSap $ Just QualificationAllR -- never displayed
breadcrumb LmsAllR = i18nCrumb MsgMenuLms Nothing breadcrumb LmsAllR = i18nCrumb MsgMenuLms Nothing
breadcrumb (LmsSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs 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 , navForceActive = False
} }
} }
-- , return NavHeader , return NavHeader
-- { navHeaderRole = NavHeaderPrimary { navHeaderRole = NavHeaderPrimary
-- , navIcon = IconMenuQualification , navIcon = IconMenuQualification
-- , navLink = NavLink , navLink = NavLink
-- { navLabel = MsgMenuQualifications { navLabel = MsgMenuQualifications
-- , navRoute = QualificationAllR , navRoute = QualificationAllR
-- , navAccess' = NavAccessHandler $ is _Just <$> maybeAuthId , navAccess' = NavAccessHandler $ is _Just <$> maybeAuthId
-- , navType = NavTypeLink { navModal = False } , navType = NavTypeLink { navModal = False }
-- , navQuick' = mempty , navQuick' = mempty
-- , navForceActive = False , navForceActive = False
-- } }
-- } }
, return NavHeader , return NavHeader
{ navHeaderRole = NavHeaderPrimary { navHeaderRole = NavHeaderPrimary
, navIcon = IconMenuLms , navIcon = IconMenuLms

2
src/Handler/Admin/Avs.hs
View File

@ -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' (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
icnSuper = text2markup " " <> icon IconSupervisor icnSuper = text2markup " " <> icon IconSupervisor
pure $ toWgt $ mconcat companies 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 "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 "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 , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d

769
src/Handler/Qualification.hs
View File

@ -15,7 +15,7 @@ module Handler.Qualification
import Import import Import
-- import Jobs import Jobs
import Handler.Utils import Handler.Utils
-- import Handler.Utils.Csv -- import Handler.Utils.Csv
-- import Handler.Utils.LMS -- import Handler.Utils.LMS
@ -23,13 +23,13 @@ import Handler.Utils
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Map as Map 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.Text as T
-- import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
-- import qualified Data.Conduit.List as C import qualified Data.Conduit.List as C
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Legacy as E 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 qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
@ -42,7 +42,7 @@ single = uncurry Map.singleton
getQualificationSchoolR :: SchoolId -> Handler Html 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 :: Handler Html
getQualificationAllR = do -- TODO just a stub getQualificationAllR = do -- TODO just a stub
@ -92,11 +92,11 @@ mkQualificationAllTable = do
[ colSchool $ resultAllQualification . _qualificationSchool [ colSchool $ resultAllQualification . _qualificationSchool
, sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) ->
let qsh = qualificationShorthand quali in 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) -> , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) ->
let qsh = qualificationShorthand quali let qsh = qualificationShorthand quali
qnm = qualificationName 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) -> , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) ->
maybeCell (qualificationDescription quali) markupCellLargeModal maybeCell (qualificationDescription quali) markupCellLargeModal
, sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $
@ -149,419 +149,414 @@ mkQualificationAllTable = do
-- getQualificationEditR = postQualificationEditR -- getQualificationEditR = postQualificationEditR
-- postQualificationEditR = error "TODO" -- postQualificationEditR = error "TODO"
getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc..
getQualificationR = postQualificationR { ltcDisplayName :: UserDisplayName
postQualificationR = error "TODO: STUB" , 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.. ltcExample :: LmsTableCsv
-- { ltcDisplayName :: UserDisplayName ltcExample = LmsTableCsv
-- , ltcEmail :: UserEmail { ltcDisplayName = "Max Mustermann"
-- , ltcValidUntil :: Day , ltcEmail = "m.mustermann@does.not.exist"
-- , ltcLastRefresh :: Day , ltcValidUntil = compDay
-- , ltcFirstHeld :: Day , ltcLastRefresh = compDay
-- , ltcBlockedDue :: Maybe QualificationBlocked , ltcFirstHeld = compDay
-- , ltcLmsIdent :: Maybe LmsIdent , ltcBlockedDue = Nothing
-- , ltcLmsStatus :: Maybe LmsStatus , ltcLmsIdent = Nothing
-- , ltcLmsStarted :: Maybe UTCTime , ltcLmsStatus = Nothing
-- , ltcLmsDatePin :: Maybe UTCTime , ltcLmsStarted = Just compTime
-- , ltcLmsReceived :: Maybe UTCTime , ltcLmsDatePin = Nothing
-- , ltcLmsNotified :: Maybe UTCTime , ltcLmsReceived = Nothing
-- , ltcLmsEnded :: Maybe UTCTime , ltcLmsNotified = Nothing
-- } , ltcLmsEnded = Nothing
-- deriving Generic }
-- makeLenses_ ''LmsTableCsv where
compTime :: UTCTime
compTime = $compileTime
compDay :: Day
compDay = utctDay compTime
-- ltcExample :: LmsTableCsv ltcOptions :: Csv.Options
-- ltcExample = LmsTableCsv ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
-- { ltcDisplayName = "Max Mustermann" where
-- , ltcEmail = "m.mustermann@does.not.exist" renameLtc "ltcDisplayName" = "licensee"
-- , ltcValidUntil = compDay renameLtc "ltcLmsDatePin" = prefixLms "pin-created"
-- , ltcLastRefresh = compDay renameLtc "ltcLmsReceived" = prefixLms "last-update"
-- , ltcFirstHeld = compDay renameLtc other = replaceLtc $ camelToPathPiece' 1 other
-- , ltcBlockedDue = Nothing replaceLtc ('l':'m':'s':'-':t) = prefixLms t
-- , ltcLmsIdent = Nothing replaceLtc other = other
-- , ltcLmsStatus = Nothing prefixLms = ("e-learn-" <>)
-- , ltcLmsStarted = Just compTime
-- , ltcLmsDatePin = Nothing
-- , ltcLmsReceived = Nothing
-- , ltcLmsNotified = Nothing
-- , ltcLmsEnded = Nothing
-- }
-- where
-- compTime :: UTCTime
-- compTime = $compileTime
-- compDay :: Day
-- compDay = utctDay compTime
-- ltcOptions :: Csv.Options instance Csv.ToNamedRecord LmsTableCsv where
-- ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc } toNamedRecord = Csv.genericToNamedRecord ltcOptions
-- 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 instance Csv.DefaultOrdered LmsTableCsv where
-- toNamedRecord = Csv.genericToNamedRecord ltcOptions headerOrder = Csv.genericHeaderOrder ltcOptions
-- instance Csv.DefaultOrdered LmsTableCsv where instance CsvColumnsExplained LmsTableCsv where
-- headerOrder = Csv.genericHeaderOrder ltcOptions csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList
[ ('ltcDisplayName, MsgLmsUser)
-- instance CsvColumnsExplained LmsTableCsv where , ('ltcEmail , MsgTableLmsEmail)
-- csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList , ('ltcValidUntil , MsgLmsQualificationValidUntil)
-- [ ('ltcDisplayName, MsgLmsUser) , ('ltcLastRefresh, MsgTableQualificationLastRefresh)
-- , ('ltcEmail , MsgTableLmsEmail) , ('ltcFirstHeld , MsgTableQualificationFirstHeld)
-- , ('ltcValidUntil , MsgLmsQualificationValidUntil) , ('ltcLmsIdent , MsgTableLmsIdent)
-- , ('ltcLastRefresh, MsgTableQualificationLastRefresh) , ('ltcLmsStatus , MsgTableLmsStatus)
-- , ('ltcFirstHeld , MsgTableQualificationFirstHeld) , ('ltcLmsStarted , MsgTableLmsStarted)
-- , ('ltcLmsIdent , MsgTableLmsIdent) , ('ltcLmsDatePin , MsgTableLmsDatePin)
-- , ('ltcLmsStatus , MsgTableLmsStatus) , ('ltcLmsReceived, MsgTableLmsReceived)
-- , ('ltcLmsStarted , MsgTableLmsStarted) , ('ltcLmsEnded , MsgTableLmsEnded)
-- , ('ltcLmsDatePin , MsgTableLmsDatePin) ]
-- , ('ltcLmsReceived, MsgTableLmsReceived)
-- , ('ltcLmsEnded , MsgTableLmsEnded)
-- ]
-- type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser)
-- `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)
-- ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
-- queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser) queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser)
-- queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1)
-- queryUser :: LmsTableExpr -> E.SqlExpr (Entity User) queryUser :: LmsTableExpr -> E.SqlExpr (Entity User)
-- queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1) queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1)
-- queryLmsUser :: LmsTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) queryLmsUser :: LmsTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
-- queryLmsUser = $(sqlLOJproj 2 2) 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 :: Lens' LmsTableData (Entity QualificationUser)
-- resultQualUser = _dbrOutput . _1 resultQualUser = _dbrOutput . _1
-- resultUser :: Lens' LmsTableData (Entity User) resultUser :: Lens' LmsTableData (Entity User)
-- resultUser = _dbrOutput . _2 resultUser = _dbrOutput . _2
-- resultLmsUser :: Traversal' LmsTableData (Entity LmsUser) resultLmsUser :: Traversal' LmsTableData (Entity LmsUser)
-- resultLmsUser = _dbrOutput . _3 . _Just resultLmsUser = _dbrOutput . _3 . _Just
-- resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime] resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime]
-- resultPrintAck = _dbrOutput . _4 . _unValue . _Just resultPrintAck = _dbrOutput . _4 . _unValue . _Just
-- instance HasEntity LmsTableData User where instance HasEntity LmsTableData User where
-- hasEntity = resultUser hasEntity = resultUser
-- instance HasUser LmsTableData where instance HasUser LmsTableData where
-- hasUser = resultUser . _entityVal hasUser = resultUser . _entityVal
-- data LmsTableAction = LmsActNotify data LmsTableAction = LmsActNotify
-- | LmsActRenewNotify | LmsActRenewNotify
-- | LmsActRenewPin | LmsActRenewPin
-- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-- instance Universe LmsTableAction instance Universe LmsTableAction
-- instance Finite LmsTableAction instance Finite LmsTableAction
-- nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2 nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2
-- embedRenderMessage ''UniWorX ''LmsTableAction id embedRenderMessage ''UniWorX ''LmsTableAction id
-- -- Not yet needed, since there is no additional data for now: -- Not yet needed, since there is no additional data for now:
-- data LmsTableActionData = LmsActNotifyData data LmsTableActionData = LmsActNotifyData
-- | LmsActRenewNotifyData | LmsActRenewNotifyData
-- | LmsActRenewPinData -- no longer used | LmsActRenewPinData -- no longer used
-- deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)
-- isNotifyAct :: LmsTableActionData -> Bool isNotifyAct :: LmsTableActionData -> Bool
-- isNotifyAct LmsActNotifyData = True isNotifyAct LmsActNotifyData = True
-- isNotifyAct LmsActRenewNotifyData = True isNotifyAct LmsActRenewNotifyData = True
-- isNotifyAct LmsActRenewPinData = False isNotifyAct LmsActRenewPinData = False
-- isRenewPinAct :: LmsTableActionData -> Bool isRenewPinAct :: LmsTableActionData -> Bool
-- isRenewPinAct LmsActNotifyData = False isRenewPinAct LmsActNotifyData = False
-- isRenewPinAct LmsActRenewNotifyData = True isRenewPinAct LmsActRenewNotifyData = True
-- isRenewPinAct LmsActRenewPinData = True isRenewPinAct LmsActRenewPinData = True
-- lmsTableQuery :: QualificationId -> LmsTableExpr -> Int64 -> Int64 lmsTableQuery :: QualificationId -> LmsTableExpr -> Int64 -> Int64
-- -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
-- , E.SqlExpr (Entity User) , E.SqlExpr (Entity User)
-- , E.SqlExpr (Maybe (Entity LmsUser)) , 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 , 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 lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) nlimit noffset = do
-- -- RECALL: another outer join on PrintJob did not work out well, since -- 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; -- - 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; -- - 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 -- 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.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.&&. 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.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
-- E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification 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 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! -- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other!
-- -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken! -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken!
-- let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
-- E.where_ $ E.isJust (pj E.^. PrintJobLmsUser) E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
-- E.&&. ((lmsUser E.?. LmsUserIdent) E.==. (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! 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! 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 E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
-- return (qualUser, user, lmsUser, printAcknowledged) return (qualUser, user, lmsUser, printAcknowledged)
-- newtype LmsTableFilterProj = LmsTableFilterProj { ltProjFilterMayAccess :: Maybe Bool } newtype LmsTableFilterProj = LmsTableFilterProj { ltProjFilterMayAccess :: Maybe Bool }
-- instance Default LmsTableFilterProj where instance Default LmsTableFilterProj where
-- def = LmsTableFilterProj def = LmsTableFilterProj
-- { ltProjFilterMayAccess = Nothing } { ltProjFilterMayAccess = Nothing }
-- makeLenses_ ''LmsTableFilterProj makeLenses_ ''LmsTableFilterProj
-- mkLmsTable :: forall h p cols act act'. mkLmsTable :: forall h p cols act act'.
-- ( Functor h, ToSortable h ( Functor h, ToSortable h
-- , Ord act, PathPiece act, RenderMessage UniWorX act , Ord act, PathPiece act, RenderMessage UniWorX act
-- , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols
-- ) )
-- => Int64 -> Int64 => Int64 -> Int64
-- -> Bool -> Bool
-- -> Entity Qualification -> Entity Qualification
-- -> Map act (AForm Handler act') -> Map act (AForm Handler act')
-- -> cols -> cols
-- -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData)) -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))
-- -> DB (FormResult (act', Set UserId), Widget) -> DB (FormResult (act', Set UserId), Widget)
-- mkLmsTable nlimit noffset isAdmin (Entity qid quali) acts cols psValidator = do mkLmsTable nlimit noffset isAdmin (Entity qid quali) acts cols psValidator = do
-- now <- liftIO getCurrentTime now <- liftIO getCurrentTime
-- -- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route here -- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route here
-- let let
-- currentRoute = QualificationR (qualificationSchool quali) (qualificationShorthand quali) currentRoute = QualificationR (qualificationSchool quali) (qualificationShorthand quali)
-- nowaday = utctDay now nowaday = utctDay now
-- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
-- csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
-- dbtIdent :: Text dbtIdent :: Text
-- dbtIdent = "qualification" dbtIdent = "qualification"
-- dbtSQLQuery q = lmsTableQuery qid q nlimit noffset dbtSQLQuery q = lmsTableQuery qid q nlimit noffset
-- dbtRowKey = queryUser >>> (E.^. UserId) dbtRowKey = queryUser >>> (E.^. UserId)
-- --dbtProj = dbtProjFilteredPostId --dbtProj = dbtProjFilteredPostId
-- dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do
-- qusr <- view $ _dbtProjRow . resultQualUser qusr <- view $ _dbtProjRow . resultQualUser
-- user <- view $ _dbtProjRow . resultUser user <- view $ _dbtProjRow . resultUser
-- lusr <- preview $ _dbtProjRow . resultLmsUser lusr <- preview $ _dbtProjRow . resultLmsUser
-- pjac <- preview $ _dbtProjRow . resultPrintAck pjac <- preview $ _dbtProjRow . resultPrintAck
-- forMM_ (view $ _dbtProjFilter . _ltProjFilterMayAccess) $ \b -> do forMM_ (view $ _dbtProjFilter . _ltProjFilterMayAccess) $ \b -> do
-- euid <- encrypt $ user ^. _entityKey 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! 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) return (qusr,user,lusr,E.Value pjac)
-- dbtColonnade = cols dbtColonnade = cols
-- dbtSorting = mconcat dbtSorting = mconcat
-- [ single $ sortUserNameLink queryUser [ single $ sortUserNameLink queryUser
-- , single $ sortUserEmail queryUser , single $ sortUserEmail queryUser
-- , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
-- , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
-- , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
-- , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
-- , single ("schedule-renew", SortColumn $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) , single ("schedule-renew", SortColumn $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
-- , single ("lms-ident" , SortColumn $ queryLmsUser >>> (E.?. LmsUserIdent)) , single ("lms-ident" , SortColumn $ queryLmsUser >>> (E.?. LmsUserIdent))
-- , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
-- , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted)) , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted))
-- , single ("lms-datepin" , SortColumn $ queryLmsUser >>> (E.?. LmsUserDatePin)) , single ("lms-datepin" , SortColumn $ queryLmsUser >>> (E.?. LmsUserDatePin))
-- , single ("lms-received" , SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived)) , single ("lms-received" , SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived))
-- , single ("lms-notified" , SortColumn $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date , single ("lms-notified" , SortColumn $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date
-- , single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded)) , single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded))
-- ] ]
-- dbtFilter = mconcat dbtFilter = mconcat
-- [ single ("may-access" , FilterProjected $ (_ltProjFilterMayAccess ?~) . getAny) [ single ("may-access" , FilterProjected $ (_ltProjFilterMayAccess ?~) . getAny)
-- , single $ fltrUserNameEmail queryUser , single $ fltrUserNameEmail queryUser
-- , single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent)) , 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 ("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) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
-- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday))
-- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
-- if | Just renewal <- mbRenewal if | Just renewal <- mbRenewal
-- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
-- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
-- | otherwise -> E.true | otherwise -> E.true
-- ) )
-- , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified))) , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified)))
-- ] ]
-- dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
-- [ fltrUserNameEmailHdrUI MsgLmsUser mPrev [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
-- , prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) , 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 "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 "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) , prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified)
-- , if isNothing mbRenewal then mempty , if isNothing mbRenewal then mempty
-- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
-- ] ]
-- dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
-- dbtCsvEncode = Just DBTCsvEncode dbtCsvEncode = Just DBTCsvEncode
-- { dbtCsvExportForm = pure () { dbtCsvExportForm = pure ()
-- , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
-- , dbtCsvName = csvName , dbtCsvName = csvName
-- , dbtCsvSheetName = csvName , dbtCsvSheetName = csvName
-- , dbtCsvNoExportData = Just id , dbtCsvNoExportData = Just id
-- , dbtCsvHeader = const $ return $ Csv.headerOrder ltcExample , dbtCsvHeader = const $ return $ Csv.headerOrder ltcExample
-- , dbtCsvExampleData = Just [ltcExample] , dbtCsvExampleData = Just [ltcExample]
-- } }
-- where where
-- doEncode' :: LmsTableData -> LmsTableCsv doEncode' :: LmsTableData -> LmsTableCsv
-- doEncode' = LmsTableCsv doEncode' = LmsTableCsv
-- <$> view (resultUser . _entityVal . _userDisplayName) <$> view (resultUser . _entityVal . _userDisplayName)
-- <*> view (resultUser . _entityVal . _userEmail) <*> view (resultUser . _entityVal . _userEmail)
-- <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
-- <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
-- <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld)
-- <*> view (resultQualUser . _entityVal . _qualificationUserBlockedDue) <*> view (resultQualUser . _entityVal . _qualificationUserBlockedDue)
-- <*> preview (resultLmsUser . _entityVal . _lmsUserIdent) <*> preview (resultLmsUser . _entityVal . _lmsUserIdent)
-- <*> (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) <*> (join . preview (resultLmsUser . _entityVal . _lmsUserStatus))
-- <*> preview (resultLmsUser . _entityVal . _lmsUserStarted) <*> preview (resultLmsUser . _entityVal . _lmsUserStarted)
-- <*> preview (resultLmsUser . _entityVal . _lmsUserDatePin) <*> preview (resultLmsUser . _entityVal . _lmsUserDatePin)
-- <*> (join . preview (resultLmsUser . _entityVal . _lmsUserReceived)) <*> (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 . _lmsUserNotified)) -- TODO: only exports last email date / print job sending date, not print acknowledge
-- <*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded)) <*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded))
-- dbtCsvDecode = Nothing dbtCsvDecode = Nothing
-- dbtExtraReps = [] dbtExtraReps = []
-- dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else
-- DBParamsForm DBParamsForm
-- { dbParamsFormMethod = POST { dbParamsFormMethod = POST
-- , dbParamsFormAction = Just $ SomeRoute currentRoute , dbParamsFormAction = Just $ SomeRoute currentRoute
-- , dbParamsFormAttrs = [] , dbParamsFormAttrs = []
-- , dbParamsFormSubmit = FormSubmit , dbParamsFormSubmit = FormSubmit
-- , dbParamsFormAdditional , dbParamsFormAdditional
-- = renderAForm FormStandard = renderAForm FormStandard
-- $ (, mempty) . First . Just $ (, mempty) . First . Just
-- <$> multiActionA acts (fslI MsgTableAction) Nothing <$> multiActionA acts (fslI MsgTableAction) Nothing
-- , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormEvaluate = liftHandler . runFormPost
-- , dbParamsFormResult = id , dbParamsFormResult = id
-- , dbParamsFormIdent = def , dbParamsFormIdent = def
-- } }
-- -- acts :: Map LmsTableAction (AForm Handler LmsTableActionData) -- acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
-- -- acts = mconcat -- acts = mconcat
-- -- [ singletonMap LmsActNotify $ pure LmsActNotifyData -- [ singletonMap LmsActNotify $ pure LmsActNotifyData
-- -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData
-- -- ] -- ]
-- postprocess :: FormResult (First act', DBFormResult UserId Bool LmsTableData) postprocess :: FormResult (First act', DBFormResult UserId Bool LmsTableData)
-- -> FormResult ( act', Set UserId) -> FormResult ( act', Set UserId)
-- postprocess inp = do postprocess inp = do
-- (First (Just act), usrMap) <- inp (First (Just act), usrMap) <- inp
-- let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
-- return (act, usrSet) return (act, usrSet)
-- -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableActionData)) -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableActionData))
-- -- resultDBTableValidator = def -- resultDBTableValidator = def
-- -- & defaultSorting [SortAscBy csvLmsIdent] -- & defaultSorting [SortAscBy csvLmsIdent]
-- over _1 postprocess <$> dbTable psValidator DBTable{..} over _1 postprocess <$> dbTable psValidator DBTable{..}
-- getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html
-- getQualificationR = postQualificationR getQualificationR = postQualificationR
-- postQualificationR sid qsh = do postQualificationR sid qsh = do
-- let nlimit = 5000 -- TODO: remove me let nlimit = 5000 -- TODO: remove me
-- noffset = 0 noffset = 0
-- isAdmin <- hasReadAccessTo AdminR isAdmin <- hasReadAccessTo AdminR
-- currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler 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 ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
-- qent <- getBy404 $ SchoolQualificationShort sid qsh qent <- getBy404 $ SchoolQualificationShort sid qsh
-- let acts :: Map LmsTableAction (AForm Handler LmsTableActionData) let acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
-- acts = mconcat acts = mconcat
-- [ singletonMap LmsActNotify $ pure LmsActNotifyData [ singletonMap LmsActNotify $ pure LmsActNotifyData
-- , singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData , singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData
-- -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData
-- ] ]
-- colChoices = mconcat 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" [ 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 , colUserNameLinkHdr MsgLmsUser AdminUserR
-- , colUserEmail , colUserEmail
-- , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , 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 "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 "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
-- , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip
-- ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b
-- , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
-- ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification ) $ \( 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-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-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-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-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-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) $ \(preview $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d
-- , sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row -> , sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row ->
-- -- 4 Cases: -- 4 Cases:
-- -- - No notification: LmsUserNotified == Nothing -- - No notification: LmsUserNotified == Nothing
-- -- - Email sent : LmsUserNotified == Just _ && PrintJobId == Nothing -- - Email sent : LmsUserNotified == Just _ && PrintJobId == Nothing
-- -- - Letter printed : LmsUserNotified == Just _ && PrintJobId == Just _ -- - Letter printed : LmsUserNotified == Just _ && PrintJobId == Just _
-- -- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _ -- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _
-- let notifyDate = join $ row ^? resultLmsUser . _entityVal . _lmsUserNotified let notifyDate = join $ row ^? resultLmsUser . _entityVal . _lmsUserNotified
-- lmsident = row ^? resultLmsUser . _entityVal . _lmsUserIdent lmsident = row ^? resultLmsUser . _entityVal . _lmsUserIdent
-- recipient = row ^. hasUser recipient = row ^. hasUser
-- letterDates = row ^? resultPrintAck letterDates = row ^? resultPrintAck
-- lastLetterDate = headDef Nothing =<< letterDates 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) 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 notNotified = isNothing notifyDate
-- cIcon = iconFixedCell $ iconLetterOrEmail letterSent cIcon = iconFixedCell $ iconLetterOrEmail letterSent
-- cDate = if | not letterSent -> foldMap dateTimeCell notifyDate cDate = if | not letterSent -> foldMap dateTimeCell notifyDate
-- | Just d <- lastLetterDate -> dateTimeCell d | Just d <- lastLetterDate -> dateTimeCell d
-- | otherwise -> i18nCell MsgPrintJobUnacknowledged | otherwise -> i18nCell MsgPrintJobUnacknowledged
-- lprLink :: Maybe (Route UniWorX) = lmsident <&> (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)])) lprLink :: Maybe (Route UniWorX) = lmsident <&> (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)]))
-- cAckDates = case letterDates of cAckDates = case letterDates of
-- Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet| Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet|
-- <h1> <h1>
-- _{MsgPrintJobAcknowledgements} ^{userWidget recipient} _{MsgPrintJobAcknowledgements} ^{userWidget recipient}
-- <ul> <ul>
-- $forall mbackdate <- ackDates $forall mbackdate <- ackDates
-- <li> <li>
-- #{iconLetter} # #{iconLetter} #
-- $maybe ackdate <- mbackdate $maybe ackdate <- mbackdate
-- ^{formatTimeW SelFormatDateTime ackdate} ^{formatTimeW SelFormatDateTime ackdate}
-- $nothing $nothing
-- _{MsgPrintJobUnacknowledged} _{MsgPrintJobUnacknowledged}
-- $maybe lu <- lprLink $maybe lu <- lprLink
-- <p> <p>
-- <a href=@{lu}> <a href=@{lu}>
-- _{MsgPrintJobs} _{MsgPrintJobs}
-- |] |]
-- -- (PrintCenterR, [("pj-lmsid", toPathPiece lu)]) -- (PrintCenterR, [("pj-lmsid", toPathPiece lu)])
-- _ -> mempty _ -> mempty
-- in if notNotified in if notNotified
-- then mempty then mempty
-- else cIcon <> spacerCell <> cDate <> cAckDates else cIcon <> spacerCell <> cDate <> cAckDates
-- -- , sortable (Just "lms-notified-alternative") (i18nLms MsgTableLmsNotified) $ \(preview resultPrintAck -> d) -> textCell (show d) -- , sortable (Just "lms-notified-alternative") (i18nLms MsgTableLmsNotified) $ \(preview resultPrintAck -> d) -> textCell (show d)
-- , sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d , sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d
-- ] ]
-- where where
-- -- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
-- i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
-- psValidator = def & forceFilter "may-access" (Any True) psValidator = def & forceFilter "may-access" (Any True)
-- tbl <- mkLmsTable nlimit noffset isAdmin qent acts colChoices psValidator tbl <- mkLmsTable nlimit noffset isAdmin qent acts colChoices psValidator
-- return (tbl, qent) return (tbl, qent)
-- formResult lmsRes $ \case formResult lmsRes $ \case
-- _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page
-- (action, selectedUsers) -> do -- | isRenewPinAct action || isNotifyAct action -> do (action, selectedUsers) -> do -- | isRenewPinAct action || isNotifyAct action -> do
-- now <- liftIO getCurrentTime now <- liftIO getCurrentTime
-- numExaminees <- runDBJobs $ do numExaminees <- runDBJobs $ do
-- okUsers <- selectList [LmsUserUser <-. Set.toList selectedUsers, LmsUserQualification ==. qid] [] okUsers <- selectList [LmsUserUser <-. Set.toList selectedUsers, LmsUserQualification ==. qid] []
-- forM_ okUsers $ \(Entity lid LmsUser {lmsUserUser = uid, lmsUserQualification = qid'}) -> do forM_ okUsers $ \(Entity lid LmsUser {lmsUserUser = uid, lmsUserQualification = qid'}) -> do
-- when (isRenewPinAct action) $ do when (isRenewPinAct action) $ do
-- newPin <- liftIO randomLMSpw update lid [LmsUserPin =. "1234", LmsUserDatePin =. now]
-- update lid [LmsUserPin =. newPin, LmsUserDatePin =. now] when (isNotifyAct action) $
-- when (isNotifyAct action) $ queueDBJob $ JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' }
-- queueDBJob $ JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' } return $ length okUsers
-- return $ length okUsers let numSelected = length selectedUsers
-- let numSelected = length selectedUsers diffSelected = numSelected - numExaminees
-- diffSelected = numSelected - numExaminees when (isRenewPinAct action) $ addMessageI Success $ MsgLmsPinRenewal numExaminees
-- when (isRenewPinAct action) $ addMessageI Success $ MsgLmsPinRenewal numExaminees when (isNotifyAct action) $ addMessageI Success $ MsgLmsNotificationSend numExaminees
-- when (isNotifyAct action) $ addMessageI Success $ MsgLmsNotificationSend numExaminees when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected
-- when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected redirect currentRoute
-- redirect currentRoute
-- let heading = citext2widget $ qualificationName quali let heading = citext2widget $ qualificationName quali
-- siteLayout heading $ do siteLayout heading $ do
-- setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh
-- $(widgetFile "qualification") $(widgetFile "qualification")

10
src/Handler/Utils/Table/Cells.hs
View File

@ -278,13 +278,13 @@ courseCell Course{..} = anchorCell link name `mappend` desc
qualificationCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c qualificationCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
qualificationCell (view hasQualification -> Qualification{..}) = anchorCell link name qualificationCell (view hasQualification -> Qualification{..}) = anchorCell link name
where where
link = LmsR qualificationSchool qualificationShorthand --TODO: revert URL link = QualificationR qualificationSchool qualificationShorthand
name = citext2widget qualificationName name = citext2widget qualificationName
qualificationShortCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c qualificationShortCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
qualificationShortCell (view hasQualification -> Qualification{..}) = anchorCell link name qualificationShortCell (view hasQualification -> Qualification{..}) = anchorCell link name
where where
link = LmsR qualificationSchool qualificationShorthand --TODO: revert URL link = QualificationR qualificationSchool qualificationShorthand
name = citext2widget qualificationShorthand name = citext2widget qualificationShorthand
qualificationDescrCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c qualificationDescrCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
@ -294,6 +294,12 @@ qualificationDescrCell (view hasQualification -> q@Qualification{..}) = qualific
Nothing -> mempty Nothing -> mempty
(Just descr) -> spacerCell <> markupCellLargeModal descr (Just descr) -> spacerCell <> markupCellLargeModal descr
lmsShortCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
lmsShortCell (view hasQualification -> Qualification{..}) = anchorCell link name
where
link = LmsR qualificationSchool qualificationShorthand
name = citext2widget qualificationShorthand
sheetCell :: IsDBTable m a => CourseLink -> SheetName -> DBCell m a sheetCell :: IsDBTable m a => CourseLink -> SheetName -> DBCell m a
sheetCell crse shn = sheetCell crse shn =
let tid = crse ^. _1 let tid = crse ^. _1