1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
|
{-# LANGUAGE OverloadedStrings #-}
-- #hide
-----------------------------------------------------------------------------
-- |
-- Module : Network.CGI.Multipart
-- Copyright : (c) Peter Thiemann 2001,2002
-- (c) Bjorn Bringert 2005-2006
-- License : BSD-style
--
-- Maintainer : Anders Kaseorg <andersk@mit.edu>
-- Stability : experimental
-- Portability : non-portable
--
-- Parsing of the multipart format from RFC2046.
-- Partly based on code from WASHMail.
--
-----------------------------------------------------------------------------
module Network.Multipart
(
-- * Multi-part messages
MultiPart(..), BodyPart(..)
, parseMultipartBody, hGetMultipartBody
, showMultipartBody
-- * Headers
, Headers , HeaderName(..)
, ContentType(..), ContentTransferEncoding(..)
, ContentDisposition(..)
, parseContentType
, getContentType
, getContentTransferEncoding
, getContentDisposition
) where
import Control.Monad
import Data.List (intersperse)
import Data.Maybe
import System.IO (Handle)
import Network.Multipart.Header
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.ByteString.Lazy.Search (breakOn)
--
-- * Multi-part stuff.
--
data MultiPart = MultiPart [BodyPart]
deriving (Show, Eq, Ord)
data BodyPart = BodyPart Headers ByteString
deriving (Show, Eq, Ord)
-- | Read a multi-part message from a 'ByteString'.
parseMultipartBody :: String -- ^ Boundary
-> ByteString -> MultiPart
parseMultipartBody b =
MultiPart . mapMaybe parseBodyPart . splitParts (BS.pack b)
-- | Read a multi-part message from a 'Handle'.
-- Fails on parse errors.
hGetMultipartBody :: String -- ^ Boundary
-> Handle
-> IO MultiPart
hGetMultipartBody b = liftM (parseMultipartBody b) . BS.hGetContents
parseBodyPart :: ByteString -> Maybe BodyPart
parseBodyPart s = do
let (hdr,bdy) = splitAtEmptyLine s
hs <- parseM pHeaders "<input>" (BS.unpack hdr)
return $ BodyPart hs bdy
showMultipartBody :: String -> MultiPart -> ByteString
showMultipartBody b (MultiPart bs) =
unlinesCRLF $ foldr (\x xs -> d:showBodyPart x:xs) [c,BS.empty] bs
where d = BS.pack ("--" ++ b)
c = BS.pack ("--" ++ b ++ "--")
showBodyPart :: BodyPart -> ByteString
showBodyPart (BodyPart hs c) =
unlinesCRLF $ [BS.pack (n++": "++v) | (HeaderName n,v) <- hs] ++ [BS.empty,c]
--
-- * Splitting into multipart parts.
--
-- | Split a multipart message into the multipart parts.
splitParts :: ByteString -- ^ The boundary, without the initial dashes
-> ByteString
-> [ByteString]
splitParts b = spl . dropPreamble b
where
spl x = case splitAtBoundary b x of
Nothing -> []
Just (s1,d,s2) | isClose b d -> [s1]
| otherwise -> s1:spl s2
-- | Drop everything up to and including the first line starting
-- with the boundary.
dropPreamble :: ByteString -- ^ The boundary, without the initial dashes
-> ByteString
-> ByteString
dropPreamble b s = case splitAtBoundary b s of
Nothing -> BS.empty
Just (_,_,v) -> v
-- | Split a string at the first boundary line.
splitAtBoundary :: ByteString -- ^ The boundary, without the initial dashes
-> ByteString -- ^ String to split.
-> Maybe (ByteString,ByteString,ByteString)
-- ^ The part before the boundary, the boundary line,
-- and the part after the boundary line. The CRLF
-- before and the CRLF (if any) after the boundary line
-- are not included in any of the strings returned.
-- Returns 'Nothing' if there is no boundary.
splitAtBoundary b s =
let b' = BS.append "--" b
bcrlf = BS.append "\r\n" b'
-- check if we are at the beginning of a boundary, if so, we
-- won’t have a \r\n
prefix = if BS.isPrefixOf b' s then b'
else bcrlf
(before, t) = breakOn (BS.toStrict prefix) s
in case BS.stripPrefix prefix t of
Nothing -> Nothing
Just t' ->
let after = case BS.stripPrefix "\r\n" t' of
Nothing -> t'
Just t'' -> t''
in Just (before, prefix, after)
-- | Check whether a string for which 'isBoundary' returns true
-- has two dashes after the boudary string.
isClose :: ByteString -- ^ The boundary, without the initial dashes
-> ByteString
-> Bool
isClose b s = BS.isPrefixOf (BS.append "--" (BS.append b "--")) s
--
-- * RFC 2046 CRLF
--
crlf :: ByteString
crlf = BS.pack "\r\n"
unlinesCRLF :: [ByteString] -> ByteString
unlinesCRLF = BS.concat . intersperse crlf
-- | Split a string at the first empty line. The CRLF (if any) before the
-- empty line is included in the first result. The CRLF after the
-- empty line is not included in the result.
-- If there is no empty line, the entire input is returned
-- as the first result.
splitAtEmptyLine :: ByteString -> (ByteString, ByteString)
splitAtEmptyLine s =
let blank = "\r\n\r\n"
(before, after) = breakOn (BS.toStrict blank) s
in case BS.stripPrefix blank after of
Nothing -> (before, after)
Just after' -> (BS.append before "\r\n", after')
|
