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

chore(lms): full export (WIP)

Browse Source
This commit is contained in:
Steffen Jost 2022-07-28 17:25:04 +02:00
parent 7a532e9778
commit 8aab8b7b6b
2 changed files with 65 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

100
src/Handler/LMS.hs
View File

@ -185,39 +185,55 @@ data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc..
makeLenses_ ''LmsTableCsv makeLenses_ ''LmsTableCsv
lmsTableCsvHeaderList :: [ByteString] ltcOptions :: Csv.Options
lmsTableCsvHeaderList = ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
[ "licensee" where
, "email" renameLtc "ltcDisplayName" = "licensee"
, "valid-until" renameLtc "ltcLmsDatePin" = prefixLms "pin-created"
, "last-renewed" renameLtc "ltcLmsReceived" = prefixLms "last-update"
, "first-held" renameLtc other = replaceLtc $ camelToPathPiece' 1 other
, "e-learn-ident" replaceLtc ('l':'m':'s':'-':t) = prefixLms t
, "e-learn-status" replaceLtc other = other
, "e-learn-started" prefixLms = ("e-learn-" <>)
, "e-learn-pin-created"
, "e-learn-last-update" lmsTableCsvHeaderList :: LmsTableCsv -> [(ByteString, ByteString)]
, "e-learn-ended" lmsTableCsvHeaderList LmsTableCsv{..} =
[ "licensee" Csv..= ltcDisplayName
, "email" Csv..= ltcEmail
, "valid-until" Csv..= ltcValidUntil
, "last-renewed" Csv..= ltcLastRefresh
, "first-held" Csv..= ltcFirstHeld
, "e-learn-ident" Csv..= ltcLmsIdent
, "e-learn-status" Csv..= ltcLmsStatus
, "e-learn-started" Csv..= ltcLmsStarted
, "e-learn-pin-created" Csv..= ltcLmsDatePin
, "e-learn-last-update" Csv..= ltcLmsReceived
, "e-learn-ended" Csv..= ltcLmsEnded
] ]
lmsTableCsvHeader :: Csv.Header lmsTableCsvHeader :: Csv.Header
lmsTableCsvHeader = Csv.header lmsTableCsvHeaderList lmsTableCsvHeader = Csv.header $ fst <$> lmsTableCsvHeaderList (error "lmsTableCsvHeader: this value should never be evaluated")
{-
where dummy = LmsTableCsv { ltcDisplayName = mempty
, ltcEmail = mempty
, ltcValidUntil = mempty
, ltcLastRefresh = mempty
, ltcFirstHeld = mempty
, ltcLmsIdent = mempty
, ltcLmsStatus = mempty
, ltcLmsStarted = mempty
, ltcLmsDatePin = mempty
, ltcLmsReceived = mempty
, ltcLmsEnded = mempty
}
-}
instance Csv.ToNamedRecord LmsTableCsv where instance Csv.ToNamedRecord LmsTableCsv where
toNamedRecord LmsTableCsv{..} = Csv.namedRecord $ zipWith lmsTableCsvHeaderList lmsTableFields Csv.namedField toNamedRecord ltc = Csv.namedRecord $ lmsTableCsvHeaderList ltc
where lmsTableFields =
[ ltcDisplayName instance CsvColumnsExplained LmsTableCsv
, ltcEmail -- where csvColumnsExplanations _ = ??
, ltcValidUntil
, ltcLastRefresh
, ltcFirstHeld
, ltcLmsIdent
, ltcLmsStatus
, ltcLmsStarted
, ltcLmsDatePin
, ltcLmsReceived
, ltcLmsEnded
]
type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser)
@ -349,8 +365,8 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
dbtCsvEncode = Just DBTCsvEncode dbtCsvEncode = Just DBTCsvEncode
{ dbtCsvExportForm = pure () { dbtCsvExportForm = pure ()
, dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
, dbtCsvName , dbtCsvName = "TODO" :: Text
, dbtCsvSheetName , dbtCsvSheetName = "TODO" :: Text
, dbtCsvNoExportData = Just id , dbtCsvNoExportData = Just id
, dbtCsvHeader = const $ return lmsTableCsvHeader , dbtCsvHeader = const $ return lmsTableCsvHeader
, dbtCsvExampleData = Nothing -- TODO , dbtCsvExampleData = Nothing -- TODO
@ -362,18 +378,20 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
-} -}
} }
where where
doEncode' :: LmsTableData -> LmsTableCsv
doEncode' = LmsTableCsv 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)
<*> preview (resultLmsUser . _entityVal . _lmsUserIdent) <*> preview (resultLmsUser . _entityVal . _lmsUserIdent)
<*> preview (resultLmsUser . _entityVal . _lmsUserStatus) <*> view (resultLmsUser . _entityVal . _lmsUserStatus)
<*> preview (resultLmsUser . _entityVal . _lmsUserStarted) <*> preview (resultLmsUser . _entityVal . _lmsUserStarted)
<*> preview (resultLmsUser . _entityVal . _lmsUserDatePin) <*> preview (resultLmsUser . _entityVal . _lmsUserDatePin)
<*> preview (resultLmsUser . _entityVal . _lmsUserReceived) <*> view (resultLmsUser . _entityVal . _lmsUserReceived)
<*> preview (resultLmsUser . _entityVal . _lmsUserEnded) <*> view (resultLmsUser . _entityVal . _lmsUserEnded)
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
dbtExtraReps = [] dbtExtraReps = []

4
src/Model/Types/Lms.hs
View File

@ -49,6 +49,10 @@ deriveJSON defaultOptions
} ''LmsStatus } ''LmsStatus
derivePersistFieldJSON ''LmsStatus derivePersistFieldJSON ''LmsStatus
instance Csv.ToField LmsStatus where
toField (LmsBlocked d) = "Failure: " <> Csv.toField d
toField (LmsSuccess d) = "Success: " <> Csv.toField d
-- | LMS interface requires Bool to be encoded by 0 or 1 only -- | LMS interface requires Bool to be encoded by 0 or 1 only
newtype LmsBool = LmsBool { lms2bool :: Bool } newtype LmsBool = LmsBool { lms2bool :: Bool }