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         -- | @'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 ∷ !(Map CIAscii Text)
  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 says that non-ASCII field names are encoded according
  88 --     to the method in RFC 2047
  89 --     <http://www.faqs.org/rfcs/rfc2047.html>, but they won't be
  90 --     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 = ( (string "--" <?> "suffix")
 135              *>
 136              crlf
 137              *>
 138              endOfInput
 139            )
 140            <?>
 141            "epilogue"
 142
 143 parsePart ∷ (Functor m, MonadError String m)
 144           ⇒ Ascii
 145           → LS.ByteString
 146           → m (LS.ByteString, Part)
 147 {-# INLINEABLE parsePart #-}
 148 parsePart boundary src
 149     = case LP.parse partHeader src of
 150         LP.Done src' hdrs
 151             → do dispo ← getContDispo hdrs
 152                  cType ← fromMaybe defaultCType <$> getContType hdrs
 153                  (body, src'')
 154                        ← getBody boundary src'
 155                  return (src'', Part dispo cType body)
 156         LP.Fail _ eCtx e
 157             → throwError $ "unparsable part: "
 158                          ⧺ intercalate ", " eCtx
 159                          ⧺ ": "
 160                          ⧺ e
 161       where
 162         defaultCType ∷ MIMEType
 163         defaultCType = parseMIMEType "text/plain"
 164
 165 partHeader ∷ Parser Headers
 166 partHeader = crlf *> headers
 167
 168 getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
 169 {-# INLINEABLE getContDispo #-}
 170 getContDispo hdrs
 171     = case getHeader "Content-Disposition" hdrs of
 172         Nothing
 173             → throwError "Content-Disposition is missing"
 174         Just str
 175             → case parseOnly p $ A.toByteString str of
 176                  Right  d → return d
 177                  Left err → throwError $ "malformed Content-Disposition: "
 178                                        ⧺ A.toString str
 179                                        ⧺ ": "
 180                                        ⧺ err
 181     where
 182       p = do dispo ← contentDisposition
 183              endOfInput
 184              return dispo
 185
 186 contentDisposition ∷ Parser ContDispo
 187 contentDisposition
 188     = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams)
 189       <?>
 190       "contentDisposition"
 191
 192 getContType ∷ MonadError String m ⇒ Headers → m (Maybe MIMEType)
 193 {-# INLINEABLE getContType #-}
 194 getContType hdrs
 195     = case getHeader "Content-Type" hdrs of
 196         Nothing
 197             → return Nothing
 198         Just str
 199             → case parseOnly p $ A.toByteString str of
 200                  Right  d → return $ Just d
 201                  Left err → throwError $ "malformed Content-Type: "
 202                                        ⧺ A.toString str
 203                                        ⧺ ": "
 204                                        ⧺ err
 205     where
 206       p = do t ← mimeType
 207              endOfInput
 208              return t
 209
 210 getBody ∷ MonadError String m
 211         ⇒ Ascii
 212         → LS.ByteString
 213         → m (LS.ByteString, LS.ByteString)
 214 {-# INLINEABLE getBody #-}
 215 getBody (("\r\n--" ⊕) ∘ A.toByteString → boundary) src
 216     = case breakOn boundary src of
 217         (before, after)
 218             | LS.null after
 219                 → throwError "missing boundary"
 220             | otherwise
 221                 → let len    = fromIntegral $ BS.length boundary
 222                       after' = LS.drop len after
 223                   in
 224                     return (before, after')
 225
 226 partToFormPair ∷ MonadError String m ⇒ Part → m (Ascii, FormData)
 227 {-# INLINEABLE partToFormPair #-}
 228 partToFormPair pt@(Part {..})
 229     | dType ptContDispo ≡ "form-data"
 230         = do name ← partName pt
 231              let fd = FormData {
 232                         fdFileName = partFileName pt
 233                       , fdMIMEType = ptContType
 234                       , fdContent  = ptBody
 235                       }
 236              return (name, fd)
 237     | otherwise
 238         = throwError $ "disposition type is not \"form-data\": "
 239                      ⧺ A.toString (A.fromCIAscii $ dType ptContDispo)
 240
 241 partName ∷ MonadError String m ⇒ Part → m Ascii
 242 {-# INLINEABLE partName #-}
 243 partName (Part {..})
 244     = case M.lookup "name" $ dParams ptContDispo of
 245         Just name
 246             → case A.fromText name of
 247                  Just a  → return a
 248                  Nothing → throwError $ "Non-ascii part name: "
 249                                       ⧺ T.unpack name
 250         Nothing
 251             → throwError $ "form-data without name: "
 252                          ⧺ A.toString (printContDispo ptContDispo)
 253
 254 partFileName ∷ Part → Maybe Text
 255 partFileName (Part {..})
 256     = M.lookup "filename" $ dParams ptContDispo