Network/HTTP/Lucu/MultipartForm.hs

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