lms: add interface for create fake users and verify it is working

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

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

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

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

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

src/Handler/LMS/Fake.hs

@@ -1,9 +1,13 @@
-module Handler.Utils.FakeUsers
+module Handler.LMS.Fake
-  ( fakeQualificationUsers
+  ( 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
+fakeQualificationUsers :: QualificationId -> (Int, Day, Day) -> DB (Int,Int)
-cycle :: [a] -> [a]
+fakeQualificationUsers qid (usersPerDay, dfrom, dto) = do
-cycle [] = []
-cycle xs = xs' where xs' = xs ++ xs'
-
-
-fakeQualificationUsers :: QualificationId -> Int -> (Day,Day) -> DB 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) = 
+        fakeUser (firstNames, userSurname, (userLanguages, userDateTimeFormat, userDateFormat, userTimeFormat), userPrefersPostal) =
-          let userIdent = CI.mk $ Text.intercalate "." (take 1 firstNames ++ [userSurname]) <> "@example.com"        
+          let userIdent = CI.mk $ Text.intercalate "." (take 1 firstNames ++ (Text.take 1 <$> drop 1 firstNames) ++ [userSurname]) <> "@example.com"
-              userDisplayName = Text.unwords $ firstNames <> [userSurname]
+              userEmail = userIdent
-              userEmail = CI.mk "s.jost@fraport.de" -- test that email is truly recieved 
               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 
+              userTelephone = Nothing
-              userMobile = Nothing 
+              userMobile = Nothing
-              userCompanyPersonalNumber = Nothing 
+              userCompanyPersonalNumber = Nothing
               userCompanyDepartment = Nothing
               userPostAddress = postalAddress
           in User{..}
 
-    valid <- forM (zip expiryOffsets names) $ \(expOffset, user) -> do 
+    valid <- forM (zip expiryOffsets $ drop dropNames names) $ \(expOffset, user) -> do
-      muid <- insertUnique $ fakeUser user
+      euid <- insertBy $ fakeUser user
-      case muid of
+      let uid = either entityKey id euid
-        Nothing    -> return 0 
+          qualificationUserUser = uid
-        (Just uid) -> do
+          qualificationUserQualification = qid
-          let qualificationUserUser = uid
+          qualificationUserValidUntil    = addDays expOffset dfrom
-              qualificationUserQualification = qid 
+          qualificationUserFirstHeld     = addGregorianMonthsClip (-24) qualificationUserValidUntil
-              qualificationUserValidUntil    = addDays expOffset dfrom
+          qualificationUserLastRefresh   = qualificationUserFirstHeld
-              qualificationUserFirstHeld     = setYear (getYear qualificationUserValidUntil - 2) qualificationUserValidUntil
+      ok <- insertUnique QualificationUser{..}
-              qualificationUserLastRefresh   = qualificationUserFirstHeld
+      return $ maybe 0 (const 1) ok
-          ok <- insertUnique QualificationUser{..}
+    return (sum valid, length expiryOffsets)
-          return $ maybe 0 (const 1) ok
-    return $ sum valid
 
-  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") 
+    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") 
+                 , (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 ["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"]        , 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") 
+                 , (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)) 
+    names = getZipList $ (\f m s l p -> (f : concat m, s, l, p))
-              <$> ZipList (cycle givenNames) 
+              <$> ZipList (cycle givenNames)
-              <*> ZipList (cycle middlenames) 
+              <*> ZipList (cycle middlenames)
               <*> ZipList (cycle surnames)
               <*> ZipList (cycle someLangs)
               <*> ZipList (cycle postal)

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