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     = try $
  66       do parts ← many (partP boundary)
  67          _     ← string "--"
  68          _     ← string $ A.toByteString boundary
  69          _     ← string "--"
  70          crlf
  71          catMaybes <$> mapM partToFormPair parts
  72
  73 partP ∷ Ascii → Parser Part
  74 partP boundary
  75     = try $
  76       do _    ← string "--"
  77          _    ← string $ A.toByteString boundary
  78          crlf
  79          hs   ← headersP
  80          d    ← getContDispo hs
  81          body ← bodyP boundary
  82          return $ Part hs d body
  83
  84 bodyP ∷ Ascii → Parser LS.ByteString
  85 bodyP boundary
  86     = try $
  87       do body ← manyCharsTill anyChar $
  88                     try $
  89                     do crlf
  90                        _ ← string "--"
  91                        _ ← string $ A.toByteString boundary
  92                        return ()
  93          crlf
  94          return body
  95
  96 partToFormPair ∷ Monad m ⇒ Part → m (Maybe (Text, FormData))
  97 {-# INLINEABLE partToFormPair #-}
  98 partToFormPair pt
  99     | dType (ptContDispo pt) ≡ "form-data"
 100         = do name  ← partName pt
 101              let fname = partFileName pt
 102              let fd    = FormData {
 103                            fdFileName = fname
 104                          , fdContent  = ptBody pt
 105                          }
 106              return $ Just (name, fd)
 107     | otherwise
 108         = return Nothing
 109
 110 partName ∷ Monad m ⇒ Part → m Text
 111 {-# INLINEABLE partName #-}
 112 partName pt
 113     = case find ((≡ "name") ∘ fst) $ dParams $ ptContDispo pt of
 114         Just (_, name)
 115             → return name
 116         Nothing
 117             → fail ("form-data without name: " ⧺
 118                     A.toString (printContDispo $ ptContDispo pt))
 119
 120 partFileName ∷ Part → Maybe Text
 121 {-# INLINEABLE partFileName #-}
 122 partFileName pt
 123     = snd <$> (find ((== "filename") ∘ fst) $ dParams $ ptContDispo pt)
 124
 125 getContDispo ∷ Monad m ⇒ Headers → m ContDispo
 126 {-# INLINEABLE getContDispo #-}
 127 getContDispo hdr
 128     = case getHeader "Content-Disposition" hdr of
 129         Nothing
 130             → fail ("There is a part without Content-Disposition in the multipart/form-data.")
 131         Just str
 132             → let p  = do d ← contDispoP
 133                           endOfInput
 134                           return d
 135                   bs = A.toByteString str
 136               in
 137                 case parseOnly p bs of
 138                   Right  d → return d
 139                   Left err → fail (concat [ "Unparsable Content-Disposition: "
 140                                           , BS.unpack bs
 141                                           , ": "
 142                                           , err
 143                                           ])
 144
 145 contDispoP ∷ Parser ContDispo
 146 contDispoP = try $
 147              do dispoType ← A.toCIAscii <$> token
 148                 params    ← many paramP
 149                 return $ ContDispo dispoType params
 150     where
 151       paramP ∷ Parser (CIAscii, Ascii)
 152       paramP = do skipMany lws
 153                   _     ← char ';'
 154                   skipMany lws
 155                   name  ← A.toCIAscii <$> token
 156                   _     ← char '='
 157                   value ← token <|> quotedStr
 158                   return (name, value)