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

Skip to content

Commit 8520f05

Browse files
phadejphadej
committed
Re-implement request creation
1 parent 0cc8c51 commit 8520f05

File tree

4 files changed

+215
-114
lines changed

4 files changed

+215
-114
lines changed

‎Github/Data.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@ module Github.Data (
1515
module Github.Data.Issues,
1616
module Github.Data.PullRequests,
1717
module Github.Data.Repos,
18+
module Github.Data.Request,
1819
module Github.Data.Search,
1920
module Github.Data.Teams,
2021
module Github.Data.Webhooks,
@@ -56,6 +57,7 @@ import Github.Data.Issues
5657
import Github.Data.Name
5758
import Github.Data.PullRequests
5859
import Github.Data.Repos
60+
import Github.Data.Request
5961
import Github.Data.Search
6062
import Github.Data.Teams
6163
import Github.Data.Webhooks

‎Github/Data/Request.hs‎

Lines changed: 87 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,87 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE DataKinds #-}
3+
{-# LANGUAGE DeriveDataTypeable #-}
4+
{-# LANGUAGE DeriveGeneric #-}
5+
{-# LANGUAGE GADTs #-}
6+
{-# LANGUAGE KindSignatures #-}
7+
{-# LANGUAGE OverloadedStrings #-}
8+
{-# LANGUAGE StandaloneDeriving #-}
9+
module Github.Data.Request (
10+
GithubRequest(..),
11+
PostMethod(..),
12+
toMethod,
13+
Paths,
14+
QueryString,
15+
) where
16+
17+
#if !MIN_VERSION_base(4,8,0)
18+
import Control.Applicative
19+
#endif
20+
21+
import Data.Aeson.Compat (FromJSON)
22+
import Data.Typeable (Typeable)
23+
import GHC.Generics (Generic)
24+
import Network.HTTP.Types (Status,)
25+
26+
import qualified Data.ByteString.Lazy as LBS
27+
import qualified Network.HTTP.Types.Method as Method
28+
29+
------------------------------------------------------------------------------
30+
-- Auxillary types
31+
------------------------------------------------------------------------------
32+
33+
type Paths = [String]
34+
type QueryString = String
35+
36+
-- | Http method of requests with body.
37+
data PostMethod = Post | Patch | Put
38+
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
39+
40+
toMethod :: PostMethod -> Method.Method
41+
toMethod Post = Method.methodPost
42+
toMethod Patch = Method.methodPatch
43+
toMethod Put = Method.methodPut
44+
45+
------------------------------------------------------------------------------
46+
-- Github request
47+
------------------------------------------------------------------------------
48+
49+
-- | Github request data type.
50+
--
51+
-- * @k@ describes whether authentication is required. It's required for non-@GET@ requests.
52+
-- * @a@ is the result type
53+
--
54+
-- /Note:/ 'GithubRequest' is not 'Functor' on purpose.
55+
--
56+
-- TODO: Add constructor for collection fetches.
57+
data GithubRequest (k :: Bool) a where
58+
GithubGet :: FromJSON a => Paths -> QueryString -> GithubRequest k a
59+
GithubPost :: FromJSON a => PostMethod -> Paths -> LBS.ByteString -> GithubRequest 'True a
60+
GithubDelete :: Paths -> GithubRequest 'True ()
61+
GithubStatus :: GithubRequest k () -> GithubRequest k Status
62+
deriving (Typeable)
63+
64+
deriving instance Eq (GithubRequest k a)
65+
66+
instance Show (GithubRequest k a) where
67+
showsPrec d r =
68+
case r of
69+
GithubGet ps qs -> showParen (d > appPrec) $
70+
showString "GithubGet "
71+
. showsPrec (appPrec + 1) ps
72+
. showString " "
73+
. showsPrec (appPrec + 1) qs
74+
GithubPost m ps body -> showParen (d > appPrec) $
75+
showString "GithubPost "
76+
. showsPrec (appPrec + 1) m
77+
. showString " "
78+
. showsPrec (appPrec + 1) ps
79+
. showString " "
80+
. showsPrec (appPrec + 1) body
81+
GithubDelete ps -> showParen (d > appPrec) $
82+
showString "GithubDelete "
83+
. showsPrec (appPrec + 1) ps
84+
GithubStatus req -> showParen (d > appPrec) $
85+
showString "GithubStatus "
86+
. showsPrec (appPrec + 1) req
87+
where appPrec = 10 :: Int

‎Github/Request.hs‎

Lines changed: 123 additions & 111 deletions
Original file line numberDiff line numberDiff line change
@@ -7,100 +7,46 @@
77
{-# LANGUAGE OverloadedStrings #-}
88
{-# LANGUAGE StandaloneDeriving #-}
99
module Github.Request (
10+
-- * Types
1011
GithubRequest(..),
1112
PostMethod(..),
1213
toMethod,
1314
Paths,
1415
QueryString,
16+
-- * Request execution in IO
1517
executeRequest,
1618
executeRequestWithMgr,
1719
executeRequest',
1820
executeRequestWithMgr',
1921
executeRequestMaybe,
2022
unsafeDropAuthRequirements,
23+
-- * Tools
24+
makeHttpRequest,
2125
) where
2226

2327
#if !MIN_VERSION_base(4,8,0)
2428
import Control.Applicative
2529
#endif
2630

27-
import Data.Aeson.Compat (FromJSON)
28-
import Data.Typeable (Typeable)
29-
import GHC.Generics (Generic)
30-
import Network.HTTP.Conduit (Manager, httpLbs, newManager, tlsManagerSettings)
31-
import Network.HTTP.Types (Status)
32-
33-
import qualified Data.ByteString.Lazy as LBS
34-
import qualified Network.HTTP.Types.Method as Method
35-
36-
import Github.Auth (GithubAuth)
37-
import Github.Data (Error)
38-
39-
import qualified Github.Private as Private
40-
41-
------------------------------------------------------------------------------
42-
-- Auxillary types
43-
------------------------------------------------------------------------------
44-
45-
type Paths = [String]
46-
type QueryString = String
47-
48-
-- | Http method of requests with body.
49-
data PostMethod = Post | Patch | Put
50-
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
51-
52-
toMethod :: PostMethod -> Method.Method
53-
toMethod Post = Method.methodPost
54-
toMethod Patch = Method.methodPatch
55-
toMethod Put = Method.methodPut
56-
57-
------------------------------------------------------------------------------
58-
-- Github request
59-
------------------------------------------------------------------------------
60-
61-
-- | Github request data type.
62-
--
63-
-- * @k@ describes whether authentication is required. It's required for non-@GET@ requests.
64-
-- * @a@ is the result type
65-
--
66-
-- /Note:/ 'GithubRequest' is not 'Functor' on purpose.
67-
--
68-
-- TODO: Add constructor for collection fetches.
69-
data GithubRequest (k :: Bool) a where
70-
GithubGet :: FromJSON a => Paths -> QueryString -> GithubRequest k a
71-
GithubPost :: FromJSON a => PostMethod -> Paths -> LBS.ByteString -> GithubRequest 'True a
72-
GithubDelete :: Paths -> GithubRequest 'True ()
73-
GithubStatus :: GithubRequest k () -> GithubRequest k Status
74-
deriving (Typeable)
75-
76-
deriving instance Eq (GithubRequest k a)
77-
78-
instance Show (GithubRequest k a) where
79-
showsPrec d r =
80-
case r of
81-
GithubGet ps qs -> showParen (d > appPrec) $
82-
showString "GithubGet "
83-
. showsPrec (appPrec + 1) ps
84-
. showString " "
85-
. showsPrec (appPrec + 1) qs
86-
GithubPost m ps body -> showParen (d > appPrec) $
87-
showString "GithubPost "
88-
. showsPrec (appPrec + 1) m
89-
. showString " "
90-
. showsPrec (appPrec + 1) ps
91-
. showString " "
92-
. showsPrec (appPrec + 1) body
93-
GithubDelete ps -> showParen (d > appPrec) $
94-
showString "GithubDelete "
95-
. showsPrec (appPrec + 1) ps
96-
GithubStatus req -> showParen (d > appPrec) $
97-
showString "GithubStatus "
98-
. showsPrec (appPrec + 1) req
99-
where appPrec = 10 :: Int
100-
101-
------------------------------------------------------------------------------
102-
-- Basic IO executor
103-
------------------------------------------------------------------------------
31+
import Control.Monad.Catch (MonadThrow)
32+
import Data.Aeson.Compat (eitherDecode)
33+
import Data.List (intercalate)
34+
import Data.Monoid ((<>))
35+
import Network.HTTP.Client (HttpException (..), Manager, Request (..),
36+
RequestBody (..), Response (..), applyBasicAuth,
37+
httpLbs, newManager, parseUrl, setQueryString)
38+
import Network.HTTP.Client.TLS (tlsManagerSettings)
39+
import Network.HTTP.Types (Method, RequestHeaders, Status (..),
40+
methodDelete)
41+
42+
import qualified Control.Exception as E
43+
import qualified Data.ByteString.Char8 as BS8
44+
import qualified Data.ByteString.Lazy as LBS
45+
import qualified Data.Text as T
46+
47+
import Github.Auth (GithubAuth (..))
48+
import Github.Data (Error (..))
49+
import Github.Data.Request
10450

10551
-- | Execute 'GithubRequest' in 'IO'
10652
executeRequest :: Show a
@@ -121,28 +67,26 @@ executeRequestWithMgr :: Show a
12167
-> IO (Either Error a)
12268
executeRequestWithMgr mgr auth req =
12369
case req of
124-
GithubGet paths qs ->
125-
Private.githubAPI' getResponse
126-
Method.methodGet
127-
(Private.buildPath paths ++ qs')
128-
(Just auth)
129-
Nothing
130-
where qs' | null qs = ""
131-
| otherwise = '?' : qs
132-
GithubPost m paths body ->
133-
Private.githubAPI' getResponse
134-
(toMethod m)
135-
(Private.buildPath paths)
136-
(Just auth)
137-
(Just body)
138-
GithubDelete paths ->
139-
Private.githubAPIDelete' getResponse
140-
auth
141-
(Private.buildPath paths)
142-
GithubStatus _req' ->
143-
error "executeRequestWithMgr GithubStatus not implemented"
144-
where
145-
getResponse = flip httpLbs mgr
70+
GithubGet {} -> do
71+
httpReq <- makeHttpRequest (Just auth) req
72+
res <- httpLbs httpReq mgr
73+
case eitherDecode (responseBody res) of
74+
Right x -> pure . Right $ x
75+
Left err -> pure . Left . ParseError . T.pack $ err
76+
GithubPost {} -> do
77+
httpReq <- makeHttpRequest (Just auth) req
78+
res <- httpLbs httpReq mgr
79+
case eitherDecode (responseBody res) of
80+
Right x -> pure . Right $ x
81+
Left err -> pure . Left . ParseError . T.pack $ err
82+
GithubDelete {} -> do
83+
httpReq <- makeHttpRequest (Just auth) req
84+
_ <- httpLbs httpReq mgr
85+
pure . Right $ ()
86+
GithubStatus {} -> do
87+
httpReq <- makeHttpRequest (Just auth) req
88+
res <- httpLbs httpReq mgr
89+
pure . Right . responseStatus $ res
14690

14791
-- | Like 'executeRequest' but without authentication.
14892
executeRequest' :: Show a
@@ -162,18 +106,16 @@ executeRequestWithMgr' :: Show a
162106
-> IO (Either Error a)
163107
executeRequestWithMgr' mgr req =
164108
case req of
165-
GithubGet paths qs ->
166-
Private.githubAPI' getResponse
167-
Method.methodGet
168-
(Private.buildPath paths ++ qs')
169-
Nothing
170-
Nothing
171-
where qs' | null qs = ""
172-
| otherwise = '?' : qs
173-
GithubStatus (GithubGet _paths _qs) ->
174-
error "executeRequestWithMgr' GithubStatus not implemented"
175-
where
176-
getResponse = flip httpLbs mgr
109+
GithubGet {} -> do
110+
httpReq <- makeHttpRequest Nothing req
111+
res <- httpLbs httpReq mgr
112+
case eitherDecode (responseBody res) of
113+
Right x -> pure . Right $ x
114+
Left err -> pure . Left . ParseError . T.pack $ err
115+
GithubStatus {} -> do
116+
httpReq <- makeHttpRequest Nothing req
117+
res <- httpLbs httpReq mgr
118+
pure . Right . responseStatus $ res
177119

178120
-- | Helper for picking between 'executeRequest' and 'executeRequest''.
179121
--
@@ -188,3 +130,73 @@ unsafeDropAuthRequirements :: GithubRequest 'True a -> GithubRequest k a
188130
unsafeDropAuthRequirements (GithubGet ps qs) = GithubGet ps qs
189131
unsafeDropAuthRequirements r =
190132
error $ "Trying to drop authenatication from" ++ show r
133+
134+
------------------------------------------------------------------------------
135+
-- Tools
136+
------------------------------------------------------------------------------
137+
138+
makeHttpRequest :: MonadThrow m
139+
=> Maybe GithubAuth
140+
-> GithubRequest k a
141+
-> m Request
142+
makeHttpRequest auth r = case r of
143+
GithubStatus req -> makeHttpRequest auth req
144+
GithubGet paths _qs -> do
145+
req <- parseUrl $ url paths
146+
pure $ setReqHeaders
147+
. setCheckStatus
148+
. setAuthRequest auth
149+
. setQueryString []
150+
$ req
151+
GithubPost m paths body -> do
152+
req <- parseUrl $ url paths
153+
pure $ setReqHeaders
154+
. setCheckStatus
155+
. setAuthRequest auth
156+
. setBody body
157+
. setMethod (toMethod m)
158+
$ req
159+
GithubDelete paths -> do
160+
req <- parseUrl $ url paths
161+
pure $ setReqHeaders
162+
. setCheckStatus
163+
. setAuthRequest auth
164+
. setMethod methodDelete
165+
$ req
166+
where
167+
url :: Paths -> String
168+
url paths = baseUrl ++ '/' : intercalate "/" paths
169+
170+
baseUrl :: String
171+
baseUrl = case auth of
172+
Just (GithubEnterpriseOAuth endpoint _) -> endpoint
173+
_ -> "https://api.github.com"
174+
175+
setReqHeaders :: Request -> Request
176+
setReqHeaders req = req { requestHeaders = reqHeaders <> requestHeaders req }
177+
178+
setCheckStatus :: Request -> Request
179+
setCheckStatus req = req { checkStatus = successOrMissing }
180+
181+
setMethod :: Method -> Request -> Request
182+
setMethod m req = req { method = m }
183+
184+
reqHeaders :: RequestHeaders
185+
reqHeaders = maybe [] getOAuthHeader auth
186+
<> [("User-Agent", "github.hs/0.7.4")]
187+
<> [("Accept", "application/vnd.github.preview")]
188+
189+
setBody :: LBS.ByteString -> Request -> Request
190+
setBody body req = req { requestBody = RequestBodyLBS body }
191+
192+
setAuthRequest :: Maybe GithubAuth -> Request -> Request
193+
setAuthRequest (Just (GithubBasicAuth user pass)) = applyBasicAuth user pass
194+
setAuthRequest _ = id
195+
196+
getOAuthHeader :: GithubAuth -> RequestHeaders
197+
getOAuthHeader (GithubOAuth token) = [("Authorization", BS8.pack ("token " ++ token))]
198+
getOAuthHeader _ = []
199+
200+
successOrMissing s@(Status sci _) hs cookiejar
201+
| (200 <= sci && sci < 300) || sci == 404 = Nothing
202+
| otherwise = Just $ E.toException $ StatusCodeException s hs cookiejar

0 commit comments

Comments
 (0)