chore(lms): dispatch single fresh lms user implemented

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
 

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 = 
+dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act 
-  -- lident <- randomLMSIdent 
+  where 
-  -- lpw    <- randomLMSpw
+    act :: YesodJobDB UniWorX ()
-  error "lms enqueue user stub"
+    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 = 

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 --
 ------------