From 49ccb35035a24b047c5139cf953c06eafa83bbc1 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 6 Apr 2022 17:35:47 +0200 Subject: [PATCH] chore(lms): dispatch single fresh lms user implemented --- src/Handler/Utils/LMS.hs | 13 +++++++- src/Jobs/Handler/LMS.hs | 69 +++++++++++++++------------------------- src/Utils.hs | 27 ++++++++++++++++ 3 files changed, 64 insertions(+), 45 deletions(-) diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 425ae2a5b..f56eeaaca 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -14,7 +14,7 @@ module Handler.Utils.LMS , csvFilenameLmsResult , lmsUserToDelete, _lmsUserToDelete , lmsUserToDeleteExpr - , randomLMSIdent, randomLMSpw + , randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries ) where -- general utils for LMS Interface Handlers @@ -97,12 +97,23 @@ lengthIdent = 8 lengthPassword :: Int lengthPassword = 8 +-- | Maximal number of times, randomLMSIdent should be called in a row to find an unused LmsIdent +maxLmsUserIdentRetries :: Int +maxLmsUserIdentRetries = 27 + randomText :: MonadIO m => Int -> m Text randomText n | n <= 8 = T.take n . UUID.toText <$> liftIO UUID.nextRandom | n <= 32 = T.take n . T.filter ('-' ==) . UUID.toText <$> liftIO UUID.nextRandom | otherwise = (<>) <$> randomText 32 <*> randomText (n - 32) +--TODO: consider using package elocrypt for user-friendly passwords here, licence requires mentioning of author, etc. though +-- import qualified Data.Elocrypt as Elo +-- randomLMSIdent :: MonadRandom m => m LmsIdent +-- randomLMSIdent = LmsIdent . T.pack <$> Elo.mkPassword lengthIdent eopt +-- where +-- eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True } + randomLMSIdent :: MonadIO m => m LmsIdent randomLMSIdent = LmsIdent <$> randomText lengthIdent diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index c2cb820a6..5b468288e 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -17,6 +17,8 @@ import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E -- import Handler.Utils.DateTime (addDiffDays) +import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries) + dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX dispatchJobLmsEnqueue qid = JobHandlerAtomic act @@ -43,51 +45,30 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act forM_ renewalUsers (\uid -> queueDBJob JobLmsEnqueueUser { jQualification = qid, jUser = E.unValue uid } ) -{- - hoist lift $ do - - let (Entity _ quali) = fromMaybe (error "TODO") mbq -- HACK / TODO - refreshTime = fromMaybe (error "TODO") $ qualificationRefreshWithin quali -- HACK / TODO - freshIdent = LmsIdent "abcd" -- TODO - freshPin = "1234" -- TODO - cutoff = addDiffDays refreshTime now - - {- - whileM .. $ do - ident <- ... -- use System.Random for now for ident gen - MaybeT . E.insert $ ... - -} - - E.insertSelect ( do - quser <- E.from (E.table @QualificationUser) - E.where_ ( quser E.^. QualificationUserQualification E.==. E.val qid - E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now - E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val cutoff - -- and not exists already as LMS User - ) - - return $ LmsUser - E.<# E.val qid - E.<&> (quser E.^. QualificationUserUser) - E.<&> E.val freshIdent -- ident -- THIS IS A PROBLEM! MUST ALSO BE UNIQUE! - E.<&> E.val freshPin -- pin -- can be done: E.unsafeSqlFunction "substring(gen_random_uuid()::text from 1 for 8)" - E.<&> E.false -- reset - E.<&> E.nothing -- status - E.<&> E.val now -- started - E.<&> E.nothing -- received - E.<&> E.nothing -- ended - ) - - -- find qualification holders - - - error "lms dequeu stub" - -} - dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX -dispatchJobLmsEnqueueUser _qid _uid = - -- lident <- randomLMSIdent - -- lpw <- randomLMSpw - error "lms enqueue user stub" +dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act + where + act :: YesodJobDB UniWorX () + act = do + now <- liftIO getCurrentTime + let mkLmsUser lid lpin = LmsUser + { lmsUserQualification = qid + , lmsUserUser = uid + , lmsUserIdent = lid + , lmsUserPin = lpin + , lmsUserResetPin = False + , lmsUserStatus = Nothing + , lmsUserStarted = now + , lmsUserReceived = Nothing + , lmsUserEnded = Nothing + } + -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser)) + startLmsUser = insertUniqueEntity =<< (mkLmsUser <$> randomLMSIdent <*> randomLMSpw) + inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser + case inserted of + Nothing -> $logErrorS "lms" "Inserting fresh LmsIdent failed!" + (Just _) -> error "continue here by notifying user by email or mail" + dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX dispatchJobLmsDequeue _qid = diff --git a/src/Utils.hs b/src/Utils.hs index f3b026c15..db49a7af2 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -800,6 +800,33 @@ forMaybeM :: ( Monad m ) => f a -> (Element (f a) -> MaybeT m (Element (f b))) -> m (f b) forMaybeM = flip mapMaybeM +{- +-- Takes computations returnings @Maybes@; tries each one in order. +-- The first one to return a @Just@ wins. Returns @Nothing@ if all computations +-- return @Nothing@. +-- Copied from GHC.Data.Maybe, which could not be imported somehow. +firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a) +firstJustsM = foldlM go Nothing + where + go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a) + go Nothing action = action + go result@(Just _) _action = return result +-} + +-- | Run the maybe computation repeatedly until the first Just is returned +-- or the number of maximum retries is exhausted. +-- So like Control.Monad.Loops.untilJust, but with a maximum number of attempts. +untilJustMaxM :: Monad m => Int -> m (Maybe a) -> m (Maybe a) +untilJustMaxM nmax act = go 0 + where + go n | n >= nmax = return Nothing + | otherwise = do + x <- act + case x of + Nothing -> go $ succ n + res@(Just _) -> return res + + ------------ -- Either -- ------------