^examples/Implanted$
^examples/ImplantedSmall$
^examples/MiseRafturai\.hs$
+^examples/Multipart$
^examples/SmallFile\.hs$
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
module Network.HTTP.Lucu.Abortion
( Abortion(..)
, abort
+ , abortPurely
, abortSTM
, abortA
, abortPage
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
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
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)]
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 のこの部分
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
--- /dev/null
+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)
(<|>) :: 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
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
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
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
-- | 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`
-> 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)
= 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
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 $@ $<
--- /dev/null
+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 ("<title>Multipart Form Test</title>" ++
+ "<form action=\"/\" method=\"post\" enctype=\"multipart/form-data\">" ++
+ " Enter some value:" ++
+ " <input type=\"text\" name=\"val\">" ++
+ " <input type=\"submit\" value=\"Submit\">" ++
+ "</form>")
+ , 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
projects / Lucu.git / commitdiff