-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}

module Jobs.Types
  ( Job(..), Notification(..)
  , JobChildren
  , classifyJob
  , JobCtl(..)
  , classifyJobCtl
  , YesodJobDB
  , JobHandler(..), _JobHandlerAtomic, _JobHandlerException
  , JobOffloadHandler(..), JobContext(..)
  , JobState(..), _jobWorkers, _jobWorkerName, _jobContext, _jobPoolManager, _jobCron, _jobShutdown, _jobCurrentCrontab
  , jobWorkerNames
  , JobWorkerState(..), _jobWorkerJobCtl, _jobWorkerJob
  , JobWorkerId
  , showWorkerId, newWorkerId
  , JobQueue, jqInsert, jqDequeue', jqDequeue, jqDepth, jqContents
  , JobPriority(..), prioritiseJob
  , JobNoQueueSame(..), jobNoQueueSame, jobMovable
  , module Cron
  ) where

import Import.NoModel hiding (Unique, state)
import Settings.Log
import Utils.Lens.TH
import Model

import qualified Data.Aeson as Aeson

import qualified Data.HashMap.Strict as HashMap

import Data.Unique

import qualified Data.Map.Strict as Map
import qualified Data.Set as Set

import Data.PQueue.Prio.Max (MaxPQueue)
import qualified Data.PQueue.Prio.Max as PQ

import Cron (CronNextMatch(..), _MatchAsap, _MatchAt, _MatchNone)

import System.Clock (getTime, Clock(Monotonic), TimeSpec)
import GHC.Conc (unsafeIOToSTM)

import Data.Generics.Product.Types (Children, ChGeneric, HasTypesCustom(..))

{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}


data Job
  = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
  | JobUserNotification { jRecipient :: UserId, jNotification :: Notification }
  | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext }
  | JobQueueNotification { jNotification :: Notification }
  | JobHelpRequest { jHelpSender :: Either (Maybe Address) UserId
                   , jRequestTime :: UTCTime
                   , jSubject :: Maybe Text
                   , jHelpRequest :: Maybe Html
                   , jReferer :: Maybe Text
                   , jError :: Maybe ErrorResponse
                   }
  | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
  | JobDistributeCorrections { jSheet :: SheetId }
  | JobSendCourseCommunication { jRecipientEmail :: Either UserEmail UserId
                               , jAllRecipientAddresses :: Set Address
                               , jCourse :: CourseId
                               , jSender :: UserId
                               , jMailObjectUUID :: UUID
                               , jMailContent :: CommunicationContent
                               }
  | JobSendFirmCommunication   { jRecipientEmail :: Either UserEmail UserId
                               , jAllRecipientAddresses :: Set Address
                               , jCompanies :: Companies
                               , jSender :: UserId
                               , jMailObjectUUID :: UUID
                               , jMailContent :: CommunicationContent
                               }
  | JobInvitation { jInviter :: Maybe UserId
                  , jInvitee :: UserEmail
                  , jInvitationUrl :: Text
                  , jInvitationSubject :: Text
                  , jInvitationExplanation :: Html
                  }
  | JobSendPasswordReset { jRecipient :: UserId
                         }
  | JobTruncateTransactionLog
  | JobPruneInvitations
  | JobDeleteTransactionLogIPs
  | JobSynchroniseLdap        { jNumIterations
                              , jEpoch
                              , jIteration :: Natural
                              }
  | JobSynchroniseLdapUser    { jUser :: UserId }
  | JobSynchroniseLdapAll
  | JobSynchroniseAvs         { jNumIterations
                              , jEpoch
                              , jIteration :: Natural
                              , jSynchAfter :: Maybe Day
                              }
  | JobSynchroniseByAvsDataContact
                              { jAvsDataContact :: AvsDataContact
                              }
  --   JobSynchroniseAvsUser     { jUser :: UserId
  --                             , jSynchAfter :: Maybe Day
  --                             }
  --   JobSynchroniseAvsId       { jAvsId      :: AvsPersonId
  --                             , jSynchAfter :: Maybe Day
  --                             }
  | JobSynchroniseAvsQueue
  | JobSynchroniseAvsLicences
  | JobChangeUserDisplayEmail { jUser :: UserId
                              , jDisplayEmail :: UserEmail
                              }
  | JobPruneSessionFiles
  | JobPruneUnreferencedFiles { jNumIterations
                              , jEpoch
                              , jIteration :: Natural
                              }
  | JobExternalApiExpire { jExternalApi :: ExternalApiId
                         }
  | JobInjectFiles
  | JobPruneFallbackPersonalisedSheetFilesKeys
  | JobRechunkFiles
  | JobDetectMissingFiles
  | JobPruneOldSentMails
  | JobStudyFeaturesCacheRelevance
  | JobStudyFeaturesRecacheRelevance { jNumIterations
                                     , jEpoch
                                     , jIteration :: Natural
                                     }
  | JobLmsQualificationsEnqueue
  | JobLmsEnqueue     { jQualification :: QualificationId }
  | JobLmsEnqueueUser { jQualification :: QualificationId, jUser :: UserId }
  | JobLmsQualificationsDequeue
  | JobLmsDequeue     { jQualification :: QualificationId }
  | JobLmsReports     { jQualification :: QualificationId }
  | JobPrintAck
  | JobPrintAckAgain
  | JobSleep          { jSleep :: Int } -- dummy job that just sleeps to test job system
  deriving (Eq, Ord, Show, Read, Generic)

