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

refactor(lms): simplify lms result interface

Browse Source
This commit is contained in:
Steffen Jost 2022-03-07 12:51:04 +01:00
parent 1acaf54840
commit 5aae0339fb
6 changed files with 307 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
messages/uniworx/categories/qualification/de-de-formal.msg
View File

@ -6,7 +6,8 @@ CsvColumnLmsIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Tei
CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme
CsvColumnLmsFailed: User was blocked by LMS, usually due to too many attempts CsvColumnLmsFailed: User was blocked by LMS, usually due to too many attempts
LmsUserlistInsert: Neuer LMS User LmsUserlistInsert: Neuer LMS User
LmsUserlistUpdate: Aktualisierung von LMS User LmsUserlistUpdate: LMS User aktualisierung
LmsResultInsert: Neues LMS Ergebnis LmsResultInsert: Neues LMS Ergebnis
LmsResultUpdate: LMS Ergebnis aktualisierung
LmsResultCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel LmsResultCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel
LmsUserlistCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel LmsUserlistCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel

1
messages/uniworx/categories/qualification/en-eu.msg
View File

@ -8,5 +8,6 @@ CsvColumnLmsFailed: Blockier durch LMS, üblicherweise wegen zu vieler Fehlversu
LmsUserlistInsert: New LMS User LmsUserlistInsert: New LMS User
LmsUserlistUpdate: Update of LMS User LmsUserlistUpdate: Update of LMS User
LmsResultInsert: New LMS result LmsResultInsert: New LMS result
LmsResultUpdate: Update of LMS result
LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key
LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key

142
src/Handler/LMS/Result.hs
View File

