{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_HADDOCK show-extensions #-}

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

Maintainer  : Rhys Adams <rhys.adams@deakin.edu.au>
Stability   : unstable
Portability : portable

Eclogues REST API definition. See also the <https://github.com/dstil/eclogues#api README>.
-}

module Eclogues.API (
      API
    , Get, Mutating, Location, Pointer
    -- * Specific endpoints
    , ListJobs, JobStatus, KillJob, PatchJob, JobOnScheduler
    , DeleteJob, CreateJob
    , ListBoxes, BoxStatus, SealBox, CreateBox, DeleteBox
    , ListEntities
    , UploadFile, DownloadFile
    , ListContainers, GetContainer, AddContainer, DeleteContainer
    , AtomicActions
    -- * Error details
    , JobError (..), displayError
    , StageExpectation (..), displayStageExpectation, satisfiesStageExpectation
    -- * Other types
    , AbsoluteURI (..), parseAbsoluteURI, uriPath
    , Action ( ActCreateJob, ActKillJob, ActPatchJob, ActDeleteJob
             , ActCreateBox, ActSealBox, ActDeleteBox )
    , DependencyPatch (..)
    , actCreate
    ) where

import qualified Eclogues.Job as Job

import Control.Applicative (Alternative, (<|>), empty)
import Control.DeepSeq (NFData)
import Data.Aeson (ToJSON (..), FromJSON (..))
import qualified Data.Aeson as Aeson
import Data.Aeson.TH (deriveJSON, defaultOptions)
import Data.Char (toLower)
import Data.List (dropWhileEnd)
import Data.List.NonEmpty (NonEmpty, toList)
import Data.Monoid ((<>))
import Data.Text (Text, intercalate, pack, unpack)
import GHC.Generics (Generic)
import Lens.Micro (Lens', has, lens)
import qualified Network.URI as URI
import Servant.API
  ( (:>), (:<|>), Capture, JSON, OctetStream, ReqBody, StdMethod (..) )
import qualified Servant.API as S
import Servant.Streaming (StreamBody, StreamResponseGet)
import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))

type Get = S.Get '[JSON]
type Mutating (method :: StdMethod) = S.Verb method 204 '[S.PlainText] S.NoContent
type Location a = S.Headers '[S.Header "Location" AbsoluteURI] a
type Pointer (method :: StdMethod) code a = S.Verb method code '[S.PlainText] (Location a)

type ListJobs       = "jobs" :> Get [Job.Status]
type JobStatus      = "jobs" :> Capture "id" Job.Name :> Get Job.Status
type KillJob        = "jobs" :> Capture "id" Job.Name :> "kill" :> Mutating 'POST
type PatchJob       = "jobs" :> Capture "id" Job.Name :> ReqBody '[JSON] DependencyPatch :> Mutating 'PATCH
type JobOnScheduler = "jobs" :> Capture "id" Job.Name :> "scheduler" :> Pointer 'GET 303 S.NoContent
type DeleteJob      = "jobs" :> Capture "id" Job.Name :> Mutating 'DELETE
type CreateJob      = "jobs" :> ReqBody '[JSON] Job.InputSpec :> Pointer 'POST 201 Job.Name

type ListBoxes      = "boxes" :> Get [Job.BoxStatus]
type BoxStatus      = "boxes" :> Capture "id" Job.Name :> Get Job.BoxStatus
type SealBox        = "boxes" :> Capture "id" Job.Name :> "seal" :> Mutating 'POST
type CreateBox      = "boxes" :> ReqBody '[JSON] Job.BoxSpec :> Pointer 'POST 201 S.NoContent
type DeleteBox      = "boxes" :> Capture "id" Job.Name :> Mutating 'DELETE

type ListEntities   = "entities" :> Get [Job.AnyStatus]

type UploadFile     = "files" :> Capture "id" Job.Name :> Capture "filename" Job.FileId :> StreamBody '[OctetStream] :> Mutating 'PUT
type DownloadFile   = "files" :> Capture "id" Job.Name :> Capture "filename" Job.FileId :> StreamResponseGet '[OctetStream]

type ListContainers  = "containers" :> Get [Job.ContainerId]
type AddContainer    = "containers" :> Capture "id" Job.ContainerId :> StreamBody '[OctetStream] :> Mutating 'PUT
type GetContainer    = "containers" :> Capture "id" Job.ContainerId :> StreamResponseGet '[OctetStream]
type DeleteContainer = "containers" :> Capture "id" Job.ContainerId :> Mutating 'DELETE

type AtomicActions   = "atomic" :> ReqBody '[JSON] [Action] :> Mutating 'POST

-- NB: Make sure the module header is updated with this.
-- | Eclogues API definition.
type API = ListJobs       :<|> JobStatus      :<|> KillJob
      :<|> PatchJob       :<|> JobOnScheduler :<|> DeleteJob :<|> CreateJob
      :<|> ListBoxes      :<|> BoxStatus      :<|> CreateBox :<|> SealBox
      :<|> DeleteBox
      :<|> ListEntities
      :<|> UploadFile     :<|> DownloadFile
      :<|> ListContainers :<|> GetContainer :<|> AddContainer
      :<|> DeleteContainer
      :<|> AtomicActions

data DependencyPatch = DependencyPatch { addDependsOn    :: Job.Dependencies
                                       , removeDependsOn :: [Job.Name] }
                     deriving (Show, Eq, Generic, NFData)

