Network/HTTP/Lucu/MultipartForm.hs

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