http-conduit 1.8.6.3 → 1.8.7

raw patch · 10 files changed

+415/−29 lines, 10 filesdep +arraydep +filepathdep +mime-typesdep ~http-typesbinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: array, filepath, mime-types, random

Dependency ranges changed: http-types

API changes (from Hackage documentation)

Files

• Network/HTTP/Conduit/Manager.hs +2/−2
• Network/HTTP/Conduit/MultipartFormData.hs +223/−0
• Network/HTTP/Conduit/Request.hs +3/−5
• Network/HTTP/Conduit/Response.hs +77/−7
• Network/HTTP/Conduit/Types.hs +53/−4
• Network/HTTP/Conduit/Util.hs +13/−0
• http-conduit.cabal +15/−3
• multipart-example.bin binary
• nyan.gif binary
• test/main.hs +29/−8

@@ -408,9 +408,9 @@ -- fails. failedConnectionException :: Request m -> HttpException failedConnectionException req =-    FailedConnectionException host port+    FailedConnectionException host' port'   where-    (_, host, port) = getConnDest req+    (_, host', port') = getConnDest req  getConnDest :: Request m -> (Bool, String, Int) getConnDest req =

@@ -0,0 +1,223 @@+{-# 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+-- >     Response{responseBody=cat} <- flip httpLbs m $ fromJust $ parseUrl "http://random-cat-photo.net/cat.jpg"+-- >     flip httpLbs m =<<+-- >         (formDataBody [partBS "title" "Bleaurgh"+-- >                       ,partBS "text" $ TE.encodeUtf8 "矢田矢田矢田矢田矢田"+-- >                       ,partFileSource "file1" "/home/friedrich/Photos/MyLittlePony.jpg"+-- >                       ,partFileRequestBody "file2" "cat.jpg" $ RequestBodyLBS cat]+-- >             $ fromJust $ parseUrl "http://example.org/~friedrich/blog/addPost.hs")+module Network.HTTP.Conduit.MultipartFormData+    (+    -- * Part type+     Part(..)+    -- * Constructing parts+    ,partBS+    ,partLBS+    ,partFile+    ,partFileSource+    ,partFileSourceChunked+    ,partFileRequestBody+    ,partFileRequestBodyM+    -- * Building form data+    ,formDataBody+    ,formDataBodyPure+    ,formDataBodyWithBoundary+    -- * Boundary+    ,webkitBoundary+    ,webkitBoundaryPure+    -- * Misc+    ,renderParts+    ,renderPart+    ) where++import Network.HTTP.Conduit.Request+import Network.HTTP.Conduit.Util+import Network.Mime+import Network.HTTP.Types (hContentType, methodPost)++import Blaze.ByteString.Builder+import qualified Data.Conduit.List as CL+import qualified Data.Conduit.Binary as CB+import Data.Conduit++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.Functor.Identity+import Data.Monoid (Monoid(..))+import Control.Monad++{-# INLINE _mmap #-}+-- | Kludge to get rid of 'Functor' constraint+infixl 4 `_mmap`+_mmap :: Monad m => (a -> b) -> m a -> m b+_mmap = \f m -> m >>= return . f++-- | A single part of a multipart message.+data Part m m' = 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 :: m (RequestBody m') -- ^ Action in m which returns the body+                                        -- of a message.+    }++instance Show (Part m m') 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 :: (Monad m, Monad m') => Text -> BS.ByteString -> Part m m'+partBS n b = Part n mempty mempty $ return $ RequestBodyBS b++partLBS :: (Monad m, Monad m') => Text -> BL.ByteString -> Part m m'+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 :: (MonadIO m, Monad m') => Text -> FilePath -> Part m m'+partFile n f =+    partFileRequestBodyM n f $ do+        _mmap RequestBodyBS $ liftIO $ BS.readFile f++-- | Stream 'Part' from a file.+partFileSource :: (MonadIO m, MonadResource m') => Text -> FilePath -> Part m m'+partFileSource n f =+    partFileRequestBodyM n f $ do+        size <- liftIO $ withBinaryFile f ReadMode hFileSize+        return $ RequestBodySource (fromInteger size) $+            CB.sourceFile f $= CL.map fromByteString++-- | '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 :: (Monad m, MonadResource m') => Text -> FilePath -> Part m m'+partFileSourceChunked n f =+    partFileRequestBody n f $ do+        RequestBodySourceChunked $ CB.sourceFile f $= CL.map fromByteString++-- | Construct a 'Part' from form name, filepath and a 'RequestBody'+--+-- > partFileRequestBody "who_calls" "caller.json" $ RequestBodyBS "{\"caller\":\"Jason J Jason\"}"+partFileRequestBody :: (Monad m, Monad m') => Text -> FilePath -> RequestBody m' -> Part m m'+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 :: Monad m' => Text -> FilePath -> m (RequestBody m') -> Part m m'+partFileRequestBodyM n f rqb =+    Part n (Just f) (Just $ defaultMimeLookup $ pack f) rqb++{-# INLINABLE cp #-}+cp :: BS.ByteString -> RequestBody m+cp bs = RequestBodyBuilder (fromIntegral $ BS.length bs) $ copyByteString bs++renderPart :: (Monad m, Monad m') => BS.ByteString -> Part m m' -> m (RequestBody m')+renderPart boundary (Part name mfilename mcontenttype get) = _mmap 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 :: (Monad m, Monad m') => BS.ByteString -> [Part m m'] -> m (RequestBody m')+renderParts boundary parts = fin . mconcat `_mmap` 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, Monad m') => [Part m m'] -> Request m' -> m (Request m')+formDataBody a b = do+    boundary <- liftIO webkitBoundary+    formDataBodyWithBoundary boundary a b++{-# INLINE formDataBodyPure #-}+-- | Add form data to request without doing any IO. Your form data should only+-- contain pure parts ('partBS', 'partLBS', 'partFileRequestBody'). You'll have+-- to supply your own boundary (for example one generated by 'webkitBoundary')+formDataBodyPure :: Monad m => BS.ByteString -> [Part Identity m] -> Request m -> Request m+formDataBodyPure = \boundary parts req ->+    runIdentity $ formDataBodyWithBoundary boundary parts req++-- | Add form data with supplied boundary+formDataBodyWithBoundary :: (Monad m, Monad m') => BS.ByteString -> [Part m m'] -> Request m' -> m (Request m')+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+        }

@@ -227,13 +227,11 @@ requestBuilder req =     CL.sourceList [builder] `mappend` bodySource   where-    sourceSingle = CL.sourceList . return-     (contentLength, bodySource) =         case requestBody req of-            RequestBodyLBS lbs -> (Just $ L.length lbs, sourceSingle $ fromLazyByteString lbs)-            RequestBodyBS bs -> (Just $ fromIntegral $ S.length bs, sourceSingle $ fromByteString bs)-            RequestBodyBuilder i b -> (Just $ i, sourceSingle b)+            RequestBodyLBS lbs -> (Just $ L.length lbs, C.yield $ fromLazyByteString lbs)+            RequestBodyBS bs -> (Just $ fromIntegral $ S.length bs, C.yield $ fromByteString bs)+            RequestBodyBuilder i b -> (Just $ i, C.yield b)             RequestBodySource i source -> (Just i, source)             RequestBodySourceChunked source -> (Nothing, source C.$= chunkIt) 

@@ -8,18 +8,20 @@     , lbsResponse     ) where +import Control.Applicative ((<$>), (<*>)) import Control.Arrow (first)-import Control.Monad (liftM)+import Control.Monad (liftM, unless, when)  import Control.Exception (throwIO) import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L  import qualified Data.CaseInsensitive as CI -import Data.Conduit hiding (Sink, Conduit)+import Data.Conduit hiding (Conduit) import Data.Conduit.Internal (ResumableSource (..), Pipe (..)) import qualified Data.Conduit.Zlib as CZ import qualified Data.Conduit.Binary as CB@@ -33,13 +35,11 @@ import Network.HTTP.Conduit.Manager import Network.HTTP.Conduit.Request import Network.HTTP.Conduit.Util-import Network.HTTP.Conduit.Parser import Network.HTTP.Conduit.Chunk  import Data.Void (Void, absurd)  import System.Timeout.Lifted (timeout)-import Control.Monad.Trans.Control (MonadBaseControl)  -- | If a request is a redirection (status code 3xx) this function will create -- a new request from the old request, the server headers returned with the@@ -99,7 +99,7 @@ checkHeaderLength len (PipeM msink) = PipeM (liftM (checkHeaderLength len) msink) checkHeaderLength _ s@Done{} = s checkHeaderLength _ (HaveOutput _ _ o) = absurd o-checkHeaderLength len (Leftover p i) = Leftover (checkHeaderLength len p) i+checkHeaderLength len (Leftover p i) = Leftover (checkHeaderLength (len + S.length i) p) i  getResponse :: (MonadResource m, MonadBaseControl IO m)             => ConnRelease m@@ -115,14 +115,14 @@                     case x of                         Nothing -> liftIO $ throwIO ResponseTimeout                         Just y -> return y-    (src2, ((vbs, sc, sm), hs)) <- timeout' $ src1 $$+ checkHeaderLength 4096 sinkHeaders+    (src2, ((vbs, sc, sm), hs)) <- timeout' $ src1 $$+ checkHeaderLength 4096 sinkHeaders'     let version = if vbs == "1.1" then W.http11 else W.http10     let s = W.Status sc sm     let hs' = map (first CI.mk) hs     let mcl = lookup "content-length" hs' >>= readDec . S8.unpack      -- should we put this connection back into the connection manager?-    let toPut = Just "close" /= lookup "connection" hs'+    let toPut = Just "close" /= lookup "connection" hs' && vbs /= "1.0"     let cleanup bodyConsumed = connRelease $ if toPut && bodyConsumed then Reuse else DontReuse      -- RFC 2616 section 4.4_1 defines responses that must not include a body@@ -150,3 +150,73 @@   where     fmapResume f (ResumableSource src m) = ResumableSource (f src) m     addCleanup' f (ResumableSource src m) = ResumableSource (addCleanup f src) (m >> f False)++-- | New version of @sinkHeaders@ that doesn't use attoparsec. Should create+-- more meaningful exceptions.+--+-- Since 1.8.7+sinkHeaders' :: (MonadThrow m, MonadResource m) => Sink S.ByteString m (Status, [Header])+sinkHeaders' = do+    status <- getStatusLine+    headers <- parseHeaders id+    return (status, headers)+  where+    getStatusLine = do+        status@(_, code, _) <- sinkLine >>= parseStatus+        if code == 100+            then newline ExpectedBlankAfter100Continue >> getStatusLine+            else return status++    newline exc = do+        line <- sinkLine+        unless (S.null line) $ monadThrow exc++    sinkLine = do+        bs <- fmap (killCR . S.concat) $ CB.takeWhile (/= charLF) =$ CL.consume+        CB.drop 1+        return bs+    charLF = 10+    charCR = 13+    charSpace = 32+    charColon = 58+    killCR bs+        | S.null bs = bs+        | S.last bs == charCR = S.init bs+        | otherwise = bs++    parseStatus :: MonadThrow m => S.ByteString -> m Status+    parseStatus bs = do+        let (ver, bs2) = S.breakByte charSpace bs+            (code, bs3) = S.breakByte charSpace $ S.dropWhile (== charSpace) bs2+            msg = S.dropWhile (== charSpace) bs3+        case (,) <$> parseVersion ver <*> parseCode code of+            Just (ver', code') -> return (ver', code', msg)+            _ -> monadThrow $ InvalidStatusLine bs++    stripPrefixBS x y+        | x `S.isPrefixOf` y = Just $ S.drop (S.length x) y+        | otherwise = Nothing+    parseVersion = stripPrefixBS "HTTP/"+    parseCode bs =+        case S8.readInt bs of+            Just (i, "") -> Just i+            _ -> Nothing++    parseHeaders front = do+        line <- sinkLine+        if S.null line+            then return $ front []+            else do+                header <- parseHeader line+                parseHeaders $ front . (header:)++    parseHeader :: MonadThrow m => S.ByteString -> m Header+    parseHeader bs = do+        let (key, bs2) = S.breakByte charColon bs+        when (S.null bs2) $ monadThrow $ InvalidHeader bs+        return (strip key, strip $ S.drop 1 bs2)++    strip = S.dropWhile (== charSpace) . fst . S.spanEnd (== charSpace)++type Header = (S.ByteString, S.ByteString)+type Status = (S.ByteString, Int, S.ByteString)

