{-# 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)
{-# LANGUAGE
BangPatterns
, OverloadedStrings
+ , ScopedTypeVariables
, UnicodeSyntax
#-}
-- |This is an auxiliary parser utilities for parsing things related
, qvalue
, atMost
+ , manyCharsTill
)
where
import Control.Applicative
-import Control.Applicative.Unicode
+import Control.Applicative.Unicode hiding ((∅))
import Control.Monad.Unicode
import Data.Ascii (Ascii)
import qualified Data.Ascii as A
-import Data.Attoparsec.Char8 as P
+import Data.Attoparsec.Char8 as P hiding (scan)
import qualified Data.Attoparsec.FastSet as FS
import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy.Char8 as LS
+import qualified Data.ByteString.Lazy.Internal as LS
+import qualified Data.Foldable as F
+import Data.Monoid
+import Data.Monoid.Unicode
+import qualified Data.Sequence as S
+import Data.Sequence.Unicode hiding ((∅))
import Prelude.Unicode
-- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= c < 0x7F@.
atMost n v = ( (:) <$> v ⊛ atMost (n-1) v )
<|>
pure []
+
+
+data CharAccumState
+ = CharAccumState {
+ casChunks ∷ !(S.Seq BS.ByteString)
+ , casLastChunk ∷ !(S.Seq Char)
+ }
+
+instance Monoid CharAccumState where
+ mempty
+ = CharAccumState {
+ casChunks = (∅)
+ , casLastChunk = (∅)
+ }
+ mappend a b
+ = b {
+ casChunks = (casChunks a ⊳ lastChunk a) ⋈ casChunks b
+ }
+
+lastChunk ∷ CharAccumState → BS.ByteString
+{-# INLINE lastChunk #-}
+lastChunk = BS.pack ∘ F.toList ∘ casLastChunk
+
+snoc ∷ CharAccumState → Char → CharAccumState
+{-# INLINEABLE snoc #-}
+snoc cas c
+ | S.length (casLastChunk cas) ≥ LS.defaultChunkSize
+ = cas {
+ casChunks = casChunks cas ⊳ lastChunk cas
+ , casLastChunk = S.singleton c
+ }
+ | otherwise
+ = cas {
+ casLastChunk = casLastChunk cas ⊳ c
+ }
+
+finish ∷ CharAccumState → LS.ByteString
+{-# INLINEABLE finish #-}
+finish cas
+ = let chunks = F.toList $ casChunks cas ⊳ lastChunk cas
+ str = LS.fromChunks chunks
+ in
+ str
+
+manyCharsTill ∷ ∀m b. (Monad m, Alternative m)
+ ⇒ m Char
+ → m b
+ → m LS.ByteString
+{-# INLINEABLE manyCharsTill #-}
+manyCharsTill p end = scan (∅)
+ where
+ scan ∷ CharAccumState → m LS.ByteString
+ {-# INLINE scan #-}
+ scan s
+ = (end *> pure (finish s))
+ <|>
+ (scan =≪ (snoc s <$> p))
projects / Lucu.git / commitdiff