Network/HTTP/Lucu/MultipartForm.hs

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