-import Data.ByteString.Base (LazyByteString(..))
-import qualified Data.ByteString.Char8 as C8
-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
-
-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
- ""
- 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)]
-multipartFormP boundary
- = do parts <- many (partP boundary)
- string "--"
- string boundary
- string "--"
- crlf
- eof
- return $ map partToPair parts
-
-
-partP :: String -> Parser Part
-partP boundary
- = do string "--"
- string boundary
- crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。
- hs <- headersP
- body <- bodyP boundary
- return $ Part hs body
-
-
-bodyP :: String -> Parser String
-bodyP boundary
- = do body <- many $
- do notFollowedBy $ do crlf
- string "--"
- string boundary
- anyChar
- 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)
+-- |'FormData' represents a form value and possibly an uploaded file
+-- name.
+data FormData
+ = FormData {
+ -- | @'Nothing'@ for non-file values.
+ fdFileName ∷ !(Maybe Text)
+ -- | MIME Type of this value, defaulted to \"text/plain\".
+ , fdMIMEType ∷ !MIMEType
+ -- | The form value.
+ , fdContent ∷ !(LS.ByteString)
+ }
+
+data Part
+ = Part {
+ ptContDispo ∷ !ContDispo
+ , ptContType ∷ !MIMEType
+ , ptBody ∷ !LS.ByteString
+ }
+
+data ContDispo
+ = ContDispo {
+ dType ∷ !CIAscii
+ , dParams ∷ !MIMEParams
+ }
+
+instance ConvertSuccess ContDispo Ascii where
+ {-# INLINE convertSuccess #-}
+ convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance ConvertSuccess ContDispo AsciiBuilder where
+ {-# INLINE convertSuccess #-}
+ convertSuccess (ContDispo {..})
+ = cs dType ⊕ cs dParams
+
+deriveAttempts [ ([t| ContDispo |], [t| Ascii |])
+ , ([t| ContDispo |], [t| AsciiBuilder |])
+ ]
+
+-- |Parse \"multipart/form-data\" and return either @'Left' err@ or
+-- @'Right' result@. Note that there are currently the following
+-- limitations:
+--
+-- * Multiple files embedded as \"multipart/mixed\" within the
+-- \"multipart/form-data\" won't be decomposed.
+--
+-- * \"Content-Transfer-Encoding\" is always ignored.
+--
+-- * RFC 2388 (<http://tools.ietf.org/html/rfc2388#section-3>) says
+-- that non-ASCII field names are encoded according to the method in
+-- RFC 2047 (<http://tools.ietf.org/html/rfc2047>), but they won't
+-- be decoded.
+parseMultipartFormData ∷ Ascii -- ^boundary
+ → LS.ByteString -- ^input
+ → Either String [(Ascii, FormData)]
+parseMultipartFormData boundary = (mapM partToFormPair =≪) ∘ go
+ where
+ go ∷ (Functor m, MonadError String m)
+ ⇒ LS.ByteString
+ → m [Part]
+ {-# INLINEABLE go #-}
+ go src
+ = case LP.parse (prologue boundary) src of
+ LP.Done src' _
+ → go' src' (∅)
+ LP.Fail _ eCtx e
+ → throwError $ "Unparsable multipart/form-data: "
+ ⧺ intercalate ", " eCtx
+ ⧺ ": "
+ ⧺ e
+ go' ∷ (Functor m, MonadError String m)
+ ⇒ LS.ByteString
+ → Seq Part
+ → m [Part]
+ {-# INLINEABLE go' #-}
+ go' src xs
+ = case LP.parse epilogue src of
+ LP.Done _ _
+ → return $ toList xs
+ LP.Fail _ _ _
+ → do (src', x) ← parsePart boundary src
+ go' src' $ xs ⊳ x
+
+prologue ∷ Ascii → Parser ()
+prologue boundary
+ = ( (string "--" <?> "prefix")
+ *>
+ (string (A.toByteString boundary) <?> "boundary")
+ *>
+ pure ()
+ )
+ <?>
+ "prologue"
+
+epilogue ∷ Parser ()
+epilogue = finishOff ((string "--" <?> "suffix") *> crlf)
+ <?>
+ "epilogue"
+
+parsePart ∷ (Functor m, MonadError String m)
+ ⇒ Ascii
+ → LS.ByteString
+ → m (LS.ByteString, Part)
+{-# INLINEABLE parsePart #-}
+parsePart boundary src
+ = case LP.parse partHeader src of
+ LP.Done src' hdrs
+ → do dispo ← getContDispo hdrs
+ cType ← fromMaybe defaultCType <$> getContType hdrs
+ (body, src'')
+ ← getBody boundary src'
+ return (src'', Part dispo cType body)
+ LP.Fail _ eCtx e
+ → throwError $ "unparsable part: "
+ ⧺ intercalate ", " eCtx
+ ⧺ ": "
+ ⧺ e