git.iko.soy/gogol
on develop help sign in
Merging Client and Types modules
commitf36b2c07404c5a49ed646486666753369eb826b0 authorBrendan Hay <brendan.g.hay@gmail.com> dateTue 6 Oct 2015, 13:35 (11 years ago) parentfa413f6
5 files changed+466−576
compare with develop
unifiedsplit
core/gogol-core.cabal+9−11 core/src/Network/Google/Client.hs−451 core/src/Network/Google/Data/JSON.hs−1 core/src/Network/Google/Prelude.hs−110 core/src/Network/Google/Types.hs+457−3
core/gogol-core.cabal+9−11
@@ -36,32 +36,30 @@ library
3636 ghc-options: -Wall
3737
3838 exposed-modules:
39− Network.Google.Client
40− , Network.Google.Data.JSON
39+ Network.Google.Data.JSON
4140 , Network.Google.Data.Numeric
4241 , Network.Google.Data.Time
4342 , Network.Google.Prelude
4443 , Network.Google.Types
4544
4645 build-depends:
47− aeson >= 0.8
48− , base >= 4.7 && < 5
46+ aeson >= 0.8
47+ , base >= 4.7 && < 5
4948 , bifunctors
5049 , bytestring
5150 , conduit
5251 , data-default-class
53− , dlist >= 0.7
52+ , dlist >= 0.7
5453 , exceptions
55− , hashable >= 1.2
54+ , hashable >= 1.2
5655 , http-client
5756 , http-media
5857 , http-types
59− , lens >= 4.4
58+ , lens >= 4.4
6059 , resourcet
61− , scientific >= 0.3
62− , servant >= 0.4.4
63− , text >= 1.1
64− , transformers
60+ , scientific >= 0.3
61+ , servant >= 0.4.4
62+ , text >= 1.1
6563
6664 if !impl(ghc>=7.9)
6765 build-depends:
core/src/Network/Google/Client.hsdeleted−451
@@ -1,451 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE DeriveGeneric #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE LambdaCase #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE RankNTypes #-}
11−{-# LANGUAGE RecordWildCards #-}
12−{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE TypeFamilies #-}
14−{-# LANGUAGE TypeOperators #-}
15−{-# LANGUAGE UndecidableInstances #-}
16−
17−-- |
18−-- Module : Network.Google.Client
19−-- Copyright : (c) 2015 Brendan Hay <brendan.g.hay@gmail.com>
20−-- License : Mozilla Public License, v. 2.0.
21−-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
22−-- Stability : provisional
23−-- Portability : non-portable (GHC extensions)
24−--
25−module Network.Google.Client where
26−
27−import Control.Monad.Catch
28−-- import Control.Exception
29−import Control.Lens
30−import Control.Monad.Trans.Class
31−import Control.Monad.Trans.Reader
32−import Control.Monad.Trans.Resource
33−import Data.Bifunctor
34−import Data.ByteString (ByteString)
35−import qualified Data.ByteString.Lazy as LBS
36−import Data.Conduit
37−import qualified Data.Conduit.List as CL
38−import Data.Data
39−import Data.Default.Class (def)
40−import Data.DList (DList)
41−import qualified Data.DList as DList
42−import Data.Foldable (foldMap, foldl')
43−import Data.List (intersperse)
44−import Data.Maybe
45−import Data.Monoid
46−import Data.Proxy
47−import Data.Text (Text)
48−import qualified Data.Text as Text
49−import Data.Text.Lazy.Builder (Builder)
50−import qualified Data.Text.Lazy.Builder as Build
51−import GHC.Generics
52−import GHC.TypeLits
53−import Network.Google.Types
54−import Network.HTTP.Client (HttpException)
55−import qualified Network.HTTP.Client as Client
56−import Network.HTTP.Media hiding (Accept)
57−import Network.HTTP.Types
58−import Servant.API hiding (Header)
59−
60−-- | A convenience alias to avoid type ambiguity.
61−type ClientRequest = Client.Request
62−
63−-- | A convenience alias encapsulating the common 'Response'.
64−type ClientResponse = Client.Response ResponseBody
65−
66−-- | A convenience alias encapsulating the common 'Response' body.
67−type ResponseBody = ResumableSource (ResourceT IO) ByteString
68−
69−-- import Servant.API
70−-- import Servant.Utils.Links
71−
72−data Body = Body -- MediaType
73− deriving (Eq, Show, Generic, Data, Typeable)
74−
75−data Error
76− = TransportError HttpException
77− | SerializeError SerializeError
78− | ServiceError ServiceError
79− deriving (Show, Typeable)
80−
81−instance Exception Error
82−
83−data SerializeError = SerializeError'
84− -- , _serializeHeaders :: [Header]
85− { -- _serializeAbbrev :: !Abbrev
86− -- , _serializeStatus :: !Status
87− -- , _serializeMessage :: String
88− } deriving (Eq, Show, Typeable)
89−
90−data ServiceError = ServiceError' !Status !MediaType [Header] LBS.ByteString
91− -- _serviceAbbrev :: !Abbrev
92− -- , _serviceStatus :: !Status
93− -- , _serviceHeaders :: [Header]
94− -- , _serviceCode :: !ErrorCode
95− -- , _serviceMessage :: Maybe ErrorMessage
96− -- , _serviceRequestId :: Maybe RequestId
97− deriving (Eq, Show, Typeable)
98−
99−class AsError a where
100− -- | A general Amazonka error.
101− _Error :: Prism' a Error
102− {-# MINIMAL _Error #-}
103−
104− -- | An error occured while communicating over HTTP with a remote service.
105− _TransportError :: Prism' a HttpException
106−
107− -- | A serialisation error occured when attempting to deserialise a response.
108− _SerializeError :: Prism' a SerializeError
109−
110− -- | A service specific error returned by the remote service.
111− _ServiceError :: Prism' a ServiceError
112−
113− _TransportError = _Error . _TransportError
114− _SerializeError = _Error . _SerializeError
115− _ServiceError = _Error . _ServiceError
116−
117−instance AsError Error where
118− _Error = id
119−
120− _TransportError = prism TransportError $ \case
121− TransportError e -> Right e
122− x -> Left x
123−
124− _SerializeError = prism SerializeError $ \case
125− SerializeError e -> Right e
126− x -> Left x
127−
128− _ServiceError = prism ServiceError $ \case
129− ServiceError e -> Right e
130− x -> Left x
131−
132−-- | Multiple path captures, with @[xs]@ forming @/<x1>/<x2>/<x2>/...@.
133−data Captures (s :: Symbol) a
134− deriving (Typeable)
135−
136−-- | Form a Google style sub-resource, such as @/<capture>:<mode>@.
137−data CaptureMode (s :: Symbol) (m :: Symbol) a
138− deriving (Typeable)
139−
140−data MultipartRelated (cs :: [*]) m b
141− deriving (Typeable)
142−
143−-- | An intermediary request builder.
144−data RequestBuilder = RequestBuilder
145− { _rqHost :: ByteString
146− , _rqBasePath :: ByteString
147− , _rqPath :: Builder
148− , _rqQuery :: DList (Text, Maybe Text)
149− , _rqBody :: Maybe (MediaType, LBS.ByteString)
150− }
151−
152−-- | Construct a default request builder. Since the Google service descriptions
153−-- have http/https in the host (rootUrl), the scheme is assumed.
154−defaultRequest :: ByteString -- ^ Host. (rootUrl)
155− -> ByteString -- ^ Path. (servicePath)
156− -> RequestBuilder
157−defaultRequest h p = RequestBuilder
158− { _rqHost = h
159− , _rqBasePath = p
160− , _rqPath = mempty
161− , _rqQuery = mempty
162− , _rqBody = Nothing
163− }
164−
165−appendPath :: RequestBuilder -> Builder -> RequestBuilder
166−appendPath rq x = rq { _rqPath = _rqPath rq <> "/" <> x }
167−
168−appendPaths :: ToText a => RequestBuilder -> [a] -> RequestBuilder
169−appendPaths rq = appendPath rq . foldMap (mappend "/" . buildText)
170−
171−appendQuery :: RequestBuilder -> Text -> Maybe Text -> RequestBuilder
172−appendQuery rq k v = rq { _rqQuery = DList.snoc (_rqQuery rq) (k, v) }
173−
174−setBody :: RequestBuilder -> MediaType -> LBS.ByteString -> RequestBuilder
175−setBody rq c x = rq { _rqBody = Just (c, x) }
176−
177−-- | A materialised 'http-client' request and associated response parser.
178−data Client a = Client
179− { _clientAccept :: Maybe MediaType
180− , _clientCheck :: Int -> Bool
181− , _clientResponse :: ResponseBody -> ResourceT IO (Either SerializeError a)
182− , _clientRequest :: ClientRequest
183− }
184−
185−client :: (ResponseBody -> ResourceT IO (Either SerializeError a))
186− -> Maybe MediaType
187− -> Method
188− -> [Int]
189− -> RequestBuilder
190− -> Client a
191−client f cs m ns rq = Client
192− { _clientAccept = cs
193− , _clientCheck = (`elem` ns)
194− , _clientResponse = f
195− , _clientRequest = clientRequest cs m rq
196− }
197−
198−clientRequest :: Maybe MediaType -> Method -> RequestBuilder -> ClientRequest
199−clientRequest cs m RequestBuilder {..} = def
200− { Client.method = m
201− , Client.checkStatus = \_ _ _ -> Nothing
202− }
203−
204−clientMime :: MimeUnrender c a
205− => Proxy c
206− -> Method
207− -> [Int]
208− -> RequestBuilder
209− -> Client a
210−clientMime p = client go (Just (contentType p))
211− where
212− go b = do
213− lbs <- sinkLBS b
214− case mimeUnrender p lbs of
215− Left e -> undefined
216− Right x -> pure (Right x)
217−
218−clientStream :: Accept c
219− => Proxy c
220− -> Method
221− -> [Int]
222− -> RequestBuilder
223− -> Client ResponseBody
224−clientStream p = client (pure . Right) (Just (contentType p))
225−
226−clientEmpty :: Method -> [Int] -> RequestBuilder -> Client ()
227−clientEmpty = client go Nothing
228− where
229− go b = closeResumableSource b >> pure (Right ())
230−
231−-- sinkLBS :: ResponseBody -> Client LBS.ByteString
232−sinkLBS = fmap LBS.fromChunks . ($$+- CL.consume)
233−
234−class GoogleRequest a where
235− type Rs a :: *
236−
237− request :: a -> Client (Rs a)
238− requestWith :: RequestBuilder -> a -> Client (Rs a)
239−
240−class GoogleClient fn where
241− type Fn fn :: *
242−
243− clientBuild :: Proxy fn -> RequestBuilder -> Fn fn
244−
245−instance ( MimeRender c m
246− , GoogleClient fn
247− ) => GoogleClient (MultipartRelated (c ': cs) m b :> fn) where
248− type Fn (MultipartRelated (c ': cs) m b :> fn) = m -> b -> Fn fn
249−
250− -- requestBuild Proxy rq m b = requestBuild (Proxy :: Proxy fn) $
251− -- mimeRender p m
252− -- mimeRender (Proxy :: Proxy OctetStream) b
253− -- where
254− -- p = Proxy :: Proxy c
255−
256−instance (KnownSymbol s, GoogleClient fn) => GoogleClient (s :> fn) where
257− type Fn (s :> fn) = Fn fn
258−
259− clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn) $
260− appendPath rq (buildSymbol (Proxy :: Proxy s))
261−
262−instance (GoogleClient a, GoogleClient b) => GoogleClient (a :<|> b) where
263− type Fn (a :<|> b) = Fn a :<|> Fn b
264−
265− clientBuild Proxy rq =
266− clientBuild (Proxy :: Proxy a) rq
267− :<|> clientBuild (Proxy :: Proxy b) rq
268−
269−instance ( KnownSymbol s
270− , ToText a
271− , GoogleClient fn
272− ) => GoogleClient (Capture s a :> fn) where
273− type Fn (Capture s a :> fn) = a -> Fn fn
274−
275− clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn)
276− . appendPath rq
277− . buildText
278−
279−instance ( KnownSymbol s
280− , ToText a
281− , GoogleClient fn
282− ) => GoogleClient (Captures s a :> fn) where
283− type Fn (Captures s a :> fn) = [a] -> Fn fn
284−
285− clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn)
286− . appendPaths rq
287−
288−instance ( KnownSymbol s
289− , KnownSymbol m
290− , ToText a
291− , GoogleClient fn
292− ) => GoogleClient (CaptureMode s m a :> fn) where
293− type Fn (CaptureMode s m a :> fn) = a -> Fn fn
294−
295− clientBuild Proxy rq x = clientBuild (Proxy :: Proxy fn)
296− . appendPath rq
297− $ buildText x <> buildSymbol (Proxy :: Proxy m)
298−
299−instance ( KnownSymbol s
300− , ToText a
301− , GoogleClient fn
302− ) => GoogleClient (QueryParam s a :> fn) where
303− type Fn (QueryParam s a :> fn) = Maybe a -> Fn fn
304−
305− clientBuild Proxy rq mx = clientBuild (Proxy :: Proxy fn) $
306− case mx of
307− Nothing -> rq
308− Just x -> appendQuery rq k v
309− where
310− k = textSymbol (Proxy :: Proxy s)
311− v = Just (toText x)
312−
313−instance ( KnownSymbol s
314− , ToText a
315− , GoogleClient fn
316− ) => GoogleClient (QueryParams s a :> fn) where
317− type Fn (QueryParams s a :> fn) = [a] -> Fn fn
318−
319− clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn) . foldl' go rq
320− where
321− go r = appendQuery r k . Just . toText
322−
323− k = textSymbol (Proxy :: Proxy s)
324−
325−instance ( MimeRender c a
326− , GoogleClient fn
327− ) => GoogleClient (ReqBody (c ': cs) a :> fn) where
328− type Fn (ReqBody (c ': cs) a :> fn) = a -> Fn fn
329−
330− clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn)
331− . setBody rq (contentType p)
332− . mimeRender p
333− where
334− p = Proxy :: Proxy c
335−
336−instance {-# OVERLAPPABLE #-}
337− MimeUnrender c a => GoogleClient (Get (c ': cs) a) where
338− type Fn (Get (c ': cs) a) = Client a
339−
340− clientBuild Proxy = clientMime (Proxy :: Proxy c) methodGet [200, 203]
341−
342−instance {-# OVERLAPPING #-}
343− Accept c => GoogleClient (Get (c ': cs) ResponseBody) where
344− type Fn (Get (c ': cs) ResponseBody) = Client ResponseBody
345−
346− clientBuild Proxy = clientStream (Proxy :: Proxy c) methodGet [200, 203]
347−
348−instance {-# OVERLAPPING #-}
349− GoogleClient (Get (c ': cs) ()) where
350− type Fn (Get (c ': cs) ()) = Client ()
351−
352− clientBuild Proxy = clientEmpty methodGet [204]
353−
354−instance {-# OVERLAPPABLE #-}
355− MimeUnrender c a => GoogleClient (Post (c ': cs) a) where
356− type Fn (Post (c ': cs) a) = Client a
357−
358− clientBuild Proxy = clientMime (Proxy :: Proxy c) methodPost [200, 201]
359−
360−instance {-# OVERLAPPING #-}
361− GoogleClient (Post (c ': cs) ()) where
362− type Fn (Post (c ': cs) ()) = Client ()
363−
364− clientBuild Proxy = clientEmpty methodPost [204]
365−
366−instance {-# OVERLAPPABLE #-}
367− MimeUnrender c a => GoogleClient (Put (c ': cs) a) where
368− type Fn (Put (c ': cs) a) = Client a
369−
370− clientBuild Proxy = clientMime (Proxy :: Proxy c) methodPut [200, 201]
371−
372−instance {-# OVERLAPPING #-}
373− GoogleClient (Put (c ': cs) ()) where
374− type Fn (Put (c ': cs) ()) = Client ()
375−
376− clientBuild Proxy = clientEmpty methodPut [204]
377−
378−instance {-# OVERLAPPABLE #-}
379− MimeUnrender c a => GoogleClient (Patch (c ': cs) a) where
380− type Fn (Patch (c ': cs) a) = Client a
381−
382− clientBuild Proxy = clientMime (Proxy :: Proxy c) methodPatch [200, 201]
383−
384−instance {-# OVERLAPPING #-}
385− GoogleClient (Patch (c ': cs) ()) where
386− type Fn (Patch (c ': cs) ()) = Client ()
387−
388− clientBuild Proxy = clientEmpty methodPatch [204]
389−
390−instance {-# OVERLAPPABLE #-}
391− MimeUnrender c a => GoogleClient (Delete (c ': cs) a) where
392− type Fn (Delete (c ': cs) a) = Client a
393−
394− clientBuild Proxy = clientMime (Proxy :: Proxy c) methodDelete [200, 202]
395−
396−instance {-# OVERLAPPING #-}
397− GoogleClient (Delete (c ': cs) ()) where
398− type Fn (Delete (c ': cs) ()) = Client ()
399−
400− clientBuild Proxy = clientEmpty methodDelete [204]
401−
402−-- perform :: Accept
403−-- -> (ResponseBody -> Client (Either SerializeError a))
404−-- -> Method
405−-- -> [Int]
406−-- -> RequestBuilder
407−-- -> Client a
408−-- perform a meth ns f rq = undefined -- do
409− -- m <- ask
410− -- x <- lift . try $ Client.http m (clientRequest meth a rq)
411− -- either (failure . TransportError) success x
412− -- where
413− -- failure = pure . Left
414−
415− -- success rs = do
416− -- let s = Client.responseStatus rs
417− -- b = Client.responseBody rs
418− -- hs = Client.responseHeaders rs
419− -- case content hs of
420− -- unless (matches respCT (acceptCT)) $
421− -- left $ UnsupportedContentType respCT respBody
422−
423− -- Nothing -> failure (SerializeError' (SerializeError hs))
424−
425− -- Just _ | statusInvalid s -> do
426− -- lbs <- sinkLBS b
427− -- failure (ServiceError' (ServiceError s c hs lbs))
428−
429− -- Just c | contentInvalid c -> do
430− -- lbs <- sinkLBS b
431− -- failure (SerializeError' (SerializeError s c hs lbs))
432−
433−
434− -- Just c -> first SerializeError' <$> f b
435−
436− -- content :: [Header] -> Maybe c
437− -- content = parseAccept
438− -- . fromMaybe "application/octet-stream"
439− -- . lookup hContentType
440−
441− -- statusCheck s = fromEnum s `elem` ns
442− -- contentCheck = matches a
443−
444−buildText :: ToText a => a -> Builder
445−buildText = Build.fromText . toText
446−
447−buildSymbol :: forall n proxy. KnownSymbol n => proxy n -> Builder
448−buildSymbol = Build.fromString . symbolVal
449−
450−textSymbol :: forall n proxy. KnownSymbol n => proxy n -> Text
451−textSymbol = Text.pack . symbolVal
core/src/Network/Google/Data/JSON.hs−1
@@ -29,7 +29,6 @@ module Network.Google.Data.JSON
2929 , (.!=)
3030 ) where
3131
32−import Control.Lens hiding ((.=))
3332import Data.Aeson
3433import Data.Aeson.Types
3534import Servant.API
core/src/Network/Google/Prelude.hs−110
@@ -1,15 +1,3 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE DeriveGeneric #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE OverloadedStrings #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE TypeOperators #-}
12−
131-- |
142-- Module : Network.Google.Prelude
153-- Copyright : (c) 2015 Brendan Hay <brendan.g.hay@gmail.com>
@@ -20,13 +8,11 @@
208--
219module Network.Google.Prelude
2210 ( module Export
23− , module Network.Google.Prelude
2411 ) where
2512
2613import Control.Applicative as Export (pure, (<$>), (<*>))
2714import Control.Lens as Export (Lens', lens, mapping,
2815 (^.), _Just)
29−import Control.Lens
3016import Data.Data as Export (Data, Typeable)
3117import Data.Hashable as Export
3218import Data.Int as Export (Int32, Int64)
@@ -34,12 +20,9 @@ import Data.Maybe as Export
3420import Data.Monoid as Export (mempty, (<>))
3521import Data.Proxy as Export
3622import Data.Text as Export (Text)
37−import qualified Data.Text as Text
3823import Data.Time as Export
3924import Data.Word as Export (Word32, Word64, Word8)
4025import GHC.Generics as Export (Generic)
41−import GHC.TypeLits
42−import Network.Google.Client as Export
4326import Network.Google.Data.JSON as Export
4427import Network.Google.Data.Numeric as Export
4528import Network.Google.Data.Time as Export
@@ -47,97 +30,4 @@ import Network.Google.Types as Export
4730import Numeric.Natural as Export (Natural)
4831import Prelude as Export hiding (product)
4932import Servant.API as Export hiding (getResponse)
50−-- import Servant.Client as Export
51−-- import Servant.Common.Req as Export (Req, defReq)
52−-- import Servant.Common.Req (appendToPath)
5333import Servant.Utils.Links as Export hiding (Link)
54−
55−-- data Body = Body -- MediaType
56−-- deriving (Eq, Show, Generic, Data, Typeable)
57−
58−-- -- data ReqStream
59−-- -- data ResStream
60−-- -- type API = ReqBody '[JSON] Request :> Post '[JSON] Response
61−-- -- type API = MultipartRelated '[JSON] Meta '[JSON] Media :> Post '[JSON] Response
62−
63−-- instance MimeRender OctetStream Body
64−-- instance MimeUnrender OctetStream Body
65−
66−-- data MultipartRelated (metatypes :: [*]) meta media
67−-- deriving (Typeable)
68−
69−-- instance (MimeUnrender ct a, HasClient sublayout)
70−-- => HasClient (MultipartRelated (ct ': cts) a b :> sublayout) where
71−
72−-- type Client (MultipartRelated (ct ': cts) a b :> sublayout) =
73−-- a -> b -> Client sublayout
74−
75−-- clientWithRoute Proxy req baseurl meta media = undefined
76−
77− -- clientWithRoute (Proxy :: Proxy sublayout)
78− -- (let ctProxy = Proxy :: Proxy ct
79− -- in setRQBody (mimeRender ctProxy body)
80− -- (contentType ctProxy)
81− -- req
82− -- )
83− -- baseurl
84−
85−
86−-- IsElem sa (ReqBody y x :> sb) = IsElem sa sb
87−
88−-- instance HasLink sub => HasLink (ReqBody ct a :> sub) where
89−-- type MkLink (ReqBody ct a :> sub) = MkLink sub
90−-- toLink _ = toLink (Proxy :: Proxy sub)
91−
92−-- instance (MimeRender ct a, HasClient sublayout)
93−-- => HasClient (ReqBody (ct ': cts) a :> sublayout) where
94−-- type Client (ReqBody (ct ': cts) a :> sublayout) =
95−-- a -> Client sublayout
96−
97−-- clientWithRoute Proxy req baseurl body =
98−-- clientWithRoute (Proxy :: Proxy sublayout)
99−-- (let ctProxy = Proxy :: Proxy ct
100−-- in setRQBody (mimeRender ctProxy body)
101−-- (contentType ctProxy)
102−-- req
103−-- )
104−-- baseurl
105−
106−-- POST /upload/drive/v2/files?uploadType=multipart HTTP/1.1
107−-- Host: www.googleapis.com
108−-- Authorization: Bearer your_auth_token
109−-- Content-Type: multipart/related; boundary="foo_bar_baz"
110−-- Content-Length: number_of_bytes_in_entire_request_body
111−--
112−-- --foo_bar_baz
113−-- Content-Type: application/json; charset=UTF-8
114−-- {
115−-- "title": "My File"
116−-- }
117−-- --foo_bar_baz
118−-- Content-Type: image/jpeg
119−-- JPEG data
120−-- --foo_bar_baz--
121−
122−-- "mediaType" param also comes/calculated from the request body?
123−--
124−-- Resumable endpoints - Not supported to begin with, need to figure
125−-- out how to return session id etc.
126−--
127−-- Assume initially that every service supports multipart upload.
128−--
129−-- When downloading media you must set the alt query parameter
130−-- to media in the request URL.
131−--
132−-- "resumable" or "multipart" needs to go into the "uploadType" param
133−--
134−
135−-- if c.protocol_ == "resumable" {
136−-- if c.mediaType_ == "" {
137−-- c.mediaType_ = googleapi.DetectMediaType(c.resumable_)
138−-- }
139−-- req.Header.Set("X-Upload-Content-Type", c.mediaType_)
140−-- req.Header.Set("Content-Type", "application/json; charset=utf-8")
141−-- } else {
142−-- req.Header.Set("Content-Type", ctype)
143−-- }
core/src/Network/Google/Types.hs+457−3
@@ -1,7 +1,16 @@
1+{-# LANGUAGE DataKinds #-}
12{-# LANGUAGE DeriveDataTypeable #-}
23{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE FlexibleInstances #-}
35{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
48{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE RecordWildCards #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
514
615-- |
716-- Module : Network.Google.Types
@@ -13,14 +22,36 @@
1322--
1423module Network.Google.Types where
1524
16−import Control.Lens hiding (coerce)
25+import Control.Lens hiding (coerce)
26+import Control.Monad.Catch
27+import Control.Monad.Trans.Resource
28+import Data.Aeson
29+import Data.Bifunctor
30+import Data.ByteString (ByteString)
31+import qualified Data.ByteString.Lazy as LBS
1732import Data.Coerce
33+import Data.Conduit
34+import qualified Data.Conduit.List as CL
1835import Data.Data
36+import Data.Default.Class (def)
37+import Data.DList (DList)
38+import qualified Data.DList as DList
39+import Data.Foldable (foldMap, foldl')
40+import Data.List (intersperse)
41+import Data.Maybe
1942import Data.Monoid
20−import Data.Text (Text)
43+import Data.Proxy
44+import Data.Text (Text)
45+import qualified Data.Text as Text
46+import Data.Text.Lazy.Builder (Builder)
47+import qualified Data.Text.Lazy.Builder as Build
2148import GHC.Generics
49+import GHC.TypeLits
50+import Network.HTTP.Client (HttpException, RequestBody (..))
51+import qualified Network.HTTP.Client as Client
52+import Network.HTTP.Media hiding (Accept)
2253import Network.HTTP.Types
23−import Servant.API
54+import Servant.API hiding (Header)
2455import Servant.Utils.Links
2556
2657data AltJSON = AltJSON
@@ -65,3 +96,426 @@ _Default = iso f Just
6596 where
6697 f (Just x) = x
6798 f Nothing = mempty
99+
100+-- | A convenience alias to avoid type ambiguity.
101+type ClientRequest = Client.Request
102+
103+-- | A convenience alias encapsulating the common 'Response'.
104+type ClientResponse = Client.Response Stream
105+
106+type Stream = ResumableSource (ResourceT IO) ByteString
107+
108+data Error
109+ = TransportError HttpException
110+ | SerializeError SerializeError
111+ | ServiceError ServiceError
112+ deriving (Show, Typeable)
113+
114+instance Exception Error
115+
116+data SerializeError = SerializeError'
117+ -- , _serializeHeaders :: [Header]
118+ { -- _serializeAbbrev :: !Abbrev
119+ -- , _serializeStatus :: !Status
120+ -- , _serializeMessage :: String
121+ } deriving (Eq, Show, Typeable)
122+
123+data ServiceError = ServiceError' !Status !MediaType [Header] LBS.ByteString
124+ -- _serviceAbbrev :: !Abbrev
125+ -- , _serviceStatus :: !Status
126+ -- , _serviceHeaders :: [Header]
127+ -- , _serviceCode :: !ErrorCode
128+ -- , _serviceMessage :: Maybe ErrorMessage
129+ -- , _serviceRequestId :: Maybe RequestId
130+ deriving (Eq, Show, Typeable)
131+
132+class AsError a where
133+ -- | A general Amazonka error.
134+ _Error :: Prism' a Error
135+ {-# MINIMAL _Error #-}
136+
137+ -- | An error occured while communicating over HTTP with a remote service.
138+ _TransportError :: Prism' a HttpException
139+
140+ -- | A serialisation error occured when attempting to deserialise a response.
141+ _SerializeError :: Prism' a SerializeError
142+
143+ -- | A service specific error returned by the remote service.
144+ _ServiceError :: Prism' a ServiceError
145+
146+ _TransportError = _Error . _TransportError
147+ _SerializeError = _Error . _SerializeError
148+ _ServiceError = _Error . _ServiceError
149+
150+instance AsError Error where
151+ _Error = id
152+
153+ _TransportError = prism TransportError $ \case
154+ TransportError e -> Right e
155+ x -> Left x
156+
157+ _SerializeError = prism SerializeError $ \case
158+ SerializeError e -> Right e
159+ x -> Left x
160+
161+ _ServiceError = prism ServiceError $ \case
162+ ServiceError e -> Right e
163+ x -> Left x
164+
165+-- | An intermediary request builder.
166+data RequestBuilder = RequestBuilder
167+ { _rqHost :: ByteString
168+ , _rqBasePath :: ByteString
169+ , _rqPath :: Builder
170+ , _rqQuery :: DList (Text, Maybe Text)
171+ , _rqBody :: Maybe (MediaType, Stream)
172+ }
173+
174+-- | Construct a default request builder. Since the Google service descriptions
175+-- have http/https in the host (rootUrl), the scheme is assumed.
176+defaultRequest :: ByteString -- ^ Host. (rootUrl)
177+ -> ByteString -- ^ Path. (servicePath)
178+ -> RequestBuilder
179+defaultRequest h p = RequestBuilder
180+ { _rqHost = h
181+ , _rqBasePath = p
182+ , _rqPath = mempty
183+ , _rqQuery = mempty
184+ , _rqBody = Nothing
185+ }
186+
187+appendPath :: RequestBuilder -> Builder -> RequestBuilder
188+appendPath rq x = rq { _rqPath = _rqPath rq <> "/" <> x }
189+
190+appendPaths :: ToText a => RequestBuilder -> [a] -> RequestBuilder
191+appendPaths rq = appendPath rq . foldMap (mappend "/" . buildText)
192+
193+appendQuery :: RequestBuilder -> Text -> Maybe Text -> RequestBuilder
194+appendQuery rq k v = rq { _rqQuery = DList.snoc (_rqQuery rq) (k, v) }
195+
196+setStream :: RequestBuilder -> MediaType -> Stream -> RequestBuilder
197+setStream rq c x = rq { _rqBody = Just (c, x) }
198+
199+-- | A materialised 'http-client' request and associated response parser.
200+data Client a = Client
201+ { _clientAccept :: Maybe MediaType
202+ , _clientCheck :: Int -> Bool
203+ , _clientResponse :: Stream -> ResourceT IO (Either SerializeError a)
204+ , _clientRequest :: ClientRequest
205+ }
206+
207+clientRequest :: (Stream -> ResourceT IO (Either SerializeError a))
208+ -> Maybe MediaType
209+ -> Method
210+ -> [Int]
211+ -> RequestBuilder
212+ -> Client a
213+clientRequest f cs m ns rq = Client
214+ { _clientAccept = cs
215+ , _clientCheck = (`elem` ns)
216+ , _clientResponse = f
217+ , _clientRequest = def
218+ { Client.method = m
219+ , Client.checkStatus = \_ _ _ -> Nothing
220+ }
221+ }
222+
223+clientMime :: FromStream c a
224+ => Proxy c
225+ -> Method
226+ -> [Int]
227+ -> RequestBuilder
228+ -> Client a
229+clientMime p = clientRequest (fromStream p) (Just (contentType p))
230+
231+clientEmpty :: Method -> [Int] -> RequestBuilder -> Client ()
232+clientEmpty = clientRequest go Nothing
233+ where
234+ go b = closeResumableSource b >> pure (Right ())
235+
236+class Accept c => ToStream c a where
237+ toStream :: Proxy c -> a -> Stream
238+
239+instance ToJSON a => ToStream JSON a where
240+ toStream Proxy = newResumableSource . CL.sourceList . LBS.toChunks . encode
241+
242+class Accept c => FromStream c a where
243+ fromStream :: Proxy c
244+ -> Stream
245+ -> ResourceT IO (Either SerializeError a)
246+
247+instance FromStream OctetStream Stream where
248+ fromStream Proxy = pure . Right
249+
250+instance FromJSON a => FromStream JSON a where
251+ fromStream Proxy b = do
252+ lbs <- sinkLBS b
253+ case eitherDecode lbs of
254+ Left e -> undefined
255+ Right x -> pure (Right x)
256+
257+class GoogleRequest a where
258+ type Rs a :: *
259+
260+ request :: a -> Client (Rs a)
261+ requestWith :: RequestBuilder -> a -> Client (Rs a)
262+
263+class GoogleClient fn where
264+ type Fn fn :: *
265+
266+ clientBuild :: Proxy fn -> RequestBuilder -> Fn fn
267+
268+-- | Multiple path captures, with @[xs]@ forming @/<x1>/<x2>/<x2>/...@.
269+data Captures (s :: Symbol) a
270+ deriving (Typeable)
271+
272+-- | Form a Google style sub-resource, such as @/<capture>:<mode>@.
273+data CaptureMode (s :: Symbol) (m :: Symbol) a
274+ deriving (Typeable)
275+
276+data MultipartRelated (cs :: [*]) m b
277+ deriving (Typeable)
278+
279+instance ( MimeRender c m
280+ , GoogleClient fn
281+ ) => GoogleClient (MultipartRelated (c ': cs) m b :> fn) where
282+ type Fn (MultipartRelated (c ': cs) m b :> fn) = m -> b -> Fn fn
283+
284+ -- requestBuild Proxy rq m b = requestBuild (Proxy :: Proxy fn) $
285+ -- mimeRender p m
286+ -- mimeRender (Proxy :: Proxy OctetStream) b
287+ -- where
288+ -- p = Proxy :: Proxy c
289+
290+-- POST /upload/drive/v2/files?uploadType=multipart HTTP/1.1
291+-- Host: www.googleapis.com
292+-- Authorization: Bearer your_auth_token
293+-- Content-Type: multipart/related; boundary="foo_bar_baz"
294+-- Content-Length: number_of_bytes_in_entire_request_body
295+--
296+-- --foo_bar_baz
297+-- Content-Type: application/json; charset=UTF-8
298+-- {
299+-- "title": "My File"
300+-- }
301+-- --foo_bar_baz
302+-- Content-Type: image/jpeg
303+-- JPEG data
304+-- --foo_bar_baz--
305+
306+-- "mediaType" param also comes/calculated from the request body?
307+--
308+-- Resumable endpoints - Not supported to begin with, need to figure
309+-- out how to return session id etc.
310+--
311+-- Assume initially that every service supports multipart upload.
312+--
313+-- When downloading media you must set the alt query parameter
314+-- to media in the request URL.
315+--
316+-- "resumable" or "multipart" needs to go into the "uploadType" param
317+--
318+
319+-- if c.protocol_ == "resumable" {
320+-- if c.mediaType_ == "" {
321+-- c.mediaType_ = googleapi.DetectMediaType(c.resumable_)
322+-- }
323+-- req.Header.Set("X-Upload-Content-Type", c.mediaType_)
324+-- req.Header.Set("Content-Type", "application/json; charset=utf-8")
325+-- } else {
326+-- req.Header.Set("Content-Type", ctype)
327+-- }
328+
329+instance (KnownSymbol s, GoogleClient fn) => GoogleClient (s :> fn) where
330+ type Fn (s :> fn) = Fn fn
331+
332+ clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn) $
333+ appendPath rq (buildSymbol (Proxy :: Proxy s))
334+
335+instance (GoogleClient a, GoogleClient b) => GoogleClient (a :<|> b) where
336+ type Fn (a :<|> b) = Fn a :<|> Fn b
337+
338+ clientBuild Proxy rq =
339+ clientBuild (Proxy :: Proxy a) rq
340+ :<|> clientBuild (Proxy :: Proxy b) rq
341+
342+instance ( KnownSymbol s
343+ , ToText a
344+ , GoogleClient fn
345+ ) => GoogleClient (Capture s a :> fn) where
346+ type Fn (Capture s a :> fn) = a -> Fn fn
347+
348+ clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn)
349+ . appendPath rq
350+ . buildText
351+
352+instance ( KnownSymbol s
353+ , ToText a
354+ , GoogleClient fn
355+ ) => GoogleClient (Captures s a :> fn) where
356+ type Fn (Captures s a :> fn) = [a] -> Fn fn
357+
358+ clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn)
359+ . appendPaths rq
360+
361+instance ( KnownSymbol s
362+ , KnownSymbol m
363+ , ToText a
364+ , GoogleClient fn
365+ ) => GoogleClient (CaptureMode s m a :> fn) where
366+ type Fn (CaptureMode s m a :> fn) = a -> Fn fn
367+
368+ clientBuild Proxy rq x = clientBuild (Proxy :: Proxy fn)
369+ . appendPath rq
370+ $ buildText x <> buildSymbol (Proxy :: Proxy m)
371+
372+instance ( KnownSymbol s
373+ , ToText a
374+ , GoogleClient fn
375+ ) => GoogleClient (QueryParam s a :> fn) where
376+ type Fn (QueryParam s a :> fn) = Maybe a -> Fn fn
377+
378+ clientBuild Proxy rq mx = clientBuild (Proxy :: Proxy fn) $
379+ case mx of
380+ Nothing -> rq
381+ Just x -> appendQuery rq k v
382+ where
383+ k = textSymbol (Proxy :: Proxy s)
384+ v = Just (toText x)
385+
386+instance ( KnownSymbol s
387+ , ToText a
388+ , GoogleClient fn
389+ ) => GoogleClient (QueryParams s a :> fn) where
390+ type Fn (QueryParams s a :> fn) = [a] -> Fn fn
391+
392+ clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn) . foldl' go rq
393+ where
394+ go r = appendQuery r k . Just . toText
395+
396+ k = textSymbol (Proxy :: Proxy s)
397+
398+instance ( ToStream c a
399+ , GoogleClient fn
400+ ) => GoogleClient (ReqBody (c ': cs) a :> fn) where
401+ type Fn (ReqBody (c ': cs) a :> fn) = a -> Fn fn
402+
403+ clientBuild Proxy rq = clientBuild (Proxy :: Proxy fn)
404+ . setStream rq (contentType p)
405+ . toStream p
406+ where
407+ p = Proxy :: Proxy c
408+
409+instance {-# OVERLAPPABLE #-}
410+ FromStream c a => GoogleClient (Get (c ': cs) a) where
411+ type Fn (Get (c ': cs) a) = Client a
412+
413+ clientBuild Proxy = clientMime (Proxy :: Proxy c) methodGet [200, 203]
414+
415+instance {-# OVERLAPPING #-}
416+ GoogleClient (Get (c ': cs) ()) where
417+ type Fn (Get (c ': cs) ()) = Client ()
418+
419+ clientBuild Proxy = clientEmpty methodGet [204]
420+
421+instance {-# OVERLAPPABLE #-}
422+ (FromStream c a, cs' ~ (c ': cs)) => GoogleClient (Post cs' a) where
423+ type Fn (Post cs' a) = Client a
424+
425+ clientBuild Proxy = clientMime (Proxy :: Proxy c) methodPost [200, 201]
426+
427+instance {-# OVERLAPPING #-}
428+ GoogleClient (Post cs ()) where
429+ type Fn (Post cs ()) = Client ()
430+
431+ clientBuild Proxy = clientEmpty methodPost [204]
432+
433+instance {-# OVERLAPPABLE #-}
434+ FromStream c a => GoogleClient (Put (c ': cs) a) where
435+ type Fn (Put (c ': cs) a) = Client a
436+
437+ clientBuild Proxy = clientMime (Proxy :: Proxy c) methodPut [200, 201]
438+
439+instance {-# OVERLAPPING #-}
440+ GoogleClient (Put (c ': cs) ()) where
441+ type Fn (Put (c ': cs) ()) = Client ()
442+
443+ clientBuild Proxy = clientEmpty methodPut [204]
444+
445+instance {-# OVERLAPPABLE #-}
446+ FromStream c a => GoogleClient (Patch (c ': cs) a) where
447+ type Fn (Patch (c ': cs) a) = Client a
448+
449+ clientBuild Proxy = clientMime (Proxy :: Proxy c) methodPatch [200, 201]
450+
451+instance {-# OVERLAPPING #-}
452+ GoogleClient (Patch (c ': cs) ()) where
453+ type Fn (Patch (c ': cs) ()) = Client ()
454+
455+ clientBuild Proxy = clientEmpty methodPatch [204]
456+
457+instance {-# OVERLAPPABLE #-}
458+ FromStream c a => GoogleClient (Delete (c ': cs) a) where
459+ type Fn (Delete (c ': cs) a) = Client a
460+
461+ clientBuild Proxy = clientMime (Proxy :: Proxy c) methodDelete [200, 202]
462+
463+instance {-# OVERLAPPING #-}
464+ GoogleClient (Delete (c ': cs) ()) where
465+ type Fn (Delete (c ': cs) ()) = Client ()
466+
467+ clientBuild Proxy = clientEmpty methodDelete [204]
468+
469+-- perform :: Accept
470+-- -> (Stream -> Client (Either SerializeError a))
471+-- -> Method
472+-- -> [Int]
473+-- -> RequestBuilder
474+-- -> Client a
475+-- perform a meth ns f rq = undefined -- do
476+ -- m <- ask
477+ -- x <- lift . try $ Client.http m (clientRequest meth a rq)
478+ -- either (failure . TransportError) success x
479+ -- where
480+ -- failure = pure . Left
481+
482+ -- success rs = do
483+ -- let s = Client.responseStatus rs
484+ -- b = Client.responseBody rs
485+ -- hs = Client.responseHeaders rs
486+ -- case content hs of
487+ -- unless (matches respCT (acceptCT)) $
488+ -- left $ UnsupportedContentType respCT respBody
489+
490+ -- Nothing -> failure (SerializeError' (SerializeError hs))
491+
492+ -- Just _ | statusInvalid s -> do
493+ -- lbs <- sinkLBS b
494+ -- failure (ServiceError' (ServiceError s c hs lbs))
495+
496+ -- Just c | contentInvalid c -> do
497+ -- lbs <- sinkLBS b
498+ -- failure (SerializeError' (SerializeError s c hs lbs))
499+
500+
501+ -- Just c -> first SerializeError' <$> f b
502+
503+ -- content :: [Header] -> Maybe c
504+ -- content = parseAccept
505+ -- . fromMaybe "application/octet-stream"
506+ -- . lookup hContentType
507+
508+ -- statusCheck s = fromEnum s `elem` ns
509+ -- contentCheck = matches a
510+
511+sinkLBS :: Stream -> ResourceT IO LBS.ByteString
512+sinkLBS = fmap LBS.fromChunks . ($$+- CL.consume)
513+
514+buildText :: ToText a => a -> Builder
515+buildText = Build.fromText . toText
516+
517+buildSymbol :: forall n proxy. KnownSymbol n => proxy n -> Builder
518+buildSymbol = Build.fromString . symbolVal
519+
520+textSymbol :: forall n proxy. KnownSymbol n => proxy n -> Text
521+textSymbol = Text.pack . symbolVal