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

chore(lms): csv export compiles again -- horray!

Browse Source
This commit is contained in:
Steffen Jost 2022-07-29 10:54:49 +02:00
parent 8aab8b7b6b
commit b6254bc399
1 changed files with 37 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
src/Handler/LMS.hs
View File

@ -187,7 +187,7 @@ makeLenses_ ''LmsTableCsv
ltcOptions :: Csv.Options ltcOptions :: Csv.Options
ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc } ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
where where
renameLtc "ltcDisplayName" = "licensee" renameLtc "ltcDisplayName" = "licensee"
renameLtc "ltcLmsDatePin" = prefixLms "pin-created" renameLtc "ltcLmsDatePin" = prefixLms "pin-created"
renameLtc "ltcLmsReceived" = prefixLms "last-update" renameLtc "ltcLmsReceived" = prefixLms "last-update"
@ -228,10 +228,10 @@ lmsTableCsvHeader = Csv.header $ fst <$> lmsTableCsvHeaderList (error "lmsTableC
} }
-} -}
instance Csv.ToNamedRecord LmsTableCsv where instance Csv.ToNamedRecord LmsTableCsv where
toNamedRecord ltc = Csv.namedRecord $ lmsTableCsvHeaderList ltc toNamedRecord ltc = Csv.namedRecord $ lmsTableCsvHeaderList ltc
instance CsvColumnsExplained LmsTableCsv instance CsvColumnsExplained LmsTableCsv
-- where csvColumnsExplanations _ = ?? -- where csvColumnsExplanations _ = ??
@ -279,18 +279,18 @@ embedRenderMessage ''UniWorX ''LmsTableAction id
-- Not yet needed, since there is no additional data for now: -- Not yet needed, since there is no additional data for now:
data LmsTableActionData = LmsActNotifyData data LmsTableActionData = LmsActNotifyData
| LmsActRenewNotifyData | LmsActRenewNotifyData
| LmsActRenewPinData | LmsActRenewPinData
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
isNotifyAct :: LmsTableActionData -> Bool isNotifyAct :: LmsTableActionData -> Bool
isNotifyAct LmsActNotifyData = True isNotifyAct LmsActNotifyData = True
isNotifyAct LmsActRenewNotifyData = True isNotifyAct LmsActRenewNotifyData = True
isNotifyAct LmsActRenewPinData = False isNotifyAct LmsActRenewPinData = False
isRenewPinAct :: LmsTableActionData -> Bool isRenewPinAct :: LmsTableActionData -> Bool
isRenewPinAct LmsActNotifyData = False isRenewPinAct LmsActNotifyData = False
isRenewPinAct LmsActRenewNotifyData = True isRenewPinAct LmsActRenewNotifyData = True
isRenewPinAct LmsActRenewPinData = True isRenewPinAct LmsActRenewPinData = True
lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
, E.SqlExpr (Entity User) , E.SqlExpr (Entity User)
@ -324,7 +324,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
dbtSQLQuery q = lmsTableQuery qid q <* E.where_ (restrict q) dbtSQLQuery q = lmsTableQuery qid q <* E.where_ (restrict q)
dbtRowKey = queryUser >>> (E.^. UserId) dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = dbtProjFilteredPostId dbtProj = dbtProjFilteredPostId
dbtColonnade = cols dbtColonnade = cols
dbtSorting = mconcat dbtSorting = mconcat
[ single $ sortUserNameLink queryUser [ single $ sortUserNameLink queryUser
@ -366,22 +366,37 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
{ dbtCsvExportForm = pure () { dbtCsvExportForm = pure ()
, dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
, dbtCsvName = "TODO" :: Text , dbtCsvName = "TODO" :: Text
, dbtCsvSheetName = "TODO" :: Text , dbtCsvSheetName = "TODO" :: Text
, dbtCsvNoExportData = Just id , dbtCsvNoExportData = Just id
, dbtCsvHeader = const $ return lmsTableCsvHeader , dbtCsvHeader = const $ return lmsTableCsvHeader
, dbtCsvExampleData = Nothing -- TODO , dbtCsvExampleData = Nothing -- TODO
{- {-
Just Just
[ LmsTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day } [ LmsTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day }
| (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..] | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..]
] ]
-} -}
} }
where where
doEncode' :: LmsTableData -> LmsTableCsv doEncode' :: LmsTableData -> LmsTableCsv
doEncode' = LmsTableCsv doEncode' ltd = LmsTableCsv {
ltcDisplayName = ltd ^. (resultUser . _entityVal . _userDisplayName)
, ltcEmail = ltd ^. (resultUser . _entityVal . _userEmail)
, ltcValidUntil = ltd ^. (resultQualUser . _entityVal . _qualificationUserValidUntil)
, ltcLastRefresh = ltd ^. (resultQualUser . _entityVal . _qualificationUserLastRefresh)
, ltcFirstHeld = ltd ^. (resultQualUser . _entityVal . _qualificationUserFirstHeld)
, ltcLmsIdent = ltd ^? (resultLmsUser . _entityVal . _lmsUserIdent)
, ltcLmsStatus = join $ ltd ^? (resultLmsUser . _entityVal . _lmsUserStatus)
, ltcLmsStarted = ltd ^? (resultLmsUser . _entityVal . _lmsUserStarted)
, ltcLmsDatePin = ltd ^? (resultLmsUser . _entityVal . _lmsUserDatePin)
, ltcLmsReceived = join $ ltd ^? (resultLmsUser . _entityVal . _lmsUserReceived)
, ltcLmsEnded = join $ ltd ^? (_dbrOutput . _3 . _Just . _entityVal . _lmsUserEnded)
}
{-
doEncode' = LmsTableCsv
<$> view (resultUser . _entityVal . _userDisplayName) <$> view (resultUser . _entityVal . _userDisplayName)
<*> view (resultUser . _entityVal . _userEmail) <*> view (resultUser . _entityVal . _userEmail)
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
<*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld)
@ -390,8 +405,8 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
<*> preview (resultLmsUser . _entityVal . _lmsUserStarted) <*> preview (resultLmsUser . _entityVal . _lmsUserStarted)
<*> preview (resultLmsUser . _entityVal . _lmsUserDatePin) <*> preview (resultLmsUser . _entityVal . _lmsUserDatePin)
<*> view (resultLmsUser . _entityVal . _lmsUserReceived) <*> view (resultLmsUser . _entityVal . _lmsUserReceived)
<*> view (resultLmsUser . _entityVal . _lmsUserEnded) <*> view (resultLmsUser . _entityVal . _lmsUserEnded)
-}
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
dbtExtraReps = [] dbtExtraReps = []
@ -467,11 +482,11 @@ postLmsR sid qsh = do
forM_ okUsers $ \(Entity lid LmsUser {lmsUserUser = uid, lmsUserQualification = qid'}) -> do forM_ okUsers $ \(Entity lid LmsUser {lmsUserUser = uid, lmsUserQualification = qid'}) -> do
when (isRenewPinAct action) $ do when (isRenewPinAct action) $ do
newPin <- liftIO randomLMSpw newPin <- liftIO randomLMSpw
update lid [LmsUserPin =. newPin, LmsUserDatePin =. now] update lid [LmsUserPin =. newPin, LmsUserDatePin =. now]
when (isNotifyAct action) $ when (isNotifyAct action) $
queueDBJob $ JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' } queueDBJob $ JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' }
return $ length okUsers return $ length okUsers
let numSelected = length selectedUsers let numSelected = length selectedUsers
diffSelected = numSelected - numExaminees diffSelected = numSelected - numExaminees
when (isRenewPinAct action) $ addMessageI Success $ MsgLmsPinRenewal numExaminees when (isRenewPinAct action) $ addMessageI Success $ MsgLmsPinRenewal numExaminees
when (isNotifyAct action) $ addMessageI Success $ MsgLmsNotificationSend numExaminees when (isNotifyAct action) $ addMessageI Success $ MsgLmsNotificationSend numExaminees