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

module Jobs.Types
  ( Job(..), Notification(..)
  , classifyJob
  , JobCtl(..)
  , classifyJobCtl
  , YesodJobDB
  , JobHandler(..), _JobHandlerAtomic, _JobHandlerException
  , JobContext(..)
  , JobState(..)
  , jobWorkerNames
  , JobWorkerState(..)
  , withJobWorkerState
  , JobWorkerId
  , showWorkerId, newWorkerId
  , JobQueue, jqInsert, jqDequeue
  , JobPriority(..), prioritiseJob
  , jobNoQueueSame
  , 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 Utils.Metrics (withJobWorkerStateLbls)

import qualified Prometheus (Label4)

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


data Job = JobSendNotification { 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
                                      , jSubject :: Maybe Text
                                      , jMailContent :: Html
                                      }
         | 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
                                  }
         | JobChangeUserDisplayEmail { jUser :: UserId
                                     , jDisplayEmail :: UserEmail
                                     }
         | JobPruneSessionFiles
         | JobPruneUnreferencedFiles
         | JobInjectFiles
         | JobPruneFallbackPersonalisedSheetFilesKeys
  deriving (Eq, Ord, Show, Read, Generic, Typeable)
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) }
                  | NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode }
                  | NotificationExamRegistrationActive { nExam :: ExamId }
                  | NotificationExamRegistrationSoonInactive { nExam :: ExamId }
                  | NotificationExamDeregistrationSoonInactive { nExam :: ExamId }
                  | NotificationExamResult { nExam :: ExamId }
                  | NotificationAllocationStaffRegister { nAllocations :: Set AllocationId }
                  | NotificationAllocationRegister { nAllocations :: Set AllocationId }
                  | NotificationAllocationAllocation { nAllocations :: Set AllocationId }
                  | NotificationAllocationUnratedApplications { nAllocations :: Set AllocationId }
                  | NotificationExamOfficeExamResults { nExam :: ExamId }
                  | NotificationExamOfficeExamResultsChanged { nExamResults :: Set ExamResultId }
                  | NotificationExamOfficeExternalExamResults { nExternalExam :: ExternalExamId }
                  | NotificationAllocationResults { nAllocation :: AllocationId }
                  | NotificationCourseRegistered { nUser :: UserId, nCourse :: CourseId }
                  | NotificationSubmissionEdited { nInitiator :: UserId, nSubmission :: SubmissionId }
                  | NotificationSubmissionUserCreated { nUser :: UserId, nSubmission :: SubmissionId }
                  | NotificationSubmissionUserDeleted { nUser :: UserId, nSheet :: SheetId, nSubmission :: SubmissionId }
  deriving (Eq, Ord, Show, Read, Generic, Typeable)

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

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
  deriving (Eq, Ord, Read, Show, Generic, Typeable)

instance Hashable JobCtl
instance NFData JobCtl

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 2
  , 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 ())
  deriving (Generic, Typeable)

makePrisms ''JobHandler


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

makeLenses_ ''JobWorkerState

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

classifyJobWorkerState :: JobWorkerId -> JobWorkerState -> Prometheus.Label4
classifyJobWorkerState wId jws = (showWorkerId wId, tag, maybe "n/a" pack mJobCtl, maybe "n/a" pack mJob)
  where
    Aeson.Object obj = Aeson.toJSON jws
    Aeson.String tag = obj HashMap.! "state"
    mJobCtl = asum
      [ classifyJobCtl <$> jws ^? _jobWorkerJobCtl
      , "perform" <$ jws ^? _jobWorkerJob
      ]
    mJob = classifyJob <$> jws ^? _jobWorkerJob

withJobWorkerState :: (MonadIO m, MonadMask m) => JobWorkerId -> JobWorkerState -> m a -> m a
withJobWorkerState wId newSt = withJobWorkerStateLbls $ classifyJobWorkerState wId newSt


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 JobContext = JobContext
  { jobCrontab :: TVar (Crontab JobCtl)
  , jobConfirm :: TVar (HashMap JobCtl (NonEmpty (TMVar (Maybe SomeException))))
  }


data JobPriority = JobPrioBatch | JobPrioRealtime
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
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

jobNoQueueSame :: Job -> Bool
jobNoQueueSame = \case
  JobSendPasswordReset{}       -> True
  JobTruncateTransactionLog{}  -> True
  JobPruneInvitations{}        -> True
  JobDeleteTransactionLogIPs{} -> True
  JobSynchroniseLdapUser{}     -> True
  JobChangeUserDisplayEmail{}  -> True
  JobPruneSessionFiles{}       -> True
  JobPruneUnreferencedFiles{}  -> True
  JobInjectFiles{}             -> True
  _                            -> False


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

makePrisms ''JobQueue

jqInsert :: JobCtl -> JobQueue -> JobQueue
jqInsert job = force . over _JobQueue $ PQ.insertBehind (prioritiseJob job) job

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


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

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