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