@ -17,50 +17,8 @@ import qualified Data.Csv as Csv
import qualified Data.Conduit.List as C import qualified Data.Conduit.List as C
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
type LmsResultTableExpr = ( E.SqlExpr (Entity Qualification)
`E.InnerJoin` E.SqlExpr (Entity LmsResult)
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
queryQualification :: LmsResultTableExpr -> E.SqlExpr (Entity Qualification)
queryQualification = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
queryLmsResult :: LmsResultTableExpr -> E.SqlExpr (Entity LmsResult)
queryLmsResult = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
queryLmsUser :: LmsResultTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
queryLmsUser = $(sqlLOJproj 3 2)
queryUser :: LmsResultTableExpr -> E.SqlExpr (Maybe (Entity User))
queryUser = $(sqlLOJproj 3 3)
type LmsResultTableData = DBRow (Entity Qualification, Entity LmsResult, Maybe (Entity LmsUser), Maybe (Entity User))
instance HasEntity LmsResultTableData LmsResult where
hasEntity = _dbrOutput . _2
{- MaybeHasUser only!
instance HasUser LmsResultTableData where
hasUser = _dbrOutput . _4 . _entityVal
-}
resultQualification :: Lens' LmsResultTableData (Entity Qualification)
resultQualification = _dbrOutput . _1
resultLmsResult :: Lens' LmsResultTableData (Entity LmsResult)
resultLmsResult = _dbrOutput . _2
resultLmsUser :: Traversal' LmsResultTableData (Entity LmsUser)
resultLmsUser = _dbrOutput . _3 . _Just
resultUser :: Traversal' LmsResultTableData (Entity User)
resultUser = _dbrOutput . _4 . _Just
-- required for import only
data LmsResultTableCsv = LmsResultTableCsv data LmsResultTableCsv = LmsResultTableCsv
{ csvLRTident :: LmsIdent { csvLRTident :: LmsIdent
, csvLRTsuccess :: Day , csvLRTsuccess :: Day
@ -68,11 +26,11 @@ data LmsResultTableCsv = LmsResultTableCsv
deriving Generic deriving Generic
makeLenses_ ''LmsResultTableCsv makeLenses_ ''LmsResultTableCsv
-- csv without headers -- csv without headers -- TODO not yet supported
instance Csv.ToRecord LmsResultTableCsv -- default suffices instance Csv.ToRecord LmsResultTableCsv -- default suffices
instance Csv.FromRecord LmsResultTableCsv -- default suffices instance Csv.FromRecord LmsResultTableCsv -- default suffices
-- csv with headers -- TODO not yet supported -- csv with headers
lmsResultTableCsvHeader :: Csv.Header lmsResultTableCsvHeader :: Csv.Header
lmsResultTableCsvHeader = Csv.header [ csvResultIdent, csvResultSuccess ] lmsResultTableCsvHeader = Csv.header [ csvResultIdent, csvResultSuccess ]
@ -97,12 +55,13 @@ instance CsvColumnsExplained LmsResultTableCsv where
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
single k v = singletonMap k [whamlet|_{v}|] single k v = singletonMap k [whamlet|_{v}|]
data LmsResultCsvActionClass = LmsResultInsert data LmsResultCsvActionClass = LmsResultInsert | LmsResultUpdate
deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded) deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded)
embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id
-- By coincidence the action type is identical to LmsResultTableCsv -- By coincidence the action type is identical to LmsResultTableCsv
data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day } data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day }
| LmsResultUpdateData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions deriveJSON defaultOptions
@ -118,8 +77,6 @@ data LmsResultCsvException
instance Exception LmsResultCsvException instance Exception LmsResultCsvException
embedRenderMessage ''UniWorX ''LmsResultCsvException id embedRenderMessage ''UniWorX ''LmsResultCsvException id
mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
mkResultTable sid qsh qid = do mkResultTable sid qsh qid = do
dbtCsvName <- csvFilenameLmsResult qsh dbtCsvName <- csvFilenameLmsResult qsh
@ -128,35 +85,28 @@ mkResultTable sid qsh qid = do
resultDBTable = DBTable{..} resultDBTable = DBTable{..}
where where
dbtSQLQuery = runReaderT $ do dbtSQLQuery lmsresult = do
qualification <- asks queryQualification E.where_ $ lmsresult E.^. LmsResultQualification E.==. E.val qid
lmsResult <- asks queryLmsResult return lmsresult
lmsUser <- asks queryLmsUser dbtRowKey = (E.^. LmsResultId)
user <- asks queryUser
lift $ do
E.on $ qualification E.^. QualificationId E.==. lmsResult E.^. LmsResultQualification
E.on $ lmsUser E.?. LmsUserIdent E.==. E.just (lmsResult E.^. LmsResultIdent)
E.on $ lmsUser E.?. LmsUserUser E.==. user E.?. UserId
E.where_ $ qualification E.^. QualificationId E.==. E.val qid
return (qualification, lmsResult, lmsUser, user)
dbtRowKey = queryLmsResult >>> (E.^. LmsResultId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ sortable (Just csvResultIdent) (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident [ sortable (Just csvResultIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
, sortable (Just csvResultSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dayCell success , sortable (Just csvResultSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess -> success) -> dayCell success
] -- TODO: add more columns for manual debugging view !!! , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsResultTimestamp -> timestamp) -> dateTimeCell timestamp
]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ (csvResultIdent , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent)) [ (csvResultIdent , SortColumn (E.^. LmsResultIdent))
-- , (csvResultSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess)) , (csvResultSuccess, SortColumn (E.^. LmsResultSuccess))
, (csvResultSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess)) , (csvLmsTimestamp , SortColumn (E.^. LmsResultTimestamp))
] ]
dbtFilter = Map.fromList dbtFilter = Map.fromList
[ (csvResultIdent , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent)) [ (csvResultIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent))
, (csvResultSuccess, FilterColumn . E.mkExactFilter $ views (to queryLmsResult) (E.^. LmsResultSuccess)) , (csvResultSuccess, FilterColumn $ E.mkExactFilter (E.^. LmsResultSuccess))
] ]
dbtFilterUI = \mPrev -> mconcat dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter csvResultIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) [ prismAForm (singletonFilter csvResultIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
, prismAForm (singletonFilter csvResultSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsSuccess) , prismAForm (singletonFilter csvResultSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsSuccess)
] ]
dbtStyle = def dbtStyle = def
dbtParams = def dbtParams = def
@ -173,46 +123,60 @@ mkResultTable sid qsh qid = do
} }
where where
doEncode' = LmsResultTableCsv doEncode' = LmsResultTableCsv
<$> view (resultLmsResult . _entityVal . _lmsResultIdent) <$> view (_dbrOutput . _entityVal . _lmsResultIdent)
<*> view (resultLmsResult . _entityVal . _lmsResultSuccess) <*> view (_dbrOutput . _entityVal . _lmsResultSuccess)
dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
{ dbtCsvRowKey = \LmsResultTableCsv{..} -> { dbtCsvRowKey = \LmsResultTableCsv{..} ->
fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident csvLRTsuccess fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident csvLRTsuccess
, dbtCsvComputeActions = \case -- purpose is to show a diff to the user first , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
yield $ LmsResultInsertData yield $ LmsResultInsertData
{ lmsResultInsertIdent = csvLRTident dbCsvNew { lmsResultInsertIdent = csvLRTident dbCsvNew
, lmsResultInsertSuccess = csvLRTsuccess dbCsvNew , lmsResultInsertSuccess = csvLRTsuccess dbCsvNew
} }
DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code
DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}} -> do
yield $ LmsResultUpdateData
{ lmsResultInsertIdent = csvLRTident
, lmsResultInsertSuccess = csvLRTsuccess
}
DBCsvDiffMissing{} -> return () -- no deletion DBCsvDiffMissing{} -> return () -- no deletion
DBCsvDiffExisting{} -> return () -- no merge TODO!!! ADD MERGE DUE TO Uniqueness! , dbtCsvClassifyAction = \case
, dbtCsvClassifyAction = \LmsResultInsertData{} -> LmsResultInsert LmsResultInsertData{} -> LmsResultInsert
, dbtCsvCoarsenActionClass = \LmsResultInsert -> DBCsvActionNew -- there is only one action: insert into table LmsResultUpdateData{} -> LmsResultUpdate
, dbtCsvCoarsenActionClass = \case
LmsResultInsert -> DBCsvActionNew
LmsResultUpdate -> DBCsvActionExisting
, dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error , dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error
, dbtCsvExecuteActions = do , dbtCsvExecuteActions = do
C.mapM_ $ \LmsResultInsertData{..} -> do C.mapM_ $ \actionData -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
void $ upsert void $ upsert
LmsResult LmsResult
{ lmsResultQualification = qid { lmsResultQualification = qid
, lmsResultIdent = lmsResultInsertIdent , lmsResultIdent = lmsResultInsertIdent actionData
, lmsResultSuccess = lmsResultInsertSuccess , lmsResultSuccess = lmsResultInsertSuccess actionData
, lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose? , lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose?
} }
[ LmsResultSuccess =. lmsResultInsertSuccess [ LmsResultSuccess =. lmsResultInsertSuccess actionData
, LmsResultTimestamp =. now , LmsResultTimestamp =. now
] ]
-- queueDBJob?? -- todo -- queueDBJob?? -- todo
-- audit -- audit
return $ LmsResultR sid qsh return $ LmsResultR sid qsh
, dbtCsvRenderKey = \_ LmsResultInsertData{..} -> do -- TODO: i18n , dbtCsvRenderKey = const $ \case
[whamlet| LmsResultInsertData{..} -> do -- TODO: i18n
$newline never [whamlet|
Ident #{getLmsIdent lmsResultInsertIdent} # $newline never
had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess} Insert: Ident #{getLmsIdent lmsResultInsertIdent} #
|] had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess}
|]
LmsResultUpdateData{..} -> do -- TODO: i18n
[whamlet|
$newline never
Update: Ident #{getLmsIdent lmsResultInsertIdent} #
had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess}
|]
, dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
, dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text , dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text
} }

