+{-# LANGUAGE
+ DoAndIfThenElse
+ , OverloadedStrings
+ , 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 String
-
--- |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, 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 Data.Map (Map)
+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 Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Utils
+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 :: String
+ 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 "--"
+ = try $
+ do parts ← many (partP boundary)
+ _ ← string "--"
+ _ ← string $ A.toByteString boundary
+ _ ← string "--"
crlf
- eof
- return $ map partToFormData 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
-
-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 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)