Lucu 0.3.2 → 0.3.3
raw patch · 6 files changed
+128/−66 lines, 6 files
Files
- Lucu.cabal +8/−3
- NEWS +6/−0
- Network/HTTP/Lucu/MultipartForm.hs +59/−18
- Network/HTTP/Lucu/Parser.hs +35/−36
- Network/HTTP/Lucu/Resource.hs +15/−6
- examples/Multipart.hs +5/−3
Lucu.cabal view
@@ -8,7 +8,7 @@ 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 <pho at cielonegro dot org>@@ -80,7 +80,7 @@ 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 @@ Buildable: False Main-Is: ImplantFile.hs Extensions:- BangPatterns, UnboxedTuples+ BangPatterns, ScopedTypeVariables, UnboxedTuples ghc-options: -Wall -funbox-strict-fields@@ -101,3 +101,8 @@ -- 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
NEWS view
@@ -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:
Network/HTTP/Lucu/MultipartForm.hs view
@@ -1,5 +1,6 @@ module Network.HTTP.Lucu.MultipartForm- ( multipartFormP+ ( FormData(..)+ , multipartFormP ) where @@ -17,6 +18,15 @@ 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 @@ value -multipartFormP :: String -> Parser [(String, String)]+multipartFormP :: String -> Parser [FormData] multipartFormP boundary = do parts <- many (partP boundary) string "--"@@ -48,7 +58,7 @@ string "--" crlf eof- return $ map partToPair parts+ return $ map partToFormData parts partP :: String -> Parser Part@@ -72,8 +82,51 @@ 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 @@ 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
Network/HTTP/Lucu/Parser.hs view
@@ -54,6 +54,9 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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
Network/HTTP/Lucu/Resource.hs view
@@ -61,7 +61,8 @@ module Network.HTTP.Lucu.Resource ( -- * Monad- Resource+ Resource+ , FormData(..) , runRes -- private -- * Actions@@ -302,10 +303,18 @@ -- | 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 -- so frequently: there should be actions like 'getContentType' for@@ -716,7 +725,7 @@ -- 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 @@ 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 @@ 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")
examples/Multipart.hs view
@@ -28,11 +28,13 @@ , 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 }