multipart-0.1.2/0000755000000000000000000000000012402277173011726 5ustar0000000000000000multipart-0.1.2/CHANGELOG.md0000644000000000000000000000007412402277173013540 0ustar0000000000000000# Changelog ### 0.1.2 * Expose `Network.Multipart.Header` multipart-0.1.2/LICENSE0000644000000000000000000000320312402277173012731 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.2/multipart.cabal0000644000000000000000000000167012402277173014737 0ustar0000000000000000name: multipart version: 0.1.2 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 , parsec >= 2.0 multipart-0.1.2/README.md0000644000000000000000000000035612402277173013211 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.2/Setup.hs0000644000000000000000000000012712402277173013362 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain multipart-0.1.2/Network/0000755000000000000000000000000012402277173013357 5ustar0000000000000000multipart-0.1.2/Network/Multipart.hs0000644000000000000000000001657112402277173015706 0ustar0000000000000000-- #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.Int (Int64) 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) -- -- * 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 | BS.null s = BS.empty | isBoundary b s = dropLine s | otherwise = dropPreamble b (dropLine s) -- | 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 = spl 0 where spl i = case findCRLF (BS.drop i s) of Nothing -> Nothing Just (j,l) | isBoundary b s2 -> Just (s1,d,s3) | otherwise -> spl (i+j+l) where s1 = BS.take (i+j) s s2 = BS.drop (i+j+l) s (d,s3) = splitAtCRLF s2 -- | Check whether a string starts with two dashes followed by -- the given boundary string. isBoundary :: ByteString -- ^ The boundary, without the initial dashes -> ByteString -> Bool isBoundary b s = startsWithDashes s && b `BS.isPrefixOf` BS.drop 2 s -- | 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 = startsWithDashes (BS.drop (2+BS.length b) s) -- | Checks whether a string starts with two dashes. startsWithDashes :: ByteString -> Bool startsWithDashes s = BS.pack "--" `BS.isPrefixOf` s -- -- * RFC 2046 CRLF -- crlf :: ByteString crlf = BS.pack "\r\n" unlinesCRLF :: [ByteString] -> ByteString unlinesCRLF = BS.concat . intersperse crlf -- | Drop everything up to and including the first CRLF. dropLine :: ByteString -> ByteString dropLine s = snd (splitAtCRLF s) -- | 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 | startsWithCRLF s = (BS.empty, dropCRLF s) | otherwise = spl 0 where spl i = case findCRLF (BS.drop i s) of Nothing -> (s, BS.empty) Just (j,l) | startsWithCRLF s2 -> (s1, dropCRLF s2) | otherwise -> spl (i+j+l) where (s1,s2) = BS.splitAt (i+j+l) s -- | Split a string at the first CRLF. The CRLF is not included -- in any of the returned strings. -- If there is no CRLF, the entire input is returned -- as the first string. splitAtCRLF :: ByteString -- ^ String to split. -> (ByteString,ByteString) splitAtCRLF s = case findCRLF s of Nothing -> (s,BS.empty) Just (i,l) -> (s1, BS.drop l s2) where (s1,s2) = BS.splitAt i s -- | Get the index and length of the first CRLF, if any. findCRLF :: ByteString -- ^ String to split. -> Maybe (Int64,Int64) findCRLF s = case findCRorLF s of Nothing -> Nothing Just j | BS.null (BS.drop (j+1) s) -> Just (j,1) Just j -> case (BS.index s j, BS.index s (j+1)) of ('\n','\r') -> Just (j,2) ('\r','\n') -> Just (j,2) _ -> Just (j,1) findCRorLF :: ByteString -> Maybe Int64 findCRorLF s = BS.findIndex (\c -> c == '\n' || c == '\r') s startsWithCRLF :: ByteString -> Bool startsWithCRLF s = not (BS.null s) && (c == '\n' || c == '\r') where c = BS.index s 0 -- | Drop an initial CRLF, if any. If the string is empty, -- nothing is done. If the string does not start with CRLF, -- the first character is dropped. dropCRLF :: ByteString -> ByteString dropCRLF s | BS.null s = BS.empty | BS.null (BS.drop 1 s) = BS.empty | c0 == '\n' && c1 == '\r' = BS.drop 2 s | c0 == '\r' && c1 == '\n' = BS.drop 2 s | otherwise = BS.drop 1 s where c0 = BS.index s 0 c1 = BS.index s 1 multipart-0.1.2/Network/Multipart/0000755000000000000000000000000012402277173015340 5ustar0000000000000000multipart-0.1.2/Network/Multipart/Header.hs0000644000000000000000000002375612402277173017101 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 Data.Monoid 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 = 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