X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMultipartForm.hs;h=72eef21c1ec9e99be27857e48169cd0b068d6c3e;hb=ece223c516e66223ef1d5d8e6bbe4054a235d983;hp=741427f271636e48eb3d1cf060b4fbf794c6c662;hpb=9bb89434103e9a22f100d6ecb7e65a5d461e0454;p=Lucu.git diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index 741427f..72eef21 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -1,5 +1,8 @@ {-# LANGUAGE - UnboxedTuples + DoAndIfThenElse + , OverloadedStrings + , RecordWildCards + , ScopedTypeVariables , UnicodeSyntax #-} module Network.HTTP.Lucu.MultipartForm @@ -7,147 +10,141 @@ module Network.HTTP.Lucu.MultipartForm , multipartFormP ) where -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy.Char8 as L8 -import Data.Char -import Data.List -import Network.HTTP.Lucu.Abortion -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.Parser.Http -import Network.HTTP.Lucu.Response -import Network.HTTP.Lucu.Utils - -data Part = Part Headers L8.ByteString +import Control.Applicative hiding (many) +import Control.Monad +import Data.Ascii (Ascii, CIAscii) +import qualified Data.Ascii as A +import Data.Attoparsec +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LS +import Data.Map (Map) +import qualified Data.Map as M +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.RFC2231 +import Prelude.Unicode -- |This data type represents a form value and possibly an uploaded -- file name. data FormData = FormData { - fdFileName :: Maybe String - , fdContent :: L8.ByteString + fdFileName ∷ Maybe Text + , fdContent ∷ LS.ByteString } -instance HasHeaders Part where - getHeaders (Part hs _) = hs - setHeaders (Part _ b) hs = Part hs b - +data Part + = Part { + ptHeaders ∷ Headers + , ptContDispo ∷ ContDispo + , ptBody ∷ LS.ByteString + } -data ContDispo = ContDispo String [(String, String)] +instance HasHeaders Part where + getHeaders = ptHeaders + setHeaders pt hs = pt { ptHeaders = hs } -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 +data ContDispo + = ContDispo { + dType ∷ !CIAscii + , dParams ∷ !(Map CIAscii Text) + } +printContDispo ∷ ContDispo → Ascii +printContDispo d + = A.fromAsciiBuilder + ( A.toAsciiBuilder (A.fromCIAscii $ dType d) + ⊕ + printParams (dParams d) ) -multipartFormP :: String -> Parser [(String, FormData)] +multipartFormP ∷ Ascii → Parser [(Text, FormData)] multipartFormP boundary - = do parts <- many (partP boundary) - _ <- string "--" - _ <- string boundary - _ <- string "--" - _ <- crlf - eof - return $ map partToFormPair 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 L8.ByteString -bodyP boundary - = do body <- manyChar $ - do notFollowedBy $ ( crlf >> - string "--" >> - string boundary ) - anyChar - _ <- crlf - return body - - -partToFormPair :: Part -> (String, FormData) -partToFormPair part@(Part _ body) - = let name = partName part - fname = partFileName part - fd = FormData { - fdFileName = fname - , fdContent = body - } - in (name, fd) - -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 "There is a part without Content-Disposition in the multipart/form-data.") - Just dispoStr - -> case parse contDispoP (L8.fromChunks [dispoStr]) of - (# Success dispo, _ #) - -> dispo - (# _, _ #) - -> abortPurely BadRequest [] - (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr) - - -contDispoP :: Parser ContDispo -contDispoP = do dispoType <- token - params <- allowEOF $ many paramP - return $ ContDispo dispoType params + = do void boundaryP + parts ← many $ partP boundaryP + void (string "--" "suffix") + crlf + catMaybes <$> mapM partToFormPair parts + + "multipartFormP" where - paramP :: Parser (String, String) - paramP = do _ <- many lws - _ <- char ';' - _ <- many lws - name <- token - _ <- char '=' - value <- token <|> quotedStr - return (name, value) + boundaryP ∷ Parser BS.ByteString + boundaryP = string ("--" ⊕ A.toByteString boundary) + + "boundaryP" + +partP ∷ Parser α → Parser Part +partP boundaryP + = do crlf + hs ← headersP + d ← getContDispo hs + body ← bodyP boundaryP + return $ Part hs d body + + "partP" + +bodyP ∷ Parser α → Parser LS.ByteString +bodyP boundaryP + = manyOctetsTill anyWord8 (try $ crlf *> boundaryP) + + "bodyP" + +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 (Part {..}) + = case M.lookup "name" $ dParams ptContDispo of + Just name + → return name + Nothing + → fail ("form-data without name: " ⧺ + A.toString (printContDispo ptContDispo)) + +partFileName ∷ Part → Maybe Text +{-# INLINEABLE partFileName #-} +partFileName (Part {..}) + = M.lookup "filename" $ dParams ptContDispo + +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 +{-# INLINEABLE contDispoP #-} +contDispoP + = do dispoType ← A.toCIAscii <$> token + params ← paramsP + return $ ContDispo dispoType params + + "contDispoP"