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.List (intercalate)
  37 import Data.Maybe
  38 import Data.Monoid.Unicode
  39 import Data.Sequence (Seq)
  40 import Data.Text (Text)
  41 import Network.HTTP.Lucu.Headers
  42 import Network.HTTP.Lucu.MIMEParams
  43 import Network.HTTP.Lucu.MIMEType (MIMEType)
  44 import qualified Network.HTTP.Lucu.MIMEType as MT
  45 import Network.HTTP.Lucu.MIMEType.TH
  46 import Network.HTTP.Lucu.Parser
  47 import Network.HTTP.Lucu.Parser.Http
  48 import Network.HTTP.Lucu.Utils
  49 import Prelude hiding (lookup, mapM)
  50 import Prelude.Unicode
  51
  52 -- |'FormData' represents a form value and possibly an uploaded file
  53 -- name.
  54 data FormData
  55     = FormData {
  56         -- | @'Nothing'@ for non-file values.
  57         fdFileName ∷ !(Maybe Text)
  58         -- | MIME Type of this value, defaulted to \"text/plain\".
  59       , fdMIMEType ∷ !MIMEType
  60         -- | The form value.
  61       , fdContent  ∷ !(LS.ByteString)
  62       }
  63
  64 data Part
  65     = Part {
  66         ptContDispo ∷ !ContDispo
  67       , ptContType  ∷ !MIMEType
  68       , ptBody      ∷ !LS.ByteString
  69       }
  70
  71 data ContDispo
  72     = ContDispo {
  73         dType   ∷ !CIAscii
  74       , dParams ∷ !MIMEParams
  75       }
  76
  77 instance ConvertSuccess ContDispo Ascii where
  78     {-# INLINE convertSuccess #-}
  79     convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
  80
  81 instance ConvertSuccess ContDispo AsciiBuilder where
  82     {-# INLINE convertSuccess #-}
  83     convertSuccess (ContDispo {..})
  84         = cs dType ⊕ cs dParams
  85
  86 deriveAttempts [ ([t| ContDispo |], [t| Ascii        |])
  87                , ([t| ContDispo |], [t| AsciiBuilder |])
  88                ]
  89
  90 -- |Parse \"multipart/form-data\" and return either @'Left' err@ or
  91 -- @'Right' result@. Note that there are currently the following
  92 -- limitations:
  93 --
  94 --   * Multiple files embedded as \"multipart/mixed\" within the
  95 --     \"multipart/form-data\" won't be decomposed.
  96 --
  97 --   * \"Content-Transfer-Encoding\" is always ignored.
  98 --
  99 --   * RFC 2388 (<http://tools.ietf.org/html/rfc2388#section-3>) says
 100 --   that non-ASCII field names are encoded according to the method in
 101 --   RFC 2047 (<http://tools.ietf.org/html/rfc2047>), but they won't
 102 --   be decoded.
 103 parseMultipartFormData ∷ Ascii -- ^boundary
 104                        → LS.ByteString -- ^input
 105                        → Either String [(Ascii, FormData)]
 106 parseMultipartFormData boundary = (mapM partToFormPair =≪) ∘ go
 107     where
 108       go ∷ (Functor m, MonadError String m)
 109          ⇒ LS.ByteString
 110          → m [Part]
 111       {-# INLINEABLE go #-}
 112       go src
 113           = case LP.parse (prologue boundary) src of
 114               LP.Done src' _
 115                   → go' src' (∅)
 116               LP.Fail _ eCtx e
 117                   → throwError $ "Unparsable multipart/form-data: "
 118                                ⧺ intercalate ", " eCtx
 119                                ⧺ ": "
 120                                ⧺ e
 121       go' ∷ (Functor m, MonadError String m)
 122           ⇒ LS.ByteString
 123           → Seq Part
 124           → m [Part]
 125       {-# INLINEABLE go' #-}
 126       go' src xs
 127           = case LP.parse epilogue src of
 128               LP.Done _ _
 129                   → return $ toList xs
 130               LP.Fail _ _ _
 131                   → do (src', x) ← parsePart boundary src
 132                        go' src' $ xs ⊳ x
 133
 134 prologue ∷ Ascii → Parser ()
 135 prologue boundary
 136     = ( (string "--" <?> "prefix")
 137         *>
 138         (string (cs boundary) <?> "boundary")
 139         *>
 140         pure ()
 141       )
 142       <?>
 143       "prologue"
 144
 145 epilogue ∷ Parser ()
 146 epilogue = finishOff ((string "--" <?> "suffix") *> crlf)
 147            <?>
 148            "epilogue"
 149
 150 parsePart ∷ (Functor m, MonadError String m)
 151           ⇒ Ascii
 152           → LS.ByteString
 153           → m (LS.ByteString, Part)
 154 {-# INLINEABLE parsePart #-}
 155 parsePart boundary src
 156     = case LP.parse partHeader src of
 157         LP.Done src' hdrs
 158             → do dispo ← getContDispo hdrs
 159                  cType ← fromMaybe defaultCType <$> getContType hdrs
 160                  (body, src'')
 161                        ← getBody boundary src'
 162                  return (src'', Part dispo cType body)
 163         LP.Fail _ eCtx e
 164             → throwError $ "unparsable part: "
 165                          ⧺ intercalate ", " eCtx
 166                          ⧺ ": "
 167                          ⧺ e
 168       where
 169         defaultCType ∷ MIMEType
 170         defaultCType = [mimeType| text/plain |]
 171
 172 partHeader ∷ Parser Headers
 173 partHeader = crlf *> headers
 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 contentDisposition
 191     = (ContDispo <$> (cs <$> token) ⊛ mimeParams)
 192       <?>
 193       "contentDisposition"
 194
 195 getContType ∷ MonadError String m ⇒ Headers → m (Maybe MIMEType)
 196 {-# INLINEABLE getContType #-}
 197 getContType hdrs
 198     = case getHeader "Content-Type" hdrs of
 199         Nothing
 200             → return Nothing
 201         Just str
 202             → case parseOnly (finishOff MT.mimeType) $ cs str of
 203                  Right  d → return $ Just d
 204                  Left err → throwError $ "malformed Content-Type: "
 205                                        ⊕ cs str
 206                                        ⊕ ": "
 207                                        ⊕ err
 208
 209 getBody ∷ MonadError String m
 210         ⇒ Ascii
 211         → LS.ByteString
 212         → m (LS.ByteString, LS.ByteString)
 213 {-# INLINEABLE getBody #-}
 214 getBody (("\r\n--" ⊕) ∘ cs → boundary) src
 215     = case breakOn boundary src of
 216         (before, after)
 217             | LS.null after
 218                 → throwError "missing boundary"
 219             | otherwise
 220                 → let len    = fromIntegral $ BS.length boundary
 221                       after' = LS.drop len after
 222                   in
 223                     return (before, after')
 224
 225 partToFormPair ∷ MonadError String m ⇒ Part → m (Ascii, FormData)
 226 {-# INLINEABLE partToFormPair #-}
 227 partToFormPair pt@(Part {..})
 228     | dType ptContDispo ≡ "form-data"
 229         = do name ← partName pt
 230              let fd = FormData {
 231                         fdFileName = partFileName pt
 232                       , fdMIMEType = ptContType
 233                       , fdContent  = ptBody
 234                       }
 235              return (name, fd)
 236     | otherwise
 237         = throwError $ "disposition type is not \"form-data\": "
 238                      ⊕ cs (dType ptContDispo)
 239
 240 partName ∷ MonadError String m ⇒ Part → m Ascii
 241 {-# INLINEABLE partName #-}
 242 partName (Part {..})
 243     = case lookup "name" $ dParams ptContDispo of
 244         Just name
 245             → case ca name of
 246                  Success a → return a
 247                  Failure e → throwError $ show e
 248         Nothing
 249             → throwError $ "form-data without name: "
 250                          ⊕ convertSuccessVia ((⊥) ∷ Ascii) ptContDispo
 251
 252 partFileName ∷ Part → Maybe Text
 253 partFileName (ptContDispo → ContDispo {..})
 254     = lookup "filename" dParams