data Action = ActCreateJob { _a1_spec :: Job.Spec } -- field names just for JSON
            | ActKillJob   Job.Name
            | ActPatchJob  { _a2_name :: Job.Name, _a2_patch :: DependencyPatch }
            | ActDeleteJob Job.Name
            | ActCreateBox { _a3_spec :: Job.BoxSpec }
            | ActSealBox   Job.Name
            | ActDeleteBox Job.Name
            deriving (Show, Eq, Generic, NFData)

actCreate :: Job.AnySpec -> Action
actCreate (Job.JobSpec s) = ActCreateJob s
actCreate (Job.BoxSpec s) = ActCreateBox s

-- | A URI with specified scheme and host. The 'uriPath' never ends with @/@.
newtype AbsoluteURI = AbsoluteURI { getAbsoluteURI :: URI.URI } deriving (Show, Eq, Generic, NFData)

parseAbsoluteURI :: (Alternative f) => String -> f AbsoluteURI
parseAbsoluteURI = maybe empty (pure . AbsoluteURI . stripSlash) . URI.parseAbsoluteURI

uriPath :: Lens' AbsoluteURI String
uriPath = lens (URI.uriPath . getAbsoluteURI) (\(AbsoluteURI u) p' -> AbsoluteURI . stripSlash $ u { URI.uriPath = preSlash p' })
  where
    preSlash []        = []
    preSlash s@('/':_) = s
    preSlash s         = '/':s

stripSlash :: URI.URI -> URI.URI
stripSlash u = u{ URI.uriPath = dropWhileEnd (== '/') $ URI.uriPath u }

instance ToJSON AbsoluteURI where
    toJSON = Aeson.String . toUrlPiece

instance FromJSON AbsoluteURI where
    parseJSON (Aeson.String s) = parseAbsoluteURI (unpack s) <|> fail "not a valid absolute URI"
    parseJSON _                = fail "URI should be string"

instance FromHttpApiData AbsoluteURI where
    parseUrlPiece = maybe (Left "not a valid absolute URI") Right . parseAbsoluteURI . unpack

instance ToHttpApiData AbsoluteURI where
    toUrlPiece = pack . show . getAbsoluteURI

-- | An expecation of the stage of a job that must be met for an action to be
-- successful.
data StageExpectation = ExpectExtant
                      | ExpectWaiting     -- ^ @has 'Job._Waiting'@
                      | ExpectTerminated  -- ^ 'Job.isTerminationStage'
                      | ExpectNonFailed   -- ^ @(/= 'Job.NeverAvailable') . 'Job.jobAvailability'@
                      deriving (Show, Eq, Generic, NFData)

satisfiesStageExpectation :: StageExpectation -> Job.Stage -> Bool
satisfiesStageExpectation ExpectExtant      = const True
satisfiesStageExpectation ExpectWaiting     = has Job._Waiting
satisfiesStageExpectation ExpectTerminated  = Job.isTerminationStage
satisfiesStageExpectation ExpectNonFailed   = (/= Job.NeverAvailable) . Job.jobAvailability

displayStageExpectation :: StageExpectation -> Text
displayStageExpectation ExpectExtant      = "must exist"
displayStageExpectation ExpectTerminated  = "must have terminated"
displayStageExpectation ExpectWaiting     = "must be waiting for a dependency"
displayStageExpectation ExpectNonFailed   = "cannot have failed"

-- | The various ways requests can fail.
data JobError =
      NameUsed
    -- | Target resource does not exist.
    | NoSuch
    | JobMustBe { _id :: Job.Name, _expects :: StageExpectation }
    | ContainerMustExist Job.ContainerId
    | FileAlreadyExists { _job :: Job.Name, _filename :: Job.FileId }
    | UploadClosed Job.Name
    -- | A job cannot be deleted because some dependants have not terminated.
    | OutstandingDependants (NonEmpty Job.Name)
    -- | Cannot transition from the current stage to the requested stage.
    | InvalidStageTransition Text
    -- | Cannot contact the scheduler.
    | SchedulerInaccessible
    | AtomicActionError { _action :: Action, _error :: JobError }
    deriving (Show, Eq, Generic, NFData)

-- | A user-friendly description of a 'JobError'.
displayError :: JobError -> Text
displayError NameUsed                     = "Id already in use"
displayError NoSuch                       = "No such resource"
displayError (ContainerMustExist n)       = "Container " <> Job.nameText (Job.getContainerName n) <> " must already exist"
displayError (JobMustBe n ex)             = "Job " <> Job.nameText n <> " " <> displayStageExpectation ex
displayError (FileAlreadyExists jn fn)    = "Job " <> Job.nameText jn <> " already has a file " <> Job.getFileIdText fn
displayError (UploadClosed jn)            = "Job " <> Job.nameText jn <> " is closed to new files"
displayError (OutstandingDependants ns)   = "The following dependants have not completed: " <> intercalate ", " (Job.nameText <$> toList ns)
displayError (InvalidStageTransition msg) = msg
displayError (AtomicActionError a e)      = "Error when processing " <> pack (show a) <> ": " <> displayError e
displayError SchedulerInaccessible        = "Cannot contact the backend scheduler"

$(deriveJSON defaultOptions{ Aeson.constructorTagModifier = drop 6 } ''StageExpectation)
$(deriveJSON defaultOptions{ Aeson.fieldLabelModifier = drop 1 } ''JobError)
$(deriveJSON defaultOptions{ Aeson.fieldLabelModifier = uncurry (++) . fmap (fmap toLower) . splitAt 7 } ''DependencyPatch)
$(deriveJSON defaultOptions{ Aeson.sumEncoding = Aeson.TaggedObject "action" "id", Aeson.constructorTagModifier = drop 3, Aeson.fieldLabelModifier = drop 4 } ''Action)
