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 Data.Attoparsec.Parsable
  30 import qualified Data.ByteString as BS
  31 import qualified Data.ByteString.Lazy as LS
  32 import Data.ByteString.Lazy.Search
  33 import Data.Collections
  34 import Data.Convertible.Base
  35 import Data.Convertible.Instances.Ascii ()
  36 import Data.Convertible.Utils
  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 partHeader = crlf *> parser
 173
 174 getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
 175 {-# INLINEABLE getContDispo #-}
 176 getContDispo hdrs
 177     = case getHeader "Content-Disposition" hdrs of
 178         Nothing
 179             → throwError "Content-Disposition is missing"
 180         Just str
 181             → case parseOnly (finishOff contentDisposition) $ cs str of
 182                  Right  d → return d
 183                  Left err → throwError $ "malformed Content-Disposition: "
 184                                        ⊕ cs str
 185                                        ⊕ ": "
 186                                        ⊕ err
 187
 188 contentDisposition ∷ Parser ContDispo
 189 contentDisposition
 190     = (ContDispo <$> (cs <$> token) ⊛ parser)
 191       <?>
 192       "contentDisposition"
 193
 194 getContType ∷ MonadError String m ⇒ Headers → m (Maybe MIMEType)
 195 {-# INLINEABLE getContType #-}
 196 getContType hdrs
 197     = case getHeader "Content-Type" hdrs of
 198         Nothing
 199             → return Nothing
 200         Just str
 201             → case parseOnly (finishOff parser) $ cs str of
 202                  Right  d → return $ Just d
 203                  Left err → throwError $ "malformed Content-Type: "
 204                                        ⊕ cs str
 205                                        ⊕ ": "
 206                                        ⊕ err
 207
 208 getBody ∷ MonadError String m
 209         ⇒ Ascii
 210         → LS.ByteString
 211         → m (LS.ByteString, LS.ByteString)
 212 {-# INLINEABLE getBody #-}
 213 getBody (("\r\n--" ⊕) ∘ cs → boundary) src
 214     = case breakOn boundary src of
 215         (before, after)
 216             | LS.null after
 217                 → throwError "missing boundary"
 218             | otherwise
 219                 → let len    = fromIntegral $ BS.length boundary
 220                       after' = LS.drop len after
 221                   in
 222                     return (before, after')
 223
 224 partToFormPair ∷ MonadError String m ⇒ Part → m (Ascii, FormData)
 225 {-# INLINEABLE partToFormPair #-}
 226 partToFormPair pt@(Part {..})
 227     | dType ptContDispo ≡ "form-data"
 228         = do name ← partName pt
 229              let fd = FormData {
 230                         fdFileName = partFileName pt
 231                       , fdMIMEType = ptContType
 232                       , fdContent  = ptBody
 233                       }
 234              return (name, fd)
 235     | otherwise
 236         = throwError $ "disposition type is not \"form-data\": "
 237                      ⊕ cs (dType ptContDispo)
 238
 239 partName ∷ MonadError String m ⇒ Part → m Ascii
 240 {-# INLINEABLE partName #-}
 241 partName (Part {..})
 242     = case lookup "name" $ dParams ptContDispo of
 243         Just name
 244             → case ca name of
 245                  Success a → return a
 246                  Failure e → throwError $ show e
 247         Nothing
 248             → throwError $ "form-data without name: "
 249                          ⊕ convertSuccessVia ((⊥) ∷ Ascii) ptContDispo
 250
 251 partFileName ∷ Part → Maybe Text
 252 partFileName (ptContDispo → ContDispo {..})
 253     = lookup "filename" dParams