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>
Network.HTTP.Lucu.RequestReader
Network.HTTP.Lucu.ResponseWriter
Extensions:
- BangPatterns, DeriveDataTypeable, UnboxedTuples
+ BangPatterns, DeriveDataTypeable, ScopedTypeVariables, UnboxedTuples
ghc-options:
-Wall
-funbox-strict-fields
Buildable: False
Main-Is: ImplantFile.hs
Extensions:
- BangPatterns, UnboxedTuples
+ BangPatterns, ScopedTypeVariables, UnboxedTuples
ghc-options:
-Wall
-funbox-strict-fields
-- 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
+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:
module Network.HTTP.Lucu.MultipartForm
- ( multipartFormP
+ ( FormData(..)
+ , multipartFormP
)
where
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
value
-multipartFormP :: String -> Parser [(String, String)]
+multipartFormP :: String -> Parser [FormData]
multipartFormP boundary
= do parts <- many (partP boundary)
string "--"
string "--"
crlf
eof
- return $ map partToPair parts
+ return $ map partToFormData parts
partP :: String -> Parser Part
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 []
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
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 {
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 <|>
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 -- 状態を復歸
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]
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
module Network.HTTP.Lucu.Resource
(
-- * Monad
- Resource
+ Resource
+ , FormData(..)
, runRes -- private
-- * Actions
-- | 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
-- 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
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
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")
, 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