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

chore(lms): add required lenses for stub wip

Browse Source
This commit is contained in:
Steffen Jost 2022-02-08 18:01:59 +01:00
parent c76b2efd1d
commit 31154b9430
4 changed files with 25 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Application.hs
View File

@ -145,7 +145,7 @@ import Handler.Participants
import Handler.StorageKey import Handler.StorageKey
import Handler.Error import Handler.Error
import Handler.Upload import Handler.Upload
import Handler.LMS
-- This line actually creates our YesodDispatch instance. It is the second half -- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the -- of the call to mkYesodData which occurs in Foundation.hs. Please see the

6
src/Handler/Health.hs
View File

@ -2,6 +2,8 @@ module Handler.Health where
import Import import Import
import Handler.Utils
import qualified Data.Aeson.Encode.Pretty as Aeson import qualified Data.Aeson.Encode.Pretty as Aeson
import qualified Data.Text.Lazy.Builder as Builder import qualified Data.Text.Lazy.Builder as Builder
@ -104,6 +106,7 @@ getStatusR :: Handler Html
getStatusR = do getStatusR = do
starttime <- getsYesod appStartTime starttime <- getsYesod appStartTime
currtime <- liftIO getCurrentTime currtime <- liftIO getCurrentTime
ft <- formatTime' "%Y%m%d %H:%M:%S" currtime -- use me throughout or delete me (delete, since this Handler is for mechanised tests only)
withUrlRenderer withUrlRenderer
[hamlet| [hamlet|
$doctype 5 $doctype 5
@ -113,7 +116,8 @@ getStatusR = do
<body> <body>
<p> <p>
Current Time <br> Current Time <br>
#{show currtime} #{show currtime} <br>
#{ft}
<p> <p>
Instance Start <br> Instance Start <br>
#{show starttime} #{show starttime}

27
src/Handler/LMS.hs
View File

@ -42,30 +42,31 @@ resultLmsUser = _dbrOutput . _1
resultUser :: Lens' LmsUserTableData (Maybe (Entity User)) resultUser :: Lens' LmsUserTableData (Maybe (Entity User))
resultUser = _dbrOutput . _2 resultUser = _dbrOutput . _2
csvLmsUserFilename :: IO Text csvLmsUserFilename :: MonadHandler m => m Text
csvLmsUserFilename = makeLmsFilename "user" csvLmsUserFilename = makeLmsFilename "user"
csvLmsUserlistFilename :: IO Text csvLmsUserlistFilename :: MonadHandler m => m Text
csvLmsUserlistFilename = makeLmsFilename "userliste" csvLmsUserlistFilename = makeLmsFilename "userliste"
csvLmsResultFilename :: IO Text csvLmsResultFilename :: MonadHandler m => m Text
csvLmsResultFilename = makeLmsFilename "ergebnisse" csvLmsResultFilename = makeLmsFilename "ergebnisse"
-- | Create filenames as specified by the LMS interface agreed with Know How AG -- | Create filenames as specified by the LMS interface agreed with Know How AG
makeLmsFilename :: Text -> IO Text makeLmsFilename :: MonadHandler m => Text -> m Text
makeLmsFilename ftag = do makeLmsFilename ftag = do
ymth <- get_ymth ymth <- get_ymth
return $ "fradrive_f_" <> ftag <> "_" <> ymth <> ".csv" return $ "fradrive_f_" <> ftag <> "_" <> ymth <> ".csv"
-- | Return current datetime in YYYYMMDDHH format -- | Return current datetime in YYYYMMDDHH format
get_ymth :: IO Text get_ymth :: MonadHandler m => m Text
get_ymth = do get_ymth = do
now <- getCurrentTime now <- liftIO $ getCurrentTime
return $ formatTime "%Y%m%d%h" formatTime' "%Y%m%d%H" now
getLmsR :: Handler Html getLmsR :: Handler Html
getLmsR = do getLmsR = do
dbtCsvName <- csvLmsUserFilename
let dbtIdent = "lmsUsers" :: Text let dbtIdent = "lmsUsers" :: Text
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtSQLQuery = runReaderT $ do dbtSQLQuery = runReaderT $ do
@ -78,13 +79,17 @@ getLmsR = do
dbtRowKey = queryLmsUser >>> (E.^. LmsUserId) dbtRowKey = queryLmsUser >>> (E.^. LmsUserId)
dbtProj = dbtProjSimple $ \(lmsUser, user) -> do dbtProj = dbtProjSimple $ \(lmsUser, user) -> do
-- return ("abcdefgh", "12345678", False, False, True) -- return ("abcdefgh", "12345678", False, False, True)
return (lmsUser E.^. LmsUserIdent, lmsUser E.^. LmsUserPin, lmsUser E.^. LmsUserResetPin, lmsUser E.^. LmsUserResetPin, isJust (user E.?. UserCompanyPersonalNumber)) return ( lmsUser E.^. LmsUserIdent
, lmsUser E.^. LmsUserPin
, lmsUser E.^. LmsUserResetPin
, lmsUser E.^. LmsUserResetPin
-- , True) -- works, so we need a simple type here indeed
, isJust $ E.unValue (user E.?. UserCompanyPersonalNumber))
dbtColonnade = mempty --TODO dbtColonnade = mempty --TODO
dbtSorting = mempty dbtSorting = mempty
dbtFilter = mempty dbtFilter = mempty
dbtFilterUI = mempty dbtFilterUI = mempty
dbtParams = def dbtParams = def
dbtCsvName = "lms.csv"
-- TODO: wip, for reference, see e.g. Handler.Course.Users or Handler.Exam. -- TODO: wip, for reference, see e.g. Handler.Course.Users or Handler.Exam.
dbtCsvEncode = do dbtCsvEncode = do
return $ DBTCsvEncode return $ DBTCsvEncode
@ -99,7 +104,7 @@ getLmsR = do
mitarbeiter mitarbeiter
, dbtCsvName , dbtCsvName
, dbtCsvNoExportData = Nothing , dbtCsvNoExportData = Nothing
, dbtCsvHeader = Nothing -- return . Vector.filter csvColumns' . userTableCsvHeader showSex tutorials sheets . fromMaybe def , dbtCsvHeader = def -- return . Vector.filter csvColumns' . userTableCsvHeader showSex tutorials sheets . fromMaybe def
, dbtCsvExampleData = Nothing , dbtCsvExampleData = Nothing
} }
-- TODO wip, for reference see e.g. Handler.Exam.Users -- TODO wip, for reference see e.g. Handler.Exam.Users

3
src/Utils/Lens.hs
View File

@ -113,6 +113,9 @@ makeClassyFor_ ''StudyDegree
makeClassyFor_ ''StudyTerms makeClassyFor_ ''StudyTerms
makeClassyFor_ ''StudySubTerms makeClassyFor_ ''StudySubTerms
makeClassyFor_ ''LmsUser
makeClassyFor_ ''LmsUserlist
makeClassyFor_ ''LmsResult
_entityKey :: Getter (Entity record) (Key record) _entityKey :: Getter (Entity record) (Key record)
-- ^ Not a `Lens'` for safety -- ^ Not a `Lens'` for safety