git.iko.soy/gogol
on develop help sign in
Adding Upload plumbing for multipart/related media uploads
commit6264d0fd2d00ba8719ef973680293d0f4870efd5 authorBrendan Hay <brendan.g.hay@gmail.com> dateFri 23 Oct 2015, 18:06 (11 years ago) parentf4c3a1e
5 files changed+39−36
compare with develop
unifiedsplit
core/src/Network/Google/Types.hs+15−24 gen/src/Gen/Syntax.hs+3−3 gogol/src/Network/Google.hs+19−4 gogol/src/Network/Google/Internal/HTTP.hs+1−4 gogol/src/Network/Google/Internal/Multipart.hs+1−1
core/src/Network/Google/Types.hs+15−24
@@ -48,7 +48,7 @@ import Data.Text.Lazy.Builder (Builder)
4848import qualified Data.Text.Lazy.Builder as Build
4949import GHC.Generics
5050import GHC.TypeLits
51−import Network.HTTP.Client (HttpException)
51+import Network.HTTP.Client (HttpException, RequestBody (..))
5252import Network.HTTP.Media hiding (Accept)
5353import Network.HTTP.Types hiding (Header)
5454import qualified Network.HTTP.Types as HTTP
@@ -83,8 +83,7 @@ instance ToJSON OAuthToken where
8383
8484newtype Download a = Download a
8585
86−_Download :: Iso' (Download a) a
87−_Download = iso (\(Download x) -> x) Download
86+data Upload a = Upload a RequestBody
8887
8988_Coerce :: (Coercible a b, Coercible b a) => Iso' a b
9089_Coerce = iso coerce coerce
@@ -97,7 +96,6 @@ _Default = iso f Just
9796 f (Just x) = x
9897 f Nothing = mempty
9998
100−type Body = Source IO ByteString
10199type Stream = ResumableSource (ResourceT IO) ByteString
102100
103101newtype ClientId = ClientId { clientIdToText :: Text }
@@ -167,30 +165,23 @@ instance AsError Error where
167165data Service = Service
168166 { _svcId :: !ServiceId
169167 , _svcHost :: !ByteString
170− , _svcPath :: !Builder
171168 , _svcPort :: !Int
172169 , _svcSecure :: !Bool
173170 , _svcTimeout :: !(Maybe Seconds)
174− , _svcScopes :: ![OAuthScope]
175171 }
176172
177−defaultService :: ServiceId -> ByteString -> Builder -> Service
178−defaultService i h p = Service
173+defaultService :: ServiceId -> ByteString -> Service
174+defaultService i h = Service
179175 { _svcId = i
180176 , _svcHost = h
181− , _svcPath = p
182177 , _svcPort = 443
183178 , _svcSecure = True
184179 , _svcTimeout = Just 70
185− , _svcScopes = []
186180 }
187181
188182serviceHost :: Lens' Service ByteString
189183serviceHost = lens _svcHost (\s a -> s { _svcHost = a })
190184
191−servicePath :: Lens' Service Builder
192−servicePath = lens _svcPath (\s a -> s { _svcPath = a })
193−
194185servicePort :: Lens' Service Int
195186servicePort = lens _svcPort (\s a -> s { _svcPort = a })
196187
@@ -201,10 +192,10 @@ serviceTimeout :: Lens' Service (Maybe Seconds)
201192serviceTimeout = lens _svcTimeout (\s a -> s { _svcTimeout = a })
202193
203194-- | A single part of a multipart message.
204−data Part = Part MediaType [(HeaderName, ByteString)] Body
195+data Part = Part MediaType [(HeaderName, ByteString)] RequestBody
205196
206197data Payload
207− = Body !MediaType !Body
198+ = Body !MediaType !RequestBody
208199 | Related ![Part]
209200
210201-- | An intermediary request builder.
@@ -221,7 +212,7 @@ instance Monoid Request where
221212 (_rqPath a <> "/" <> _rqPath b)
222213 (_rqQuery a <> _rqQuery b)
223214 (_rqHeaders a <> _rqHeaders b)
224− (_rqBody b <|> _rqBody a)
215+ (_rqBody b <|> _rqBody a)
225216
226217appendPath :: Request -> Builder -> Request
227218appendPath rq x = rq { _rqPath = _rqPath rq <> "/" <> x }
@@ -240,7 +231,7 @@ appendHeader rq k (Just v) = rq
240231 { _rqHeaders = DList.snoc (_rqHeaders rq) (k, Text.encodeUtf8 v)
241232 }
242233
243−setBody :: Request -> MediaType -> Body -> Request
234+setBody :: Request -> MediaType -> RequestBody -> Request
244235setBody rq c x = rq { _rqBody = Just (Body c x) }
245236
246237setRelated :: Request -> [Part] -> Request
@@ -282,25 +273,25 @@ client f cs m ns rq s = Client
282273 }
283274
284275class Accept c => ToBody c a where
285− toBody :: Proxy c -> a -> Body
276+ toBody :: Proxy c -> a -> RequestBody
286277
287−instance ToBody OctetStream Body where
278+instance ToBody OctetStream RequestBody where
288279 toBody Proxy = id
289280
290281instance ToBody OctetStream ByteString where
291− toBody Proxy = CL.sourceList . (:[])
282+ toBody Proxy = RequestBodyBS
292283
293284instance ToBody OctetStream LBS.ByteString where
294− toBody Proxy = CL.sourceList . LBS.toChunks
285+ toBody Proxy = RequestBodyLBS
295286
296287instance ToBody PlainText ByteString where
297− toBody Proxy = CL.sourceList . (:[])
288+ toBody Proxy = RequestBodyBS
298289
299290instance ToBody PlainText LBS.ByteString where
300− toBody Proxy = CL.sourceList . LBS.toChunks
291+ toBody Proxy = RequestBodyLBS
301292
302293instance ToJSON a => ToBody JSON a where
303− toBody Proxy = CL.sourceList . LBS.toChunks . encode
294+ toBody Proxy = RequestBodyLBS . encode
304295
305296class Accept c => FromStream c a where
306297 fromStream :: Proxy c -> Stream -> ResourceT IO (Either String a)
gen/src/Gen/Syntax.hs+3−3
@@ -187,9 +187,9 @@ downloadPat = pattern 2
187187uploadPat = pattern 3
188188
189189pattern n m = case (n, down, up) of
190− (1, True, True) -> infixOr (infixOr go wild) wild
191− (2, True, True) -> infixOr (infixOr wild go) wild
192− (_, True, True) -> infixOr (infixOr wild wild) go
190+ (1, True, True) -> infixOr go (infixOr wild wild)
191+ (2, True, True) -> infixOr wild (infixOr go wild)
192+ (_, True, True) -> infixOr wild (infixOr wild go)
193193
194194 (1, True, _) -> infixOr go wild
195195 (_, True, _) -> infixOr wild go
gogol/src/Network/Google.hs+19−4
@@ -45,6 +45,14 @@ module Network.Google
4545 -- ** Media Downloads
4646 , download
4747
48+ -- ** Media Uploads
49+ , upload
50+
51+ , ToBody (..)
52+ , RequestBody
53+ , requestBodySource
54+ , requestBodySourceChunked
55+
4856 -- ** Service Configuration
4957 -- ** Overriding Defaults
5058 , configure
@@ -54,10 +62,6 @@ module Network.Google
5462 , reconfigure
5563 , timeout
5664
57− -- ** Media Uploads
58− , Body
59− , ToBody (..)
60−
6165 -- * Running Asynchronous Actions
6266 -- $async
6367
@@ -109,6 +113,8 @@ import Network.Google.Internal.HTTP
109113import Network.Google.Internal.Logger
110114import Network.Google.Prelude
111115import Network.Google.Types
116+import Network.HTTP.Conduit (requestBodySource,
117+ requestBodySourceChunked)
112118
113119newtype Google a = Google { unGoogle :: ReaderT Env (ResourceT IO) a }
114120 deriving
@@ -190,6 +196,15 @@ download :: (MonadGoogle m, GoogleRequest (Download a))
190196 -> m (Rs (Download a))
191197download = send . Download
192198
199+-- | Send a request with an attached multipart/related media upload.
200+--
201+-- Throws 'Error'.
202+upload :: (MonadGoogle m, GoogleRequest (Upload a))
203+ => a
204+ -> RequestBody
205+ -> m (Rs (Upload a))
206+upload = send . Upload
207+
193208hoistError :: MonadThrow m => Either Error a -> m a
194209hoistError = either (throwingM _Error) return
195210
gogol/src/Network/Google/Internal/HTTP.hs+1−4
@@ -120,10 +120,7 @@ getContent :: MonadIO m
120120 -> m ([Header] -> [Header], RequestBody)
121121getContent = \case
122122 Nothing -> pure (id, mempty)
123− Just (Body t s) -> pure
124− ( ((hContentType, renderHeader t) :)
125− , Client.requestBodySourceChunked s
126− )
123+ Just (Body t s) -> pure (((hContentType, renderHeader t) :), s)
127124 Just (Related ps) -> do
128125 b <- genBoundary
129126 pure ( (multipartHeader b :)
gogol/src/Network/Google/Internal/Multipart.hs+1−1
@@ -72,5 +72,5 @@ renderParts b = (<> part b) . foldMap go
7272 <> copy ": "
7373 <> copy v) hs
7474 <> copy "\r\n\r\n"
75− <> Client.requestBodySourceChunked x
75+ <> x
7676 <> copy "\r\n"