+{-# 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)
projects / Lucu.git / blobdiff