@@ -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