multipart-0.1.3/0000755000000000000000000000000013335074271011727 5ustar0000000000000000multipart-0.1.3/Setup.hs0000644000000000000000000000012713335074271013363 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain multipart-0.1.3/LICENSE0000644000000000000000000000320313335074271012732 0ustar0000000000000000Copyright 2001-2010, The University Court of the University of Glasgow, Bjorn Bringert, Andy Gill, Anders Kaseorg, Ian Lynagh, Erik Meijer, Sven Panne, Jeremy Shaw All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. multipart-0.1.3/CHANGELOG.md0000644000000000000000000000021613335074271013537 0ustar0000000000000000# Changelog ### 0.1.3 * Improve performance of parsing multipart body. Thanks to Ali Abrar. ### 0.1.2 * Expose `Network.Multipart.Header` multipart-0.1.3/README.md0000644000000000000000000000035613335074271013212 0ustar0000000000000000# multipart [![Build Status](https://travis-ci.org/silkapp/multipart.svg?branch=master)](https://travis-ci.org/silkapp/multipart) A partial fork of the [cgi package](http://hackage.haskell.org/package/cgi) exposing the Multipart module. multipart-0.1.3/multipart.cabal0000644000000000000000000000174113335074271014737 0ustar0000000000000000name: multipart version: 0.1.3 synopsis: HTTP multipart split out of the cgi package description: HTTP multipart split out of the cgi package copyright: Bjorn Bringert, Andy Gill, Anders Kaseorg, Ian Lynagh, Erik Meijer, Sven Panne, Jeremy Shaw category: Network maintainer: code@silk.co author: Silk B.V. homepage: http://www.github.com/silkapp/multipart license: BSD3 license-file: LICENSE build-type: Simple cabal-version: >=1.10 extra-source-files: CHANGELOG.md LICENSE README.md source-repository head type: git location: https://github.com/silkapp/multipart.git library default-language: Haskell2010 ghc-options: -Wall exposed-modules: Network.Multipart Network.Multipart.Header build-depends: base >= 3 && < 5 , bytestring >= 0.10.8.0 && < 0.11 , parsec >= 2.0 , stringsearch multipart-0.1.3/Network/0000755000000000000000000000000013335074271013360 5ustar0000000000000000multipart-0.1.3/Network/Multipart.hs0000644000000000000000000001210113335074271015670 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- #hide ----------------------------------------------------------------------------- -- | -- Module : Network.CGI.Multipart -- Copyright : (c) Peter Thiemann 2001,2002 -- (c) Bjorn Bringert 2005-2006 -- License : BSD-style -- -- Maintainer : Anders Kaseorg -- Stability : experimental -- Portability : non-portable -- -- Parsing of the multipart format from RFC2046. -- Partly based on code from WASHMail. -- ----------------------------------------------------------------------------- module Network.Multipart ( -- * Multi-part messages MultiPart(..), BodyPart(..) , parseMultipartBody, hGetMultipartBody , showMultipartBody -- * Headers , Headers , HeaderName(..) , ContentType(..), ContentTransferEncoding(..) , ContentDisposition(..) , parseContentType , getContentType , getContentTransferEncoding , getContentDisposition ) where import Control.Monad import Data.List (intersperse) import Data.Maybe import System.IO (Handle) import Network.Multipart.Header import qualified Data.ByteString.Lazy.Char8 as BS import Data.ByteString.Lazy.Char8 (ByteString) import Data.ByteString.Lazy.Search (breakOn) -- -- * Multi-part stuff. -- data MultiPart = MultiPart [BodyPart] deriving (Show, Eq, Ord) data BodyPart = BodyPart Headers ByteString deriving (Show, Eq, Ord) -- | Read a multi-part message from a 'ByteString'. parseMultipartBody :: String -- ^ Boundary -> ByteString -> MultiPart parseMultipartBody b = MultiPart . mapMaybe parseBodyPart . splitParts (BS.pack b) -- | Read a multi-part message from a 'Handle'. -- Fails on parse errors. hGetMultipartBody :: String -- ^ Boundary -> Handle -> IO MultiPart hGetMultipartBody b = liftM (parseMultipartBody b) . BS.hGetContents parseBodyPart :: ByteString -> Maybe BodyPart parseBodyPart s = do let (hdr,bdy) = splitAtEmptyLine s hs <- parseM pHeaders "" (BS.unpack hdr) return $ BodyPart hs bdy showMultipartBody :: String -> MultiPart -> ByteString showMultipartBody b (MultiPart bs) = unlinesCRLF $ foldr (\x xs -> d:showBodyPart x:xs) [c,BS.empty] bs where d = BS.pack ("--" ++ b) c = BS.pack ("--" ++ b ++ "--") showBodyPart :: BodyPart -> ByteString showBodyPart (BodyPart hs c) = unlinesCRLF $ [BS.pack (n++": "++v) | (HeaderName n,v) <- hs] ++ [BS.empty,c] -- -- * Splitting into multipart parts. -- -- | Split a multipart message into the multipart parts. splitParts :: ByteString -- ^ The boundary, without the initial dashes -> ByteString -> [ByteString] splitParts b = spl . dropPreamble b where spl x = case splitAtBoundary b x of Nothing -> [] Just (s1,d,s2) | isClose b d -> [s1] | otherwise -> s1:spl s2 -- | Drop everything up to and including the first line starting -- with the boundary. dropPreamble :: ByteString -- ^ The boundary, without the initial dashes -> ByteString -> ByteString dropPreamble b s = case splitAtBoundary b s of Nothing -> BS.empty Just (_,_,v) -> v -- | Split a string at the first boundary line. splitAtBoundary :: ByteString -- ^ The boundary, without the initial dashes -> ByteString -- ^ String to split. -> Maybe (ByteString,ByteString,ByteString) -- ^ The part before the boundary, the boundary line, -- and the part after the boundary line. The CRLF -- before and the CRLF (if any) after the boundary line -- are not included in any of the strings returned. -- Returns 'Nothing' if there is no boundary. splitAtBoundary b s = let bcrlf = BS.append "\r\n--" b (before, t) = breakOn (BS.toStrict bcrlf) s in case BS.stripPrefix bcrlf t of Nothing -> Nothing Just t' -> let after = case BS.stripPrefix "\r\n" t' of Nothing -> t' Just t'' -> t'' in Just (before, bcrlf, after) -- | Check whether a string for which 'isBoundary' returns true -- has two dashes after the boudary string. isClose :: ByteString -- ^ The boundary, without the initial dashes -> ByteString -> Bool isClose b s = BS.isPrefixOf (BS.append "--" (BS.append b "--")) s -- -- * RFC 2046 CRLF -- crlf :: ByteString crlf = BS.pack "\r\n" unlinesCRLF :: [ByteString] -> ByteString unlinesCRLF = BS.concat . intersperse crlf -- | Split a string at the first empty line. The CRLF (if any) before the -- empty line is included in the first result. The CRLF after the -- empty line is not included in the result. -- If there is no empty line, the entire input is returned -- as the first result. splitAtEmptyLine :: ByteString -> (ByteString, ByteString) splitAtEmptyLine s = let blank = "\r\n\r\n" (before, after) = breakOn (BS.toStrict blank) s in case BS.stripPrefix blank after of Nothing -> (before, after) Just after' -> (BS.append before "\r\n", after') multipart-0.1.3/Network/Multipart/0000755000000000000000000000000013335074271015341 5ustar0000000000000000multipart-0.1.3/Network/Multipart/Header.hs0000644000000000000000000002410413335074271017066 0ustar0000000000000000-- #hide ----------------------------------------------------------------------------- -- | -- Module : Network.CGI.Header -- Copyright : (c) Peter Thiemann 2001,2002 -- (c) Bjorn Bringert 2005-2006 -- License : BSD-style -- -- Maintainer : Anders Kaseorg -- Stability : experimental -- Portability : non-portable -- -- Parsing of HTTP headers (name, value pairs) -- Partly based on code from WASHMail. -- ----------------------------------------------------------------------------- module Network.Multipart.Header ( -- * Headers Headers, HeaderName(..), HeaderValue(..), pHeaders, -- * Content-type ContentType(..), getContentType, parseContentType, showContentType, -- * Content-transfer-encoding ContentTransferEncoding(..), getContentTransferEncoding, -- * Content-disposition ContentDisposition(..), getContentDisposition, -- * Utilities parseM, caseInsensitiveEq, caseInsensitiveCompare, lexeme, ws1, p_token ) where import Control.Monad import Data.Char import Data.List import qualified Data.Monoid as M import Text.ParserCombinators.Parsec -- -- * Headers -- -- | HTTP headers. type Headers = [(HeaderName, String)] -- | A string with case insensitive equality and comparisons. newtype HeaderName = HeaderName String deriving (Show) instance Eq HeaderName where HeaderName x == HeaderName y = map toLower x == map toLower y instance Ord HeaderName where HeaderName x `compare` HeaderName y = map toLower x `compare` map toLower y class HeaderValue a where parseHeaderValue :: Parser a prettyHeaderValue :: a -> String pHeaders :: Parser Headers pHeaders = many pHeader pHeader :: Parser (HeaderName, String) pHeader = do name <- many1 headerNameChar _ <- char ':' _ <- many ws1 line <- lineString _ <- crLf extraLines <- many extraFieldLine return (HeaderName name, concat (line:extraLines)) extraFieldLine :: Parser String extraFieldLine = do sp <- ws1 line <- lineString _ <- crLf return (sp:line) getHeaderValue :: (Monad m, HeaderValue a) => String -> Headers -> m a getHeaderValue h hs = lookupM (HeaderName h) hs >>= parseM parseHeaderValue h -- -- * Parameters (for Content-type etc.) -- showParameters :: [(String,String)] -> String showParameters = concatMap f where f (n,v) = "; " ++ n ++ "=\"" ++ concatMap esc v ++ "\"" esc '\\' = "\\\\" esc '"' = "\\\"" esc c | c `elem` ['\\','"'] = '\\':[c] | otherwise = [c] p_parameter :: Parser (String,String) p_parameter = try $ do _ <- lexeme $ char ';' p_name <- lexeme $ p_token -- Don't allow parameters named q. This is needed for parsing Accept-X -- headers. From RFC 2616 14.1: -- Note: Use of the "q" parameter name to separate media type -- parameters from Accept extension parameters is due to historical -- practice. Although this prevents any media type parameter named -- "q" from being used with a media range, such an event is believed -- to be unlikely given the lack of any "q" parameters in the IANA -- media type registry and the rare usage of any media type -- parameters in Accept. Future media types are discouraged from -- registering any parameter named "q". when (p_name == "q") pzero _ <- lexeme $ char '=' -- Workaround for seemingly standardized web browser bug -- where nothing is escaped in the filename parameter -- of the content-disposition header in multipart/form-data let litStr = if p_name == "filename" then buggyLiteralString else literalString p_value <- litStr <|> p_token return (map toLower p_name, p_value) -- -- * Content type -- -- | A MIME media type value. -- The 'Show' instance is derived automatically. -- Use 'showContentType' to obtain the standard -- string representation. -- See for more -- information about MIME media types. data ContentType = ContentType { -- | The top-level media type, the general type -- of the data. Common examples are -- \"text\", \"image\", \"audio\", \"video\", -- \"multipart\", and \"application\". ctType :: String, -- | The media subtype, the specific data format. -- Examples include \"plain\", \"html\", -- \"jpeg\", \"form-data\", etc. ctSubtype :: String, -- | Media type parameters. On common example is -- the charset parameter for the \"text\" -- top-level type, e.g. @(\"charset\",\"ISO-8859-1\")@. ctParameters :: [(String, String)] } deriving (Show, Read) instance Eq ContentType where x == y = ctType x `caseInsensitiveEq` ctType y && ctSubtype x `caseInsensitiveEq` ctSubtype y && ctParameters x == ctParameters y instance Ord ContentType where x `compare` y = M.mconcat [ctType x `caseInsensitiveCompare` ctType y, ctSubtype x `caseInsensitiveCompare` ctSubtype y, ctParameters x `compare` ctParameters y] instance HeaderValue ContentType where parseHeaderValue = do _ <- many ws1 c_type <- p_token _ <- char '/' c_subtype <- lexeme $ p_token c_parameters <- many p_parameter return $ ContentType (map toLower c_type) (map toLower c_subtype) c_parameters prettyHeaderValue (ContentType x y ps) = x ++ "/" ++ y ++ showParameters ps -- | Parse the standard representation of a content-type. -- If the input cannot be parsed, this function calls -- 'fail' with a (hopefully) informative error message. parseContentType :: Monad m => String -> m ContentType parseContentType = parseM parseHeaderValue "Content-type" showContentType :: ContentType -> String showContentType = prettyHeaderValue getContentType :: Monad m => Headers -> m ContentType getContentType = getHeaderValue "content-type" -- -- * Content transfer encoding -- data ContentTransferEncoding = ContentTransferEncoding String deriving (Show, Read, Eq, Ord) instance HeaderValue ContentTransferEncoding where parseHeaderValue = do _ <- many ws1 c_cte <- p_token return $ ContentTransferEncoding (map toLower c_cte) prettyHeaderValue (ContentTransferEncoding s) = s getContentTransferEncoding :: Monad m => Headers -> m ContentTransferEncoding getContentTransferEncoding = getHeaderValue "content-transfer-encoding" -- -- * Content disposition -- data ContentDisposition = ContentDisposition String [(String, String)] deriving (Show, Read, Eq, Ord) instance HeaderValue ContentDisposition where parseHeaderValue = do _ <- many ws1 c_cd <- p_token c_parameters <- many p_parameter return $ ContentDisposition (map toLower c_cd) c_parameters prettyHeaderValue (ContentDisposition t hs) = t ++ concat ["; " ++ n ++ "=" ++ quote v | (n,v) <- hs] where quote x = "\"" ++ x ++ "\"" -- NOTE: silly, but de-facto standard getContentDisposition :: Monad m => Headers -> m ContentDisposition getContentDisposition = getHeaderValue "content-disposition" -- -- * Utilities -- parseM :: Monad m => Parser a -> SourceName -> String -> m a parseM p n inp = case parse p n inp of Left e -> fail (show e) Right x -> return x lookupM :: (Monad m, Eq a, Show a) => a -> [(a,b)] -> m b lookupM n = maybe (fail ("No such field: " ++ show n)) return . lookup n caseInsensitiveEq :: String -> String -> Bool caseInsensitiveEq x y = map toLower x == map toLower y caseInsensitiveCompare :: String -> String -> Ordering caseInsensitiveCompare x y = map toLower x `compare` map toLower y -- -- * Parsing utilities -- -- | RFC 822 LWSP-char ws1 :: Parser Char ws1 = oneOf " \t" lexeme :: Parser a -> Parser a lexeme p = do x <- p; _ <- many ws1; return x -- | RFC 822 CRLF (but more permissive) crLf :: Parser String crLf = try (string "\n\r" <|> string "\r\n") <|> string "\n" <|> string "\r" -- | One line lineString :: Parser String lineString = many (noneOf "\n\r") literalString :: Parser String literalString = do _ <- char '\"' str <- many (noneOf "\"\\" <|> quoted_pair) _ <- char '\"' return str -- No web browsers seem to implement RFC 2046 correctly, -- since they do not escape double quotes and backslashes -- in the filename parameter in multipart/form-data. -- -- Note that this eats everything until the last double quote on the line. buggyLiteralString :: Parser String buggyLiteralString = do _ <- char '\"' str <- manyTill anyChar (try lastQuote) return str where lastQuote = do _ <- char '\"' notFollowedBy (try (many (noneOf "\"") >> char '\"')) headerNameChar :: Parser Char headerNameChar = noneOf "\n\r:" tspecials, tokenchar :: [Char] tspecials = "()<>@,;:\\\"/[]?=" tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ tspecials p_token :: Parser String p_token = many1 (oneOf tokenchar) text_chars :: [Char] text_chars = map chr ([1..9] ++ [11,12] ++ [14..127]) p_text :: Parser Char p_text = oneOf text_chars quoted_pair :: Parser Char quoted_pair = do _ <- char '\\' p_text