Network/HTTP/Lucu/MultipartForm.hs

   1 {-# LANGUAGE
   2     DoAndIfThenElse
   3   , FlexibleContexts
   4   , OverloadedStrings
   5   , RecordWildCards
   6   , ScopedTypeVariables
   7   , UnicodeSyntax
   8   , ViewPatterns
   9   #-}
  10 -- |Parse \"multipart/form-data\" based on RFC 2388:
  11 -- <http://www.faqs.org/rfcs/rfc2388.html>
  12 --
  13 -- You usually don't have to use this module directly.
  14 module Network.HTTP.Lucu.MultipartForm
  15     ( FormData(..)
  16     , parseMultipartFormData
  17     )
  18     where
  19 import Control.Applicative hiding (many)
  20 import Control.Applicative.Unicode hiding ((∅))
  21 import Control.Monad.Error
  22 import Control.Monad.Unicode
  23 import Data.Ascii (Ascii, CIAscii)
  24 import qualified Data.Ascii as A
  25 import Data.Attoparsec
  26 import qualified Data.Attoparsec.Lazy as LP
  27 import qualified Data.ByteString as BS
  28 import qualified Data.ByteString.Lazy as LS
  29 import Data.ByteString.Lazy.Search
  30 import Data.Foldable
  31 import Data.List
  32 import Data.Map (Map)
  33 import qualified Data.Map as M
  34 import Data.Maybe
  35 import Data.Monoid.Unicode
  36 import Data.Sequence (Seq)
  37 import Data.Sequence.Unicode hiding ((∅))
  38 import Data.Text (Text)
  39 import qualified Data.Text as T
  40 import Network.HTTP.Lucu.Headers
  41 import Network.HTTP.Lucu.MIMEType
  42 import Network.HTTP.Lucu.Parser.Http
  43 import Network.HTTP.Lucu.RFC2231
  44 import Prelude.Unicode
  45
  46 -- |'FormData' represents a form value and possibly an uploaded file
  47 -- name.
  48 data FormData
  49     = FormData {
  50         fdFileName ∷ !(Maybe Text)
  51       , fdMIMEType ∷ !MIMEType
  52       , fdContent  ∷ !(LS.ByteString)
  53       }
  54
  55 data Part
  56     = Part {
  57         ptContDispo ∷ !ContDispo
  58       , ptContType  ∷ !MIMEType
  59       , ptBody      ∷ !LS.ByteString
  60       }
  61
  62 data ContDispo
  63     = ContDispo {
  64         dType   ∷ !CIAscii
  65       , dParams ∷ !(Map CIAscii Text)
  66       }
  67
  68 printContDispo ∷ ContDispo → Ascii
  69 printContDispo d
  70     = A.fromAsciiBuilder
  71       ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
  72         ⊕
  73         printMIMEParams (dParams d) )
  74
  75 -- |Parse \"multipart/form-data\" and return either @'Left' err@ or
  76 -- @'Right' result@. Note that there are currently the following
  77 -- limitations:
  78 --
  79 --   * Multiple files embedded as \"multipart/mixed\" within the
  80 --     \"multipart/form-data\" aren't decomposed.
  81 --
  82 --   * \"Content-Transfer-Encoding\"s are always ignored.
  83 --
  84 --   * RFC 2388 says that non-ASCII field names are encoded according
  85 --     to the method in RFC 2047
  86 --     <http://www.faqs.org/rfcs/rfc2047.html>, but they aren't
  87 --     decoded.
  88 parseMultipartFormData ∷ Ascii -- ^boundary
  89                        → LS.ByteString -- ^input
  90                        → Either String [(Ascii, FormData)]
  91 parseMultipartFormData boundary = (mapM partToFormPair =≪) ∘ go
  92     where
  93       go ∷ (Functor m, MonadError String m)
  94          ⇒ LS.ByteString
  95          → m [Part]
  96       {-# INLINEABLE go #-}
  97       go src
  98           = case LP.parse (prologue boundary) src of
  99               LP.Done src' _
 100                   → go' src' (∅)
 101               LP.Fail _ eCtx e
 102                   → throwError $ "Unparsable multipart/form-data: "
 103                                ⧺ intercalate ", " eCtx
 104                                ⧺ ": "
 105                                ⧺ e
 106       go' ∷ (Functor m, MonadError String m)
 107           ⇒ LS.ByteString
 108           → Seq Part
 109           → m [Part]
 110       {-# INLINEABLE go' #-}
 111       go' src xs
 112           = case LP.parse epilogue src of
 113               LP.Done _ _
 114                   → return $ toList xs
 115               LP.Fail _ _ _
 116                   → do (src', x) ← parsePart boundary src
 117                        go' src' $ xs ⊳ x
 118
 119 prologue ∷ Ascii → Parser ()
 120 prologue boundary
 121     = ( (string "--" <?> "prefix")
 122         *>
 123         (string (A.toByteString boundary) <?> "boundary")
 124         *>
 125         pure ()
 126       )
 127       <?>
 128       "prologue"
 129
 130 epilogue ∷ Parser ()
 131 epilogue = ( (string "--" <?> "suffix")
 132              *>
 133              crlf
 134              *>
 135              endOfInput
 136            )
 137            <?>
 138            "epilogue"
 139
 140 parsePart ∷ (Functor m, MonadError String m)
 141           ⇒ Ascii
 142           → LS.ByteString
 143           → m (LS.ByteString, Part)
 144 {-# INLINEABLE parsePart #-}
 145 parsePart boundary src
 146     = case LP.parse partHeader src of
 147         LP.Done src' hdrs
 148             → do dispo ← getContDispo hdrs
 149                  cType ← fromMaybe defaultCType <$> getContType hdrs
 150                  (body, src'')
 151                        ← getBody boundary src'
 152                  return (src'', Part dispo cType body)
 153         LP.Fail _ eCtx e
 154             → throwError $ "unparsable part: "
 155                          ⧺ intercalate ", " eCtx
 156                          ⧺ ": "
 157                          ⧺ e
 158       where
 159         defaultCType ∷ MIMEType
 160         defaultCType = parseMIMEType "text/plain"
 161
 162 partHeader ∷ Parser Headers
 163 partHeader = crlf *> headers
 164
 165 getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
 166 {-# INLINEABLE getContDispo #-}
 167 getContDispo hdrs
 168     = case getHeader "Content-Disposition" hdrs of
 169         Nothing
 170             → throwError "Content-Disposition is missing"
 171         Just str
 172             → case parseOnly p $ A.toByteString str of
 173                  Right  d → return d
 174                  Left err → throwError $ "malformed Content-Disposition: "
 175                                        ⧺ A.toString str
 176                                        ⧺ ": "
 177                                        ⧺ err
 178     where
 179       p = do dispo ← contentDisposition
 180              endOfInput
 181              return dispo
 182
 183 contentDisposition ∷ Parser ContDispo
 184 contentDisposition
 185     = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams)
 186       <?>
 187       "contentDisposition"
 188
 189 getContType ∷ MonadError String m ⇒ Headers → m (Maybe MIMEType)
 190 {-# INLINEABLE getContType #-}
 191 getContType hdrs
 192     = case getHeader "Content-Type" hdrs of
 193         Nothing
 194             → return Nothing
 195         Just str
 196             → case parseOnly p $ A.toByteString str of
 197                  Right  d → return $ Just d
 198                  Left err → throwError $ "malformed Content-Type: "
 199                                        ⧺ A.toString str
 200                                        ⧺ ": "
 201                                        ⧺ err
 202     where
 203       p = do t ← mimeType
 204              endOfInput
 205              return t
 206
 207 getBody ∷ MonadError String m
 208         ⇒ Ascii
 209         → LS.ByteString
 210         → m (LS.ByteString, LS.ByteString)
 211 {-# INLINEABLE getBody #-}
 212 getBody (("\r\n--" ⊕) ∘ A.toByteString → boundary) src
 213     = case breakOn boundary src of
 214         (before, after)
 215             | LS.null after
 216                 → throwError "missing boundary"
 217             | otherwise
 218                 → let len    = fromIntegral $ BS.length boundary
 219                       after' = LS.drop len after
 220                   in
 221                     return (before, after')
 222
 223 partToFormPair ∷ MonadError String m ⇒ Part → m (Ascii, FormData)
 224 {-# INLINEABLE partToFormPair #-}
 225 partToFormPair pt@(Part {..})
 226     | dType ptContDispo ≡ "form-data"
 227         = do name ← partName pt
 228              let fd = FormData {
 229                         fdFileName = partFileName pt
 230                       , fdMIMEType = ptContType
 231                       , fdContent  = ptBody
 232                       }
 233              return (name, fd)
 234     | otherwise
 235         = throwError $ "disposition type is not \"form-data\": "
 236                      ⧺ A.toString (A.fromCIAscii $ dType ptContDispo)
 237
 238 partName ∷ MonadError String m ⇒ Part → m Ascii
 239 {-# INLINEABLE partName #-}
 240 partName (Part {..})
 241     = case M.lookup "name" $ dParams ptContDispo of
 242         Just name
 243             → case A.fromText name of
 244                  Just a  → return a
 245                  Nothing → throwError $ "Non-ascii part name: "
 246                                       ⧺ T.unpack name
 247         Nothing
 248             → throwError $ "form-data without name: "
 249                          ⧺ A.toString (printContDispo ptContDispo)
 250
 251 partFileName ∷ Part → Maybe Text
 252 partFileName (Part {..})
 253     = M.lookup "filename" $ dParams ptContDispo