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
65 = do parts ← many $ try $ partP boundary
67 _ ← string $ A.toByteString boundary
70 catMaybes <$> mapM partToFormPair parts
72 partP ∷ Ascii → Parser Part
75 _ ← string $ A.toByteString boundary
80 return $ Part hs d body
82 bodyP ∷ Ascii → Parser LS.ByteString
84 = do body ← manyCharsTill anyChar $
88 _ ← string $ A.toByteString boundary
93 partToFormPair ∷ Monad m ⇒ Part → m (Maybe (Text, FormData))
94 {-# INLINEABLE partToFormPair #-}
96 | dType (ptContDispo pt) ≡ "form-data"
97 = do name ← partName pt
98 let fname = partFileName pt
101 , fdContent = ptBody pt
103 return $ Just (name, fd)
107 partName ∷ Monad m ⇒ Part → m Text
108 {-# INLINEABLE partName #-}
110 = case find ((≡ "name") ∘ fst) $ dParams $ ptContDispo pt of
114 → fail ("form-data without name: " ⧺
115 A.toString (printContDispo $ ptContDispo pt))
117 partFileName ∷ Part → Maybe Text
118 {-# INLINEABLE partFileName #-}
120 = snd <$> (find ((== "filename") ∘ fst) $ dParams $ ptContDispo pt)
122 getContDispo ∷ Monad m ⇒ Headers → m ContDispo
123 {-# INLINEABLE getContDispo #-}
125 = case getHeader "Content-Disposition" hdr of
127 → fail ("There is a part without Content-Disposition in the multipart/form-data.")
129 → let p = do d ← contDispoP
132 bs = A.toByteString str
134 case parseOnly p bs of
136 Left err → fail (concat [ "Unparsable Content-Disposition: "
142 contDispoP ∷ Parser ContDispo
143 contDispoP = do dispoType ← A.toCIAscii <$> token
145 return $ ContDispo dispoType params
147 paramP ∷ Parser (CIAscii, Ascii)
148 paramP = do skipMany lws
151 name ← A.toCIAscii <$> token
153 value ← token <|> quotedStr