@@ -16,7 +16,7 @@ import Data.Int (Int64) import Data.Typeable (Typeable) -import qualified Blaze.ByteString.Builder as Blaze+import Blaze.ByteString.Builder  import qualified Data.Conduit as C @@ -31,7 +31,10 @@ import Data.Certificate.X509 (X509) import Network.TLS (PrivateKey) import Network.HTTP.Conduit.ConnInfo (ConnInfo)+import Network.HTTP.Conduit.Util +import Data.Monoid (Monoid(..))+ type ContentType = S.ByteString  -- | All information on how to connect to a host and what should be sent in the@@ -143,9 +146,9 @@ data RequestBody m     = RequestBodyLBS L.ByteString     | RequestBodyBS S.ByteString-    | RequestBodyBuilder Int64 Blaze.Builder-    | RequestBodySource Int64 (C.Source m Blaze.Builder)-    | RequestBodySourceChunked (C.Source m Blaze.Builder)+    | RequestBodyBuilder Int64 Builder+    | RequestBodySource Int64 (C.Source m Builder)+    | RequestBodySourceChunked (C.Source m Builder)  -- | Define a HTTP proxy, consisting of a hostname and port number. @@ -165,6 +168,9 @@                    | OverlongHeaders                    | ResponseTimeout                    | FailedConnectionException String Int -- ^ host/port+                   | ExpectedBlankAfter100Continue+                   | InvalidStatusLine S.ByteString+                   | InvalidHeader S.ByteString     deriving (Show, Typeable) instance Exception HttpException @@ -180,3 +186,46 @@ -- | Since 1.1.2. instance Functor Response where     fmap f (Response status v headers body) = Response status v headers (f body)++-- | Since 1.8.7+instance Show (RequestBody m) where+    showsPrec d (RequestBodyBS a) =+        showParen (d>=11) $ showString "RequestBodyBS " . showsPrec 11 a+    showsPrec d (RequestBodyLBS a) =+        showParen (d>=11) $ showString "RequestBodyLBS " . showsPrec 11 a+    showsPrec d (RequestBodyBuilder l _) =+        showParen (d>=11) $ showString "RequestBodyBuilder " . showsPrec 11 l .+            showString " " . showString "<Builder>"+    showsPrec d (RequestBodySource l _) =+        showParen (d>=11) $ showString "RequestBodySource " . showsPrec 11 l .+            showString " <Source m Builder>"+    showsPrec d (RequestBodySourceChunked _) =+        showParen (d>=11) $ showString "RequestBodySource <Source m Builder>"++-- | Since 1.8.7+instance Monad m => Monoid (RequestBody m) where+    mempty = RequestBodyLBS mempty++    mappend a b =+        case (simplify a, simplify b) of+            (SBuilder l1 b1, SBuilder l2 b2) -> RequestBodyBuilder (l1 + l2) (b1 <> b2)+            (SBuilder l1 b1, SSource l2 s2) -> RequestBodySource (l1 + l2) (C.yield b1 <> s2)+            (SSource l1 s1, SBuilder l2 b2) -> RequestBodySource (l1 + l2) (s1 <> C.yield b2)+            (SSource l1 s1, SSource l2 s2) -> RequestBodySource (l1 + l2) (s1 <> s2)+            (a', b') -> RequestBodySourceChunked (toChunked a' <> toChunked b')++data Simplified m = SBuilder Int64 Builder+                  | SSource Int64 (C.Source m Builder)+                  | SChunked (C.Source m Builder)++simplify :: Monad m => RequestBody m -> Simplified m+simplify (RequestBodyBS a) = SBuilder (fromIntegral $ S.length a) (fromByteString a)+simplify (RequestBodyLBS a) = SBuilder (fromIntegral $ L.length a) (fromLazyByteString a)+simplify (RequestBodyBuilder l a) = SBuilder l a+simplify (RequestBodySource l a) = SSource l a+simplify (RequestBodySourceChunked a) = SChunked a++toChunked :: Monad m => Simplified m -> C.Source m Builder+toChunked (SBuilder _ b) = C.yield b+toChunked (SSource _ s) = s+toChunked (SChunked s) = s

