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://tools.ietf.org/html/rfc2388>
  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 qualified Data.Map as M
  33 import Data.Maybe
  34 import Data.Monoid.Unicode
  35 import Data.Sequence (Seq)
  36 import Data.Sequence.Unicode hiding ((∅))
  37 import Data.Text (Text)
  38 import qualified Data.Text as T
  39 import Network.HTTP.Lucu.Headers
  40 import Network.HTTP.Lucu.MIMEParams
  41 import Network.HTTP.Lucu.MIMEType
  42 import Network.HTTP.Lucu.Parser
  43 import Network.HTTP.Lucu.Parser.Http
  44 import Prelude.Unicode
  45
  46 -- |'FormData' represents a form value and possibly an uploaded file
  47 -- name.
  48 data FormData
  49     = FormData {
  50         -- | @'Nothing'@ for non-file values.
  51         fdFileName ∷ !(Maybe Text)
  52         -- | MIME Type of this value, defaulted to \"text/plain\".
  53       , fdMIMEType ∷ !MIMEType
  54         -- | The form value.
  55       , fdContent  ∷ !(LS.ByteString)
  56       }
  57
  58 data Part
  59     = Part {
  60         ptContDispo ∷ !ContDispo
  61       , ptContType  ∷ !MIMEType
  62       , ptBody      ∷ !LS.ByteString
  63       }
  64
  65 data ContDispo
  66     = ContDispo {
  67         dType   ∷ !CIAscii
  68       , dParams ∷ !MIMEParams
  69       }
  70
  71 printContDispo ∷ ContDispo → Ascii
  72 printContDispo d
  73     = A.fromAsciiBuilder
  74       ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
  75         ⊕
  76         printMIMEParams (dParams d) )
  77
  78 -- |Parse \"multipart/form-data\" and return either @'Left' err@ or
  79 -- @'Right' result@. Note that there are currently the following
  80 -- limitations:
  81 --
  82 --   * Multiple files embedded as \"multipart/mixed\" within the
  83 --     \"multipart/form-data\" won't be decomposed.
  84 --
  85 --   * \"Content-Transfer-Encoding\" is always ignored.
  86 --
  87 --   * RFC 2388 (<http://tools.ietf.org/html/rfc2388#section-3>) says
  88 --   that non-ASCII field names are encoded according to the method in
  89 --   RFC 2047 (<http://tools.ietf.org/html/rfc2047>), but they won't
  90 --   be decoded.
  91 parseMultipartFormData ∷ Ascii -- ^boundary
  92                        → LS.ByteString -- ^input
  93                        → Either String [(Ascii, FormData)]
  94 parseMultipartFormData boundary = (mapM partToFormPair =≪) ∘ go
  95     where
  96       go ∷ (Functor m, MonadError String m)
  97          ⇒ LS.ByteString
  98          → m [Part]
  99       {-# INLINEABLE go #-}
 100       go src
 101           = case LP.parse (prologue boundary) src of
 102               LP.Done src' _
 103                   → go' src' (∅)
 104               LP.Fail _ eCtx e
 105                   → throwError $ "Unparsable multipart/form-data: "
 106                                ⧺ intercalate ", " eCtx
 107                                ⧺ ": "
 108                                ⧺ e
 109       go' ∷ (Functor m, MonadError String m)
 110           ⇒ LS.ByteString
 111           → Seq Part
 112           → m [Part]
 113       {-# INLINEABLE go' #-}
 114       go' src xs
 115           = case LP.parse epilogue src of
 116               LP.Done _ _
 117                   → return $ toList xs
 118               LP.Fail _ _ _
 119                   → do (src', x) ← parsePart boundary src
 120                        go' src' $ xs ⊳ x
 121
 122 prologue ∷ Ascii → Parser ()
 123 prologue boundary
 124     = ( (string "--" <?> "prefix")
 125         *>
 126         (string (A.toByteString boundary) <?> "boundary")
 127         *>
 128         pure ()
 129       )
 130       <?>
 131       "prologue"
 132
 133 epilogue ∷ Parser ()
 134 epilogue = finishOff ((string "--" <?> "suffix") *> crlf)
 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 (finishOff contentDisposition) $ A.toByteString str of
 171                  Right  d → return d
 172                  Left err → throwError $ "malformed Content-Disposition: "
 173                                        ⧺ A.toString str
 174                                        ⧺ ": "
 175                                        ⧺ err
 176
 177 contentDisposition ∷ Parser ContDispo
 178 contentDisposition
 179     = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams)
 180       <?>
 181       "contentDisposition"
 182
 183 getContType ∷ MonadError String m ⇒ Headers → m (Maybe MIMEType)
 184 {-# INLINEABLE getContType #-}
 185 getContType hdrs
 186     = case getHeader "Content-Type" hdrs of
 187         Nothing
 188             → return Nothing
 189         Just str
 190             → case parseOnly (finishOff mimeType) $ A.toByteString str of
 191                  Right  d → return $ Just d
 192                  Left err → throwError $ "malformed Content-Type: "
 193                                        ⧺ A.toString str
 194                                        ⧺ ": "
 195                                        ⧺ err
 196
 197 getBody ∷ MonadError String m
 198         ⇒ Ascii
 199         → LS.ByteString
 200         → m (LS.ByteString, LS.ByteString)
 201 {-# INLINEABLE getBody #-}
 202 getBody (("\r\n--" ⊕) ∘ A.toByteString → boundary) src
 203     = case breakOn boundary src of
 204         (before, after)
 205             | LS.null after
 206                 → throwError "missing boundary"
 207             | otherwise
 208                 → let len    = fromIntegral $ BS.length boundary
 209                       after' = LS.drop len after
 210                   in
 211                     return (before, after')
 212
 213 partToFormPair ∷ MonadError String m ⇒ Part → m (Ascii, FormData)
 214 {-# INLINEABLE partToFormPair #-}
 215 partToFormPair pt@(Part {..})
 216     | dType ptContDispo ≡ "form-data"
 217         = do name ← partName pt
 218              let fd = FormData {
 219                         fdFileName = partFileName pt
 220                       , fdMIMEType = ptContType
 221                       , fdContent  = ptBody
 222                       }
 223              return (name, fd)
 224     | otherwise
 225         = throwError $ "disposition type is not \"form-data\": "
 226                      ⧺ A.toString (A.fromCIAscii $ dType ptContDispo)
 227
 228 partName ∷ MonadError String m ⇒ Part → m Ascii
 229 {-# INLINEABLE partName #-}
 230 partName (Part {..})
 231     = case M.lookup "name" params of
 232         Just name
 233             → case A.fromText name of
 234                  Just a  → return a
 235                  Nothing → throwError $ "Non-ascii part name: "
 236                                       ⧺ T.unpack name
 237         Nothing
 238             → throwError $ "form-data without name: "
 239                          ⧺ A.toString (printContDispo ptContDispo)
 240     where
 241       params = case dParams ptContDispo of
 242                  MIMEParams m → m
 243
 244 partFileName ∷ Part → Maybe Text
 245 partFileName (dParams ∘ ptContDispo → MIMEParams m)
 246     = M.lookup "filename" m