lms: add fake user generation

src/Handler/LMS.hs

@@ -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)
 

src/Handler/Utils/FakeUsers.hs

@@ -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)

src/Model/Types/Avs.hs

@@ -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' hasAddress                                      = r   -- prefer card with complete address
-    | Just r <- pickBetter' avsDataValid                                     = r   -- prefer valid cards
+    | Just r <- pickBetter' avsDataValid                                    = r   -- prefer valid cards
-    | Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas)  = r   -- prefer 'R' 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' (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:
-
+For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this can be conveniently be used like so
-Since Ordering is a Semigroup that ignores the righthand side except for EQ, this can be conveniently be used like so
-
 bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering
-  compare a b = 
+  compare a b =  compareBy avsDataValid  
-         compareBy avsDataValid  
+              <> compareBy avsDataValidTo
-      <> compareBy avsDataValidTo
+              <> compareBy avsDataIssueDate
-      <> compareBy avsDataIssueDate
+              ...
-      
     where 
       compareBy f = compare `on` f a b
-
 -} 

templates/letter/fraport_renewal.md

@@ -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