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

lms: fake users now start over the configuered days instead of validUntil

Browse Source
This commit is contained in:
Steffen Jost 2022-09-02 15:12:42 +02:00
parent d204d4313d
commit 59fe2819e9
2 changed files with 36 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
models/lms.model
View File

@ -6,7 +6,7 @@ Qualification
description StoredMarkup Maybe -- user-defined large Html, ought to contain full description description StoredMarkup Maybe -- user-defined large Html, ought to contain full description
validDuration Word Maybe -- qualification is valid indefinitely or for a specified number of months validDuration Word Maybe -- qualification is valid indefinitely or for a specified number of months
auditDuration Word Maybe -- number of month to keep audit log; or indefinitely auditDuration Word Maybe -- number of month to keep audit log; or indefinitely
refreshWithin CalendarDiffDays Maybe -- notify users about renewal within this number of month/days before expiry refreshWithin CalendarDiffDays Maybe -- notify users about renewal within this number of month/days before expiry; to be used with addGregorianDurationClip
elearningStart Bool -- automatically schedule e-refresher elearningStart Bool -- automatically schedule e-refresher
-- elearningOnly Bool -- successful E-learing automatically increases validity. NO! -- elearningOnly Bool -- successful E-learing automatically increases validity. NO!
-- refreshInvitation StoredMarkup -- hard-coded I18N-MSGs used instead, but displayed on qualification page NO! -- refreshInvitation StoredMarkup -- hard-coded I18N-MSGs used instead, but displayed on qualification page NO!

57
src/Handler/LMS/Fake.hs
View File

