From a2a726f3581933cea2d805b76aca0e93da778994 Mon Sep 17 00:00:00 2001 From: pho Date: Tue, 3 Nov 2009 16:05:43 +0900 Subject: [PATCH] Release 0.3.3 Ignore-this: d01a902c8221a1e31a12ba50faa08b46 * Network.HTTP.Lucu.Resource: - getQueryForm and inputForm now returns [FormData] instead of [(String, String)] to possibly include a name of uploaded file. darcs-hash:20091103070543-62b54-c5a9028cee38478ef6b6002907f236b130d7a431.gz --- Lucu.cabal | 11 +++-- NEWS | 6 +++ Network/HTTP/Lucu/MultipartForm.hs | 77 +++++++++++++++++++++++------- Network/HTTP/Lucu/Parser.hs | 71 ++++++++++++++------------- Network/HTTP/Lucu/Resource.hs | 21 +++++--- examples/Multipart.hs | 8 ++-- 6 files changed, 128 insertions(+), 66 deletions(-) diff --git a/Lucu.cabal b/Lucu.cabal index 325195c..110eda1 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -8,7 +8,7 @@ Description: messing around FastCGI. It is also intended to be run behind a reverse-proxy so it doesn't have some facilities like logging, client filtering or such like. -Version: 0.3.2 +Version: 0.3.3 License: PublicDomain License-File: COPYING Author: PHO @@ -80,7 +80,7 @@ Library Network.HTTP.Lucu.RequestReader Network.HTTP.Lucu.ResponseWriter Extensions: - BangPatterns, DeriveDataTypeable, UnboxedTuples + BangPatterns, DeriveDataTypeable, ScopedTypeVariables, UnboxedTuples ghc-options: -Wall -funbox-strict-fields @@ -92,7 +92,7 @@ Executable lucu-implant-file Buildable: False Main-Is: ImplantFile.hs Extensions: - BangPatterns, UnboxedTuples + BangPatterns, ScopedTypeVariables, UnboxedTuples ghc-options: -Wall -funbox-strict-fields @@ -101,3 +101,8 @@ Executable lucu-implant-file -- Main-Is: HelloWorld.hs -- Hs-Source-Dirs: ., examples -- ghc-options: -fglasgow-exts -Wall -funbox-strict-fields -O3 -prof -auto-all + +--Executable Multipart +-- Main-Is: Multipart.hs +-- Hs-Source-Dirs: ., examples +-- ghc-options: -XBangPatterns -fglasgow-exts -Wall -funbox-strict-fields -prof -auto-all diff --git a/NEWS b/NEWS index c5814dc..52c5082 100644 --- a/NEWS +++ b/NEWS @@ -1,3 +1,9 @@ +Changes from 0.3.2 to 0.3.3 +--------------------------- +* Network.HTTP.Lucu.Resource: + - getQueryForm and inputForm now returns [FormData] instead of + [(String, String)] to possibly include a name of uploaded file. + Changes from 0.3.1 to 0.3.2 --------------------------- * Network.HTTP.Lucu.Parser: diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index 8903d7f..4a34ba5 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -1,5 +1,6 @@ module Network.HTTP.Lucu.MultipartForm - ( multipartFormP + ( FormData(..) + , multipartFormP ) where @@ -17,6 +18,15 @@ import Network.HTTP.Lucu.Utils data Part = Part Headers String +-- |This data type represents a form entry name, form value and +-- possibly an uploaded file name. +data FormData + = FormData { + fdName :: String + , fdFileName :: Maybe String + , fdContent :: String + } + instance HasHeaders Part where getHeaders (Part hs _) = hs setHeaders (Part _ b) hs = Part hs b @@ -40,7 +50,7 @@ instance Show ContDispo where value -multipartFormP :: String -> Parser [(String, String)] +multipartFormP :: String -> Parser [FormData] multipartFormP boundary = do parts <- many (partP boundary) string "--" @@ -48,7 +58,7 @@ multipartFormP boundary string "--" crlf eof - return $ map partToPair parts + return $ map partToFormData parts partP :: String -> Parser Part @@ -72,8 +82,51 @@ bodyP boundary return body -partToPair :: Part -> (String, String) -partToPair part@(Part _ body) +partToFormData :: Part -> FormData +partToFormData part@(Part _ body) + = let name = partName part + fName = partFileName part + in + FormData { + fdName = name + , fdFileName = fName + , fdContent = body + } + + +partName :: Part -> String +partName = getName' . getContDispoFormData + where + getName' :: ContDispo -> String + getName' dispo@(ContDispo _ dParams) + = case find ((== "name") . map toLower . fst) dParams of + Just (_, name) -> name + Nothing + -> abortPurely BadRequest [] + (Just $ "form-data without name: " ++ show dispo) + + +partFileName :: Part -> Maybe String +partFileName = getFileName' . getContDispoFormData + where + getFileName' :: ContDispo -> Maybe String + getFileName' (ContDispo _ dParams) + = do (_, fileName) <- find ((== "filename") . map toLower . fst) dParams + return fileName + +getContDispoFormData :: Part -> ContDispo +getContDispoFormData part + = let dispo@(ContDispo dType _) = getContDispo part + in + if map toLower dType == "form-data" then + dispo + else + abortPurely BadRequest [] + (Just $ "Content-Disposition type is not form-data: " ++ dType) + + +getContDispo :: Part -> ContDispo +getContDispo part = case getHeader (C8.pack "Content-Disposition") part of Nothing -> abortPurely BadRequest [] @@ -81,22 +134,10 @@ partToPair part@(Part _ body) Just dispoStr -> case parse contDispoP (L8.fromChunks [dispoStr]) of (# Success dispo, _ #) - -> (getName dispo, body) + -> dispo (# _, _ #) -> abortPurely BadRequest [] (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr) - where - getName :: ContDispo -> String - getName dispo@(ContDispo dType dParams) - | map toLower dType == "form-data" - = case find ((== "name") . map toLower . fst) dParams of - Just (_, name) -> name - Nothing - -> abortPurely BadRequest [] - (Just $ "form-data without name: " ++ show dispo) - | otherwise - = abortPurely BadRequest [] - (Just $ "Content-Disposition type is not form-data: " ++ dType) contDispoP :: Parser ContDispo diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index 8c591de..6c66e7f 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -54,6 +54,9 @@ module Network.HTTP.Lucu.Parser import Control.Monad.State.Strict import qualified Data.ByteString.Lazy as Lazy (ByteString) import qualified Data.ByteString.Lazy.Char8 as B hiding (ByteString) +import qualified Data.Foldable as Fold +import qualified Data.Sequence as Seq +import Data.Sequence (Seq, (|>)) -- |@'Parser' a@ is obviously a parser which parses and returns @a@. newtype Parser a = Parser { @@ -142,22 +145,22 @@ allowEOF f = f `seq` satisfy :: (Char -> Bool) -> Parser Char -satisfy f = f `seq` - do c <- anyChar - if f $! c then - return c - else - failP +satisfy !f + = do c <- anyChar + if f c then + return c + else + failP char :: Char -> Parser Char -char c = c `seq` satisfy (== c) +char !c = satisfy (== c) string :: String -> Parser String -string str = str `seq` - do mapM_ char str - return str +string !str = str `seq` + do mapM_ char str + return str infixr 0 <|> @@ -190,9 +193,8 @@ oneOf = foldl (<|>) failP . map char notFollowedBy :: Parser a -> Parser () -notFollowedBy p - = p `seq` - Parser $! do saved <- get -- 状態を保存 +notFollowedBy !p + = Parser $! do saved <- get -- 状態を保存 result <- runParser p case result of Success _ -> do put saved -- 状態を復歸 @@ -221,25 +223,22 @@ hexDigit = do c <- anyChar failP -many :: Parser a -> Parser [a] -many !p = Parser $! many' p [] - --- This implementation is rather ugly but we need to make it --- tail-recursive to avoid stack overflow. -many' :: Parser a -> [a] -> State ParserState (ParserResult [a]) -many' !p !soFar - = do saved <- get - result <- runParser p - case result of - Success a -> many' p (a:soFar) - IllegalInput -> do put saved - return $! Success $ reverse soFar - ReachedEOF -> if pstIsEOFFatal saved then - do put saved - return ReachedEOF - else - do put saved - return $! Success $ reverse soFar +many :: forall a. Parser a -> Parser [a] +many !p = Parser $! + do state <- get + let (# result, state' #) = many' state Seq.empty + put state' + return result + where + many' :: ParserState -> Seq a -> (# ParserResult [a], ParserState #) + many' !st !soFar + = case runState (runParser p) st of + (Success a, st') -> many' st' (soFar |> a) + (IllegalInput, _) -> (# Success (Fold.toList soFar), st #) + (ReachedEOF , _) -> if pstIsEOFFatal st then + (# ReachedEOF, st #) + else + (# Success (Fold.toList soFar), st #) many1 :: Parser a -> Parser [a] @@ -249,16 +248,16 @@ many1 !p = do x <- p count :: Int -> Parser a -> Parser [a] -count !n !p = Parser $! count' n p [] +count !n !p = Parser $! count' n p Seq.empty -- This implementation is rather ugly but we need to make it -- tail-recursive to avoid stack overflow. -count' :: Int -> Parser a -> [a] -> State ParserState (ParserResult [a]) -count' 0 _ !soFar = return $! Success $ reverse soFar +count' :: Int -> Parser a -> Seq a -> State ParserState (ParserResult [a]) +count' 0 _ !soFar = return $! Success $! Fold.toList soFar count' !n !p !soFar = do saved <- get result <- runParser p case result of - Success a -> count' (n-1) p (a:soFar) + Success a -> count' (n-1) p (soFar |> a) IllegalInput -> do put saved return IllegalInput ReachedEOF -> do put saved diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 3a27e9c..a9d487c 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -61,7 +61,8 @@ module Network.HTTP.Lucu.Resource ( -- * Monad - Resource + Resource + , FormData(..) , runRes -- private -- * Actions @@ -302,9 +303,17 @@ getPathInfo = do rsrcPath <- getResourcePath -- | Assume the query part of request URI as -- application\/x-www-form-urlencoded, and parse it. This action -- doesn't parse the request body. See 'inputForm'. -getQueryForm :: Resource [(String, String)] +getQueryForm :: Resource [FormData] getQueryForm = do uri <- getRequestURI - return $! parseWWWFormURLEncoded $ snd $ splitAt 1 $ uriQuery uri + return $! map pairToFormData $ parseWWWFormURLEncoded $ snd $ splitAt 1 $ uriQuery uri + +pairToFormData :: (String, String) -> FormData +pairToFormData (name, value) + = FormData { + fdName = name + , fdFileName = Nothing + , fdContent = value + } -- |Get a value of given request header. Comparison of header name is -- case-insensitive. Note that this action is not intended to be used @@ -716,7 +725,7 @@ inputChunkLBS limit -- makes 'Resource' abort with status \"415 Unsupported Media -- Type\". If the request has no \"Content-Type\", it aborts with -- \"400 Bad Request\". -inputForm :: Int -> Resource [(String, String)] +inputForm :: Int -> Resource [FormData] inputForm limit = limit `seq` do cTypeM <- getContentType @@ -733,7 +742,7 @@ inputForm limit where readWWWFormURLEncoded = do src <- input limit - return $ parseWWWFormURLEncoded src + return $ map pairToFormData $ parseWWWFormURLEncoded src readMultipartFormData params = do case find ((== "boundary") . map toLower . fst) params of @@ -742,7 +751,7 @@ inputForm limit Just (_, boundary) -> do src <- inputLBS limit case parse (multipartFormP boundary) src of - (# Success pairs, _ #) -> return pairs + (# Success fdList, _ #) -> return fdList (# _, _ #) -> abort BadRequest [] (Just "Unparsable multipart/form-data") diff --git a/examples/Multipart.hs b/examples/Multipart.hs index 6c15cd3..1e2d50b 100644 --- a/examples/Multipart.hs +++ b/examples/Multipart.hs @@ -28,11 +28,13 @@ resMain , resHead = Nothing , resPost = Just $ do form <- inputForm defaultLimit - let text = fromMaybe "" $ fmap snd $ find ((== "text") . fst) form - file = fromMaybe "" $ fmap snd $ find ((== "file") . fst) form + let text = fromMaybe "" $ fmap fdContent $ find ((== "text") . fdName) form + file = fromMaybe "" $ fmap fdContent $ find ((== "file") . fdName) form + fileName = fdFileName =<< find ((== "file") . fdName) form setContentType $ read "text/plain" outputChunk ("You entered \"" ++ text ++ "\".\n") - output ("You uploaded a " ++ show (length file) ++ " bytes long file.\n") + outputChunk ("You uploaded a " ++ show (length file) ++ " bytes long file.\n") + output ("The file name is " ++ show fileName ++ ".\n") , resPut = Nothing , resDelete = Nothing } \ No newline at end of file -- 2.40.0