diff --git a/Network/CGI/Multipart.hs b/Network/CGI/Multipart.hs --- a/Network/CGI/Multipart.hs +++ b/Network/CGI/Multipart.hs @@ -20,6 +20,7 @@ -- * Multi-part messages MultiPart(..), BodyPart(..), Header , parseMultipartBody, hGetMultipartBody + , showMultipartBody -- * Headers , ContentType(..), ContentTransferEncoding(..) , ContentDisposition(..) @@ -33,6 +34,7 @@ import Control.Monad import Data.Int (Int64) +import Data.List (intersperse) import Data.Maybe import System.IO (Handle) @@ -53,33 +55,37 @@ -- | Read a multi-part message from a 'ByteString'. parseMultipartBody :: String -- ^ Boundary - -> ByteString -> Maybe MultiPart -parseMultipartBody b s = - do - ps <- splitParts (BS.pack b) s - liftM MultiPart $ mapM parseBodyPart ps + -> 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 h = - do - s <- BS.hGetContents h - case parseMultipartBody b s of - Nothing -> fail "Error parsing multi-part message" - Just m -> return m +hGetMultipartBody b = liftM (parseMultipartBody b) . BS.hGetContents parseBodyPart :: ByteString -> Maybe BodyPart parseBodyPart s = do - (hdr,bdy) <- splitAtEmptyLine s + 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) | (n,v) <- hs] ++ [BS.empty,c] + + -- -- * Splitting into multipart parts. -- @@ -87,22 +93,22 @@ -- | Split a multipart message into the multipart parts. splitParts :: ByteString -- ^ The boundary, without the initial dashes -> ByteString - -> Maybe [ByteString] -splitParts b s = dropPreamble b s >>= spl + -> [ByteString] +splitParts b = spl . dropPreamble b where spl x = case splitAtBoundary b x of - Nothing -> Nothing - Just (s1,d,s2) | isClose b d -> Just [s1] - | otherwise -> spl s2 >>= Just . (s1:) + 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. Returns 'Nothing' if there is no --- line starting with a boundary. +-- with the boundary. dropPreamble :: ByteString -- ^ The boundary, without the initial dashes -> ByteString - -> Maybe ByteString -dropPreamble b s | isBoundary b s = fmap snd (splitAtCRLF s) - | otherwise = dropLine s >>= dropPreamble b + -> 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 @@ -122,7 +128,7 @@ where s1 = BS.take (i+j) s s2 = BS.drop (i+j+l) s - (d,s3) = splitAtCRLF_ s2 + (d,s3) = splitAtCRLF s2 -- | Check whether a string starts with two dashes followed by -- the given boundary string. @@ -147,38 +153,41 @@ -- * 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 -> Maybe ByteString -dropLine s = fmap snd (splitAtCRLF s) +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. --- 'Nothing' is returned if there is no empty line. -splitAtEmptyLine :: ByteString -> Maybe (ByteString, ByteString) -splitAtEmptyLine s | startsWithCRLF s = Just (BS.empty, dropCRLF s) +-- 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 -> Nothing - Just (j,l) | startsWithCRLF s2 -> Just (s1, dropCRLF s2) + 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. - -> Maybe (ByteString,ByteString) - -- ^ Returns 'Nothing' if there is no CRLF. + -> (ByteString,ByteString) splitAtCRLF s = case findCRLF s of - Nothing -> Nothing - Just (i,l) -> Just (s1, BS.drop l s2) + Nothing -> (s,BS.empty) + Just (i,l) -> (s1, BS.drop l s2) where (s1,s2) = BS.splitAt i s - --- | Like 'splitAtCRLF', but if no CRLF is found, the first --- result is the argument string, and the second result is empty. -splitAtCRLF_ :: ByteString -> (ByteString,ByteString) -splitAtCRLF_ s = fromMaybe (s,BS.empty) (splitAtCRLF s) -- | Get the index and length of the first CRLF, if any. findCRLF :: ByteString -- ^ String to split. diff --git a/Network/CGI/Protocol.hs b/Network/CGI/Protocol.hs --- a/Network/CGI/Protocol.hs +++ b/Network/CGI/Protocol.hs @@ -63,7 +63,10 @@ -- | Input parameters. For better laziness in reading inputs, -- this is not a Map. cgiInputs :: [(String, Input)], - -- | Raw request body. + -- | Raw request body. To avoid memory leaks, + -- this is the empty string if the request body has been interpreted + -- as inputs in "application/x-www-form-urlencoded" or + -- "multipart/form-data" format. cgiRequestBody :: ByteString } deriving (Show) @@ -126,10 +129,11 @@ -> (CGIRequest -> m (Headers, CGIResult)) -- ^ CGI action. -> m ByteString -- ^ Response (headers and content). runCGIEnvFPS vars inp f - = do (hs,outp) <- f $ CGIRequest { + = do let (inputs,body) = decodeInput vars inp + (hs,outp) <- f $ CGIRequest { cgiVars = Map.fromList vars, - cgiInputs = decodeInput vars inp, - cgiRequestBody = inp + cgiInputs = inputs, + cgiRequestBody = body } return $ case outp of CGIOutput c -> formatResponse c hs' @@ -159,8 +163,11 @@ -- method and the content-type. decodeInput :: [(String,String)] -- ^ CGI environment variables. -> ByteString -- ^ Request body. - -> [(String,Input)] -- ^ Input variables and values. -decodeInput env inp = queryInput env ++ bodyInput env inp + -> ([(String,Input)],ByteString) + -- ^ A list of input variables and values, and the request body + -- if it was not interpreted. +decodeInput env inp = + let (inputs, body) = bodyInput env inp in (queryInput env ++ inputs, body) -- | Builds an 'Input' object for a simple value. simpleInput :: String -> Input @@ -237,30 +244,30 @@ -- -- | Gets input variables from the body, if any. -bodyInput :: [(String,String)] -- ^ CGI environment variables. - -> ByteString -- ^ Request body. - -> [(String,Input)] -- ^ Input variables and values. +bodyInput :: [(String,String)] + -> ByteString + -> ([(String,Input)], ByteString) bodyInput env inp = case lookup "REQUEST_METHOD" env of Just "POST" -> let ctype = lookup "CONTENT_TYPE" env >>= parseContentType in decodeBody ctype $ takeInput env inp - _ -> [] + _ -> ([], inp) -- | Decodes a POST body. -decodeBody :: Maybe ContentType -- ^ Content-type, if any - -> ByteString -- ^ Request body - -> [(String,Input)] -- ^ Input variables and values. +decodeBody :: Maybe ContentType + -> ByteString + -> ([(String,Input)], ByteString) decodeBody ctype inp = case ctype of Just (ContentType "application" "x-www-form-urlencoded" _) - -> formInput (BS.unpack inp) + -> (formInput (BS.unpack inp), BS.empty) Just (ContentType "multipart" "form-data" ps) - -> multipartDecode ps inp - Just _ -> [] -- unknown content-type, the user will have to + -> (multipartDecode ps inp, BS.empty) + Just _ -> ([], inp) -- unknown content-type, the user will have to -- deal with it by looking at the raw content -- No content-type given, assume x-www-form-urlencoded - Nothing -> formInput (BS.unpack inp) + Nothing -> (formInput (BS.unpack inp), BS.empty) -- | Takes the right number of bytes from the input. takeInput :: [(String,String)] -- ^ CGI environment variables. @@ -280,9 +287,8 @@ -> [(String,Input)] -- ^ Input variables and values. multipartDecode ps inp = case lookup "boundary" ps of - Just b -> case parseMultipartBody b inp of - Just (MultiPart bs) -> map bodyPartToInput bs - Nothing -> [] -- FIXME: report parse error + Just b -> let MultiPart bs = parseMultipartBody b inp + in map bodyPartToInput bs Nothing -> [] -- FIXME: report that there was no boundary bodyPartToInput :: BodyPart -> (String,Input) diff --git a/Network/CGI/RFC822Headers.hs b/Network/CGI/RFC822Headers.hs --- a/Network/CGI/RFC822Headers.hs +++ b/Network/CGI/RFC822Headers.hs @@ -37,6 +37,7 @@ ContentDisposition(..), getContentDisposition, parseContentDisposition, + showContentDisposition, -- * Utilities parseM) where @@ -191,6 +192,11 @@ getContentDisposition :: Monad m => [Header] -> m ContentDisposition getContentDisposition hs = lookupM "content-disposition" hs >>= parseContentDisposition + +showContentDisposition :: ContentDisposition -> String +showContentDisposition (ContentDisposition t hs) = + t ++ concat ["; " ++ n ++ "=" ++ quote v | (n,v) <- hs] + where quote x = "\"" ++ x ++ "\"" -- NOTE: silly, but de-facto standard -- -- * Utilities diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,4 +1,6 @@ -#!/usr/bin/env runghc +module Main (main) where import Distribution.Simple + +main :: IO () main = defaultMain diff --git a/cgi.cabal b/cgi.cabal --- a/cgi.cabal +++ b/cgi.cabal @@ -1,12 +1,12 @@ Name: cgi -Version: 3001.1.4 +Version: 3001.1.5 Copyright: Bjorn Bringert, Andy Gill, Ian Lynagh, Erik Meijer, Sven Panne, Jeremy Shaw Maintainer: bjorn@bringert.net Author: Bjorn Bringert License: BSD3 License-file: LICENSE -Build-depends: base >= 2.0, network>=2.0, parsec >= 2.0, mtl >= 1.0, xhtml >= 3000.0.0 +Build-depends: base >= 2.0, network>=2.0, parsec >= 2.0, mtl >= 1.0, xhtml >= 3000.0.0 Extensions: MultiParamTypeClasses Synopsis: A library for writing CGI programs Description: