From e53a2f3202f763e844de725712f1bf26b82cd41f Mon Sep 17 00:00:00 2001 From: pho Date: Sat, 6 Oct 2007 17:56:23 +0900 Subject: [PATCH] multipart/form-data and more darcs-hash:20071006085623-62b54-00a74090ea159c8767ca9a1f68303a83eabefef8.gz --- .boring | 1 + Lucu.cabal | 1 + Network/HTTP/Lucu/Abortion.hs | 6 ++ Network/HTTP/Lucu/Headers.hs | 29 ++++++-- Network/HTTP/Lucu/MultipartForm.hs | 114 +++++++++++++++++++++++++++++ Network/HTTP/Lucu/Parser.hs | 15 +++- Network/HTTP/Lucu/Resource.hs | 32 ++++---- examples/Makefile | 3 +- examples/Multipart.hs | 35 +++++++++ 9 files changed, 213 insertions(+), 23 deletions(-) create mode 100644 Network/HTTP/Lucu/MultipartForm.hs create mode 100644 examples/Multipart.hs diff --git a/.boring b/.boring index 8843524..763a6e6 100644 --- a/.boring +++ b/.boring @@ -58,4 +58,5 @@ ^examples/Implanted$ ^examples/ImplantedSmall$ ^examples/MiseRafturai\.hs$ +^examples/Multipart$ ^examples/SmallFile\.hs$ diff --git a/Lucu.cabal b/Lucu.cabal index 5006ea4..1142ea6 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -44,6 +44,7 @@ Other-Modules: Network.HTTP.Lucu.Format Network.HTTP.Lucu.Headers Network.HTTP.Lucu.Interaction + Network.HTTP.Lucu.MultipartForm Network.HTTP.Lucu.Postprocess Network.HTTP.Lucu.Preprocess Network.HTTP.Lucu.RequestReader diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index 0a5ed07..091b1bb 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -5,6 +5,7 @@ module Network.HTTP.Lucu.Abortion ( Abortion(..) , abort + , abortPurely , abortSTM , abortA , abortPage @@ -69,6 +70,11 @@ abort status headers msg in liftIO $ throwIO exc +-- |This is similar to 'abort' but compute it with +-- 'System.IO.Unsafe.unsafePerformIO'. +abortPurely :: StatusCode -> [ (ByteString, ByteString) ] -> Maybe String -> a +abortPurely = ((unsafePerformIO .) .) . abort + -- |Computation of @'abortSTM' status headers msg@ just computes -- 'abort' in a 'Control.Monad.STM.STM' monad. abortSTM :: StatusCode -> [ (ByteString, ByteString) ] -> Maybe String -> STM a diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index b26dddd..28723bc 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -70,8 +70,8 @@ noCaseCmp' :: Ptr Word8 -> Int -> Ptr Word8 -> Int -> IO Ordering noCaseCmp' p1 l1 p2 l2 | p1 `seq` l1 `seq` p2 `seq` l2 `seq` False = undefined | l1 == 0 && l2 == 0 = return EQ - | l1 == 0 && l1 /= 0 = return LT - | l1 /= 0 && l2 == 0 = return GT + | l1 == 0 = return LT + | l2 == 0 = return GT | otherwise = do c1 <- peek p1 c2 <- peek p2 @@ -135,7 +135,24 @@ emptyHeaders = M.empty toHeaders :: [(ByteString, ByteString)] -> Headers -toHeaders xs = M.fromList [(toNCBS a, b) | (a, b) <- xs] +toHeaders xs = mkHeaders xs M.empty + + +mkHeaders :: [(ByteString, ByteString)] -> Headers -> Headers +mkHeaders [] m = m +mkHeaders ((key, val):xs) m = mkHeaders xs $ + case M.lookup (toNCBS key) m of + Nothing -> M.insert (toNCBS key) val m + Just old -> M.insert (toNCBS key) (merge old val) m + where + merge :: ByteString -> ByteString -> ByteString + -- カンマ區切りである事を假定する。RFC ではカンマ區切りに出來ない + -- ヘッダは複數個あってはならない事になってゐる。 + merge a b + | C8.null a && C8.null b = C8.empty + | C8.null a = b + | C8.null b = a + | otherwise = C8.concat [a, C8.pack ", ", b] fromHeaders :: Headers -> [(ByteString, ByteString)] @@ -156,9 +173,9 @@ fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs] headersP :: Parser Headers headersP = do xs <- many header crlf - return (M.fromList xs) + return $! toHeaders xs where - header :: Parser (NCBS, ByteString) + header :: Parser (ByteString, ByteString) header = do name <- token char ':' -- FIXME: これは多少インチキだが、RFC 2616 のこの部分 @@ -171,7 +188,7 @@ headersP = do xs <- many header crlf let value = foldr (++) "" contents norm = normalize value - return (toNCBS $ C8.pack name, C8.pack norm) + return (C8.pack name, C8.pack norm) normalize :: String -> String normalize = trimBody . trim isWhiteSpace diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs new file mode 100644 index 0000000..21fca67 --- /dev/null +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -0,0 +1,114 @@ +module Network.HTTP.Lucu.MultipartForm + ( multipartFormP + ) + where + +import Data.ByteString.Base (LazyByteString(..)) +import qualified Data.ByteString.Char8 as C8 +import Data.Char +import Data.List +import Network.HTTP.Lucu.Abortion +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.Parser +import Network.HTTP.Lucu.Parser.Http +import Network.HTTP.Lucu.Response +import Network.HTTP.Lucu.Utils + + +data Part = Part Headers String + +instance HasHeaders Part where + getHeaders (Part hs _) = hs + setHeaders (Part _ b) hs = Part hs b + + +data ContDispo = ContDispo String [(String, String)] + +instance Show ContDispo where + show (ContDispo dType dParams) + = dType ++ + if null dParams then + "" + else + "; " ++ joinWith "; " (map showPair dParams) + where + showPair :: (String, String) -> String + showPair (name, value) + = name ++ "=" ++ if any (not . isToken) value then + quoteStr value + else + value + + +multipartFormP :: String -> Parser [(String, String)] +multipartFormP boundary + = do parts <- many (partP boundary) + string "--" + string boundary + string "--" + crlf + eof + return $ map partToPair parts + + +partP :: String -> Parser Part +partP boundary + = do string "--" + string boundary + crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。 + hs <- headersP + body <- bodyP boundary + return $ Part hs body + + +bodyP :: String -> Parser String +bodyP boundary + = do body <- many $ + do notFollowedBy $ do crlf + string "--" + string boundary + anyChar + crlf + return body + + +partToPair :: Part -> (String, String) +partToPair part@(Part _ body) + = case getHeader (C8.pack "Content-Disposition") part of + Nothing + -> abortPurely BadRequest [] + (Just "There is a part without Content-Disposition in the multipart/form-data.") + Just dispo + -> case parse contDispoP (LPS [dispo]) of + (# Success dispo, _ #) + -> (getName dispo, body) + (# _, _ #) + -> abortPurely BadRequest [] + (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispo) + 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 +contDispoP = do dispoType <- token + params <- allowEOF $ many paramP + return $ ContDispo dispoType params + where + paramP :: Parser (String, String) + paramP = do many lws + char ';' + many lws + name <- token + char '=' + value <- token <|> quotedStr + return (name, value) diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index 44cf155..bbe16a3 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -167,7 +167,7 @@ infixr 0 <|> (<|>) :: Parser a -> Parser a -> Parser a f <|> g = f `seq` g `seq` - Parser $! do saved <- get -- 状態を保存 + Parser $! do saved <- get -- 状態を保存 result <- runParser f case result of Success a -> return $! Success a @@ -185,8 +185,17 @@ oneOf = foldl (<|>) failP . map char notFollowedBy :: Parser a -> Parser () -notFollowedBy p = p `seq` - (p >> failP) <|> return () +notFollowedBy p + = p `seq` + Parser $! do saved <- get -- 状態を保存 + result <- runParser p + case result of + Success a -> do put saved -- 状態を復歸 + return IllegalInput + IllegalInput -> do put saved -- 状態を復歸 + return $! Success () + ReachedEOF -> do put saved -- 状態を復歸 + return $! Success () digit :: Parser Char diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index bf75de8..33eaa62 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -137,6 +137,7 @@ import Data.Bits import Data.ByteString.Base (ByteString, LazyByteString(..)) import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy.Char8 as L8 +import Data.Char import Data.List import Data.Maybe import Network.HTTP.Lucu.Abortion @@ -147,6 +148,7 @@ import Network.HTTP.Lucu.ETag import qualified Network.HTTP.Lucu.Headers as H import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.MultipartForm import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.RFC1123DateTime @@ -679,14 +681,11 @@ inputChunkLBS limit -- | Computation of @'inputForm' limit@ attempts to read the request -- body with 'input' and parse it as --- application\/x-www-form-urlencoded. If the request header --- \"Content-Type\" is not application\/x-www-form-urlencoded, --- 'inputForm' makes 'Resource' abort with status \"415 Unsupported --- Media Type\". If the request has no \"Content-Type\", it aborts --- with \"400 Bad Request\". --- --- This action should also support multipart\/form-data somehow, but --- it is not (yet) done. +-- application\/x-www-form-urlencoded or multipart\/form-data. If the +-- request header \"Content-Type\" is neither of them, 'inputForm' +-- 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 limit = limit `seq` @@ -696,8 +695,8 @@ inputForm limit -> abort BadRequest [] (Just "Missing Content-Type") Just (MIMEType "application" "x-www-form-urlencoded" _) -> readWWWFormURLEncoded - Just (MIMEType "multipart" "form-data" _) - -> readMultipartFormData + Just (MIMEType "multipart" "form-data" params) + -> readMultipartFormData params Just cType -> abort UnsupportedMediaType [] (Just $! "Unsupported media type: " ++ show cType) @@ -706,9 +705,16 @@ inputForm limit = do src <- input limit return $ parseWWWFormURLEncoded src - readMultipartFormData -- FIXME: 未對應 - = abort UnsupportedMediaType [] - (Just $! "Sorry, inputForm does not currently support multipart/form-data.") + readMultipartFormData params + = do case find ((== "boundary") . map toLower . fst) params of + Nothing + -> abort BadRequest [] (Just "Missing boundary of multipart/form-data") + Just (_, boundary) + -> do src <- inputLBS limit + case parse (multipartFormP boundary) src of + (# Success pairs, _ #) -> return pairs + (# _, _ #) + -> abort BadRequest [] (Just "Unparsable multipart/form-data") -- | This is just a constant @-1@. It's better to say @'input' -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly diff --git a/examples/Makefile b/examples/Makefile index 2727e64..5200e84 100644 --- a/examples/Makefile +++ b/examples/Makefile @@ -2,12 +2,13 @@ build: MiseRafturai.hs SmallFile.hs ghc --make HelloWorld -threaded -O3 -fwarn-unused-imports ghc --make Implanted -threaded -O3 -fwarn-unused-imports ghc --make ImplantedSmall -threaded -O3 -fwarn-unused-imports + ghc --make Multipart -threaded -O3 -fwarn-unused-imports run: build ./HelloWorld clean: - rm -f HelloWorld Implanted MiseRafturai.hs ImplantedSmall SmallFile.hs *.hi *.o + rm -f HelloWorld Implanted MiseRafturai.hs ImplantedSmall SmallFile.hs Multipart *.hi *.o MiseRafturai.hs: mise-rafturai.html lucu-implant-file -m MiseRafturai -o $@ $< diff --git a/examples/Multipart.hs b/examples/Multipart.hs new file mode 100644 index 0000000..b7faa38 --- /dev/null +++ b/examples/Multipart.hs @@ -0,0 +1,35 @@ +import Data.List +import Data.Maybe +import Network +import Network.HTTP.Lucu + +main :: IO () +main = let config = defaultConfig { cnfServerPort = PortNumber 9999 } + resources = mkResTree [ ([], resMain) ] + in + do putStrLn "Access http://localhost:9999/ with your browser." + runHttpd config resources + + +resMain :: ResourceDef +resMain + = ResourceDef { + resUsesNativeThread = False + , resIsGreedy = False + , resGet + = Just $ do setContentType $ read "text/html" + output ("Multipart Form Test" ++ + "
" ++ + " Enter some value:" ++ + " " ++ + " " ++ + "
") + , resHead = Nothing + , resPost + = Just $ do form <- inputForm defaultLimit + let value = fromMaybe "" $ fmap snd $ find ((== "val") . fst) form + setContentType $ read "text/plain" + output ("You entered: " ++ value) + , resPut = Nothing + , resDelete = Nothing + } \ No newline at end of file -- 2.40.0