{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Fly.Types where import Data.Aeson hiding (Result) import Data.Aeson.Casing import Data.Aeson.TH import Data.HashMap.Strict import Data.Maybe (fromMaybe) import Dhall import Dhall.Core import Dhall.TH import Fly.Internal.AesonOrphans () import Fly.Internal.DhallOrphans () import Fly.Internal.DhallWithPrefix import qualified Data.HashMap.Strict as M data CustomResourceType = CustomResourceType { crtName :: Text , crtType :: Text , crtSource :: Maybe (HashMap Text Value) , crtPrivileged :: Maybe Bool , crtParams :: Maybe (HashMap Text Value) , crtCheckEvery :: Maybe Text , crtTags :: Maybe Text , crtUniqueVersionHistory :: Maybe Bool } deriving (Show, Generic, Eq) deriving FromDhall via FromDhallWithPrefix CustomResourceType data ResourceType = ResourceTypeInBuilt Text | ResourceTypeCustom CustomResourceType deriving (Show, Generic, Eq) instance FromDhall ResourceType where autoWith _ = Dhall.union ( ( ResourceTypeInBuilt <$> constructor "InBuilt" strictText) <> ( ResourceTypeCustom <$> constructor "Custom" auto )) data Resource = Resource { resourceName :: Text , resourceType :: ResourceType , resourceIcon :: Maybe Text , resourcePublic :: Maybe Bool , resourceSource :: Maybe (HashMap Text Value) , resourceVersion :: Maybe (HashMap Text Text) , resourceCheckEvery :: Maybe Text , resourceTags :: Maybe [Text] , resourceWebhookToken :: Maybe Text} deriving (Show, Generic, Eq) deriving FromDhall via FromDhallWithPrefix Resource instance ToJSON Resource where toJSON x = case genericToJSON (aesonPrefix snakeCase) x of Object m -> Object $ M.insert "type" (resourceTypeValue $ resourceType x) m v -> error ("Expected " ++ show v ++ "to be Object") where resourceTypeValue (ResourceTypeInBuilt t) = String t resourceTypeValue (ResourceTypeCustom t) = String $ crtName t data TaskRunConfig = TaskRunConfig { trcPath :: Text , trcArgs :: Maybe [Text] , trcDir :: Maybe Text , trcUser :: Maybe Text } deriving (Show, Generic, Eq) deriving FromDhall via FromDhallWithPrefix TaskRunConfig data TaskImageResource = TaskImageResource { tirType :: Text , tirSource :: Maybe (HashMap Text Value) , tirParams :: Maybe (HashMap Text Value) , tirVersion :: Maybe (HashMap Text Text) } deriving (Show, Generic, Eq) deriving FromDhall via FromDhallWithPrefix TaskImageResource data TaskInput = TaskInput { tiName :: Text , tiPath :: Maybe Text , tiOptional :: Maybe Bool } deriving (Show, Generic, Eq) deriving FromDhall via FromDhallWithPrefix TaskInput data TaskOutput = TaskOutput { toName :: Text, toPath :: Maybe Text } deriving (Show, Generic, Eq) deriving FromDhall via FromDhallWithPrefix TaskOutput newtype TaskCache = TaskCache { taskcachePath :: Text} deriving (Show, Generic, Eq) deriving FromDhall via FromDhallWithPrefix TaskCache data TaskContainerLimits = TaskContainerLimits { tclCpu :: Maybe Natural , tclMemory :: Maybe Natural} deriving (Show, Generic, Eq) deriving FromDhall via FromDhallWithPrefix TaskContainerLimits data TaskConfig = TaskConfig { tcPlatform :: Text , tcRun :: TaskRunConfig , tcImageResource :: Maybe TaskImageResource , tcRootfsUri :: Maybe Text , tcInputs :: Maybe [TaskInput] , tcOutputs :: Maybe [TaskOutput] , tcCaches :: Maybe [TaskCache] , tcParams :: Maybe (HashMap Text (Maybe Text)) , tcContainerLimits :: Maybe TaskContainerLimits } deriving (Show, Generic, Eq) deriving FromDhall via FromDhallWithPrefix TaskConfig data TaskSpec = TaskSpecFile Text | TaskSpecConfig TaskConfig deriving (Show, Generic, Eq) instance FromDhall TaskSpec where autoWith _ = Dhall.union ((TaskSpecFile <$> constructor "File" strictText) <> (TaskSpecConfig <$> constructor "Config" auto)) instance ToJSON TaskSpec where toJSON (TaskSpecFile f) = object [ "file" .= f ] toJSON (TaskSpecConfig c) = object [ "config" .= c ] data GetVersion = GetVersionLatest | GetVersionEvery | GetVersionSpecific (HashMap Text Text) deriving (Show, Generic, Eq) instance ToJSON GetVersion where toJSON GetVersionLatest = String "latest" toJSON GetVersionEvery = String "every" toJSON (GetVersionSpecific v) = toJSON v instance FromDhall GetVersion where autoWith _ = Dhall.union ((GetVersionLatest <$ constructor "Latest" strictText) <> (GetVersionEvery <$ constructor "Every" strictText) <> (GetVersionSpecific <$> constructor "SpecificVersion" auto)) data GetStep = GetStep { getGet :: Maybe Text , getResource :: Resource , getParams :: Maybe (HashMap Text Value) , getVersion :: Maybe GetVersion , getPassed :: Maybe [Text] , getTrigger :: Maybe Bool , getTags :: Maybe [Text] , getTimeout :: Maybe Text , getAttempts :: Maybe Natural } deriving (Show, Generic, Eq) deriving FromDhall via FromDhallWithPrefix GetStep instance ToJSON GetStep where toJSON GetStep{..} = object [ "get" .= fromMaybe (resourceName getResource) getGet , "resource" .= toJSON (resourceName getResource <$ getGet) , "params" .= getParams , "version" .= getVersion , "passed" .= getPassed , "trigger" .= getTrigger , "tags" .= getTags , "timeout" .= getTimeout , "attempts" .= getAttempts ] data PutStep = PutStep { putPut :: Maybe Text , putResource :: Resource , putParams :: Maybe (HashMap Text Value) , putGetParams :: Maybe (HashMap Text Value) , putInputs :: Maybe [Text] , putTags :: Maybe [Text] , putTimeout :: Maybe Text , putAttempts :: Maybe Natural } deriving (Show, Generic, Eq) deriving FromDhall via FromDhallWithPrefix PutStep instance ToJSON PutStep where toJSON PutStep{..} = object [ "put" .= fromMaybe (resourceName putResource) putPut , "resource" .= toJSON (resourceName putResource <$ putPut) , "params" .= putParams , "get_params" .= putGetParams , "tags" .= putTags , "inputs" .= putInputs , "timeout" .= putTimeout , "attempts" .= putAttempts ] data TaskStep = TaskStep { taskTask :: Text , taskConfig :: TaskSpec , taskPrivileged :: Maybe Bool , taskParams :: Maybe (HashMap Text Text) , taskImage :: Maybe Text , taskInputMapping :: Maybe (HashMap Text Text) , taskOutputMapping :: Maybe (HashMap Text Text) , taskVars :: Maybe (HashMap Text Value) , taskTags :: Maybe [Text] , taskTimeout :: Maybe Text , taskAttempts :: Maybe Natural } deriving (Show, Generic, Eq) deriving FromDhall via FromDhallWithPrefix TaskStep instance ToJSON TaskStep where toJSON t@TaskStep{..} = case genericToJSON (aesonPrefix snakeCase) t of Object o1 -> case toJSON taskConfig of Object o2 -> Object (M.delete "config" o1 `M.union` o2) v -> error ("Expected " ++ show v ++ "to be Object") v -> error ("Expected " ++ show v ++ "to be Object") data InParallelStep = InParallelSteps {ipSteps :: [Step]} | InParallelStepConfig {ipConfig :: InParallelConfig} deriving (Show, Generic, Eq) inParallelSteps :: InParallelStep -> [Step] inParallelSteps (InParallelSteps steps ) = steps inParallelSteps (InParallelStepConfig InParallelConfig{..}) = ipcSteps instance ToJSON InParallelStep where toJSON (InParallelSteps steps) = toJSON steps toJSON (InParallelStepConfig cfg) = toJSON cfg instance FromDhall InParallelStep where autoWith _ = Dhall.union ((InParallelSteps <$> constructor "Steps" auto) <> (InParallelStepConfig <$> constructor "Config" auto)) data InParallelConfig = InParallelConfig { ipcSteps :: [Step] , ipcLimit :: Maybe Natural , ipcFailFast :: Maybe Bool } deriving (Show, Generic, Eq) deriving FromDhall via FromDhallWithPrefix InParallelConfig data Step = Get { stepGet :: GetStep, stepHooks :: StepHooks } | Put { stepPut :: PutStep, stepHooks :: StepHooks } | Task { stepTask :: TaskStep, stepHooks :: StepHooks } | Aggregate { aggregatedSteps :: [Step], stepHooks :: StepHooks } | InParallel { stepInParallel :: InParallelStep, stepHooks :: StepHooks } | Do { doSteps :: [Step], stepHooks :: StepHooks } | Try { tryStep :: Step, stepHooks :: StepHooks } deriving (Show, Generic, Eq) instance FromDhall Step where autoWith _ = Dhall.Type{..} where expected = $(staticDhallExpression "./dhall-concourse/types/Step.dhall") extract (Lam _ _ --Step (Lam _ _ --Constructors c)) = extractStepFromConstructors c extract x = extractStepFromConstructors x -- While recursing, only the constructor applications are available extractStepFromConstructors (App (App (Field (Var (V _ 0)) "get") s) hooks) = buildStep Get s hooks extractStepFromConstructors (App (App (Field (Var (V _ 0)) "put") s) hooks) = buildStep Put s hooks extractStepFromConstructors (App (App (Field (Var (V _ 0)) "task") s) hooks) = buildStep Task s hooks extractStepFromConstructors (App (App (Field (Var (V _ 0)) "aggregate") s) hooks) = buildStep Aggregate s hooks extractStepFromConstructors (App (App (Field (Var (V _ 0)) "do") s) hooks) = buildStep Do s hooks extractStepFromConstructors (App (App (Field (Var (V _ 0)) "try") s) hooks) = buildStep Try s hooks extractStepFromConstructors (App (App (Field (Var (V _ 0)) "in_parallel") (App (Field (Union _) "Steps") s)) hooks) = buildStep (InParallel . InParallelSteps ) s hooks extractStepFromConstructors (App (App (Field (Var (V _ 0)) "in_parallel") (App (Field (Union _) "Config") s)) hooks) = buildStep (InParallel . InParallelStepConfig ) s hooks extractStepFromConstructors t = typeError expected t buildStep f x y = f <$> Dhall.extract auto x <*> Dhall.extract auto y mergeHooks :: ToJSON a => a -> StepHooks -> Value mergeHooks step hooks = case toJSON step of Object o1 -> case toJSON hooks of Object o2 -> Object (o1 `M.union` o2) v -> error ("Expected " ++ show v ++ "to be Object") v -> error ("Expected " ++ show v ++ "to be Object") instance ToJSON Step where toJSON (Get g h) = mergeHooks g h toJSON (Put p h) = mergeHooks p h toJSON (Task t h) = mergeHooks t h toJSON (Aggregate steps h) = mergeHooks (object ["aggregate" .= steps]) h toJSON (Do steps h) = mergeHooks (object ["do" .= steps]) h toJSON (Try step h) = mergeHooks (object ["try" .= step]) h toJSON (InParallel cfg h) = mergeHooks (object ["in_parallel" .= cfg]) h data StepHooks = StepHooks { hookOnSuccess :: Maybe Step , hookOnFailure :: Maybe Step , hookOnAbort :: Maybe Step , hookEnsure :: Maybe Step } deriving (Show, Generic, Eq) deriving FromDhall via FromDhallWithPrefix StepHooks data JobBuildLogRetention = JobBuildLogRetention { jblrDays :: Maybe Natural , jblrBuilds :: Maybe Natural } deriving (Show, Generic, Eq) deriving FromDhall via FromDhallWithPrefix JobBuildLogRetention data Job = Job { jobName :: Text , jobOldName :: Maybe Text , jobPlan :: [Step] , jobSerial :: Maybe Bool , jobBuildLogRetention :: Maybe JobBuildLogRetention , jobBuildLogsToRetain :: Maybe Natural , jobSerialGroups :: Maybe [Text] , jobMaxInFlight :: Maybe Natural , jobPublic :: Maybe Bool , jobDisableManualTrigger :: Maybe Bool , jobInterruptible :: Maybe Bool , jobOnSuccess :: Maybe Step , jobOnFailure :: Maybe Step , jobOnAbort :: Maybe Step , jobEnsure :: Maybe Step } deriving (Show, Generic, Eq) deriving FromDhall via FromDhallWithPrefix Job data GroupedJob = GroupedJob { gjJob :: Job, gjGroups :: [Text]} deriving (Show, Generic, Eq) deriving FromDhall via FromDhallWithPrefix GroupedJob $(deriveToJSON (aesonPrefix snakeCase) ''CustomResourceType) $(deriveToJSON (aesonPrefix snakeCase){sumEncoding = UntaggedValue} ''ResourceType) $(deriveToJSON (aesonPrefix snakeCase) ''TaskRunConfig) $(deriveToJSON (aesonPrefix snakeCase) ''TaskImageResource) $(deriveToJSON (aesonPrefix snakeCase) ''TaskInput) $(deriveToJSON (aesonPrefix snakeCase) ''TaskOutput) $(deriveToJSON (aesonPrefix snakeCase) ''TaskCache) $(deriveToJSON (aesonPrefix snakeCase) ''TaskConfig) $(deriveToJSON (aesonPrefix snakeCase) ''TaskContainerLimits) $(deriveToJSON (aesonPrefix snakeCase) ''InParallelConfig) $(deriveToJSON (aesonPrefix snakeCase) ''StepHooks) $(deriveToJSON (aesonPrefix snakeCase) ''JobBuildLogRetention) $(deriveToJSON (aesonPrefix snakeCase) ''Job)