chore(lms): dispatch single fresh lms user implemented
This commit is contained in:
Steffen Jost
parent
19f77dad02
commit
49ccb35035
@ -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
|
||||
|
||||
|
||||
@ -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 =
|
||||
|
||||
27
src/Utils.hs
27
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 --
|
||||
------------
|
||||
|
||||
Loading…
Reference in New Issue
Block a user