fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(lms): prefix lms-ident with qualification shorthand

Browse Source
This commit is contained in:
Steffen Jost 2023-10-06 09:14:19 +00:00
parent c75d914dc3
commit f776aaaef5
2 changed files with 13 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
src/Handler/Utils/LMS.hs
View File

@ -39,6 +39,7 @@ import Import
import Handler.Utils.DateTime
import Handler.Utils.Csv
import Data.Csv (HasHeader(..), FromRecord)
import qualified Data.Text as Text
import qualified Data.Set as Set (notMember)
import qualified Database.Esqueleto.Legacy as E
@ -211,14 +212,15 @@ randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range
-- where
-- eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True }
randomLMSIdent :: MonadIO m => m LmsIdent
randomLMSIdent = LmsIdent <$> randomText [] lengthIdent -- idents must not contain '_' nor '-'
randomLMSIdent :: MonadIO m => Maybe Char -> m LmsIdent
randomLMSIdent Nothing = LmsIdent . Text.cons 'j' <$> randomText [] (pred lengthIdent) -- idents must not contain '_' nor '-'
randomLMSIdent (Just c) = LmsIdent . Text.cons c <$> randomText [] (pred lengthIdent)
randomLMSIdentBut :: MonadIO m => Set LmsIdent -> m (Maybe LmsIdent)
randomLMSIdentBut banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk
randomLMSIdentBut :: MonadIO m => Maybe Char -> Set LmsIdent -> m (Maybe LmsIdent)
randomLMSIdentBut prefix banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk
where
getIdentOk = do
l <- randomLMSIdent
l <- randomLMSIdent prefix
return $ toMaybe (Set.notMember l banList) l
randomLMSpw :: MonadIO m => m Text -- may contain all kinds of symbols, but our users had trouble with some, like ',' '.' ':' '_'

9
src/Jobs/Handler/LMS.hs
View File

@ -34,7 +34,7 @@ import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries
import Handler.Utils.Qualification
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as Text
dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX
dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue
@ -125,6 +125,9 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
where
act :: YesodJobDB UniWorX ()
act = do
quali <- getJust qid -- may throw an error, aborting the job
let qshort = CI.original $ qualificationShorthand quali
qprefix = fst <$> Text.uncons (Text.toLower qshort)
identsInUseVs <- E.select $ do
lui <- E.from $
@ -158,9 +161,9 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
-- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
startLmsUser = do
lpw <- randomLMSpw
maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut identsInUse)
maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse)
-- runMaybeT $ do
-- lid <- MaybeT $ randomLMSIdentBut identsInUse
-- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse
-- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid
inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
case inserted of