235
src/Handler/LMS/User.hs Normal file
View File

@ -0,0 +1,235 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only
module Handler.LMS.User
( getLmsUserR, postLmsUserR
)
where
-- TODO: needs complete refactoring! Old RESULT templates follows
import Import
import Handler.Utils
import Handler.Utils.Csv
import Handler.Utils.LMS
import qualified Data.Map as Map
import qualified Data.Csv as Csv
import qualified Data.Conduit.List as C
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
type LmsResultTableExpr = ( E.SqlExpr (Entity Qualification)
`E.InnerJoin` E.SqlExpr (Entity LmsResult)
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
queryQualification :: LmsResultTableExpr -> E.SqlExpr (Entity Qualification)
queryQualification = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
queryLmsResult :: LmsResultTableExpr -> E.SqlExpr (Entity LmsResult)
queryLmsResult = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
queryLmsUser :: LmsResultTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
queryLmsUser = $(sqlLOJproj 3 2)
queryUser :: LmsResultTableExpr -> E.SqlExpr (Maybe (Entity User))
queryUser = $(sqlLOJproj 3 3)
type LmsResultTableData = DBRow (Entity Qualification, Entity LmsResult, Maybe (Entity LmsUser), Maybe (Entity User))
instance HasEntity LmsResultTableData LmsResult where
hasEntity = _dbrOutput . _2
{- MaybeHasUser only!
instance HasUser LmsResultTableData where
hasUser = _dbrOutput . _4 . _entityVal
-}
resultQualification :: Lens' LmsResultTableData (Entity Qualification)
resultQualification = _dbrOutput . _1
resultLmsResult :: Lens' LmsResultTableData (Entity LmsResult)
resultLmsResult = _dbrOutput . _2
resultLmsUser :: Traversal' LmsResultTableData (Entity LmsUser)
resultLmsUser = _dbrOutput . _3 . _Just
resultUser :: Traversal' LmsResultTableData (Entity User)
resultUser = _dbrOutput . _4 . _Just
-- required for import only
data LmsResultTableCsv = LmsResultTableCsv
{ csvLRTident :: LmsIdent
, csvLRTsuccess :: Day
}
deriving Generic
makeLenses_ ''LmsResultTableCsv
-- csv without headers
instance Csv.ToRecord LmsResultTableCsv -- default suffices
instance Csv.FromRecord LmsResultTableCsv -- default suffices
-- csv with headers -- TODO not yet supported
lmsResultTableCsvHeader :: Csv.Header
lmsResultTableCsvHeader = Csv.header [ csvResultIdent, csvResultSuccess ]
instance ToNamedRecord LmsResultTableCsv where
toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord
[ csvResultIdent Csv..= csvLRTident
, csvResultSuccess Csv..= csvLRTsuccess
]
instance FromNamedRecord LmsResultTableCsv where
parseNamedRecord (lsfHeaderTranslate -> csv)
= LmsResultTableCsv
<$> csv Csv..: csvResultIdent
<*> csv Csv..: csvResultSuccess
instance CsvColumnsExplained LmsResultTableCsv where
csvColumnsExplanations _ = mconcat
[ single csvResultIdent MsgCsvColumnLmsIdent
, single csvResultSuccess MsgCsvColumnLmsSuccess
]
where
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
single k v = singletonMap k [whamlet|_{v}|]
data LmsResultCsvActionClass = LmsResultInsert
deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded)
embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id
-- By coincidence the action type is identical to LmsResultTableCsv
data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece'' 2 1 -- LmsResultInsertData -> insert
, fieldLabelModifier = camelToPathPiece' 2 -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success
, sumEncoding = TaggedObject "action" "data"
} ''LmsResultCsvAction
data LmsResultCsvException
= LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
deriving (Show, Generic, Typeable)
instance Exception LmsResultCsvException
embedRenderMessage ''UniWorX ''LmsResultCsvException id
mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
mkResultTable sid qsh qid = do
dbtCsvName <- csvFilenameLmsResult qsh
let dbtCsvSheetName = dbtCsvName
let
resultDBTable = DBTable{..}
where
dbtSQLQuery = runReaderT $ do
qualification <- asks queryQualification
lmsResult <- asks queryLmsResult
lmsUser <- asks queryLmsUser
user <- asks queryUser
lift $ do
E.on $ qualification E.^. QualificationId E.==. lmsResult E.^. LmsResultQualification
E.on $ lmsUser E.?. LmsUserIdent E.==. E.just (lmsResult E.^. LmsResultIdent)
E.on $ lmsUser E.?. LmsUserUser E.==. user E.?. UserId
E.where_ $ qualification E.^. QualificationId E.==. E.val qid
return (qualification, lmsResult, lmsUser, user)
dbtRowKey = queryLmsResult >>> (E.^. LmsResultId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
dbtColonnade = dbColonnade $ mconcat
[ sortable (Just csvResultIdent) (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
, sortable (Just csvResultSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dayCell success
] -- TODO: add more columns for manual debugging view !!!
dbtSorting = Map.fromList
[ (csvResultIdent , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent))
-- , (csvResultSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess))
, (csvResultSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess))
]
dbtFilter = Map.fromList
[ (csvResultIdent , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent))
, (csvResultSuccess, FilterColumn . E.mkExactFilter $ views (to queryLmsResult) (E.^. LmsResultSuccess))
]
dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter csvResultIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
, prismAForm (singletonFilter csvResultSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsSuccess)
]
dbtStyle = def
dbtParams = def
dbtIdent :: Text
dbtIdent = "lms-result"
dbtCsvEncode = Just DBTCsvEncode
{ dbtCsvExportForm = pure ()
, dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
, dbtCsvName
, dbtCsvSheetName
, dbtCsvNoExportData = Just id
, dbtCsvHeader = const $ return lmsResultTableCsvHeader
, dbtCsvExampleData = Nothing
}
where
doEncode' = LmsResultTableCsv
<$> view (resultLmsResult . _entityVal . _lmsResultIdent)
<*> view (resultLmsResult . _entityVal . _lmsResultSuccess)
dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
{ dbtCsvRowKey = \LmsResultTableCsv{..} ->
fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident csvLRTsuccess
, dbtCsvComputeActions = \case -- purpose is to show a diff to the user first
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
yield $ LmsResultInsertData
{ lmsResultInsertIdent = csvLRTident dbCsvNew
, lmsResultInsertSuccess = csvLRTsuccess dbCsvNew
}
DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code
DBCsvDiffMissing{} -> return () -- no deletion
DBCsvDiffExisting{} -> return () -- no merge TODO!!! ADD MERGE DUE TO Uniqueness!
, dbtCsvClassifyAction = \LmsResultInsertData{} -> LmsResultInsert
, dbtCsvCoarsenActionClass = \LmsResultInsert -> DBCsvActionNew -- there is only one action: insert into table
, dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error
, dbtCsvExecuteActions = do
C.mapM_ $ \LmsResultInsertData{..} -> do
now <- liftIO getCurrentTime
void $ upsert
LmsResult
{ lmsResultQualification = qid
, lmsResultIdent = lmsResultInsertIdent
, lmsResultSuccess = lmsResultInsertSuccess
, lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose?
}
[ LmsResultSuccess =. lmsResultInsertSuccess
, LmsResultTimestamp =. now
]
-- queueDBJob?? -- todo
-- audit
return $ LmsResultR sid qsh
, dbtCsvRenderKey = \_ LmsResultInsertData{..} -> do -- TODO: i18n
[whamlet|
$newline never
Ident #{getLmsIdent lmsResultInsertIdent} #
had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess}
|]
, dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
, dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text
}
dbtExtraReps = []
resultDBTableValidator = def
& defaultSorting [SortAscBy csvResultIdent]
dbTable resultDBTableValidator resultDBTable
getLmsUserR, postLmsUserR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsUserR = postLmsUserR
postLmsUserR sid qsh = do
lmsTable <- runDB $ do
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
view _2 <$> mkResultTable sid qsh qid
siteLayoutMsg MsgMenuLmsResult $ do
setTitleI MsgMenuLmsResult
$(widgetFile "lms-result")

