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

chore(lms): reorder routes and (wip) overview table

Browse Source
This commit is contained in:
Steffen Jost 2022-03-17 18:40:58 +01:00
parent f6e1959ad4
commit 01d9916520
11 changed files with 67 additions and 150 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

@ -123,6 +123,7 @@ MenuCourseEventNew: Neuer Kurstermin
MenuCourseEventEdit: Kurstermin bearbeiten
MenuLanguage: Sprache
MenuQualification: Qualifkationen
MenuLms: Schnittstelle E-Lernen
MenuLmsUsers: Empfang E-Lernen Benutzer
MenuLmsUserlist: Melden E-Lernen Benutzer

1
messages/uniworx/utils/navigation/menu/en-eu.msg
View File

@ -124,6 +124,7 @@ MenuCourseEventNew: New course occurrence
MenuCourseEventEdit: Edit course occurrence
MenuLanguage: Language
MenuQualification: Qualifcations
MenuLms: Interface E-Learning
MenuLmsUsers: Download E-Learning Users
MenuLmsUserlist: Upload E-Learning Users

4
models/lms.model
View File

@ -10,8 +10,8 @@ Qualification
-- elearningOnly Bool -- successful E-learing automatically increases validity. NO!
-- refreshInvitation StoredMarkup -- hard-coded I18N-MSGs used instead, but displayed on qualification page NO!
-- expiryNotification StoredMarkup Maybe -- configurable user-profile-notifcations are used instead NO!
UniqueQualificationSchoolShort school shorthand -- must be unique per school and shorthand
UniqueQualificationSchoolName school name -- must be unique per school and name
SchoolQualificationShort school shorthand -- must be unique per school and shorthand
SchoolQualificationName school name -- must be unique per school and name
deriving Generic
-- TODOs:

2
models/schools.model
View File

@ -6,7 +6,7 @@ School json
examMinimumRegisterBeforeStart NominalDiffTime Maybe
examMinimumRegisterDuration NominalDiffTime Maybe
examRequireModeForRegistration Bool default=false
examDiscouragedModes ExamModeDNF default='{"dnf-terms":[]}'
examDiscouragedModes ExamModeDNF default='{"dnf-terms":[]}' -- This comment fixes syntax highlighting error only "
examCloseMode ExamCloseMode default='separate'
sheetAuthorshipStatementMode SchoolAuthorshipStatementMode default='optional'
sheetAuthorshipStatementDefinition AuthorshipStatementDefinitionId Maybe

2
routes
View File

