X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMultipartForm.hs;h=8d09d701fbe460a37059c6ed196e99b06d0f855d;hb=dfc778742934b8f2ac6a6709741c79ecd40c5ff1;hp=c9684b18892e3e2259e1818a13385f91cfa98b8c;hpb=9ac730212cb361eb10e5fe4ad0eec6758e2b200a;p=Lucu.git diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index c9684b1..8d09d70 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -1,155 +1,143 @@ +{-# LANGUAGE + DoAndIfThenElse + , OverloadedStrings + , RecordWildCards + , ScopedTypeVariables + , UnicodeSyntax + #-} module Network.HTTP.Lucu.MultipartForm ( FormData(..) , 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 -import Network.HTTP.Lucu.Parser.Http -import Network.HTTP.Lucu.Response -import Network.HTTP.Lucu.Utils - - -data Part = Part Headers L8.ByteString - --- |This data type represents a form entry name, form value and --- possibly an uploaded file name. +import Control.Applicative hiding (many) +import Data.Ascii (Ascii, CIAscii) +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.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.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 { - fdName :: String - , 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 [FormData] +multipartFormP ∷ Ascii → Parser [(Text, FormData)] multipartFormP boundary - = do parts <- many (partP boundary) - _ <- string "--" - _ <- string boundary - _ <- string "--" - _ <- crlf - eof - return $ map partToFormData parts - - -partP :: String -> Parser Part + = do parts ← many $ try $ partP boundary + _ ← string "--" + _ ← string $ A.toByteString boundary + _ ← string "--" + crlf + catMaybes <$> mapM partToFormPair parts + +partP ∷ Ascii → Parser Part partP boundary - = do _ <- string "--" - _ <- string boundary - _ <- crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。 - hs <- headersP - body <- bodyP boundary - return $ Part hs body - - -bodyP :: String -> Parser L8.ByteString + = do _ ← string "--" + _ ← string $ A.toByteString boundary + crlf + hs ← headersP + d ← getContDispo hs + body ← bodyP boundary + return $ Part hs d body + +bodyP ∷ Ascii → Parser LS.ByteString bodyP boundary - = do body <- manyChar $ - do notFollowedBy $ ( crlf >> - string "--" >> - string boundary ) - anyChar - _ <- crlf + = do body ← manyCharsTill anyChar $ + try $ + do crlf + _ ← string "--" + _ ← string $ A.toByteString boundary + return () + crlf return 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 "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 +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 +contDispoP = do dispoType ← A.toCIAscii <$> token + params ← paramsP 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)