8 module Network.HTTP.Lucu.MultipartForm
13 import Control.Applicative hiding (many)
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
21 import qualified Data.Map as M
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
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
59 ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
61 printParams (dParams d) )
63 multipartFormP ∷ Ascii → Parser [(Text, FormData)]
64 multipartFormP boundary
66 parts ← many $ partP boundaryP
67 void (string "--" <?> "suffix")
69 catMaybes <$> mapM partToFormPair parts
73 boundaryP ∷ Parser BS.ByteString
74 boundaryP = string ("--" ⊕ A.toByteString boundary)
78 partP ∷ Parser α → Parser Part
83 body ← bodyP boundaryP
84 return $ Part hs d body
88 bodyP ∷ Parser α → Parser LS.ByteString
90 = manyOctetsTill anyWord8 (try $ crlf *> boundaryP)
94 partToFormPair ∷ Monad m ⇒ Part → m (Maybe (Text, FormData))
95 {-# INLINEABLE partToFormPair #-}
97 | dType (ptContDispo pt) ≡ "form-data"
98 = do name ← partName pt
99 let fname = partFileName pt
102 , fdContent = ptBody pt
104 return $ Just (name, fd)
108 partName ∷ Monad m ⇒ Part → m Text
109 {-# INLINEABLE partName #-}
111 = case M.lookup "name" $ dParams ptContDispo of
115 → fail ("form-data without name: " ⧺
116 A.toString (printContDispo ptContDispo))
118 partFileName ∷ Part → Maybe Text
119 {-# INLINEABLE partFileName #-}
120 partFileName (Part {..})
121 = M.lookup "filename" $ dParams ptContDispo
123 getContDispo ∷ Monad m ⇒ Headers → m ContDispo
124 {-# INLINEABLE getContDispo #-}
126 = case getHeader "Content-Disposition" hdr of
128 → fail "There is a part without Content-Disposition in the multipart/form-data."
130 → let p = do d ← contDispoP
133 bs = A.toByteString str
135 case parseOnly p bs of
137 Left err → fail (concat [ "Unparsable Content-Disposition: "
143 contDispoP ∷ Parser ContDispo
144 {-# INLINEABLE contDispoP #-}
146 = do dispoType ← A.toCIAscii <$> token
148 return $ ContDispo dispoType params