20
src/Handler/LMS/Userlist.hs
View File

@ -1,6 +1,6 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only {- # OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only
{-# OPTIONS -Wno-unused-imports #-} -- TODO: remove me, for debugging only {- # OPTIONS -Wno-unused-imports #-} -- TODO: remove me, for debugging only
module Handler.LMS.Userlist module Handler.LMS.Userlist
( getLmsUserlistR, postLmsUserlistR ( getLmsUserlistR, postLmsUserlistR
@ -18,7 +18,7 @@ import qualified Data.Csv as Csv
import qualified Data.Conduit.List as C import qualified Data.Conduit.List as C
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
data LmsUserlistTableCsv = LmsUserlistTableCsv data LmsUserlistTableCsv = LmsUserlistTableCsv
{ csvLULident :: LmsIdent { csvLULident :: LmsIdent
@ -93,12 +93,12 @@ mkUserlistTable sid qsh qid = do
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ sortable (Just csvUserlistIdent) (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ lmsUserlistIdent & getLmsIdent [ sortable (Just csvUserlistIdent) (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ lmsUserlistIdent & getLmsIdent
, sortable (Just csvUserlistBlocked) (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> isBadCell lmsUserlistFailed , sortable (Just csvUserlistBlocked) (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> isBadCell lmsUserlistFailed
, sortable (Just "timestamp") (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell lmsUserlistTimestamp , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell lmsUserlistTimestamp
] ]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ (csvUserlistIdent , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent) [ (csvUserlistIdent , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent)
, (csvUserlistBlocked, SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed) , (csvUserlistBlocked, SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed)
, ("timestamp" , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp) , (csvLmsTimestamp , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp)
] ]
dbtFilter = Map.fromList dbtFilter = Map.fromList
[ (csvUserlistIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent )) [ (csvUserlistIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent ))
@ -150,15 +150,17 @@ mkUserlistTable sid qsh qid = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
void $ upsert LmsUserlist void $ upsert LmsUserlist
{ {
lmsUserlistQualification = qid lmsUserlistQualification = qid
, lmsUserlistIdent = lmsUserlistInsertIdent actionData , lmsUserlistIdent = lmsUserlistInsertIdent actionData
, lmsUserlistFailed = lmsUserlistInsertFailed actionData , lmsUserlistFailed = lmsUserlistInsertFailed actionData
, lmsUserlistTimestamp = now , lmsUserlistTimestamp = now
} }
[ [
LmsUserlistFailed =. lmsUserlistInsertFailed actionData -- TODO: should we allow a reset from failed: True to False? LmsUserlistFailed =. lmsUserlistInsertFailed actionData -- TODO: should we allow a reset from failed: True to False?
, LmsUserlistTimestamp =. now , LmsUserlistTimestamp =. now
] ]
-- queueDBJob?? -- todo
-- audit
return $ LmsUserlistR sid qsh return $ LmsUserlistR sid qsh
dbtCsvRenderKey = const $ \case dbtCsvRenderKey = const $ \case
LmsUserlistInsertData{..} -> do -- TODO: i18n LmsUserlistInsertData{..} -> do -- TODO: i18n

6
src/Handler/Utils/LMS.hs
View File

@ -1,5 +1,6 @@
module Handler.Utils.LMS module Handler.Utils.LMS
( csvUserlistIdent, csvUserlistBlocked ( csvLmsTimestamp
, csvUserlistIdent, csvUserlistBlocked
, csvResultIdent, csvResultSuccess , csvResultIdent, csvResultSuccess
, csvFilenameLmsUser , csvFilenameLmsUser
, csvFilenameLmsUserlist , csvFilenameLmsUserlist
@ -12,6 +13,9 @@ import Import
import Handler.Utils import Handler.Utils
-- Column names -- Column names
csvLmsTimestamp :: IsString a => a
csvLmsTimestamp = fromString "Zeitstempel"
csvUserlistIdent :: IsString a => a csvUserlistIdent :: IsString a => a
csvUserlistIdent = fromString "Benutzerkennung" csvUserlistIdent = fromString "Benutzerkennung"
csvUserlistBlocked :: IsString a => a csvUserlistBlocked :: IsString a => a