072be1a · gogol · git.iko.soy

git.iko.soy/gogol

on develop help sign in

Exposing multipart non-root object's Content-Type

072be1aBrendan Hay10 years ago

core/src/Network/Google/Types.hs+35−41

compare with develop

unifiedsplit

@@ -56,14 +56,12 @@ import qualified Network.HTTP.Types as HTTP

56import Servant.API

57import Web.HttpApiData

59−data AltJSON = AltJSON deriving (Eq, Ord, Show, Read, Generic, Typeable)

59+data AltJSON = AltJSON deriving (Eq, Ord, Show, Read, Generic, Typeable)

60−data AltMedia = AltMedia deriving (Eq, Ord, Show, Read, Generic, Typeable)

60+data AltMedia = AltMedia deriving (Eq, Ord, Show, Read, Generic, Typeable)

61−

62−instance ToHttpApiData AltJSON where toQueryParam = const "json"

63−instance ToHttpApiData AltMedia where toQueryParam = const "media"

64−

65data Multipart = Multipart deriving (Eq, Ord, Show, Read, Generic, Typeable)

61data Multipart = Multipart deriving (Eq, Ord, Show, Read, Generic, Typeable)

63+instance ToHttpApiData AltJSON where toQueryParam = const "json"

64+instance ToHttpApiData AltMedia where toQueryParam = const "media"

67instance ToHttpApiData Multipart where toQueryParam = const "multipart"

65instance ToHttpApiData Multipart where toQueryParam = const "multipart"

69newtype OAuthScope = OAuthScope Text

67newtype OAuthScope = OAuthScope Text

@@ -157,7 +155,7 @@ newtype ServiceId = ServiceId Text

157 )

155 )

158

156

159newtype MediaDownload a = MediaDownload a

157newtype MediaDownload a = MediaDownload a

160−data MediaUpload a = MediaUpload a Part

158+data MediaUpload a = MediaUpload a Body

161

159

162_Coerce :: (Coercible a b, Coercible b a) => Iso' a b

160_Coerce :: (Coercible a b, Coercible b a) => Iso' a b

163_Coerce = iso coerce coerce

161_Coerce = iso coerce coerce

@@ -265,28 +263,27 @@ serviceSecure = lens _svcSecure (\s a -> s { _svcSecure = a })

265serviceTimeout :: Lens' ServiceConfig (Maybe Seconds)

263serviceTimeout :: Lens' ServiceConfig (Maybe Seconds)

266serviceTimeout = lens _svcTimeout (\s a -> s { _svcTimeout = a })

264serviceTimeout = lens _svcTimeout (\s a -> s { _svcTimeout = a })

267

265

268−-- | A single part of a multipart message.

266+-- | A single part of a (potentially multipart) request body.

269−data Part = Part MediaType [(HeaderName, ByteString)] RequestBody

267+data Body = Body !MediaType !RequestBody

270

268

271−data Payload

269+setMIMEType :: MediaType -> Body -> Body

272− = Body !MediaType !RequestBody

270+setMIMEType m (Body _ b) = Body m b

273− | Related ![Part]

274

271

275-- | An intermediary request builder.

272-- | An intermediary request builder.

276data Request = Request

273data Request = Request

277 { _rqPath :: !Builder

274 { _rqPath :: !Builder

278 , _rqQuery :: !(DList (ByteString, Maybe ByteString))

275 , _rqQuery :: !(DList (ByteString, Maybe ByteString))

279 , _rqHeaders :: !(DList (HeaderName, ByteString))

276 , _rqHeaders :: !(DList (HeaderName, ByteString))

280− , _rqBody :: !(Maybe Payload)

277+ , _rqBody :: ![Body]

281 }

278 }

282

279

283instance Monoid Request where

280instance Monoid Request where

284− mempty = Request mempty mempty mempty Nothing

281+ mempty = Request mempty mempty mempty mempty

285 mappend a b = Request

282 mappend a b = Request

286− (_rqPath a <> "/" <> _rqPath b)

283+ (_rqPath a <> "/" <> _rqPath b)

287− (_rqQuery a <> _rqQuery b)

284+ (_rqQuery a <> _rqQuery b)

288− (_rqHeaders a <> _rqHeaders b)

285+ (_rqHeaders a <> _rqHeaders b)

289− (_rqBody b <|> _rqBody a)

