{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

{-|
Module      : $Header$
Copyright   : (c) 2016 Deakin Software & Technology Innovation Lab
License     : BSD3

Maintainer  : Shannon Pace <shannon.pace@deakin.edu.au>
Stability   : unstable
Portability : portable

Tests for state functionality.
-}

module Eclogues.StateSpec (spec) where

import Eclogues.Prelude
import Eclogues.API
  ( Action (..), DependencyPatch (..), JobError (..), StageExpectation (..) )
import qualified Eclogues.Job as Job
import Eclogues.Job
  ( Stage (..), QueueStage (..), Sealed (..)
  , RunErrorReason (..), FailureReason (..)
  , singleton)
import Eclogues.State
  ( AtomicFailure (..)
  , addFile, atomicActs, deleteBox, deleteContainer, deleteJob, killJob
  , patchDepends, sealBox, updateJobs )
import qualified Eclogues.State.Monad as ES
import Eclogues.State.Types (AppState, jobs)
import TestUtils

import qualified Data.HashMap.Strict as HM
import Control.Monad.State (get, gets, put)
import Data.UUID (nil)

import Test.Hspec

{-# ANN module ("HLint: ignore Use ." :: String) #-}

job :: Job.Name
job = forceName "job"

job2 :: Job.Name
job2 = forceName "job2"

dep :: Job.Name
dep = forceName "dep"

optDepName :: Job.Name
optDepName = forceName "optDep"

optDep :: Job.Dependency
optDep = Job.Dependency optDepName True

createJobWithDep' :: Job.Dependency -> Job.Stage -> Scheduler ()
createJobWithDep' (Job.Dependency depName depOpt) depStage = do
    createJob' $ isolatedJob' depName
    ES.setJobStage depName depStage
    createJob' $ isolatedJob' job & Job.dependsOn . Job.dependenciesMap .~ HM.singleton depName depOpt

createJobWithDep :: Job.Name -> Job.Stage -> Scheduler ()
createJobWithDep = createJobWithDep' . (`Job.Dependency` False)

testCreateJob :: Spec
testCreateJob = describe "createJob" $ do
    it "should succeed when given a unique, valid job" $
        let result = schedule . createJob' $ isolatedJob' job
        in result `shouldHave` jobInStage job (Queued LocalQueue)

    context "when provided with dependency in Finished stage" $
        it "should be placed in the Queued stage" $
            let result = schedule $ createJobWithDep dep Finished
            in result `shouldHave` jobInStage job (Queued LocalQueue)

    context "when provided with dependency in an active stage" $
        it "should be waiting on one job" $
            let result = schedule $ createJobWithDep dep Running
            in result `shouldHave` jobInStage job (Waiting $ singleton dep)

    context "when provided with a dependency" $
        it "should update dependants list for that dependency" $
            let result = schedule $ do
                    createJob' $ isolatedJob' dep
                    createJob' $ dependentJob' job [dep]
            in result `shouldHave` jobWithRevDeps dep [job]

    context "when provided a job with a name that already exists" $
        it "should return JobNameUsed error" $
            let result = schedule $ do
                    createJob' $ isolatedJob' job
                    createJob' $ isolatedJob' job
            in result `shouldHave` producedError NameUsed

    context "when provided a dependency that doesn't exist" $
        it "should return JobMustBe ExpectExtant error" $
            let result = schedule . createJob' $ dependentJob' job [dep]
            in result `shouldHave` producedError (JobMustBe dep ExpectExtant)

    context "when provided a dependency that has failed" $
        it "should return JobMustBe ExpectNonFailed error" $
            let result = schedule $ do
                    createJob' $ isolatedJob' dep
                    ES.setJobStage dep (Failed UserKilled)
                    createJob' $ dependentJob' job [dep]
            in result `shouldHave` producedError (JobMustBe dep ExpectNonFailed)

    context "if the specified container does not exist" $
        it "should return ContainerMustExist error" $
            let result = schedule $ createJob' (isolatedJob' job & Job.container .~ con)
                con    = Job.ContainerId $ forceName "unknowncontainer"
            in result `shouldHave` producedError (ContainerMustExist con)

testKillJob :: Spec
testKillJob = describe "killJob" $ do
    it "should transition job with given name to Killing stage" $
        let result = schedule $ do
                createJob' $ isolatedJob' job
                killJob job
        in result `shouldHave` jobInStage job Killing

    context "when provided the name of a job that doesn't exist" $
        it "should return NoSuch error" $
            schedule (killJob job) `shouldHave` producedError NoSuch

    context "when provided the name of a job that is in a termination stage" $
        it "should do nothing" $
            let result = schedule $ do
                    discardSideEffects $ do
                        createJob' $ isolatedJob' job
                        ES.setJobStage job Finished
                    killJob job
            in result `shouldHave` noSideEffects

testPatchDepends :: Spec
testPatchDepends = describe "patchDepends" $ do
    it "should fail if the job isn't Waiting" $
        let result = schedule $ do
                discardSideEffects . createJob' $ isolatedJob' job
                patchDepends job $ DependencyPatch mempty mempty
        in result `shouldHave` producedError (JobMustBe job ExpectWaiting)

    it "should queue a job if its remaining active dependencies are removed" $
        let result = schedule $ do
                discardSideEffects $ do
                    createJob' $ isolatedJob' dep
                    createJob' $ dependentJob' job [dep]
                patchDepends' job [] [dep]
        in do
            result `shouldHave` jobInStage job (Queued LocalQueue)
            result `shouldHave` jobWithDeps job []

    it "should do nothing if an already terminated dependency is removed" $
        let result = schedule $ do
                discardSideEffects $ do
                    createJob' $ isolatedJob' dep
                    ES.setJobStage dep Finished
                    createJob' $ isolatedJob' job2
                    createJob' $ dependentJob' job [dep, job2]
                patchDepends' job [] [dep]
        in do
            result `shouldHave` jobInStage job (Waiting $ singleton job2)
            result `shouldHave` jobWithDeps job [job2]
            result `shouldHave` jobWithRevDeps dep []
            result `shouldHave` noSchedulingSideEffects

    it "should do nothing if non-dependency is removed" $
        let result = schedule $ do
                createWaitingOnJob2 job
                patchDepends' job [] [dep]
        in do
            result `shouldHave` jobInStage job (Waiting $ singleton job2)
            result `shouldHave` noSideEffects

    it "should fail when attempting to add a dependency that doesn't exist" $
        let result = schedule $ do
                createWaitingOnJob2 job
                patchDepends' job [dep] []
        in result `shouldHave` producedError (JobMustBe dep ExpectExtant)

    it "should add to Waiting when an active dependency is added" $
        let result = schedule $ do
                discardSideEffects $ do
                    createJob' $ isolatedJob' dep
                    createJob' $ isolatedJob' job2
                    createJob' $ dependentJob' job [dep]
                patchDepends' job [job2] []
        in do
            result `shouldHave` jobInStage job (Waiting $ singleton dep <> singleton job2)
            result `shouldHave` jobWithDeps job [dep, job2]
            result `shouldHave` jobWithRevDeps job2 [job]

    it "should do nothing when a Finished dependency is added" $
        let result = schedule $ do
                discardSideEffects $ do
                    createJob' $ isolatedJob' dep
                    ES.setJobStage dep Finished
                    createWaitingOnJob2 job
                patchDepends' job [dep] []
        in do
            result `shouldHave` jobInStage job (Waiting $ singleton job2)
            result `shouldHave` jobWithRevDeps dep [job]
            result `shouldHave` jobWithRevDeps job2 [job]
            result `shouldHave` noSchedulingSideEffects

    it "should do nothing when an existing dependency is added" $
        let result = schedule $ do
                discardSideEffects $ do
                    createJob' $ isolatedJob' dep
                    createJob' $ dependentJob' job [dep]
                patchDepends' job [dep] []
        in do
            result `shouldHave` jobInStage job (Waiting $ singleton dep)
            result `shouldHave` noSideEffects

    it "should fail when attempting to add a dependency that has failed" $
        let result = schedule $ do
                discardSideEffects $ do
                    createJob' $ isolatedJob' dep
                    ES.setJobStage dep (Failed $ NonZeroExitCode 5)
                    createWaitingOnJob2 job
                patchDepends' job [dep] []
        in result `shouldHave` producedError (JobMustBe dep ExpectNonFailed)
  where
    patchDepends' n add rm = patchDepends n $ DependencyPatch (namesToDeps add) rm
    createWaitingOnJob2 n = discardSideEffects $ createJob' (isolatedJob' job2) *> createJob' (dependentJob' n [job2])

