fraport/fradrive
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
success Day
timestamp UTCTime default=now()
UniqueLmsResult qualification ident success
UniqueLmsResult qualification ident success -- required by DBTable
deriving Generic
-- Logs all processed rows from LmsUserlist and LmsResult

7
routes
View File

@ -255,6 +255,7 @@
!/*WellKnownFileName WellKnownR GET !free
-- OSIS CSV Export Demo
/lms/#SchoolId/#QualificationShorthand LmsR GET
/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET
/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET
/lms/#SchoolId/#QualificationShorthand LmsR GET POST
/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST
/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
, dbtCsvNoExportData = Just id
, dbtCsvHeader = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber
, dbtCsvExampleData = Nothing
, dbtCsvExampleData = Nothing
}
where
doEncode' = ExamUserTableCsv

54
src/Handler/LMS.hs
View File

@ -4,9 +4,9 @@
module Handler.LMS
( getLmsR
, getLmsUserlistR
, getLmsResultR
( getLmsR , postLmsR
, getLmsUserlistR, postLmsUserlistR
, getLmsResultR , postLmsResultR
)
where
@ -28,7 +28,7 @@ type LmsUserIdent = Text -- Unique random use-once identifier for each individua
data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
{ csvLmsUserIdent :: LmsUserIdent
, csvLmsUserPin :: Text
, csvLmsUserPin :: Text
, csvLmsUserReset, cvsLmsUserRemove, cvsLmsUserIntern :: Int
}
@ -62,20 +62,12 @@ csvLmsUserlistFilename = makeLmsFilename "userliste"
csvLmsResultFilename :: MonadHandler m => m Text
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 sid qsh = do
_qid <- runDB . getKeyBy404 $ UniqueSchoolShort sid qsh
getLmsR, postLmsR:: SchoolId -> QualificationShorthand -> Handler Html
getLmsR = postLmsR
postLmsR sid qsh = do
_qid <- runDB . getKeyBy404 $ UniqueSchoolShort sid qsh
-- TODO !!! filter table by qid !!!
{-
dbtCsvName <- csvLmsUserFilename
@ -114,7 +106,7 @@ getLmsR sid qsh = do
(row ^. resultUser . _entityVal . _lmsUserResetPin . to fromEnum)
(row ^. resultUser . _entityVal . _lmsUserDelete . to fromEnum)
mitarbeiter
, dbtCsvName
, dbtCsvName
, dbtCsvNoExportData = Nothing
, dbtCsvHeader = def -- return . Vector.filter csvColumns' . userTableCsvHeader showSex tutorials sheets . fromMaybe def
, dbtCsvExampleData = Nothing
@ -130,10 +122,10 @@ getLmsR sid qsh = do
-- , dbtCsvRenderKey = _7
-- , dbtCsvRenderActionClass = _8
-- , dbtCsvRenderException = _9
-- }
-- }
psValidator = def
lmsTable = dbTable psValidator DBTable{..}
-}
-}
let lmsTable = [whamlet|TODO|] -- TODO: remove me, just for debugging
siteLayoutMsg MsgMenuLms $ do
setTitleI MsgMenuLms
@ -144,15 +136,15 @@ getLmsR sid qsh = do
mkUserlistTable :: QualificationId -> DB (Any, Widget)
mkUserlistTable qid = do
let
let
userlistTable = DBTable{..}
where
dbtSQLQuery lmslist = do
dbtSQLQuery lmslist = do
E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid
return lmslist
dbtRowKey = (E.^. LmsUserlistId)
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 "failed") (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> isBadCell lmsUserlistFailed
]
@ -160,7 +152,7 @@ mkUserlistTable qid = do
[ ("ident" , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent)
, ("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!
dbtStyle = def
dbtParams = def
@ -169,23 +161,23 @@ mkUserlistTable qid = do
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!
dbtExtraReps = []
userlistDBTableValidator = def
userlistDBTableValidator = def
& defaultSorting [SortAscBy "ident"]
dbTable userlistDBTableValidator userlistTable
getLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsUserlistR sid qsh = do
getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsUserlistR = postLmsUserlistR
postLmsUserlistR sid qsh = do
lmsTable <- runDB $ do
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
view _2 <$> mkUserlistTable qid
view _2 <$> mkUserlistTable qid
siteLayoutMsg MsgMenuLmsUserlist $ do
setTitleI MsgMenuLmsUserlist
$(widgetFile "lms-userlist")
-- See Module Handler.LMS.Result for
-- See Module Handler.LMS.Result for
-- getLmsResultR :: QualificationId -> Handler Html

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

@ -5,7 +5,8 @@
module Handler.LMS.Result
( getLmsResultR
( makeLmsFilename
, getLmsResultR, postLmsResultR
)
where
@ -25,6 +26,15 @@ import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
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)
@ -74,12 +84,6 @@ data LmsResultTableCsv = LmsResultTableCsv
deriving Generic
makeLenses_ ''LmsResultTableCsv
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece'' 2 1 -- TODO: purpose of dropping here is?
, fieldLabelModifier = camelToPathPiece' 2
} ''LmsResultTableCsv
-- csv without headers
instance Csv.ToRecord 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)
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 }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece'' 2 1
, fieldLabelModifier = camelToPathPiece' 2
{ constructorTagModifier = camelToPathPiece'' 2 1 -- LmsResultInsertData -> insert
, fieldLabelModifier = camelToPathPiece' 2 -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success
, sumEncoding = TaggedObject "action" "data"
} ''LmsResultCsvAction
@ -173,23 +177,31 @@ mkResultTable sid qsh qid = do
dbtParams = def
dbtIdent :: Text
dbtIdent = "lms-userlist"
dbtCsvEncode = Nothing
dbtCsvDecode = Just $ DBTCsvDecode -- Just save to DB; Job will process data later
dbtCsvEncode = Nothing
{-
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{..} ->
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
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
--let LmsResultTableCsv{..} = dbCsvNew
--let csvLRTident = error "TODO"
-- csvLRTsuccess = error "TODO"
yield $ LmsResultInsertData
{ lmsResultInsertIdent = csvLRTident 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
DBCsvDiffExisting{} -> return () -- no merge
, dbtCsvClassifyAction = \LmsResultInsertData{} -> LmsResultInsert
DBCsvDiffExisting{} -> return () -- no merge
, 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
@ -205,10 +217,15 @@ mkResultTable sid qsh qid = do
[ LmsResultSuccess =. lmsResultInsertSuccess
, LmsResultTimestamp =. now
]
-- queueDBJob
-- queueDBJob?? -- todo
-- audit
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
, dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text
}
@ -218,8 +235,9 @@ mkResultTable sid qsh qid = do
& defaultSorting [SortAscBy "ident"]
dbTable resultDBTableValidator resultDBTable
getLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsResultR sid qsh = do
getLmsResultR, postLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsResultR = postLmsResultR
postLmsResultR sid qsh = do
lmsTable <- runDB $ do
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
view _2 <$> mkResultTable sid qsh qid

3
test/Database/Fill.hs
View File

@ -457,7 +457,8 @@ fillDb = do
for_ [jost] $ \uid ->
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
sdBsc = StudyDegreeKey' 82
sdMst = StudyDegreeKey' 88