@ -18,14 +18,14 @@ import Control.Applicative (ZipList(..), getZipList)
getLmsFakeR, postLmsFakeR :: SchoolId -> QualificationShorthand -> Handler Html getLmsFakeR, postLmsFakeR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsFakeR = postLmsFakeR getLmsFakeR = postLmsFakeR
postLmsFakeR sid qsh = do postLmsFakeR sid qsh = do
qent <- runDB $ getBy404 $ SchoolQualificationShort sid qsh
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
(Entity qid _) <- runDB $ getBy404 $ SchoolQualificationShort sid qsh
let qName :: Text = CI.original $ unSchoolKey sid <> "-" <> qsh let qName :: Text = CI.original $ unSchoolKey sid <> "-" <> qsh
((fakeRes, fakeView), fakeEnctype) <- runFormPost $ renderAForm FormStandard $ mkFakeForm $ utctDay now ((fakeRes, fakeView), fakeEnctype) <- runFormPost $ renderAForm FormStandard $ mkFakeForm $ utctDay now
let fakeForm = wrapForm fakeView def { formEncoding = fakeEnctype } let fakeForm = wrapForm fakeView def { formEncoding = fakeEnctype }
formResult fakeRes $ \res -> do formResult fakeRes $ \res -> do
(uNew, uTotal) <- runDB $ fakeQualificationUsers qid res (uNew, uTotal) <- runDB $ fakeQualificationUsers qent res
let msgStatus = if | uNew == 0 -> Error let msgStatus = if | uNew == 0 -> Error
| uNew == uTotal -> Success | uNew == uTotal -> Success
| otherwise -> Warning | otherwise -> Warning
@ -34,20 +34,28 @@ postLmsFakeR sid qsh = do
siteLayout "Testnutzer generieren" $ do siteLayout "Testnutzer generieren" $ do
setTitle $ toHtml $ "Testnutzer generieren " <> qName setTitle $ toHtml $ "Testnutzer generieren " <> qName
toWidget [whamlet| toWidget [whamlet|
Hier können zufällige Testbenutzer mit ablaufenden Qualifikationen generiert werden. Hier können zufällige Testbenutzer mit ablaufenden Qualifikationen generiert werden,
welche dann im angegebenen Zeitraum fällig werden.
^{fakeForm} ^{fakeForm}
<h2>Hinweise:
<ul>
<li> Emails der generierten Teilnehmer enden auf <tt>@example.com<\tt>
und die Matrikelnummer lautet <tt>TESTUSER<\tt>.
<li> Bereits vorhandene Teilnehmer mit gleicher Ident werden nicht neu generiert.
<li> Vorhandene Qualifikationen solcher Teilnehmer werden einfach überschrieben.
|] |]
mkFakeForm :: Day -> AForm Handler (Int, Day, Day) mkFakeForm :: Day -> AForm Handler (Int, Day, Day)
mkFakeForm d = (,,) mkFakeForm d = (,,)
<$> areq intField (fsl "Fällige Teilnehmer pro Tag") (Just 10) <$> areq intField (fsl "Fällige Teilnehmer pro Tag") (Just 10)
<*> areq dayField (fsl "Erster Tag mit fälligen Teilnehmern") (Just d) <*> areq dayField (fsl "Erster Tag an dem Teilnehmer fällig werden") (Just d)
<*> areq dayField (fsl "Letzter Tag mit fälligen Teilnehmern") (Just $ addDays 7 d) <*> areq dayField (fsl "Letzter Tag an dem Teilnehmer fällig werden") (Just $ addDays 7 d)
fakeQualificationUsers :: QualificationId -> (Int, Day, Day) -> DB (Int,Int) fakeQualificationUsers :: Entity Qualification -> (Int, Day, Day) -> DB (Int,Int)
fakeQualificationUsers qid (usersPerDay, dfrom, dto) = do fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (usersPerDay, dfrom, dto) = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
dropNames <- liftIO $ randomRIO (0,length givenNames * length surnames) dropNames <- liftIO $ randomRIO (0,length givenNames * length surnames)
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
@ -57,7 +65,7 @@ fakeQualificationUsers qid (usersPerDay, dfrom, dto) = do
pwHash <- liftIO $ PWStore.makePasswordWith pwHashAlgorithm pw pwHashStrength pwHash <- liftIO $ PWStore.makePasswordWith pwHashAlgorithm pw pwHashStrength
return $ AuthPWHash $ TEnc.decodeUtf8 pwHash return $ AuthPWHash $ TEnc.decodeUtf8 pwHash
let expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dto dfrom)] let expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dto dfrom)]
expiryNotifyDay = addGregorianDurationClip (fromMaybe calendarDay qualificationRefreshWithin) dfrom
fakeUser :: ([Text], UserSurname, (Maybe Languages, DateTimeFormat, DateTimeFormat, DateTimeFormat), Bool) -> User fakeUser :: ([Text], UserSurname, (Maybe Languages, DateTimeFormat, DateTimeFormat, DateTimeFormat), Bool) -> User
fakeUser (firstNames, userSurname, (userLanguages, userDateTimeFormat, userDateFormat, userTimeFormat), userPrefersPostal) = fakeUser (firstNames, userSurname, (userLanguages, userDateTimeFormat, userDateFormat, userTimeFormat), userPrefersPostal) =
let userIdent = CI.mk $ Text.intercalate "." (take 1 firstNames ++ (Text.take 1 <$> drop 1 firstNames) ++ [userSurname]) <> "@example.com" let userIdent = CI.mk $ Text.intercalate "." (take 1 firstNames ++ (Text.take 1 <$> drop 1 firstNames) ++ [userSurname]) <> "@example.com"
@ -92,21 +100,26 @@ fakeQualificationUsers qid (usersPerDay, dfrom, dto) = do
userPinPassword = Just "tomatenmarmelade" userPinPassword = Just "tomatenmarmelade"
in User{..} in User{..}
$logWarnS "FAKEUSER" $ tshow expiryNotifyDay
valid <- forM (zip expiryOffsets $ drop dropNames names) $ \(expOffset, user) -> do valid <- forM (zip expiryOffsets $ drop dropNames names) $ \(expOffset, user) -> do
euid <- insertBy $ fakeUser user euid <- insertBy $ fakeUser user
let uid = either entityKey id euid if | (Left (Entity _ User{userMatrikelnummer})) <- euid
qualificationUserUser = uid , userMatrikelnummer /= Just "TESTUSER"
qualificationUserQualification = qid -> return 0
qualificationUserValidUntil = addDays expOffset dfrom | otherwise -> do
qualificationUserFirstHeld = addGregorianMonthsClip (-24) qualificationUserValidUntil let uid = either entityKey id euid
qualificationUserLastRefresh = qualificationUserFirstHeld qualificationUserUser = uid
-- upsert QualificationUser{..} [ QualificationUserValidUntil =. qualificationUserValidUntil qualificationUserQualification = qid
-- , QualificationUserLastRefresh =. qualificationUserLastRefresh qualificationUserValidUntil = addDays expOffset expiryNotifyDay
-- ] qualificationUserFirstHeld = addGregorianMonthsClip (-24) qualificationUserValidUntil
-- return 1 qualificationUserLastRefresh = qualificationUserFirstHeld
-- We do not overwrite any existing qualifications, just to be on the save side: _ <- upsert QualificationUser{..}
ok <- insertUnique QualificationUser{..} [ QualificationUserValidUntil =. qualificationUserValidUntil
return $ maybe 0 (const 1) ok , QualificationUserLastRefresh =. qualificationUserLastRefresh
]
return $ either (const 0) (const 1) euid
-- ok <- insertUnique QualificationUser{..} -- We do not overwrite any existing qualifications, just to be on the save side:
-- return $ maybe 0 (const 1) ok
return (sum valid, length expiryOffsets) return (sum valid, length expiryOffsets)
where where