251 lines
14 KiB
Haskell
251 lines
14 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
|
|
{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
module Handler.Qualification
|
|
( getQualificationAllR
|
|
, getQualificationSchoolR
|
|
, getQualificationR
|
|
)
|
|
where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
-- import Handler.Utils.Csv
|
|
-- import Handler.Utils.LMS
|
|
|
|
import qualified Data.Map as Map
|
|
-- import qualified Data.Csv as Csv
|
|
-- 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.Utils as E
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
|
|
-- avoids repetition of local definitions
|
|
single :: (k,a) -> Map k a
|
|
single = uncurry Map.singleton
|
|
|
|
getQualificationSchoolR :: SchoolId -> Handler Html
|
|
getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)])
|
|
|
|
getQualificationAllR :: Handler Html
|
|
getQualificationAllR = do -- TODO just a stub
|
|
lmsTable <- runDB $ do
|
|
view _2 <$> mkLmsAllTable
|
|
siteLayoutMsg MsgMenuQualifications $ do
|
|
setTitleI MsgMenuQualifications
|
|
$(widgetFile "qualification-all")
|
|
|
|
type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64)
|
|
resultAllQualification :: Lens' AllQualificationTableData Qualification
|
|
resultAllQualification = _dbrOutput . _1 . _entityVal
|
|
|
|
resultAllQualificationActive :: Lens' AllQualificationTableData Word64
|
|
resultAllQualificationActive = _dbrOutput . _2 . _unValue
|
|
|
|
resultAllQualificationTotal :: Lens' AllQualificationTableData Word64
|
|
resultAllQualificationTotal = _dbrOutput . _3 . _unValue
|
|
|
|
|
|
mkLmsAllTable :: DB (Any, Widget)
|
|
mkLmsAllTable = do
|
|
now <- liftIO getCurrentTime
|
|
let
|
|
resultDBTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery quali = do
|
|
cusers <- pure . Ex.subSelectCount $ do
|
|
quser <- Ex.from $ Ex.table @QualificationUser
|
|
Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
|
|
cactive <- pure . Ex.subSelectCount $ do
|
|
quser <- Ex.from $ Ex.table @QualificationUser
|
|
Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
|
|
E.&&. quser Ex.^. QualificationUserValidUntil Ex.>=. E.val (utctDay now)
|
|
-- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem
|
|
return (quali, cactive, cusers)
|
|
dbtRowKey = (E.^. QualificationId)
|
|
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
|
|
dbtColonnade = dbColonnade $ mconcat
|
|
[ colSchool $ resultAllQualification . _qualificationSchool
|
|
, sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) ->
|
|
let qsh = qualificationShorthand quali in
|
|
anchorCell (LmsR (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
|
|
, sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) ->
|
|
maybeCell (qualificationDescription quali) markupCellLargeModal
|
|
, sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $
|
|
foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration)
|
|
, sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltip MsgTableDiffDaysTooltip) $
|
|
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin)
|
|
-- , sortable Nothing (i18nCell MsgQualificationRefreshWithin) $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between
|
|
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
|
|
$ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
|
|
, sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
|
|
$ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
|
|
, sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal
|
|
-- \(view resultAllQualificationTotal -> n) -> wgtCell $ word2widget n
|
|
]
|
|
dbtSorting = mconcat
|
|
[
|
|
sortSchool $ to (E.^. QualificationSchool)
|
|
, singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand)
|
|
, singletonMap "qname" $ SortColumn (E.^. QualificationName)
|
|
, singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart)
|
|
]
|
|
dbtFilter = mconcat
|
|
[
|
|
fltrSchool $ to (E.^. QualificationSchool)
|
|
, singletonMap "qelearning" . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart)
|
|
]
|
|
dbtFilterUI = mconcat
|
|
[
|
|
fltrSchoolUI
|
|
, \mPrev -> prismAForm (singletonFilter "qelearning" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning)
|
|
]
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
dbtParams = def
|
|
dbtIdent :: Text
|
|
dbtIdent = "qualification-overview"
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
|
|
resultDBTableValidator = def
|
|
& defaultSorting [SortAscBy "school", SortAscBy "qshort"]
|
|
dbTable resultDBTableValidator resultDBTable
|
|
|
|
|
|
|
|
getQualificationEditR, postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
getQualificationEditR = postQualificationEditR
|
|
postQualificationEditR = error "TODO"
|
|
|
|
|
|
type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser)
|
|
`E.InnerJoin` E.SqlExpr (Entity User)
|
|
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
|
|
|
|
queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser)
|
|
queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1)
|
|
|
|
queryUser :: LmsTableExpr -> E.SqlExpr (Entity User)
|
|
queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1)
|
|
|
|
queryLmsUser :: LmsTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
|
|
queryLmsUser = $(sqlLOJproj 2 2)
|
|
|
|
type LmsTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser))
|
|
|
|
resultQualUser :: Lens' LmsTableData (Entity QualificationUser)
|
|
resultQualUser = _dbrOutput . _1
|
|
|
|
resultUser :: Lens' LmsTableData (Entity User)
|
|
resultUser = _dbrOutput . _2
|
|
|
|
resultLmsUser :: Traversal' LmsTableData (Entity LmsUser)
|
|
resultLmsUser = _dbrOutput . _3 . _Just
|
|
|
|
instance HasEntity LmsTableData User where
|
|
hasEntity = resultUser
|
|
|
|
instance HasUser LmsTableData where
|
|
hasUser = resultUser . _entityVal
|
|
|
|
mkLmsTable :: Entity Qualification -> DB (Any, Widget)
|
|
mkLmsTable (Entity qid quali) = do
|
|
now <- liftIO getCurrentTime
|
|
let
|
|
nowaday = utctDay now
|
|
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
|
|
resultDBTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery = runReaderT $ do
|
|
qualUser <- asks queryQualUser
|
|
user <- asks queryUser
|
|
lmsUser <- asks queryLmsUser
|
|
lift $ do
|
|
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
|
|
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
|
|
E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
|
|
return (qualUser, user, lmsUser)
|
|
dbtRowKey = queryUser >>> (E.^. UserId)
|
|
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
|
|
dbtColonnade = dbColonnade $ mconcat
|
|
[ 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 "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-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
|
|
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 ("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-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded))
|
|
]
|
|
dbtFilter = mconcat
|
|
[ 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 ("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
|
|
)
|
|
]
|
|
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)
|
|
, if isNothing mbRenewal then mempty
|
|
else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
|
|
]
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
dbtParams = def
|
|
dbtIdent :: Text
|
|
dbtIdent = "qualification"
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
|
|
resultDBTableValidator = def
|
|
-- & defaultSorting [SortAscBy csvLmsIdent]
|
|
dbTable resultDBTableValidator resultDBTable
|
|
|
|
getQualificationR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
getQualificationR sid qsh = do -- TODO just a copied stub
|
|
(lmsTable, quali) <- runDB $ do
|
|
qent@(Entity _qid quali) <- getBy404 $ SchoolQualificationShort sid qsh
|
|
tbl <- view _2 <$> mkLmsTable qent
|
|
return (tbl, quali)
|
|
let heading = citext2widget $ qualificationName quali
|
|
siteLayout heading $ do
|
|
setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh
|
|
$(widgetFile "lms")
|