lms: fake users now start over the configuered days instead of validUntil
This commit is contained in:
Steffen Jost
parent
d204d4313d
commit
59fe2819e9
@ -6,7 +6,7 @@ Qualification
|
||||
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
|
||||
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
|
||||
-- elearningOnly Bool -- successful E-learing automatically increases validity. NO!
|
||||
-- refreshInvitation StoredMarkup -- hard-coded I18N-MSGs used instead, but displayed on qualification page NO!
|
||||
|
||||
@ -18,14 +18,14 @@ import Control.Applicative (ZipList(..), getZipList)
|
||||
|
||||
getLmsFakeR, postLmsFakeR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||
getLmsFakeR = postLmsFakeR
|
||||
postLmsFakeR sid qsh = do
|
||||
postLmsFakeR sid qsh = do
|
||||
qent <- runDB $ getBy404 $ SchoolQualificationShort sid qsh
|
||||
now <- liftIO getCurrentTime
|
||||
(Entity qid _) <- runDB $ getBy404 $ SchoolQualificationShort sid qsh
|
||||
let qName :: Text = CI.original $ unSchoolKey sid <> "-" <> qsh
|
||||
((fakeRes, fakeView), fakeEnctype) <- runFormPost $ renderAForm FormStandard $ mkFakeForm $ utctDay now
|
||||
let fakeForm = wrapForm fakeView def { formEncoding = fakeEnctype }
|
||||
formResult fakeRes $ \res -> do
|
||||
(uNew, uTotal) <- runDB $ fakeQualificationUsers qid res
|
||||
(uNew, uTotal) <- runDB $ fakeQualificationUsers qent res
|
||||
let msgStatus = if | uNew == 0 -> Error
|
||||
| uNew == uTotal -> Success
|
||||
| otherwise -> Warning
|
||||
@ -34,20 +34,28 @@ postLmsFakeR sid qsh = do
|
||||
siteLayout "Testnutzer generieren" $ do
|
||||
setTitle $ toHtml $ "Testnutzer generieren " <> qName
|
||||
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}
|
||||
|
||||
<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 d = (,,)
|
||||
<$> areq intField (fsl "Fällige Teilnehmer pro Tag") (Just 10)
|
||||
<*> areq dayField (fsl "Erster Tag mit fälligen Teilnehmern") (Just d)
|
||||
<*> areq dayField (fsl "Letzter Tag mit fälligen Teilnehmern") (Just $ addDays 7 d)
|
||||
<*> areq dayField (fsl "Erster Tag an dem Teilnehmer fällig werden") (Just 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 qid (usersPerDay, dfrom, dto) = do
|
||||
fakeQualificationUsers :: Entity Qualification -> (Int, Day, Day) -> DB (Int,Int)
|
||||
fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (usersPerDay, dfrom, dto) = do
|
||||
now <- liftIO getCurrentTime
|
||||
dropNames <- liftIO $ randomRIO (0,length givenNames * length surnames)
|
||||
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
||||
@ -57,7 +65,7 @@ fakeQualificationUsers qid (usersPerDay, dfrom, dto) = do
|
||||
pwHash <- liftIO $ PWStore.makePasswordWith pwHashAlgorithm pw pwHashStrength
|
||||
return $ AuthPWHash $ TEnc.decodeUtf8 pwHash
|
||||
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 (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"
|
||||
@ -92,21 +100,26 @@ fakeQualificationUsers qid (usersPerDay, dfrom, dto) = do
|
||||
userPinPassword = Just "tomatenmarmelade"
|
||||
in User{..}
|
||||
|
||||
$logWarnS "FAKEUSER" $ tshow expiryNotifyDay
|
||||
valid <- forM (zip expiryOffsets $ drop dropNames names) $ \(expOffset, user) -> do
|
||||
euid <- insertBy $ fakeUser user
|
||||
let uid = either entityKey id euid
|
||||
qualificationUserUser = uid
|
||||
qualificationUserQualification = qid
|
||||
qualificationUserValidUntil = addDays expOffset dfrom
|
||||
qualificationUserFirstHeld = addGregorianMonthsClip (-24) qualificationUserValidUntil
|
||||
qualificationUserLastRefresh = qualificationUserFirstHeld
|
||||
-- upsert QualificationUser{..} [ QualificationUserValidUntil =. qualificationUserValidUntil
|
||||
-- , QualificationUserLastRefresh =. qualificationUserLastRefresh
|
||||
-- ]
|
||||
-- return 1
|
||||
-- We do not overwrite any existing qualifications, just to be on the save side:
|
||||
ok <- insertUnique QualificationUser{..}
|
||||
return $ maybe 0 (const 1) ok
|
||||
if | (Left (Entity _ User{userMatrikelnummer})) <- euid
|
||||
, userMatrikelnummer /= Just "TESTUSER"
|
||||
-> return 0
|
||||
| otherwise -> do
|
||||
let uid = either entityKey id euid
|
||||
qualificationUserUser = uid
|
||||
qualificationUserQualification = qid
|
||||
qualificationUserValidUntil = addDays expOffset expiryNotifyDay
|
||||
qualificationUserFirstHeld = addGregorianMonthsClip (-24) qualificationUserValidUntil
|
||||
qualificationUserLastRefresh = qualificationUserFirstHeld
|
||||
_ <- upsert QualificationUser{..}
|
||||
[ QualificationUserValidUntil =. qualificationUserValidUntil
|
||||
, 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)
|
||||
|
||||
where
|
||||
|
||||
Loading…
Reference in New Issue
Block a user