diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 57b478f0c..a8b6464e8 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -185,39 +185,55 @@ data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. makeLenses_ ''LmsTableCsv -lmsTableCsvHeaderList :: [ByteString] -lmsTableCsvHeaderList = - [ "licensee" - , "email" - , "valid-until" - , "last-renewed" - , "first-held" - , "e-learn-ident" - , "e-learn-status" - , "e-learn-started" - , "e-learn-pin-created" - , "e-learn-last-update" - , "e-learn-ended" +ltcOptions :: Csv.Options +ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc } + where + renameLtc "ltcDisplayName" = "licensee" + renameLtc "ltcLmsDatePin" = prefixLms "pin-created" + renameLtc "ltcLmsReceived" = prefixLms "last-update" + renameLtc other = replaceLtc $ camelToPathPiece' 1 other + replaceLtc ('l':'m':'s':'-':t) = prefixLms t + replaceLtc other = other + prefixLms = ("e-learn-" <>) + +lmsTableCsvHeaderList :: LmsTableCsv -> [(ByteString, ByteString)] +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 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 - toNamedRecord LmsTableCsv{..} = Csv.namedRecord $ zipWith lmsTableCsvHeaderList lmsTableFields Csv.namedField - where lmsTableFields = - [ ltcDisplayName - , ltcEmail - , ltcValidUntil - , ltcLastRefresh - , ltcFirstHeld - , ltcLmsIdent - , ltcLmsStatus - , ltcLmsStarted - , ltcLmsDatePin - , ltcLmsReceived - , ltcLmsEnded - ] + toNamedRecord ltc = Csv.namedRecord $ lmsTableCsvHeaderList ltc + +instance CsvColumnsExplained LmsTableCsv + -- where csvColumnsExplanations _ = ?? + type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) @@ -349,8 +365,8 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do dbtCsvEncode = Just DBTCsvEncode { dbtCsvExportForm = pure () , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) - , dbtCsvName - , dbtCsvSheetName + , dbtCsvName = "TODO" :: Text + , dbtCsvSheetName = "TODO" :: Text , dbtCsvNoExportData = Just id , dbtCsvHeader = const $ return lmsTableCsvHeader , dbtCsvExampleData = Nothing -- TODO @@ -362,19 +378,21 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do -} } where - doEncode' = LmsTableCsv - <$> view (resultUser . _entityVal . _userDisplayName) - <*> view (resultUser . _entityVal . _userEmail) - <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) - <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) - <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) - <*> preview (resultLmsUser . _entityVal . _lmsUserIdent) - <*> preview (resultLmsUser . _entityVal . _lmsUserStatus) - <*> preview (resultLmsUser . _entityVal . _lmsUserStarted) - <*> preview (resultLmsUser . _entityVal . _lmsUserDatePin) - <*> preview (resultLmsUser . _entityVal . _lmsUserReceived) - <*> preview (resultLmsUser . _entityVal . _lmsUserEnded) - + doEncode' :: LmsTableData -> LmsTableCsv + doEncode' = LmsTableCsv + <$> view (resultUser . _entityVal . _userDisplayName) + <*> view (resultUser . _entityVal . _userEmail) + <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) + <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) + <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) + <*> preview (resultLmsUser . _entityVal . _lmsUserIdent) + <*> view (resultLmsUser . _entityVal . _lmsUserStatus) + <*> preview (resultLmsUser . _entityVal . _lmsUserStarted) + <*> preview (resultLmsUser . _entityVal . _lmsUserDatePin) + <*> view (resultLmsUser . _entityVal . _lmsUserReceived) + <*> view (resultLmsUser . _entityVal . _lmsUserEnded) + + dbtCsvDecode = Nothing dbtExtraReps = [] dbtParams = DBParamsForm diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index 6df3a7302..50f50090c 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -49,6 +49,10 @@ deriveJSON defaultOptions } ''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 newtype LmsBool = LmsBool { lms2bool :: Bool }