8 module Network.HTTP.Lucu.MultipartForm
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
20 import qualified Data.Map as M
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
29 -- |This data type represents a form value and possibly an uploaded
33 fdFileName ∷ Maybe Text
34 , fdContent ∷ LS.ByteString
40 , ptContDispo ∷ ContDispo
41 , ptBody ∷ LS.ByteString
44 instance HasHeaders Part where
45 getHeaders = ptHeaders
46 setHeaders pt hs = pt { ptHeaders = hs }
51 , dParams ∷ !(Map CIAscii Text)
54 printContDispo ∷ ContDispo → Ascii
57 ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
59 printParams (dParams d) )
61 multipartFormP ∷ Ascii → Parser [(Text, FormData)]
62 multipartFormP boundary
63 = do parts ← many $ try $ partP boundary
65 _ ← string $ A.toByteString boundary
68 catMaybes <$> mapM partToFormPair parts
70 partP ∷ Ascii → Parser Part
73 _ ← string $ A.toByteString boundary
78 return $ Part hs d body
80 bodyP ∷ Ascii → Parser LS.ByteString
82 = do body ← manyCharsTill anyChar $
86 _ ← string $ A.toByteString boundary
91 partToFormPair ∷ Monad m ⇒ Part → m (Maybe (Text, FormData))
92 {-# INLINEABLE partToFormPair #-}
94 | dType (ptContDispo pt) ≡ "form-data"
95 = do name ← partName pt
96 let fname = partFileName pt
99 , fdContent = ptBody pt
101 return $ Just (name, fd)
105 partName ∷ Monad m ⇒ Part → m Text
106 {-# INLINEABLE partName #-}
108 = case M.lookup "name" $ dParams ptContDispo of
112 → fail ("form-data without name: " ⧺
113 A.toString (printContDispo ptContDispo))
115 partFileName ∷ Part → Maybe Text
116 {-# INLINEABLE partFileName #-}
117 partFileName (Part {..})
118 = M.lookup "filename" $ dParams ptContDispo
120 getContDispo ∷ Monad m ⇒ Headers → m ContDispo
121 {-# INLINEABLE getContDispo #-}
123 = case getHeader "Content-Disposition" hdr of
125 → fail "There is a part without Content-Disposition in the multipart/form-data."
127 → let p = do d ← contDispoP
130 bs = A.toByteString str
132 case parseOnly p bs of
134 Left err → fail (concat [ "Unparsable Content-Disposition: "
140 contDispoP ∷ Parser ContDispo
141 contDispoP = do dispoType ← A.toCIAscii <$> token
143 return $ ContDispo dispoType params