chore(lms): add action to manually enqueue qual holder for e-learning
This commit is contained in:
parent
37efc89e07
commit
e25a8569c5
@ -107,6 +107,8 @@ QualificationActUnblock: Entzug aufheben
|
|||||||
QualificationActRenew: Qualifikation regulär verlängern
|
QualificationActRenew: Qualifikation regulär verlängern
|
||||||
QualificationActGrant: Qualifikation vergeben
|
QualificationActGrant: Qualifikation vergeben
|
||||||
QualificationActGrantWarning: Diese Funktion ist nur für seltene Ausnahmefälle vorgesehen! Ein Entzug wird ggf. aufgehoben.
|
QualificationActGrantWarning: Diese Funktion ist nur für seltene Ausnahmefälle vorgesehen! Ein Entzug wird ggf. aufgehoben.
|
||||||
|
QualificationActStartELearning: E‑Learning für gültige Inhaber (neu) starten
|
||||||
|
QualificationActStartELearningStatus l@QualificationShorthand n@Int m@Int: E‑Learning #{l} für #{n}/#{m} Teilnehmer (neu) gestartet. Hinweis: Es kann länger dauern, bis das LMS tatsächlich startet.
|
||||||
QualificationStatusBlock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen
|
QualificationStatusBlock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen
|
||||||
QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert
|
QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert
|
||||||
LmsInactive: Aktuell kein E‑Learning aktiv
|
LmsInactive: Aktuell kein E‑Learning aktiv
|
||||||
@ -120,7 +122,7 @@ LmsActReset: E‑Learning Fehlversuche zurücksetzen und entsperren
|
|||||||
LmsActResetInfo: E‑Learning Login, Passwort und Fortschritt bleiben unverändert, eine neue Benachrichtigung ist nicht notwendig. Nur möglich für bereits gesperrte Lerner. Es kann bis zu 2 Stunden dauern, bis das LMS die Anfrage umgesetzt hat.
|
LmsActResetInfo: E‑Learning Login, Passwort und Fortschritt bleiben unverändert, eine neue Benachrichtigung ist nicht notwendig. Nur möglich für bereits gesperrte Lerner. Es kann bis zu 2 Stunden dauern, bis das LMS die Anfrage umgesetzt hat.
|
||||||
LmsActResetFeedback n@Int m@Int: Für #{n}/#{m} E‑Learning Nutzer wurden alle Fehlversuche zurückgesetzt.
|
LmsActResetFeedback n@Int m@Int: Für #{n}/#{m} E‑Learning Nutzer wurden alle Fehlversuche zurückgesetzt.
|
||||||
LmsActRestart: E‑Learning komplett neu starten
|
LmsActRestart: E‑Learning komplett neu starten
|
||||||
LmsActRestartWarning: Das vorhandene E‑Learning wird komplett gelöscht! Für Inhaber einer gültigen Fahrlizenz werden später Benutzer und Passwort neu vergeben und es sollte eine neue Benachrichtigung versendet werden. Hinweis: Es kann mehrere Stunden dauern, bis das LMS diese Anfrage umgesetzt hat.
|
LmsActRestartWarning: Das vorhandene E‑Learning wird komplett gelöscht! Für Inhaber einer gültigen Lizenz werden später Benutzer und Passwort neu vergeben und es sollte eine neue Benachrichtigung versendet werden. Hinweis: Es kann mehrere Stunden dauern, bis das LMS diese Anfrage umgesetzt hat.
|
||||||
LmsActRestartFeedback n@Int m@Int: #{n}/#{m} E‑Learning Nutzer wurden komplett neu gestartet mit neuem Login und Passwort.
|
LmsActRestartFeedback n@Int m@Int: #{n}/#{m} E‑Learning Nutzer wurden komplett neu gestartet mit neuem Login und Passwort.
|
||||||
LmsActRestartExtend: Gültig bis ggf. erhöhen für die nächsten # Tage
|
LmsActRestartExtend: Gültig bis ggf. erhöhen für die nächsten # Tage
|
||||||
LmsActRestartUnblock: Entzug ggf. aufheben
|
LmsActRestartUnblock: Entzug ggf. aufheben
|
||||||
|
|||||||
@ -107,6 +107,8 @@ QualificationActUnblock: Clear revocation
|
|||||||
QualificationActRenew: Renew qualification
|
QualificationActRenew: Renew qualification
|
||||||
QualificationActGrant: Grant qualification
|
QualificationActGrant: Grant qualification
|
||||||
QualificationActGrantWarning: Use with caution in rare exceptional cases only! Any revocation will be undone.
|
QualificationActGrantWarning: Use with caution in rare exceptional cases only! Any revocation will be undone.
|
||||||
|
QualificationActStartELearning: Manually (re)start e‑learning for valid qualification holders
|
||||||
|
QualificationActStartELearningStatus l n m: E‑learning #{l} (re)started for #{n}/#{m} users. Note: It may take a while, until the e‑learning is activated.
|
||||||
QualificationStatusBlock l n m: #{n}/#{m} #{l} revoked
|
QualificationStatusBlock l n m: #{n}/#{m} #{l} revoked
|
||||||
QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated
|
QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated
|
||||||
LmsInactive: Currently no active e‑learning
|
LmsInactive: Currently no active e‑learning
|
||||||
|
|||||||
@ -14,7 +14,7 @@ module Handler.Qualification
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
-- import Jobs
|
import Jobs
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
import Handler.Utils.Users
|
import Handler.Utils.Users
|
||||||
import Handler.Utils.LMS
|
import Handler.Utils.LMS
|
||||||
@ -55,7 +55,7 @@ getQualificationAllR = do
|
|||||||
|
|
||||||
type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64)
|
type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64)
|
||||||
resultAllQualification :: Lens' AllQualificationTableData Qualification
|
resultAllQualification :: Lens' AllQualificationTableData Qualification
|
||||||
resultAllQualification = _dbrOutput . _1 . _entityVal
|
resultAllQualification = _dbrOutput . _1 . _entityVal
|
||||||
|
|
||||||
resultAllQualificationActive :: Lens' AllQualificationTableData Word64
|
resultAllQualificationActive :: Lens' AllQualificationTableData Word64
|
||||||
resultAllQualificationActive = _dbrOutput . _2 . _unValue
|
resultAllQualificationActive = _dbrOutput . _2 . _unValue
|
||||||
@ -65,53 +65,53 @@ resultAllQualificationTotal = _dbrOutput . _3 . _unValue
|
|||||||
|
|
||||||
|
|
||||||
mkQualificationAllTable :: Bool -> DB (Any, Widget)
|
mkQualificationAllTable :: Bool -> DB (Any, Widget)
|
||||||
mkQualificationAllTable isAdmin = do
|
mkQualificationAllTable isAdmin = do
|
||||||
svs <- getSupervisees
|
svs <- getSupervisees
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
let
|
let
|
||||||
resultDBTable = DBTable{..}
|
resultDBTable = DBTable{..}
|
||||||
where
|
where
|
||||||
dbtSQLQuery quali = do
|
dbtSQLQuery quali = do
|
||||||
let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
|
let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
|
||||||
Ex.&&. (E.val isAdmin E.||. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs)
|
Ex.&&. (E.val isAdmin E.||. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs)
|
||||||
cusers = Ex.subSelectCount $ do
|
cusers = Ex.subSelectCount $ do
|
||||||
quser <- Ex.from $ Ex.table @QualificationUser
|
quser <- Ex.from $ Ex.table @QualificationUser
|
||||||
Ex.where_ $ filterSvs quser
|
Ex.where_ $ filterSvs quser
|
||||||
cactive = Ex.subSelectCount $ do
|
cactive = Ex.subSelectCount $ do
|
||||||
quser <- Ex.from $ Ex.table @QualificationUser
|
quser <- Ex.from $ Ex.table @QualificationUser
|
||||||
Ex.where_ $ filterSvs quser Ex.&&. validQualification now quser
|
Ex.where_ $ filterSvs quser Ex.&&. validQualification now quser
|
||||||
return (quali, cactive, cusers)
|
return (quali, cactive, cusers)
|
||||||
dbtRowKey = (Ex.^. QualificationId)
|
dbtRowKey = (Ex.^. QualificationId)
|
||||||
dbtProj = dbtProjId
|
dbtProj = dbtProjId
|
||||||
dbtColonnade = dbColonnade $ mconcat
|
dbtColonnade = dbColonnade $ mconcat
|
||||||
[ colSchool $ resultAllQualification . _qualificationSchool
|
[ colSchool $ resultAllQualification . _qualificationSchool
|
||||||
, sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) ->
|
, sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) ->
|
||||||
let qsh = qualificationShorthand quali in
|
let qsh = qualificationShorthand quali in
|
||||||
anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh
|
anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh
|
||||||
, sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) ->
|
, sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) ->
|
||||||
let qsh = qualificationShorthand quali
|
let qsh = qualificationShorthand quali
|
||||||
qnm = qualificationName quali
|
qnm = qualificationName quali
|
||||||
in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm
|
in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm
|
||||||
, sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) ->
|
, sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) ->
|
||||||
maybeCell (qualificationDescription quali) markupCellLargeModal
|
maybeCell (qualificationDescription quali) markupCellLargeModal
|
||||||
, sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $
|
, sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $
|
||||||
foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration)
|
foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration)
|
||||||
, sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $
|
, sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $
|
||||||
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin)
|
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin)
|
||||||
, sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
|
, sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
|
||||||
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder)
|
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder)
|
||||||
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
|
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
|
||||||
$ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
|
$ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
|
||||||
, sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip)
|
, sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip)
|
||||||
$ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification)
|
$ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification)
|
||||||
, sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip)
|
, sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip)
|
||||||
$ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char
|
$ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char
|
||||||
, sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)
|
, sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)
|
||||||
$ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) -> tickmarkCell $ isJust mbSapId
|
$ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) -> tickmarkCell $ isJust mbSapId
|
||||||
, sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
|
, sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
|
||||||
$ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
|
$ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
|
||||||
, sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal
|
, sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal
|
||||||
]
|
]
|
||||||
dbtSorting = mconcat
|
dbtSorting = mconcat
|
||||||
[
|
[
|
||||||
sortSchool $ to (E.^. QualificationSchool)
|
sortSchool $ to (E.^. QualificationSchool)
|
||||||
@ -133,7 +133,7 @@ mkQualificationAllTable isAdmin = do
|
|||||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||||
dbtParams = def
|
dbtParams = def
|
||||||
dbtIdent :: Text
|
dbtIdent :: Text
|
||||||
dbtIdent = "qualification-overview"
|
dbtIdent = "qualification-overview"
|
||||||
dbtCsvEncode = noCsvEncode
|
dbtCsvEncode = noCsvEncode
|
||||||
dbtCsvDecode = Nothing
|
dbtCsvDecode = Nothing
|
||||||
dbtExtraReps = []
|
dbtExtraReps = []
|
||||||
@ -145,7 +145,7 @@ mkQualificationAllTable isAdmin = do
|
|||||||
|
|
||||||
|
|
||||||
-- getQualificationEditR, postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html
|
-- getQualificationEditR, postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||||
-- getQualificationEditR = postQualificationEditR
|
-- getQualificationEditR = postQualificationEditR
|
||||||
-- postQualificationEditR = error "TODO"
|
-- postQualificationEditR = error "TODO"
|
||||||
|
|
||||||
data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc..
|
data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc..
|
||||||
@ -156,7 +156,7 @@ data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc..
|
|||||||
, qtcValidUntil :: Day
|
, qtcValidUntil :: Day
|
||||||
, qtcLastRefresh :: Day
|
, qtcLastRefresh :: Day
|
||||||
, qtcBlockStatus :: Maybe Bool
|
, qtcBlockStatus :: Maybe Bool
|
||||||
, qtcBlockFrom :: Maybe UTCTime
|
, qtcBlockFrom :: Maybe UTCTime
|
||||||
, qtcScheduleRenewal:: Bool
|
, qtcScheduleRenewal:: Bool
|
||||||
, qtcLmsStatusTxt :: Maybe Text
|
, qtcLmsStatusTxt :: Maybe Text
|
||||||
, qtcLmsStatusDay :: Maybe UTCTime
|
, qtcLmsStatusDay :: Maybe UTCTime
|
||||||
@ -173,7 +173,7 @@ qtcExample = QualificationTableCsv
|
|||||||
, qtcValidUntil = compDay
|
, qtcValidUntil = compDay
|
||||||
, qtcLastRefresh = compDay
|
, qtcLastRefresh = compDay
|
||||||
, qtcBlockStatus = Nothing
|
, qtcBlockStatus = Nothing
|
||||||
, qtcBlockFrom = Nothing
|
, qtcBlockFrom = Nothing
|
||||||
, qtcScheduleRenewal= True
|
, qtcScheduleRenewal= True
|
||||||
, qtcLmsStatusTxt = Just "Success"
|
, qtcLmsStatusTxt = Just "Success"
|
||||||
, qtcLmsStatusDay = Just compTime
|
, qtcLmsStatusDay = Just compTime
|
||||||
@ -211,7 +211,7 @@ instance CsvColumnsExplained QualificationTableCsv where
|
|||||||
, ('qtcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom)
|
, ('qtcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom)
|
||||||
, ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip)
|
, ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip)
|
||||||
, ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus)
|
, ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus)
|
||||||
, ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay)
|
, ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay)
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|
||||||
@ -266,15 +266,16 @@ instance HasQualificationUser QualificationTableData where
|
|||||||
-- hasQualificationUserBlock = resultQualBlock
|
-- hasQualificationUserBlock = resultQualBlock
|
||||||
|
|
||||||
|
|
||||||
data QualificationTableAction
|
data QualificationTableAction
|
||||||
= QualificationActExpire
|
= QualificationActExpire
|
||||||
| QualificationActUnexpire
|
| QualificationActUnexpire
|
||||||
| QualificationActBlockSupervisor
|
| QualificationActBlockSupervisor
|
||||||
| QualificationActBlock
|
| QualificationActBlock
|
||||||
| QualificationActUnblock
|
| QualificationActUnblock
|
||||||
| QualificationActRenew
|
| QualificationActRenew
|
||||||
| QualificationActGrant
|
| QualificationActGrant
|
||||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
| QualificationActStartELearning
|
||||||
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||||
|
|
||||||
instance Universe QualificationTableAction
|
instance Universe QualificationTableAction
|
||||||
instance Finite QualificationTableAction
|
instance Finite QualificationTableAction
|
||||||
@ -289,15 +290,16 @@ isAdminAct QualificationActBlockSupervisor = False
|
|||||||
isAdminAct _ = True
|
isAdminAct _ = True
|
||||||
-}
|
-}
|
||||||
|
|
||||||
data QualificationTableActionData
|
data QualificationTableActionData
|
||||||
= QualificationActExpireData
|
= QualificationActExpireData
|
||||||
| QualificationActUnexpireData
|
| QualificationActUnexpireData
|
||||||
| QualificationActBlockSupervisorData
|
| QualificationActBlockSupervisorData
|
||||||
| QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool }
|
| QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool }
|
||||||
| QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool}
|
| QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool }
|
||||||
| QualificationActRenewData { qualTableActChangeReason :: Text}
|
| QualificationActRenewData { qualTableActChangeReason :: Text }
|
||||||
| QualificationActGrantData { qualTableActGrantUntil :: Day }
|
| QualificationActGrantData { qualTableActGrantUntil :: Day }
|
||||||
deriving (Eq, Ord, Show, Generic)
|
| QualificationActStartELearningData -- { qualTableActELearnUntil :: Maybe Day }
|
||||||
|
deriving (Eq, Ord, Show, Generic)
|
||||||
|
|
||||||
isExpiryAct :: QualificationTableActionData -> Bool
|
isExpiryAct :: QualificationTableActionData -> Bool
|
||||||
isExpiryAct QualificationActExpireData = True
|
isExpiryAct QualificationActExpireData = True
|
||||||
@ -335,14 +337,14 @@ qualificationTableQuery :: UTCTime -> QualificationId -> (_ -> E.SqlExpr (E.Valu
|
|||||||
)
|
)
|
||||||
qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
|
qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
|
||||||
-- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps
|
-- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps
|
||||||
--
|
--
|
||||||
E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId
|
E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId
|
||||||
E.&&. qualBlock `isLatestBlockBefore` E.val now
|
E.&&. qualBlock `isLatestBlockBefore` E.val now
|
||||||
E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser
|
E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser
|
||||||
E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
|
E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
|
||||||
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
|
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
|
||||||
E.where_ $ fltr qualUser
|
E.where_ $ fltr qualUser
|
||||||
E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
|
E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
|
||||||
return (qualUser, user, lmsUser, qualBlock)
|
return (qualUser, user, lmsUser, qualBlock)
|
||||||
|
|
||||||
|
|
||||||
@ -352,15 +354,15 @@ mkQualificationTable ::
|
|||||||
)
|
)
|
||||||
=> Bool
|
=> Bool
|
||||||
-> Entity Qualification
|
-> Entity Qualification
|
||||||
-> Map QualificationTableAction (AForm Handler QualificationTableActionData)
|
-> Map QualificationTableAction (AForm Handler QualificationTableActionData)
|
||||||
-> (Map CompanyId Company -> cols)
|
-> (Map CompanyId Company -> cols)
|
||||||
-> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
|
-> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
|
||||||
-> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
|
-> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
|
||||||
mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||||
svs <- getSupervisees
|
svs <- getSupervisees
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
-- lookup all companies
|
-- lookup all companies
|
||||||
cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
|
cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
|
||||||
cmps <- selectList [] [] -- [Asc CompanyShorthand]
|
cmps <- selectList [] [] -- [Asc CompanyShorthand]
|
||||||
return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
|
return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
|
||||||
let
|
let
|
||||||
@ -390,7 +392,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
|||||||
, single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified))
|
, single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified))
|
||||||
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
|
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
|
||||||
, single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
|
, single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
|
||||||
, single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay)
|
, single ("lms-status-plus",SortColumnNullsInv $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay)
|
||||||
, E.joinV (queryLmsUser row E.?. LmsUserNotified)
|
, E.joinV (queryLmsUser row E.?. LmsUserNotified)
|
||||||
, queryLmsUser row E.?. LmsUserStarted])
|
, queryLmsUser row E.?. LmsUserStarted])
|
||||||
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
|
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
|
||||||
@ -405,7 +407,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
|||||||
dbtFilter = mconcat
|
dbtFilter = mconcat
|
||||||
[ single $ fltrUserNameEmail queryUser
|
[ single $ fltrUserNameEmail queryUser
|
||||||
, single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion ->
|
, single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion ->
|
||||||
E.from $ \usrAvs -> -- do
|
E.from $ \usrAvs -> -- do
|
||||||
E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId
|
E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId
|
||||||
E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
|
E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
|
||||||
(E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
|
(E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
|
||||||
@ -415,14 +417,14 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
|||||||
| otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
|
| otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
|
||||||
)
|
)
|
||||||
, single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
|
, single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
|
||||||
E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||||
let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
|
let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
|
||||||
(E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
|
(E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
|
||||||
testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
|
testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
|
||||||
testcrit = maybe testname testnumber $ readMay $ CI.original criterion
|
testcrit = maybe testname testnumber $ readMay $ CI.original criterion
|
||||||
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
||||||
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit
|
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit
|
||||||
)
|
)
|
||||||
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
|
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
|
||||||
, single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
|
, single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
|
||||||
if | Just renewal <- mbRenewal
|
if | Just renewal <- mbRenewal
|
||||||
@ -441,7 +443,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
|||||||
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
|
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
|
||||||
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
|
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
|
||||||
, fltrAVSCardNosUI mPrev
|
, fltrAVSCardNosUI mPrev
|
||||||
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
|
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
|
||||||
, prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
|
, prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
|
||||||
, if isNothing mbRenewal then mempty
|
, if isNothing mbRenewal then mempty
|
||||||
else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
|
else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
|
||||||
@ -466,31 +468,31 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
|||||||
<*> (view resultCompanyUser >>= getCompanies)
|
<*> (view resultCompanyUser >>= getCompanies)
|
||||||
<*> (view resultCompanyUser >>= getCompanyNos)
|
<*> (view resultCompanyUser >>= getCompanyNos)
|
||||||
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
|
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
|
||||||
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
|
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
|
||||||
<*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not)
|
<*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not)
|
||||||
<*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom)
|
<*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom)
|
||||||
<*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
|
<*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
|
||||||
<*> getStatusPlusTxt
|
<*> getStatusPlusTxt
|
||||||
<*> getStatusPlusDay
|
<*> getStatusPlusDay
|
||||||
getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
|
getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
|
||||||
[] -> pure Nothing
|
[] -> pure Nothing
|
||||||
somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
|
somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
|
||||||
getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
|
getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
|
||||||
|
|
||||||
getStatusPlusTxt =
|
getStatusPlusTxt =
|
||||||
(join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case
|
(join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case
|
||||||
Just LmsBlocked{} -> return $ Just "Failed"
|
Just LmsBlocked{} -> return $ Just "Failed"
|
||||||
Just LmsExpired{} -> return $ Just "Expired"
|
Just LmsExpired{} -> return $ Just "Expired"
|
||||||
Just LmsSuccess{} -> return $ Just "Success"
|
Just LmsSuccess{} -> return $ Just "Success"
|
||||||
Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $
|
Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $
|
||||||
preview (resultLmsUser . _entityVal . _lmsUserStarted)
|
preview (resultLmsUser . _entityVal . _lmsUserStarted)
|
||||||
getStatusPlusDay =
|
getStatusPlusDay =
|
||||||
(join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case
|
(join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case
|
||||||
lsd@(Just _) -> return lsd
|
lsd@(Just _) -> return lsd
|
||||||
Nothing -> preview (resultLmsUser . _entityVal . _lmsUserStarted)
|
Nothing -> preview (resultLmsUser . _entityVal . _lmsUserStarted)
|
||||||
|
|
||||||
dbtCsvDecode = Nothing
|
dbtCsvDecode = Nothing
|
||||||
dbtExtraReps = []
|
dbtExtraReps = []
|
||||||
dbtParams = DBParamsForm
|
dbtParams = DBParamsForm
|
||||||
{ dbParamsFormMethod = POST
|
{ dbParamsFormMethod = POST
|
||||||
, dbParamsFormAction = Nothing
|
, dbParamsFormAction = Nothing
|
||||||
@ -518,7 +520,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
|||||||
|
|
||||||
getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html
|
getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||||
getQualificationR = postQualificationR
|
getQualificationR = postQualificationR
|
||||||
postQualificationR sid qsh = do
|
postQualificationR sid qsh = do
|
||||||
isAdmin <- hasReadAccessTo AdminR
|
isAdmin <- hasReadAccessTo AdminR
|
||||||
msgGrantWarning <- messageIconI Warning IconWarning MsgQualificationActGrantWarning
|
msgGrantWarning <- messageIconI Warning IconWarning MsgQualificationActGrantWarning
|
||||||
msgUnexpire <- messageIconI Info IconWarning MsgQualificationActUnexpireWarning
|
msgUnexpire <- messageIconI Info IconWarning MsgQualificationActUnexpireWarning
|
||||||
@ -533,13 +535,13 @@ postQualificationR sid qsh = do
|
|||||||
}} <- getBy404 $ SchoolQualificationShort sid qsh
|
}} <- getBy404 $ SchoolQualificationShort sid qsh
|
||||||
|
|
||||||
-- Block copied to Handler/Qualifications TODO: refactor
|
-- Block copied to Handler/Qualifications TODO: refactor
|
||||||
let getBlockReasons unblk = Ex.select $ do
|
let getBlockReasons unblk = Ex.select $ do
|
||||||
(quser :& qblock) <- Ex.from $ Ex.table @QualificationUser
|
(quser :& qblock) <- Ex.from $ Ex.table @QualificationUser
|
||||||
`Ex.innerJoin` Ex.table @QualificationUserBlock
|
`Ex.innerJoin` Ex.table @QualificationUserBlock
|
||||||
`Ex.on` (\(quser :& qblock) -> quser Ex.^. QualificationUserId Ex.==. qblock Ex.^. QualificationUserBlockQualificationUser)
|
`Ex.on` (\(quser :& qblock) -> quser Ex.^. QualificationUserId Ex.==. qblock Ex.^. QualificationUserBlockQualificationUser)
|
||||||
Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. Ex.val qid
|
Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. Ex.val qid
|
||||||
Ex.&&. unblk (qblock Ex.^. QualificationUserBlockUnblock)
|
Ex.&&. unblk (qblock Ex.^. QualificationUserBlockUnblock)
|
||||||
Ex.groupBy (qblock Ex.^. QualificationUserBlockReason)
|
Ex.groupBy (qblock Ex.^. QualificationUserBlockReason)
|
||||||
let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows
|
let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows
|
||||||
Ex.orderBy [Ex.desc countRows']
|
Ex.orderBy [Ex.desc countRows']
|
||||||
Ex.limit 7
|
Ex.limit 7
|
||||||
@ -553,67 +555,82 @@ postQualificationR sid qsh = do
|
|||||||
acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
|
acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
|
||||||
acts = mconcat $
|
acts = mconcat $
|
||||||
[ singletonMap QualificationActExpire $ pure QualificationActExpireData
|
[ singletonMap QualificationActExpire $ pure QualificationActExpireData
|
||||||
, singletonMap QualificationActUnexpire $ QualificationActUnexpireData
|
, singletonMap QualificationActUnexpire $ QualificationActUnexpireData
|
||||||
<$ aformMessage msgUnexpire
|
<$ aformMessage msgUnexpire
|
||||||
] ++ bool
|
] ++ bool
|
||||||
-- nonAdmin actions, ie. Supervisor
|
-- nonAdmin actions, ie. Supervisor
|
||||||
[ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ]
|
[ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ]
|
||||||
-- Admin-only actions
|
-- Admin-only actions
|
||||||
[ singletonMap QualificationActUnblock $ QualificationActUnblockData
|
[ singletonMap QualificationActUnblock $ QualificationActUnblockData
|
||||||
<$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing
|
<$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing
|
||||||
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
|
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
|
||||||
, singletonMap QualificationActBlock $ QualificationActBlockData
|
, singletonMap QualificationActBlock $ QualificationActBlockData
|
||||||
<$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing
|
<$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing
|
||||||
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
|
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
|
||||||
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False)
|
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False)
|
||||||
, singletonMap QualificationActRenew $ QualificationActRenewData
|
, singletonMap QualificationActRenew $ QualificationActRenewData
|
||||||
<$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationRenewReason) Nothing
|
<$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationRenewReason) Nothing
|
||||||
, singletonMap QualificationActGrant $ QualificationActGrantData
|
, singletonMap QualificationActGrant $ QualificationActGrantData
|
||||||
<$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
|
<$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
|
||||||
<* aformMessage msgGrantWarning
|
<* aformMessage msgGrantWarning
|
||||||
|
, singletonMap QualificationActStartELearning $ pure QualificationActStartELearningData
|
||||||
|
-- <$> aopt dayField (fslI MsgQualificationReduceValidUntil) Nothing
|
||||||
] isAdmin
|
] isAdmin
|
||||||
linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh)
|
linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh)
|
||||||
linkUserName = bool ForProfileR ForProfileDataR isAdmin
|
linkUserName = bool ForProfileR ForProfileDataR isAdmin
|
||||||
colChoices cmpMap = mconcat
|
colChoices cmpMap = mconcat
|
||||||
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
||||||
, colUserNameModalHdr MsgLmsUser linkUserName
|
, colUserNameModalHdr MsgLmsUser linkUserName
|
||||||
, colUserEmail
|
, colUserEmail
|
||||||
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
|
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
|
||||||
let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
|
let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
|
||||||
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
|
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
|
||||||
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
|
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
|
||||||
]
|
]
|
||||||
in intercalate spacerCell cs
|
in intercalate spacerCell cs
|
||||||
, guardMonoid isAdmin $ colUserMatriclenr isAdmin
|
, guardMonoid isAdmin $ colUserMatriclenr isAdmin
|
||||||
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
|
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
|
||||||
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
|
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
|
||||||
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
|
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
|
||||||
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil))
|
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil))
|
||||||
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
|
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
|
||||||
qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row
|
qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row
|
||||||
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
|
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
|
||||||
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
|
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
|
||||||
, sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths))
|
, sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths))
|
||||||
$ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusCell isAdmin linkLmsUser) lu
|
$ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusCell isAdmin linkLmsUser) lu
|
||||||
-- QualificationUserLastNotified is about notification on actual validity changes. If a user's licence is about to expire and renewed before expiry via e-learning, this value does not change.
|
-- QualificationUserLastNotified is about notification on actual validity changes. If a user's licence is about to expire and renewed before expiry via e-learning, this value does not change.
|
||||||
-- NOTE: If this column is reinstatiated, header and tooltip were already updated to avoid any confusion!
|
-- NOTE: If this column is reinstatiated, header and tooltip were already updated to avoid any confusion!
|
||||||
-- , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified & cellTooltip MsgTableQualificationLastNotifiedTooltip)
|
-- , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified & cellTooltip MsgTableQualificationLastNotifiedTooltip)
|
||||||
-- $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d
|
-- $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d
|
||||||
]
|
]
|
||||||
psValidator = def & defaultSorting [SortDescBy "last-refresh"]
|
psValidator = def & defaultSorting [SortDescBy "last-refresh"]
|
||||||
tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
|
tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
|
||||||
return (tbl, qent)
|
return (tbl, qent)
|
||||||
|
|
||||||
formResult lmsRes $ \case
|
formResult lmsRes $ \case
|
||||||
(QualificationActRenewData renewReason, selectedUsers) | isAdmin -> do
|
(QualificationActRenewData renewReason, selectedUsers) | isAdmin -> do
|
||||||
noks <- runDB $ renewValidQualificationUsers qid (canonical $ Just $ Left renewReason) Nothing $ Set.toList selectedUsers
|
noks <- runDB $ renewValidQualificationUsers qid (canonical $ Just $ Left renewReason) Nothing $ Set.toList selectedUsers
|
||||||
addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
|
addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
|
||||||
reloadKeepGetParams $ QualificationR sid qsh
|
reloadKeepGetParams $ QualificationR sid qsh
|
||||||
(QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
|
(QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
|
||||||
runDB . forM_ selectedUsers $ upsertQualificationUser qid now grantValidday Nothing "Admin"
|
runDB . forM_ selectedUsers $ upsertQualificationUser qid now grantValidday Nothing "Admin"
|
||||||
addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
|
addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
|
||||||
reloadKeepGetParams $ QualificationR sid qsh
|
reloadKeepGetParams $ QualificationR sid qsh
|
||||||
(action, selectedUsers) | isExpiryAct action -> do
|
(QualificationActStartELearningData, Set.toList -> selectedUsers) | isAdmin -> do
|
||||||
|
-- whenIsJust mbExpDay $ \expDay ->
|
||||||
|
-- when expDay > nowaday $
|
||||||
|
-- -- updateWhere [QualificationUserQualification ==. qid, QualificationUserUser <-. selectedUsers, QualificationUserValidUntil >. expDay] [QualificationUserValidUntil =. expDay] -- DO NOT USE: no audit
|
||||||
|
-- NOTE: if needed, create function Handler.Utils.Qualification.updateQualificationUser qid QualificationChangeReason -> Day -> [UserId] -> DB Int
|
||||||
|
validQualHolderEnts <- runDB $ selectValidQualifications qid selectedUsers now
|
||||||
|
let validQualHolders = view (_entityVal . _qualificationUserUser) <$> validQualHolderEnts
|
||||||
|
jobs <- forM validQualHolders $ queueJob . JobLmsEnqueueUser qid
|
||||||
|
let nrTodo = length selectedUsers
|
||||||
|
nrEnqueued = length $ catMaybes jobs
|
||||||
|
addMessageI (bool Warning Success $ nrEnqueued > 0 && nrEnqueued == nrTodo) $ MsgQualificationActStartELearningStatus qsh nrEnqueued nrTodo
|
||||||
|
-- transaction audit identical to automatic start, performed by JobLmsEnqueueUser
|
||||||
|
reloadKeepGetParams $ QualificationR sid qsh
|
||||||
|
(action, selectedUsers) | isExpiryAct action -> do
|
||||||
let isUnexpire = action == QualificationActUnexpireData
|
let isUnexpire = action == QualificationActUnexpireData
|
||||||
upd <- runDB $ do
|
upd <- runDB $ do
|
||||||
forM_ selectedUsers $ \uid -> audit TransactionQualificationUserScheduleRenewal
|
forM_ selectedUsers $ \uid -> audit TransactionQualificationUserScheduleRenewal
|
||||||
@ -628,18 +645,18 @@ postQualificationR sid qsh = do
|
|||||||
msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
|
msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
|
||||||
addMessageI msgKind msgVal
|
addMessageI msgKind msgVal
|
||||||
reloadKeepGetParams $ QualificationR sid qsh
|
reloadKeepGetParams $ QualificationR sid qsh
|
||||||
(action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do
|
(action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do
|
||||||
let selUserIds = Set.toList selectedUsers
|
let selUserIds = Set.toList selectedUsers
|
||||||
(unblock, reason) = case action of
|
(unblock, reason) = case action of
|
||||||
QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany)
|
QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany)
|
||||||
QualificationActBlockData{..} -> (False, Left qualTableActBlockReason)
|
QualificationActBlockData{..} -> (False, Left qualTableActBlockReason)
|
||||||
QualificationActUnblockData{..} -> (True , Left qualTableActBlockReason)
|
QualificationActUnblockData{..} -> (True , Left qualTableActBlockReason)
|
||||||
_ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks
|
_ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks
|
||||||
notify = case action of
|
notify = case action of
|
||||||
QualificationActBlockData{qualTableActNotify} -> qualTableActNotify
|
QualificationActBlockData{qualTableActNotify} -> qualTableActNotify
|
||||||
_ -> False
|
_ -> False
|
||||||
|
|
||||||
oks <- runDB $ do
|
oks <- runDB $ do
|
||||||
when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds]
|
when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds]
|
||||||
qualificationUserBlocking qid selUserIds unblock Nothing reason notify
|
qualificationUserBlocking qid selUserIds unblock Nothing reason notify
|
||||||
let nrq = length selectedUsers
|
let nrq = length selectedUsers
|
||||||
|
|||||||
@ -30,9 +30,9 @@ statusQualificationBlock s = statusHtml (bool Error Success s) $ iconQualificati
|
|||||||
-- needs refactoring, probbably no longer helpful
|
-- needs refactoring, probbably no longer helpful
|
||||||
mkQualificationBlocked :: QualificationStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock
|
mkQualificationBlocked :: QualificationStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock
|
||||||
mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..}
|
mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..}
|
||||||
where
|
where
|
||||||
qualificationUserBlockReason = tshow reason
|
qualificationUserBlockReason = tshow reason
|
||||||
qualificationUserBlockUnblock = False
|
qualificationUserBlockUnblock = False
|
||||||
qualificationUserBlockBlocker = Nothing
|
qualificationUserBlockBlocker = Nothing
|
||||||
|
|
||||||
-- somewhat dangerous, if not used with latest effective block
|
-- somewhat dangerous, if not used with latest effective block
|
||||||
@ -54,7 +54,7 @@ quserToNotify cutoff quser qblock = -- either recently become invalid with no pr
|
|||||||
E.&&. quser E.^. QualificationUserValidUntil E.>. E.day (quser E.^. QualificationUserLastNotified)
|
E.&&. quser E.^. QualificationUserValidUntil E.>. E.day (quser E.^. QualificationUserLastNotified)
|
||||||
E.&&. E.not_ (E.isFalse (qblock E.?. QualificationUserBlockUnblock)) -- not currently blocked
|
E.&&. E.not_ (E.isFalse (qblock E.?. QualificationUserBlockUnblock)) -- not currently blocked
|
||||||
) E.||. ( -- was recently blocked
|
) E.||. ( -- was recently blocked
|
||||||
E.isFalse (qblock E.?. QualificationUserBlockUnblock)
|
E.isFalse (qblock E.?. QualificationUserBlockUnblock)
|
||||||
E.&&. qblock E.?. QualificationUserBlockFrom E.>. E.just (quser E.^. QualificationUserLastNotified)
|
E.&&. qblock E.?. QualificationUserBlockFrom E.>. E.just (quser E.^. QualificationUserLastNotified)
|
||||||
))
|
))
|
||||||
|
|
||||||
@ -73,8 +73,8 @@ isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. Qualificatio
|
|||||||
|
|
||||||
-- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_`
|
-- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_`
|
||||||
quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
|
quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
|
||||||
quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do
|
quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do
|
||||||
qualUserBlock <- E.from $ E.table @QualificationUserBlock
|
qualUserBlock <- E.from $ E.table @QualificationUserBlock
|
||||||
E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock)
|
E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock)
|
||||||
E.&&. (qualUserBlock E.^. QualificationUserBlockFrom E.<=. cutoff)
|
E.&&. (qualUserBlock E.^. QualificationUserBlockFrom E.<=. cutoff)
|
||||||
E.&&. checkQualUserId (qualUserBlock E.^. QualificationUserBlockQualificationUser)
|
E.&&. checkQualUserId (qualUserBlock E.^. QualificationUserBlockQualificationUser)
|
||||||
@ -87,11 +87,11 @@ quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists
|
|||||||
)
|
)
|
||||||
whenIsJust mbBlockCondition (E.where_ . ($ qualUserBlock))
|
whenIsJust mbBlockCondition (E.where_ . ($ qualUserBlock))
|
||||||
|
|
||||||
-- | Test whether a QualificationUser was blocked/unblocked at a given day; negCond: True:isBlocked False:isUnblocked
|
-- | Test whether a QualificationUser was blocked/unblocked at a given day; negCond: True:isBlocked False:isUnblocked
|
||||||
quserBlock :: Bool -> UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
|
quserBlock :: Bool -> UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
|
||||||
quserBlock negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.==. (qualUser E.^. QualificationUserId)) Nothing
|
quserBlock negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.==. (qualUser E.^. QualificationUserId)) Nothing
|
||||||
|
|
||||||
-- | Variant of `isBlocked` for outer joins
|
-- | Variant of `isBlocked` for outer joins
|
||||||
quserBlock' :: Bool -> UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
|
quserBlock' :: Bool -> UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
|
||||||
quserBlock' negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.=?. (qualUser E.?. QualificationUserId)) Nothing
|
quserBlock' negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.=?. (qualUser E.?. QualificationUserId)) Nothing
|
||||||
|
|
||||||
@ -112,15 +112,15 @@ validQualification' cutoff qualUser =
|
|||||||
E.&&. quserBlock' False cutoff qualUser
|
E.&&. quserBlock' False cutoff qualUser
|
||||||
|
|
||||||
-- selectValidQualifications :: QualificationId -> [UserId] -> UTCTime -> DB [Entity QualificationUser]
|
-- selectValidQualifications :: QualificationId -> [UserId] -> UTCTime -> DB [Entity QualificationUser]
|
||||||
selectValidQualifications ::
|
selectValidQualifications ::
|
||||||
( MonadIO m
|
( MonadIO m
|
||||||
, BackendCompatible SqlBackend backend
|
, BackendCompatible SqlBackend backend
|
||||||
, PersistQueryRead backend
|
, PersistQueryRead backend
|
||||||
, PersistUniqueRead backend
|
, PersistUniqueRead backend
|
||||||
) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
|
) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
|
||||||
selectValidQualifications qid uids cutoff =
|
selectValidQualifications qid uids cutoff =
|
||||||
-- cutoff <- utctDay <$> liftIO getCurrentTime
|
-- cutoff <- utctDay <$> liftIO getCurrentTime
|
||||||
E.select $ do
|
E.select $ do
|
||||||
qUser <- E.from $ E.table @QualificationUser
|
qUser <- E.from $ E.table @QualificationUser
|
||||||
E.where_ $ (qUser E.^. QualificationUserQualification E.==. E.val qid)
|
E.where_ $ (qUser E.^. QualificationUserQualification E.==. E.val qid)
|
||||||
E.&&. qUser E.^. QualificationUserUser `E.in_` E.valList uids
|
E.&&. qUser E.^. QualificationUserUser `E.in_` E.valList uids
|
||||||
@ -142,7 +142,7 @@ upsertQualificationUser qualificationUserQualification startTime qualificationU
|
|||||||
let qualificationUserLastRefresh = utctDay startTime
|
let qualificationUserLastRefresh = utctDay startTime
|
||||||
Entity quid _ <- upsert
|
Entity quid _ <- upsert
|
||||||
QualificationUser
|
QualificationUser
|
||||||
{ qualificationUserFirstHeld = qualificationUserLastRefresh
|
{ qualificationUserFirstHeld = qualificationUserLastRefresh
|
||||||
, qualificationUserScheduleRenewal = fromMaybe True mbScheduleRenewal
|
, qualificationUserScheduleRenewal = fromMaybe True mbScheduleRenewal
|
||||||
, qualificationUserLastNotified = utctDayMidnight qualificationUserLastRefresh
|
, qualificationUserLastNotified = utctDayMidnight qualificationUserLastRefresh
|
||||||
, ..
|
, ..
|
||||||
@ -151,7 +151,7 @@ upsertQualificationUser qualificationUserQualification startTime qualificationU
|
|||||||
[ QualificationUserScheduleRenewal =. scheduleRenewal | Just scheduleRenewal <- [mbScheduleRenewal]
|
[ QualificationUserScheduleRenewal =. scheduleRenewal | Just scheduleRenewal <- [mbScheduleRenewal]
|
||||||
] ++
|
] ++
|
||||||
[ QualificationUserValidUntil =. qualificationUserValidUntil
|
[ QualificationUserValidUntil =. qualificationUserValidUntil
|
||||||
, QualificationUserLastRefresh =. qualificationUserLastRefresh
|
, QualificationUserLastRefresh =. qualificationUserLastRefresh
|
||||||
]
|
]
|
||||||
)
|
)
|
||||||
authUsr <- liftHandler maybeAuthId
|
authUsr <- liftHandler maybeAuthId
|
||||||
@ -166,8 +166,8 @@ upsertQualificationUser qualificationUserQualification startTime qualificationU
|
|||||||
}
|
}
|
||||||
|
|
||||||
-- | Renew an existing valid qualification, ignoring all blocks otherwise
|
-- | Renew an existing valid qualification, ignoring all blocks otherwise
|
||||||
-- renewValidQualificationUsers :: QualificationId -> Maybe UTCTime -> [UserId] -> DB Int -- not general enough for use in YesodJobDB
|
-- renewValidQualificationUsers :: QualificationId -> Maybe QualificationChangeReason -> Maybe UTCTime -> [UserId] -> DB Int -- not general enough for use in YesodJobDB
|
||||||
renewValidQualificationUsers ::
|
renewValidQualificationUsers ::
|
||||||
( AuthId (HandlerSite m) ~ Key User
|
( AuthId (HandlerSite m) ~ Key User
|
||||||
, IsPersistBackend (YesodPersistBackend (HandlerSite m))
|
, IsPersistBackend (YesodPersistBackend (HandlerSite m))
|
||||||
, BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
|
, BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
|
||||||
@ -178,7 +178,7 @@ renewValidQualificationUsers ::
|
|||||||
, YesodAuthPersist (HandlerSite m)
|
, YesodAuthPersist (HandlerSite m)
|
||||||
, HasAppSettings (HandlerSite m)
|
, HasAppSettings (HandlerSite m)
|
||||||
, MonadHandler m
|
, MonadHandler m
|
||||||
, MonadCatch m
|
, MonadCatch m
|
||||||
) => QualificationId -> Maybe QualificationChangeReason -> Maybe UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int
|
) => QualificationId -> Maybe QualificationChangeReason -> Maybe UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int
|
||||||
renewValidQualificationUsers qid reason renewalTime uids =
|
renewValidQualificationUsers qid reason renewalTime uids =
|
||||||
-- The following short code snippet suffices in principle, but would not allow audit log entries. Are these still needed?
|
-- The following short code snippet suffices in principle, but would not allow audit log entries. Are these still needed?
|
||||||
@ -186,14 +186,14 @@ renewValidQualificationUsers qid reason renewalTime uids =
|
|||||||
-- E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only
|
-- E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only
|
||||||
-- E.where_ $ (qu E.^. QualificationUserQualification E.==. E.val qid )
|
-- E.where_ $ (qu E.^. QualificationUserQualification E.==. E.val qid )
|
||||||
-- E.&&. (qu E.^. QualificationUserUser `E.in_` E.valList uids)
|
-- E.&&. (qu E.^. QualificationUserUser `E.in_` E.valList uids)
|
||||||
get qid >>= \case
|
get qid >>= \case
|
||||||
Just Qualification{qualificationValidDuration=Just renewalMonths} -> do
|
Just Qualification{qualificationValidDuration=Just renewalMonths} -> do
|
||||||
cutoff <- maybe (liftIO getCurrentTime) return renewalTime
|
cutoff <- maybe (liftIO getCurrentTime) return renewalTime
|
||||||
quEntsAll <- selectValidQualifications qid uids cutoff
|
quEntsAll <- selectValidQualifications qid uids cutoff
|
||||||
let cutoffday = utctDay cutoff
|
let cutoffday = utctDay cutoff
|
||||||
maxValidTo = addGregorianMonthsRollOver (toInteger $ renewalMonths `div` 2) cutoffday
|
maxValidTo = addGregorianMonthsRollOver (toInteger $ renewalMonths `div` 2) cutoffday
|
||||||
quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll
|
quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll
|
||||||
forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do
|
forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do
|
||||||
let newValidTo = computeNewValidDate renewalMonths qualificationUserValidUntil
|
let newValidTo = computeNewValidDate renewalMonths qualificationUserValidUntil
|
||||||
update quId [ QualificationUserValidUntil =. newValidTo
|
update quId [ QualificationUserValidUntil =. newValidTo
|
||||||
, QualificationUserLastRefresh =. cutoffday
|
, QualificationUserLastRefresh =. cutoffday
|
||||||
@ -210,7 +210,7 @@ renewValidQualificationUsers qid reason renewalTime uids =
|
|||||||
_ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.
|
_ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.
|
||||||
|
|
||||||
-- | Block or unblock some users for a given reason, but only if they are not already blocked (essential assumption that is actually used)
|
-- | Block or unblock some users for a given reason, but only if they are not already blocked (essential assumption that is actually used)
|
||||||
qualificationUserBlocking ::
|
qualificationUserBlocking ::
|
||||||
( AuthId (HandlerSite m) ~ Key User
|
( AuthId (HandlerSite m) ~ Key User
|
||||||
, IsPersistBackend (YesodPersistBackend (HandlerSite m))
|
, IsPersistBackend (YesodPersistBackend (HandlerSite m))
|
||||||
, BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
|
, BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
|
||||||
@ -228,10 +228,10 @@ qualificationUserBlocking qid uids unblock mbBlockTime (qualificationChangeReaso
|
|||||||
$logInfoS "BLOCK" $ Text.intercalate " - " [tshow qid, tshow uids, tshow unblock, tshow mbBlockTime, tshow reason, tshow notify]
|
$logInfoS "BLOCK" $ Text.intercalate " - " [tshow qid, tshow uids, tshow unblock, tshow mbBlockTime, tshow reason, tshow notify]
|
||||||
authUsr <- liftHandler maybeAuthId
|
authUsr <- liftHandler maybeAuthId
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
let blockTime = fromMaybe now mbBlockTime
|
let blockTime = fromMaybe now mbBlockTime
|
||||||
-- -- Code would work, but problematic
|
-- -- Code would work, but problematic
|
||||||
-- oks <- E.insertSelectCount . E.from $ \qualificationUser -> do
|
-- oks <- E.insertSelectCount . E.from $ \qualificationUser -> do
|
||||||
-- E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid
|
-- E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid
|
||||||
-- E.&&. qualificationUser E.^. QualificationUserUser E.in_ E.valList uid
|
-- E.&&. qualificationUser E.^. QualificationUserUser E.in_ E.valList uid
|
||||||
-- E.&&. quserBlock unblock blockTime qualificationUser -- only unblock blocked qualification and vice versa
|
-- E.&&. quserBlock unblock blockTime qualificationUser -- only unblock blocked qualification and vice versa
|
||||||
-- return $ QualificationUserBlock
|
-- return $ QualificationUserBlock
|
||||||
@ -242,7 +242,7 @@ qualificationUserBlocking qid uids unblock mbBlockTime (qualificationChangeReaso
|
|||||||
-- E.<&> E.val authUsr
|
-- E.<&> E.val authUsr
|
||||||
toChange <- E.select $ do
|
toChange <- E.select $ do
|
||||||
qualUser <- E.from $ E.table @QualificationUser
|
qualUser <- E.from $ E.table @QualificationUser
|
||||||
E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid
|
E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid
|
||||||
E.&&. qualUser E.^. QualificationUserUser `E.in_` E.valList uids
|
E.&&. qualUser E.^. QualificationUserUser `E.in_` E.valList uids
|
||||||
E.&&. quserBlock unblock blockTime qualUser -- only unblock blocked qualification and vice versa
|
E.&&. quserBlock unblock blockTime qualUser -- only unblock blocked qualification and vice versa
|
||||||
return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser)
|
return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser)
|
||||||
@ -262,7 +262,7 @@ qualificationUserBlocking qid uids unblock mbBlockTime (qualificationChangeReaso
|
|||||||
}
|
}
|
||||||
return $ fromIntegral $ length newBlocks
|
return $ fromIntegral $ length newBlocks
|
||||||
|
|
||||||
qualificationUserUnblockByReason ::
|
qualificationUserUnblockByReason ::
|
||||||
( AuthId (HandlerSite m) ~ Key User
|
( AuthId (HandlerSite m) ~ Key User
|
||||||
, IsPersistBackend (YesodPersistBackend (HandlerSite m))
|
, IsPersistBackend (YesodPersistBackend (HandlerSite m))
|
||||||
, BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
|
, BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
|
||||||
@ -277,11 +277,11 @@ qualificationUserUnblockByReason ::
|
|||||||
, Num n
|
, Num n
|
||||||
) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationChangeReason -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
|
) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationChangeReason -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
|
||||||
qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationChangeReasonText -> reason) undo_reason notify = do
|
qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationChangeReasonText -> reason) undo_reason notify = do
|
||||||
cutoff <- maybe (liftIO getCurrentTime) return mbUnblockTime
|
cutoff <- maybe (liftIO getCurrentTime) return mbUnblockTime
|
||||||
toUnblock <- E.select $ do
|
toUnblock <- E.select $ do
|
||||||
quser <- E.from $ E.table @QualificationUser
|
quser <- E.from $ E.table @QualificationUser
|
||||||
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||||
E.&&. quser E.^. QualificationUserUser `E.in_` E.valList uids
|
E.&&. quser E.^. QualificationUserUser `E.in_` E.valList uids
|
||||||
E.&&. quserBlockAux True (E.val cutoff) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason))
|
E.&&. quserBlockAux True (E.val cutoff) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason))
|
||||||
return $ quser E.^. QualificationUserUser
|
return $ quser E.^. QualificationUserUser
|
||||||
qualificationUserBlocking qid (E.unValue <$> toUnblock) True mbUnblockTime undo_reason notify
|
qualificationUserBlocking qid (E.unValue <$> toUnblock) True mbUnblockTime undo_reason notify
|
||||||
|
|||||||
@ -129,7 +129,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
|||||||
qprefix = fst <$> Text.uncons (Text.toLower qshort)
|
qprefix = fst <$> Text.uncons (Text.toLower qshort)
|
||||||
identsInUseVs <- E.select $ do
|
identsInUseVs <- E.select $ do
|
||||||
lui <- E.from $
|
lui <- E.from $
|
||||||
( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser ) ) -- no filter by Qid, since LmsIdents must be unique across all
|
( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser ) ) -- no filter by qid, since LmsIdents must be unique across all
|
||||||
`E.union_`
|
`E.union_`
|
||||||
( (E.^. LmsReportIdent) <$> E.from (E.table @LmsReport ) ) -- V2
|
( (E.^. LmsReportIdent) <$> E.from (E.table @LmsReport ) ) -- V2
|
||||||
E.orderBy [E.asc lui]
|
E.orderBy [E.asc lui]
|
||||||
@ -152,20 +152,20 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
|||||||
, lmsUserEnded = Nothing
|
, lmsUserEnded = Nothing
|
||||||
, lmsUserResetTries = False
|
, lmsUserResetTries = False
|
||||||
, lmsUserLocked = True -- initially display locked, since it is not yet available until the first feedback
|
, lmsUserLocked = True -- initially display locked, since it is not yet available until the first feedback
|
||||||
}
|
}
|
||||||
-- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
|
-- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
|
||||||
startLmsUser = do
|
startLmsUser = do
|
||||||
lpw <- randomLMSpw
|
lpw <- randomLMSpw
|
||||||
maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse)
|
maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse)
|
||||||
-- runMaybeT $ do
|
-- runMaybeT $ do
|
||||||
-- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse
|
-- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse
|
||||||
-- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid
|
-- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid
|
||||||
getBy uniqLmsUse >>= \case
|
getBy uniqLmsUse >>= \case
|
||||||
Just Entity{entityVal=LmsUser{..}}
|
Just Entity{entityVal=LmsUser{..}}
|
||||||
| isNothing lmsUserEnded, isNothing lmsUserStatus || lmsUserStatus == Just LmsSuccess -> do
|
| isNothing lmsUserEnded, isNothing lmsUserStatus || lmsUserStatus == Just LmsSuccess -> do
|
||||||
uuid :: CryptoUUIDUser <- encrypt uid
|
uuid :: CryptoUUIDUser <- encrypt uid
|
||||||
$logErrorS "LMS" $ "Generating fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> " due to LMS still existing!"
|
$logErrorS "LMS" $ "Generating fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> " due to LMS still existing!"
|
||||||
other -> do
|
other -> do
|
||||||
when (isJust other) $ deleteBy uniqLmsUse
|
when (isJust other) $ deleteBy uniqLmsUse
|
||||||
untilJustMaxM maxLmsUserIdentRetries startLmsUser >>= \case
|
untilJustMaxM maxLmsUserIdentRetries startLmsUser >>= \case
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
@ -211,7 +211,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
|||||||
E.where_ $ E.isNothing (luser E.^. LmsUserStatus)
|
E.where_ $ E.isNothing (luser E.^. LmsUserStatus)
|
||||||
E.&&. luser E.^. LmsUserQualification E.==. E.val qid
|
E.&&. luser E.^. LmsUserQualification E.==. E.val qid
|
||||||
E.&&. (luser E.^. LmsUserId) `E.in_` E.valList expiredLearners
|
E.&&. (luser E.^. LmsUserId) `E.in_` E.valList expiredLearners
|
||||||
let dequeueInfo = "Blocked qualification holders " <> tshow nrBlocked <> " out of expired lms users " <> tshow nrExpired <> " for qualification " <> qshort
|
let dequeueInfo = "Blocked qualification holders " <> tshow nrBlocked <> " out of expired lms users " <> tshow nrExpired <> " for qualification " <> qshort
|
||||||
$logInfoS "LMS" dequeueInfo
|
$logInfoS "LMS" dequeueInfo
|
||||||
|
|
||||||
when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers
|
when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers
|
||||||
|
|||||||
@ -8,13 +8,13 @@ Description: Types for Learning Management System Interface operated by Know how
|
|||||||
|
|
||||||
-}
|
-}
|
||||||
module Model.Types.Lms
|
module Model.Types.Lms
|
||||||
( module Model.Types.Lms
|
( module Model.Types.Lms
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Import.NoModel
|
import Import.NoModel
|
||||||
-- import qualified Data.Map as Map
|
-- import qualified Data.Map as Map
|
||||||
-- import Data.Map ((!))
|
-- import Data.Map ((!))
|
||||||
import Database.Persist.Sql
|
import Database.Persist.Sql
|
||||||
import qualified Database.Esqueleto.Experimental as E
|
import qualified Database.Esqueleto.Experimental as E
|
||||||
import qualified Data.Csv as Csv
|
import qualified Data.Csv as Csv
|
||||||
import qualified Data.Time.Format as Time
|
import qualified Data.Time.Format as Time
|
||||||
@ -28,19 +28,19 @@ instance E.SqlString LmsIdent
|
|||||||
makeLenses_ ''LmsIdent
|
makeLenses_ ''LmsIdent
|
||||||
|
|
||||||
deriveJSON defaultOptions
|
deriveJSON defaultOptions
|
||||||
{ constructorTagModifier = camelToPathPiece' 1
|
{ constructorTagModifier = camelToPathPiece' 1
|
||||||
, fieldLabelModifier = camelToPathPiece' 2
|
, fieldLabelModifier = camelToPathPiece' 2
|
||||||
, omitNothingFields = True
|
, omitNothingFields = True
|
||||||
} ''LmsIdent
|
} ''LmsIdent
|
||||||
|
|
||||||
-- TODO: Is this a good idea? An ordinary Enum and a separate Day column in the DB would be better, e.g. allowing use of insertSelect in Jobs.Handler.LMS?
|
-- TODO: Is this a good idea? An ordinary Enum and a separate Day column in the DB would be better, e.g. allowing use of insertSelect in Jobs.Handler.LMS?
|
||||||
-- ...also see similar type QualificationBlocked
|
-- ...also see similar type QualificationBlocked
|
||||||
data LmsStatus = LmsExpired
|
data LmsStatus = LmsExpired
|
||||||
| LmsBlocked
|
| LmsBlocked
|
||||||
| LmsSuccess
|
| LmsSuccess
|
||||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, NFData, Universe, Finite)
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, NFData, Universe, Finite)
|
||||||
|
|
||||||
-- embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3) -- moved to src/Foundation.hs
|
-- embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3) -- moved to src/Foundation.I18n
|
||||||
|
|
||||||
deriveJSON defaultOptions
|
deriveJSON defaultOptions
|
||||||
{ constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor
|
{ constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor
|
||||||
@ -59,22 +59,22 @@ instance Csv.ToField LmsStatus where
|
|||||||
data QualificationStandardReason
|
data QualificationStandardReason
|
||||||
= QualificationRenewELearningBy LmsIdent
|
= QualificationRenewELearningBy LmsIdent
|
||||||
| QualificationBlockFailedELearningBy LmsIdent
|
| QualificationBlockFailedELearningBy LmsIdent
|
||||||
| QualificationBlockFailedELearning
|
| QualificationBlockFailedELearning
|
||||||
| QualificationBlockReturnedByCompany
|
| QualificationBlockReturnedByCompany
|
||||||
| QualificationBlockExpired
|
| QualificationBlockExpired
|
||||||
|
|
||||||
-- deriving (Eq, Ord, Enum, Bounded, Universe, Finite)
|
-- deriving (Eq, Ord, Enum, Bounded, Universe, Finite)
|
||||||
|
|
||||||
instance Show QualificationStandardReason where
|
instance Show QualificationStandardReason where
|
||||||
show (QualificationRenewELearningBy lid) = "E-Learning bestanden für " <> show lid
|
show (QualificationRenewELearningBy lid) = "E-Learning bestanden für " <> show lid
|
||||||
show (QualificationBlockFailedELearningBy lid) = "E-Learning durchgefallen für " <> show lid
|
show (QualificationBlockFailedELearningBy lid) = "E-Learning durchgefallen für " <> show lid
|
||||||
show QualificationBlockFailedELearning = "E-Learning durchgefallen"
|
show QualificationBlockFailedELearning = "E-Learning durchgefallen"
|
||||||
show QualificationBlockReturnedByCompany = "Rückgabe Firma"
|
show QualificationBlockReturnedByCompany = "Rückgabe Firma"
|
||||||
show QualificationBlockExpired = "Abgelaufen"
|
show QualificationBlockExpired = "Abgelaufen"
|
||||||
|
|
||||||
{-
|
{-
|
||||||
qualificationBlockedReasonText :: QualificationStandardReason -> Text
|
qualificationBlockedReasonText :: QualificationStandardReason -> Text
|
||||||
qualificationBlockedReasonText =
|
qualificationBlockedReasonText =
|
||||||
let dictionary :: Map.Map QualificationStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF]
|
let dictionary :: Map.Map QualificationStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF]
|
||||||
in (dictionary !) -- cannot fail due to universeF
|
in (dictionary !) -- cannot fail due to universeF
|
||||||
|
|
||||||
@ -95,13 +95,13 @@ newtype LmsBool = LmsBool { lms2bool :: Bool }
|
|||||||
_lmsBool :: Iso' Bool LmsBool
|
_lmsBool :: Iso' Bool LmsBool
|
||||||
_lmsBool = iso LmsBool lms2bool
|
_lmsBool = iso LmsBool lms2bool
|
||||||
|
|
||||||
instance Csv.ToField LmsBool where
|
instance Csv.ToField LmsBool where
|
||||||
toField (LmsBool False) = "0"
|
toField (LmsBool False) = "0"
|
||||||
toField (LmsBool True ) = "1"
|
toField (LmsBool True ) = "1"
|
||||||
|
|
||||||
instance Csv.FromField LmsBool where
|
instance Csv.FromField LmsBool where
|
||||||
parseField "0" = pure $ LmsBool False
|
parseField "0" = pure $ LmsBool False
|
||||||
parseField "1" = pure $ LmsBool True
|
parseField "1" = pure $ LmsBool True
|
||||||
parseField _ = mempty
|
parseField _ = mempty
|
||||||
|
|
||||||
-- | Only to be used in LMS interface communicating user status
|
-- | Only to be used in LMS interface communicating user status
|
||||||
@ -110,18 +110,18 @@ data LmsState = LmsFailed | LmsOpen | LmsPassed
|
|||||||
|
|
||||||
instance Csv.ToField LmsState where
|
instance Csv.ToField LmsState where
|
||||||
toField LmsFailed = "0"
|
toField LmsFailed = "0"
|
||||||
toField LmsOpen = "1"
|
toField LmsOpen = "1"
|
||||||
toField LmsPassed = "2"
|
toField LmsPassed = "2"
|
||||||
|
|
||||||
instance Csv.FromField LmsState where
|
instance Csv.FromField LmsState where
|
||||||
parseField "0" = pure LmsFailed
|
parseField "0" = pure LmsFailed
|
||||||
parseField "1" = pure LmsOpen
|
parseField "1" = pure LmsOpen
|
||||||
parseField "2" = pure LmsPassed
|
parseField "2" = pure LmsPassed
|
||||||
parseField _ = mempty
|
parseField _ = mempty
|
||||||
|
|
||||||
deriveJSON defaultOptions
|
deriveJSON defaultOptions
|
||||||
{ constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor
|
{ constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor
|
||||||
, fieldLabelModifier = camelToPathPiece' 1
|
, fieldLabelModifier = camelToPathPiece' 1
|
||||||
, sumEncoding = UntaggedValue
|
, sumEncoding = UntaggedValue
|
||||||
} ''LmsState
|
} ''LmsState
|
||||||
derivePersistFieldJSON ''LmsState
|
derivePersistFieldJSON ''LmsState
|
||||||
@ -132,21 +132,21 @@ nullaryPathPiece ''LmsState $ camelToPathPiece' 1
|
|||||||
newtype LmsDay = LmsDay { lms2day :: Day }
|
newtype LmsDay = LmsDay { lms2day :: Day }
|
||||||
deriving (Eq, Ord, Read, Show, Generic)
|
deriving (Eq, Ord, Read, Show, Generic)
|
||||||
|
|
||||||
_lmsDay :: Iso' Day LmsDay
|
_lmsDay :: Iso' Day LmsDay
|
||||||
_lmsDay = iso LmsDay lms2day
|
_lmsDay = iso LmsDay lms2day
|
||||||
|
|
||||||
-- | Format for day for LMS interface
|
-- | Format for day for LMS interface
|
||||||
lmsDayFormat :: String
|
lmsDayFormat :: String
|
||||||
lmsDayFormat = "%d-%m-%Y" -- fixed in LMS interface desctiption, due defaultTimeLocale, should not use named entities like weekdays or month names
|
lmsDayFormat = "%d-%m-%Y" -- fixed in LMS interface desctiption, due defaultTimeLocale, should not use named entities like weekdays or month names
|
||||||
|
|
||||||
instance Csv.ToField LmsDay where
|
instance Csv.ToField LmsDay where
|
||||||
toField (LmsDay d) = Csv.toField $ Time.formatTime Time.defaultTimeLocale lmsDayFormat d -- TimeLocale should not matter since format string does not use names; getTimeLocale requires MonadHandler
|
toField (LmsDay d) = Csv.toField $ Time.formatTime Time.defaultTimeLocale lmsDayFormat d -- TimeLocale should not matter since format string does not use names; getTimeLocale requires MonadHandler
|
||||||
|
|
||||||
instance Csv.FromField LmsDay where
|
instance Csv.FromField LmsDay where
|
||||||
-- parseField = fmap LmsDay . parseLmsDay <=< Csv.parseField
|
-- parseField = fmap LmsDay . parseLmsDay <=< Csv.parseField
|
||||||
-- where parseLmsDay = Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat
|
-- where parseLmsDay = Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat
|
||||||
parseField i = do
|
parseField i = do
|
||||||
s <- Csv.parseField i
|
s <- Csv.parseField i
|
||||||
d <- Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat s
|
d <- Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat s
|
||||||
<|> iso8601ParseM s -- Know-How AG considers supplying iso8601 dates in the future
|
<|> iso8601ParseM s -- Know-How AG considers supplying iso8601 dates in the future
|
||||||
return $ LmsDay d
|
return $ LmsDay d
|
||||||
@ -155,21 +155,21 @@ instance Csv.FromField LmsDay where
|
|||||||
newtype LmsTimestamp = LmsTimestamp { lms2timestamp :: UTCTime }
|
newtype LmsTimestamp = LmsTimestamp { lms2timestamp :: UTCTime }
|
||||||
deriving (Eq, Ord, Read, Show, Generic)
|
deriving (Eq, Ord, Read, Show, Generic)
|
||||||
|
|
||||||
_lmsTimestamp :: Iso' UTCTime LmsTimestamp
|
_lmsTimestamp :: Iso' UTCTime LmsTimestamp
|
||||||
_lmsTimestamp = iso LmsTimestamp lms2timestamp
|
_lmsTimestamp = iso LmsTimestamp lms2timestamp
|
||||||
|
|
||||||
-- | Format for day for LMS interface
|
-- | Format for day for LMS interface
|
||||||
lmsTimestampFormat :: String
|
lmsTimestampFormat :: String
|
||||||
lmsTimestampFormat = "%d-%m-%Y %T" -- fixed in LMS interface desctiption, due defaultTimeLocale, should not use named entities like weekdays or month names
|
lmsTimestampFormat = "%d-%m-%Y %T" -- fixed in LMS interface desctiption, due defaultTimeLocale, should not use named entities like weekdays or month names
|
||||||
|
|
||||||
instance Csv.ToField LmsTimestamp where
|
instance Csv.ToField LmsTimestamp where
|
||||||
toField (LmsTimestamp d) = Csv.toField $ Time.formatTime Time.defaultTimeLocale lmsTimestampFormat d -- TimeLocale should not matter since format string does not use names; getTimeLocale requires MonadHandler
|
toField (LmsTimestamp d) = Csv.toField $ Time.formatTime Time.defaultTimeLocale lmsTimestampFormat d -- TimeLocale should not matter since format string does not use names; getTimeLocale requires MonadHandler
|
||||||
|
|
||||||
instance Csv.FromField LmsTimestamp where
|
instance Csv.FromField LmsTimestamp where
|
||||||
-- parseField = fmap LmsDay . parseLmsDay <=< Csv.parseField
|
-- parseField = fmap LmsDay . parseLmsDay <=< Csv.parseField
|
||||||
-- where parseLmsDay = Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat
|
-- where parseLmsDay = Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat
|
||||||
parseField i = do
|
parseField i = do
|
||||||
s <- Csv.parseField i
|
s <- Csv.parseField i
|
||||||
d <- Time.parseTimeM True Time.defaultTimeLocale lmsTimestampFormat s
|
d <- Time.parseTimeM True Time.defaultTimeLocale lmsTimestampFormat s
|
||||||
<|> (utctDayMidnight <$> Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat s)
|
<|> (utctDayMidnight <$> Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat s)
|
||||||
<|> iso8601ParseM s -- Know-How AG considers supplying iso8601 dates in the future
|
<|> iso8601ParseM s -- Know-How AG considers supplying iso8601 dates in the future
|
||||||
|
|||||||
Reference in New Issue
Block a user