diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index d3381809c..7fdeea11f 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 802356ef7..546f2d9d0 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -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 diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index f94fadc55..8deee987b 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -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)