@@ -6,11 +6,18 @@     , (<>)     , readDec     , hasNoBody+    , fromStrict     ) where  import Data.Monoid (Monoid, mappend)  import qualified Data.ByteString.Char8 as S8+#if MIN_VERSION_bytestring(0,10,0)+import Data.ByteString.Lazy (fromStrict)+#else+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as S+#endif  import qualified Data.Text as T import qualified Data.Text.Read@@ -69,3 +76,9 @@ hasNoBody _ 204 = True hasNoBody _ 304 = True hasNoBody _ i = 100 <= i && i < 200++#if !MIN_VERSION_bytestring(0,10,0)+{-# INLINE fromStrict #-}+fromStrict :: S.ByteString -> L.ByteString+fromStrict x = L.fromChunks [x]+#endif

@@ -1,5 +1,5 @@ name:            http-conduit-version:         1.8.6.3+version:         1.8.7 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -14,7 +14,10 @@ cabal-version:   >= 1.8 build-type:      Simple homepage:        http://www.yesodweb.com/book/http-conduit-extra-source-files: test/main.hs, test/CookieTest.hs+extra-source-files: test/main.hs+                  , test/CookieTest.hs+                  , multipart-example.bin+                  , nyan.gif  flag network-bytestring   default: False@@ -32,7 +35,8 @@                  , attoparsec            >= 0.8.0.2                  , utf8-string           >= 0.3.4                  , blaze-builder         >= 0.2.1-                 , http-types            >= 0.6+                 , http-types            >= 0.7+                 , mime-types            >= 0.1                  , cprng-aes             >= 0.2                  , tls                   >= 1.0.0                  , tls-extra             >= 0.5.0@@ -53,6 +57,9 @@                  , regex-compat                  , mtl                  , deepseq+                 , array                 >= 0.4+                 , random+                 , filepath     if flag(network-bytestring)         build-depends: network               >= 2.2.1   && < 2.2.3                      , network-bytestring    >= 0.1.3   && < 0.1.4@@ -60,6 +67,7 @@         build-depends: network               >= 2.3     exposed-modules: Network.HTTP.Conduit                      Network.HTTP.Conduit.Internal+                     Network.HTTP.Conduit.MultipartFormData     other-modules:   Network.HTTP.Conduit.Parser                      Network.HTTP.Conduit.ConnInfo                      Network.HTTP.Conduit.Request@@ -118,6 +126,10 @@                  , void                  , deepseq                  , mtl+                 , array+                 , random+                 , filepath+                 , mime-types  source-repository head   type:     git

