http-client 0.2.3.1 → 0.3.0
raw patch · 3 files changed
+233/−13 lines, 3 filesdep +arraydep +exceptionsdep +filepathdep ~failure
Dependencies added: array, exceptions, filepath, mime-types, random
Dependency ranges changed: failure
Files
- Network/HTTP/Client/MultipartFormData.hs +215/−0
- Network/HTTP/Client/Request.hs +11/−11
- http-client.cabal +7/−2
+ Network/HTTP/Client/MultipartFormData.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE CPP, OverloadedStrings #-}+-- | This module handles building multipart/form-data. Example usage:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import Network+-- > import Network.HTTP.Conduit+-- > import Network.HTTP.Conduit.MultipartFormData+-- >+-- > import Data.Text.Encoding as TE+-- >+-- > import Control.Monad+-- >+-- > main = withSocketsDo $ withManager $ \m -> do+-- > req1 <- parseUrl "http://random-cat-photo.net/cat.jpg"+-- > res <- httpLbs req1 m+-- > req2 <- parseUrl "http://example.org/~friedrich/blog/addPost.hs"+-- > flip httpLbs m =<<+-- > (formDataBody [partBS "title" "Bleaurgh"+-- > ,partBS "text" $ TE.encodeUtf8 "矢田矢田矢田矢田矢田"+-- > ,partFileSource "file1" "/home/friedrich/Photos/MyLittlePony.jpg"+-- > ,partFileRequestBody "file2" "cat.jpg" $ RequestBodyLBS $ responseBody res]+-- > req2)+module Network.HTTP.Client.MultipartFormData+ (+ -- * Part type+ Part(..)+ -- * Constructing parts+ ,partBS+ ,partLBS+ ,partFile+ ,partFileSource+ ,partFileSourceChunked+ ,partFileRequestBody+ ,partFileRequestBodyM+ -- * Building form data+ ,formDataBody+ ,formDataBodyWithBoundary+ -- * Boundary+ ,webkitBoundary+ ,webkitBoundaryPure+ -- * Misc+ ,renderParts+ ,renderPart+ ) where++import Network.HTTP.Client+import Network.Mime+import Network.HTTP.Types (hContentType, methodPost)+import Data.Monoid ((<>))++import Blaze.ByteString.Builder++import Data.Text+import qualified Data.Text.Encoding as TE+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as BS++import Control.Monad.Trans.State.Strict (state, runState)+import Control.Monad.IO.Class+import System.FilePath+import System.Random+import Data.Array.Base+import System.IO+import Data.Bits+import Data.Word+import Data.Monoid (Monoid(..))+import Control.Monad+import Data.ByteString.Lazy.Internal (defaultChunkSize)++-- | A single part of a multipart message.+data Part = Part+ { partName :: Text -- ^ Name of the corresponding \<input\>+ , partFilename :: Maybe String -- ^ A file name, if this is an attached file+ , partContentType :: Maybe MimeType -- ^ Content type+ , partGetBody :: IO RequestBody -- ^ Action in m which returns the body+ -- of a message.+ }++instance Show Part where+ showsPrec d (Part n f c _) =+ showParen (d>=11) $ showString "Part "+ . showsPrec 11 n+ . showString " "+ . showsPrec 11 f+ . showString " "+ . showsPrec 11 c+ . showString " "+ . showString "<m (RequestBody m)>"++partBS :: Text -> BS.ByteString -> Part+partBS n b = Part n mempty mempty $ return $ RequestBodyBS b++partLBS :: Text -> BL.ByteString -> Part+partLBS n b = Part n mempty mempty $ return $ RequestBodyLBS b++-- | Make a 'Part' from a file, the entire file will reside in memory at once.+-- If you want constant memory usage use 'partFileSource'+partFile :: Text -> FilePath -> Part+partFile n f =+ partFileRequestBodyM n f $ do+ liftM RequestBodyBS $ liftIO $ BS.readFile f++-- | Stream 'Part' from a file.+partFileSource :: Text -> FilePath -> Part+partFileSource n f =+ partFileRequestBodyM n f $ do+ size <- liftIO $ withBinaryFile f ReadMode hFileSize+ return $ RequestBodyStream (fromInteger size) $ streamFile f++streamFile :: FilePath -> GivesPopper ()+streamFile fp np =+ withFile fp ReadMode $ np . go+ where+ go h = BS.hGetSome h defaultChunkSize++-- | 'partFileSourceChunked' will read a file and send it in chunks.+--+-- Note that not all servers support this. Only use 'partFileSourceChunked'+-- if you know the server you're sending to supports chunked request bodies.+partFileSourceChunked :: Text -> FilePath -> Part+partFileSourceChunked n f =+ partFileRequestBody n f $ do+ RequestBodyStreamChunked $ streamFile f++-- | Construct a 'Part' from form name, filepath and a 'RequestBody'+--+-- > partFileRequestBody "who_calls" "caller.json" $ RequestBodyBS "{\"caller\":\"Jason J Jason\"}"+--+-- > -- empty upload form+-- > partFileRequestBody "file" mempty mempty+partFileRequestBody :: Text -> FilePath -> RequestBody -> Part+partFileRequestBody n f rqb =+ partFileRequestBodyM n f $ return rqb++-- | Construct a 'Part' from action returning the 'RequestBody'+--+-- > partFileRequestBodyM "cat_photo" "haskell-the-cat.jpg" $ do+-- > size <- fromInteger <$> withBinaryFile "haskell-the-cat.jpg" ReadMode hFileSize+-- > return $ RequestBodySource size $ CB.sourceFile "haskell-the-cat.jpg" $= CL.map fromByteString+partFileRequestBodyM :: Text -> FilePath -> IO RequestBody -> Part+partFileRequestBodyM n f rqb =+ Part n (Just f) (Just $ defaultMimeLookup $ pack f) rqb++{-# INLINE cp #-}+cp :: BS.ByteString -> RequestBody+cp bs = RequestBodyBuilder (fromIntegral $ BS.length bs) $ copyByteString bs++renderPart :: BS.ByteString -> Part -> IO RequestBody+renderPart boundary (Part name mfilename mcontenttype get) = liftM render get+ where render renderBody =+ cp "--" <> cp boundary <> cp "\r\n"+ <> cp "Content-Disposition: form-data; name=\""+ <> RequestBodyBS (TE.encodeUtf8 name)+ <> (case mfilename of+ Just f -> cp "\"; filename=\""+ <> RequestBodyBS (TE.encodeUtf8 $ pack $ takeFileName f)+ _ -> mempty)+ <> cp "\""+ <> (case mcontenttype of+ Just ct -> cp "\r\n"+ <> cp "Content-Type: "+ <> cp ct+ _ -> mempty)+ <> cp "\r\n\r\n"+ <> renderBody <> cp "\r\n"++-- | Combine the 'Part's to form multipart/form-data body+renderParts :: BS.ByteString -> [Part] -> IO RequestBody+renderParts boundary parts = (fin . mconcat) `liftM` mapM (renderPart boundary) parts+ where fin = (<> cp "--" <> cp boundary <> cp "--\r\n")++-- | Generate a boundary simillar to those generated by WebKit-based browsers.+webkitBoundary :: IO BS.ByteString+webkitBoundary = getStdRandom webkitBoundaryPure++webkitBoundaryPure :: RandomGen g => g -> (BS.ByteString, g)+webkitBoundaryPure g = (`runState` g) $ do+ fmap (BS.append prefix . BS.pack . Prelude.concat) $ replicateM 4 $ do+ randomness <- state $ random+ return [unsafeAt alphaNumericEncodingMap $ randomness `shiftR` 24 .&. 0x3F+ ,unsafeAt alphaNumericEncodingMap $ randomness `shiftR` 16 .&. 0x3F+ ,unsafeAt alphaNumericEncodingMap $ randomness `shiftR` 8 .&. 0x3F+ ,unsafeAt alphaNumericEncodingMap $ randomness .&. 0x3F]+ where+ prefix = "----WebKitFormBoundary"+ alphaNumericEncodingMap :: UArray Int Word8+ alphaNumericEncodingMap = listArray (0, 63)+ [0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48,+ 0x49, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F, 0x50,+ 0x51, 0x52, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58,+ 0x59, 0x5A, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66,+ 0x67, 0x68, 0x69, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E,+ 0x6F, 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76,+ 0x77, 0x78, 0x79, 0x7A, 0x30, 0x31, 0x32, 0x33,+ 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x41, 0x42]++-- | Add form data to the 'Request'.+--+-- This sets a new 'requestBody', adds a content-type request header and changes the method to POST.+formDataBody :: MonadIO m => [Part] -> Request -> m Request+formDataBody a b = liftIO $ do+ boundary <- webkitBoundary+ formDataBodyWithBoundary boundary a b++-- | Add form data with supplied boundary+formDataBodyWithBoundary :: BS.ByteString -> [Part] -> Request -> IO Request+formDataBodyWithBoundary boundary parts req = do+ body <- renderParts boundary parts+ return $ req+ { method = methodPost+ , requestHeaders =+ (hContentType, "multipart/form-data; boundary=" <> boundary)+ : Prelude.filter (\(x, _) -> x /= hContentType) (requestHeaders req)+ , requestBody = body+ }
Network/HTTP/Client/Request.hs view
@@ -40,7 +40,6 @@ import Control.Monad.IO.Class (liftIO) import Control.Exception (Exception, toException, throw, throwIO)-import Control.Failure (Failure (failure)) import qualified Data.CaseInsensitive as CI import qualified Data.ByteString.Base64 as B64 @@ -50,34 +49,35 @@ import Network.HTTP.Client.Util (readDec, (<>)) import System.Timeout (timeout) import Data.Time.Clock+import Control.Monad.Catch (MonadThrow, throwM) -- | Convert a URL into a 'Request'. -- -- This defaults some of the values in 'Request', such as setting 'method' to -- GET and 'requestHeaders' to @[]@. ----- Since this function uses 'Failure', the return monad can be anything that is--- an instance of 'Failure', such as 'IO' or 'Maybe'.+-- Since this function uses 'MonadThrow', the return monad can be anything that is+-- an instance of 'MonadThrow', such as 'IO' or 'Maybe'. -- -- Since 0.1.0-parseUrl :: Failure HttpException m => String -> m Request+parseUrl :: MonadThrow m => String -> m Request parseUrl s = case parseURI (encode s) of Just uri -> setUri def uri- Nothing -> failure $ InvalidUrlException s "Invalid URL"+ Nothing -> throwM $ InvalidUrlException s "Invalid URL" where encode = escapeURIString isAllowedInURI -- | Add a 'URI' to the request. If it is absolute (includes a host name), add -- it as per 'setUri'; if it is relative, merge it with the existing request.-setUriRelative :: Failure HttpException m => Request -> URI -> m Request+setUriRelative :: MonadThrow m => Request -> URI -> m Request setUriRelative req uri = #if MIN_VERSION_network(2,4,0) setUri req $ uri `relativeTo` getUri req #else case uri `relativeTo` getUri req of Just uri' -> setUri req uri'- Nothing -> failure $ InvalidUrlException (show uri) "Invalid URL"+ Nothing -> throwM $ InvalidUrlException (show uri) "Invalid URL" #endif -- | Extract a 'URI' from the request.@@ -99,7 +99,7 @@ } -- | Validate a 'URI', then add it to the request.-setUri :: Failure HttpException m => Request -> URI -> m Request+setUri :: MonadThrow m => Request -> URI -> m Request setUri req uri = do sec <- parseScheme uri auth <- maybe (failUri "URL must be absolute") return $ uriAuthority uri@@ -118,8 +118,8 @@ , queryString = S8.pack $ uriQuery uri } where- failUri :: Failure HttpException m => String -> m a- failUri = failure . InvalidUrlException (show uri)+ failUri :: MonadThrow m => String -> m a+ failUri = throwM . InvalidUrlException (show uri) parseScheme URI{uriScheme = scheme} = case scheme of@@ -205,7 +205,7 @@ instance IsString Request where fromString s = case parseUrl s of- Left e -> throw (e :: HttpException)+ Left e -> throw e Right r -> r -- | Always decompress a compressed stream.
http-client.cabal view
@@ -1,5 +1,5 @@ name: http-client-version: 0.2.3.1+version: 0.3.0 synopsis: An HTTP client engine, intended as a base layer for more user-friendly packages. description: This codebase has been refactored from http-conduit. homepage: https://github.com/snoyberg/http-client@@ -14,6 +14,7 @@ library exposed-modules: Network.HTTP.Client+ Network.HTTP.Client.MultipartFormData Network.HTTP.Client.Internal other-modules: Network.HTTP.Client.Body Network.HTTP.Client.Connection@@ -38,10 +39,14 @@ , transformers , deepseq >= 1.3 && <1.4 , case-insensitive >= 1.0- , failure >= 0.2 && <0.3 , base64-bytestring >= 1.0 && <1.1 , publicsuffixlist , cookie+ , exceptions >= 0.4+ , array+ , random+ , filepath+ , mime-types default-language: Haskell2010 test-suite spec