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

module Jobs.Types
  ( Job(..), Notification(..)
  , JobChildren
  , classifyJob
  , JobCtlPrewarmSource(..), _jcpsSheet, _jcpsSheetFileType
  , JobCtl(..), _jcPrewarmSource, _jcChunkInterval
  , 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, 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)

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


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 { jNumIterations
                              , jEpoch
                              , jIteration :: Natural
                              }
  | JobInjectFiles
  | JobPruneFallbackPersonalisedSheetFilesKeys
  | JobRechunkFiles
  | JobDetectMissingFiles
  | JobPruneOldSentMails
  | JobStudyFeaturesCacheRelevance
  | JobStudyFeaturesRecacheRelevance { jNumIterations
                                     , jEpoch
                                     , jIteration :: Natural
                                     }
  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) }
  | NotificationUserSystemFunctionsUpdate { nUser :: UserId, nOriginalSystemFunctions :: Set SystemFunction }
  | 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 }
  | NotificationAllocationNewCourse { nAllocation :: AllocationId, nCourse :: CourseId }
  | 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


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 a) = '[]

  ChildrenJobChildren a = Children ChGeneric a
  

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


data JobCtlPrewarmSource
  = JobCtlPrewarmSheetFile
    { jcpsSheet :: SheetId
    , jcpsSheetFileType :: SheetFileType
    }
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
  deriving anyclass (Hashable, NFData)

makeLenses_ ''JobCtlPrewarmSource
  
deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 3
  , fieldLabelModifier = camelToPathPiece' 1
  , tagSingleConstructors = True
  , sumEncoding = TaggedObject "source" "data"
  } ''JobCtlPrewarmSource

data JobCtl = JobCtlFlush
            | JobCtlPerform QueuedJobId
            | JobCtlPrewarmCache
                { jcPrewarmSource :: JobCtlPrewarmSource
                , jcTargetTime    :: UTCTime
                , jcChunkInterval :: (Maybe FileContentChunkReference, Maybe FileContentChunkReference)
                }
            | JobCtlInhibitInject
                { jcPrewarmSource :: JobCtlPrewarmSource
                , jcTargetTime    :: UTCTime
                }
            | JobCtlDetermineCrontab
            | JobCtlQueue Job
            | JobCtlGenerateHealthReport HealthCheck
            | JobCtlTest
            | JobCtlSleep Micro -- | For debugging
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
  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 ())
  deriving (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


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
  }


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
  JobPruneFallbackPersonalisedSheetFilesKeys{} -> True
  JobRechunkFiles{}            -> True
  JobDetectMissingFiles{}      -> True
  _                            -> False

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
