refactor(lms): cvs export for qualifcation overview working and clean
This commit is contained in:
Steffen Jost
parent
bb7ddcdd20
commit
20422a76e2
@ -13,6 +13,7 @@ TableQualificationValidUntil: Gültig bis
|
||||
TableQualificationLastRefresh: Zuletzt erneuert
|
||||
TableQualificationFirstHeld: Erstmalig
|
||||
TableLmsUser: Ermächtigter
|
||||
TableLmsEmail: E-Mail
|
||||
TableLmsIdent: Identifikation
|
||||
TableLmsElearning: E-Lernen
|
||||
TableLmsPin: E-Lernen Pin
|
||||
|
||||
@ -13,6 +13,7 @@ TableQualificationValidUntil: Valid until
|
||||
TableQualificationLastRefresh: Last renewed
|
||||
TableQualificationFirstHeld: First held
|
||||
TableLmsUser: Licensee
|
||||
TableLmsEmail: Email
|
||||
TableLmsIdent: Identifier
|
||||
TableLmsPin: E-learning pin
|
||||
TableLmsElearning: E-learning
|
||||
|
||||
@ -26,6 +26,8 @@ import Handler.Utils.LMS
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Csv as Csv
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Conduit.List as C
|
||||
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
@ -182,9 +184,26 @@ data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc..
|
||||
, ltcLmsEnded :: Maybe UTCTime
|
||||
}
|
||||
deriving Generic
|
||||
|
||||
makeLenses_ ''LmsTableCsv
|
||||
|
||||
ltcExample :: LmsTableCsv
|
||||
ltcExample = LmsTableCsv
|
||||
{ ltcDisplayName = "Max Mustermann"
|
||||
, ltcEmail = "m.mustermann@does.not.exist"
|
||||
, ltcValidUntil = compday
|
||||
, ltcLastRefresh = compday
|
||||
, ltcFirstHeld = compday
|
||||
, ltcLmsIdent = Nothing
|
||||
, ltcLmsStatus = Nothing
|
||||
, ltcLmsStarted = Nothing
|
||||
, ltcLmsDatePin = Nothing
|
||||
, ltcLmsReceived = Nothing
|
||||
, ltcLmsEnded = Nothing
|
||||
}
|
||||
where
|
||||
compday :: Day
|
||||
compday = utctDay $compileTime
|
||||
|
||||
ltcOptions :: Csv.Options
|
||||
ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
|
||||
where
|
||||
@ -196,44 +215,26 @@ ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
|
||||
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 $ 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 ltc = Csv.namedRecord $ lmsTableCsvHeaderList ltc
|
||||
toNamedRecord = Csv.genericToNamedRecord ltcOptions
|
||||
|
||||
instance CsvColumnsExplained LmsTableCsv
|
||||
-- where csvColumnsExplanations _ = ??
|
||||
instance Csv.DefaultOrdered LmsTableCsv where
|
||||
headerOrder = Csv.genericHeaderOrder ltcOptions
|
||||
|
||||
instance CsvColumnsExplained LmsTableCsv where
|
||||
csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList
|
||||
[ ('ltcDisplayName, MsgTableLmsUser)
|
||||
, ('ltcEmail , MsgTableLmsEmail)
|
||||
, ('ltcValidUntil , MsgTableQualificationValidUntil)
|
||||
, ('ltcLastRefresh, MsgTableQualificationLastRefresh)
|
||||
, ('ltcFirstHeld , MsgTableQualificationFirstHeld)
|
||||
, ('ltcLmsIdent , MsgTableLmsIdent)
|
||||
, ('ltcLmsStatus , MsgTableLmsStatus)
|
||||
, ('ltcLmsStarted , MsgTableLmsStarted)
|
||||
, ('ltcLmsDatePin , MsgTableLmsDatePin)
|
||||
, ('ltcLmsReceived, MsgTableLmsReceived)
|
||||
, ('ltcLmsEnded , MsgTableLmsEnded)
|
||||
]
|
||||
|
||||
|
||||
type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser)
|
||||
@ -309,19 +310,22 @@ mkLmsTable :: forall h p cols act act'.
|
||||
, Ord act, PathPiece act, RenderMessage UniWorX act
|
||||
, AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols
|
||||
)
|
||||
=> Entity Qualification
|
||||
=> Entity Qualification
|
||||
-> Map act (AForm Handler act')
|
||||
-> (LmsTableExpr -> E.SqlExpr (E.Value Bool))
|
||||
-> cols
|
||||
-> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))
|
||||
-> DB (FormResult (act', Set UserId), Widget)
|
||||
mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
|
||||
now <- liftIO getCurrentTime
|
||||
now <- liftIO getCurrentTime
|
||||
-- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route here
|
||||
let
|
||||
let
|
||||
currentRoute = LmsR (qualificationSchool quali) (qualificationShorthand quali)
|
||||
nowaday = utctDay now
|
||||
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
|
||||
csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "qualification"
|
||||
dbtSQLQuery q = lmsTableQuery qid q <* E.where_ (restrict q)
|
||||
dbtRowKey = queryUser >>> (E.^. UserId)
|
||||
dbtProj = dbtProjFilteredPostId
|
||||
@ -359,55 +363,30 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
|
||||
, if isNothing mbRenewal then mempty
|
||||
else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "qualification"
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtCsvEncode = Just DBTCsvEncode
|
||||
{ dbtCsvExportForm = pure ()
|
||||
, dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
|
||||
, dbtCsvName = "TODO" :: Text
|
||||
, dbtCsvSheetName = "TODO" :: Text
|
||||
, dbtCsvName = csvName
|
||||
, dbtCsvSheetName = csvName
|
||||
, dbtCsvNoExportData = Just id
|
||||
, dbtCsvHeader = const $ return lmsTableCsvHeader
|
||||
, dbtCsvExampleData = Nothing -- TODO
|
||||
{-
|
||||
Just
|
||||
[ LmsTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day }
|
||||
| (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..]
|
||||
]
|
||||
-}
|
||||
, dbtCsvHeader = const $ return $ Csv.headerOrder ltcExample
|
||||
, dbtCsvExampleData = Just [ltcExample]
|
||||
}
|
||||
where
|
||||
doEncode' :: LmsTableData -> 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 . _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)
|
||||
-}
|
||||
|
||||
<$> view (resultUser . _entityVal . _userDisplayName)
|
||||
<*> view (resultUser . _entityVal . _userEmail)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld)
|
||||
<*> preview (resultLmsUser . _entityVal . _lmsUserIdent)
|
||||
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserStatus))
|
||||
<*> preview (resultLmsUser . _entityVal . _lmsUserStarted)
|
||||
<*> preview (resultLmsUser . _entityVal . _lmsUserDatePin)
|
||||
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserReceived))
|
||||
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded))
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
dbtParams = DBParamsForm
|
||||
@ -444,7 +423,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
|
||||
getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||
getLmsR = postLmsR
|
||||
postLmsR sid qsh = do
|
||||
currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
|
||||
currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
|
||||
((lmsRes, lmsTable), Entity qid quali) <- runDB $ do
|
||||
qent <- getBy404 $ SchoolQualificationShort sid qsh
|
||||
let acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user