286+ (_rqBody b <> _rqBody a)

290

287

291appendPath :: Request -> Builder -> Request

288appendPath :: Request -> Builder -> Request

292appendPath rq x = rq { _rqPath = _rqPath rq <> "/" <> x }

289appendPath rq x = rq { _rqPath = _rqPath rq <> "/" <> x }

@@ -305,11 +302,8 @@ appendHeader rq k (Just v) = rq

305 { _rqHeaders = DList.snoc (_rqHeaders rq) (k, Text.encodeUtf8 v)

302 { _rqHeaders = DList.snoc (_rqHeaders rq) (k, Text.encodeUtf8 v)

306 }

303 }

307

304

308−setBody :: Request -> MediaType -> RequestBody -> Request

305+setBody :: Request -> [Body] -> Request

309−setBody rq c x = rq { _rqBody = Just (Body c x) }

306+setBody rq bs = rq { _rqBody = bs }

310−

311−setRelated :: Request -> [Part] -> Request

312−setRelated rq ps = rq { _rqBody = Just (Related ps) }

313

307

314-- | A materialised 'http-client' request and associated response parser.

308-- | A materialised 'http-client' request and associated response parser.

315data Client a = Client

309data Client a = Client

@@ -357,25 +351,22 @@ client f cs m ns rq s = Client

357 }

351 }

358

352

359class Accept c => ToBody c a where

353class Accept c => ToBody c a where

360− toBody :: Proxy c -> a -> RequestBody

354+ toBody :: Proxy c -> a -> Body

361−

362−instance ToBody OctetStream RequestBody where

363− toBody Proxy = id

364

355

365instance ToBody OctetStream ByteString where

356instance ToBody OctetStream ByteString where

366− toBody Proxy = RequestBodyBS

357+ toBody p = Body (contentType p) . RequestBodyBS

367

358

368instance ToBody OctetStream LBS.ByteString where

359instance ToBody OctetStream LBS.ByteString where

369− toBody Proxy = RequestBodyLBS

360+ toBody p = Body (contentType p) . RequestBodyLBS

370

361

371instance ToBody PlainText ByteString where

362instance ToBody PlainText ByteString where

372− toBody Proxy = RequestBodyBS

363+ toBody p = Body (contentType p) . RequestBodyBS

373

364

374instance ToBody PlainText LBS.ByteString where

365instance ToBody PlainText LBS.ByteString where

375− toBody Proxy = RequestBodyLBS

366+ toBody p = Body (contentType p) . RequestBodyLBS

376

367

377instance ToJSON a => ToBody JSON a where

368instance ToJSON a => ToBody JSON a where

378− toBody Proxy = RequestBodyLBS . encode

369+ toBody p = Body (contentType p) . RequestBodyLBS . encode

379

370

380class Accept c => FromStream c a where

371class Accept c => FromStream c a where

381 fromStream :: Proxy c

372 fromStream :: Proxy c

@@ -417,13 +408,18 @@ data MultipartRelated (cs :: [*]) m

