fradrive/src/Handler/LMS/Fake.hs

-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

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
import qualified Yesod.Auth.Util.PasswordStore as PWStore
import Control.Applicative (ZipList(..), getZipList)



getLmsFakeR,  postLmsFakeR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsFakeR = postLmsFakeR
postLmsFakeR sid qsh = do  
  qent <- runDB $ getBy404 $ SchoolQualificationShort sid qsh
  now <- liftIO getCurrentTime
  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 qent 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 zufällige Testbenutzer mit ablaufenden Qualifikationen generiert werden,
        welche dann im angegebenen Zeitraum fällig werden.      

        ^{fakeForm}

        <h2>Hinweise: 
        <ul>
          <li> Emails der generierten Teilnehmer enden auf <tt>@example.com</tt> 
               und die Matrikelnummer lautet <tt>TESTUSER</tt>.
          <li> Bereits vorhandene Teilnehmer mit gleicher Ident werden nicht neu generiert.
          <li> Vorhandene Qualifikationen solcher Teilnehmer werden einfach überschrieben.
      |]

mkFakeForm :: Day -> AForm Handler (Int, Day, Day)
mkFakeForm d = (,,)
  <$> areq intField (fsl "Fällige Teilnehmer pro Tag")           (Just 10)
  <*> areq dayField (fsl "Erster Tag an dem Teilnehmer fällig werden")  (Just             d)
  <*> areq dayField (fsl "Letzter Tag an dem Teilnehmer fällig werden") (Just $ addDays 7 d)


fakeQualificationUsers :: Entity Qualification -> (Int, Day, Day) -> DB (Int,Int)
fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (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
    theSupervisor <- selectKeysList [UserSurname ==. "Jost", UserFirstName ==. "Steffen"] [Asc UserCreated, LimitTo 1]
    let addSupervisor = case theSupervisor of 
          [s] -> \suid k -> case k of 
                    1 -> void $ insertBy $ UserSupervisor s suid True Nothing Nothing
                    2 -> do
                          void $ insertBy $ UserSupervisor s    suid True Nothing (Just "Test")
                          void $ insertBy $ UserSupervisor suid suid True Nothing Nothing
                    3 -> void $ insertBy $ UserSupervisor s suid True Nothing Nothing
                    _ -> return ()
          _   -> \_ _ -> return ()
        expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dto dfrom)]
        expiryNotifyDay = addGregorianDurationClip (fromMaybe calendarDay qualificationRefreshWithin) dfrom
        fakeUser :: ([Text], UserSurname, (Maybe Languages, DateTimeFormat, DateTimeFormat, DateTimeFormat), Bool, Int) -> User
        fakeUser (firstNames, userSurname, (userLanguages, userDateTimeFormat, userDateFormat, userTimeFormat), userPrefersPostal, _isSupervised) =
          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
              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
              userBirthday = Nothing
              userShowSex = userDefaultShowSex
              userTelephone = Nothing
              userMobile = Nothing
              userCompanyPersonalNumber = Nothing
              userCompanyDepartment = Nothing
              userPostAddress = postalAddress
              userPostLastUpdate = Nothing
              userPinPassword = Just "tomatenmarmelade"
          in User{..}

    $logWarnS "FAKEUSER" $ tshow expiryNotifyDay
    valid <- forM (zip expiryOffsets $ drop dropNames names) $ \(expOffset, user) -> do
      euid <- insertBy $ fakeUser user
      if  | (Left (Entity _ User{userMatrikelnummer})) <- euid
          , userMatrikelnummer /= Just "TESTUSER"
              -> return 0
          | otherwise -> do 
              let uid = either entityKey id euid
                  qualificationUserUser             = uid
                  qualificationUserQualification    = qid
                  qualificationUserValidUntil       = addDays expOffset expiryNotifyDay
                  qualificationUserFirstHeld        = addGregorianMonthsClip (-24) qualificationUserValidUntil
                  qualificationUserLastRefresh      = qualificationUserFirstHeld                  
                  qualificationUserScheduleRenewal  = True
                  qualificationUserLastNotified     = now
              _ <- upsert QualificationUser{..} 
                          [ QualificationUserValidUntil  =. qualificationUserValidUntil
                          , QualificationUserLastRefresh =. qualificationUserLastRefresh
                          ]
              addSupervisor uid (user ^. _5)
              return $ either (const 0) (const 1) euid
              -- ok <- insertUnique QualificationUser{..} -- We do not overwrite any existing qualifications, just to be on the save side:
              -- return $ maybe 0 (const 1) ok
    return (sum valid, length expiryOffsets)

  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]
    supervised = [0,1,2,3]

    names = getZipList $ (\f m s l p v -> (f : concat m, s, l, p, v))
              <$> ZipList (cycle givenNames)
              <*> ZipList (cycle middlenames)
              <*> ZipList (cycle surnames)
              <*> ZipList (cycle someLangs)
              <*> ZipList (cycle postal)
              <*> ZipList (cycle supervised)