refactor(lms): simplify lms result interface
This commit is contained in:
Steffen Jost
parent
1acaf54840
commit
5aae0339fb
@ -6,7 +6,8 @@ CsvColumnLmsIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Tei
|
||||
CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme
|
||||
CsvColumnLmsFailed: User was blocked by LMS, usually due to too many attempts
|
||||
LmsUserlistInsert: Neuer LMS User
|
||||
LmsUserlistUpdate: Aktualisierung von LMS User
|
||||
LmsUserlistUpdate: LMS User aktualisierung
|
||||
LmsResultInsert: Neues LMS Ergebnis
|
||||
LmsResultUpdate: LMS Ergebnis aktualisierung
|
||||
LmsResultCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel
|
||||
LmsUserlistCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel
|
||||
@ -8,5 +8,6 @@ CsvColumnLmsFailed: Blockier durch LMS, üblicherweise wegen zu vieler Fehlversu
|
||||
LmsUserlistInsert: New LMS User
|
||||
LmsUserlistUpdate: Update of LMS User
|
||||
LmsResultInsert: New LMS result
|
||||
LmsResultUpdate: Update of LMS result
|
||||
LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key
|
||||
LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key
|
||||
@ -17,50 +17,8 @@ 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
|
||||
@ -68,11 +26,11 @@ data LmsResultTableCsv = LmsResultTableCsv
|
||||
deriving Generic
|
||||
makeLenses_ ''LmsResultTableCsv
|
||||
|
||||
-- csv without headers
|
||||
-- csv without headers -- TODO not yet supported
|
||||
instance Csv.ToRecord 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 [ csvResultIdent, csvResultSuccess ]
|
||||
|
||||
@ -97,12 +55,13 @@ instance CsvColumnsExplained LmsResultTableCsv where
|
||||
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
|
||||
single k v = singletonMap k [whamlet|_{v}|]
|
||||
|
||||
data LmsResultCsvActionClass = LmsResultInsert
|
||||
data LmsResultCsvActionClass = LmsResultInsert | LmsResultUpdate
|
||||
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 }
|
||||
| LmsResultUpdateData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
@ -118,8 +77,6 @@ data LmsResultCsvException
|
||||
instance Exception LmsResultCsvException
|
||||
embedRenderMessage ''UniWorX ''LmsResultCsvException id
|
||||
|
||||
|
||||
|
||||
mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
|
||||
mkResultTable sid qsh qid = do
|
||||
dbtCsvName <- csvFilenameLmsResult qsh
|
||||
@ -128,35 +85,28 @@ mkResultTable sid qsh qid = do
|
||||
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)
|
||||
dbtSQLQuery lmsresult = do
|
||||
E.where_ $ lmsresult E.^. LmsResultQualification E.==. E.val qid
|
||||
return lmsresult
|
||||
dbtRowKey = (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 !!!
|
||||
[ sortable (Just csvResultIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
|
||||
, sortable (Just csvResultSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess -> success) -> dayCell success
|
||||
, sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsResultTimestamp -> timestamp) -> dateTimeCell timestamp
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ (csvResultIdent , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent))
|
||||
-- , (csvResultSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess))
|
||||
, (csvResultSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess))
|
||||
[ (csvResultIdent , SortColumn (E.^. LmsResultIdent))
|
||||
, (csvResultSuccess, SortColumn (E.^. LmsResultSuccess))
|
||||
, (csvLmsTimestamp , SortColumn (E.^. LmsResultTimestamp))
|
||||
]
|
||||
dbtFilter = Map.fromList
|
||||
[ (csvResultIdent , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent))
|
||||
, (csvResultSuccess, FilterColumn . E.mkExactFilter $ views (to queryLmsResult) (E.^. LmsResultSuccess))
|
||||
[ (csvResultIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent))
|
||||
, (csvResultSuccess, FilterColumn $ E.mkExactFilter (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)
|
||||
[ prismAForm (singletonFilter csvResultIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
|
||||
, prismAForm (singletonFilter csvResultSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsSuccess)
|
||||
]
|
||||
dbtStyle = def
|
||||
dbtParams = def
|
||||
@ -173,46 +123,60 @@ mkResultTable sid qsh qid = do
|
||||
}
|
||||
where
|
||||
doEncode' = LmsResultTableCsv
|
||||
<$> view (resultLmsResult . _entityVal . _lmsResultIdent)
|
||||
<*> view (resultLmsResult . _entityVal . _lmsResultSuccess)
|
||||
|
||||
<$> view (_dbrOutput . _entityVal . _lmsResultIdent)
|
||||
<*> view (_dbrOutput . _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
|
||||
{ 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
|
||||
DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}} -> do
|
||||
yield $ LmsResultUpdateData
|
||||
{ lmsResultInsertIdent = csvLRTident
|
||||
, lmsResultInsertSuccess = csvLRTsuccess
|
||||
}
|
||||
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
|
||||
, dbtCsvClassifyAction = \case
|
||||
LmsResultInsertData{} -> LmsResultInsert
|
||||
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
|
||||
, dbtCsvExecuteActions = do
|
||||
C.mapM_ $ \LmsResultInsertData{..} -> do
|
||||
C.mapM_ $ \actionData -> do
|
||||
now <- liftIO getCurrentTime
|
||||
void $ upsert
|
||||
LmsResult
|
||||
{ lmsResultQualification = qid
|
||||
, lmsResultIdent = lmsResultInsertIdent
|
||||
, lmsResultSuccess = lmsResultInsertSuccess
|
||||
, lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose?
|
||||
{ lmsResultQualification = qid
|
||||
, lmsResultIdent = lmsResultInsertIdent actionData
|
||||
, lmsResultSuccess = lmsResultInsertSuccess actionData
|
||||
, lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose?
|
||||
}
|
||||
[ LmsResultSuccess =. lmsResultInsertSuccess
|
||||
[ LmsResultSuccess =. lmsResultInsertSuccess actionData
|
||||
, 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}
|
||||
|]
|
||||
, dbtCsvRenderKey = const $ \case
|
||||
LmsResultInsertData{..} -> do -- TODO: i18n
|
||||
[whamlet|
|
||||
$newline never
|
||||
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
|
||||
, dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text
|
||||
}
|
||||
|
||||
235
src/Handler/LMS/User.hs
Normal file
235
src/Handler/LMS/User.hs
Normal 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")
|
||||
@ -1,6 +1,6 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
|
||||
{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only
|
||||
{-# OPTIONS -Wno-unused-imports #-} -- 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
|
||||
|
||||
module Handler.LMS.Userlist
|
||||
( getLmsUserlistR, postLmsUserlistR
|
||||
@ -18,7 +18,7 @@ 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
|
||||
|
||||
|
||||
data LmsUserlistTableCsv = LmsUserlistTableCsv
|
||||
{ csvLULident :: LmsIdent
|
||||
@ -93,12 +93,12 @@ mkUserlistTable sid qsh qid = do
|
||||
dbtColonnade = dbColonnade $ mconcat
|
||||
[ 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 "timestamp") (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell lmsUserlistTimestamp
|
||||
, sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell lmsUserlistTimestamp
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ (csvUserlistIdent , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent)
|
||||
, (csvUserlistBlocked, SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed)
|
||||
, ("timestamp" , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp)
|
||||
, (csvLmsTimestamp , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp)
|
||||
]
|
||||
dbtFilter = Map.fromList
|
||||
[ (csvUserlistIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent ))
|
||||
@ -150,15 +150,17 @@ mkUserlistTable sid qsh qid = do
|
||||
now <- liftIO getCurrentTime
|
||||
void $ upsert LmsUserlist
|
||||
{
|
||||
lmsUserlistQualification = qid
|
||||
, lmsUserlistIdent = lmsUserlistInsertIdent actionData
|
||||
, lmsUserlistFailed = lmsUserlistInsertFailed actionData
|
||||
, lmsUserlistTimestamp = now
|
||||
lmsUserlistQualification = qid
|
||||
, lmsUserlistIdent = lmsUserlistInsertIdent actionData
|
||||
, lmsUserlistFailed = lmsUserlistInsertFailed actionData
|
||||
, lmsUserlistTimestamp = now
|
||||
}
|
||||
[
|
||||
LmsUserlistFailed =. lmsUserlistInsertFailed actionData -- TODO: should we allow a reset from failed: True to False?
|
||||
, LmsUserlistTimestamp =. now
|
||||
]
|
||||
-- queueDBJob?? -- todo
|
||||
-- audit
|
||||
return $ LmsUserlistR sid qsh
|
||||
dbtCsvRenderKey = const $ \case
|
||||
LmsUserlistInsertData{..} -> do -- TODO: i18n
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
module Handler.Utils.LMS
|
||||
( csvUserlistIdent, csvUserlistBlocked
|
||||
( csvLmsTimestamp
|
||||
, csvUserlistIdent, csvUserlistBlocked
|
||||
, csvResultIdent, csvResultSuccess
|
||||
, csvFilenameLmsUser
|
||||
, csvFilenameLmsUserlist
|
||||
@ -12,6 +13,9 @@ import Import
|
||||
import Handler.Utils
|
||||
|
||||
-- Column names
|
||||
csvLmsTimestamp :: IsString a => a
|
||||
csvLmsTimestamp = fromString "Zeitstempel"
|
||||
|
||||
csvUserlistIdent :: IsString a => a
|
||||
csvUserlistIdent = fromString "Benutzerkennung"
|
||||
csvUserlistBlocked :: IsString a => a
|
||||
|
||||
Loading…
Reference in New Issue
Block a user