chore(lms): complete dispatchJobLmsResults with persistent now

models/lms.model

@@ -93,8 +93,7 @@ LmsUser
   ident             LmsIdent                    -- must be unique accross all LMS courses!
   pin               Text
   resetPin          Bool        default=false   -- should pin be reset?
-  success           Bool Maybe                  -- open, success or failure; isJust indicates user will be deleted from LMS 
+  success           LmsStatus Maybe                  -- open, success or failure; isJust indicates user will be deleted from LMS 
-  -- success           LmsStatus   -- this would also encode Day information?!
   --toDelete encoded by Handler.Utils.LMS.lmsUserToDelete
   started           UTCTime     default=now()
   received          UTCTime Maybe               -- last acknowledgement by LMS 
@@ -124,7 +123,7 @@ LmsResult
 LmsAudit 
   qualification     QualificationId
   ident             LmsIdent
-  notificationType  LmsStatus               -- LmsOpen | LmsBlocked | LmsSuccess Day   
+  notificationType  LmsStatus               -- LmsBlocked Day | LmsSuccess Day   
   received          UTCTime                 -- timestamp from LmsUserlist/LmsResult
   processed         UTCTime default=now()
   deriving Generic

src/Jobs/Handler/LMS.hs

@@ -10,8 +10,8 @@ import Import
 -- import Jobs.Handler.Intervals.Utils
 import qualified Database.Esqueleto.Experimental as E
 --import qualified Database.Esqueleto.Legacy as E
-import qualified Database.Esqueleto.PostgreSQL as E
+-- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant
-import qualified Database.Esqueleto.Utils as E
+-- import qualified Database.Esqueleto.Utils as E
 
 
 dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX
@@ -19,7 +19,8 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
   where
     -- act :: YesodJobDB UniWorX ()
     act = hoist lift $ do
-      _now <- liftIO getCurrentTime
+      now <- liftIO getCurrentTime
+      {- Unfortunately, we cannot use insertSelect due to Haskell-Type changes and deletion of keys
       E.insertSelectWithConflict 
         (UniqueLmsUser $ error "insertSelectWithConflict inspected constraint") -- never executed, just a type hint
         (do 
@@ -33,17 +34,35 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
                           E.<&> (luser   E.^. LmsUserIdent)
                           E.<&> (luser   E.^. LmsUserPin)
                           E.<&> (luser   E.^. LmsUserResetPin)
-                          E.<&> E.justVal True -- how to convert Day to LmsStatus here?
+                          E.<&> (E.val $ (LmsSuccess . E.unValue) <$> (lresult E.^. LmsResultSuccess)) -- how to convert Day to LmsStatus here?
                           E.<&> (luser   E.^. LmsUserStarted)
                           E.<&> E.just (lresult E.^. LmsResultTimestamp)
                           E.<&> (luser   E.^. LmsUserEnded)
         )
         (\current _excluded ->
-          [ LmsUserSuccess E.=. E.justVal True, LmsUserReceived E.=. current E.^. LmsUserReceived ] -- I believe this list could just be empty, since excluded is not uses?!
+          [ LmsUserSuccess E.=. current E.^. LmsUserSuccess, LmsUserReceived E.=. current E.^. LmsUserReceived ] -- I believe this list could just be empty, since excluded is not uses?!
         )
       -- Unclear how to delete here
-      return ()    
+      -}
-
+      -- result :: [(Entity LmsUser, Entity LmsResult)]
+      results <- E.select $ do 
+        (luser E.:& lresult) <- E.from $ 
+            E.table @LmsUser `E.innerJoin` E.table @LmsResult 
+            `E.on` (\(luser E.:& lresult) -> luser E.^. LmsUserIdent         E.==. lresult E.^. LmsResultIdent 
+                                       E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification)
+        E.where_ $ lresult E.^. LmsResultQualification E.==. E.val qid
+                  E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
+        return (luser, lresult)
+      forM_ results $ \(Entity luid luser, Entity lrid lresult) -> do 
+        -- three separate DB operations per result is not so nice. All within one transaction though.
+        let lstatus   = lmsResultSuccess   lresult & LmsSuccess 
+            lreceived = lmsResultTimestamp lresult 
+        update luid [ LmsUserSuccess  =. Just lstatus
+                    , LmsUserReceived =. Just lreceived 
+                    ]
+        insert_ $ LmsAudit qid (lmsUserIdent luser) lstatus lreceived now
+        delete lrid                   
+      $logInfoS "LmsResult" [st|Processed ${tshow (length results)} LMS results|]
 
 dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX
 dispatchJobLmsUserlist _qid = JobHandlerAtomic $ return ()

src/Model/Types/Lms.hs

@@ -27,8 +27,9 @@ deriveJSON defaultOptions
   , omitNothingFields = True  
   } ''LmsIdent 
 
--- TODO: is this a good idea? Maybe just an ordinary Enum and a separate Day Column in the DB would be better, especially since LmsBlocked should really also encode a Day
+-- TODO: Is this a good idea? An ordinary Enum and a separate Day column in the DB would be better, e.g. allowing use of insertSelect in Jobs.Handler.LMS?
-data LmsStatus = LmsOpen | LmsBlocked | LmsSuccess Day 
+data LmsStatus = LmsBlocked { lmsStatusDay :: Day } 
+               | LmsSuccess { lmsStatusDay :: Day }
   deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData)
 
 deriveJSON  defaultOptions

test/Database/Fill.hs

@@ -476,8 +476,8 @@ fillDb = do
   void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True  now 
   void . insert' $ LmsUserlist qid_f (LmsIdent "ijk"    ) False now 
   void . insert' $ LmsUser qid_f jost     (LmsIdent "ijk"    ) "123" False Nothing now Nothing Nothing
-  void . insert' $ LmsUser qid_f svaupel  (LmsIdent "abcdefg") "abc" False (Just True)  now (Just now) Nothing
+  void . insert' $ LmsUser qid_f svaupel  (LmsIdent "abcdefg") "abc" False (Just $ LmsSuccess $ utctDay now) now (Just now) Nothing
-  void . insert' $ LmsUser qid_f gkleen   (LmsIdent "hijklmn") "@#!" True  (Just False) now (Just now) Nothing
+  void . insert' $ LmsUser qid_f gkleen   (LmsIdent "hijklmn") "@#!" True  (Just $ LmsBlocked $ utctDay now) now (Just now) Nothing
   
   let
     sdBsc = StudyDegreeKey' 82