Network/HTTP/Lucu/MultipartForm.hs

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