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

chore(lms): export user implemented

Browse Source
This commit is contained in:
Steffen Jost 2022-03-07 19:12:15 +01:00
parent 5aae0339fb
commit dc4ea0cc29
18 changed files with 489 additions and 306 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,8 +1,16 @@
TableLmsIdent: Identifikation
TableLmsFailed: Gesperrt
TableLmsSuccess: Bestanden
TableLmsPin: E-Lernen Pin
TableLmsResetPin: Pin zurücksetzen?
TableLmsDelete: Löschen?
TableLmsStaff: Interner Mitarbeiter?
TableLmsReceived: Erhalten
TableLmsSuccess: Bestanden
TableLmsFailed: Gesperrt
CsvColumnLmsIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Teilnehmer
CsvColumnLmsPin: PIN des E-Lernen Zugangs
CsvColumnLmsResetPin: Wird die PIN bei der nächsten Synchronisation zurückgesetzt?
CsvColumnLmsDelete: Wird der Identifikator in der E-Lernen Plattform bei der nächsten Synchronisation gelöscht?
CsvColumnLmsStaff: Handelt es sich um einen internen Mitarbeiter? (Aus historischen Gründen, wird momentan ignoriert.)
CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme
CsvColumnLmsFailed: User was blocked by LMS, usually due to too many attempts
LmsUserlistInsert: Neuer LMS User

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

@ -1,8 +1,16 @@
TableLmsIdent: Identifier
TableLmsFailed: Blocked
TableLmsSuccess: Completed
TableLmsPin: E-learning pin
TableLmsResetPin: Reset pin?
TableLmsDelete: Delete?
TableLmsStaff: Staff?
TableLmsReceived: Received
CsvColumnLmsIdent: E-Learing identifier, unique for each qualfication and user
TableLmsSuccess: Completed
TableLmsFailed: Blocked
CsvColumnLmsIdent: E-learning identifier, unique for each qualfication and user
CsvColumnLmsPin: PIN for E-learning access
CsvColumnLmsResetPin: Will the E-learning PIN be reset upon next synchronisation?
CsvColumnLmsDelete: Will the identifier be deleted from the E-learning platfrom upon next synchronisation?
CsvColumnLmsStaff: Is the user an internal staff member? (Legacy, currently ignored)
CsvColumnLmsSuccess: Timestamp of successful completion
CsvColumnLmsFailed: Blockier durch LMS, üblicherweise wegen zu vieler Fehlversuche
LmsUserlistInsert: New LMS User

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

@ -124,5 +124,6 @@ MenuCourseEventEdit: Kurstermin bearbeiten
MenuLanguage: Sprache
MenuLms: Schnittstelle E-Lernen
MenuLmsUsers: Empfang E-Lernen Benutzer
MenuLmsUserlist: Melden E-Lernen Benutzer
MenuLmsResult: Melden Ergebnisse E-Lernen

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

@ -125,5 +125,6 @@ MenuCourseEventEdit: Edit course occurrence
MenuLanguage: Language
MenuLms: Interface E-Learning
MenuLmsUsers: Download E-Learning Users
MenuLmsUserlist: Upload E-Learning Users
MenuLmsResult: Upload E-Learning Results

3
models/lms.model
View File

@ -90,11 +90,12 @@ QualificationUser
LmsUser
qualification QualificationId OnDeleteCascade OnUpdateCascade
user UserId
ident LmsIdent
ident LmsIdent -- must be unique accross all LMS courses!
pin Text
resetPin Bool default=false -- should pin be reset?
success Bool Maybe -- open, success or failure; isJust indicates user will be deleted from LMS
-- success LmsStatus -- this would also encode Day information?!
--toDelete encoded by Handler.Utils.LMS.lmsUserToDelete
started UTCTime default=now()
received UTCTime Maybe -- last acknowledgement by LMS
ended UTCTime Maybe -- ident was deleted from LMS

2
routes
View File

@ -256,7 +256,7 @@
-- OSIS CSV Export Demo
/lms/#SchoolId/#QualificationShorthand LmsR GET POST
--/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET POST
/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET POST
/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST
/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST

1
src/Foundation/Navigation.hs
View File

@ -134,6 +134,7 @@ 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 (LmsUserlistR sid qsh) = i18nCrumb MsgMenuLmsUserlist $ Just $ LmsR sid qsh
breadcrumb (LmsResultR sid qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR sid qsh

225
src/Handler/LMS.hs
View File

@ -1,3 +1,4 @@
{-# 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-redundant-constraints #-} -- TODO: remove me, for debugging only
@ -5,6 +6,7 @@
module Handler.LMS
( getLmsR , postLmsR
, getLmsUsersR , postLmsUsersR
, getLmsUserlistR, postLmsUserlistR
, getLmsResultR , postLmsResultR
)
@ -13,6 +15,7 @@ module Handler.LMS
import Import
import Handler.Utils
import Handler.Utils.Csv
import Handler.Utils.LMS
import qualified Data.Map as Map
@ -22,11 +25,11 @@ import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
import Handler.LMS.Result as Handler.LMS
import Handler.LMS.Users as Handler.LMS
import Handler.LMS.Userlist as Handler.LMS
import Handler.LMS.Result as Handler.LMS
{-
data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
{ csvLmsUserIdent :: LmsIdent
, csvLmsUserPin :: Text
@ -60,7 +63,7 @@ getLmsR = postLmsR
postLmsR sid qsh = do
_qid <- runDB . getKeyBy404 $ UniqueSchoolShort sid qsh
-- TODO !!! filter table by qid !!!
{-
dbtCsvName <- csvLmsUserFilename
let dbtIdent = "lmsUsers" :: Text
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
@ -116,10 +119,222 @@ postLmsR sid qsh = do
-- }
psValidator = def
lmsTable = dbTable psValidator DBTable{..}
-}
let lmsTable = [whamlet|TODO|] -- TODO: remove me, just for debugging
siteLayoutMsg MsgMenuLms $ do
setTitleI MsgMenuLms
$(widgetFile "lms")
-}
--- old above, new below
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 [ 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
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 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))
-- , (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))
]
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)
]
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 csvLmsIdent]
dbTable resultDBTableValidator resultDBTable
getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsR = postLmsR
postLmsR sid qsh = do
lmsTable <- runDB $ do
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
view _2 <$> mkLmsTable sid qsh qid
siteLayoutMsg MsgMenuLmsResult $ do
setTitleI MsgMenuLmsResult
$(widgetFile "lms")

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

