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

Merge branch 'csv-osis-demo'

Browse Source
This commit is contained in:
Steffen Jost 2022-03-17 13:15:39 +01:00
commit 7d85ea64ee
18 changed files with 315 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
config/settings.yml
View File

@ -165,7 +165,7 @@ memcached-local:
maximum-weight: 104857600 # 100MiB
upload-cache:
host: "_env:UPLOAD_S3_HOST:"
host: "_env:UPLOAD_S3_HOST:" # should be optional, but all file transfers will be empty without an S3 cache
port: "_env:UPLOAD_S3_PORT:9000"
access-key: "_env:UPLOAD_S3_KEY_ID:"
secret-key: "_env:UPLOAD_S3_KEY"

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

@ -11,11 +11,12 @@ 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
CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme (UTC)
CsvColumnLmsFailed: User was blocked by LMS, usually due to too many attempts
LmsUserlistInsert: Neuer LMS User
LmsUserlistUpdate: LMS User aktualisierung
LmsResultInsert: Neues LMS Ergebnis
LmsResultUpdate: LMS Ergebnis aktualisierung
LmsResultCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel
LmsUserlistCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel
LmsUserlistCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel
LmsDirectUpload: Direkter Upload für automatisierte Systeme

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

@ -11,11 +11,12 @@ 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
CsvColumnLmsSuccess: Timestamp of successful completion (UTC)
CsvColumnLmsFailed: Blockier durch LMS, üblicherweise wegen zu vieler Fehlversuche
LmsUserlistInsert: New LMS User
LmsUserlistUpdate: Update of LMS User
LmsResultInsert: New LMS result
LmsResultUpdate: Update of LMS result
LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key
LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key
LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key
LmsDirectUpload: Direct upload for automated Systems

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

@ -126,4 +126,5 @@ MenuLanguage: Sprache
MenuLms: Schnittstelle E-Lernen
MenuLmsUsers: Empfang E-Lernen Benutzer
MenuLmsUserlist: Melden E-Lernen Benutzer
MenuLmsResult: Melden Ergebnisse E-Lernen
MenuLmsResult: Melden Ergebnisse E-Lernen
MenuLmsUpload: Direkter Upload

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

@ -127,4 +127,5 @@ MenuLanguage: Language
MenuLms: Interface E-Learning
MenuLmsUsers: Download E-Learning Users
MenuLmsUserlist: Upload E-Learning Users
MenuLmsResult: Upload E-Learning Results
MenuLmsResult: Upload E-Learning Results
MenuLmsUpload: Direct Upload

8
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!
UniqueSchoolShort school shorthand -- must be unique per school and shorthand
UniqueSchoolName school name -- must be unique per school and name
UniqueQualificationSchoolShort school shorthand -- must be unique per school and shorthand
UniqueQualificationSchoolName school name -- must be unique per school and name
deriving Generic
-- TODOs:
@ -99,7 +99,7 @@ LmsUser
started UTCTime default=now()
received UTCTime Maybe -- last acknowledgement by LMS
ended UTCTime Maybe -- ident was deleted from LMS
UniqueLmsUser qualification ident
UniqueLmsUser ident -- idents must be unique accross all qualifications, since idents are global within LMS!
deriving Generic
-- LmsUserlist stores LMS upload for later processing only
@ -117,7 +117,7 @@ LmsResult
ident LmsIdent
success Day
timestamp UTCTime default=now()
UniqueLmsResult qualification ident success -- required by DBTable
UniqueLmsResult qualification ident -- required by DBTable
deriving Generic
-- Logs all processed rows from LmsUserlist and LmsResult

1
nix/docker/default.nix
View File

@ -27,6 +27,7 @@ let
curl wget netcat # just for manual testing within the pod, remove for production!
openldap # just for manual testing within the pod, remove for production!
iana-etc
unixtools.netstat htop gnugrep
] ++ optionals isDemo [ postgresql_12 memcached uniworx.uniworx.components.exes.uniworxdb ];
runAsRoot = ''

14
routes
View File

