cgi 3001.1.4 → 3001.1.5
raw patch · 5 files changed
+85/−62 lines, 5 filessetup-changed
Files
- Network/CGI/Multipart.hs +48/−39
- Network/CGI/Protocol.hs +26/−20
- Network/CGI/RFC822Headers.hs +6/−0
- Setup.hs +3/−1
- cgi.cabal +2/−2
Network/CGI/Multipart.hs view
@@ -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 "<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) | (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.
Network/CGI/Protocol.hs view
@@ -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)
Network/CGI/RFC822Headers.hs view
@@ -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
Setup.hs view
@@ -1,4 +1,6 @@-#!/usr/bin/env runghc+module Main (main) where import Distribution.Simple++main :: IO () main = defaultMain
cgi.cabal view
@@ -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: