Current Time
- #{show currtime}
- #{ft}
+ #{show currtime}
Instance Start
#{show starttime} #
diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs
index bb4c35326..263d97cfc 100644
--- a/src/Handler/LMS.hs
+++ b/src/Handler/LMS.hs
@@ -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")
diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs
index e24ebb641..66c3a7588 100644
--- a/src/Handler/LMS/Result.hs
+++ b/src/Handler/LMS/Result.hs
@@ -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,41 +26,42 @@ data LmsResultTableCsv = LmsResultTableCsv
deriving Generic
makeLenses_ ''LmsResultTableCsv
--- csv without headers
-instance Csv.ToRecord LmsResultTableCsv -- default suffices
-instance Csv.FromRecord LmsResultTableCsv -- default suffices
+-- 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 ]
+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
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 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 $ queryLmsResult >>> (E.^. LmsResultIdent))
- -- , (csvResultSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess))
- , (csvResultSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess))
+ [ (csvLmsIdent , SortColumn (E.^. LmsResultIdent))
+ , (csvLmsSuccess , 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))
+ [ (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 checkBoxField) (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
@@ -173,53 +123,67 @@ 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
}
dbtExtraReps = []
resultDBTableValidator = def
- & defaultSorting [SortAscBy csvResultIdent]
+ & defaultSorting [SortAscBy csvLmsIdent]
dbTable resultDBTableValidator resultDBTable
getLmsResultR, postLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html
diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs
index 73a04b422..858559d14 100644
--- a/src/Handler/LMS/Userlist.hs
+++ b/src/Handler/LMS/Userlist.hs
@@ -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
@@ -18,38 +16,38 @@ 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
- , csvLULfailed :: Bool
+ , csvLULfailed :: LmsBool
}
deriving Generic
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 "timestamp") (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)
- , ("timestamp" , 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
@@ -121,7 +119,7 @@ mkUserlistTable sid qsh qid = do
dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
doEncode' = LmsUserlistTableCsv
<$> view (_dbrOutput . _entityVal . _lmsUserlistIdent)
- <*> view (_dbrOutput . _entityVal . _lmsUserlistFailed)
+ <*> view (_dbrOutput . _entityVal . _lmsUserlistFailed . _lmsBool)
dbtCsvDecode = Just DBTCsvDecode {..}
where
dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} ->
@@ -129,13 +127,13 @@ mkUserlistTable sid qsh qid = do
dbtCsvComputeActions = \case -- shows a diff first
DBCsvDiffNew{dbCsvNew} -> do
yield $ LmsUserlistInsertData
- { lmsUserlistInsertIdent = csvLULident dbCsvNew
- , lmsUserlistInsertFailed = csvLULfailed dbCsvNew
+ { lmsUserlistInsertIdent = csvLULident dbCsvNew
+ , lmsUserlistInsertFailed = lms2bool $ csvLULfailed dbCsvNew
}
DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}} -> do
yield $ LmsUserlistUpdateData
{ lmsUserlistInsertIdent = csvLULident
- , lmsUserlistInsertFailed = csvLULfailed
+ , lmsUserlistInsertFailed = csvLULfailed & lms2bool
}
DBCsvDiffMissing{} -> return () -- no deletion
dbtCsvClassifyAction = \case
@@ -150,15 +148,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
@@ -184,7 +184,7 @@ mkUserlistTable sid qsh qid = do
dbtExtraReps = []
userlistDBTableValidator = def
- & defaultSorting [SortAscBy csvUserlistIdent]
+ & defaultSorting [SortAscBy csvLmsIdent]
dbTable userlistDBTableValidator userlistTable
diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs
new file mode 100644
index 000000000..6f541f030
--- /dev/null
+++ b/src/Handler/LMS/Users.hs
@@ -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")
diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs
index 14693fe6a..edcfbdc42 100644
--- a/src/Handler/Utils/DateTime.hs
+++ b/src/Handler/Utils/DateTime.hs
@@ -167,6 +167,8 @@ validDateTimeFormats _ SelFormatDate = Set.fromList
, DateTimeFormat "%A %d.%m.%Y"
, DateTimeFormat "%Y-%m-%d"
, DateTimeFormat "%y-%m-%d"
+ , DateTimeFormat "%d-%m-%Y"
+ , DateTimeFormat "%d-%m-%y"
]
validDateTimeFormats TimeLocale{..} SelFormatTime = Set.fromList . concat . catMaybes $
[ Just
@@ -336,7 +338,7 @@ instance Csv.FromField ZonedTime where
return $ utcToZonedTime _ltuResult
parseFormats = do
- date <- ["%Y-%m-%d", "%d.%m.%Y"]
+ date <- ["%Y-%m-%d", "%d.%m.%Y", "%d-%m-%Y"]
sep <- ["T", " "]
doZone <- [True, False]
let zone = bool "" "%z" doZone
diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs
index b06d930fd..1c9775888 100644
--- a/src/Handler/Utils/LMS.hs
+++ b/src/Handler/Utils/LMS.hs
@@ -1,9 +1,18 @@
+{-# OPTIONS -Wno-redundant-constraints #-} -- needed for Getter
+
module Handler.Utils.LMS
- ( 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
@@ -11,16 +20,33 @@ module Handler.Utils.LMS
import Import
import Handler.Utils
--- Column names
-csvUserlistIdent :: IsString a => a
-csvUserlistIdent = fromString "Benutzerkennung"
-csvUserlistBlocked :: IsString a => a
-csvUserlistBlocked = fromString "Sperrung"
+-- generic Column names
+csvLmsIdent :: IsString a => a
+csvLmsIdent = fromString "user" -- "Benutzerkennung"
-csvResultIdent :: IsString a => a
-csvResultIdent = fromString "Benutzerkennung"
-csvResultSuccess :: IsString a => a
-csvResultSuccess = fromString "Datum"
+csvLmsTimestamp :: IsString a => a
+csvLmsTimestamp = fromString "timestamp" -- "Zeitstempel"
+
+-- for User Table
+csvLmsPin :: IsString a => a
+csvLmsPin = fromString "pin" -- "PIN"
+
+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
@@ -43,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
\ No newline at end of file
+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
\ No newline at end of file
diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs
index 3f99e4b99..e6f08695a 100644
--- a/src/Handler/Utils/Table/Cells.hs
+++ b/src/Handler/Utils/Table/Cells.hs
@@ -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)
diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs
index d62851469..59790590c 100644
--- a/src/Model/Types/Lms.hs
+++ b/src/Model/Types/Lms.hs
@@ -36,3 +36,46 @@ deriveJSON defaultOptions
, sumEncoding = TaggedObject "lmsaudit" "lmsaction"
} ''LmsStatus
derivePersistFieldJSON ''LmsStatus
+
+
+-- LMS Interface requires Bool to be encoded by 0 or 1 only
+{-
+data LmsBool = LmsUnset | LmsSet
+ deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData)
+
+lms2bool :: LmsBool -> Bool
+lms2bool LmsUnset = False
+lms2bool LmsSet = True
+bool2lms :: Bool -> LmsBool
+bool2lms False = LmsUnset
+bool2lms True = LmsSet
+
+_lmsBool :: Iso' Bool LmsBool
+_lmsBool = iso bool2lms lms2bool
+
+instance Csv.ToField LmsBool where
+ toField LmsUnset = "0"
+ toField LmsSet = "1"
+
+instance Csv.FromField LmsBool where
+ parseField i
+ | i == "0" = pure LmsUnset
+ | i == "1" = pure LmsSet
+ | otherwise = empty
+-}
+
+newtype LmsBool = LmsBool { lms2bool :: Bool }
+ deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+_lmsBool :: Iso' Bool LmsBool
+_lmsBool = iso LmsBool lms2bool
+
+instance Csv.ToField LmsBool where
+ toField (LmsBool False) = "0"
+ toField (LmsBool True ) = "1"
+
+instance Csv.FromField LmsBool where
+ parseField i
+ | i == "0" = pure $ LmsBool False
+ | i == "1" = pure $ LmsBool True
+ | otherwise = empty
diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs
index d220f9f7f..b03b15874 100644
--- a/src/Utils/Icon.hs
+++ b/src/Utils/Icon.hs
@@ -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
diff --git a/templates/lms-user.hamlet b/templates/lms-user.hamlet
new file mode 100644
index 000000000..5d7ab85f6
--- /dev/null
+++ b/templates/lms-user.hamlet
@@ -0,0 +1,2 @@
+LMS User
+^{lmsTable}
diff --git a/templates/lms.hamlet b/templates/lms.hamlet
index 79aa7175b..b04cf5204 100644
--- a/templates/lms.hamlet
+++ b/templates/lms.hamlet
@@ -1,5 +1,10 @@
LMS Overview
+