From 3eedff2b9f50079175fadb50af8b24808d74e36c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 1 Sep 2022 12:57:02 +0200 Subject: [PATCH] lms: add interface for create fake users and verify it is working --- .../utils/navigation/menu/de-de-formal.msg | 3 +- .../uniworx/utils/navigation/menu/en-eu.msg | 1 + routes | 3 +- src/Foundation/Navigation.hs | 5 +- src/Handler/LMS.hs | 2 + .../{Utils/FakeUsers.hs => LMS/Fake.hs} | 113 +++++++++++------- test/Model/TypesSpec.hs | 2 +- 7 files changed, 81 insertions(+), 48 deletions(-) rename src/Handler/{Utils/FakeUsers.hs => LMS/Fake.hs} (59%) diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 83fa124e1..1c8948184 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 1570ce735..b0e1779d1 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -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 diff --git a/routes b/routes index 4563b0a5f..bdc345e0c 100644 --- a/routes +++ b/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 diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index f63c1093f..419c3de01 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -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 diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index a96d005ee..fa563ba9a 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -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 diff --git a/src/Handler/Utils/FakeUsers.hs b/src/Handler/LMS/Fake.hs similarity index 59% rename from src/Handler/Utils/FakeUsers.hs rename to src/Handler/LMS/Fake.hs index b97527ec8..d6d8d13ed 100644 --- a/src/Handler/Utils/FakeUsers.hs +++ b/src/Handler/LMS/Fake.hs @@ -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) diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index ed98ad9b5..53d8ab8dc 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -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