X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMultipartForm.hs;h=a5280c043f6bf252bf0095ba2792c3959ab26247;hb=bb121f1189d01b5089aa5c29f0d390fad36ade48;hp=53174fa94d0a2f0ac448e4a53182800e5da64c43;hpb=a362be1c8664306b970c32e1df9b62081498feb1;p=Lucu.git diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index 53174fa..a5280c0 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -2,14 +2,14 @@ DoAndIfThenElse , FlexibleContexts , OverloadedStrings + , QuasiQuotes , RecordWildCards , ScopedTypeVariables , 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 @@ -17,36 +17,42 @@ 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.Attoparsec import qualified Data.Attoparsec.Lazy as LP -import qualified Data.ByteString.Lazy.Char8 as LS +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.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) } @@ -60,7 +66,7 @@ data Part data ContDispo = ContDispo { dType ∷ !CIAscii - , dParams ∷ !(Map CIAscii Text) + , dParams ∷ !MIMEParams } printContDispo ∷ ContDispo → Ascii @@ -75,14 +81,14 @@ printContDispo d -- 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)] @@ -126,12 +132,7 @@ prologue boundary "prologue" epilogue ∷ Parser () -epilogue = ( (string "--" "suffix") - *> - crlf - *> - endOfInput - ) +epilogue = finishOff ((string "--" "suffix") *> crlf) "epilogue" @@ -155,7 +156,7 @@ parsePart boundary src ⧺ e where defaultCType ∷ MIMEType - defaultCType = parseMIMEType "text/plain" + defaultCType = [mimeType| text/plain |] partHeader ∷ Parser Headers partHeader = crlf *> headers @@ -167,16 +168,12 @@ getContDispo hdrs Nothing → throwError "Content-Disposition is missing" Just str - → case parseOnly p $ A.toByteString str of + → case parseOnly (finishOff contentDisposition) $ A.toByteString str of Right d → return d Left err → throwError $ "malformed Content-Disposition: " ⧺ A.toString str ⧺ ": " ⧺ err - where - p = do dispo ← contentDisposition - endOfInput - return dispo contentDisposition ∷ Parser ContDispo contentDisposition @@ -191,27 +188,28 @@ getContType hdrs Nothing → return Nothing Just str - → case parseOnly p $ A.toByteString str of + → case parseOnly (finishOff MT.mimeType) $ A.toByteString 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 getBody ∷ MonadError String m ⇒ Ascii → LS.ByteString → m (LS.ByteString, LS.ByteString) {-# INLINEABLE getBody #-} -getBody boundary src - = case breakFindAfter (A.toByteString boundary) src of - ((before, after), True) - → return (before, after) - _ → throwError "missing boundary" +getBody (("\r\n--" ⊕) ∘ A.toByteString → boundary) src + = case breakOn boundary src of + (before, after) + | LS.null after + → throwError "missing boundary" + | otherwise + → let len = fromIntegral $ BS.length boundary + after' = LS.drop len after + in + return (before, after') partToFormPair ∷ MonadError String m ⇒ Part → m (Ascii, FormData) {-# INLINEABLE partToFormPair #-} @@ -231,7 +229,7 @@ partToFormPair pt@(Part {..}) 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 @@ -242,5 +240,5 @@ partName (Part {..}) ⧺ A.toString (printContDispo ptContDispo) partFileName ∷ Part → Maybe Text -partFileName (Part {..}) - = M.lookup "filename" $ dParams ptContDispo +partFileName (ptContDispo → ContDispo {..}) + = lookup "filename" dParams