chore(super): split view compiles again
This commit is contained in:
Steffen Jost
parent
2de8ee0ee6
commit
cc070ed21b
25
routes
25
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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|
|
||||
-- <h1>
|
||||
-- _{MsgPrintJobAcknowledgements} ^{userWidget recipient}
|
||||
-- <ul>
|
||||
-- $forall mbackdate <- ackDates
|
||||
-- <li>
|
||||
-- #{iconLetter} #
|
||||
-- $maybe ackdate <- mbackdate
|
||||
-- ^{formatTimeW SelFormatDateTime ackdate}
|
||||
-- $nothing
|
||||
-- _{MsgPrintJobUnacknowledged}
|
||||
-- $maybe lu <- lprLink
|
||||
-- <p>
|
||||
-- <a href=@{lu}>
|
||||
-- _{MsgPrintJobs}
|
||||
-- |]
|
||||
-- -- (PrintCenterR, [("pj-lmsid", toPathPiece lu)])
|
||||
-- _ -> mempty
|
||||
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|
|
||||
<h1>
|
||||
_{MsgPrintJobAcknowledgements} ^{userWidget recipient}
|
||||
<ul>
|
||||
$forall mbackdate <- ackDates
|
||||
<li>
|
||||
#{iconLetter} #
|
||||
$maybe ackdate <- mbackdate
|
||||
^{formatTimeW SelFormatDateTime ackdate}
|
||||
$nothing
|
||||
_{MsgPrintJobUnacknowledged}
|
||||
$maybe lu <- lprLink
|
||||
<p>
|
||||
<a href=@{lu}>
|
||||
_{MsgPrintJobs}
|
||||
|]
|
||||
-- (PrintCenterR, [("pj-lmsid", toPathPiece lu)])
|
||||
_ -> mempty
|
||||
|
||||
-- in if notNotified
|
||||
-- then mempty
|
||||
-- else cIcon <> spacerCell <> cDate <> cAckDates
|
||||
-- -- , 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
|
||||
-- ]
|
||||
-- where
|
||||
-- -- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
|
||||
-- i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
|
||||
-- psValidator = def & forceFilter "may-access" (Any True)
|
||||
-- tbl <- mkLmsTable nlimit noffset isAdmin qent acts colChoices psValidator
|
||||
-- return (tbl, qent)
|
||||
in if notNotified
|
||||
then mempty
|
||||
else cIcon <> spacerCell <> cDate <> cAckDates
|
||||
-- , 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
|
||||
]
|
||||
where
|
||||
-- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
|
||||
i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
|
||||
psValidator = def & forceFilter "may-access" (Any True)
|
||||
tbl <- mkLmsTable nlimit noffset isAdmin qent acts colChoices psValidator
|
||||
return (tbl, qent)
|
||||
|
||||
-- formResult lmsRes $ \case
|
||||
-- _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page
|
||||
-- (action, selectedUsers) -> do -- | isRenewPinAct action || isNotifyAct action -> do
|
||||
-- now <- liftIO getCurrentTime
|
||||
-- numExaminees <- runDBJobs $ do
|
||||
-- okUsers <- selectList [LmsUserUser <-. Set.toList selectedUsers, LmsUserQualification ==. qid] []
|
||||
-- forM_ okUsers $ \(Entity lid LmsUser {lmsUserUser = uid, lmsUserQualification = qid'}) -> do
|
||||
-- when (isRenewPinAct action) $ do
|
||||
-- newPin <- liftIO randomLMSpw
|
||||
-- update lid [LmsUserPin =. newPin, LmsUserDatePin =. now]
|
||||
-- when (isNotifyAct action) $
|
||||
-- queueDBJob $ JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' }
|
||||
-- return $ length okUsers
|
||||
-- let numSelected = length selectedUsers
|
||||
-- diffSelected = numSelected - numExaminees
|
||||
-- when (isRenewPinAct action) $ addMessageI Success $ MsgLmsPinRenewal numExaminees
|
||||
-- when (isNotifyAct action) $ addMessageI Success $ MsgLmsNotificationSend numExaminees
|
||||
-- when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected
|
||||
-- redirect currentRoute
|
||||
formResult lmsRes $ \case
|
||||
_ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page
|
||||
(action, selectedUsers) -> do -- | isRenewPinAct action || isNotifyAct action -> do
|
||||
now <- liftIO getCurrentTime
|
||||
numExaminees <- runDBJobs $ do
|
||||
okUsers <- selectList [LmsUserUser <-. Set.toList selectedUsers, LmsUserQualification ==. qid] []
|
||||
forM_ okUsers $ \(Entity lid LmsUser {lmsUserUser = uid, lmsUserQualification = qid'}) -> do
|
||||
when (isRenewPinAct action) $ do
|
||||
update lid [LmsUserPin =. "1234", LmsUserDatePin =. now]
|
||||
when (isNotifyAct action) $
|
||||
queueDBJob $ JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' }
|
||||
return $ length okUsers
|
||||
let numSelected = length selectedUsers
|
||||
diffSelected = numSelected - numExaminees
|
||||
when (isRenewPinAct action) $ addMessageI Success $ MsgLmsPinRenewal numExaminees
|
||||
when (isNotifyAct action) $ addMessageI Success $ MsgLmsNotificationSend numExaminees
|
||||
when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected
|
||||
redirect currentRoute
|
||||
|
||||
-- let heading = citext2widget $ qualificationName quali
|
||||
-- siteLayout heading $ do
|
||||
-- setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh
|
||||
-- $(widgetFile "qualification")
|
||||
let heading = citext2widget $ qualificationName quali
|
||||
siteLayout heading $ do
|
||||
setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh
|
||||
$(widgetFile "qualification")
|
||||
|
||||
@ -278,13 +278,13 @@ courseCell Course{..} = anchorCell link name `mappend` desc
|
||||
qualificationCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
|
||||
qualificationCell (view hasQualification -> Qualification{..}) = anchorCell link name
|
||||
where
|
||||
link = LmsR qualificationSchool qualificationShorthand --TODO: revert URL
|
||||
link = QualificationR qualificationSchool qualificationShorthand
|
||||
name = citext2widget qualificationName
|
||||
|
||||
qualificationShortCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
|
||||
qualificationShortCell (view hasQualification -> Qualification{..}) = anchorCell link name
|
||||
where
|
||||
link = LmsR qualificationSchool qualificationShorthand --TODO: revert URL
|
||||
link = QualificationR qualificationSchool qualificationShorthand
|
||||
name = citext2widget qualificationShorthand
|
||||
|
||||
qualificationDescrCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
|
||||
@ -294,6 +294,12 @@ qualificationDescrCell (view hasQualification -> q@Qualification{..}) = qualific
|
||||
Nothing -> mempty
|
||||
(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 crse shn =
|
||||
let tid = crse ^. _1
|
||||
|
||||
Loading…
Reference in New Issue
Block a user