data Notification
  = NotificationSubmissionRated { nSubmission :: SubmissionId }
  | NotificationSheetActive { nSheet :: SheetId }
  | NotificationSheetSoonInactive { nSheet :: SheetId }
  | NotificationSheetInactive { nSheet :: SheetId }
  | NotificationSheetHint { nSheet :: SheetId }
  | NotificationSheetSolution { nSheet :: SheetId }
  | NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId }
  | NotificationCorrectionsNotDistributed { nSheet :: SheetId }
  | NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: Set (SchoolFunction, SchoolShorthand) }
  | NotificationUserSystemFunctionsUpdate { nUser :: UserId, nOriginalSystemFunctions :: Set SystemFunction }
  | NotificationUserAuthModeUpdate { nUser :: UserId }
  | NotificationExamRegistrationActive { nExam :: ExamId }
  | NotificationExamRegistrationSoonInactive { nExam :: ExamId }
  | NotificationExamDeregistrationSoonInactive { nExam :: ExamId }
  | NotificationExamResult { nExam :: ExamId }
  | NotificationExamOfficeExamResults { nExam :: ExamId }
  | NotificationExamOfficeExamResultsChanged { nExamResults :: Set ExamResultId }
  | NotificationExamOfficeExternalExamResults { nExternalExam :: ExternalExamId }
  | NotificationCourseRegistered { nUser :: UserId, nCourse :: CourseId }
  | NotificationSubmissionEdited { nInitiator :: UserId, nSubmission :: SubmissionId }
  | NotificationSubmissionUserCreated { nUser :: UserId, nSubmission :: SubmissionId }
  | NotificationSubmissionUserDeleted { nUser :: UserId, nSheet :: SheetId, nSubmission :: SubmissionId }
  | NotificationQualificationExpiry  { nQualification :: QualificationId, nExpiry :: Day }      -- NotificationTrigger: NTQualificationExpiry TODO: separate
  | NotificationQualificationExpired { nQualification :: QualificationId }                      -- NotificationTrigger: NTQualificationExpiry
  | NotificationQualificationRenewal { nQualification :: QualificationId, nReminder :: Bool }   -- NotificationTrigger: NTQualificationExpiry/NTQualificationReminder je nach nReminder
  deriving (Eq, Ord, Show, Read, Generic)

instance Hashable Job
instance NFData Job
instance Hashable Notification
instance NFData Notification

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 1
  , fieldLabelModifier = camelToPathPiece' 1
  , tagSingleConstructors = True
  , sumEncoding = TaggedObject "job" "data"
  } ''Job

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 1
  , fieldLabelModifier = camelToPathPiece' 1
  , tagSingleConstructors = True
  , sumEncoding = TaggedObject "notification" "data"
  } ''Notification


data JobChildren
type instance Children JobChildren a = ChildrenJobChildren a
type family ChildrenJobChildren a where
  ChildrenJobChildren ByteString = '[]
  ChildrenJobChildren Html = '[]
  ChildrenJobChildren Day = '[]
  ChildrenJobChildren DiffTime = '[]
  ChildrenJobChildren (SelDateTimeFormat -> DateTimeFormat) = '[]
  ChildrenJobChildren Natural = '[]
  ChildrenJobChildren UUID = '[]
  ChildrenJobChildren (Key a) = '[]
  ChildrenJobChildren (CI a) = '[]
  ChildrenJobChildren (Set v) = '[v]
  ChildrenJobChildren MailContext = '[]
  ChildrenJobChildren (Digest a) = '[]

  ChildrenJobChildren a = Children ChGeneric a

