Network/HTTP/Lucu/MultipartForm.hs

   1 {-# LANGUAGE
   2     DoAndIfThenElse
   3   , OverloadedStrings
   4   , RecordWildCards
   5   , ScopedTypeVariables
   6   , UnicodeSyntax
   7   #-}
   8 module Network.HTTP.Lucu.MultipartForm
   9     ( FormData(..)
  10     , multipartFormP
  11     )
  12     where
  13 import Control.Applicative hiding (many)
  14 import Data.Ascii (Ascii, CIAscii)
  15 import qualified Data.Ascii as A
  16 import Data.Attoparsec.Char8
  17 import qualified Data.ByteString.Char8 as BS
  18 import qualified Data.ByteString.Lazy.Char8 as LS
  19 import Data.Map (Map)
  20 import qualified Data.Map as M
  21 import Data.Maybe
  22 import Data.Monoid.Unicode
  23 import Data.Text (Text)
  24 import Network.HTTP.Lucu.Headers
  25 import Network.HTTP.Lucu.Parser.Http
  26 import Network.HTTP.Lucu.RFC2231
  27 import Prelude.Unicode
  28
  29 -- |This data type represents a form value and possibly an uploaded
  30 -- file name.
  31 data FormData
  32     = FormData {
  33         fdFileName ∷ Maybe Text
  34       , fdContent  ∷ LS.ByteString
  35       }
  36
  37 data Part
  38     = Part {
  39         ptHeaders   ∷ Headers
  40       , ptContDispo ∷ ContDispo
  41       , ptBody      ∷ LS.ByteString
  42       }
  43
  44 instance HasHeaders Part where
  45     getHeaders = ptHeaders
  46     setHeaders pt hs = pt { ptHeaders = hs }
  47
  48 data ContDispo
  49     = ContDispo {
  50         dType   ∷ !CIAscii
  51       , dParams ∷ !(Map CIAscii Text)
  52       }
  53
  54 printContDispo ∷ ContDispo → Ascii
  55 printContDispo d
  56     = A.fromAsciiBuilder $
  57       ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
  58         ⊕
  59         printParams (dParams d) )
  60
  61 multipartFormP ∷ Ascii → Parser [(Text, FormData)]
  62 multipartFormP boundary
  63     = do parts ← many $ try $ partP boundary
  64          _     ← string "--"
  65          _     ← string $ A.toByteString boundary
  66          _     ← string "--"
  67          crlf
  68          catMaybes <$> mapM partToFormPair parts
  69
  70 partP ∷ Ascii → Parser Part
  71 partP boundary
  72     = do _    ← string "--"
  73          _    ← string $ A.toByteString boundary
  74          crlf
  75          hs   ← headersP
  76          d    ← getContDispo hs
  77          body ← bodyP boundary
  78          return $ Part hs d body
  79
  80 bodyP ∷ Ascii → Parser LS.ByteString
  81 bodyP boundary
  82     = do body ← manyCharsTill anyChar $
  83                     try $
  84                     do crlf
  85                        _ ← string "--"
  86                        _ ← string $ A.toByteString boundary
  87                        return ()
  88          crlf
  89          return body
  90
  91 partToFormPair ∷ Monad m ⇒ Part → m (Maybe (Text, FormData))
  92 {-# INLINEABLE partToFormPair #-}
  93 partToFormPair pt
  94     | dType (ptContDispo pt) ≡ "form-data"
  95         = do name  ← partName pt
  96              let fname = partFileName pt
  97              let fd    = FormData {
  98                            fdFileName = fname
  99                          , fdContent  = ptBody pt
 100                          }
 101              return $ Just (name, fd)
 102     | otherwise
 103         = return Nothing
 104
 105 partName ∷ Monad m ⇒ Part → m Text
 106 {-# INLINEABLE partName #-}
 107 partName (Part {..})
 108     = case M.lookup "name" $ dParams ptContDispo of
 109         Just name
 110             → return name
 111         Nothing
 112             → fail ("form-data without name: " ⧺
 113                     A.toString (printContDispo ptContDispo))
 114
 115 partFileName ∷ Part → Maybe Text
 116 {-# INLINEABLE partFileName #-}
 117 partFileName (Part {..})
 118     = M.lookup "filename" $ dParams ptContDispo
 119
 120 getContDispo ∷ Monad m ⇒ Headers → m ContDispo
 121 {-# INLINEABLE getContDispo #-}
 122 getContDispo hdr
 123     = case getHeader "Content-Disposition" hdr of
 124         Nothing
 125             → fail ("There is a part without Content-Disposition in the multipart/form-data.")
 126         Just str
 127             → let p  = do d ← contDispoP
 128                           endOfInput
 129                           return d
 130                   bs = A.toByteString str
 131               in
 132                 case parseOnly p bs of
 133                   Right  d → return d
 134                   Left err → fail (concat [ "Unparsable Content-Disposition: "
 135                                           , BS.unpack bs
 136                                           , ": "
 137                                           , err
 138                                           ])
 139
 140 contDispoP ∷ Parser ContDispo
 141 contDispoP = do dispoType ← A.toCIAscii <$> token
 142                 params    ← paramsP
 143                 return $ ContDispo dispoType params