lms: add interface for create fake users and verify it is working
This commit is contained in:
Steffen Jost
parent
e9485fe22d
commit
3eedff2b9f
@ -130,7 +130,8 @@ MenuLmsUsers: Export E-Lernen Benutzer
|
||||
MenuLmsUserlist: Melden E-Lernen Benutzer
|
||||
MenuLmsResult: Melden Ergebnisse E-Lernen
|
||||
MenuLmsUpload: Hochladen
|
||||
MenuLmsDirect: Direkter Upload
|
||||
MenuLmsDirect: Direkter Upload
|
||||
MenuLmsFake: Testnutzer generieren
|
||||
|
||||
MenuAvs: Schnittstelle AVS
|
||||
MenuApc: Druckerei
|
||||
|
||||
@ -132,6 +132,7 @@ MenuLmsUserlist: Upload E-Learning Users
|
||||
MenuLmsResult: Upload E-Learning Results
|
||||
MenuLmsUpload: Upload
|
||||
MenuLmsDirect: Direct Upload
|
||||
MenuLmsFake: Generate test users
|
||||
|
||||
MenuAvs: AVS Interface
|
||||
MenuApc: Printing
|
||||
|
||||
3
routes
3
routes
@ -265,7 +265,7 @@
|
||||
-- for users
|
||||
/qualification QualificationAllR GET !free
|
||||
/qualification/#SchoolId QualificationSchoolR GET !free -- TODO
|
||||
/qualification/#SchoolId/#QualificationShorthand QualificationR GET !free -- must be logged in though
|
||||
/qualification/#SchoolId/#QualificationShorthand QualificationR GET -- TODO make !free again after repurpose
|
||||
-- OSIS CSV Export Demo
|
||||
/lms LmsAllR GET POST
|
||||
/lms/#SchoolId LmsSchoolR GET
|
||||
@ -279,6 +279,7 @@
|
||||
/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST
|
||||
/lms/#SchoolId/#QualificationShorthand/fake LmsFakeR GET POST -- TODO: delete this testing URL
|
||||
|
||||
/api ApiDocsR GET !free
|
||||
/swagger SwaggerR GET !free
|
||||
|
||||
@ -162,7 +162,7 @@ breadcrumb (LmsUserlistDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Jus
|
||||
breadcrumb (LmsResultR ssh qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR ssh qsh
|
||||
breadcrumb (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh
|
||||
breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed
|
||||
|
||||
breadcrumb (LmsFakeR ssh qsh) = i18nCrumb MsgMenuLmsFake $ Just $ LmsR ssh qsh -- TODO: remove in production
|
||||
|
||||
breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing
|
||||
breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail $ Just ProfileR
|
||||
@ -2484,6 +2484,9 @@ pageActions (LmsR sid qsh) = return
|
||||
, NavPageActionSecondary {
|
||||
navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh
|
||||
}
|
||||
, NavPageActionSecondary {
|
||||
navLink = defNavLink MsgMenuLmsFake $ LmsFakeR sid qsh
|
||||
}
|
||||
]
|
||||
pageActions ApiDocsR = return
|
||||
[ NavPageActionPrimary
|
||||
|
||||
@ -12,6 +12,7 @@ module Handler.LMS
|
||||
, getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR
|
||||
, getLmsResultR , postLmsResultR
|
||||
, getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR
|
||||
, getLmsFakeR , postLmsFakeR
|
||||
)
|
||||
where
|
||||
|
||||
@ -37,6 +38,7 @@ import Database.Esqueleto.Utils.TH
|
||||
import Handler.LMS.Users as Handler.LMS
|
||||
import Handler.LMS.Userlist as Handler.LMS
|
||||
import Handler.LMS.Result as Handler.LMS
|
||||
import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production!
|
||||
|
||||
-- avoids repetition of local definitions
|
||||
single :: (k,a) -> Map k a
|
||||
|
||||
@ -1,9 +1,13 @@
|
||||
module Handler.Utils.FakeUsers
|
||||
( fakeQualificationUsers
|
||||
module Handler.LMS.Fake
|
||||
( getLmsFakeR, postLmsFakeR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import System.Random (randomRIO)
|
||||
|
||||
import Data.List (cycle)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as TEnc
|
||||
@ -11,32 +15,55 @@ import qualified Yesod.Auth.Util.PasswordStore as PWStore
|
||||
import Control.Applicative (ZipList(..), getZipList)
|
||||
|
||||
|
||||
import Handler.Utils.DateTime
|
||||
|
||||
getLmsFakeR, postLmsFakeR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||
getLmsFakeR = postLmsFakeR
|
||||
postLmsFakeR sid qsh = do
|
||||
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
|
||||
let msgStatus = if | uNew == 0 -> Error
|
||||
| uNew == uTotal -> Success
|
||||
| otherwise -> Warning
|
||||
addMessage msgStatus $ toHtml $ tshow uNew <> " von " <> tshow uTotal <> " neue Testnutzer mit ablaufender Qualifikation " <> qName <> " generiert"
|
||||
redirect $ LmsR sid qsh
|
||||
siteLayout "Testnutzer generieren" $ do
|
||||
setTitle $ toHtml $ "Testnutzer generieren " <> qName
|
||||
toWidget [whamlet|
|
||||
Hier können neu zufällige Testbenutzer mit ablaufenden Qualifikationen generiert werden.
|
||||
|
||||
^{fakeForm}
|
||||
|]
|
||||
|
||||
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)
|
||||
|
||||
|
||||
-- | indefinitely repeat a list, from Prelude
|
||||
cycle :: [a] -> [a]
|
||||
cycle [] = []
|
||||
cycle xs = xs' where xs' = xs ++ xs'
|
||||
|
||||
|
||||
fakeQualificationUsers :: QualificationId -> Int -> (Day,Day) -> DB Int
|
||||
fakeQualificationUsers qid usersPerDay (dfrom, dto) = do
|
||||
fakeQualificationUsers :: QualificationId -> (Int, Day, Day) -> DB (Int,Int)
|
||||
fakeQualificationUsers qid (usersPerDay, dfrom, dto) = do
|
||||
now <- liftIO getCurrentTime
|
||||
dropNames <- liftIO $ randomRIO (0,length givenNames * length surnames)
|
||||
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
||||
pwSimple <- do
|
||||
let pw = "123.456"
|
||||
PWHashConf{..} <- getsYesod $ view _appAuthPWHash
|
||||
pwHash <- liftIO $ PWStore.makePasswordWith pwHashAlgorithm pw pwHashStrength
|
||||
return $ AuthPWHash $ TEnc.decodeUtf8 pwHash
|
||||
let expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dfrom dto)]
|
||||
|
||||
let expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dto 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 ++ [userSurname]) <> "@example.com"
|
||||
userDisplayName = Text.unwords $ firstNames <> [userSurname]
|
||||
userEmail = CI.mk "s.jost@fraport.de" -- test that email is truly recieved
|
||||
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"
|
||||
userEmail = userIdent
|
||||
userDisplayEmail = userIdent
|
||||
userDisplayName = Text.unwords $ firstNames <> [userSurname]
|
||||
userMatrikelnummer = Just "TESTUSER"
|
||||
userAuthentication = pwSimple
|
||||
userLastAuthentication = Nothing
|
||||
@ -45,7 +72,7 @@ fakeQualificationUsers qid usersPerDay (dfrom, dto) = do
|
||||
userLdapPrimaryKey = Nothing
|
||||
userTokensIssuedAfter = Nothing
|
||||
userFirstName = Text.unwords firstNames
|
||||
userTitle = Nothing
|
||||
userTitle = Nothing
|
||||
userMaxFavourites = userDefaultMaxFavourites
|
||||
userMaxFavouriteTerms = userDefaultMaxFavourites
|
||||
userTheme = userDefaultTheme
|
||||
@ -57,28 +84,26 @@ fakeQualificationUsers qid usersPerDay (dfrom, dto) = do
|
||||
userCsvOptions = def
|
||||
userSex = Nothing
|
||||
userShowSex = userDefaultShowSex
|
||||
userTelephone = Nothing
|
||||
userMobile = Nothing
|
||||
userCompanyPersonalNumber = Nothing
|
||||
userTelephone = Nothing
|
||||
userMobile = Nothing
|
||||
userCompanyPersonalNumber = Nothing
|
||||
userCompanyDepartment = Nothing
|
||||
userPostAddress = postalAddress
|
||||
in User{..}
|
||||
|
||||
valid <- forM (zip expiryOffsets names) $ \(expOffset, user) -> do
|
||||
muid <- insertUnique $ fakeUser user
|
||||
case muid of
|
||||
Nothing -> return 0
|
||||
(Just uid) -> do
|
||||
let qualificationUserUser = uid
|
||||
qualificationUserQualification = qid
|
||||
qualificationUserValidUntil = addDays expOffset dfrom
|
||||
qualificationUserFirstHeld = setYear (getYear qualificationUserValidUntil - 2) qualificationUserValidUntil
|
||||
qualificationUserLastRefresh = qualificationUserFirstHeld
|
||||
ok <- insertUnique QualificationUser{..}
|
||||
return $ maybe 0 (const 1) ok
|
||||
return $ sum valid
|
||||
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
|
||||
ok <- insertUnique QualificationUser{..}
|
||||
return $ maybe 0 (const 1) ok
|
||||
return (sum valid, length expiryOffsets)
|
||||
|
||||
where
|
||||
where
|
||||
postalAddress = Just $ plaintextToStoredMarkup $ Text.unlines ["Kapazitätsmanagement Airside (AVN-AR2) - FDTest", "Flughafen Frankfurt Main", "60547 Frankfurt am Main"]
|
||||
givenNames = [ "James", "John", "Robert", "Michael"
|
||||
, "William", "David", "Mary", "Richard"
|
||||
@ -99,17 +124,17 @@ fakeQualificationUsers qid usersPerDay (dfrom, dto) = do
|
||||
, "Clark", "Lewis", "Robinson", "Walker"
|
||||
, "Perez", "Hall", "Young", "Allen"
|
||||
]
|
||||
someLangs = [ (Just $ Languages ["de-de"] , DateTimeFormat "%a %d %b %Y %T", DateTimeFormat "%a %d.%m.%Y", DateTimeFormat "%T")
|
||||
, (Nothing , DateTimeFormat "%d.%m.%y %R" , DateTimeFormat "%d.%m.%y" , DateTimeFormat "%R")
|
||||
, (Just $ Languages ["en-eu","de"], DateTimeFormat "%a %d %b %Y %T", DateTimeFormat "%b %d %y" , DateTimeFormat "%I:%M %p")
|
||||
, (Just $ Languages ["fr"] , DateTimeFormat "%d-%m-%Y %R" , DateTimeFormat "%d-%m-%Y" , DateTimeFormat "%R")
|
||||
, (Just $ Languages ["fr","en"] , DateTimeFormat "%B %d %Y %R" , DateTimeFormat "%B %d %y" , DateTimeFormat "%I:%M:%S %p")
|
||||
]
|
||||
someLangs = [ (Just $ Languages ["de-de"] , DateTimeFormat "%a %d %b %Y %T", DateTimeFormat "%a %d.%m.%Y", DateTimeFormat "%T")
|
||||
, (Nothing , DateTimeFormat "%d.%m.%y %R" , DateTimeFormat "%d.%m.%y" , DateTimeFormat "%R")
|
||||
, (Just $ Languages ["en-eu","de"], DateTimeFormat "%a %d %b %Y %T", DateTimeFormat "%b %d %y" , DateTimeFormat "%I:%M %p")
|
||||
, (Just $ Languages ["fr"] , DateTimeFormat "%d-%m-%Y %R" , DateTimeFormat "%d-%m-%Y" , DateTimeFormat "%R")
|
||||
, (Just $ Languages ["fr","en"] , DateTimeFormat "%B %d %Y %R" , DateTimeFormat "%B %d %y" , DateTimeFormat "%I:%M:%S %p")
|
||||
]
|
||||
postal = [False, True, False]
|
||||
|
||||
names = getZipList $ (\f m s l p -> (f : concat m, s, l, p))
|
||||
<$> ZipList (cycle givenNames)
|
||||
<*> ZipList (cycle middlenames)
|
||||
names = getZipList $ (\f m s l p -> (f : concat m, s, l, p))
|
||||
<$> ZipList (cycle givenNames)
|
||||
<*> ZipList (cycle middlenames)
|
||||
<*> ZipList (cycle surnames)
|
||||
<*> ZipList (cycle someLangs)
|
||||
<*> ZipList (cycle postal)
|
||||
@ -363,7 +363,7 @@ instance Arbitrary SemVer.Version where
|
||||
<*> fmap getNonNegative arbitrary
|
||||
<*> fmap getNonNegative arbitrary
|
||||
<*> arbitrary
|
||||
<*> mempty -- Ord SemVer.Version ignores Metadata, so the Ord properties don't hold
|
||||
<*> pure mempty -- Ord SemVer.Version ignores Metadata, so the Ord properties don't hold
|
||||
|
||||
instance Arbitrary SemVer.Identifier where
|
||||
arbitrary = -- oneof
|
||||
|
||||
Loading…
Reference in New Issue
Block a user