417instance ( ToBody c m

408instance ( ToBody c m

418 , GoogleClient fn

409 , GoogleClient fn

419 ) => GoogleClient (MultipartRelated (c ': cs) m :> fn) where

410 ) => GoogleClient (MultipartRelated (c ': cs) m :> fn) where

420− type Fn (MultipartRelated (c ': cs) m :> fn) = m -> Part -> Fn fn

411+ type Fn (MultipartRelated (c ': cs) m :> fn) = m -> Body -> Fn fn

421

412

422 buildClient Proxy rq m b =

413 buildClient Proxy rq m b =

423 buildClient (Proxy :: Proxy fn) $

414 buildClient (Proxy :: Proxy fn) $

424− setRelated rq [Part (contentType mc) [] (toBody mc m), b]

415+ setBody rq [toBody (Proxy :: Proxy c) m, b]

425− where

416+

417+instance GoogleClient fn => GoogleClient (AltMedia :> fn) where

418+ type Fn (AltMedia :> fn) = Body -> Fn fn

419+

420+ buildClient Proxy rq b =

426− mc = Proxy :: Proxy c

421+ buildClient (Proxy :: Proxy fn) $

422+ setBody rq [b]

427

423

428instance (KnownSymbol s, GoogleClient fn) => GoogleClient (s :> fn) where

424instance (KnownSymbol s, GoogleClient fn) => GoogleClient (s :> fn) where

429 type Fn (s :> fn) = Fn fn

425 type Fn (s :> fn) = Fn fn

@@ -513,11 +509,9 @@ instance ( ToBody c a

513 ) => GoogleClient (ReqBody (c ': cs) a :> fn) where

509 ) => GoogleClient (ReqBody (c ': cs) a :> fn) where

514 type Fn (ReqBody (c ': cs) a :> fn) = a -> Fn fn

510 type Fn (ReqBody (c ': cs) a :> fn) = a -> Fn fn

515

511

512+ buildClient Proxy rq x =

516− buildClient Proxy rq = buildClient (Proxy :: Proxy fn)

513+ buildClient (Proxy :: Proxy fn) $

517− . setBody rq (contentType p)

518− . toBody p

519− where

520− p = Proxy :: Proxy c

514+ setBody rq [toBody (Proxy :: Proxy c) x]

521

515

522instance {-# OVERLAPPABLE #-}

516instance {-# OVERLAPPABLE #-}

523 FromStream c a => GoogleClient (Get (c ': cs) a) where

517 FromStream c a => GoogleClient (Get (c ': cs) a) where

gen/src/Gen/Syntax.hs+23−11

@@ -87,7 +87,7 @@ downloadAlias m

87 | _mSupportsMediaDownload m = Just download

88 | otherwise = Nothing

89 where

90− download = servantSub (downloadVerb m) (params ++ [altParam])

90+ download = servantSub (downloadVerb m) (params ++ [downloadParam])

92 params = requestQuery m . Map.delete "alt" $ requestQueryParams m

@@ -96,7 +96,7 @@ uploadAlias sub m

96 | _mSupportsMediaUpload m = Just upload

97 | otherwise = Nothing

98 where

99− upload = servantSub (jsonVerb m) (path ++ params ++ [uploadParam, media])

99+ upload = servantSub (jsonVerb m) (path ++ params ++ media)

100

101 params = requestQuery m (requestQueryParams m)

102

@@ -106,12 +106,15 @@ uploadAlias sub m

106

107 media = case _mRequest m of

108 Just b ->

109+ [ multipartParam

109− TyApp (TyApp (TyCon "MultipartRelated") jsonMedia)

110+ , TyApp (TyApp (TyCon "MultipartRelated") jsonMedia)

110− (tycon (ref b))

111+ (tycon (ref b))

112+ ]

111

113

112 Nothing ->

114 Nothing ->

113− TyApp (TyApp (TyCon "ReqBody") streamMedia)

115+ [ mediaParam

114− (TyCon "RequestBody")

116+ , TyCon "AltMedia"

117+ ]

115

118

116requestPath :: Method Solved -> Text -> [Type]

119requestPath :: Method Solved -> Text -> [Type]

117requestPath m = map go . extractPath

120requestPath m = map go . extractPath

@@ -176,13 +179,18 @@ jsonMedia, streamMedia :: Type

176jsonMedia = tylist ["JSON"]

179jsonMedia = tylist ["JSON"]

177streamMedia = tylist ["OctetStream"]

180streamMedia = tylist ["OctetStream"]

178

181

179−altParam :: Type

182+downloadParam :: Type

180−altParam =

183+downloadParam =

181 TyApp (TyApp (TyCon "QueryParam") (sing "alt"))

184 TyApp (TyApp (TyCon "QueryParam") (sing "alt"))

182 (TyCon "AltMedia")

185 (TyCon "AltMedia")

183

186

184−uploadParam :: Type

187+mediaParam :: Type

185−uploadParam =

188+mediaParam =

189+ TyApp (TyApp (TyCon "QueryParam") (sing "uploadType"))

190+ (TyCon "AltMedia")

191+

192+multipartParam :: Type

193+multipartParam =

186 TyApp (TyApp (TyCon "QueryParam") (sing "uploadType"))

194 TyApp (TyApp (TyCon "QueryParam") (sing "uploadType"))

187 (TyCon "Multipart")

195 (TyCon "Multipart")

188

196

@@ -257,7 +265,11 @@ uploadDecl n pre api url fs m =

257

265

258 extras = maybeToList alt ++ [upl] ++ payload ++ [var media]

266 extras = maybeToList alt ++ [upl] ++ payload ++ [var media]

259 where

267 where

260− upl = app (var "Just") (var "Multipart")

268+ upl = app (var "Just") $

269+ if isJust (_mRequest m)

270+ then var "Multipart"

271+ else var "AltMedia"

272+

261 alt = app (var "Just") . var . name . Text.unpack . alternate <$>

273 alt = app (var "Just") . var . name . Text.unpack . alternate <$>

262 (Map.lookup "alt" (_mParameters m) >>= view iDefault)

274 (Map.lookup "alt" (_mParameters m) >>= view iDefault)

263

275

gogol/gogol.cabal+1

@@ -75,6 +75,7 @@ library

75 , http-types >= 0.8.6

76 , lens >= 4.4

77 , memory >= 0.8

78+ , mime-types >= 0.1

78 , monad-control >= 1

79 , monad-control >= 1

79 , mtl >= 2.1.3.1

80 , mtl >= 2.1.3.1

80 , resourcet >= 1.1

81 , resourcet >= 1.1

gogol/src/Network/Google.hs+2−1

@@ -135,6 +135,7 @@ import Network.Google.Internal.Logger

135import Network.Google.Prelude

136import Network.Google.Types

137import Network.HTTP.Conduit (newManager, tlsManagerSettings)

138+import Network.HTTP.Media.MediaType (MediaType)

138

139

139newtype Google s a = Google { unGoogle :: ReaderT (Env s) (ResourceT IO) a }

140newtype Google s a = Google { unGoogle :: ReaderT (Env s) (ResourceT IO) a }

140 deriving

141 deriving

@@ -242,7 +243,7 @@ upload :: ( MonadGoogle s m

242 , GoogleRequest (MediaUpload a)

243 , GoogleRequest (MediaUpload a)

243 )

244 )

244 => a

245 => a

245− -> RequestBody

246+ -> Body

246 -> m (Rs (MediaUpload a))

247 -> m (Rs (MediaUpload a))

247upload x = send . MediaUpload x

248upload x = send . MediaUpload x

248

249

gogol/src/Network/Google/Internal/Body.hs+22−4

@@ -1,3 +1,5 @@

1+{-# LANGUAGE OverloadedStrings #-}

1-- |

3-- |

2-- Module : Network.Google.Internal.Body

4-- Module : Network.Google.Internal.Body

@@ -10,17 +12,33 @@ module Network.Google.Internal.Body where

11import Control.Monad.IO.Class (MonadIO (..))

13import Control.Monad.IO.Class (MonadIO (..))

12import Data.Conduit.Binary (sourceFile)

14import Data.Conduit.Binary (sourceFile)

15+import Data.Maybe (fromMaybe)

16+import qualified Data.Text as Text

17+import Network.Google.Types (Body (..))

13import Network.HTTP.Conduit (RequestBody, requestBodySource)

18import Network.HTTP.Conduit (RequestBody, requestBodySource)

19+import Network.HTTP.Media (MediaType, parseAccept, (//))

20+import qualified Network.Mime as MIME

14import System.IO

21import System.IO

16-- | Convenience function for obtaining the size of a file.

23-- | Convenience function for obtaining the size of a file.

17getFileSize :: MonadIO m => FilePath -> m Integer

24getFileSize :: MonadIO m => FilePath -> m Integer

18getFileSize f = liftIO (withBinaryFile f ReadMode hFileSize)

25getFileSize f = liftIO (withBinaryFile f ReadMode hFileSize)

27+getMIMEType :: FilePath -> MediaType

28+getMIMEType =

29+ fromMaybe ("application" // "octet-stream")

30+ . parseAccept

31+ . MIME.defaultMimeLookup

32+ . Text.takeWhileEnd (/= '/')

33+ . Text.pack

34+

20−-- | Construct a 'RequestBody' from a 'FilePath'.

35+-- | Construct a 'Body' from a 'FilePath'.

21--

36--

22−-- /See:/ 'ToBody'.

37+-- This attempts to guess the MIME type from the file extension,

38+-- you can use "Network.Google.Types.setMIMEType" to set a MIME type explicitly.

23−sourceBody :: MonadIO m => FilePath -> m RequestBody

39+sourceBody :: MonadIO m => FilePath -> m Body

24sourceBody f = do

40sourceBody f = do

25 n <- getFileSize f

41 n <- getFileSize f

42+ pure $ Body

43+ (getMIMEType f)

26− pure $ requestBodySource (fromIntegral n) (sourceFile f)

44+ (requestBodySource (fromIntegral n) (sourceFile f))

gogol/src/Network/Google/Internal/HTTP.hs+8−9

@@ -123,13 +123,12 @@ perform Env{..} x = catches go handlers

123 err e = return (Left e)

124

125getContent :: MonadIO m

126− => Maybe Payload

126+ => [Body]

127 -> m ([Header] -> [Header], RequestBody)

128−getContent = \case

129− Nothing -> pure (id, mempty)

128+getContent [] = pure (id, mempty)

130− Just (Body t s) -> pure (((hContentType, renderHeader t) :), s)

129+getContent [Body t s] = pure (((hContentType, renderHeader t) :), s)

131− Just (Related ps) -> do

130+getContent bs = do

132− b <- genBoundary

131+ b <- genBoundary

133− pure ( (multipartHeader b :)

132+ pure ( (multipartHeader b :)

134− , renderParts b ps

133+ , renderParts b bs

135− )

134+ )

gogol/src/Network/Google/Internal/Logger.hs+2−1

@@ -147,7 +147,6 @@ instance ToLog RequestBody where

147 build = \case

148 RequestBodyBuilder n _ -> " <msger:" <> build n <> ">"

149 RequestBodyStream n _ -> " <stream:" <> build n <> ">"

150− RequestBodyStreamChunked _ -> " <chunked>"

151

150

152 RequestBodyLBS lbs

151 RequestBodyLBS lbs

153 | n <= 4096 -> build lbs

152 | n <= 4096 -> build lbs

@@ -161,6 +160,8 @@ instance ToLog RequestBody where

161 where

160 where

162 n = BS.length bs

161 n = BS.length bs

163

162

163+ _ -> " <chunked>"

164+

164instance ToLog HttpException where

165instance ToLog HttpException where

165 build x = "[HttpException] {\n" <> build (show x) <> "\n}"

166 build x = "[HttpException] {\n" <> build (show x) <> "\n}"

166

167

gogol/src/Network/Google/Internal/Multipart.hs+7−12

@@ -1,4 +1,4 @@

1− {-# LANGUAGE OverloadedStrings #-}

1+{-# LANGUAGE OverloadedStrings #-}

3-- |

4-- Module : Network.Google.Internal.Multipart

@@ -12,14 +12,14 @@ module Network.Google.Internal.Multipart where

13import Control.Monad.IO.Class (MonadIO (..))

14import Data.ByteString (ByteString)

15−import qualified Data.ByteString as BS

15+import qualified Data.ByteString as BS

16import Data.ByteString.Builder.Extra (byteStringCopy)

17−import qualified Data.CaseInsensitive as CI

17+import qualified Data.CaseInsensitive as CI

18import Data.Monoid ((<>))

19−import Network.Google.Types (Part (..))

19+import Network.Google.Types (Body (..))

20import Network.HTTP.Client

21import Network.HTTP.Client.MultipartFormData (webkitBoundary)

22−import Network.HTTP.Media (RenderHeader(..))

22+import Network.HTTP.Media (RenderHeader (..))

23import Network.HTTP.Types (Header, hContentType)

25-- POST /upload/drive/v2/files?uploadType=multipart HTTP/1.1

@@ -58,18 +58,13 @@ part (Boundary bs) = copy "--" <> copy bs <> copy "--\r\n"

58copy :: ByteString -> RequestBody

59copy bs = RequestBodyBuilder (fromIntegral (BS.length bs)) (byteStringCopy bs)

61−renderParts :: Boundary -> [Part] -> RequestBody

61+renderParts :: Boundary -> [Body] -> RequestBody

62renderParts b = (<> part b) . foldMap go

63 where

64− go (Part ct hs x) =

64+ go (Body ct x) =

65 start b

66 <> copy "Content-Type: "

67 <> copy (renderHeader ct)

68− <> foldMap (\(k, v) ->

69− copy "\r\n"

70− <> copy (CI.original k)

71− <> copy ": "

72− <> copy v) hs

73 <> copy "\r\n\r\n"

68 <> copy "\r\n\r\n"

74 <> x

69 <> x

75 <> copy "\r\n"

70 <> copy "\r\n"