lms: add fake user generation
This commit is contained in:
Steffen Jost
parent
3e9b62a322
commit
e9485fe22d
@ -449,7 +449,7 @@ postLmsR sid qsh = do
|
||||
where
|
||||
-- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
|
||||
i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
|
||||
psValidator = def
|
||||
psValidator = def -- TODO: hier einen Filter für Schützlinge einbauen
|
||||
tbl <- mkLmsTable qent acts (const E.true) colChoices psValidator
|
||||
return (tbl, qent)
|
||||
|
||||
|
||||
115
src/Handler/Utils/FakeUsers.hs
Normal file
115
src/Handler/Utils/FakeUsers.hs
Normal file
@ -0,0 +1,115 @@
|
||||
module Handler.Utils.FakeUsers
|
||||
( fakeQualificationUsers
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as TEnc
|
||||
import qualified Yesod.Auth.Util.PasswordStore as PWStore
|
||||
import Control.Applicative (ZipList(..), getZipList)
|
||||
|
||||
|
||||
import Handler.Utils.DateTime
|
||||
|
||||
|
||||
-- | 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
|
||||
now <- liftIO getCurrentTime
|
||||
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)]
|
||||
|
||||
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
|
||||
userDisplayEmail = userIdent
|
||||
userMatrikelnummer = Just "TESTUSER"
|
||||
userAuthentication = pwSimple
|
||||
userLastAuthentication = Nothing
|
||||
userCreated = now
|
||||
userLastLdapSynchronisation = Nothing
|
||||
userLdapPrimaryKey = Nothing
|
||||
userTokensIssuedAfter = Nothing
|
||||
userFirstName = Text.unwords firstNames
|
||||
userTitle = Nothing
|
||||
userMaxFavourites = userDefaultMaxFavourites
|
||||
userMaxFavouriteTerms = userDefaultMaxFavourites
|
||||
userTheme = userDefaultTheme
|
||||
userDownloadFiles = userDefaultDownloadFiles
|
||||
userWarningDays = userDefaultWarningDays
|
||||
userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
|
||||
userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
|
||||
userNotificationSettings = def
|
||||
userCsvOptions = def
|
||||
userSex = Nothing
|
||||
userShowSex = userDefaultShowSex
|
||||
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
|
||||
|
||||
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"
|
||||
, "Joseph", "Thomas", "Charles", "Daniel"
|
||||
, "Matthew", "Patricia", "Jennifer", "Linda"
|
||||
, "Elizabeth", "Barbara", "Anthony", "Donald"
|
||||
, "Mark", "Paul", "Steven", "Andrew"
|
||||
, "Kenneth", "Joshua", "George", "Kevin"
|
||||
, "Brian", "Edward", "Susan", "Ronald"
|
||||
]
|
||||
middlenames = [ Nothing, Nothing, Just ["Tiberius"], Nothing, Just ["Jamesson", "Maria"], Nothing, Just ["Jörg"] ]
|
||||
surnames = [ "Müller", "Smith", "Johnson", "Williams", "Brown"
|
||||
, "Jones", "Miller", "Davis", "Garcia"
|
||||
, "Rodriguez", "Wilson", "Martinez", "Anderson"
|
||||
, "Taylor", "Thomas", "Hernandez", "Moore"
|
||||
, "Martin", "Jackson", "Thompson", "White"
|
||||
, "Lopez", "Lee", "Gonzalez", "Harris"
|
||||
, "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")
|
||||
]
|
||||
postal = [False, True, False]
|
||||
|
||||
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)
|
||||
@ -250,15 +250,15 @@ hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity &&
|
||||
|
||||
pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard
|
||||
pickLicenceAddress a b
|
||||
| Just r <- pickBetter' hasAddress = r -- prefer card with complete address
|
||||
| Just r <- pickBetter' avsDataValid = r -- prefer valid cards
|
||||
| Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards
|
||||
| Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards
|
||||
| Just r <- pickBetter' hasAddress = r -- prefer card with complete address
|
||||
| Just r <- pickBetter' avsDataValid = r -- prefer valid cards
|
||||
| Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards
|
||||
| Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards
|
||||
| avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date
|
||||
| avsDataIssueDate a < avsDataIssueDate b = b
|
||||
| avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date
|
||||
| avsDataValidTo a < avsDataValidTo b = b
|
||||
| Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm
|
||||
| Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm
|
||||
| a <= b = b -- respect natural Ord instance
|
||||
| otherwise = a
|
||||
where
|
||||
@ -266,16 +266,12 @@ pickLicenceAddress a b
|
||||
pickBetter' = pickBetter a b
|
||||
|
||||
{- Note:
|
||||
|
||||
Since Ordering is a Semigroup that ignores the righthand side except for EQ, this can be conveniently be used like so
|
||||
|
||||
For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this can be conveniently be used like so
|
||||
bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering
|
||||
compare a b =
|
||||
compareBy avsDataValid
|
||||
<> compareBy avsDataValidTo
|
||||
<> compareBy avsDataIssueDate
|
||||
|
||||
compare a b = compareBy avsDataValid
|
||||
<> compareBy avsDataValidTo
|
||||
<> compareBy avsDataIssueDate
|
||||
...
|
||||
where
|
||||
compareBy f = compare `on` f a b
|
||||
|
||||
-}
|
||||
@ -6,7 +6,7 @@ en-subject: Renewal of apron driving License
|
||||
author: Fraport AG - Fahrerausbildung (AVN-AR)
|
||||
phone: +49 69 690-30306
|
||||
email: fahrerausbildung@fraport.de
|
||||
url: <http://www.fraport.de/fahrerausbildung>
|
||||
url: <http://drive.fraport.de>
|
||||
place: Frankfurt/Main
|
||||
return-address:
|
||||
- 60547 Frankfurt
|
||||
|
||||
Loading…
Reference in New Issue
Block a user