diff --git a/Network/HTTP/Client/MultipartFormData.hs b/Network/HTTP/Client/MultipartFormData.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Client/MultipartFormData.hs @@ -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 \ + , 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 "" + +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 + } diff --git a/Network/HTTP/Client/Request.hs b/Network/HTTP/Client/Request.hs --- a/Network/HTTP/Client/Request.hs +++ b/Network/HTTP/Client/Request.hs @@ -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. diff --git a/http-client.cabal b/http-client.cabal --- a/http-client.cabal +++ b/http-client.cabal @@ -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