@ -255,8 +255,12 @@
!/*WellKnownFileName WellKnownR GET !free
-- OSIS CSV Export Demo
/lms/#SchoolId/#QualificationShorthand LmsR GET POST
/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET POST
/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST
/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST
/lms/#SchoolId/#QualificationShorthand LmsR GET POST
/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET
/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET
/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST
/lms/#SchoolId/#QualificationShorthand/userliss/upload LmsUserlistUploadR GET POST
/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST
/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST
/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST
/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST

14
src/Foundation/Navigation.hs
View File

@ -133,10 +133,16 @@ 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 (LmsUserlistR sid qsh) = i18nCrumb MsgMenuLmsUserlist $ Just $ LmsR sid qsh
breadcrumb (LmsResultR sid qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR sid qsh
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 ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing
breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail $ Just ProfileR

18
src/Handler/LMS.hs
View File

@ -5,10 +5,12 @@
module Handler.LMS
( getLmsR , postLmsR
, getLmsUsersR , postLmsUsersR
, getLmsUserlistR, postLmsUserlistR
, getLmsResultR , postLmsResultR
( getLmsR , postLmsR
, getLmsUsersR , getLmsUsersDirectR
, getLmsUserlistR , postLmsUserlistR
, getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR
, getLmsResultR , postLmsResultR
, getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR
)
where
@ -61,7 +63,7 @@ resultUser = _dbrOutput . _2
getLmsR, postLmsR:: SchoolId -> QualificationShorthand -> Handler Html
getLmsR = postLmsR
postLmsR sid qsh = do
_qid <- runDB . getKeyBy404 $ UniqueSchoolShort sid qsh
_qid <- runDB . getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
-- TODO !!! filter table by qid !!!
dbtCsvName <- csvLmsUserFilename
@ -265,7 +267,7 @@ mkLmsTable sid qsh qid = do
[ 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
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def
dbtIdent :: Text
dbtIdent = "lms-result"
@ -285,7 +287,7 @@ mkLmsTable sid qsh qid = do
dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
{ dbtCsvRowKey = \LmsResultTableCsv{..} ->
fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident csvLRTsuccess
fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident
, dbtCsvComputeActions = \case -- purpose is to show a diff to the user first
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
yield $ LmsResultInsertData
@ -333,7 +335,7 @@ getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsR = postLmsR
postLmsR sid qsh = do
lmsTable <- runDB $ do
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
view _2 <$> mkLmsTable sid qsh qid
siteLayoutMsg MsgMenuLmsResult $ do
setTitleI MsgMenuLmsResult

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

@ -1,8 +1,9 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only
module Handler.LMS.Result
( getLmsResultR, postLmsResultR
, getLmsResultUploadR, postLmsResultUploadR
, postLmsResultDirectR
)
where
@ -21,7 +22,7 @@ import qualified Database.Esqueleto.Utils as E
data LmsResultTableCsv = LmsResultTableCsv
{ csvLRTident :: LmsIdent
, csvLRTsuccess :: Day
, csvLRTsuccess :: LmsDay
}
deriving Generic
makeLenses_ ''LmsResultTableCsv
@ -66,7 +67,7 @@ data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece'' 2 1 -- LmsResultInsertData -> insert
, fieldLabelModifier = camelToPathPiece' 2 -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success
, fieldLabelModifier = camelToPathPiece' 2 -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success
, sumEncoding = TaggedObject "action" "data"
} ''LmsResultCsvAction
@ -79,12 +80,12 @@ embedRenderMessage ''UniWorX ''LmsResultCsvException id
mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
mkResultTable sid qsh qid = do
now_day <- utctDay <$> liftIO getCurrentTime
dbtCsvName <- csvFilenameLmsResult qsh
let dbtCsvSheetName = dbtCsvName
let
resultDBTable = DBTable{..}
where
dbtSQLQuery lmsresult = do
E.where_ $ lmsresult E.^. LmsResultQualification E.==. E.val qid
return lmsresult
@ -108,38 +109,43 @@ mkResultTable sid qsh qid = do
[ 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
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def
dbtIdent :: Text
dbtIdent = "lms-result"
dbtCsvEncode = Just DBTCsvEncode
dbtCsvEncode = Just DBTCsvEncode
{ dbtCsvExportForm = pure ()
, dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
, dbtCsvName
, dbtCsvSheetName
, dbtCsvNoExportData = Just id
, dbtCsvHeader = const $ return lmsResultTableCsvHeader
, dbtCsvExampleData = Nothing
, dbtCsvExampleData = Just
[ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day }
| (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..]
]
}
where
doEncode' = LmsResultTableCsv
<$> view (_dbrOutput . _entityVal . _lmsResultIdent)
<*> view (_dbrOutput . _entityVal . _lmsResultSuccess)
<*> view (_dbrOutput . _entityVal . _lmsResultSuccess . _lmsDay)
dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
{ dbtCsvRowKey = \LmsResultTableCsv{..} ->
fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident csvLRTsuccess
fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident
, 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
, lmsResultInsertSuccess = csvLRTsuccess dbCsvNew & lms2day
}
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
}
DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}, dbCsvOld} -> do
let successDay = lms2day csvLRTsuccess
when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsResultSuccess) $
yield $ LmsResultUpdateData
{ lmsResultInsertIdent = csvLRTident
, lmsResultInsertSuccess = successDay
}
DBCsvDiffMissing{} -> return () -- no deletion
, dbtCsvClassifyAction = \case
LmsResultInsertData{} -> LmsResultInsert
@ -189,9 +195,77 @@ mkResultTable sid qsh qid = do
getLmsResultR, postLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsResultR = postLmsResultR
postLmsResultR sid qsh = do
let directUploadLink = LmsResultUploadR sid qsh
lmsTable <- runDB $ do
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
view _2 <$> mkResultTable sid qsh qid
siteLayoutMsg MsgMenuLmsResult $ do
setTitleI MsgMenuLmsResult
$(widgetFile "lms-result")
-- Direct File Upload/Download
--saveResultCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend) =>
-- Key Qualification -> LmsResultTableCsv -> ReaderT backend m ()
saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> DB Int
saveResultCsv qid i LmsResultTableCsv{..} = do
now <- liftIO getCurrentTime
void $ upsert
LmsResult
{ lmsResultQualification = qid
, lmsResultIdent = csvLRTident
, lmsResultSuccess = csvLRTsuccess & lms2day
, lmsResultTimestamp = now
}
[ LmsResultSuccess =. (csvLRTsuccess & lms2day)
, LmsResultTimestamp =. now
]
return $ succ i
makeResultUploadForm :: Form FileInfo
makeResultUploadForm = renderAForm FormStandard $ fileAFormReq "Result CSV"
getLmsResultUploadR, postLmsResultUploadR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsResultUploadR = postLmsResultUploadR
postLmsResultUploadR sid qsh = do
((result,widget), enctype) <- runFormPost makeResultUploadForm
case result of
FormSuccess file -> do
-- content <- fileSourceByteString file
-- return $ Just (fileName file, content)
nr <- runDB $ do
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
runConduit $ fileSource file
.| decodeCsv
.| foldMC (saveResultCsv qid) 0
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
redirect $ LmsResultR sid qsh
FormFailure errs -> do
forM_ errs $ addMessage Error . toHtml
redirect $ LmsResultUploadR sid qsh
FormMissing ->
siteLayoutMsg MsgMenuLmsResult $ do
setTitleI MsgMenuLmsUpload
[whamlet|$newline never
<form method=post enctype=#{enctype}>
^{widget}
<p>
<input type=submit>
|]
postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html
postLmsResultDirectR sid qsh = do
(_params, files) <- runRequestBody
case files of
[(fhead,file)] -> do
nr <- runDB $ do
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
runConduit $ fileSource file
.| decodeCsv
.| foldMC (saveResultCsv qid) 0
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen für Result mit Header ") <> fhead
[] -> addMessage Error "Es wurde keine Datei übermittelt."
_other -> addMessage Error "Es darf nur genau eine Datei übermittelt werden."
redirect $ LmsResultR sid qsh

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

@ -2,6 +2,8 @@
module Handler.LMS.Userlist
( getLmsUserlistR, postLmsUserlistR
, getLmsUserlistUploadR, postLmsUserlistUploadR
, postLmsUserlistDirectR
)
where
@ -30,8 +32,8 @@ makeLenses_ ''LmsUserlistTableCsv
--instance Csv.FromRecord LmsUserlistTableCsv
-- csv with headers
lmsUserlistTableCsvHeader :: Csv.Header
lmsUserlistTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsBlocked ]
instance DefaultOrdered LmsUserlistTableCsv where
headerOrder = const $ Csv.header [ csvLmsIdent, csvLmsBlocked ]
instance ToNamedRecord LmsUserlistTableCsv where
toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord
@ -106,17 +108,17 @@ mkUserlistTable sid qsh qid = do
[ 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
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def
dbtIdent :: Text
dbtIdent = "lms-userlist"
dbtCsvEncode = Just DBTCsvEncode {..}
dbtCsvEncode = simpleCsvEncode dbtCsvName dbtCsvSheetName doEncode' <&> addExample
where
dbtCsvExportForm = pure ()
dbtCsvNoExportData = Just id
dbtCsvExampleData = Nothing
dbtCsvHeader = const $ return lmsUserlistTableCsvHeader
dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
addExample dce = dce{ dbtCsvExampleData = csvExample }
csvExample = Just
[ LmsUserlistTableCsv{csvLULident = LmsIdent lid, csvLULfailed = LmsBool ufl}
| (lid,ufl) <- zip ["abcdefgh", "12345678", "ident8ch"] [False,True,False]
]
doEncode' = LmsUserlistTableCsv
<$> view (_dbrOutput . _entityVal . _lmsUserlistIdent)
<*> view (_dbrOutput . _entityVal . _lmsUserlistFailed . _lmsBool)
@ -130,11 +132,13 @@ mkUserlistTable sid qsh qid = do
{ lmsUserlistInsertIdent = csvLULident dbCsvNew
, lmsUserlistInsertFailed = lms2bool $ csvLULfailed dbCsvNew
}
DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}} -> do
yield $ LmsUserlistUpdateData
{ lmsUserlistInsertIdent = csvLULident
, lmsUserlistInsertFailed = csvLULfailed & lms2bool
}
DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do
let failedBool = lms2bool csvLULfailed
when (failedBool /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsUserlistFailed) $
yield $ LmsUserlistUpdateData
{ lmsUserlistInsertIdent = csvLULident
, lmsUserlistInsertFailed = csvLULfailed & lms2bool
}
DBCsvDiffMissing{} -> return () -- no deletion
dbtCsvClassifyAction = \case
LmsUserlistInsertData{} -> LmsUserlistInsert
@ -193,8 +197,73 @@ getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handl
getLmsUserlistR = postLmsUserlistR
postLmsUserlistR sid qsh = do
lmsTable <- runDB $ do
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
view _2 <$> mkUserlistTable sid qsh qid
siteLayoutMsg MsgMenuLmsUserlist $ do
setTitleI MsgMenuLmsUserlist
$(widgetFile "lms-userlist")
-- Direct File Upload/Download
--saveUserlistCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend) =>
-- Key Qualification -> LmsUserlistTableCsv -> ReaderT backend m ()
saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> DB Int
saveUserlistCsv qid i LmsUserlistTableCsv{..} = do
now <- liftIO getCurrentTime
void $ upsert
LmsUserlist
{ lmsUserlistQualification = qid
, lmsUserlistIdent = csvLULident
, lmsUserlistFailed = csvLULfailed & lms2bool
, lmsUserlistTimestamp = now
}
[ LmsUserlistFailed =. (csvLULfailed & lms2bool)
, LmsUserlistTimestamp =. now
]
return $ succ i
makeUserlistUploadForm :: Form FileInfo
makeUserlistUploadForm = renderAForm FormStandard $ fileAFormReq "Userlist CSV"
getLmsUserlistUploadR, postLmsUserlistUploadR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsUserlistUploadR = postLmsUserlistUploadR
postLmsUserlistUploadR sid qsh = do
((result,widget), enctype) <- runFormPost makeUserlistUploadForm
case result of
FormSuccess file -> do
nr <- runDB $ do
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
runConduit $ fileSource file
.| decodeCsv
.| foldMC (saveUserlistCsv qid) 0
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
redirect $ LmsUserlistR sid qsh
FormFailure errs -> do
forM_ errs $ addMessage Error . toHtml
redirect $ LmsUserlistUploadR sid qsh
FormMissing ->
siteLayoutMsg MsgMenuLmsUserlist $ do
setTitleI MsgMenuLmsUpload
[whamlet|$newline never
<form method=post enctype=#{enctype}>
^{widget}
<p>
<input type=submit>
|]
postLmsUserlistDirectR :: SchoolId -> QualificationShorthand -> Handler Html
postLmsUserlistDirectR sid qsh = do
(_params, files) <- runRequestBody
case files of
[(fhead,file)] -> do
nr <- runDB $ do
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
runConduit $ fileSource file
.| decodeCsv
.| foldMC (saveUserlistCsv qid) 0
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen für Userlit mit Header ") <> fhead
[] -> addMessage Error "Es wurde keine Datei übermittelt."
_other -> addMessage Error "Es darf nur genau eine Datei übermittelt werden."
redirect $ LmsUserlistR sid qsh

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

@ -1,8 +1,9 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only
{- LANGUAGE TypeApplications -} -- only needed for Database.Esqueleto.Experimental
module Handler.LMS.Users
( getLmsUsersR, postLmsUsersR
( getLmsUsersR
, getLmsUsersDirectR
)
where
@ -17,6 +18,7 @@ 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.Experimental as Ex
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
@ -28,6 +30,15 @@ data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
deriving Generic
makeLenses_ ''LmsUserTableCsv
-- | Mundane conversion needed for direct download without dbTable onlu
lmsUser2csv :: LmsUser -> LmsUserTableCsv
lmsUser2csv lu@LmsUser{..} = LmsUserTableCsv
{ csvLUTident = lmsUserIdent
, csvLUTpin = lmsUserPin
, csvLUTresetPin = lmsUserResetPin & LmsBool
, csvLUTdelete = lmsUserToDelete lu & LmsBool
, csvLUTstaff = False & LmsBool
}
-- csv without headers -- TODO not yet supported
-- instance Csv.ToRecord LmsUserTableCsv
@ -77,6 +88,7 @@ mkUserTable _sid qsh qid = do
where
dbtSQLQuery lmsuser = do
E.where_ $ lmsuser E.^. LmsUserQualification E.==. E.val qid
E.&&. E.isNothing (lmsuser E.^. LmsUserEnded)
return lmsuser
dbtRowKey = (E.^. LmsUserId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
@ -85,11 +97,13 @@ mkUserTable _sid qsh qid = do
, 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
, sortable Nothing (i18nCell MsgTableLmsStaff) $ const mempty
]
dbtSorting = Map.fromList
[ (csvLmsIdent , SortColumn $ \lmslist -> lmslist E.^. LmsUserIdent)
, (csvLmsResetPin , SortColumn $ \lmslist -> lmslist E.^. LmsUserResetPin)
[ (csvLmsIdent , SortColumn (E.^. LmsUserIdent))
, (csvLmsPin , SortColumn (E.^. LmsUserPin))
, (csvLmsResetPin , SortColumn (E.^. LmsUserResetPin))
, (csvLmsDelete , SortColumn lmsUserToDeleteExpr)
]
dbtFilter = Map.fromList
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserIdent ))
@ -99,7 +113,7 @@ mkUserTable _sid qsh qid = do
[ 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
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def
dbtIdent :: Text
dbtIdent = "lms-user"
@ -115,8 +129,7 @@ mkUserTable _sid qsh qid = do
<*> view (_dbrOutput . _entityVal . _lmsUserPin)
<*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool)
<*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool)
-- <*> const $ LmsBool False
<*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool)
<*> const (LmsBool False)
dbtCsvDecode = Nothing
dbtExtraReps = []
@ -125,12 +138,38 @@ mkUserTable _sid qsh qid = do
& defaultSorting [SortAscBy csvLmsIdent]
dbTable userDBTableValidator userDBTable
getLmsUsersR, postLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsUsersR = postLmsUsersR
postLmsUsersR sid qsh = do
getLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsUsersR sid qsh = do
lmsTable <- runDB $ do
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
view _2 <$> mkUserTable sid qsh qid
siteLayoutMsg MsgMenuLmsUsers $ do
setTitleI MsgMenuLmsUsers
$(widgetFile "lms-user")
getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
getLmsUsersDirectR sid qsh = do
lms_users <- runDB $ do
qid <- getKeyBy404 $ UniqueQualificationSchoolShort 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
lmsuser <- Ex.from $ Ex.table @LmsUser
Ex.where_ $ lmsuser Ex.^. LmsUserQualification Ex.==. Ex.val qid
Ex.&&. Ex.isNothing (lmsuser Ex.^. LmsUserEnded)
pure $ LmsUserTableCsv
{ csvLUTident = lmsuser Ex.^. LmsUserIdent
, csvLUTpin = lmsuser Ex.^. LmsUserPin
, csvLUTresetPin = LmsBool . Ex.unValue $ lmsuser Ex.^. LmsUserResetPin
, csvLUTdelete = LmsBool . Ex.unValue $ Ex.isNothing (lmsuser Ex.^. LmsUserEnded) Ex.&&. Ex.not_ (Ex.isNothing $ lmsuser Ex.^. LmsUserSuccess)
, csvLUTstaff = LmsBool False
}
-}
let csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
csvRenderedHeader = lmsUserTableCsvHeader
csvSheetName <- csvFilenameLmsUser qsh
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
csvRenderedToTypedContent csvSheetName CsvRendered{..}
-- direct Download see:
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod

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

@ -13,12 +13,14 @@ module Handler.Utils.LMS
, csvFilenameLmsUserlist
, csvFilenameLmsResult
, lmsUserToDelete, _lmsUserToDelete
, lmsUserToDeleteExpr
) where
-- general utils for LMS Interface Handlers
import Import
import Handler.Utils
import qualified Database.Esqueleto.Legacy as E
-- generic Column names
csvLmsIdent :: IsString a => a
@ -27,7 +29,7 @@ csvLmsIdent = fromString "user" -- "Benutzerkennung"
csvLmsTimestamp :: IsString a => a
csvLmsTimestamp = fromString "timestamp" -- "Zeitstempel"
-- for User Table
-- for Users Table
csvLmsPin :: IsString a => a
csvLmsPin = fromString "pin" -- "PIN"
@ -72,8 +74,12 @@ getYMTH :: MonadHandler m => m Text
getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime
-- | Deceide whether LMS platform should delete an identifier
lmsUserToDeleteExpr :: E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool)
lmsUserToDeleteExpr lmslist = E.isNothing (lmslist E.^. LmsUserEnded) E.&&. E.not_ (E.isNothing $ lmslist E.^. LmsUserSuccess)
lmsUserToDelete :: LmsUser -> Bool
lmsUserToDelete LmsUser{lmsUserEnded, lmsUserSuccess} = isNothing lmsUserEnded && isJust lmsUserSuccess
_lmsUserToDelete :: Getter LmsUser Bool
_lmsUserToDelete = to lmsUserToDelete
_lmsUserToDelete = to lmsUserToDelete

2
src/Handler/Utils/Table/Pagination.hs
View File

@ -1066,6 +1066,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
<|> piInput
psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit
lch <- lookupCustomHeader HeaderDBTableShortcircuit
$logErrorS "DBShortcircuit" $ fromMaybe mempty lch <> " and also " <> tshow psShortcircuit
let
-- adjustPI = over _piSorting $ guardOnM doSorting -- probably not neccessary; not displaying the links should be enough for now

54
src/Model/Types/Lms.hs
View File

@ -11,6 +11,8 @@ import Import.NoModel
import Database.Persist.Sql
import qualified Database.Esqueleto.Legacy as E
import qualified Data.Csv as Csv
import qualified Data.Time.Format as Time
import Data.Time.Format.ISO8601 (iso8601ParseM)
import Utils.Lens.TH
newtype LmsIdent = LmsIdent { getLmsIdent :: Text }
@ -38,32 +40,7 @@ deriveJSON defaultOptions
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
-}
-- | LMS interface requires Bool to be encoded by 0 or 1 only
newtype LmsBool = LmsBool { lms2bool :: Bool }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
@ -78,4 +55,27 @@ instance Csv.FromField LmsBool where
parseField i
| i == "0" = pure $ LmsBool False
| i == "1" = pure $ LmsBool True
| otherwise = empty
| otherwise = mempty
-- | LMS interface requires day format not compliant with iso8601
newtype LmsDay = LmsDay { lms2day :: Day }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
_lmsDay :: Iso' Day LmsDay
_lmsDay = iso LmsDay lms2day
-- | Format for day for LMS interface
lmsDayFormat :: String
lmsDayFormat = "%d-%m-%Y"
instance Csv.ToField LmsDay where
toField (LmsDay d) = Csv.toField $ Time.formatTime Time.defaultTimeLocale lmsDayFormat d -- TimeLocale should not matter; getTimeLocale requires MonadHandler
instance Csv.FromField LmsDay where
-- parseField = fmap LmsDay . parseLmsDay <=< Csv.parseField
-- where parseLmsDay = Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat
parseField i = do
s <- Csv.parseField i
d <- Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat s
<|> iso8601ParseM s -- Know-How AG considers supplying iso8601 dates in the future
return $ LmsDay d

3
templates/lms-result.hamlet
View File

@ -1,2 +1,5 @@
LMS Result
^{lmsTable}
<p>
<a href=@{directUploadLink}>
_{MsgLmsDirectUpload}

5
testdata/test_results.csv vendored Normal file
View File

@ -0,0 +1,5 @@
user,success
barfoo,2022-02-01
huhuuhu,10-12-2011
pqgrst,2022-03-07
hootsman,1994-07-08
1 user success
2 barfoo 2022-02-01
3 huhuuhu 10-12-2011
4 pqgrst 2022-03-07
5 hootsman 1994-07-08