Network/HTTP/Lucu/MultipartForm.hs

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