7 module Network.HTTP.Lucu.MultipartForm
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
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
31 -- |This data type represents a form value and possibly an uploaded
35 fdFileName ∷ Maybe Text
36 , fdContent ∷ LS.ByteString
42 , ptContDispo ∷ ContDispo
43 , ptBody ∷ LS.ByteString
46 instance HasHeaders Part where
47 getHeaders = ptHeaders
48 setHeaders pt hs = pt { ptHeaders = hs }
53 , dParams ∷ !(Map CIAscii Text)
56 printContDispo ∷ ContDispo → Ascii
58 = A.fromAsciiBuilder $
59 ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
61 printParams (dParams d) )
63 multipartFormP ∷ Ascii → Parser [(Text, FormData)]
64 multipartFormP boundary
66 do parts ← many (partP boundary)
68 _ ← string $ A.toByteString boundary
71 catMaybes <$> mapM partToFormPair parts
73 partP ∷ Ascii → Parser Part
77 _ ← string $ A.toByteString boundary
82 return $ Part hs d body
84 bodyP ∷ Ascii → Parser LS.ByteString
87 do body ← manyCharsTill anyChar $
91 _ ← string $ A.toByteString boundary
96 partToFormPair ∷ Monad m ⇒ Part → m (Maybe (Text, FormData))
97 {-# INLINEABLE partToFormPair #-}
99 | dType (ptContDispo pt) ≡ "form-data"
100 = do name ← partName pt
101 let fname = partFileName pt
104 , fdContent = ptBody pt
106 return $ Just (name, fd)
110 partName ∷ Monad m ⇒ Part → m Text
111 {-# INLINEABLE partName #-}
113 = case find ((≡ "name") ∘ fst) $ dParams $ ptContDispo pt of
117 → fail ("form-data without name: " ⧺
118 A.toString (printContDispo $ ptContDispo pt))
120 partFileName ∷ Part → Maybe Text
121 {-# INLINEABLE partFileName #-}
123 = snd <$> (find ((== "filename") ∘ fst) $ dParams $ ptContDispo pt)
125 getContDispo ∷ Monad m ⇒ Headers → m ContDispo
126 {-# INLINEABLE getContDispo #-}
128 = case getHeader "Content-Disposition" hdr of
130 → fail ("There is a part without Content-Disposition in the multipart/form-data.")
132 → let p = do d ← contDispoP
135 bs = A.toByteString str
137 case parseOnly p bs of
139 Left err → fail (concat [ "Unparsable Content-Disposition: "
145 contDispoP ∷ Parser ContDispo
147 do dispoType ← A.toCIAscii <$> token
149 return $ ContDispo dispoType params
151 paramP ∷ Parser (CIAscii, Ascii)
152 paramP = do skipMany lws
155 name ← A.toCIAscii <$> token
157 value ← token <|> quotedStr