538 lines
28 KiB
Haskell
538 lines
28 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.LMS
|
|
( getLmsAllR , postLmsAllR
|
|
, getLmsSchoolR
|
|
, getLmsR , postLmsR
|
|
, getLmsEditR , postLmsEditR
|
|
, getLmsUsersR , getLmsUsersDirectR
|
|
, getLmsUserlistR , postLmsUserlistR
|
|
, getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR
|
|
, getLmsResultR , postLmsResultR
|
|
, getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR
|
|
, getLmsFakeR , postLmsFakeR
|
|
)
|
|
where
|
|
|
|
import Import
|
|
|
|
import Jobs
|
|
import Handler.Utils
|
|
-- import Handler.Utils.Csv
|
|
import Handler.Utils.LMS
|
|
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Csv as Csv
|
|
import qualified Data.Text as T
|
|
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.Utils as E
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
import Handler.LMS.Users as Handler.LMS
|
|
import Handler.LMS.Userlist as Handler.LMS
|
|
import Handler.LMS.Result as Handler.LMS
|
|
import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production!
|
|
|
|
-- avoids repetition of local definitions
|
|
single :: (k,a) -> Map k a
|
|
single = uncurry Map.singleton
|
|
|
|
-- Button only needed here
|
|
data ButtonManualLms = LmsEnqueue | LmsDequeue
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe ButtonManualLms
|
|
instance Finite ButtonManualLms
|
|
|
|
nullaryPathPiece ''ButtonManualLms camelToPathPiece
|
|
|
|
instance Button UniWorX ButtonManualLms where
|
|
btnLabel LmsEnqueue = "Enqeue"
|
|
btnLabel LmsDequeue = "Deqeue"
|
|
|
|
btnClasses LmsEnqueue = [BCIsButton, BCPrimary]
|
|
btnClasses LmsDequeue = [BCIsButton, BCDefault]
|
|
|
|
|
|
getLmsSchoolR :: SchoolId -> Handler Html
|
|
getLmsSchoolR ssh = redirect (LmsAllR, [("qualification-overview-school", toPathPiece ssh)])
|
|
|
|
getLmsAllR, postLmsAllR :: Handler Html
|
|
getLmsAllR = postLmsAllR
|
|
postLmsAllR = do
|
|
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms)
|
|
let btnForm = wrapForm btnWdgt def
|
|
{ formAction = Just $ SomeRoute LmsAllR
|
|
, formEncoding = btnEnctype
|
|
, formSubmit = FormNoSubmit
|
|
}
|
|
case btnResult of
|
|
(FormSuccess LmsEnqueue) -> queueJob' JobLmsQualificationsEnqueue
|
|
(FormSuccess LmsDequeue) -> queueJob' JobLmsQualificationsDequeue
|
|
FormMissing -> return ()
|
|
_other -> addMessage Warning "Kein korrekter LMS Knopf erkannt"
|
|
|
|
lmsTable <- runDB $ do
|
|
view _2 <$> mkLmsAllTable
|
|
siteLayoutMsg MsgMenuQualifications $ do
|
|
setTitleI MsgMenuQualifications
|
|
$(widgetFile "lms-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
|
|
|
|
|
|
|
|
getLmsEditR, postLmsEditR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
getLmsEditR = postLmsEditR
|
|
postLmsEditR = error "TODO"
|
|
|
|
|
|
data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc..
|
|
{ ltcDisplayName :: UserDisplayName
|
|
, ltcEmail :: UserEmail
|
|
, ltcValidUntil :: Day
|
|
, ltcLastRefresh :: Day
|
|
, ltcFirstHeld :: Day
|
|
, ltcBlockedDue :: Maybe QualificationBlocked
|
|
, ltcLmsIdent :: Maybe LmsIdent
|
|
, ltcLmsStatus :: Maybe LmsStatus
|
|
, ltcLmsStarted :: Maybe UTCTime
|
|
, ltcLmsDatePin :: Maybe UTCTime
|
|
, ltcLmsReceived :: Maybe UTCTime
|
|
, ltcLmsNotified :: Maybe UTCTime
|
|
, ltcLmsEnded :: Maybe UTCTime
|
|
}
|
|
deriving Generic
|
|
makeLenses_ ''LmsTableCsv
|
|
|
|
ltcExample :: LmsTableCsv
|
|
ltcExample = LmsTableCsv
|
|
{ ltcDisplayName = "Max Mustermann"
|
|
, ltcEmail = "m.mustermann@does.not.exist"
|
|
, ltcValidUntil = compDay
|
|
, ltcLastRefresh = compDay
|
|
, ltcFirstHeld = compDay
|
|
, ltcBlockedDue = Nothing
|
|
, ltcLmsIdent = Nothing
|
|
, ltcLmsStatus = Nothing
|
|
, ltcLmsStarted = Just compTime
|
|
, ltcLmsDatePin = Nothing
|
|
, ltcLmsReceived = Nothing
|
|
, ltcLmsNotified = Nothing
|
|
, ltcLmsEnded = Nothing
|
|
}
|
|
where
|
|
compTime :: UTCTime
|
|
compTime = $compileTime
|
|
compDay :: Day
|
|
compDay = utctDay compTime
|
|
|
|
ltcOptions :: Csv.Options
|
|
ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
|
|
where
|
|
renameLtc "ltcDisplayName" = "licensee"
|
|
renameLtc "ltcLmsDatePin" = prefixLms "pin-created"
|
|
renameLtc "ltcLmsReceived" = prefixLms "last-update"
|
|
renameLtc other = replaceLtc $ camelToPathPiece' 1 other
|
|
replaceLtc ('l':'m':'s':'-':t) = prefixLms t
|
|
replaceLtc other = other
|
|
prefixLms = ("e-learn-" <>)
|
|
|
|
instance Csv.ToNamedRecord LmsTableCsv where
|
|
toNamedRecord = Csv.genericToNamedRecord ltcOptions
|
|
|
|
instance Csv.DefaultOrdered LmsTableCsv where
|
|
headerOrder = Csv.genericHeaderOrder ltcOptions
|
|
|
|
instance CsvColumnsExplained LmsTableCsv where
|
|
csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList
|
|
[ ('ltcDisplayName, MsgLmsUser)
|
|
, ('ltcEmail , MsgTableLmsEmail)
|
|
, ('ltcValidUntil , MsgLmsQualificationValidUntil)
|
|
, ('ltcLastRefresh, MsgTableQualificationLastRefresh)
|
|
, ('ltcFirstHeld , MsgTableQualificationFirstHeld)
|
|
, ('ltcLmsIdent , MsgTableLmsIdent)
|
|
, ('ltcLmsStatus , MsgTableLmsStatus)
|
|
, ('ltcLmsStarted , MsgTableLmsStarted)
|
|
, ('ltcLmsDatePin , MsgTableLmsDatePin)
|
|
, ('ltcLmsReceived, MsgTableLmsReceived)
|
|
, ('ltcLmsEnded , MsgTableLmsEnded)
|
|
]
|
|
|
|
|
|
type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser)
|
|
`E.InnerJoin` E.SqlExpr (Entity User)
|
|
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
|
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity PrintJob))
|
|
|
|
|
|
queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser)
|
|
queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
|
|
|
queryUser :: LmsTableExpr -> E.SqlExpr (Entity User)
|
|
queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
|
|
|
queryLmsUser :: LmsTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
|
|
queryLmsUser = $(sqlLOJproj 3 2)
|
|
|
|
queryPrintJob :: LmsTableExpr -> E.SqlExpr (Maybe (Entity PrintJob))
|
|
queryPrintJob = $(sqlLOJproj 3 3)
|
|
|
|
type LmsTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity PrintJob))
|
|
|
|
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
|
|
|
|
resultPrintJob :: Traversal' LmsTableData (Entity PrintJob)
|
|
resultPrintJob = _dbrOutput . _4 . _Just
|
|
|
|
instance HasEntity LmsTableData User where
|
|
hasEntity = resultUser
|
|
|
|
instance HasUser LmsTableData where
|
|
hasUser = resultUser . _entityVal
|
|
|
|
data LmsTableAction = LmsActNotify
|
|
| LmsActRenewNotify
|
|
| LmsActRenewPin
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
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
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
isNotifyAct :: LmsTableActionData -> Bool
|
|
isNotifyAct LmsActNotifyData = True
|
|
isNotifyAct LmsActRenewNotifyData = True
|
|
isNotifyAct LmsActRenewPinData = False
|
|
|
|
isRenewPinAct :: LmsTableActionData -> Bool
|
|
isRenewPinAct LmsActNotifyData = False
|
|
isRenewPinAct LmsActRenewNotifyData = True
|
|
isRenewPinAct LmsActRenewPinData = True
|
|
|
|
lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
|
|
, E.SqlExpr (Entity User)
|
|
, E.SqlExpr (Maybe (Entity LmsUser))
|
|
, E.SqlExpr (Maybe (Entity PrintJob))
|
|
)
|
|
lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` printJob) = do
|
|
-- E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting
|
|
E.on $ lmsUser E.?. LmsUserId E.=?. printJob E.?. PrintJobLmsUser
|
|
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.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
|
|
E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
|
|
return (qualUser, user, lmsUser, printJob)
|
|
|
|
|
|
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
|
|
)
|
|
=> Entity Qualification
|
|
-> Map act (AForm Handler act')
|
|
-> (LmsTableExpr -> E.SqlExpr (E.Value Bool))
|
|
-> cols
|
|
-> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))
|
|
-> DB (FormResult (act', Set UserId), Widget)
|
|
mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
|
|
now <- liftIO getCurrentTime
|
|
-- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route here
|
|
let
|
|
currentRoute = LmsR (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 <* E.where_ (restrict q)
|
|
dbtRowKey = queryUser >>> (E.^. UserId)
|
|
dbtProj = dbtProjFilteredPostId
|
|
dbtColonnade = cols
|
|
dbtSorting = mconcat
|
|
[ single $ sortUserNameLink queryUser
|
|
, single $ sortUserEmail queryUser
|
|
, single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
|
|
, 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-notified", SortColumn $ queryLmsUser >>> (E.?. LmsUserNotified))
|
|
, single ("lms-notified", SortColumn $ \row -> E.coalesce [queryPrintJob row E.?. PrintJobAcknowledged, queryLmsUser row E.?. LmsUserNotified]) -- prefer printJob acknowledgement date, if it exists
|
|
-- , single ("lms-notified", SortColumn $ \row -> E.greatest (queryPrintJob row E.?. PrintJobAcknowledged, queryLmsUser row E.?. LmsUserNotified)) -- bad idea, since resending increase notifyDate but just schedules yet another print job
|
|
, 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
|
|
)
|
|
-- , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified)))
|
|
, single ("lms-notified", FilterColumn $ \row criterion ->
|
|
let luser = queryLmsUser row
|
|
pjob = queryPrintJob row
|
|
in
|
|
case getLast criterion of
|
|
Just True -> E.isJust (luser E.?. LmsUserNotified)
|
|
E.&&. (E.isNothing (pjob E.?. PrintJobId) E.||. E.isJust (pjob E.?. PrintJobAcknowledged))
|
|
Just False -> E.isNothing (luser E.?. LmsUserNotified)
|
|
E.||. (E.isJust (pjob E.?. PrintJobId) E.&&. E.isNothing (pjob E.?. PrintJobAcknowledged))
|
|
Nothing -> 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)
|
|
, 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))
|
|
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded))
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
dbtParams = DBParamsForm
|
|
{ dbParamsFormMethod = POST
|
|
, dbParamsFormAction = Just $ SomeRoute currentRoute
|
|
, dbParamsFormAttrs = []
|
|
, dbParamsFormSubmit = FormSubmit
|
|
, dbParamsFormAdditional
|
|
= renderAForm FormStandard
|
|
$ (, mempty) . First . Just
|
|
<$> multiActionA acts (fslI MsgTableAction) Nothing
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
, dbParamsFormResult = id
|
|
, dbParamsFormIdent = def
|
|
}
|
|
|
|
-- acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
|
|
-- acts = mconcat
|
|
-- [ singletonMap LmsActNotify $ pure LmsActNotifyData
|
|
-- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData
|
|
-- ]
|
|
postprocess :: FormResult (First act', DBFormResult UserId Bool LmsTableData)
|
|
-> FormResult ( act', Set UserId)
|
|
postprocess inp = do
|
|
(First (Just act), usrMap) <- inp
|
|
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
|
|
return (act, usrSet)
|
|
|
|
-- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableActionData))
|
|
-- resultDBTableValidator = def
|
|
-- & defaultSorting [SortAscBy csvLmsIdent]
|
|
over _1 postprocess <$> dbTable psValidator DBTable{..}
|
|
|
|
getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
getLmsR = postLmsR
|
|
postLmsR sid qsh = do
|
|
currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
|
|
((lmsRes, lmsTable), 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
|
|
[ 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 "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) $ \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
|
|
letterDate = join $ row ^? resultPrintJob . _entityVal . _printJobAcknowledged
|
|
-- letterSent = isJust (row ^? resultPrintJob . _entityKey) && (isNothing letterDate || letterDate > notifyDate) -- bad idea, since a resending increase notifyDay but just reschedules a print job
|
|
letterSent = isJust (row ^? resultPrintJob . _entityKey) -- note the difference to letterDate!
|
|
notNotified = isNothing notifyDate
|
|
cIcon = iconFixedCell $ iconLetterOrEmail letterSent
|
|
cDate = if letterSent
|
|
then foldMap dateTimeCell letterDate
|
|
else foldMap dateTimeCell notifyDate
|
|
in if notNotified
|
|
then mempty
|
|
else cIcon <> spacerCell <> cDate
|
|
, 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 -- TODO: hier einen Filter für Schützlinge einbauen
|
|
tbl <- mkLmsTable qent acts (const E.true) colChoices psValidator
|
|
return (tbl, qent)
|
|
|
|
formResult lmsRes $ \case
|
|
(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
|
|
|
|
let heading = citext2widget $ qualificationName quali
|
|
siteLayout heading $ do
|
|
setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh
|
|
$(widgetFile "lms")
|