{-# LANGUAGE
- UnboxedTuples
+ DoAndIfThenElse
+ , OverloadedStrings
+ , ScopedTypeVariables
+ , UnboxedTuples
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.MultipartForm
, multipartFormP
)
where
-import qualified Data.ByteString.Char8 as C8
-import qualified Data.ByteString.Lazy.Char8 as L8
+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.Http
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Utils
-
-data Part = Part Headers L8.ByteString
+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
+ }
+instance HasHeaders Part where
+ getHeaders = ptHeaders
+ setHeaders pt hs = pt { ptHeaders = hs }
-data ContDispo = ContDispo String [(String, String)]
+data ContDispo
+ = ContDispo {
+ dType ∷ !CIAscii
+ , dParams ∷ ![(CIAscii, Ascii)]
+ }
-instance Show ContDispo where
- show (ContDispo dType dParams)
- = dType ++
- if null dParams then
- ""
+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, FormData)]
+ 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 "--"
- _ <- crlf
- eof
- return $ map partToFormPair parts
-
-
-partP :: String -> Parser Part
+ = try $
+ do parts ← many (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
+ = try $
+ 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
+ = try $
+ do body ← manyCharsTill anyChar $
+ try $
+ do crlf
+ _ ← string "--"
+ _ ← string $ A.toByteString boundary
+ return ()
+ 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
+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)
projects / Lucu.git / blobdiff