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

chore(lms): import ought to work now

Browse Source
This commit is contained in:
Steffen Jost 2022-02-21 17:02:53 +01:00
parent 8ad25c6ca5
commit e5216fde31
6 changed files with 72 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
models/lms.model
View File

@ -115,7 +115,7 @@ LmsResult
ident LmsIdent ident LmsIdent
success Day success Day
timestamp UTCTime default=now() timestamp UTCTime default=now()
UniqueLmsResult qualification ident success UniqueLmsResult qualification ident success -- required by DBTable
deriving Generic deriving Generic
-- Logs all processed rows from LmsUserlist and LmsResult -- Logs all processed rows from LmsUserlist and LmsResult

7
routes
View File

@ -255,6 +255,7 @@
!/*WellKnownFileName WellKnownR GET !free !/*WellKnownFileName WellKnownR GET !free
-- OSIS CSV Export Demo -- OSIS CSV Export Demo
/lms/#SchoolId/#QualificationShorthand LmsR GET /lms/#SchoolId/#QualificationShorthand LmsR GET POST
/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET /lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST
/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET /lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST

2
src/Handler/Exam/Users.hs
View File

@ -600,7 +600,7 @@ postEUsersR tid ssh csh examn = do
, dbtCsvName, dbtCsvSheetName , dbtCsvName, dbtCsvSheetName
, dbtCsvNoExportData = Just id , dbtCsvNoExportData = Just id
, dbtCsvHeader = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber , dbtCsvHeader = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber
, dbtCsvExampleData = Nothing , dbtCsvExampleData = Nothing
} }
where where
doEncode' = ExamUserTableCsv doEncode' = ExamUserTableCsv

54
src/Handler/LMS.hs
View File

@ -4,9 +4,9 @@
module Handler.LMS module Handler.LMS
( getLmsR ( getLmsR , postLmsR
, getLmsUserlistR , getLmsUserlistR, postLmsUserlistR
, getLmsResultR , getLmsResultR , postLmsResultR
) )
where where
@ -28,7 +28,7 @@ type LmsUserIdent = Text -- Unique random use-once identifier for each individua
data LmsUserTableCsv = LmsUserTableCsv -- for csv export only data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
{ csvLmsUserIdent :: LmsUserIdent { csvLmsUserIdent :: LmsUserIdent
, csvLmsUserPin :: Text , csvLmsUserPin :: Text
, csvLmsUserReset, cvsLmsUserRemove, cvsLmsUserIntern :: Int , csvLmsUserReset, cvsLmsUserRemove, cvsLmsUserIntern :: Int
} }
@ -62,20 +62,12 @@ csvLmsUserlistFilename = makeLmsFilename "userliste"
csvLmsResultFilename :: MonadHandler m => m Text csvLmsResultFilename :: MonadHandler m => m Text
csvLmsResultFilename = makeLmsFilename "ergebnisse" csvLmsResultFilename = makeLmsFilename "ergebnisse"
-- | Create filenames as specified by the LMS interface agreed with Know How AG
makeLmsFilename :: MonadHandler m => Text -> m Text
makeLmsFilename ftag = do
ymth <- getYMTH
return $ "fradrive_f_" <> ftag <> "_" <> ymth <> ".csv"
-- | Return current datetime in YYYYMMDDHH format
getYMTH :: MonadHandler m => m Text
getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime
getLmsR :: SchoolId -> QualificationShorthand -> Handler Html getLmsR, postLmsR:: SchoolId -> QualificationShorthand -> Handler Html
getLmsR sid qsh = do getLmsR = postLmsR
_qid <- runDB . getKeyBy404 $ UniqueSchoolShort sid qsh postLmsR sid qsh = do
_qid <- runDB . getKeyBy404 $ UniqueSchoolShort sid qsh
-- TODO !!! filter table by qid !!! -- TODO !!! filter table by qid !!!
{- {-
dbtCsvName <- csvLmsUserFilename dbtCsvName <- csvLmsUserFilename
@ -114,7 +106,7 @@ getLmsR sid qsh = do
(row ^. resultUser . _entityVal . _lmsUserResetPin . to fromEnum) (row ^. resultUser . _entityVal . _lmsUserResetPin . to fromEnum)
(row ^. resultUser . _entityVal . _lmsUserDelete . to fromEnum) (row ^. resultUser . _entityVal . _lmsUserDelete . to fromEnum)
mitarbeiter mitarbeiter
, dbtCsvName , dbtCsvName
, dbtCsvNoExportData = Nothing , dbtCsvNoExportData = Nothing
, dbtCsvHeader = def -- return . Vector.filter csvColumns' . userTableCsvHeader showSex tutorials sheets . fromMaybe def , dbtCsvHeader = def -- return . Vector.filter csvColumns' . userTableCsvHeader showSex tutorials sheets . fromMaybe def
, dbtCsvExampleData = Nothing , dbtCsvExampleData = Nothing
@ -130,10 +122,10 @@ getLmsR sid qsh = do
-- , dbtCsvRenderKey = _7 -- , dbtCsvRenderKey = _7
-- , dbtCsvRenderActionClass = _8 -- , dbtCsvRenderActionClass = _8
-- , dbtCsvRenderException = _9 -- , dbtCsvRenderException = _9
-- } -- }
psValidator = def psValidator = def
lmsTable = dbTable psValidator DBTable{..} lmsTable = dbTable psValidator DBTable{..}
-} -}
let lmsTable = [whamlet|TODO|] -- TODO: remove me, just for debugging let lmsTable = [whamlet|TODO|] -- TODO: remove me, just for debugging
siteLayoutMsg MsgMenuLms $ do siteLayoutMsg MsgMenuLms $ do
setTitleI MsgMenuLms setTitleI MsgMenuLms
@ -144,15 +136,15 @@ getLmsR sid qsh = do
mkUserlistTable :: QualificationId -> DB (Any, Widget) mkUserlistTable :: QualificationId -> DB (Any, Widget)
mkUserlistTable qid = do mkUserlistTable qid = do
let let
userlistTable = DBTable{..} userlistTable = DBTable{..}
where where
dbtSQLQuery lmslist = do dbtSQLQuery lmslist = do
E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid
return lmslist return lmslist
dbtRowKey = (E.^. LmsUserlistId) dbtRowKey = (E.^. LmsUserlistId)
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 "ident") (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ getLmsIdent lmsUserlistIdent [ sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ getLmsIdent lmsUserlistIdent
, sortable (Just "failed") (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> isBadCell lmsUserlistFailed , sortable (Just "failed") (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> isBadCell lmsUserlistFailed
] ]
@ -160,7 +152,7 @@ mkUserlistTable qid = do
[ ("ident" , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent) [ ("ident" , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent)
, ("failed", SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed) , ("failed", SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed)
] ]
dbtFilter = mempty -- TODO !!! continue here !!! dbtFilter = mempty -- TODO !!! continue here !!!
dbtFilterUI = const mempty -- TODO !!! continue here !!! Manual filtering useful to deal with user complaints! dbtFilterUI = const mempty -- TODO !!! continue here !!! Manual filtering useful to deal with user complaints!
dbtStyle = def dbtStyle = def
dbtParams = def dbtParams = def
@ -169,23 +161,23 @@ mkUserlistTable qid = do
dbtCsvEncode = noCsvEncode dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing -- TODO !!! continue here !!! CSV Import is the purpose of this page! Just save to DB, create Job to deal with it later! dbtCsvDecode = Nothing -- TODO !!! continue here !!! CSV Import is the purpose of this page! Just save to DB, create Job to deal with it later!
dbtExtraReps = [] dbtExtraReps = []
userlistDBTableValidator = def userlistDBTableValidator = def
& defaultSorting [SortAscBy "ident"] & defaultSorting [SortAscBy "ident"]
dbTable userlistDBTableValidator userlistTable dbTable userlistDBTableValidator userlistTable
getLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsUserlistR sid qsh = do getLmsUserlistR = postLmsUserlistR
postLmsUserlistR sid qsh = do
lmsTable <- runDB $ do lmsTable <- runDB $ do
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
view _2 <$> mkUserlistTable qid view _2 <$> mkUserlistTable qid
siteLayoutMsg MsgMenuLmsUserlist $ do siteLayoutMsg MsgMenuLmsUserlist $ do
setTitleI MsgMenuLmsUserlist setTitleI MsgMenuLmsUserlist
$(widgetFile "lms-userlist") $(widgetFile "lms-userlist")
-- See Module Handler.LMS.Result for -- See Module Handler.LMS.Result for
-- getLmsResultR :: QualificationId -> Handler Html -- getLmsResultR :: QualificationId -> Handler Html

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

@ -5,7 +5,8 @@
module Handler.LMS.Result module Handler.LMS.Result
( getLmsResultR ( makeLmsFilename
, getLmsResultR, postLmsResultR
) )
where where
@ -25,6 +26,15 @@ 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 import Database.Esqueleto.Utils.TH
-- | Create filenames as specified by the LMS interface agreed with Know How AG
makeLmsFilename :: MonadHandler m => Text -> m Text
makeLmsFilename ftag = do
ymth <- getYMTH
return $ "fradrive_f_" <> ftag <> "_" <> ymth <> ".csv"
-- | Return current datetime in YYYYMMDDHH format
getYMTH :: MonadHandler m => m Text
getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime
type LmsResultTableExpr = ( E.SqlExpr (Entity Qualification) type LmsResultTableExpr = ( E.SqlExpr (Entity Qualification)
@ -74,12 +84,6 @@ data LmsResultTableCsv = LmsResultTableCsv
deriving Generic deriving Generic
makeLenses_ ''LmsResultTableCsv makeLenses_ ''LmsResultTableCsv
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece'' 2 1 -- TODO: purpose of dropping here is?
, fieldLabelModifier = camelToPathPiece' 2
} ''LmsResultTableCsv
-- csv without headers -- csv without headers
instance Csv.ToRecord LmsResultTableCsv -- default suffices instance Csv.ToRecord LmsResultTableCsv -- default suffices
instance Csv.FromRecord LmsResultTableCsv -- default suffices instance Csv.FromRecord LmsResultTableCsv -- default suffices
@ -114,13 +118,13 @@ data LmsResultCsvActionClass = LmsResultInsert
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
-- TODO: why can't we use LmsResultTableCsv here instead? -- By coincidence the action type is identical to LmsResultTableCsv
data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day } data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece'' 2 1 { constructorTagModifier = camelToPathPiece'' 2 1 -- LmsResultInsertData -> insert
, fieldLabelModifier = camelToPathPiece' 2 , fieldLabelModifier = camelToPathPiece' 2 -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success
, sumEncoding = TaggedObject "action" "data" , sumEncoding = TaggedObject "action" "data"
} ''LmsResultCsvAction } ''LmsResultCsvAction
@ -173,23 +177,31 @@ mkResultTable sid qsh qid = do
dbtParams = def dbtParams = def
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "lms-userlist" dbtIdent = "lms-userlist"
dbtCsvEncode = Nothing dbtCsvEncode = Nothing
dbtCsvDecode = Just $ DBTCsvDecode -- Just save to DB; Job will process data later {-
dbtCsvEncode = Just DBTCsvEncode
{ dbtCsvExportForm = pure ()
, dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
, dbtCsvName = makeLmsFilename "ergebnisse"
, dbtCsvSheetName = makeLmsFilename "ergebnisse"
, dbtCsvNoExportData = Just id
, dbtCsvHeader = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber
, dbtCsvExampleData = Nothing
-}
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
--let LmsResultTableCsv{..} = dbCsvNew
--let csvLRTident = error "TODO"
-- csvLRTsuccess = error "TODO"
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 Key no longer exists." DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists."
DBCsvDiffMissing{} -> return () -- no deletion DBCsvDiffMissing{} -> return () -- no deletion
DBCsvDiffExisting{} -> return () -- no merge DBCsvDiffExisting{} -> return () -- no merge
, dbtCsvClassifyAction = \LmsResultInsertData{} -> LmsResultInsert , dbtCsvClassifyAction = \LmsResultInsertData{} -> LmsResultInsert
, dbtCsvCoarsenActionClass = \LmsResultInsert -> DBCsvActionNew -- there is only one action: insert into table , 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 , dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error
, dbtCsvExecuteActions = do , dbtCsvExecuteActions = do
@ -205,10 +217,15 @@ mkResultTable sid qsh qid = do
[ LmsResultSuccess =. lmsResultInsertSuccess [ LmsResultSuccess =. lmsResultInsertSuccess
, LmsResultTimestamp =. now , LmsResultTimestamp =. now
] ]
-- queueDBJob -- queueDBJob?? -- todo
-- audit -- audit
return $ LmsResultR sid qsh return $ LmsResultR sid qsh
, dbtCsvRenderKey = error "TODO" -- what is the purpose? , dbtCsvRenderKey = \_ LmsResultInsertData{..} -> do
[whamlet|
$newline never
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
} }
@ -218,8 +235,9 @@ mkResultTable sid qsh qid = do
& defaultSorting [SortAscBy "ident"] & defaultSorting [SortAscBy "ident"]
dbTable resultDBTableValidator resultDBTable dbTable resultDBTableValidator resultDBTable
getLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html getLmsResultR, postLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsResultR sid qsh = do getLmsResultR = postLmsResultR
postLmsResultR sid qsh = do
lmsTable <- runDB $ do lmsTable <- runDB $ do
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
view _2 <$> mkResultTable sid qsh qid view _2 <$> mkResultTable sid qsh qid

3
test/Database/Fill.hs
View File

@ -457,7 +457,8 @@ fillDb = do
for_ [jost] $ \uid -> for_ [jost] $ \uid ->
void . insert' $ UserSchool uid avn False void . insert' $ UserSchool uid avn False
-- void . insert' _qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" Nothing (Just 24) (Just $ 5 * 12) Nothing True
_qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" Nothing (Just 24) (Just $ 5 * 12) Nothing False
let let
sdBsc = StudyDegreeKey' 82 sdBsc = StudyDegreeKey' 82
sdMst = StudyDegreeKey' 88 sdMst = StudyDegreeKey' 88