Thanks to visit codestin.com
Credit goes to github.com

Skip to content

Commit 3373cbf

Browse files
brendanhaybrendanhay
committed
Adding basic deployments and deployment statuses support
1 parent 0f60196 commit 3373cbf

File tree

4 files changed

+277
-0
lines changed

4 files changed

+277
-0
lines changed

‎github.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -75,6 +75,7 @@ Library
7575
GitHub.Data.Content
7676
GitHub.Data.Definitions
7777
GitHub.Data.DeployKeys
78+
GitHub.Data.Deployments
7879
GitHub.Data.Email
7980
GitHub.Data.Events
8081
GitHub.Data.Gists
@@ -122,6 +123,7 @@ Library
122123
GitHub.Endpoints.Repos.Commits
123124
GitHub.Endpoints.Repos.Contents
124125
GitHub.Endpoints.Repos.DeployKeys
126+
GitHub.Endpoints.Repos.Deployments
125127
GitHub.Endpoints.Repos.Forks
126128
GitHub.Endpoints.Repos.Releases
127129
GitHub.Endpoints.Repos.Statuses

‎src/GitHub/Data.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,7 @@ module GitHub.Data (
3737
module GitHub.Data.Content,
3838
module GitHub.Data.Definitions,
3939
module GitHub.Data.DeployKeys,
40+
module GitHub.Data.Deployments,
4041
module GitHub.Data.Email,
4142
module GitHub.Data.Events,
4243
module GitHub.Data.Gists,
@@ -66,6 +67,7 @@ import GitHub.Data.Comments
6667
import GitHub.Data.Content
6768
import GitHub.Data.Definitions
6869
import GitHub.Data.DeployKeys
70+
import GitHub.Data.Deployments
6971
import GitHub.Data.Email
7072
import GitHub.Data.Events
7173
import GitHub.Data.Gists

‎src/GitHub/Data/Deployments.hs‎

Lines changed: 205 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,205 @@
1+
{-# LANGUAGE LambdaCase #-}
2+
3+
module GitHub.Data.Deployments
4+
( DeploymentQueryOption (..)
5+
, renderDeploymentQueryOption
6+
7+
, Deployment (..)
8+
, CreateDeployment (..)
9+
10+
, DeploymentStatus (..)
11+
, DeploymentStatusState (..)
12+
, CreateDeploymentStatus (..)
13+
) where
14+
15+
import Control.Arrow (second)
16+
17+
import Data.ByteString (ByteString)
18+
import Data.Maybe (catMaybes)
19+
import Data.Text (Text)
20+
import Data.Time.Clock (UTCTime)
21+
import Data.Vector (Vector)
22+
23+
import GitHub.Data.Definitions (SimpleUser)
24+
import GitHub.Data.Id (Id)
25+
import GitHub.Data.Name (Name)
26+
import GitHub.Data.URL (URL)
27+
import GitHub.Internal.Prelude
28+
29+
import qualified Data.Aeson as JSON
30+
import qualified Data.Text as Text
31+
import qualified Data.Text.Encoding as Text
32+
33+
data DeploymentQueryOption
34+
= DeploymentQuerySha !Text
35+
| DeploymentQueryRef !Text
36+
| DeploymentQueryTask !Text
37+
| DeploymentQueryEnvironment !Text
38+
deriving (Show, Data, Typeable, Eq, Ord, Generic)
39+
40+
instance NFData DeploymentQueryOption where rnf = genericRnf
41+
instance Binary DeploymentQueryOption
42+
43+
renderDeploymentQueryOption :: DeploymentQueryOption -> (ByteString, ByteString)
44+
renderDeploymentQueryOption =
45+
second Text.encodeUtf8 . \case
46+
DeploymentQuerySha sha -> ("sha", sha)
47+
DeploymentQueryRef ref -> ("ref", ref)
48+
DeploymentQueryTask task -> ("task", task)
49+
DeploymentQueryEnvironment env -> ("environment", env)
50+
51+
data Deployment a = Deployment
52+
{ deploymentUrl :: !URL
53+
, deploymentId :: !(Id (Deployment a))
54+
, deploymentSha :: !(Name (Deployment a))
55+
, deploymentRef :: !Text
56+
, deploymentTask :: !Text
57+
, deploymentPayload :: !(Maybe a)
58+
, deploymentEnvironment :: !Text
59+
, deploymentDescription :: !Text
60+
, deploymentCreator :: !SimpleUser
61+
, deploymentCreatedAt :: !UTCTime
62+
, deploymentUpdatedAt :: !UTCTime
63+
, deploymentStatusesUrl :: !URL
64+
, deploymentRepositoryUrl :: !URL
65+
} deriving (Show, Data, Typeable, Eq, Ord, Generic)
66+
67+
instance NFData a => NFData (Deployment a) where rnf = genericRnf
68+
instance Binary a => Binary (Deployment a)
69+
70+
instance FromJSON a => FromJSON (Deployment a) where
71+
parseJSON = withObject "GitHub Deployment" $ \o ->
72+
Deployment
73+
<$> o .: "url"
74+
<*> o .: "id"
75+
<*> o .: "sha"
76+
<*> o .: "ref"
77+
<*> o .: "task"
78+
<*> o .:? "payload"
79+
<*> o .: "environment"
80+
<*> o .: "description"
81+
<*> o .: "creator"
82+
<*> o .: "created_at"
83+
<*> o .: "updated_at"
84+
<*> o .: "statuses_url"
85+
<*> o .: "repository_url"
86+
87+
data CreateDeployment a = CreateDeployment
88+
{ createDeploymentRef :: !Text
89+
-- ^ Required. The ref to deploy. This can be a branch, tag, or SHA.
90+
, createDeploymentTask :: !(Maybe Text)
91+
-- ^ Specifies a task to execute (e.g., deploy or deploy:migrations).
92+
-- Default: deploy
93+
, createDeploymentAutoMerge :: !(Maybe Bool)
94+
-- ^ Attempts to automatically merge the default branch into the requested
95+
-- ref, if it is behind the default branch. Default: true
96+
, createDeploymentRequiredContexts :: !(Maybe (Vector Text))
97+
-- ^ The status contexts to verify against commit status checks. If this
98+
-- parameter is omitted, then all unique contexts will be verified before a
99+
-- deployment is created. To bypass checking entirely pass an empty array.
100+
-- Defaults to all unique contexts.
101+
, createDeploymentPayload :: !(Maybe a)
102+
-- ^ JSON payload with extra information about the deployment. Default: ""
103+
, createDeploymentEnvironment :: !(Maybe Text)
104+
-- ^ Name for the target deployment environment (e.g., production, staging,
105+
-- qa). Default: production
106+
, createDeploymentDescription :: !(Maybe Text)
107+
-- ^ Short description of the deployment. Default: ""
108+
} deriving (Show, Data, Typeable, Eq, Ord, Generic)
109+
110+
instance NFData a => NFData (CreateDeployment a) where rnf = genericRnf
111+
instance Binary a => Binary (CreateDeployment a)
112+
113+
instance ToJSON a => ToJSON (CreateDeployment a) where
114+
toJSON x =
115+
JSON.object $ catMaybes
116+
[ Just ("ref" .= createDeploymentRef x)
117+
, ("task" .=) <$> createDeploymentTask x
118+
, ("auto_merge" .=) <$> createDeploymentAutoMerge x
119+
, ("required_contexts" .=) <$> createDeploymentRequiredContexts x
120+
, ("payload" .=) <$> createDeploymentPayload x
121+
, ("environment" .=) <$> createDeploymentEnvironment x
122+
, ("description" .=) <$> createDeploymentDescription x
123+
]
124+
125+
data DeploymentStatus = DeploymentStatus
126+
{ deploymentStatusUrl :: !URL
127+
, deploymentStatusId :: !(Id DeploymentStatus)
128+
, deploymentStatusState :: !DeploymentStatusState
129+
, deploymentStatusCreator :: !SimpleUser
130+
, deploymentStatusDescription :: !Text
131+
, deploymentStatusTargetUrl :: !URL
132+
, deploymentStatusCreatedAt :: !UTCTime
133+
, deploymentStatusUpdatedAt :: !UTCTime
134+
, deploymentStatusDeploymentUrl :: !URL
135+
, deploymentStatusRepositoryUrl :: !URL
136+
} deriving (Show, Data, Typeable, Eq, Ord, Generic)
137+
138+
instance NFData DeploymentStatus where rnf = genericRnf
139+
instance Binary DeploymentStatus
140+
141+
instance FromJSON DeploymentStatus where
142+
parseJSON = withObject "GitHub DeploymentStatus" $ \o ->
143+
DeploymentStatus
144+
<$> o .: "url"
145+
<*> o .: "id"
146+
<*> o .: "state"
147+
<*> o .: "creator"
148+
<*> o .: "description"
149+
<*> o .: "target_url"
150+
<*> o .: "created_at"
151+
<*> o .: "updated_at"
152+
<*> o .: "deployment_url"
153+
<*> o .: "repository_url"
154+
155+
data DeploymentStatusState
156+
= DeploymentStatusError
157+
| DeploymentStatusFailure
158+
| DeploymentStatusPending
159+
| DeploymentStatusSuccess
160+
| DeploymentStatusInactive
161+
deriving (Show, Data, Typeable, Eq, Ord, Generic)
162+
163+
instance NFData DeploymentStatusState where rnf = genericRnf
164+
instance Binary DeploymentStatusState
165+
166+
instance ToJSON DeploymentStatusState where
167+
toJSON = \case
168+
DeploymentStatusError -> "error"
169+
DeploymentStatusFailure -> "failure"
170+
DeploymentStatusPending -> "pending"
171+
DeploymentStatusSuccess -> "success"
172+
DeploymentStatusInactive -> "inactive"
173+
174+
instance FromJSON DeploymentStatusState where
175+
parseJSON = withText "GitHub DeploymentStatusState" $ \case
176+
"error" -> pure DeploymentStatusError
177+
"failure" -> pure DeploymentStatusFailure
178+
"pending" -> pure DeploymentStatusPending
179+
"success" -> pure DeploymentStatusSuccess
180+
"inactive" -> pure DeploymentStatusInactive
181+
x -> fail $ "Unknown deployment status: " ++ Text.unpack x
182+
183+
data CreateDeploymentStatus = CreateDeploymentStatus
184+
{ createDeploymentStatusState :: !DeploymentStatusState
185+
-- ^ Required. The state of the status. Can be one of error, failure,
186+
-- pending, or success.
187+
, createDeploymentStatusTargetUrl :: !(Maybe Text) -- TODO: should this be URL?
188+
-- ^ The target URL to associate with this status. This URL should contain
189+
-- output to keep the user updated while the task is running or serve as
190+
-- historical information for what happened in the deployment. Default: ""
191+
, createDeploymentStatusDescription :: !(Maybe Text)
192+
-- ^ A short description of the status. Maximum length of 140 characters.
193+
-- Default: ""
194+
} deriving (Show, Data, Typeable, Eq, Ord, Generic)
195+
196+
instance NFData CreateDeploymentStatus where rnf = genericRnf
197+
instance Binary CreateDeploymentStatus
198+
199+
instance ToJSON CreateDeploymentStatus where
200+
toJSON x =
201+
JSON.object $ catMaybes
202+
[ Just ("state" .= createDeploymentStatusState x)
203+
, ("target_url" .=) <$> createDeploymentStatusTargetUrl x
204+
, ("description" .=) <$> createDeploymentStatusDescription x
205+
]

‎src/GitHub/Endpoints/Repos/Deployments.hs‎

Lines changed: 68 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,68 @@
1+
{-# LANGUAGE LambdaCase #-}
2+
3+
-- | The deployments API, as described at <https://developer.github.com/v3/repos/deployments/>
4+
module GitHub.Endpoints.Repos.Deployments
5+
( deploymentsWithOptionsForR
6+
, createDeploymentR
7+
8+
, deploymentStatusesForR
9+
, createDeploymentStatusR
10+
11+
, module GitHub.Data
12+
) where
13+
14+
import Control.Arrow (second)
15+
16+
import Data.Vector (Vector)
17+
18+
import GitHub.Data
19+
import GitHub.Internal.Prelude
20+
21+
deploymentsWithOptionsForR
22+
:: FromJSON a
23+
=> Name Owner
24+
-> Name Repo
25+
-> FetchCount
26+
-> [DeploymentQueryOption]
27+
-> Request 'RA (Vector (Deployment a))
28+
deploymentsWithOptionsForR owner repo limit opts =
29+
pagedQuery (deployPaths owner repo)
30+
(map (second Just . renderDeploymentQueryOption) opts)
31+
limit
32+
33+
createDeploymentR
34+
:: ( ToJSON a
35+
, FromJSON a
36+
)
37+
=> Name Owner
38+
-> Name Repo
39+
-> CreateDeployment a
40+
-> Request 'RW (Deployment a)
41+
createDeploymentR owner repo =
42+
command Post (deployPaths owner repo) . encode
43+
44+
deploymentStatusesForR
45+
:: Name Owner
46+
-> Name Repo
47+
-> Id (Deployment a)
48+
-> FetchCount
49+
-> Request 'RA (Vector DeploymentStatus)
50+
deploymentStatusesForR owner repo deploy =
51+
pagedQuery (statusesPaths owner repo deploy) []
52+
53+
createDeploymentStatusR
54+
:: Name Owner
55+
-> Name Repo
56+
-> Id (Deployment a)
57+
-> CreateDeploymentStatus
58+
-> Request 'RW DeploymentStatus
59+
createDeploymentStatusR owner repo deploy =
60+
command Post (statusesPaths owner repo deploy) . encode
61+
62+
statusesPaths :: Name Owner -> Name Repo -> Id (Deployment a) -> Paths
63+
statusesPaths owner repo deploy =
64+
deployPaths owner repo ++ [toPathPart deploy, "statuses"]
65+
66+
deployPaths :: Name Owner -> Name Repo -> Paths
67+
deployPaths owner repo =
68+
["repos", toPathPart owner, toPathPart repo, "deployments"]

0 commit comments

Comments
 (0)