fradrive/src/Jobs/Handler/LMS.hs

{-# LANGUAGE TypeApplications #-}

module Jobs.Handler.LMS 
  ( dispatchJobLmsEnqueue
  , dispatchJobLmsDequeue
  , dispatchJobLmsResults
  , dispatchJobLmsUserlist
  ) where 

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 -- for insertSelect variant
import qualified Database.Esqueleto.Utils as E

-- import Handler.Utils.DateTime (addDiffDays)

dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX
dispatchJobLmsEnqueue _qid = JobHandlerAtomic act
  where 
    -- act :: YesodJobDB UniWorX ()
    act = hoist lift $ do      
      {-
      now <- liftIO getCurrentTime
      mbq <- E.selectOne $ E.from $ \quali -> E.where_ (quali E.^. QualificationId E.==. E.val qid) >> pure quali      
      -- Just quali <- get qid 
      
      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
      
      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       -- THIS IS A PROBLEM!
            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"

dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX
dispatchJobLmsDequeue _qid = 
  -- wenn bestanden: qualification verlängern & LmsIdent löschen
  -- wenn durchgefallen: LmsIdent löschen
  -- wenn Zeit abgelaufen: LmsIdent löschen 
  error "lms dequeu stub"

dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX
dispatchJobLmsResults qid = JobHandlerAtomic act 
  where
    -- act :: YesodJobDB UniWorX ()
    act = hoist lift $ do
      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 
          (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
          return $ LmsUser E.<# E.val qid
                          E.<&> (luser   E.^. LmsUserUser)
                          E.<&> (luser   E.^. LmsUserIdent)
                          E.<&> (luser   E.^. LmsUserPin)
                          E.<&> (luser   E.^. LmsUserResetPin)
                          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 ->
          [ LmsUserStatus E.=. current E.^. LmsUserStatus, LmsUserReceived E.=. current E.^. LmsUserReceived ] -- I believe this list could just be empty, since excluded is not uses?!
        )
      -- Unclear how to delete here
      -}
      -- 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_ $ luser E.^. LmsUserQualification 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 lreceived = lmsResultTimestamp lresult 
            lstatus   = lmsResultSuccess   lresult & LmsSuccess
        -- always log success, since this is only transmitted once
        update luid [ LmsUserStatus   =. 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 act 
  where
    -- act :: YesodJobDB UniWorX ()
    act = hoist lift $ do
      now <- liftIO getCurrentTime
      -- result :: [(Entity LmsUser, Entity LmsUserlist)]
      results <- E.select $ do 
        (luser E.:& lulist) <- E.from $ 
            E.table @LmsUser `E.leftJoin` E.table @LmsUserlist
            `E.on` (\(luser E.:& lulist) ->  luser E.^. LmsUserIdent         E.=?. lulist E.?. LmsUserlistIdent 
                                       E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification)
        E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
                  E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
        return (luser, lulist)
      forM_ results $ \case 
        (Entity luid luser, Nothing) 
          | isJust    $ lmsUserReceived luser
          , isNothing $ lmsUserEnded    luser ->            
              update luid [LmsUserEnded =. Just now]
          | otherwise -> return () -- likely not yet started

        (Entity luid luser, Just (Entity lulid lulist)) -> do           
          let usrNoStat = isNothing $ lmsUserStatus luser
              lBlocked  = lmsUserlistFailed    lulist              
              updStatus = lBlocked && usrNoStat -- only update empty status to blocked
              lReceived = lmsUserlistTimestamp lulist
              lStatus   = LmsBlocked $ utctDay lReceived
          update luid $ [ LmsUserStatus   =. Just lStatus   | updStatus ]
                     <> [ LmsUserReceived =. Just lReceived ]
          when lBlocked . insert_ $ LmsAudit qid (lmsUserIdent luser) lStatus lReceived now -- always log blocked
          delete lulid

      $logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]