discardSideEffects :: Scheduler a -> Scheduler a
discardSideEffects sch = do
    st <- get
    a <- sch
    st' <- get
    put $ st & ES.appState .~ (st' ^. ES.appState)
    pure a

testDeleteJob :: Spec
testDeleteJob = describe "deleteJob" $ do
    it "should remove the finished job with the given name from application stage" $
        let result = schedule $ do
             createJob' $ isolatedJob' job
             ES.setJobStage job Finished
             deleteJob job
        in result `shouldHave` noEntity job

    context "when provided the name of an active job with dependencies" $
        it "should remove any reverse dependencies" $
            let result = schedule $ do
                    createJob' $ isolatedJob' dep
                    createJob' $ dependentJob' job [dep]
                    ES.setJobStage job Running
                    deleteJob job
            in do
                result `shouldHave` noEntity job
                result `shouldHave` noRevDep dep

    context "when provided the name of a job that has outstanding dependants" $
        it "should return OutstandingDependants error" $
            let result = schedule $ do
                    createJobWithDep dep Finished
                    deleteJob dep
            in result `shouldHave` producedError (OutstandingDependants (pure job))

testDeleteContainer :: Spec
testDeleteContainer = describe "deleteContainer" $ do
    it "should refuse to delete containers with active jobs" $
        let result = schedule $ do
                createJob' $ isolatedJob' job
                deleteContainer echoContainer
        in result `shouldHave` producedError (OutstandingDependants (pure job))

    it "should be fine deleting containers where all the jobs are done" $
        let result = schedule $ do
                createJob' $ isolatedJob' job
                ES.setJobStage job Finished
                deleteContainer echoContainer
        in result `shouldHave` noContainer echoContainer

testDeleteBox :: Spec
testDeleteBox = describe "deleteBox" $ do
    it "should refuse to delete boxes with active dependants" $
        let result = schedule $ do
                createBox' dep
                createJob' $ dependentJob' job [dep]
                deleteBox dep
        in result `shouldHave` producedError (OutstandingDependants (pure job))

    it "should be fine deleting boxes with a finished job dependant" $
        let result = schedule $ do
                createBox' dep
                createJob' $ dependentJob' job [dep]
                updateJobs' [(job, Finished)]
                deleteBox dep
        in result `shouldHave` noEntity dep

updateJobs' :: [(Job.Name, Job.Stage)] -> Scheduler ()
updateJobs' statuses = (`updateJobs` statuses) =<< gets (^.. jobs)

testUpdateJobs :: Spec
testUpdateJobs = describe "updateJobs" $ do
    context "when job is on scheduler and no new status information is received" $
        it "should do nothing" $
            let result = schedule $ do
                    createJob' $ isolatedJob' job
                    ES.setJobStage job (Queued SchedulerQueue)
                    updateJobs' [(job, Queued SchedulerQueue)]
        in result `shouldHave` jobInStage job (Queued SchedulerQueue)

    context "when job is in stage Killing and no updated information is provided" $
        it "should change job to Failed UserKilled stage" $
            let result = schedule $ do
                    createJob' $ isolatedJob' job
                    ES.setJobStage job Killing
                    updateJobs' []
            in result `shouldHave` jobInStage job (Failed UserKilled)

    context "when job is in stage Killing and is updated to stage Finished" $
        it "should change job to Failed UserKilled stage" $
            let result = schedule $ do
                    createJob' $ isolatedJob' job
                    ES.setJobStage job Killing
                    updateJobs' [(job, Finished)]
            in result `shouldHave` jobInStage job (Failed UserKilled)

    context "when job is in stage Killing and is updated to stage RunError SchedulerLost" $
        it "should change job to RunError SchedulerLost stage" $
            let result = schedule $ do
                    createJob' $ isolatedJob' job
                    ES.setJobStage job Killing
                    updateJobs' [(job, RunError SchedulerLost)]
            in result `shouldHave` jobInStage job (RunError SchedulerLost)

    context "when job is in stage Killing and is updated to stage Running" $
        it "should change job to Killing stage" $
            let result = schedule $ do
                    createJob' $ isolatedJob' job
                    ES.setJobStage job Killing
                    updateJobs' [(job, Running)]
            in result `shouldHave` jobInStage job Killing

    context "when job is on scheduler and is provided no stage information" $
        it "should change job to RunError SchedulerLost stage" $
            let result = schedule $ do
                    createJob' $ isolatedJob' job
                    ES.setJobStage job Running
                    updateJobs' []
            in result `shouldHave` jobInStage job (RunError SchedulerLost)

    context "when job is not on scheduler and is provided no stage information" $
        it "should change job to Queued LocalQueue stage" $
            let result = schedule $ do
                    createJob' $ isolatedJob' job
                    updateJobs' []
            in result `shouldHave` jobInStage job (Queued LocalQueue)

    context "when provided job stage that is an expected transition from current stage" $
        it "should change job to the provided stage" $
            let result = schedule $ do
                    createJob' $ isolatedJob' job
                    updateJobs' [(job, Running)]
            in result `shouldHave` jobInStage job Running

    context "when provided job stage is not an expected transition from current stage" $
        it "should change job to RunError BadSchedulerTransition stage" $
            let result = schedule $ do
                    createJob' $ isolatedJob' job
                    ES.setJobStage job Running
                    updateJobs' [(job, Waiting $ singleton dep)]
            in result `shouldHave` jobInStage job (RunError BadSchedulerTransition)

    context "when job does not transition into a termination stage" $
        it "should not change the stage of any dependent jobs" $
            let result = schedule $ do
                    createJobWithDep dep Running
                    updateJobs' [(dep, Running)]
            in do
                result `shouldHave` jobInStage dep Running
                result `shouldHave` jobInStage job (Waiting $ singleton dep)

    context "when optional job does not transition into a termination stage" $
        it "should not change the stage of any dependent jobs" $
            let result = schedule $ do
                    createJobWithDep' optDep Running
                    updateJobs' [(optDepName, Running)]
            in do
                result `shouldHave` jobInStage optDepName Running
                result `shouldHave` jobInStage job (Waiting $ singleton optDepName)

    context "when job transitions into non-Finished termination stage" $
        it "should change the stage of dependent jobs to Failed DependencyFailed" $
            let result = schedule $ do
                    createJobWithDep dep Running
                    updateJobs' [(dep, Failed UserKilled)]
            in do
                result `shouldHave` jobInStage dep (Failed UserKilled)
                result `shouldHave` jobInStage job (Failed (DependencyFailed dep))

    context "when optional job transitions into non-Finished termination stage" $
        it "should change the stage of exclusively dependent job to Queued LocalQueue" $
            let result = schedule $ do
                    createJobWithDep' optDep Running
                    updateJobs' [(optDepName, Failed UserKilled)]
            in do
                result `shouldHave` jobInStage optDepName (Failed UserKilled)
                result `shouldHave` jobInStage job (Queued LocalQueue)

    context "when job transitions into Finished stage" $
        it "should change the stage of exclusively dependent job to Queued LocalQueue" $
            let result = schedule $ do
                    createJobWithDep dep Running
                    updateJobs' [(dep, Finished)]
            in do
                result `shouldHave` jobInStage dep Finished
                result `shouldHave` jobInStage job (Queued LocalQueue)

    context "when job transitions into Finished stage but dependent is also waiting on another job" $
        it "should change the stage of dependent job to Waiting 1" $
            let result = schedule $ do
                    createJob' $ isolatedJob' dep
                    createJob' $ isolatedJob' job2
                    createJob' $ dependentJob' job [dep, job2]
                    updateJobs' [(dep, Finished)]
            in do
                result `shouldHave` jobInStage dep Finished
                result `shouldHave` jobInStage job (Waiting $ singleton job2)

    context "when dependent job finishes" $ do
        it "should remove reverse dependency on the job on which it depended" $
            let result = schedule $ do
                    createJob' $ isolatedJob' dep
                    createJob' $ dependentJob' job [dep]
                    updateJobs' [(dep, Finished), (job, Finished)]
            in result `shouldHave` noRevDep dep

        it "should allow job and dependent to be deleted" $
            let result = schedule $ do
                    createJob' $ isolatedJob' dep
                    createJob' $ dependentJob' job [dep]
                    updateJobs' [(dep, Failed UserKilled)]
                    ES.deleteJob dep
                    ES.deleteJob job
            in do
                result `shouldHave` noEntity dep
                result `shouldHave` noEntity job

        it "should recursively cause all dependencies to fail" $
            let result = schedule $ do
                    createJob' $ isolatedJob' dep
                    createJob' $ dependentJob' job [dep]
                    createJob' $ dependentJob' job2 [job]
                    updateJobs' [(dep, Failed UserKilled)]
            in do
                result `shouldHave` noRevDep dep
                result `shouldHave` noRevDep job
                result `shouldHave` jobInStage job (Failed (DependencyFailed dep))
                result `shouldHave` jobInStage job2 (Failed (DependencyFailed job))

    context "a job sent to the scheduler isn't seen in the list" $ do
        it "should change the stage to SchedulerLost if the job has been seen on the scheduler before" $
            let result = schedule $ do
                    createJob' $ isolatedJob' job
                    ES.setJobStage job $ Queued SchedulerQueue
                    updateJobs' []
            in result `shouldHave` jobInStage job (RunError SchedulerLost)

        it "should do nothing if the job hasn't been seen on the scheduler before" $
            let result = schedule $ do
                    createJob' $ isolatedJob' job
                    ES.setJobStage job $ Queued SentToScheduler
                    updateJobs' []
            in result `shouldHave` jobInStage job (Queued SentToScheduler)

testAddFile :: Spec
testAddFile = describe "addFile" $ do
    it "can add files under both jobs and boxes" $
        let result = schedule $ do
                createBox' job
                createJob' $ isolatedJob' job2
                addFile job  f1 nil
                addFile job2 f2 nil
            f1 = "afile"
            f2 = "file"
        in do
            result `shouldHave` file job  f1
            result `shouldHave` file job2 f2

    it "fails if given an unknown namespace" $
        let result = schedule $ addFile job "afile" nil
        in  result `shouldHave` producedError NoSuch

    it "fails if a filename is already taken" $
        let result = schedule $ do
                createBox' job
                addFile job f1 nil
                addFile job f1 nil
            f1 = "file"
        in result `shouldHave` producedError (FileAlreadyExists job f1)

testSealBox :: Spec
testSealBox = describe "sealBox" $ do
    it "triggers dependants of the box" $
        let result = schedule $ do
                createBox' dep
                createJob' $ dependentJob' job [dep]
                sealBox dep
        in do
            result `shouldHave` boxInStage dep Sealed
            result `shouldHave` jobInStage job (Queued LocalQueue)

    it "does nothing on an already sealed box" $
        let result = schedule $ do
                createBox' dep
                sealBox dep
                createJob' $ dependentJob' job [dep]
                ES.setJobStage job (Waiting $ singleton dep)
                sealBox dep -- should do nothing
        in do
            result `shouldHave` boxInStage dep Sealed
            result `shouldHave` jobInStage job (Waiting $ singleton dep)

atomicActs' :: [Action] -> Either AtomicFailure AppState
atomicActs' as = (^. ES.appState) <$> atomicActs defWithContainer Nothing ((nil,) <$> as)

testAtomic :: Spec
testAtomic = describe "atomicActs" $ do
    it "stops at the first failure" $
        let result = atomicActs' [ cr1, cr2 ]
            cr1 = ActCreateJob $ dependentJob' job  [dep]
            cr2 = ActCreateJob $ dependentJob' job2 [job]
        in result `shouldBe` Left (AtomicFailure cr1 $ JobMustBe dep ExpectExtant)

    it "applies all actions" $
        let result = atomicActs' [ cr1, cr2, cr3, k2 ]
            cr1  = ActCreateJob $ isolatedJob'  job
            cr2  = ActCreateJob $ dependentJob' job2 [job]
            cr3  = ActCreateJob $ dependentJob' job3 [job]
            k2   = ActKillJob   job2
            job3 = forceName "job3"
        in do
          result `shouldSatisfy` has _Right
          let res = either (error "left") id result
          pure res `shouldHave` jobInStage job  (Queued LocalQueue)
          pure res `shouldHave` jobInStage job2 Killing
          pure res `shouldHave` jobInStage job3 (Waiting $ singleton job)

spec :: Spec
spec = do
    testCreateJob
    testKillJob
    testPatchDepends
    testDeleteJob
    testDeleteBox
    testDeleteContainer
    testUpdateJobs
    testAddFile
    testSealBox
    testAtomic
