fraport/fradrive-old
Archived
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.DateTime
import Handler.Utils.Csv import Handler.Utils.Csv
import Data.Csv (HasHeader(..), FromRecord) import Data.Csv (HasHeader(..), FromRecord)
import qualified Data.Text as Text
import qualified Data.Set as Set (notMember) import qualified Data.Set as Set (notMember)
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
@ -211,14 +212,15 @@ randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range
-- where -- where
-- eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True } -- eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True }
randomLMSIdent :: MonadIO m => m LmsIdent randomLMSIdent :: MonadIO m => Maybe Char -> m LmsIdent
randomLMSIdent = LmsIdent <$> randomText [] lengthIdent -- idents must not contain '_' nor '-' 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 :: MonadIO m => Maybe Char -> Set LmsIdent -> m (Maybe LmsIdent)
randomLMSIdentBut banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk randomLMSIdentBut prefix banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk
where where
getIdentOk = do getIdentOk = do
l <- randomLMSIdent l <- randomLMSIdent prefix
return $ toMaybe (Set.notMember l banList) l 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 ',' '.' ':' '_' 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 Handler.Utils.Qualification
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.Text as Text
dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX
dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue
@ -125,6 +125,9 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
where where
act :: YesodJobDB UniWorX () act :: YesodJobDB UniWorX ()
act = do 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 identsInUseVs <- E.select $ do
lui <- E.from $ lui <- E.from $
@ -158,9 +161,9 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
-- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser)) -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
startLmsUser = do startLmsUser = do
lpw <- randomLMSpw lpw <- randomLMSpw
maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut identsInUse) maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse)
-- runMaybeT $ do -- runMaybeT $ do
-- lid <- MaybeT $ randomLMSIdentBut identsInUse -- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse
-- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid -- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid
inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
case inserted of case inserted of