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 qualified Data.Ascii as A
  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.List (intercalate)
  37 import Data.Maybe
  38 import Data.Monoid.Unicode
  39 import Data.Sequence (Seq)
  40 import Data.Text (Text)
  41 import qualified Data.Text as T
  42 import Network.HTTP.Lucu.Headers
  43 import Network.HTTP.Lucu.MIMEParams
  44 import Network.HTTP.Lucu.MIMEType (MIMEType)
  45 import qualified Network.HTTP.Lucu.MIMEType as MT
  46 import Network.HTTP.Lucu.MIMEType.TH
  47 import Network.HTTP.Lucu.Parser
  48 import Network.HTTP.Lucu.Parser.Http
  49 import Network.HTTP.Lucu.Utils
  50 import Prelude hiding (lookup, mapM)
  51 import Prelude.Unicode
  52
  53 -- |'FormData' represents a form value and possibly an uploaded file
  54 -- name.
  55 data FormData
  56     = FormData {
  57         -- | @'Nothing'@ for non-file values.
  58         fdFileName ∷ !(Maybe Text)
  59         -- | MIME Type of this value, defaulted to \"text/plain\".
  60       , fdMIMEType ∷ !MIMEType
  61         -- | The form value.
  62       , fdContent  ∷ !(LS.ByteString)
  63       }
  64
  65 data Part
  66     = Part {
  67         ptContDispo ∷ !ContDispo
  68       , ptContType  ∷ !MIMEType
  69       , ptBody      ∷ !LS.ByteString
  70       }
  71
  72 data ContDispo
  73     = ContDispo {
  74         dType   ∷ !CIAscii
  75       , dParams ∷ !MIMEParams
  76       }
  77
  78 instance ConvertSuccess ContDispo Ascii where
  79     {-# INLINE convertSuccess #-}
  80     convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
  81
  82 instance ConvertSuccess ContDispo AsciiBuilder where
  83     {-# INLINE convertSuccess #-}
  84     convertSuccess (ContDispo {..})
  85         = cs dType ⊕ cs dParams
  86
  87 deriveAttempts [ ([t| ContDispo |], [t| Ascii        |])
  88                , ([t| ContDispo |], [t| AsciiBuilder |])
  89                ]
  90
  91 -- |Parse \"multipart/form-data\" and return either @'Left' err@ or
  92 -- @'Right' result@. Note that there are currently the following
  93 -- limitations:
  94 --
  95 --   * Multiple files embedded as \"multipart/mixed\" within the
  96 --     \"multipart/form-data\" won't be decomposed.
  97 --
  98 --   * \"Content-Transfer-Encoding\" is always ignored.
  99 --
 100 --   * RFC 2388 (<http://tools.ietf.org/html/rfc2388#section-3>) says
 101 --   that non-ASCII field names are encoded according to the method in
 102 --   RFC 2047 (<http://tools.ietf.org/html/rfc2047>), but they won't
 103 --   be decoded.
 104 parseMultipartFormData ∷ Ascii -- ^boundary
 105                        → LS.ByteString -- ^input
 106                        → Either String [(Ascii, FormData)]
 107 parseMultipartFormData boundary = (mapM partToFormPair =≪) ∘ go
 108     where
 109       go ∷ (Functor m, MonadError String m)
 110          ⇒ LS.ByteString
 111          → m [Part]
 112       {-# INLINEABLE go #-}
 113       go src
 114           = case LP.parse (prologue boundary) src of
 115               LP.Done src' _
 116                   → go' src' (∅)
 117               LP.Fail _ eCtx e
 118                   → throwError $ "Unparsable multipart/form-data: "
 119                                ⧺ intercalate ", " eCtx
 120                                ⧺ ": "
 121                                ⧺ e
 122       go' ∷ (Functor m, MonadError String m)
 123           ⇒ LS.ByteString
 124           → Seq Part
 125           → m [Part]
 126       {-# INLINEABLE go' #-}
 127       go' src xs
 128           = case LP.parse epilogue src of
 129               LP.Done _ _
 130                   → return $ toList xs
 131               LP.Fail _ _ _
 132                   → do (src', x) ← parsePart boundary src
 133                        go' src' $ xs ⊳ x
 134
 135 prologue ∷ Ascii → Parser ()
 136 prologue boundary
 137     = ( (string "--" <?> "prefix")
 138         *>
 139         (string (A.toByteString boundary) <?> "boundary")
 140         *>
 141         pure ()
 142       )
 143       <?>
 144       "prologue"
 145
 146 epilogue ∷ Parser ()
 147 epilogue = finishOff ((string "--" <?> "suffix") *> crlf)
 148            <?>
 149            "epilogue"
 150
 151 parsePart ∷ (Functor m, MonadError String m)
 152           ⇒ Ascii
 153           → LS.ByteString
 154           → m (LS.ByteString, Part)
 155 {-# INLINEABLE parsePart #-}
 156 parsePart boundary src
 157     = case LP.parse partHeader src of
 158         LP.Done src' hdrs
 159             → do dispo ← getContDispo hdrs
 160                  cType ← fromMaybe defaultCType <$> getContType hdrs
 161                  (body, src'')
 162                        ← getBody boundary src'
 163                  return (src'', Part dispo cType body)
 164         LP.Fail _ eCtx e
 165             → throwError $ "unparsable part: "
 166                          ⧺ intercalate ", " eCtx
 167                          ⧺ ": "
 168                          ⧺ e
 169       where
 170         defaultCType ∷ MIMEType
 171         defaultCType = [mimeType| text/plain |]
 172
 173 partHeader ∷ Parser Headers
 174 partHeader = crlf *> headers
 175
 176 getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
 177 {-# INLINEABLE getContDispo #-}
 178 getContDispo hdrs
 179     = case getHeader "Content-Disposition" hdrs of
 180         Nothing
 181             → throwError "Content-Disposition is missing"
 182         Just str
 183             → case parseOnly (finishOff contentDisposition) $ A.toByteString str of
 184                  Right  d → return d
 185                  Left err → throwError $ "malformed Content-Disposition: "
 186                                        ⧺ A.toString str
 187                                        ⧺ ": "
 188                                        ⧺ err
 189
 190 contentDisposition ∷ Parser ContDispo
 191 contentDisposition
 192     = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams)
 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 MT.mimeType) $ A.toByteString str of
 204                  Right  d → return $ Just d
 205                  Left err → throwError $ "malformed Content-Type: "
 206                                        ⧺ A.toString 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--" ⊕) ∘ 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 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                          ⊕ convertSuccessVia ((⊥) ∷ Ascii) ptContDispo
 253
 254 partFileName ∷ Part → Maybe Text
 255 partFileName (ptContDispo → ContDispo {..})
 256     = lookup "filename" dParams