instance (Ord b', HasTypesCustom JobChildren a' b' a b) => HasTypesCustom JobChildren (Set a') (Set b') a b where
  typesCustom = iso Set.toList Set.fromList . traverse . typesCustom @JobChildren


classifyJob :: Job -> String
classifyJob job = unpack tag
  where
    Aeson.Object obj = Aeson.toJSON job
    Aeson.String tag = obj HashMap.! "job"


data JobCtl = JobCtlFlush
            | JobCtlPerform QueuedJobId
            | JobCtlDetermineCrontab
            | JobCtlQueue Job
            | JobCtlGenerateHealthReport HealthCheck
            | JobCtlTest
            | JobCtlSleep Micro -- ^ For debugging
  deriving (Eq, Ord, Read, Show, Generic)
  deriving anyclass (Hashable, NFData)

makePrisms ''JobCtl
makeLenses_ ''JobCtl

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 2
  , fieldLabelModifier = camelToPathPiece' 1
  , tagSingleConstructors = True
  , sumEncoding = TaggedObject "instruction" "data"
  } ''JobCtl

classifyJobCtl :: JobCtl -> String
classifyJobCtl jobctl = unpack tag
  where
    Aeson.Object obj = Aeson.toJSON jobctl
    Aeson.String tag = obj HashMap.! "instruction"


-- | Slightly modified Version of `YesodDB` for `runDBJobs`
type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerFor site))

data JobHandler site
  = JobHandlerAtomic    (YesodJobDB site ())
  | JobHandlerException (HandlerFor site ())
  | forall a. JobHandlerAtomicWithFinalizer (YesodJobDB site a) (a -> HandlerFor site ())
  | forall a. JobHandlerAtomicDeferrableWithFinalizer (ReaderT SqlReadBackend (HandlerFor site) a) (a -> HandlerFor site ())

makePrisms ''JobHandler


data JobWorkerState
  = JobWorkerBusy
  | JobWorkerExecJobCtl { jobWorkerJobCtl :: JobCtl }
  | JobWorkerExecJob { jobWorkerJob :: Job }
  deriving (Eq, Ord, Read, Show, Generic)

makeLenses_ ''JobWorkerState

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 2
  , fieldLabelModifier = camelToPathPiece' 2
  , tagSingleConstructors = True
  , sumEncoding = TaggedObject "state" "data"
  } ''JobWorkerState


newtype JobWorkerId = JobWorkerId { jobWorkerUnique :: Unique }
  deriving (Eq, Ord)

showWorkerId :: JobWorkerId -> Text
-- ^ Make a `JobWorkerId` somewhat human readable as a small-ish Number
showWorkerId = tshow . hashUnique . jobWorkerUnique

newWorkerId :: MonadIO m => m JobWorkerId
newWorkerId = JobWorkerId <$> liftIO newUnique

data JobOffloadHandler = JobOffloadHandler
  { jobOffloadHandler :: Async ()
  , jobOffloadOutgoing :: TVar (Seq QueuedJobId)
  }

data JobContext = JobContext
  { jobCrontab :: TVar (Crontab JobCtl)
  , jobConfirm :: TVar (HashMap JobCtl (NonEmpty (TMVar (Maybe SomeException))))
  , jobHeldLocks :: TVar (Set QueuedJobId)
  , jobOffload :: TMVar JobOffloadHandler
  , jobLastFlush :: TVar (Maybe UTCTime)
  }


data JobPriority = JobPrioBatch | JobPrioRealtime
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe JobPriority
instance Finite JobPriority
instance NFData JobPriority

nullaryPathPiece ''JobPriority $ camelToPathPiece' 2

prioritiseJob :: JobCtl -> JobPriority
prioritiseJob  JobCtlTest                     = JobPrioRealtime
prioritiseJob (JobCtlGenerateHealthReport _)  = JobPrioRealtime
prioritiseJob  JobCtlDetermineCrontab         = JobPrioRealtime
prioritiseJob  _                              = JobPrioBatch

data JobNoQueueSame = JobNoQueueSame | JobNoQueueSameTag
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
  deriving anyclass (Universe, Finite)

