Network/HTTP/Lucu/MultipartForm.hs

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