multipart (empty) → 0.1
raw patch · 5 files changed
+538/−0 lines, 5 filesdep +MonadCatchIO-mtldep +MonadCatchIO-transformersdep +basesetup-changed
Dependencies added: MonadCatchIO-mtl, MonadCatchIO-transformers, base, bytestring, cgi, parsec
Files
- LICENSE +32/−0
- Network/Multipart.hs +219/−0
- Network/Multipart/Header.hs +251/−0
- Setup.hs +6/−0
- multipart.cabal +30/−0
+ LICENSE view
@@ -0,0 +1,32 @@+Copyright 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.
+ Network/Multipart.hs view
@@ -0,0 +1,219 @@+-- #hide++-----------------------------------------------------------------------------+-- |+-- Module : Network.CGI.Multipart+-- Copyright : (c) Peter Thiemann 2001,2002+-- (c) Bjorn Bringert 2005-2006+-- License : BSD-style+--+-- Maintainer : Anders Kaseorg <andersk@mit.edu>+-- 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+ , 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 "<input>" (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
+ Network/Multipart/Header.hs view
@@ -0,0 +1,251 @@+-- #hide++-----------------------------------------------------------------------------+-- |+-- Module : Network.CGI.Header+-- Copyright : (c) Peter Thiemann 2001,2002+-- (c) Bjorn Bringert 2005-2006+-- License : BSD-style+--+-- Maintainer : Anders Kaseorg <andersk@mit.edu>+-- 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 Network.CGI.Protocol+import Network.CGI++import Text.ParserCombinators.Parsec++--+-- * Headers+--++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)++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+++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
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ multipart.cabal view
@@ -0,0 +1,30 @@+name: multipart+version: 0.1+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+synopsis: A partial fork of the cgi package exposing the multipart module+build-type: Simple+cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/silkapp/multipart.git++library+ default-language: Haskell2010+ ghc-options: -Wall+ exposed-modules: Network.Multipart+ other-modules: Network.Multipart.Header+ build-depends:+ base >= 3 && < 5+ -- Reject versions depending on monads-tf+ , MonadCatchIO-mtl == 0.3.0.5+ , MonadCatchIO-transformers == 0.3.0.*+ , bytestring+ , cgi >= 3001.1.8 && < 3001.1.9+ , parsec >= 2.0