X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMultipartForm.hs;h=2d1b3470f1cf62a797a1336c183e8d54999589b9;hb=c9a269666f2d60d9c5ba817e1c43b45f6d77de22;hp=edba0d50f1e33e589feeb10b57ec71dbe4ebb3da;hpb=2089e7b8c07ae67292073b4113eb14d858a4a2c0;p=Lucu.git diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index edba0d5..2d1b347 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -1,16 +1,18 @@ {-# LANGUAGE DoAndIfThenElse + , FlexibleInstances , FlexibleContexts + , MultiParamTypeClasses , OverloadedStrings + , QuasiQuotes , RecordWildCards , ScopedTypeVariables + , TemplateHaskell , UnicodeSyntax , ViewPatterns #-} -- |Parse \"multipart/form-data\" based on RFC 2388: --- --- --- You usually don't have to use this module directly. +-- module Network.HTTP.Lucu.MultipartForm ( FormData(..) , parseMultipartFormData @@ -18,37 +20,44 @@ module Network.HTTP.Lucu.MultipartForm where import Control.Applicative hiding (many) import Control.Applicative.Unicode hiding ((∅)) -import Control.Monad.Error +import Control.Monad.Error (MonadError, throwError) import Control.Monad.Unicode -import Data.Ascii (Ascii, CIAscii) -import qualified Data.Ascii as A +import Data.Ascii (Ascii, CIAscii, AsciiBuilder) +import Data.Attempt import Data.Attoparsec import qualified Data.Attoparsec.Lazy as LP import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LS import Data.ByteString.Lazy.Search -import Data.Foldable -import Data.List -import Data.Map (Map) -import qualified Data.Map as M +import Data.Collections +import Data.Convertible.Base +import Data.Convertible.Instances.Ascii () +import Data.Convertible.Utils +import Data.List (intercalate) import Data.Maybe import Data.Monoid.Unicode import Data.Sequence (Seq) -import Data.Sequence.Unicode hiding ((∅)) import Data.Text (Text) -import qualified Data.Text as T import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.MIMEType +import Network.HTTP.Lucu.MIMEParams +import Network.HTTP.Lucu.MIMEType (MIMEType) +import qualified Network.HTTP.Lucu.MIMEType as MT +import Network.HTTP.Lucu.MIMEType.TH +import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Parser.Http -import Network.HTTP.Lucu.RFC2231 +import Network.HTTP.Lucu.Utils +import Prelude hiding (lookup, mapM) import Prelude.Unicode -- |'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) } @@ -62,29 +71,35 @@ data Part data ContDispo = ContDispo { dType ∷ !CIAscii - , dParams ∷ !(Map CIAscii Text) + , dParams ∷ !MIMEParams } -printContDispo ∷ ContDispo → Ascii -printContDispo d - = A.fromAsciiBuilder - ( A.toAsciiBuilder (A.fromCIAscii $ dType d) - ⊕ - printMIMEParams (dParams d) ) +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\" aren't decomposed. +-- \"multipart/form-data\" won't be decomposed. -- --- * \"Content-Transfer-Encoding\"s are always ignored. +-- * \"Content-Transfer-Encoding\" is always ignored. -- --- * RFC 2388 says that non-ASCII field names are encoded according --- to the method in RFC 2047 --- , but they aren't --- decoded. +-- * RFC 2388 () says +-- that non-ASCII field names are encoded according to the method in +-- RFC 2047 (), but they won't +-- be decoded. parseMultipartFormData ∷ Ascii -- ^boundary → LS.ByteString -- ^input → Either String [(Ascii, FormData)] @@ -120,7 +135,7 @@ prologue ∷ Ascii → Parser () prologue boundary = ( (string "--" "prefix") *> - (string (A.toByteString boundary) "boundary") + (string (cs boundary) "boundary") *> pure () ) @@ -128,12 +143,7 @@ prologue boundary "prologue" epilogue ∷ Parser () -epilogue = ( (string "--" "suffix") - *> - crlf - *> - endOfInput - ) +epilogue = finishOff ((string "--" "suffix") *> crlf) "epilogue" @@ -157,7 +167,7 @@ parsePart boundary src ⧺ e where defaultCType ∷ MIMEType - defaultCType = parseMIMEType "text/plain" + defaultCType = [mimeType| text/plain |] partHeader ∷ Parser Headers partHeader = crlf *> headers @@ -169,20 +179,16 @@ getContDispo hdrs Nothing → throwError "Content-Disposition is missing" Just str - → case parseOnly p $ A.toByteString str of + → case parseOnly (finishOff contentDisposition) $ cs str of Right d → return d Left err → throwError $ "malformed Content-Disposition: " - ⧺ A.toString str - ⧺ ": " - ⧺ err - where - p = do dispo ← contentDisposition - endOfInput - return dispo + ⊕ cs str + ⊕ ": " + ⊕ err contentDisposition ∷ Parser ContDispo contentDisposition - = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams) + = (ContDispo <$> (cs <$> token) ⊛ mimeParams) "contentDisposition" @@ -193,23 +199,19 @@ getContType hdrs Nothing → return Nothing Just str - → case parseOnly p $ A.toByteString str of + → case parseOnly (finishOff MT.mimeType) $ cs str of Right d → return $ Just d Left err → throwError $ "malformed Content-Type: " - ⧺ A.toString str - ⧺ ": " - ⧺ err - where - p = do t ← mimeType - endOfInput - return t + ⊕ cs str + ⊕ ": " + ⊕ err getBody ∷ MonadError String m ⇒ Ascii → LS.ByteString → m (LS.ByteString, LS.ByteString) {-# INLINEABLE getBody #-} -getBody (("\r\n--" ⊕) ∘ A.toByteString → boundary) src +getBody (("\r\n--" ⊕) ∘ cs → boundary) src = case breakOn boundary src of (before, after) | LS.null after @@ -233,21 +235,20 @@ partToFormPair pt@(Part {..}) return (name, fd) | otherwise = throwError $ "disposition type is not \"form-data\": " - ⧺ A.toString (A.fromCIAscii $ dType ptContDispo) + ⊕ cs (dType ptContDispo) partName ∷ MonadError String m ⇒ Part → m Ascii {-# INLINEABLE partName #-} partName (Part {..}) - = case M.lookup "name" $ dParams ptContDispo of + = case lookup "name" $ dParams ptContDispo of Just name - → case A.fromText name of - Just a → return a - Nothing → throwError $ "Non-ascii part name: " - ⧺ T.unpack name + → case ca name of + Success a → return a + Failure e → throwError $ show e Nothing → throwError $ "form-data without name: " - ⧺ A.toString (printContDispo ptContDispo) + ⊕ convertSuccessVia ((⊥) ∷ Ascii) ptContDispo partFileName ∷ Part → Maybe Text -partFileName (Part {..}) - = M.lookup "filename" $ dParams ptContDispo +partFileName (ptContDispo → ContDispo {..}) + = lookup "filename" dParams