diff --git a/github.cabal b/github.cabal index 29b5dc22..1b07f1ee 100644 --- a/github.cabal +++ b/github.cabal @@ -75,6 +75,7 @@ Library GitHub.Data.Content GitHub.Data.Definitions GitHub.Data.DeployKeys + GitHub.Data.Deployments GitHub.Data.Email GitHub.Data.Events GitHub.Data.Gists @@ -122,6 +123,7 @@ Library GitHub.Endpoints.Repos.Commits GitHub.Endpoints.Repos.Contents GitHub.Endpoints.Repos.DeployKeys + GitHub.Endpoints.Repos.Deployments GitHub.Endpoints.Repos.Forks GitHub.Endpoints.Repos.Releases GitHub.Endpoints.Repos.Statuses diff --git a/src/GitHub/Data.hs b/src/GitHub/Data.hs index 1c935721..b429a99e 100644 --- a/src/GitHub/Data.hs +++ b/src/GitHub/Data.hs @@ -37,6 +37,7 @@ module GitHub.Data ( module GitHub.Data.Content, module GitHub.Data.Definitions, module GitHub.Data.DeployKeys, + module GitHub.Data.Deployments, module GitHub.Data.Email, module GitHub.Data.Events, module GitHub.Data.Gists, @@ -66,6 +67,7 @@ import GitHub.Data.Comments import GitHub.Data.Content import GitHub.Data.Definitions import GitHub.Data.DeployKeys +import GitHub.Data.Deployments import GitHub.Data.Email import GitHub.Data.Events import GitHub.Data.Gists diff --git a/src/GitHub/Data/Deployments.hs b/src/GitHub/Data/Deployments.hs new file mode 100644 index 00000000..8234d998 --- /dev/null +++ b/src/GitHub/Data/Deployments.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE LambdaCase #-} + +module GitHub.Data.Deployments + ( DeploymentQueryOption (..) + , renderDeploymentQueryOption + + , Deployment (..) + , CreateDeployment (..) + + , DeploymentStatus (..) + , DeploymentStatusState (..) + , CreateDeploymentStatus (..) + ) where + +import Control.Arrow (second) + +import Data.ByteString (ByteString) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import Data.Vector (Vector) + +import GitHub.Data.Definitions (SimpleUser) +import GitHub.Data.Id (Id) +import GitHub.Data.Name (Name) +import GitHub.Data.URL (URL) +import GitHub.Internal.Prelude + +import qualified Data.Aeson as JSON +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +data DeploymentQueryOption + = DeploymentQuerySha !Text + | DeploymentQueryRef !Text + | DeploymentQueryTask !Text + | DeploymentQueryEnvironment !Text + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData DeploymentQueryOption where rnf = genericRnf +instance Binary DeploymentQueryOption + +renderDeploymentQueryOption :: DeploymentQueryOption -> (ByteString, ByteString) +renderDeploymentQueryOption = + second Text.encodeUtf8 . \case + DeploymentQuerySha sha -> ("sha", sha) + DeploymentQueryRef ref -> ("ref", ref) + DeploymentQueryTask task -> ("task", task) + DeploymentQueryEnvironment env -> ("environment", env) + +data Deployment a = Deployment + { deploymentUrl :: !URL + , deploymentId :: !(Id (Deployment a)) + , deploymentSha :: !(Name (Deployment a)) + , deploymentRef :: !Text + , deploymentTask :: !Text + , deploymentPayload :: !(Maybe a) + , deploymentEnvironment :: !Text + , deploymentDescription :: !Text + , deploymentCreator :: !SimpleUser + , deploymentCreatedAt :: !UTCTime + , deploymentUpdatedAt :: !UTCTime + , deploymentStatusesUrl :: !URL + , deploymentRepositoryUrl :: !URL + } deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData a => NFData (Deployment a) where rnf = genericRnf +instance Binary a => Binary (Deployment a) + +instance FromJSON a => FromJSON (Deployment a) where + parseJSON = withObject "GitHub Deployment" $ \o -> + Deployment + <$> o .: "url" + <*> o .: "id" + <*> o .: "sha" + <*> o .: "ref" + <*> o .: "task" + <*> o .:? "payload" + <*> o .: "environment" + <*> o .: "description" + <*> o .: "creator" + <*> o .: "created_at" + <*> o .: "updated_at" + <*> o .: "statuses_url" + <*> o .: "repository_url" + +data CreateDeployment a = CreateDeployment + { createDeploymentRef :: !Text + -- ^ Required. The ref to deploy. This can be a branch, tag, or SHA. + , createDeploymentTask :: !(Maybe Text) + -- ^ Specifies a task to execute (e.g., deploy or deploy:migrations). + -- Default: deploy + , createDeploymentAutoMerge :: !(Maybe Bool) + -- ^ Attempts to automatically merge the default branch into the requested + -- ref, if it is behind the default branch. Default: true + , createDeploymentRequiredContexts :: !(Maybe (Vector Text)) + -- ^ The status contexts to verify against commit status checks. If this + -- parameter is omitted, then all unique contexts will be verified before a + -- deployment is created. To bypass checking entirely pass an empty array. + -- Defaults to all unique contexts. + , createDeploymentPayload :: !(Maybe a) + -- ^ JSON payload with extra information about the deployment. Default: "" + , createDeploymentEnvironment :: !(Maybe Text) + -- ^ Name for the target deployment environment (e.g., production, staging, + -- qa). Default: production + , createDeploymentDescription :: !(Maybe Text) + -- ^ Short description of the deployment. Default: "" + } deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData a => NFData (CreateDeployment a) where rnf = genericRnf +instance Binary a => Binary (CreateDeployment a) + +instance ToJSON a => ToJSON (CreateDeployment a) where + toJSON x = + JSON.object $ catMaybes + [ Just ("ref" .= createDeploymentRef x) + , ("task" .=) <$> createDeploymentTask x + , ("auto_merge" .=) <$> createDeploymentAutoMerge x + , ("required_contexts" .=) <$> createDeploymentRequiredContexts x + , ("payload" .=) <$> createDeploymentPayload x + , ("environment" .=) <$> createDeploymentEnvironment x + , ("description" .=) <$> createDeploymentDescription x + ] + +data DeploymentStatus = DeploymentStatus + { deploymentStatusUrl :: !URL + , deploymentStatusId :: !(Id DeploymentStatus) + , deploymentStatusState :: !DeploymentStatusState + , deploymentStatusCreator :: !SimpleUser + , deploymentStatusDescription :: !Text + , deploymentStatusTargetUrl :: !URL + , deploymentStatusCreatedAt :: !UTCTime + , deploymentStatusUpdatedAt :: !UTCTime + , deploymentStatusDeploymentUrl :: !URL + , deploymentStatusRepositoryUrl :: !URL + } deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData DeploymentStatus where rnf = genericRnf +instance Binary DeploymentStatus + +instance FromJSON DeploymentStatus where + parseJSON = withObject "GitHub DeploymentStatus" $ \o -> + DeploymentStatus + <$> o .: "url" + <*> o .: "id" + <*> o .: "state" + <*> o .: "creator" + <*> o .: "description" + <*> o .: "target_url" + <*> o .: "created_at" + <*> o .: "updated_at" + <*> o .: "deployment_url" + <*> o .: "repository_url" + +data DeploymentStatusState + = DeploymentStatusError + | DeploymentStatusFailure + | DeploymentStatusPending + | DeploymentStatusSuccess + | DeploymentStatusInactive + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData DeploymentStatusState where rnf = genericRnf +instance Binary DeploymentStatusState + +instance ToJSON DeploymentStatusState where + toJSON = \case + DeploymentStatusError -> "error" + DeploymentStatusFailure -> "failure" + DeploymentStatusPending -> "pending" + DeploymentStatusSuccess -> "success" + DeploymentStatusInactive -> "inactive" + +instance FromJSON DeploymentStatusState where + parseJSON = withText "GitHub DeploymentStatusState" $ \case + "error" -> pure DeploymentStatusError + "failure" -> pure DeploymentStatusFailure + "pending" -> pure DeploymentStatusPending + "success" -> pure DeploymentStatusSuccess + "inactive" -> pure DeploymentStatusInactive + x -> fail $ "Unknown deployment status: " ++ Text.unpack x + +data CreateDeploymentStatus = CreateDeploymentStatus + { createDeploymentStatusState :: !DeploymentStatusState + -- ^ Required. The state of the status. Can be one of error, failure, + -- pending, or success. + , createDeploymentStatusTargetUrl :: !(Maybe Text) -- TODO: should this be URL? + -- ^ The target URL to associate with this status. This URL should contain + -- output to keep the user updated while the task is running or serve as + -- historical information for what happened in the deployment. Default: "" + , createDeploymentStatusDescription :: !(Maybe Text) + -- ^ A short description of the status. Maximum length of 140 characters. + -- Default: "" + } deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData CreateDeploymentStatus where rnf = genericRnf +instance Binary CreateDeploymentStatus + +instance ToJSON CreateDeploymentStatus where + toJSON x = + JSON.object $ catMaybes + [ Just ("state" .= createDeploymentStatusState x) + , ("target_url" .=) <$> createDeploymentStatusTargetUrl x + , ("description" .=) <$> createDeploymentStatusDescription x + ] diff --git a/src/GitHub/Endpoints/Repos/Deployments.hs b/src/GitHub/Endpoints/Repos/Deployments.hs new file mode 100644 index 00000000..21c29587 --- /dev/null +++ b/src/GitHub/Endpoints/Repos/Deployments.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE LambdaCase #-} + +-- | The deployments API, as described at +module GitHub.Endpoints.Repos.Deployments + ( deploymentsWithOptionsForR + , createDeploymentR + + , deploymentStatusesForR + , createDeploymentStatusR + + , module GitHub.Data + ) where + +import Control.Arrow (second) + +import Data.Vector (Vector) + +import GitHub.Data +import GitHub.Internal.Prelude + +deploymentsWithOptionsForR + :: FromJSON a + => Name Owner + -> Name Repo + -> FetchCount + -> [DeploymentQueryOption] + -> Request 'RA (Vector (Deployment a)) +deploymentsWithOptionsForR owner repo limit opts = + pagedQuery (deployPaths owner repo) + (map (second Just . renderDeploymentQueryOption) opts) + limit + +createDeploymentR + :: ( ToJSON a + , FromJSON a + ) + => Name Owner + -> Name Repo + -> CreateDeployment a + -> Request 'RW (Deployment a) +createDeploymentR owner repo = + command Post (deployPaths owner repo) . encode + +deploymentStatusesForR + :: Name Owner + -> Name Repo + -> Id (Deployment a) + -> FetchCount + -> Request 'RA (Vector DeploymentStatus) +deploymentStatusesForR owner repo deploy = + pagedQuery (statusesPaths owner repo deploy) [] + +createDeploymentStatusR + :: Name Owner + -> Name Repo + -> Id (Deployment a) + -> CreateDeploymentStatus + -> Request 'RW DeploymentStatus +createDeploymentStatusR owner repo deploy = + command Post (statusesPaths owner repo deploy) . encode + +statusesPaths :: Name Owner -> Name Repo -> Id (Deployment a) -> Paths +statusesPaths owner repo deploy = + deployPaths owner repo ++ [toPathPart deploy, "statuses"] + +deployPaths :: Name Owner -> Name Repo -> Paths +deployPaths owner repo = + ["repos", toPathPart owner, toPathPart repo, "deployments"]