git.iko.soy/gogol
on develop help sign in
Adding start of custom servant client
f970490Brendan Hay
core/gogol-core.cabal+7−6
compare with develop
unifiedsplit
@@ -36,24 +36,25 @@ library
36 ghc-options: -Wall
36 ghc-options: -Wall
37
37
38 exposed-modules:
38 exposed-modules:
39− Network.Google.Prelude
39+ Network.Google.Client
40−
41− other-modules:
42− Network.Google.Data.JSON
40+ , Network.Google.Data.JSON
43 , Network.Google.Data.Numeric
41 , Network.Google.Data.Numeric
44 , Network.Google.Data.Time
42 , Network.Google.Data.Time
43+ , Network.Google.Prelude
44+ , Network.Google.Types
45
45
46 build-depends:
46 build-depends:
47 aeson >= 0.8
47 aeson >= 0.8
48 , base >= 4.7 && < 5
48 , base >= 4.7 && < 5
49− , either
49+ , bytestring
50 , hashable >= 1.2
50 , hashable >= 1.2
51 , http-media
51 , http-media
52+ , http-types
52 , lens >= 4.4
53 , lens >= 4.4
53 , scientific >= 0.3
54 , scientific >= 0.3
54 , servant >= 0.4.4
55 , servant >= 0.4.4
55− , servant-client
56 , text >= 1.1
56 , text >= 1.1
57+ , dlist >= 0.7
57
58
58 if !impl(ghc>=7.9)
59 if !impl(ghc>=7.9)
59 build-depends:
60 build-depends:
core/src/Network/Google/Client.hsnew file+241
@@ -0,0 +1,241 @@
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+{-# LANGUAGE UndecidableInstances #-}
13+
14+-- |
15+-- Module : Network.Google.Client
16+-- Copyright : (c) 2015 Brendan Hay <brendan.g.hay@gmail.com>
17+-- License : Mozilla Public License, v. 2.0.
18+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
19+-- Stability : provisional
20+-- Portability : non-portable (GHC extensions)
21+--
22+module Network.Google.Client where
23+
24+import Control.Lens
25+import Data.ByteString (ByteString)
26+import qualified Data.ByteString.Lazy as LBS
27+import 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)
32+import Data.Monoid
33+import 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
38+import GHC.Generics
39+import GHC.TypeLits
40+import Network.Google.Types
41+import Network.HTTP.Media
42+import Network.HTTP.Types
43+import Servant.API hiding (Header)
44+
45+-- import Servant.API
46+-- import Servant.Utils.Links
47+
48+data Body = Body -- MediaType
49+ deriving (Eq, Show, Generic, Data, Typeable)
50+
51+data Request = Request
52+ { _rqHost :: ByteString
53+ , _rqPort :: Int
54+ , _rqBasePath :: ByteString
55+ , _rqPath :: Builder
56+ , _rqQuery :: DList (Text, Maybe Text)
57+ , _rqHeaders :: [Header]
58+ , _rqBody :: Maybe (MediaType, LBS.ByteString)
59+ , _rqAccept :: [MediaType]
60+ }
61+
62+defaultRequest :: ByteString -- ^ Host.
63+ -> Int -- ^ Port.
64+ -> ByteString -- ^ Base Path.
65+ -> Request
66+defaultRequest h n p = Request
67+ { _rqHost = h
68+ , _rqPort = n
69+ , _rqBasePath = p
70+ , _rqPath = mempty
71+ , _rqQuery = mempty
72+ , _rqHeaders = mempty
73+ , _rqBody = Nothing
74+ , _rqAccept = mempty
75+ }
76+
77+appendPath :: Request -> Builder -> Request
78+appendPath rq x = rq { _rqPath = _rqPath rq <> "/" <> x }
79+
80+appendPaths :: ToText a => Request -> [a] -> Request
81+appendPaths rq = appendPath rq . foldMap (mappend "/" . buildText)
82+
83+appendQuery :: Request -> Text -> Maybe Text -> Request
84+appendQuery rq k v = rq { _rqQuery = DList.snoc (_rqQuery rq) (k, v) }
85+
86+setBody :: Request -> MediaType -> LBS.ByteString -> Request
87+setBody rq c x = rq { _rqBody = Just (c, x) }
88+
89+buildText :: ToText a => a -> Builder
90+buildText = Build.fromText . toText
91+
92+buildSymbol :: forall n proxy. KnownSymbol n => proxy n -> Builder
93+buildSymbol = Build.fromString . symbolVal
94+
95+textSymbol :: forall n proxy. KnownSymbol n => proxy n -> Text
96+textSymbol = Text.pack . symbolVal
97+
98+data Error = Error
99+ deriving (Generic, Data, Typeable)
100+
101+data Captures (s :: Symbol) a
102+ deriving (Typeable)
103+
104+data CaptureMode (s :: Symbol) (m :: Symbol) a
105+ deriving (Typeable)
106+
107+data MultipartRelated (cs :: [*]) meta body
108+ deriving (Typeable)
109+
110+class GoogleRequest a where
111+ type Rs a :: *
112+
113+ request :: a -> IO (Either Error (Rs a))
114+ requestWith :: Request -> a -> IO (Either Error (Rs a))
115+
116+class GoogleClient fn where
117+ type Fn fn :: *
118+
119+ requestBuild :: Proxy fn -> Request -> Fn fn
120+
121+instance (KnownSymbol s, GoogleClient fn) => GoogleClient (s :> fn) where
122+ type Fn (s :> fn) = Fn fn
123+
124+ requestBuild Proxy rq = requestBuild (Proxy :: Proxy fn) $
125+ appendPath rq (buildSymbol (Proxy :: Proxy s))
126+
127+instance (GoogleClient a, GoogleClient b) => GoogleClient (a :<|> b) where
128+ type Fn (a :<|> b) = Fn a :<|> Fn b
129+
130+ requestBuild Proxy rq =
131+ requestBuild (Proxy :: Proxy a) rq
132+ :<|> requestBuild (Proxy :: Proxy b) rq
133+
134+instance ( KnownSymbol s
135+ , ToText a
136+ , GoogleClient fn
137+ ) => GoogleClient (Capture s a :> fn) where
138+ type Fn (Capture s a :> fn) = a -> Fn fn
139+
140+ requestBuild Proxy rq = requestBuild (Proxy :: Proxy fn)
141+ . appendPath rq
142+ . buildText
143+
144+instance ( KnownSymbol s
145+ , ToText a
146+ , GoogleClient fn
147+ ) => GoogleClient (Captures s a :> fn) where
148+ type Fn (Captures s a :> fn) = [a] -> Fn fn
149+
150+ requestBuild Proxy rq = requestBuild (Proxy :: Proxy fn)
151+ . appendPaths rq
152+
153+instance ( KnownSymbol s
154+ , KnownSymbol m
155+ , ToText a
156+ , GoogleClient fn
157+ ) => GoogleClient (CaptureMode s m a :> fn) where
158+ type Fn (CaptureMode s m a :> fn) = a -> Fn fn
159+
160+ requestBuild Proxy rq x = requestBuild (Proxy :: Proxy fn)
161+ . appendPath rq
162+ $ buildText x <> buildSymbol (Proxy :: Proxy m)
163+
164+instance ( KnownSymbol s
165+ , ToText a
166+ , GoogleClient fn
167+ ) => GoogleClient (QueryParam s a :> fn) where
168+ type Fn (QueryParam s a :> fn) = Maybe a -> Fn fn
169+
170+ requestBuild Proxy rq mx = requestBuild (Proxy :: Proxy fn) $
171+ case mx of
172+ Nothing -> rq
173+ Just x -> appendQuery rq k v
174+ where
175+ k = textSymbol (Proxy :: Proxy s)
176+ v = Just (toText x)
177+
178+instance ( KnownSymbol s
179+ , ToText a
180+ , GoogleClient fn
181+ ) => GoogleClient (QueryParams s a :> fn) where
182+ type Fn (QueryParams s a :> fn) = [a] -> Fn fn
183+
184+ requestBuild Proxy rq = requestBuild (Proxy :: Proxy fn) . foldl' go rq
185+ where
186+ go r = appendQuery r k . Just . toText
187+
188+ k = textSymbol (Proxy :: Proxy s)
189+
190+instance ( MimeRender c a
191+ , GoogleClient fn
192+ ) => GoogleClient (ReqBody (c ': cs) a :> fn) where
193+ type Fn (ReqBody (c ': cs) a :> fn) = a -> Fn fn
194+
195+ requestBuild Proxy rq = requestBuild (Proxy :: Proxy fn)
196+ . setBody rq (contentType p)
197+ . mimeRender p
198+ where
199+ p = Proxy :: Proxy c
200+
201+instance MimeUnrender c a => GoogleClient (Get (c ': cs) a) where
202+ type Fn (Get (c ': cs) a) = IO (Either Error a)
203+
204+ requestBuild Proxy rq = undefined -- perform . methodGet [200, 203]
205+
206+instance GoogleClient (Get (c ': cs) ()) where
207+ type Fn (Get (c ': cs) ()) = IO (Either Error ())
208+
209+ requestBuild Proxy rq = undefined -- perform . methodGet [204]
210+
211+instance MimeUnrender c a => GoogleClient (Post (c ': cs) a) where
212+ type Fn (Post (c ': cs) a) = IO (Either Error a)
213+
214+ requestBuild Proxy rq = undefined -- perform . methodPost [200, 201]
215+
216+instance GoogleClient (Post (c ': cs) ()) where
217+ type Fn (Post (c ': cs) ()) = IO (Either Error ())
218+
219+ requestBuild Proxy rq = undefined -- perform . methodPost [204]
220+
221+instance MimeUnrender c a => GoogleClient (Put (c ': cs) a) where
222+ type Fn (Put (c ': cs) a) = IO (Either Error a)
223+
224+ requestBuild Proxy rq = undefined -- perform . methodPut [200, 201]
225+
226+instance GoogleClient (Put (c ': cs) ()) where
227+ type Fn (Put (c ': cs) ()) = IO (Either Error ())
228+
229+ requestBuild Proxy rq = undefined -- perform . methodPut [204]
230+
231+instance MimeUnrender c a => GoogleClient (Patch (c ': cs) a) where
232+ type Fn (Patch (c ': cs) a) = IO (Either Error a)
233+
234+ requestBuild Proxy rq = undefined -- perform . methodPatch [200, 201]
235+
236+instance GoogleClient (Patch (c ': cs) ()) where
237+ type Fn (Patch (c ': cs) ()) = IO (Either Error ())
238+
239+ requestBuild Proxy rq = undefined -- perform . methodPatch [204]
240+
241+-- MultipartRelated
core/src/Network/Google/Prelude.hs+22−92
@@ -26,9 +26,7 @@ module Network.Google.Prelude
26import Control.Applicative as Export (pure, (<$>), (<*>))
26import Control.Applicative as Export (pure, (<$>), (<*>))
27import Control.Lens as Export (Lens', lens, mapping,
27import Control.Lens as Export (Lens', lens, mapping,
28 (^.), _Just)
28 (^.), _Just)
29−import Control.Lens hiding (coerce)
29+import Control.Lens
30−import Control.Monad.Trans.Either as Export (EitherT)
31−import Data.Coerce
32import Data.Data as Export (Data, Typeable)
30import Data.Data as Export (Data, Typeable)
33import Data.Hashable as Export
31import Data.Hashable as Export
34import Data.Int as Export (Int32, Int64)
32import Data.Int as Export (Int32, Int64)
@@ -41,108 +39,40 @@ import Data.Time as Export
41import Data.Word as Export (Word32, Word64, Word8)
39import Data.Word as Export (Word32, Word64, Word8)
42import GHC.Generics as Export (Generic)
40import GHC.Generics as Export (Generic)
43import GHC.TypeLits
41import GHC.TypeLits
42+import Network.Google.Client as Export
44import Network.Google.Data.JSON as Export
43import Network.Google.Data.JSON as Export
45import Network.Google.Data.Numeric as Export
44import Network.Google.Data.Numeric as Export
46import Network.Google.Data.Time as Export
45import Network.Google.Data.Time as Export
47−-- import Network.HTTP.Media
46+import Network.Google.Types as Export
48import Numeric.Natural as Export (Natural)
47import Numeric.Natural as Export (Natural)
49import Prelude as Export hiding (product)
48import Prelude as Export hiding (product)
50−import Servant.API as Export
49+import Servant.API as Export hiding (getResponse)
51−import Servant.Client as Export
50+-- import Servant.Client as Export
52−import Servant.Common.Req as Export (Req, defReq)
51+-- import Servant.Common.Req as Export (Req, defReq)
53−import Servant.Common.Req (appendToPath)
52+-- import Servant.Common.Req (appendToPath)
54import Servant.Utils.Links as Export hiding (Link)
53import Servant.Utils.Links as Export hiding (Link)
55
54
56−_Coerce :: (Coercible a b, Coercible b a) => Iso' a b
55+-- data Body = Body -- MediaType
57−_Coerce = iso coerce coerce
56+-- deriving (Eq, Show, Generic, Data, Typeable)
58
57
59−-- | Invalid Iso, exists for ease of composition with the current 'Lens . Iso'
58+-- -- data ReqStream
60−-- chaining to hide internal types from the user.
59+-- -- data ResStream
61−_Default :: Monoid a => Iso' (Maybe a) a
60+-- -- type API = ReqBody '[JSON] Request :> Post '[JSON] Response
62−_Default = iso f Just
61+-- -- type API = MultipartRelated '[JSON] Meta '[JSON] Media :> Post '[JSON] Response
63− where
64− f (Just x) = x
65− f Nothing = mempty
66
62
67−data AltJSON = AltJSON
63+-- instance MimeRender OctetStream Body
68− deriving (Eq, Ord, Show, Read, Generic, Data, Typeable)
64+-- instance MimeUnrender OctetStream Body
69
65
70−instance ToText AltJSON where
66+-- data MultipartRelated (metatypes :: [*]) meta media
71− toText = const "json"
67+-- deriving (Typeable)
72
68
73−data AltMedia = AltMedia
69+-- instance (MimeUnrender ct a, HasClient sublayout)
74− deriving (Eq, Ord, Show, Read, Generic, Data, Typeable)
70+-- => HasClient (MultipartRelated (ct ': cts) a b :> sublayout) where
75
71
76−instance ToText AltMedia where
72+-- type Client (MultipartRelated (ct ': cts) a b :> sublayout) =
77− toText = const "media"
73+-- a -> b -> Client sublayout
78
74
79−class GoogleRequest a where
80− type Rs a :: *
81−
82− requestWithRoute :: Req -> BaseUrl -> a -> EitherT ServantError IO (Rs a)
83− request :: a -> EitherT ServantError IO (Rs a)
84−
85−newtype AuthKey = AuthKey Text
86− deriving (Eq, Ord, Show, Read, Generic, Data, Typeable, ToText, FromText)
87−
88−newtype OAuthToken = OAuthToken Text
89− deriving (Eq, Ord, Show, Read, Generic, Data, Typeable, ToText, FromText)
90−
91−class GoogleAuth a where
92− authKey :: Traversal' a AuthKey
93− authToken :: Traversal' a OAuthToken
94− -- ^ only set if unset semantics?
95−
96−newtype MediaDownload a = MediaDownload a
97−
98−_MediaDownload :: Iso' (MediaDownload a) a
99−_MediaDownload = iso (\(MediaDownload x) -> x) MediaDownload
100−
101−instance GoogleAuth a => GoogleAuth (MediaDownload a) where
102− authKey = _MediaDownload . authKey
103− authToken = _MediaDownload . authToken
104−
105−data Body = Body -- MediaType
106− deriving (Eq, Show, Generic, Data, Typeable)
107−
108−data Captures (capture :: Symbol) a
109− deriving (Typeable)
110−
111−instance (KnownSymbol capture, ToText a, HasClient sublayout)
112− => HasClient (Captures capture a :> sublayout) where
113− type Client (Captures capture a :> sublayout) = [a] -> Client sublayout
114−
115− clientWithRoute Proxy req baseUrl xs =
116− clientWithRoute (Proxy :: Proxy sublayout) (appendToPath vs req) baseUrl
117− where
118− vs = Text.unpack $ Text.intercalate "/" (map toText xs)
119−
120−data CaptureMode (capture :: Symbol) (mode :: Symbol) a
121− deriving (Typeable)
122−
123−instance (KnownSymbol capture, KnownSymbol mode, ToText a, HasClient sublayout)
124− => HasClient (CaptureMode capture mode a :> sublayout) where
125− type Client (CaptureMode capture mode a :> sublayout) = a -> Client sublayout
126−
127− clientWithRoute Proxy req baseUrl val =
128− clientWithRoute (Proxy :: Proxy sublayout) (appendToPath p req) baseUrl
129− where
130− p = Text.unpack (toText val) <> m
131− m = symbolVal (Proxy :: Proxy mode)
132−
133−instance MimeRender OctetStream Body
134−instance MimeUnrender OctetStream Body
135−
136−data MultipartRelated (metatypes :: [*]) meta media
137− deriving (Typeable)
138−
139−instance (MimeUnrender ct a, HasClient sublayout)
140− => HasClient (MultipartRelated (ct ': cts) a b :> sublayout) where
141−
142− type Client (MultipartRelated (ct ': cts) a b :> sublayout) =
143− a -> b -> Client sublayout
144−
145− clientWithRoute Proxy req baseurl meta media = undefined
75+-- clientWithRoute Proxy req baseurl meta media = undefined
146
76
147 -- clientWithRoute (Proxy :: Proxy sublayout)
77 -- clientWithRoute (Proxy :: Proxy sublayout)
148 -- (let ctProxy = Proxy :: Proxy ct
78 -- (let ctProxy = Proxy :: Proxy ct
core/src/Network/Google/Types.hsnew file+67
@@ -0,0 +1,67 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+
6+-- |
7+-- Module : Network.Google.Types
8+-- Copyright : (c) 2015 Brendan Hay <brendan.g.hay@gmail.com>
9+-- License : Mozilla Public License, v. 2.0.
10+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
11+-- Stability : provisional
12+-- Portability : non-portable (GHC extensions)
13+--
14+module Network.Google.Types where
15+
16+import Control.Lens hiding (coerce)
17+import Data.Coerce
18+import Data.Data
19+import Data.Monoid
20+import Data.Text (Text)
21+import GHC.Generics
22+import Network.HTTP.Types
23+import Servant.API
24+import Servant.Utils.Links
25+
26+data AltJSON = AltJSON
27+ deriving (Eq, Ord, Show, Read, Generic, Data, Typeable)
28+
29+instance ToText AltJSON where
30+ toText = const "json"
31+
32+data AltMedia = AltMedia
33+ deriving (Eq, Ord, Show, Read, Generic, Data, Typeable)
34+
35+instance ToText AltMedia where
36+ toText = const "media"
37+
38+newtype AuthKey = AuthKey Text
39+ deriving (Eq, Ord, Show, Read, Generic, Data, Typeable, ToText, FromText)
40+
41+newtype OAuthToken = OAuthToken Text
42+ deriving (Eq, Ord, Show, Read, Generic, Data, Typeable, ToText, FromText)
43+
44+class GoogleAuth a where
45+ authKey :: Traversal' a AuthKey
46+ authToken :: Traversal' a OAuthToken
47+ -- ^ only set if unset semantics?
48+
49+newtype MediaDownload a = MediaDownload a
50+
51+_MediaDownload :: Iso' (MediaDownload a) a
52+_MediaDownload = iso (\(MediaDownload x) -> x) MediaDownload
53+
54+instance GoogleAuth a => GoogleAuth (MediaDownload a) where
55+ authKey = _MediaDownload . authKey
56+ authToken = _MediaDownload . authToken
57+
58+_Coerce :: (Coercible a b, Coercible b a) => Iso' a b
59+_Coerce = iso coerce coerce
60+
61+-- | Invalid Iso, exists for ease of composition with the current 'Lens . Iso'
62+-- chaining to hide internal types from the user.
63+_Default :: Monoid a => Iso' (Maybe a) a
64+_Default = iso f Just
65+ where
66+ f (Just x) = x
67+ f Nothing = mempty