-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE TypeApplications #-}

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

import Import
import Jobs.Queue

-- import Jobs.Handler.Intervals.Utils
import           Database.Esqueleto.Experimental ((:&)(..))
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 qualified Data.Set as Set

import qualified Data.Time.Zones as TZ
import Handler.Utils.DateTime
import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries)
import Handler.Utils.Qualification

import qualified Data.CaseInsensitive as CI


dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX
dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue

dispatchJobLmsQualificationsDequeue :: JobHandler UniWorX
dispatchJobLmsQualificationsDequeue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsDequeue

-- execute given job for all qualifications that allow refreshs
fetchRefreshQualifications :: (QualificationId -> Job) -> YesodJobDB UniWorX ()
fetchRefreshQualifications qidJob = do
  qids <- E.select $ do
            q <- E.from $ E.table @Qualification
            E.where_ $  E.isJust (q E.^. QualificationRefreshWithin)
            pure $ q E.^. QualificationId
  forM_ qids $ \(E.unValue -> qid) ->
    queueDBJob $ qidJob qid


-- | enlist expiring qualification holders to e-learning
--   NOTE: getting rid of QualificationId parameter and using a DB-join fails, since addGregorianDurationClip cannot be performed within DB
dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX
dispatchJobLmsEnqueue qid = JobHandlerAtomic act
  where
    -- act :: YesodJobDB UniWorX ()
    act = do
      quali <- getJust qid -- may throw an error, aborting the job
      let qshort = CI.original $ qualificationShorthand quali
      $logInfoS "LMS" $ "Notifying about exipiring qualification " <> qshort
      now <- liftIO getCurrentTime
      case qualificationRefreshWithin quali of
        Nothing -> return () -- TODO: no renewal period, no reminders currenty 
        (Just renewalPeriod) -> do
          let nowaday     = utctDay now
              renewalDate = addGregorianDurationClip renewalPeriod nowaday
              sendReminders remindPeriod = do 
                let remindDate = addGregorianDurationClip remindPeriod nowaday                
                reminders <- E.select $ do -- TODO: refactor to remove some redundancies with later query 
                  (luser :& quser) <- E.from $ E.table @LmsUser `E.innerJoin` E.table @QualificationUser
                    `E.on` (\(luser :& quser) -> luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification
                                          E.&&.  luser E.^. LmsUserUser          E.==. quser E.^. QualificationUserUser
                            )
                  E.where_ $  quser E.^. QualificationUserQualification E.==. E.val qid
                        E.&&. quser E.^. QualificationUserScheduleRenewal
                        E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val remindDate
                        E.&&. validQualification now quser
                        E.&&. E.isNothing (luser E.^. LmsUserEnded)
                        E.&&. E.isNothing (luser E.^. LmsUserStatus)
                        E.&&. E.isJust    (luser E.^. LmsUserNotified)
                        -- E.&&. ((day_ (luser E.^. LmsUserNotified) E.+. E.interval remindPeriod) E.<. quser E.^. QualificationUserValidUntil) -- not sure whether may throw runtime errors, so we check in Haskell-Land instead
                  return (luser, quser E.^. QualificationUserValidUntil)
                forM_ reminders $ \case
                  (Entity _ LmsUser{lmsUserUser=luser, lmsUserNotified=Just lnotified}, E.Value quValidUntil)
                    | addGregorianDurationClip remindPeriod (utctDay lnotified) < quValidUntil ->
                        queueDBJob JobUserNotification
                          { jRecipient    = luser
                          , jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = True }
                          }
                  _ -> return ()
          -- send second reminders first, before enqueing even more
          ifMaybeM (qualificationRefreshReminder quali) () sendReminders

          renewalUsers <- E.select $ do
            quser <- E.from $ E.table @QualificationUser
            E.where_ $  quser E.^. QualificationUserQualification E.==. E.val qid
                  E.&&. quser E.^. QualificationUserScheduleRenewal                  
                  E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
                  E.&&. (quser `qualificationValid` now)
                  E.&&. E.notExists (do
                          luser <- E.from $ E.table @LmsUser
                          E.where_ $  luser E.^. LmsUserQualification E.==. E.val qid
                                E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
                                E.&&. E.isNothing (luser E.^. LmsUserEnded)
                        )
            pure quser
          let usr_job :: Entity QualificationUser -> Job
              usr_job quser =
                let uid = quser ^. _entityVal . _qualificationUserUser
                    uex = quser ^. _entityVal . _qualificationUserValidUntil
                in if qualificationElearningStart quali
                    then JobLmsEnqueueUser { jQualification = qid, jUser = uid  }
                    else JobUserNotification { jRecipient = uid, jNotification =
                              NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
                         }
          forM_ renewalUsers (queueDBJob . usr_job)

dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX
dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
  where
    act :: YesodJobDB UniWorX ()
    act = do
      identsInUseVs <- E.select $ do
        lui <- E.from $
          ( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) ) -- no filter by Qid, since LmsIdents must be unique across all 
          `E.union_`
          ( (E.^. LmsResultIdent)   <$> E.from (E.table @LmsResult  ) )
          `E.union_`
          ( (E.^. LmsUserIdent)     <$> E.from (E.table @LmsUser    ) )
        E.orderBy [E.asc lui]
        pure lui
      now <- liftIO getCurrentTime
      let identsInUse = Set.fromList (E.unValue <$> identsInUseVs)
          mkLmsUser lpin lid = LmsUser
            { lmsUserQualification = qid
            , lmsUserUser          = uid
            , lmsUserIdent         = lid
            , lmsUserPin           = lpin
            , lmsUserResetPin      = False
            , lmsUserDatePin       = now
            , lmsUserStatus        = Nothing
            , lmsUserStatusDay     = Nothing
            , lmsUserStarted       = now
            , lmsUserReceived      = Nothing
            , lmsUserNotified      = Nothing
            , lmsUserEnded         = Nothing
            }
          -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
          startLmsUser = do
            pw <- randomLMSpw
            maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser pw) (randomLMSIdentBut identsInUse)
      inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
      case inserted of
        Nothing  -> do
          uuid :: CryptoUUIDUser <- encrypt uid
          $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> "!"
        (Just _) -> return () -- lmsUser started, but not yet notified


-- purge LmsIdent after QualificationAuditDuration expired
dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX
dispatchJobLmsDequeue qid = JobHandlerAtomic act
  where
    act = do
      quali <- getJust qid -- may throw an error, aborting the job
      let qshort = CI.original $ qualificationShorthand quali
      $logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort
      now <- liftIO getCurrentTime
      let nowaday = utctDay now      
      -- end users that expired by doing nothing
      expiredLearners <- E.select $ do 
          (quser :& luser) <- E.from $
            E.table @QualificationUser
            `E.innerJoin` E.table @LmsUser
            `E.on` (\(quser :& luser) ->
                              luser E.^. LmsUserUser           E.==. quser   E.^. QualificationUserUser
                        E.&&. luser E.^. LmsUserQualification  E.==. quser   E.^. QualificationUserQualification)
          E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
              E.&&.  luser E.^. LmsUserQualification           E.==. E.val qid
              E.&&.  E.isNothing (luser E.^. LmsUserStatus)
              E.&&.  E.isNothing (luser E.^. LmsUserEnded)
              E.&&.  E.not_ (validQualification now quser)
          pure (luser E.^. LmsUserId)      
      nrExpired <- E.updateCount $ \luser -> do
        E.set luser [LmsUserStatus E.=. E.justVal LmsExpired, LmsUserStatusDay E.=. E.justVal nowaday]
        E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners)
             E.&&.  luser E.^. LmsUserQualification E.==. E.val qid
      $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort

      when (quali ^. _qualificationExpiryNotification) $ do
        notifyInvalidDrivers <- E.select $ do 
            quser <- E.from $ E.table @QualificationUser 
            E.where_ $ E.not_ (quser `qualificationValid` now)                 -- currently invalid
              E.&&. quser E.^. QualificationUserQualification E.==. E.val qid  -- correct qualification
              E.&&. quser `quserToNotify` now                                  -- recently became invalid or blocked
            pure (quser E.^. QualificationUserUser)      
        
        forM_ notifyInvalidDrivers $ \(E.Value uid) ->
          queueDBJob JobUserNotification
            { jRecipient    = uid
            , jNotification = NotificationQualificationExpired { nQualification = qid }
            }

      -- purge outdated LmsUsers
      case qualificationAuditDuration quali of
        Nothing -> return () -- no automatic removal
        (Just auditDuration) -> do
          let auditCutoff = addDiffDaysRollOver (fromMonths $ negate auditDuration) now
          $logInfoS "LMS" $ "Audit Cuttoff at " <> tshow auditCutoff <> " for Audit Duration " <> tshow auditDuration <> " for qualification " <> qshort
          delusersVals <- E.select $ do
            luser <- E.from $ E.table @LmsUser
            E.where_ $  luser E.^. LmsUserQualification E.==. E.val qid
                  E.&&. luser E.^. LmsUserEnded         E.<.  E.justVal auditCutoff
                  E.&&. E.isJust (luser E.^. LmsUserEnded)
                  -- E.&&. E.notExists (do
                  --         laudit <- E.from $ E.table @LmsAudit
                  --         E.where_ $  laudit E.^. LmsAuditQualification E.==. E.val qid
                  --             E.&&.   laudit E.^. LmsAuditIdent         E.==. luser E.^. LmsUserIdent
                  --             E.&&.   laudit E.^. LmsAuditProcessed     E.>=. E.val auditCutoff
                  --       )
            pure (luser E.^. LmsUserIdent)
          let delusers = E.unValue <$> delusersVals
              numdel = length delusers              
          when (numdel > 0) $ do
            $logInfoS "LMS" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort
            deleteWhere [LmsUserQualification     ==. qid, LmsUserIdent     <-. delusers]
            deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers]
            deleteWhere [LmsResultQualification   ==. qid, LmsResultIdent   <-. delusers]
            -- deleteWhere [LmsAuditQualification    ==. qid, LmsAuditIdent    <-. delusers]