binary file changed (absent → 4267 bytes)

binary file changed (absent → 3422 bytes)

@@ -9,6 +9,7 @@ import qualified Network.Wai as Wai import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsPort, settingsBeforeMainLoop) import Network.HTTP.Conduit hiding (port)+import Network.HTTP.Conduit.MultipartFormData import Control.Concurrent (forkIO, killThread, putMVar, takeMVar, newEmptyMVar) import Network.HTTP.Types import Control.Exception.Lifted (try, SomeException, bracket, onException, IOException)@@ -21,7 +22,7 @@ import Data.Conduit.Network (runTCPServer, serverSettings, HostPreference (..), appSink, appSource, bindPort, serverAfterBind, ServerSettings) import qualified Data.Conduit.Network import System.IO.Unsafe (unsafePerformIO)-import Data.Conduit (($$), yield, Flush (Chunk))+import Data.Conduit (($$), yield, Flush (Chunk), runResourceT, await) import Control.Monad (void, forever) import Control.Monad.IO.Class (liftIO) import Data.ByteString.UTF8 (fromString)@@ -32,8 +33,9 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.ByteString.Lazy as L-import Blaze.ByteString.Builder (fromByteString)+import Blaze.ByteString.Builder (fromByteString, toByteString) import System.IO+import Data.Monoid (mconcat)  app :: Application app req =@@ -49,12 +51,6 @@             in return $ responseLBS status303                     [(hLocation, S.append "/infredir/" $ S8.pack $ show $ i+1)]                     (L8.pack $ show i)-        ["infredirrepeat", i'] ->-            let i = read $ T.unpack i' :: Int-            in return $ responseLBS status303-                    [(hLocation, S.append "/infredirrepeat/" $ S8.pack $ show $ i + 1)-                    ,(hContentLength, "2048")]-                    (L8.pack $ take 2048 $ unwords $ repeat $ show i)         _ -> return $ responseLBS status404 [] "not found"      where tastyCookie = (mk (fromString "Set-Cookie"), fromString "flavor=chocolate-chip;")@@ -198,6 +194,31 @@                 liftIO $ do                     Network.HTTP.Conduit.responseStatus res `shouldBe` status200                     responseBody res `shouldBe` "Hello World!"+    describe "multipart/form-data" $ do+        it "formats correctly" $ do+            let bd = "---------------------------190723902820679116301912680260"+            (RequestBodySource _ src) <- renderParts bd+                [partBS "email" ""+                ,partBS "parent_id" "70488"+                ,partBS "captcha" ""+                ,partBS "homeboard" "0chan.hk"+                ,partBS "text" $ TE.encodeUtf8 ">>72127\r\nМы работаем над этим."+                ,partFileSource "upload" "nyan.gif"+                ]+            mfd <- fmap (toByteString . mconcat) $ runResourceT $ src $$ CL.consume+            exam <- S.readFile "multipart-example.bin"+            mfd @?= exam++    describe "HTTP/1.0" $ do+        it "BaseHTTP" $ do+            let baseHTTP app' = do+                    appSource app' $$ await+                    yield "HTTP/1.0 200 OK\r\n\r\nThis is it!" $$ appSink app'+            withCApp baseHTTP $ \port -> withManager $ \manager -> do+                req <- parseUrl $ "http://127.0.0.1:" ++ show port+                res1 <- httpLbs req manager+                res2 <- httpLbs req manager+                liftIO $ res1 @?= res2  withCApp :: Data.Conduit.Network.Application IO -> (Int -> IO ()) -> IO () withCApp app' f = do