@ -255,6 +255,8 @@
!/*WellKnownFileName WellKnownR GET !free
-- OSIS CSV Export Demo
/lms LmsAllR GET
/lms/#SchoolId LmsSchoolR GET
/lms/#SchoolId/#QualificationShorthand LmsR GET POST
/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET
/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET

24
src/Foundation/Navigation.hs
View File

@ -133,15 +133,21 @@ breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing
breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing
breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed
breadcrumb (LmsR _sid _qsh) = i18nCrumb MsgMenuLms Nothing
breadcrumb (LmsUsersR sid qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsR sid qsh
breadcrumb (LmsUsersDirectR sid qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsUsersR sid qsh -- never displayed, TypedContent
breadcrumb (LmsUserlistR sid qsh) = i18nCrumb MsgMenuLmsUserlist $ Just $ LmsR sid qsh
breadcrumb (LmsUserlistUploadR sid qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR sid qsh
breadcrumb (LmsUserlistDirectR sid qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR sid qsh -- never displayed
breadcrumb (LmsResultR sid qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR sid qsh
breadcrumb (LmsResultUploadR sid qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR sid qsh
breadcrumb (LmsResultDirectR sid qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR sid qsh -- never displayed
breadcrumb LmsAllR = i18nCrumb MsgMenuQualification Nothing
breadcrumb (LmsSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs
guardM . lift . existsBy . UniqueSchoolShorthand $ unSchoolKey ssh
return (CI.original $ unSchoolKey ssh, Just LmsAllR)
breadcrumb (LmsR ssh qsh) =useRunDB . maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ LmsSchoolR ssh) $ do
guardM . lift . existsBy $ SchoolQualificationShort ssh qsh
return (CI.original qsh, Just $ LmsSchoolR ssh)
breadcrumb (LmsUsersR ssh qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsR ssh qsh
breadcrumb (LmsUsersDirectR ssh qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsUsersR ssh qsh -- never displayed, TypedContent
breadcrumb (LmsUserlistR ssh qsh) = i18nCrumb MsgMenuLmsUserlist $ Just $ LmsR ssh qsh
breadcrumb (LmsUserlistUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR ssh qsh
breadcrumb (LmsUserlistDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR ssh qsh -- never displayed
breadcrumb (LmsResultR ssh qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR ssh qsh
breadcrumb (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh
breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed
breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing

165
src/Handler/LMS.hs
View File

@ -5,7 +5,9 @@
module Handler.LMS
( getLmsR , postLmsR
( getLmsAllR
, getLmsSchoolR
, getLmsR , postLmsR
, getLmsUsersR , getLmsUsersDirectR
, getLmsUserlistR , postLmsUserlistR
, getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR
@ -31,6 +33,19 @@ import Handler.LMS.Users as Handler.LMS
import Handler.LMS.Userlist as Handler.LMS
import Handler.LMS.Result as Handler.LMS
getLmsAllR :: Handler Html
getLmsAllR = error "TODO"
getLmsSchoolR :: SchoolId -> Handler Html
getLmsSchoolR ssh = redirect (LmsAllR, [("qualification-school", toPathPiece ssh)])
{- --redirect with filering
getLmsR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsR ssh qsh = redirect (LmsAllR, [("qualification-school" , toPathPiece ssh)
,("qualification-shorthand", toPathPiece qsh)
])
-}
{-
data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
{ csvLmsUserIdent :: LmsIdent
@ -63,7 +78,7 @@ resultUser = _dbrOutput . _2
getLmsR, postLmsR:: SchoolId -> QualificationShorthand -> Handler Html
getLmsR = postLmsR
postLmsR sid qsh = do
_qid <- runDB . getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
_qid <- runDB . getKeyBy404 $ SchoolQualificationShort sid qsh
-- TODO !!! filter table by qid !!!
dbtCsvName <- csvLmsUserFilename
@ -169,74 +184,12 @@ 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 [ csvLmsIdent, csvLmsSuccess ]
instance ToNamedRecord LmsResultTableCsv where
toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord
[ csvLmsIdent Csv..= csvLRTident
, csvLmsSuccess Csv..= csvLRTsuccess
]
instance FromNamedRecord LmsResultTableCsv where
parseNamedRecord (lsfHeaderTranslate -> csv)
= LmsResultTableCsv
<$> csv Csv..: csvLmsIdent
<*> csv Csv..: csvLmsSuccess
instance CsvColumnsExplained LmsResultTableCsv where
csvColumnsExplanations _ = mconcat
[ single csvLmsIdent MsgCsvColumnLmsIdent
, single csvLmsSuccess 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
mkLmsTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
mkLmsTable sid qsh qid = do
dbtCsvName <- csvFilenameLmsResult qsh
let dbtCsvSheetName = dbtCsvName
mkLmsTable :: QualificationId -> DB (Any, Widget)
mkLmsTable qid = do
let
resultDBTable = DBTable{..}
where
dbtSQLQuery = runReaderT $ do
qualification <- asks queryQualification
lmsResult <- asks queryLmsResult
@ -251,80 +204,32 @@ mkLmsTable sid qsh qid = do
dbtRowKey = queryLmsResult >>> (E.^. LmsResultId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
dbtColonnade = dbColonnade $ mconcat
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
, sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dayCell success
[ sortable (Just "school") (i18nCell MsgTableSchool) $ \(view $ resultQualification . _entityVal . _qualificationSchool -> schoolShorthand) -> wgtCell $ toWgt schoolShorthand
, sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
, sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dayCell success
] -- TODO: add more columns for manual debugging view !!!
dbtSorting = Map.fromList
[ (csvLmsIdent , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent))
[ ("school" , SortColumn $ queryQualification >>> (E.^. QualificationSchool))
, (csvLmsIdent , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent))
-- , (csvLmsSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess))
, (csvLmsSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess))
]
dbtFilter = Map.fromList
[ (csvLmsIdent , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent))
, (csvLmsSuccess, FilterColumn . E.mkExactFilter $ views (to queryLmsResult) (E.^. LmsResultSuccess))
[ ("school" , FilterColumn . E.mkExactFilter $ views (to queryQualification) (E.^. QualificationSchool))
, (csvLmsIdent , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent))
, (csvLmsSuccess, FilterColumn . E.mkExactFilter $ views (to queryLmsResult) (E.^. LmsResultSuccess))
]
dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
, prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsSuccess)
[ prismAForm (singletonFilter "school" . maybePrism (_PathPiece . from _SchoolId)) mPrev $ aopt (hoistField lift schoolField) (fslI MsgTableCourseSchool)
, prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
, prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsSuccess)
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
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
, 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
}
dbtIdent = "qualification"
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
dbtExtraReps = []
resultDBTableValidator = def
@ -335,8 +240,8 @@ getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsR = postLmsR
postLmsR sid qsh = do
lmsTable <- runDB $ do
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
view _2 <$> mkLmsTable sid qsh qid
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
view _2 <$> mkLmsTable qid
siteLayoutMsg MsgMenuLmsResult $ do
setTitleI MsgMenuLmsResult
$(widgetFile "lms")

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

@ -197,7 +197,7 @@ getLmsResultR = postLmsResultR
postLmsResultR sid qsh = do
let directUploadLink = LmsResultUploadR sid qsh
lmsTable <- runDB $ do
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
view _2 <$> mkResultTable sid qsh qid
siteLayoutMsg MsgMenuLmsResult $ do
setTitleI MsgMenuLmsResult
@ -235,7 +235,7 @@ postLmsResultUploadR sid qsh = do
-- content <- fileSourceByteString file
-- return $ Just (fileName file, content)
nr <- runDB $ do
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
runConduit $ fileSource file
.| decodeCsv
.| foldMC (saveResultCsv qid) 0
@ -261,7 +261,7 @@ postLmsResultDirectR sid qsh = do
case files of
[(fhead,file)] -> do
nr <- runDB $ do
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
runConduit $ fileSource file
.| decodeCsv
.| foldMC (saveResultCsv qid) 0

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

@ -197,7 +197,7 @@ getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handl
getLmsUserlistR = postLmsUserlistR
postLmsUserlistR sid qsh = do
lmsTable <- runDB $ do
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
view _2 <$> mkUserlistTable sid qsh qid
siteLayoutMsg MsgMenuLmsUserlist $ do
setTitleI MsgMenuLmsUserlist
@ -233,7 +233,7 @@ postLmsUserlistUploadR sid qsh = do
case result of
FormSuccess file -> do
nr <- runDB $ do
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
runConduit $ fileSource file
.| decodeCsv
.| foldMC (saveUserlistCsv qid) 0
@ -259,7 +259,7 @@ postLmsUserlistDirectR sid qsh = do
case files of
[(fhead,file)] -> do
nr <- runDB $ do
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
runConduit $ fileSource file
.| decodeCsv
.| foldMC (saveUserlistCsv qid) 0

4
src/Handler/LMS/Users.hs
View File

@ -140,7 +140,7 @@ mkUserTable _sid qsh qid = do
getLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsUsersR sid qsh = do
lmsTable <- runDB $ do
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
view _2 <$> mkUserTable sid qsh qid
siteLayoutMsg MsgMenuLmsUsers $ do
setTitleI MsgMenuLmsUsers
@ -149,7 +149,7 @@ getLmsUsersR sid qsh = do
getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
getLmsUsersDirectR sid qsh = do
lms_users <- runDB $ do
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
selectList [LmsUserQualification ==. qid, LmsUserEnded ==. Nothing] [Asc LmsUserStarted, Asc LmsUserIdent]
{- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it
Ex.select $ do

2
src/Utils/Icon.hs
View File

@ -85,6 +85,7 @@ data Icon
| IconMenuCorrections
| IconMenuExams
| IconMenuAdmin
| IconMenuLms
| IconPageActionPrimaryExpand | IconPageActionSecondary
| IconBreadcrumbSeparator
| IconMissingAllocationPriority
@ -169,6 +170,7 @@ iconText = \case
IconMenuCorrections -> "check"
IconMenuExams -> "poll-h"
IconMenuAdmin -> "screwdriver"
IconMenuLms -> "chalkboard-teacher" -- From fontawesome v6 onwards: "chalkboard-user" / or "desktop" for both
IconPageActionPrimaryExpand -> "bars"
IconPageActionSecondary -> "ellipsis-h"
IconBreadcrumbSeparator -> "angle-right"