-- processes received results and lengthen qualifications, if applicable
dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX
dispatchJobLmsResults qid = JobHandlerAtomic act
  where
    -- act :: YesodJobDB UniWorX ()
    act = hoist lift $ do
        results <- E.select $ do
          (quser :& luser :& lresult) <- E.from $
              E.table @QualificationUser  -- table not needed if renewal from lms completion day is used TODO: decide!
              `E.innerJoin` E.table @LmsUser
              `E.on` (\(quser :& luser) ->
                              luser E.^. LmsUserUser           E.==. quser   E.^. QualificationUserUser
                        E.&&. luser E.^. LmsUserQualification  E.==. quser   E.^. QualificationUserQualification)
              `E.innerJoin` E.table @LmsResult
              `E.on` (\(_ :& luser :& lresult) ->
                              luser E.^. LmsUserIdent          E.==. lresult E.^. LmsResultIdent
                        E.&&. luser E.^. LmsUserQualification  E.==. lresult E.^. LmsResultQualification)
          E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
            E.&&.    luser E.^. LmsUserQualification           E.==. E.val qid
            -- E.&&. E.isNothing (luser E.^. LmsUserStatus)  -- do not process learners already having a result WORKAROUND LMS-Bug: LMS may send blocked & success simultanesouly or within a few hours; in this case, success is the correct meaning
            E.&&. E.isNothing (luser E.^. LmsUserEnded)   -- do not process closed learners
          return (quser, luser, lresult)
        now <- liftIO getCurrentTime
        let locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now
        forM_ results $ \(Entity _quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do
          -- three separate DB operations per result is not so nice. All within one transaction though.
          let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted
              saneDate    = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay)
                            -- && qualificationUserLastRefresh <= utctDay lmsUserStarted    NOTE: not always true due to manual intervention; also renewValidQualificationUsers prevents double renewals anyway              
              -- newValidTo  = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
          note <- if saneDate && (lmsUserStatus /= Just LmsSuccess)
            then do
              -- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
              let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
              ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log
              when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid}|])

              _ok_renew <- renewValidQualificationUsers qid [qualificationUserUser] -- ignores possible blocks
              -- when (ok==1) $ update luid -- we end lms regardless of whether or not a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings

              update luid 
                [ LmsUserStatus     =. Just LmsSuccess
                , LmsUserStatusDay  =. Just lmsResultSuccess
                , LmsUserReceived   =. Just lmsResultTimestamp
                ]                          
              return Nothing
            else do
              let errmsg = [st|LMS Result: success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}  for #{tshow qid}|]
              $logErrorS "LMS" errmsg
              return $ Just errmsg

          audit TransactionLmsSuccess -- always log success, since this is only transmitted once
            { transactionQualification = qid
            , transactionLmsIdent      = lmsUserIdent
            , transactionLmsDay        = lmsResultSuccess
            , transactionLmsUser       = Just lmsUserUser
            , transactionNote          = note
            , transactionReceived      = lmsResultTimestamp
            }
          delete lrid
        $logInfoS "LMS" [st|Processed #{tshow (length results)} LMS results|]


-- processes received input and block qualifications, if applicable
dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX
dispatchJobLmsUserlist qid = JobHandlerAtomic act
  where
    act :: YesodJobDB UniWorX ()
    act = do
      now <- liftIO getCurrentTime              
      -- result :: [(Entity LmsUser, Entity LmsUserlist)]
      results <- E.select $ do
        (luser :& lulist) <- E.from $
            E.table @LmsUser `E.leftJoin` E.table @LmsUserlist
            `E.on` (\(luser :& 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          -- mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
          , isNothing $ lmsUserEnded    luser ->
              update luid [LmsUserEnded =. Just now]
          | otherwise -> return ()                     -- users likely not yet started

        (Entity luid luser, Just (Entity _lulid lulist)) -> do
          let lReceived = lmsUserlistTimestamp lulist
              lmsMsgDay = utctDay lReceived
          update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications          

          when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available
            queueDBJob JobUserNotification
              { jRecipient    = lmsUserUser luser
              , jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False }
              }
          
          let isBlocked = lmsUserlistFailed lulist
              oldStatus = lmsUserStatus luser
              updateStatus = isBlocked && oldStatus /= Just LmsSuccess
          when updateStatus $ do            
            update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. Just lmsMsgDay]     
            ok <- qualificationUserBlocking qid [lmsUserUser luser] False (Right QualificationBlockFailedELearning)  True
            when (ok /= 1) $ do 
              uuid :: CryptoUUIDUser <- encrypt $ lmsUserUser luser
              $logWarnS "LmsUserlist" [st|Blocking by failed E-learning failed for learner #{tshow uuid} and qualification #{tshow qid}]            
            audit TransactionLmsBlocked
              { transactionQualification = qid
              , transactionLmsIdent      = lmsUserIdent luser
              , transactionLmsDay        = lmsMsgDay
              , transactionLmsUser       = Just $ lmsUserUser luser
              , transactionNote          = Just $ "Old status was " <> tshow oldStatus
              , transactionReceived      = lReceived
              }
          delete lulid
      $logInfoS "LMS" [st|Processed LMS Userlist with #{tshow (length results)} entries|]