@ -27,29 +27,29 @@ data LmsResultTableCsv = LmsResultTableCsv
makeLenses_ ''LmsResultTableCsv
-- csv without headers -- TODO not yet supported
instance Csv.ToRecord LmsResultTableCsv -- default suffices
instance Csv.FromRecord LmsResultTableCsv -- default suffices
--instance Csv.ToRecord LmsResultTableCsv -- default suffices
--instance Csv.FromRecord LmsResultTableCsv -- default suffices
-- csv with headers
lmsResultTableCsvHeader :: Csv.Header
lmsResultTableCsvHeader = Csv.header [ csvResultIdent, csvResultSuccess ]
lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ]
instance ToNamedRecord LmsResultTableCsv where
toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord
[ csvResultIdent Csv..= csvLRTident
, csvResultSuccess Csv..= csvLRTsuccess
[ csvLmsIdent Csv..= csvLRTident
, csvLmsSuccess Csv..= csvLRTsuccess
]
instance FromNamedRecord LmsResultTableCsv where
parseNamedRecord (lsfHeaderTranslate -> csv)
= LmsResultTableCsv
<$> csv Csv..: csvResultIdent
<*> csv Csv..: csvResultSuccess
<$> csv Csv..: csvLmsIdent
<*> csv Csv..: csvLmsSuccess
instance CsvColumnsExplained LmsResultTableCsv where
csvColumnsExplanations _ = mconcat
[ single csvResultIdent MsgCsvColumnLmsIdent
, single csvResultSuccess MsgCsvColumnLmsSuccess
[ single csvLmsIdent MsgCsvColumnLmsIdent
, single csvLmsSuccess MsgCsvColumnLmsSuccess
]
where
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
@ -91,22 +91,22 @@ mkResultTable sid qsh qid = do
dbtRowKey = (E.^. LmsResultId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
dbtColonnade = dbColonnade $ mconcat
[ 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
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
, sortable (Just csvLmsSuccess) (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 (E.^. LmsResultIdent))
, (csvResultSuccess, SortColumn (E.^. LmsResultSuccess))
, (csvLmsTimestamp , SortColumn (E.^. LmsResultTimestamp))
[ (csvLmsIdent , SortColumn (E.^. LmsResultIdent))
, (csvLmsSuccess , SortColumn (E.^. LmsResultSuccess))
, (csvLmsTimestamp, SortColumn (E.^. LmsResultTimestamp))
]
dbtFilter = Map.fromList
[ (csvResultIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent))
, (csvResultSuccess, FilterColumn $ E.mkExactFilter (E.^. LmsResultSuccess))
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent))
, (csvLmsSuccess, 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 dayField) (fslI MsgTableLmsSuccess)
[ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
, prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsSuccess)
]
dbtStyle = def
dbtParams = def
@ -183,7 +183,7 @@ mkResultTable sid qsh qid = do
dbtExtraReps = []
resultDBTableValidator = def
& defaultSorting [SortAscBy csvResultIdent]
& defaultSorting [SortAscBy csvLmsIdent]
dbTable resultDBTableValidator resultDBTable
getLmsResultR, postLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html

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

@ -1,235 +0,0 @@
{-# 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")

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

@ -1,6 +1,4 @@
{-# 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
module Handler.LMS.Userlist
( getLmsUserlistR, postLmsUserlistR
@ -28,28 +26,28 @@ data LmsUserlistTableCsv = LmsUserlistTableCsv
makeLenses_ ''LmsUserlistTableCsv
-- csv without headers -- TODO not yet supported
instance Csv.ToRecord LmsUserlistTableCsv
instance Csv.FromRecord LmsUserlistTableCsv
--instance Csv.ToRecord LmsUserlistTableCsv
--instance Csv.FromRecord LmsUserlistTableCsv
-- csv with headers
lmsUserlistTableCsvHeader :: Csv.Header
lmsUserlistTableCsvHeader = Csv.header [ csvUserlistIdent, csvUserlistBlocked ]
lmsUserlistTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsBlocked ]
instance ToNamedRecord LmsUserlistTableCsv where
toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord
[ csvUserlistIdent Csv..= csvLULident
, csvUserlistBlocked Csv..= csvLULfailed
[ csvLmsIdent Csv..= csvLULident
, csvLmsBlocked Csv..= csvLULfailed
]
instance FromNamedRecord LmsUserlistTableCsv where
parseNamedRecord (lsfHeaderTranslate -> csv)
= LmsUserlistTableCsv
<$> csv Csv..: csvUserlistIdent
<*> csv Csv..: csvUserlistBlocked
<$> csv Csv..: csvLmsIdent
<*> csv Csv..: csvLmsBlocked
instance CsvColumnsExplained LmsUserlistTableCsv where
csvColumnsExplanations _ = mconcat
[ single csvUserlistIdent MsgCsvColumnLmsIdent
, single csvUserlistBlocked MsgCsvColumnLmsFailed
[ single csvLmsIdent MsgCsvColumnLmsIdent
, single csvLmsBlocked MsgCsvColumnLmsFailed
]
where
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
@ -91,22 +89,22 @@ mkUserlistTable sid qsh qid = do
dbtRowKey = (E.^. LmsUserlistId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
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 csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell lmsUserlistTimestamp
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ lmsUserlistIdent & getLmsIdent
, sortable (Just csvLmsBlocked) (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell lmsUserlistFailed IconBlocked
, 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)
, (csvLmsTimestamp , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp)
[ (csvLmsIdent , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent)
, (csvLmsBlocked , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed)
, (csvLmsTimestamp, SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp)
]
dbtFilter = Map.fromList
[ (csvUserlistIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent ))
, (csvUserlistBlocked, FilterColumn $ E.mkExactFilter (E.^. LmsUserlistFailed))
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent ))
, (csvLmsBlocked, FilterColumn $ E.mkExactFilter (E.^. LmsUserlistFailed))
]
dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter csvUserlistIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
, prismAForm (singletonFilter csvUserlistBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed)
[ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
, prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed)
]
dbtStyle = def
dbtParams = def
@ -186,7 +184,7 @@ mkUserlistTable sid qsh qid = do
dbtExtraReps = []
userlistDBTableValidator = def
& defaultSorting [SortAscBy csvUserlistIdent]
& defaultSorting [SortAscBy csvLmsIdent]
dbTable userlistDBTableValidator userlistTable

136
src/Handler/LMS/Users.hs Normal file
View File

@ -0,0 +1,136 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only
module Handler.LMS.Users
( getLmsUsersR, postLmsUsersR
)
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
data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
{ csvLUTident :: LmsIdent
, csvLUTpin :: Text
, csvLUTresetPin, csvLUTdelete, csvLUTstaff :: LmsBool
}
deriving Generic
makeLenses_ ''LmsUserTableCsv
-- csv without headers -- TODO not yet supported
-- instance Csv.ToRecord LmsUserTableCsv
-- instance Csv.FromRecord LmsUserTableCsv
-- csv with headers
lmsUserTableCsvHeader :: Csv.Header
lmsUserTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsPin, csvLmsResetPin, csvLmsDelete, csvLmsStaff ]
instance ToNamedRecord LmsUserTableCsv where
toNamedRecord LmsUserTableCsv{..} = Csv.namedRecord
[ csvLmsIdent Csv..= csvLUTident
, csvLmsPin Csv..= csvLUTpin
, csvLmsResetPin Csv..= csvLUTresetPin
, csvLmsDelete Csv..= csvLUTdelete
, csvLmsStaff Csv..= csvLUTstaff
]
instance FromNamedRecord LmsUserTableCsv where
parseNamedRecord (lsfHeaderTranslate -> csv)
= LmsUserTableCsv
<$> csv Csv..: csvLmsIdent
<*> csv Csv..: csvLmsPin
<*> csv Csv..: csvLmsResetPin
<*> csv Csv..: csvLmsDelete
<*> csv Csv..: csvLmsStaff
instance CsvColumnsExplained LmsUserTableCsv where
csvColumnsExplanations _ = mconcat
[ single csvLmsIdent MsgCsvColumnLmsIdent
, single csvLmsPin MsgCsvColumnLmsPin
, single csvLmsResetPin MsgCsvColumnLmsResetPin
, single csvLmsDelete MsgCsvColumnLmsDelete
, single csvLmsStaff MsgCsvColumnLmsStaff
]
where
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
single k v = singletonMap k [whamlet|_{v}|]
mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
mkUserTable _sid qsh qid = do
dbtCsvName <- csvFilenameLmsUser qsh
let dbtCsvSheetName = dbtCsvName
let
userDBTable = DBTable{..}
where
dbtSQLQuery lmsuser = do
E.where_ $ lmsuser E.^. LmsUserQualification E.==. E.val qid
return lmsuser
dbtRowKey = (E.^. LmsUserId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
dbtColonnade = dbColonnade $ mconcat
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsUserIdent . _getLmsIdent -> ident) -> textCell ident
, sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin) $ \(view $ _dbrOutput . _entityVal . _lmsUserPin -> pin ) -> textCell pin
, sortable (Just csvLmsResetPin) (i18nCell MsgTableLmsResetPin) $ \(view $ _dbrOutput . _entityVal . _lmsUserResetPin -> reset) -> ifIconCell reset IconReset
, sortable (Just csvLmsDelete) (i18nCell MsgTableLmsDelete) $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete -> del ) -> ifIconCell del IconRemoveUser
, sortable (Just csvLmsStaff) (i18nCell MsgTableLmsStaff) $ const mempty
]
dbtSorting = Map.fromList
[ (csvLmsIdent , SortColumn $ \lmslist -> lmslist E.^. LmsUserIdent)
, (csvLmsResetPin , SortColumn $ \lmslist -> lmslist E.^. LmsUserResetPin)
]
dbtFilter = Map.fromList
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserIdent ))
, (csvLmsResetPin , FilterColumn $ E.mkExactFilter (E.^. LmsUserResetPin))
]
dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
, prismAForm (singletonFilter csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsResetPin)
]
dbtStyle = def
dbtParams = def
dbtIdent :: Text
dbtIdent = "lms-user"
dbtCsvEncode = Just DBTCsvEncode {..}
where
dbtCsvExportForm = pure ()
dbtCsvNoExportData = Just id
dbtCsvExampleData = Nothing
dbtCsvHeader = const $ return lmsUserTableCsvHeader
dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
doEncode' = LmsUserTableCsv
<$> view (_dbrOutput . _entityVal . _lmsUserIdent)
<*> view (_dbrOutput . _entityVal . _lmsUserPin)
<*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool)
<*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool)
-- <*> const $ LmsBool False
<*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool)
dbtCsvDecode = Nothing
dbtExtraReps = []
userDBTableValidator = def
& defaultSorting [SortAscBy csvLmsIdent]
dbTable userDBTableValidator userDBTable
getLmsUsersR, postLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsUsersR = postLmsUsersR
postLmsUsersR sid qsh = do
lmsTable <- runDB $ do
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
view _2 <$> mkUserTable sid qsh qid
siteLayoutMsg MsgMenuLmsUsers $ do
setTitleI MsgMenuLmsUsers
$(widgetFile "lms-user")

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