jobNoQueueSame :: Job -> Maybe JobNoQueueSame
jobNoQueueSame = \case
  JobSendNotification{jNotification}  -> notifyNoQueueSame jNotification
  JobUserNotification{jNotification}  -> notifyNoQueueSame jNotification
  JobSendPasswordReset{}              -> Just JobNoQueueSame
  JobTruncateTransactionLog{}         -> Just JobNoQueueSame
  JobPruneInvitations{}               -> Just JobNoQueueSame
  JobDeleteTransactionLogIPs{}        -> Just JobNoQueueSame
  JobSynchroniseLdap{}                -> Just JobNoQueueSame
  JobSynchroniseLdapUser{}            -> Just JobNoQueueSame
  JobSynchroniseLdapAll{}             -> Just JobNoQueueSameTag
  JobSynchroniseAvs{}                 -> Just JobNoQueueSame
  -- JobSynchroniseAvsUser{}             -> Just JobNoQueueSame
  -- JobSynchroniseAvsId{}               -> Just JobNoQueueSame
  JobSynchroniseAvsQueue{}            -> Just JobNoQueueSame
  JobChangeUserDisplayEmail{}         -> Just JobNoQueueSame
  JobPruneSessionFiles{}              -> Just JobNoQueueSameTag
  JobPruneUnreferencedFiles{}         -> Just JobNoQueueSameTag
  JobInjectFiles{}                    -> Just JobNoQueueSameTag
  JobPruneFallbackPersonalisedSheetFilesKeys{} -> Just JobNoQueueSameTag
  JobRechunkFiles{}                   -> Just JobNoQueueSameTag
  JobDetectMissingFiles{}             -> Just JobNoQueueSameTag
  JobLmsQualificationsEnqueue         -> Just JobNoQueueSame
  JobLmsEnqueue     {}                -> Just JobNoQueueSame
  JobLmsEnqueueUser {}                -> Just JobNoQueueSame
  JobLmsQualificationsDequeue         -> Just JobNoQueueSame
  JobLmsDequeue     {}                -> Just JobNoQueueSame
  JobLmsReports     {}                -> Just JobNoQueueSame
  JobPrintAck       {}                -> Just JobNoQueueSame
  JobPrintAckAgain  {}                -> Just JobNoQueueSame
  _                                   -> Nothing

notifyNoQueueSame :: Notification -> Maybe JobNoQueueSame
notifyNoQueueSame = \case
  NotificationQualificationRenewal{} -> Just JobNoQueueSame -- send one at once; safe, since the job is rescheduled if sending was not acknowledged
  NotificationQualificationExpiry{}  -> Just JobNoQueueSame -- do not send multiple expiry messages to the same person at once
  NotificationQualificationExpired{} -> Just JobNoQueueSame
  _                                  -> Nothing

jobMovable :: JobCtl -> Bool
jobMovable = isn't _JobCtlTest


newtype JobQueue = JobQueue { getJobQueue :: MaxPQueue (JobPriority, Down TimeSpec) JobCtl }
  deriving (Eq, Ord, Read, Show)
  deriving newtype (Semigroup, Monoid, NFData)

makePrisms ''JobQueue

jqInsert' :: TimeSpec -> JobCtl -> JobQueue -> JobQueue
jqInsert' cTime job = force . over _JobQueue $ PQ.insertBehind (prioritiseJob job, Down cTime) job

jqInsert :: JobCtl -> JobQueue -> STM JobQueue
jqInsert job queue = do
  cTime <- unsafeIOToSTM $ getTime Monotonic
  return $ jqInsert' cTime job queue

jqDequeue' :: JobQueue -> Maybe (((JobPriority, Down TimeSpec), JobCtl), JobQueue)
jqDequeue' = fmap ((\r@(_, q) -> q `deepseq` r) . over _2 JobQueue) . PQ.maxViewWithKey . getJobQueue

jqDequeue :: JobQueue -> Maybe (JobCtl, JobQueue)
jqDequeue = fmap (over _1 $ view _2) . jqDequeue'

jqDepth :: Integral n => JobQueue -> n
jqDepth = fromIntegral . PQ.size . getJobQueue

jqContents :: IndexedTraversal' (JobPriority, Down TimeSpec) JobQueue JobCtl
jqContents = _JobQueue . PQ.traverseWithKey . indexed


data JobState = JobState
  { jobWorkers :: Map (Async ()) (TVar JobQueue)
  , jobWorkerName :: Async () -> JobWorkerId
  , jobContext :: JobContext
  , jobPoolManager :: Async ()
  , jobCron :: Async ()
  , jobShutdown :: TMVar ()
  , jobCurrentCrontab :: TVar (Maybe (UTCTime, [(JobCtl, Maybe UTCTime, CronNextMatch UTCTime)]))
  }

jobWorkerNames :: JobState -> Set JobWorkerId
jobWorkerNames JobState{..} = Set.map jobWorkerName $ Map.keysSet jobWorkers

makeLenses_ ''JobState
