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 Control.Monad
  15 import Data.Ascii (Ascii, CIAscii)
  16 import qualified Data.Ascii as A
  17 import Data.Attoparsec
  18 import qualified Data.ByteString.Char8 as BS
  19 import qualified Data.ByteString.Lazy.Char8 as LS
  20 import Data.Map (Map)
  21 import qualified Data.Map as M
  22 import Data.Maybe
  23 import Data.Monoid.Unicode
  24 import Data.Text (Text)
  25 import Network.HTTP.Lucu.Headers
  26 import Network.HTTP.Lucu.Parser
  27 import Network.HTTP.Lucu.Parser.Http
  28 import Network.HTTP.Lucu.RFC2231
  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 void boundaryP
  66          parts ← many $ partP boundaryP
  67          void (string "--" <?> "suffix")
  68          crlf
  69          catMaybes <$> mapM partToFormPair parts
  70       <?>
  71       "multipartFormP"
  72     where
  73       boundaryP ∷ Parser BS.ByteString
  74       boundaryP = string ("--" ⊕ A.toByteString boundary)
  75                   <?>
  76                   "boundaryP"
  77
  78 partP ∷ Parser α → Parser Part
  79 partP boundaryP
  80     = do crlf
  81          hs   ← headersP
  82          d    ← getContDispo hs
  83          body ← bodyP boundaryP
  84          return $ Part hs d body
  85       <?>
  86       "partP"
  87
  88 bodyP ∷ Parser α → Parser LS.ByteString
  89 bodyP boundaryP
  90     = manyOctetsTill anyWord8 (try $ crlf *> boundaryP)
  91       <?>
  92       "bodyP"
  93
  94 partToFormPair ∷ Monad m ⇒ Part → m (Maybe (Text, FormData))
  95 {-# INLINEABLE partToFormPair #-}
  96 partToFormPair pt
  97     | dType (ptContDispo pt) ≡ "form-data"
  98         = do name ← partName pt
  99              let fname = partFileName pt
 100              let fd    = FormData {
 101                            fdFileName = fname
 102                          , fdContent  = ptBody pt
 103                          }
 104              return $ Just (name, fd)
 105     | otherwise
 106         = return Nothing
 107
 108 partName ∷ Monad m ⇒ Part → m Text
 109 {-# INLINEABLE partName #-}
 110 partName (Part {..})
 111     = case M.lookup "name" $ dParams ptContDispo of
 112         Just name
 113             → return name
 114         Nothing
 115             → fail ("form-data without name: " ⧺
 116                     A.toString (printContDispo ptContDispo))
 117
 118 partFileName ∷ Part → Maybe Text
 119 {-# INLINEABLE partFileName #-}
 120 partFileName (Part {..})
 121     = M.lookup "filename" $ dParams ptContDispo
 122
 123 getContDispo ∷ Monad m ⇒ Headers → m ContDispo
 124 {-# INLINEABLE getContDispo #-}
 125 getContDispo hdr
 126     = case getHeader "Content-Disposition" hdr of
 127         Nothing
 128             → fail "There is a part without Content-Disposition in the multipart/form-data."
 129         Just str
 130             → let p  = do d ← contDispoP
 131                           endOfInput
 132                           return d
 133                   bs = A.toByteString str
 134               in
 135                 case parseOnly p bs of
 136                   Right  d → return d
 137                   Left err → fail (concat [ "Unparsable Content-Disposition: "
 138                                           , BS.unpack bs
 139                                           , ": "
 140                                           , err
 141                                           ])
 142
 143 contDispoP ∷ Parser ContDispo
 144 {-# INLINEABLE contDispoP #-}
 145 contDispoP
 146     = do dispoType ← A.toCIAscii <$> token
 147          params    ← paramsP
 148          return $ ContDispo dispoType params
 149       <?>
 150       "contDispoP"