@ -1,10 +1,18 @@
{-# OPTIONS -Wno-redundant-constraints #-} -- needed for Getter
module Handler.Utils.LMS
( csvLmsTimestamp
, csvUserlistIdent, csvUserlistBlocked
, csvResultIdent, csvResultSuccess
( csvLmsIdent
, csvLmsTimestamp
, csvLmsBlocked
, csvLmsSuccess
, csvLmsPin
, csvLmsResetPin
, csvLmsDelete
, csvLmsStaff
, csvFilenameLmsUser
, csvFilenameLmsUserlist
, csvFilenameLmsResult
, csvFilenameLmsResult
, lmsUserToDelete, _lmsUserToDelete
) where
-- general utils for LMS Interface Handlers
@ -12,19 +20,33 @@ module Handler.Utils.LMS
import Import
import Handler.Utils
-- Column names
-- generic Column names
csvLmsIdent :: IsString a => a
csvLmsIdent = fromString "user" -- "Benutzerkennung"
csvLmsTimestamp :: IsString a => a
csvLmsTimestamp = fromString "Zeitstempel"
csvLmsTimestamp = fromString "timestamp" -- "Zeitstempel"
csvUserlistIdent :: IsString a => a
csvUserlistIdent = fromString "Benutzerkennung"
csvUserlistBlocked :: IsString a => a
csvUserlistBlocked = fromString "Sperrung"
-- for User Table
csvLmsPin :: IsString a => a
csvLmsPin = fromString "pin" -- "PIN"
csvResultIdent :: IsString a => a
csvResultIdent = fromString "Benutzerkennung"
csvResultSuccess :: IsString a => a
csvResultSuccess = fromString "Datum"
csvLmsResetPin :: IsString a => a
csvLmsResetPin = fromString "reset_pin" -- "PIN zurücksetzen"
csvLmsDelete :: IsString a => a
csvLmsDelete = fromString "delete" -- "Account löschen"
csvLmsStaff :: IsString a => a
csvLmsStaff = fromString "staff" -- "Mitarbeiter"
-- for Userlist Table
csvLmsBlocked :: IsString a => a
csvLmsBlocked = fromString "blocked" -- "Sperrung"
-- for Result Table
csvLmsSuccess :: IsString a => a
csvLmsSuccess = fromString "success" -- "Datum"
-- | Filename for User transmission, contains current datestamp as agreed in LMS interface
@ -47,4 +69,11 @@ makeLmsFilename ftag (citext2lower -> qsh) = do
-- | Return current datetime in YYYYMMDDHH format
getYMTH :: MonadHandler m => m Text
getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime
getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime
-- | Deceide whether LMS platform should delete an identifier
lmsUserToDelete :: LmsUser -> Bool
lmsUserToDelete LmsUser{lmsUserEnded, lmsUserSuccess} = isNothing lmsUserEnded && isJust lmsUserSuccess
_lmsUserToDelete :: Getter LmsUser Bool
_lmsUserToDelete = to lmsUserToDelete

4
src/Handler/Utils/Table/Cells.hs
View File

@ -80,6 +80,10 @@ guardAuthCell mkParams = over cellContents $ \act -> do
iconCell :: IsDBTable m a => Icon -> DBCell m a
iconCell = cell . toWidget . icon
ifIconCell :: IsDBTable m a => Bool -> Icon -> DBCell m a
ifIconCell True = iconCell
ifIconCell False = const iconSpacerCell
addIconFixedWidth :: IsDBTable m a => DBCell m a -> DBCell m a
addIconFixedWidth = addCellClass ("icon-fixed-width" :: Text)

6
src/Utils/Icon.hs
View File

@ -100,6 +100,9 @@ data Icon
| IconSubmissionUserDuplicate
| IconNoAllocationUser
| IconSubmissionNoUsers
| IconRemoveUser
| IconReset
| IconBlocked
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
deriving anyclass (Universe, Finite, NFData)
@ -143,6 +146,7 @@ iconText = \case
IconApplyTrue -> "file-alt"
IconApplyFalse -> "trash"
IconNoCorrectors -> "user-slash"
IconRemoveUser -> "user-slash"
IconApplicationVeto -> "times"
IconApplicationFiles -> "file-alt"
IconTooltipDefault -> "question-circle"
@ -183,6 +187,8 @@ iconText = \case
IconSubmissionUserDuplicate -> "copy"
IconNoAllocationUser -> "user-slash"
IconSubmissionNoUsers -> "user-slash"
IconReset -> "undo" -- From fontawesome v6 onwards: "arrow-rotate-left"
IconBlocked -> "ban"
nullaryPathPiece ''Icon $ camelToPathPiece' 1
deriveLift ''Icon

2
templates/lms-user.hamlet Normal file
View File

@ -0,0 +1,2 @@
LMS User
^{lmsTable}

5
templates/lms.hamlet
View File

@ -1,5 +1,10 @@
LMS Overview
<ul>
<li> <a href=@{LmsUsersR sid qsh}>Export Users
<li> <a href=@{LmsUserlistR sid qsh}>Import Userlist
<li> <a href=@{LmsResultR sid qsh}>Import Result
!!!THIS PAGE IS NOT YET FUNCTIONAL!!!
^{lmsTable}

7
test/Database/Fill.hs
View File

@ -457,14 +457,17 @@ fillDb = do
for_ [jost] $ \uid ->
void . insert' $ UserSchool uid avn False
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
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
void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (addBDays (-1) $ utctDay now) now
void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (addBDays (-2) $ utctDay now) now
void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (addBDays (-3) $ utctDay now) now
void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now
void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True now
void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now
void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False Nothing now Nothing Nothing
void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False (Just True) now (Just now) Nothing
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True (Just False) now (Just now) Nothing
let
sdBsc = StudyDegreeKey' 82
sdMst = StudyDegreeKey' 88