@@ -4,8 +4,10 @@
44{-# LANGUAGE FlexibleContexts #-}
55{-# LANGUAGE FlexibleInstances #-}
66{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+{-# LANGUAGE LambdaCase #-}
78{-# LANGUAGE MultiParamTypeClasses #-}
89{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE RecordWildCards #-}
911{-# LANGUAGE ScopedTypeVariables #-}
1012{-# LANGUAGE TypeFamilies #-}
1113{-# LANGUAGE TypeOperators #-}
@@ -21,26 +23,47 @@
2123--
2224module Network.Google.Client where
2325
26+import Control.Exception
2427import Control.Lens
25−import Data.ByteString (ByteString)
26−import qualified Data.ByteString.Lazy as LBS
28+import Control.Monad.Trans.Class
29+import Control.Monad.Trans.Reader
30+import Control.Monad.Trans.Resource
31+import Data.Bifunctor
32+import Data.ByteString (ByteString)
33+import qualified Data.ByteString.Lazy as LBS
34+import Data.Conduit
35+import qualified Data.Conduit.List as CL
2736import Data.Data
28−import Data.DList (DList)
29−import qualified Data.DList as DList
30−import Data.Foldable (foldMap, foldl')
31−import Data.List (intersperse)
37+import Data.Default.Class (def)
38+import Data.DList (DList)
39+import qualified Data.DList as DList
40+import Data.Foldable (foldMap, foldl')
41+import Data.List (intersperse)
42+import Data.Maybe
3243import Data.Monoid
3344import Data.Proxy
34−import Data.Text (Text)
35−import qualified Data.Text as Text
36−import Data.Text.Lazy.Builder (Builder)
37−import qualified Data.Text.Lazy.Builder as Build
45+import Data.Text (Text)
46+import qualified Data.Text as Text
47+import Data.Text.Lazy.Builder (Builder)
48+import qualified Data.Text.Lazy.Builder as Build
3849import GHC.Generics
3950import GHC.TypeLits
4051import Network.Google.Types
52+import Network.HTTP.Client (HttpException)
53+import Network.HTTP.Conduit (Manager)
54+import qualified Network.HTTP.Conduit as Client
4155import Network.HTTP.Media
4256import Network.HTTP.Types
43−import Servant.API hiding (Header)
57+import Servant.API hiding (Header)
58+
59+-- | A convenience alias to avoid type ambiguity.
60+type ClientRequest = Client.Request
61+
62+-- | A convenience alias encapsulating the common 'Response'.
63+type ClientResponse = Client.Response ResponseBody
64+
65+-- | A convenience alias encapsulating the common 'Response' body.
66+type ResponseBody = ResumableSource (ResourceT IO) ByteString
4467
4568-- import Servant.API
4669-- import Servant.Utils.Links
@@ -59,11 +82,11 @@ data Request = Request
5982 , _rqAccept :: [MediaType]
6083 }
6184
62−defaultRequest :: ByteString -- ^ Host.
85+initialRequest :: ByteString -- ^ Host.
6386 -> Int -- ^ Port.
6487 -> ByteString -- ^ Base Path.
6588 -> Request
66−defaultRequest h n p = Request
89+initialRequest h n p = Request
6790 { _rqHost = h
6891 , _rqPort = n
6992 , _rqBasePath = p
@@ -74,6 +97,12 @@ defaultRequest h n p = Request
7497 , _rqAccept = mempty
7598 }
7699
100+clientRequest :: Method -> Request -> ClientRequest
101+clientRequest m Request {..} = def
102+ { Client.method = m
103+ , Client.checkStatus = \_ _ _ -> Nothing
104+ }
105+
77106appendPath :: Request -> Builder -> Request
78107appendPath rq x = rq { _rqPath = _rqPath rq <> "/" <> x }
79108
@@ -86,17 +115,62 @@ appendQuery rq k v = rq { _rqQuery = DList.snoc (_rqQuery rq) (k, v) }
86115setBody :: Request -> MediaType -> LBS.ByteString -> Request
87116setBody rq c x = rq { _rqBody = Just (c, x) }
88117
89−buildText :: ToText a => a -> Builder
90−buildText = Build.fromText . toText
118+data Error
119+ = TransportError HttpException
120+ | SerializeError SerializeError
121+ | ServiceError ServiceError
122+ deriving (Show, Typeable)
91123
92−buildSymbol :: forall n proxy. KnownSymbol n => proxy n -> Builder
93−buildSymbol = Build.fromString . symbolVal
124+instance Exception Error
94125
95−textSymbol :: forall n proxy. KnownSymbol n => proxy n -> Text
96−textSymbol = Text.pack . symbolVal
126+data SerializeError = SerializeError'
127+ -- , _serializeHeaders :: [Header]
128+ { -- _serializeAbbrev :: !Abbrev
129+ -- , _serializeStatus :: !Status
130+ -- , _serializeMessage :: String
131+ } deriving (Eq, Show, Typeable)
97132
98−data Error = Error
99− deriving (Generic, Data, Typeable)
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
140+ deriving (Eq, Show, Typeable)
141+
142+class AsError a where
143+ -- | A general Amazonka error.
144+ _Error :: Prism' a Error
145+ {-# MINIMAL _Error #-}
146+
147+ -- | An error occured while communicating over HTTP with a remote service.
148+ _TransportError :: Prism' a HttpException
149+
150+ -- | A serialisation error occured when attempting to deserialise a response.
151+ _SerializeError :: Prism' a SerializeError
152+
153+ -- | A service specific error returned by the remote service.
154+ _ServiceError :: Prism' a ServiceError
155+
156+ _TransportError = _Error . _TransportError
157+ _SerializeError = _Error . _SerializeError
158+ _ServiceError = _Error . _ServiceError
159+
160+instance AsError Error where
161+ _Error = id
162+
163+ _TransportError = prism TransportError $ \case
164+ TransportError e -> Right e
165+ x -> Left x
166+
167+ _SerializeError = prism SerializeError $ \case
168+ SerializeError e -> Right e
169+ x -> Left x
170+
171+ _ServiceError = prism ServiceError $ \case
172+ ServiceError e -> Right e
173+ x -> Left x
100174
101175data Captures (s :: Symbol) a
102176 deriving (Typeable)
@@ -104,9 +178,21 @@ data Captures (s :: Symbol) a
104178data CaptureMode (s :: Symbol) (m :: Symbol) a
105179 deriving (Typeable)
106180
107−data MultipartRelated (cs :: [*]) meta body
181+data MultipartRelated (cs :: [*]) m b
108182 deriving (Typeable)
109183
184+instance ( MimeRender c m
185+ , GoogleClient fn
186+ ) => GoogleClient (MultipartRelated (c ': cs) m b :> fn) where
187+ type Fn (MultipartRelated (c ': cs) m b :> fn) = m -> b -> Fn fn
188+
189+ -- requestBuild Proxy rq m b = requestBuild (Proxy :: Proxy fn) $
190+ -- mimeRender p m
191+ -- mimeRender (Proxy :: Proxy OctetStream) b
192+ -- where
193+ -- p = Proxy :: Proxy c
194+
195+
110196class GoogleRequest a where
111197 type Rs a :: *
112198
@@ -199,43 +285,90 @@ instance ( MimeRender c a
199285 p = Proxy :: Proxy c
200286
201287instance 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
289+
290+ requestBuild Proxy = perform methodGet [200, 203]
291+
292+instance GoogleClient (Get (c ': cs) Body) where
293+ type Fn (Get (c ': cs) Body) = Client Body
203294
204− requestBuild Proxy rq = undefined -- perform . methodGet [200, 203]
295+ requestBuild Proxy = perform methodGet [204]
205296
206297instance GoogleClient (Get (c ': cs) ()) where
207− type Fn (Get (c ': cs) ()) = IO (Either Error ())
298+ type Fn (Get (c ': cs) ()) = Client ()
208299
209− requestBuild Proxy rq = undefined -- perform . methodGet [204]
300+ requestBuild Proxy = perform methodGet [204]
210301
211302instance 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
213304
214− requestBuild Proxy rq = undefined -- perform . methodPost [200, 201]
305+ requestBuild Proxy = perform methodPost [200, 201]
215306
216307instance GoogleClient (Post (c ': cs) ()) where
217− type Fn (Post (c ': cs) ()) = IO (Either Error ())
308+ type Fn (Post (c ': cs) ()) = Client ()
218309
219− requestBuild Proxy rq = undefined -- perform . methodPost [204]
310+ requestBuild Proxy = perform methodPost [204]
220311
221312instance 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
223314
224− requestBuild Proxy rq = undefined -- perform . methodPut [200, 201]
315+ requestBuild Proxy = perform methodPut [200, 201]
225316
226317instance GoogleClient (Put (c ': cs) ()) where
227− type Fn (Put (c ': cs) ()) = IO (Either Error ())
318+ type Fn (Put (c ': cs) ()) = Client ()
228319
229− requestBuild Proxy rq = undefined -- perform . methodPut [204]
320+ requestBuild Proxy = perform methodPut [204]
230321
231322instance 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
233324
234− requestBuild Proxy rq = undefined -- perform . methodPatch [200, 201]
325+ requestBuild Proxy = perform methodPatch [200, 201]
235326
236327instance GoogleClient (Patch (c ': cs) ()) where
237− type Fn (Patch (c ': cs) ()) = IO (Either Error ())
328+ type Fn (Patch (c ': cs) ()) = Client ()
329+
330+ requestBuild Proxy = perform methodPatch [204]
331+
332+type Client a = ReaderT Manager IO (Either Error a)
333+
334+perform :: forall c a. Proxy c
335+ -> Method
336+ -> [Int]
337+ -> (ResponseBody -> IO (Either SerializeError a))
338+ -> Request
339+ -> Client a
340+perform Proxy meth ns f rq = do
341+ m <- ask
342+ x <- lift . try $ Client.http m (clientRequest meth rq)
343+ either (failure . TransportError) success x
344+ where
345+ failure = pure . Left
346+
347+ success rs = do
348+ let s = Client.responseStatus rs
349+ b = Client.responseBody rs
350+ hs = Client.responseHeaders rs
351+ case content hs of
352+ Nothing -> failure (SerializeError' (SerializeError hs))
353+
354+ Just c | check s -> first SerializeError' <$> f b
238355
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))
240359
241−-- MultipartRelated
360+ content :: [Header] -> Maybe c
361+ content = parseAccept
362+ . fromMaybe "application/octet-stream"
363+ . lookup hContentType
364+
365+ check s = fromEnum s `elem` ns
366+
367+buildText :: ToText a => a -> Builder
368+buildText = Build.fromText . toText
369+
370+buildSymbol :: forall n proxy. KnownSymbol n => proxy n -> Builder
371+buildSymbol = Build.fromString . symbolVal
372+
373+textSymbol :: forall n proxy. KnownSymbol n => proxy n -> Text
374+textSymbol = Text.pack . symbolVal