@@ -4,8 +4,10 @@
4{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE RecordWildCards #-}
9{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE TypeOperators #-}
13{-# LANGUAGE TypeOperators #-}
@@ -21,26 +23,47 @@
22module Network.Google.Client where
24module Network.Google.Client where
26+import Control.Exception
24import Control.Lens
27import Control.Lens
28+import Control.Monad.Trans.Class
29+import Control.Monad.Trans.Reader
30+import Control.Monad.Trans.Resource
25−import Data.ByteString (ByteString)
32+import Data.ByteString (ByteString)
26−import qualified Data.ByteString.Lazy as LBS
33+import qualified Data.ByteString.Lazy as LBS
35+import qualified Data.Conduit.List as CL
27import Data.Data
36import Data.Data
37+import Data.Default.Class (def)
28−import Data.DList (DList)
38+import Data.DList (DList)
29−import qualified Data.DList as DList
39+import qualified Data.DList as DList
30−import Data.Foldable (foldMap, foldl')
40+import Data.Foldable (foldMap, foldl')
31−import Data.List (intersperse)
41+import Data.List (intersperse)
32import Data.Monoid
43import Data.Monoid
33import Data.Proxy
44import Data.Proxy
34−import Data.Text (Text)
45+import Data.Text (Text)
35−import qualified Data.Text as Text
46+import qualified Data.Text as Text
36−import Data.Text.Lazy.Builder (Builder)
47+import Data.Text.Lazy.Builder (Builder)
37−import qualified Data.Text.Lazy.Builder as Build
48+import qualified Data.Text.Lazy.Builder as Build
38import GHC.Generics
49import GHC.Generics
39import GHC.TypeLits
50import GHC.TypeLits
40import Network.Google.Types
51import Network.Google.Types
52+import Network.HTTP.Client (HttpException)
53+import Network.HTTP.Conduit (Manager)
54+import qualified Network.HTTP.Conduit as Client
41import Network.HTTP.Media
55import Network.HTTP.Media
42import Network.HTTP.Types
56import Network.HTTP.Types
43−import Servant.API hiding (Header)
57+import Servant.API hiding (Header)
59+-- | A convenience alias to avoid type ambiguity.
60+type ClientRequest = Client.Request
62+-- | A convenience alias encapsulating the common 'Response'.
63+type ClientResponse = Client.Response ResponseBody
65+-- | A convenience alias encapsulating the common 'Response' body.
66+type ResponseBody = ResumableSource (ResourceT IO) ByteString
45-- import Servant.API
68-- import Servant.API
46-- import Servant.Utils.Links
69-- import Servant.Utils.Links
@@ -59,11 +82,11 @@ data Request = Request
59 , _rqAccept :: [MediaType]
82 , _rqAccept :: [MediaType]
62−defaultRequest :: ByteString -- ^ Host.
85+initialRequest :: ByteString -- ^ Host.
63 -> Int -- ^ Port.
86 -> Int -- ^ Port.
64 -> ByteString -- ^ Base Path.
87 -> ByteString -- ^ Base Path.
65 -> Request
88 -> Request
66−defaultRequest h n p = Request
89+initialRequest h n p = Request
67 { _rqHost = h
90 { _rqHost = h
68 , _rqPort = n
91 , _rqPort = n
69 , _rqBasePath = p
92 , _rqBasePath = p
@@ -74,6 +97,12 @@ defaultRequest h n p = Request
74 , _rqAccept = mempty
97 , _rqAccept = mempty
100+clientRequest :: Method -> Request -> ClientRequest
101+clientRequest m Request {..} = def
103+ , Client.checkStatus = \_ _ _ -> Nothing
77appendPath :: Request -> Builder -> Request
106appendPath :: Request -> Builder -> Request
78appendPath rq x = rq { _rqPath = _rqPath rq <> "/" <> x }
107appendPath rq x = rq { _rqPath = _rqPath rq <> "/" <> x }
@@ -86,17 +115,62 @@ appendQuery rq k v = rq { _rqQuery = DList.snoc (_rqQuery rq) (k, v) }
86setBody :: Request -> MediaType -> LBS.ByteString -> Request
115setBody :: Request -> MediaType -> LBS.ByteString -> Request
87setBody rq c x = rq { _rqBody = Just (c, x) }
116setBody rq c x = rq { _rqBody = Just (c, x) }
89−buildText :: ToText a => a -> Builder
118+data Error
90−buildText = Build.fromText . toText
119+ = TransportError HttpException
120+ | SerializeError SerializeError
121+ | ServiceError ServiceError
122+ deriving (Show, Typeable)
92−buildSymbol :: forall n proxy. KnownSymbol n => proxy n -> Builder
124+instance Exception Error
93−buildSymbol = Build.fromString . symbolVal
95−textSymbol :: forall n proxy. KnownSymbol n => proxy n -> Text
126+data SerializeError = SerializeError'
96−textSymbol = Text.pack . symbolVal
127+ -- , _serializeHeaders :: [Header]
128+ { -- _serializeAbbrev :: !Abbrev
129+ -- , _serializeStatus :: !Status
130+ -- , _serializeMessage :: String
131+ } deriving (Eq, Show, Typeable)
98−data Error = Error
133+data ServiceError = ServiceError' !Status !MediaType [Header] LBS.ByteString
134+ -- _serviceAbbrev :: !Abbrev
135+ -- , _serviceStatus :: !Status
136+ -- , _serviceHeaders :: [Header]
137+ -- , _serviceCode :: !ErrorCode
138+ -- , _serviceMessage :: Maybe ErrorMessage
139+ -- , _serviceRequestId :: Maybe RequestId
99− deriving (Generic, Data, Typeable)
140+ deriving (Eq, Show, Typeable)
142+class AsError a where
143+ -- | A general Amazonka error.
144+ _Error :: Prism' a Error
145+ {-# MINIMAL _Error #-}
147+ -- | An error occured while communicating over HTTP with a remote service.
148+ _TransportError :: Prism' a HttpException
150+ -- | A serialisation error occured when attempting to deserialise a response.
151+ _SerializeError :: Prism' a SerializeError
153+ -- | A service specific error returned by the remote service.
154+ _ServiceError :: Prism' a ServiceError
156+ _TransportError = _Error . _TransportError
157+ _SerializeError = _Error . _SerializeError
158+ _ServiceError = _Error . _ServiceError
160+instance AsError Error where
163+ _TransportError = prism TransportError $ \case
164+ TransportError e -> Right e
167+ _SerializeError = prism SerializeError $ \case
168+ SerializeError e -> Right e
171+ _ServiceError = prism ServiceError $ \case
172+ ServiceError e -> Right e
101data Captures (s :: Symbol) a
175data Captures (s :: Symbol) a
102 deriving (Typeable)
176 deriving (Typeable)
@@ -104,9 +178,21 @@ data Captures (s :: Symbol) a
104data CaptureMode (s :: Symbol) (m :: Symbol) a
178data CaptureMode (s :: Symbol) (m :: Symbol) a
105 deriving (Typeable)
179 deriving (Typeable)
107−data MultipartRelated (cs :: [*]) meta body
181+data MultipartRelated (cs :: [*]) m b
108 deriving (Typeable)
182 deriving (Typeable)
184+instance ( MimeRender c m
186+ ) => GoogleClient (MultipartRelated (c ': cs) m b :> fn) where
187+ type Fn (MultipartRelated (c ': cs) m b :> fn) = m -> b -> Fn fn
189+ -- requestBuild Proxy rq m b = requestBuild (Proxy :: Proxy fn) $
191+ -- mimeRender (Proxy :: Proxy OctetStream) b
193+ -- p = Proxy :: Proxy c
110class GoogleRequest a where
196class GoogleRequest a where
111 type Rs a :: *
197 type Rs a :: *
@@ -199,43 +285,90 @@ instance ( MimeRender c a
199 p = Proxy :: Proxy c
285 p = Proxy :: Proxy c
201instance MimeUnrender c a => GoogleClient (Get (c ': cs) a) where
287instance MimeUnrender c a => GoogleClient (Get (c ': cs) a) where
202− type Fn (Get (c ': cs) a) = IO (Either Error a)
288+ type Fn (Get (c ': cs) a) = Client a
290+ requestBuild Proxy = perform methodGet [200, 203]
292+instance GoogleClient (Get (c ': cs) Body) where
293+ type Fn (Get (c ': cs) Body) = Client Body
204− requestBuild Proxy rq = undefined -- perform . methodGet [200, 203]
295+ requestBuild Proxy = perform methodGet [204]
206instance GoogleClient (Get (c ': cs) ()) where
297instance GoogleClient (Get (c ': cs) ()) where
207− type Fn (Get (c ': cs) ()) = IO (Either Error ())
298+ type Fn (Get (c ': cs) ()) = Client ()
209− requestBuild Proxy rq = undefined -- perform . methodGet [204]
300+ requestBuild Proxy = perform methodGet [204]
211instance MimeUnrender c a => GoogleClient (Post (c ': cs) a) where
302instance MimeUnrender c a => GoogleClient (Post (c ': cs) a) where
212− type Fn (Post (c ': cs) a) = IO (Either Error a)
303+ type Fn (Post (c ': cs) a) = Client a
214− requestBuild Proxy rq = undefined -- perform . methodPost [200, 201]
305+ requestBuild Proxy = perform methodPost [200, 201]
216instance GoogleClient (Post (c ': cs) ()) where
307instance GoogleClient (Post (c ': cs) ()) where
217− type Fn (Post (c ': cs) ()) = IO (Either Error ())
308+ type Fn (Post (c ': cs) ()) = Client ()
219− requestBuild Proxy rq = undefined -- perform . methodPost [204]
310+ requestBuild Proxy = perform methodPost [204]
221instance MimeUnrender c a => GoogleClient (Put (c ': cs) a) where
312instance MimeUnrender c a => GoogleClient (Put (c ': cs) a) where
222− type Fn (Put (c ': cs) a) = IO (Either Error a)
313+ type Fn (Put (c ': cs) a) = Client a
224− requestBuild Proxy rq = undefined -- perform . methodPut [200, 201]
315+ requestBuild Proxy = perform methodPut [200, 201]
226instance GoogleClient (Put (c ': cs) ()) where
317instance GoogleClient (Put (c ': cs) ()) where
227− type Fn (Put (c ': cs) ()) = IO (Either Error ())
318+ type Fn (Put (c ': cs) ()) = Client ()
229− requestBuild Proxy rq = undefined -- perform . methodPut [204]
320+ requestBuild Proxy = perform methodPut [204]
231instance MimeUnrender c a => GoogleClient (Patch (c ': cs) a) where
322instance MimeUnrender c a => GoogleClient (Patch (c ': cs) a) where
232− type Fn (Patch (c ': cs) a) = IO (Either Error a)
323+ type Fn (Patch (c ': cs) a) = Client a
234− requestBuild Proxy rq = undefined -- perform . methodPatch [200, 201]
325+ requestBuild Proxy = perform methodPatch [200, 201]
236instance GoogleClient (Patch (c ': cs) ()) where
327instance GoogleClient (Patch (c ': cs) ()) where
237− type Fn (Patch (c ': cs) ()) = IO (Either Error ())
328+ type Fn (Patch (c ': cs) ()) = Client ()
330+ requestBuild Proxy = perform methodPatch [204]
332+type Client a = ReaderT Manager IO (Either Error a)
334+perform :: forall c a. Proxy c
337+ -> (ResponseBody -> IO (Either SerializeError a))
340+perform Proxy meth ns f rq = do
342+ x <- lift . try $ Client.http m (clientRequest meth rq)
343+ either (failure . TransportError) success x
345+ failure = pure . Left
348+ let s = Client.responseStatus rs
349+ b = Client.responseBody rs
350+ hs = Client.responseHeaders rs
352+ Nothing -> failure (SerializeError' (SerializeError hs))
354+ Just c | check s -> first SerializeError' <$> f b
239− requestBuild Proxy rq = undefined -- perform . methodPatch [204]
356+ Just c -> do
357+ lbs <- b $$+- CL.consume
358+ failure (ServiceError' (ServiceError s c hs lbs))
241−-- MultipartRelated
360+ content :: [Header] -> Maybe c
361+ content = parseAccept
362+ . fromMaybe "application/octet-stream"
363+ . lookup hContentType
365+ check s = fromEnum s `elem` ns
367+buildText :: ToText a => a -> Builder
368+buildText = Build.fromText . toText
370+buildSymbol :: forall n proxy. KnownSymbol n => proxy n -> Builder
371+buildSymbol = Build.fromString . symbolVal
373+textSymbol :: forall n proxy. KnownSymbol n => proxy n -> Text
374+textSymbol = Text.pack . symbolVal