X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMultipartForm.hs;h=4dcf076c93c13be34f7fd3bc0986f24652601616;hb=02d702c138d918386135245021d5778676ee6d0e;hp=21fca67b8519f2a13d29c5c11cfbda6a116c5c18;hpb=e53a2f3202f763e844de725712f1bf26b82cd41f;p=Lucu.git diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index 21fca67..4dcf076 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -1,114 +1,170 @@ +{-# LANGUAGE + DoAndIfThenElse + , OverloadedStrings + , ScopedTypeVariables + , UnboxedTuples + , UnicodeSyntax + #-} module Network.HTTP.Lucu.MultipartForm - ( multipartFormP + ( FormData(..) + , multipartFormP ) where - -import Data.ByteString.Base (LazyByteString(..)) -import qualified Data.ByteString.Char8 as C8 +import Control.Applicative hiding (many) +import Data.Ascii (Ascii, CIAscii, AsciiBuilder) +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LS import Data.Char import Data.List -import Network.HTTP.Lucu.Abortion +import Data.Maybe +import Data.Monoid.Unicode +import Data.Text (Text) 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 +import Prelude.Unicode + +-- |This data type represents a form value and possibly an uploaded +-- file name. +data FormData + = FormData { + fdFileName ∷ Maybe Text + , fdContent ∷ LS.ByteString + } + +data Part + = Part { + ptHeaders ∷ Headers + , ptContDispo ∷ ContDispo + , ptBody ∷ LS.ByteString + } 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 - "" + getHeaders = ptHeaders + setHeaders pt hs = pt { ptHeaders = hs } + +data ContDispo + = ContDispo { + dType ∷ !CIAscii + , dParams ∷ ![(CIAscii, Ascii)] + } + +printContDispo ∷ ContDispo → Ascii +printContDispo d + = A.fromAsciiBuilder $ + ( A.toAsciiBuilder (A.fromCIAscii $ dType d) + ⊕ + ( if null $ dParams d 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)] + A.toAsciiBuilder "; " ⊕ + joinWith "; " (map printPair $ dParams d) ) ) + where + printPair ∷ (CIAscii, Ascii) → AsciiBuilder + printPair (name, value) + = A.toAsciiBuilder (A.fromCIAscii name) ⊕ + A.toAsciiBuilder "=" ⊕ + ( if BS.any ((¬) ∘ isToken) $ A.toByteString value then + quoteStr value + else + A.toAsciiBuilder value ) + +multipartFormP ∷ Ascii → Parser [(Text, FormData)] multipartFormP boundary - = do parts <- many (partP boundary) - string "--" - string boundary - string "--" + = try $ + do parts ← many (partP boundary) + _ ← string "--" + _ ← string $ A.toByteString boundary + _ ← string "--" crlf - eof - return $ map partToPair parts - + catMaybes <$> mapM partToFormPair parts -partP :: String -> Parser Part +partP ∷ Ascii → Parser Part partP boundary - = do string "--" - string boundary - crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。 - hs <- headersP - body <- bodyP boundary - return $ Part hs body - + = try $ + do _ ← string "--" + _ ← string $ A.toByteString boundary + crlf + hs ← headersP + d ← getContDispo hs + body ← bodyP boundary + return $ Part hs d body -bodyP :: String -> Parser String +bodyP ∷ Ascii → Parser LS.ByteString bodyP boundary - = do body <- many $ - do notFollowedBy $ do crlf - string "--" - string boundary - anyChar + = try $ + do body ← manyCharsTill anyChar $ + try $ + do crlf + _ ← string "--" + _ ← string $ A.toByteString boundary + return () 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 +partToFormPair ∷ Monad m ⇒ Part → m (Maybe (Text, FormData)) +{-# INLINEABLE partToFormPair #-} +partToFormPair pt + | dType (ptContDispo pt) ≡ "form-data" + = do name ← partName pt + let fname = partFileName pt + let fd = FormData { + fdFileName = fname + , fdContent = ptBody pt + } + return $ Just (name, fd) + | otherwise + = return Nothing + +partName ∷ Monad m ⇒ Part → m Text +{-# INLINEABLE partName #-} +partName pt + = case find ((≡ "name") ∘ fst) $ dParams $ ptContDispo pt of + Just (_, name) + → return name + Nothing + → fail ("form-data without name: " ⧺ + A.toString (printContDispo $ ptContDispo pt)) + +partFileName ∷ Part → Maybe Text +{-# INLINEABLE partFileName #-} +partFileName pt + = snd <$> (find ((== "filename") ∘ fst) $ dParams $ ptContDispo pt) + +getContDispo ∷ Monad m ⇒ Headers → m ContDispo +{-# INLINEABLE getContDispo #-} +getContDispo hdr + = case getHeader "Content-Disposition" hdr of + Nothing + → fail ("There is a part without Content-Disposition in the multipart/form-data.") + Just str + → let p = do d ← contDispoP + endOfInput + return d + bs = A.toByteString str + in + case parseOnly p bs of + Right d → return d + Left err → fail (concat [ "Unparsable Content-Disposition: " + , BS.unpack bs + , ": " + , err + ]) + +contDispoP ∷ Parser ContDispo +contDispoP = try $ + do dispoType ← A.toCIAscii <$> token + params ← many paramP return $ ContDispo dispoType params where - paramP :: Parser (String, String) - paramP = do many lws - char ';' - many lws - name <- token - char '=' - value <- token <|> quotedStr + paramP ∷ Parser (CIAscii, Ascii) + paramP = do skipMany lws + _ ← char ';' + skipMany lws + name ← A.toCIAscii <$> token + _ ← char '=' + value ← token <|> quotedStr return (name, value)