{-# LANGUAGE OverloadedStrings #-}
module Network.Multipart
(
MultiPart(..), BodyPart(..)
, parseMultipartBody, hGetMultipartBody
, showMultipartBody
, 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)
data MultiPart = MultiPart [BodyPart]
deriving (Int -> MultiPart -> ShowS
[MultiPart] -> ShowS
MultiPart -> [Char]
(Int -> MultiPart -> ShowS)
-> (MultiPart -> [Char])
-> ([MultiPart] -> ShowS)
-> Show MultiPart
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MultiPart -> ShowS
showsPrec :: Int -> MultiPart -> ShowS
$cshow :: MultiPart -> [Char]
show :: MultiPart -> [Char]
$cshowList :: [MultiPart] -> ShowS
showList :: [MultiPart] -> ShowS
Show, MultiPart -> MultiPart -> Bool
(MultiPart -> MultiPart -> Bool)
-> (MultiPart -> MultiPart -> Bool) -> Eq MultiPart
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MultiPart -> MultiPart -> Bool
== :: MultiPart -> MultiPart -> Bool
$c/= :: MultiPart -> MultiPart -> Bool
/= :: MultiPart -> MultiPart -> Bool
Eq, Eq MultiPart
Eq MultiPart =>
(MultiPart -> MultiPart -> Ordering)
-> (MultiPart -> MultiPart -> Bool)
-> (MultiPart -> MultiPart -> Bool)
-> (MultiPart -> MultiPart -> Bool)
-> (MultiPart -> MultiPart -> Bool)
-> (MultiPart -> MultiPart -> MultiPart)
-> (MultiPart -> MultiPart -> MultiPart)
-> Ord MultiPart
MultiPart -> MultiPart -> Bool
MultiPart -> MultiPart -> Ordering
MultiPart -> MultiPart -> MultiPart
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: MultiPart -> MultiPart -> Ordering
compare :: MultiPart -> MultiPart -> Ordering
$c< :: MultiPart -> MultiPart -> Bool
< :: MultiPart -> MultiPart -> Bool
$c<= :: MultiPart -> MultiPart -> Bool
<= :: MultiPart -> MultiPart -> Bool
$c> :: MultiPart -> MultiPart -> Bool
> :: MultiPart -> MultiPart -> Bool
$c>= :: MultiPart -> MultiPart -> Bool
>= :: MultiPart -> MultiPart -> Bool
$cmax :: MultiPart -> MultiPart -> MultiPart
max :: MultiPart -> MultiPart -> MultiPart
$cmin :: MultiPart -> MultiPart -> MultiPart
min :: MultiPart -> MultiPart -> MultiPart
Ord)
data BodyPart = BodyPart Headers ByteString
deriving (Int -> BodyPart -> ShowS
[BodyPart] -> ShowS
BodyPart -> [Char]
(Int -> BodyPart -> ShowS)
-> (BodyPart -> [Char]) -> ([BodyPart] -> ShowS) -> Show BodyPart
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BodyPart -> ShowS
showsPrec :: Int -> BodyPart -> ShowS
$cshow :: BodyPart -> [Char]
show :: BodyPart -> [Char]
$cshowList :: [BodyPart] -> ShowS
showList :: [BodyPart] -> ShowS
Show, BodyPart -> BodyPart -> Bool
(BodyPart -> BodyPart -> Bool)
-> (BodyPart -> BodyPart -> Bool) -> Eq BodyPart
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BodyPart -> BodyPart -> Bool
== :: BodyPart -> BodyPart -> Bool
$c/= :: BodyPart -> BodyPart -> Bool
/= :: BodyPart -> BodyPart -> Bool
Eq, Eq BodyPart
Eq BodyPart =>
(BodyPart -> BodyPart -> Ordering)
-> (BodyPart -> BodyPart -> Bool)
-> (BodyPart -> BodyPart -> Bool)
-> (BodyPart -> BodyPart -> Bool)
-> (BodyPart -> BodyPart -> Bool)
-> (BodyPart -> BodyPart -> BodyPart)
-> (BodyPart -> BodyPart -> BodyPart)
-> Ord BodyPart
BodyPart -> BodyPart -> Bool
BodyPart -> BodyPart -> Ordering
BodyPart -> BodyPart -> BodyPart
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: BodyPart -> BodyPart -> Ordering
compare :: BodyPart -> BodyPart -> Ordering
$c< :: BodyPart -> BodyPart -> Bool
< :: BodyPart -> BodyPart -> Bool
$c<= :: BodyPart -> BodyPart -> Bool
<= :: BodyPart -> BodyPart -> Bool
$c> :: BodyPart -> BodyPart -> Bool
> :: BodyPart -> BodyPart -> Bool
$c>= :: BodyPart -> BodyPart -> Bool
>= :: BodyPart -> BodyPart -> Bool
$cmax :: BodyPart -> BodyPart -> BodyPart
max :: BodyPart -> BodyPart -> BodyPart
$cmin :: BodyPart -> BodyPart -> BodyPart
min :: BodyPart -> BodyPart -> BodyPart
Ord)
parseMultipartBody :: String
-> ByteString -> MultiPart
parseMultipartBody :: [Char] -> ByteString -> MultiPart
parseMultipartBody [Char]
b =
[BodyPart] -> MultiPart
MultiPart ([BodyPart] -> MultiPart)
-> (ByteString -> [BodyPart]) -> ByteString -> MultiPart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Maybe BodyPart) -> [ByteString] -> [BodyPart]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ByteString -> Maybe BodyPart
parseBodyPart ([ByteString] -> [BodyPart])
-> (ByteString -> [ByteString]) -> ByteString -> [BodyPart]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> [ByteString]
splitParts ([Char] -> ByteString
BS.pack [Char]
b)
hGetMultipartBody :: String
-> Handle
-> IO MultiPart
hGetMultipartBody :: [Char] -> Handle -> IO MultiPart
hGetMultipartBody [Char]
b = (ByteString -> MultiPart) -> IO ByteString -> IO MultiPart
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([Char] -> ByteString -> MultiPart
parseMultipartBody [Char]
b) (IO ByteString -> IO MultiPart)
-> (Handle -> IO ByteString) -> Handle -> IO MultiPart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO ByteString
BS.hGetContents
parseBodyPart :: ByteString -> Maybe BodyPart
parseBodyPart :: ByteString -> Maybe BodyPart
parseBodyPart ByteString
s = do
let (ByteString
hdr,ByteString
bdy) = ByteString -> (ByteString, ByteString)
splitAtEmptyLine ByteString
s
Headers
hs <- Parser Headers -> [Char] -> [Char] -> Maybe Headers
forall (m :: * -> *) a.
MonadFail m =>
Parser a -> [Char] -> [Char] -> m a
parseM Parser Headers
pHeaders [Char]
"<input>" (ByteString -> [Char]
BS.unpack ByteString
hdr)
BodyPart -> Maybe BodyPart
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (BodyPart -> Maybe BodyPart) -> BodyPart -> Maybe BodyPart
forall a b. (a -> b) -> a -> b
$ Headers -> ByteString -> BodyPart
BodyPart Headers
hs ByteString
bdy
showMultipartBody :: String -> MultiPart -> ByteString
showMultipartBody :: [Char] -> MultiPart -> ByteString
showMultipartBody [Char]
b (MultiPart [BodyPart]
bs) =
[ByteString] -> ByteString
unlinesCRLF ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (BodyPart -> [ByteString] -> [ByteString])
-> [ByteString] -> [BodyPart] -> [ByteString]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\BodyPart
x [ByteString]
xs -> ByteString
dByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:BodyPart -> ByteString
showBodyPart BodyPart
xByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
xs) [ByteString
c,ByteString
BS.empty] [BodyPart]
bs
where d :: ByteString
d = [Char] -> ByteString
BS.pack ([Char]
"--" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
b)
c :: ByteString
c = [Char] -> ByteString
BS.pack ([Char]
"--" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
b [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"--")
showBodyPart :: BodyPart -> ByteString
showBodyPart :: BodyPart -> ByteString
showBodyPart (BodyPart Headers
hs ByteString
c) =
[ByteString] -> ByteString
unlinesCRLF ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [[Char] -> ByteString
BS.pack ([Char]
n[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
": "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
v) | (HeaderName [Char]
n,[Char]
v) <- Headers
hs] [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
BS.empty,ByteString
c]
splitParts :: ByteString
-> ByteString
-> [ByteString]
splitParts :: ByteString -> ByteString -> [ByteString]
splitParts ByteString
b = ByteString -> [ByteString]
spl (ByteString -> [ByteString])
-> (ByteString -> ByteString) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
dropPreamble ByteString
b
where
spl :: ByteString -> [ByteString]
spl ByteString
x = case ByteString
-> ByteString -> Maybe (ByteString, ByteString, ByteString)
splitAtBoundary ByteString
b ByteString
x of
Maybe (ByteString, ByteString, ByteString)
Nothing -> []
Just (ByteString
s1,ByteString
d,ByteString
s2) | ByteString -> ByteString -> Bool
isClose ByteString
b ByteString
d -> [ByteString
s1]
| Bool
otherwise -> ByteString
s1ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:ByteString -> [ByteString]
spl ByteString
s2
dropPreamble :: ByteString
-> ByteString
-> ByteString
dropPreamble :: ByteString -> ByteString -> ByteString
dropPreamble ByteString
b ByteString
s = case ByteString
-> ByteString -> Maybe (ByteString, ByteString, ByteString)
splitAtBoundary ByteString
b ByteString
s of
Maybe (ByteString, ByteString, ByteString)
Nothing -> ByteString
BS.empty
Just (ByteString
_,ByteString
_,ByteString
v) -> ByteString
v
splitAtBoundary :: ByteString
-> ByteString
-> Maybe (ByteString,ByteString,ByteString)
splitAtBoundary :: ByteString
-> ByteString -> Maybe (ByteString, ByteString, ByteString)
splitAtBoundary ByteString
b ByteString
s =
let b' :: ByteString
b' = ByteString -> ByteString -> ByteString
BS.append ByteString
"--" ByteString
b
bcrlf :: ByteString
bcrlf = ByteString -> ByteString -> ByteString
BS.append ByteString
"\r\n" ByteString
b'
prefix :: ByteString
prefix = if ByteString -> ByteString -> Bool
BS.isPrefixOf ByteString
b' ByteString
s then ByteString
b'
else ByteString
bcrlf
(ByteString
before, ByteString
t) = ByteString -> ByteString -> (ByteString, ByteString)
breakOn (ByteString -> ByteString
BS.toStrict ByteString
prefix) ByteString
s
in case ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
prefix ByteString
t of
Maybe ByteString
Nothing -> Maybe (ByteString, ByteString, ByteString)
forall a. Maybe a
Nothing
Just ByteString
t' ->
let after :: ByteString
after = case ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
"\r\n" ByteString
t' of
Maybe ByteString
Nothing -> ByteString
t'
Just ByteString
t'' -> ByteString
t''
in (ByteString, ByteString, ByteString)
-> Maybe (ByteString, ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
before, ByteString
prefix, ByteString
after)
isClose :: ByteString
-> ByteString
-> Bool
isClose :: ByteString -> ByteString -> Bool
isClose ByteString
b ByteString
s = ByteString -> ByteString -> Bool
BS.isPrefixOf (ByteString -> ByteString -> ByteString
BS.append ByteString
"--" (ByteString -> ByteString -> ByteString
BS.append ByteString
b ByteString
"--")) ByteString
s
crlf :: ByteString
crlf :: ByteString
crlf = [Char] -> ByteString
BS.pack [Char]
"\r\n"
unlinesCRLF :: [ByteString] -> ByteString
unlinesCRLF :: [ByteString] -> ByteString
unlinesCRLF = [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString)
-> ([ByteString] -> [ByteString]) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
intersperse ByteString
crlf
splitAtEmptyLine :: ByteString -> (ByteString, ByteString)
splitAtEmptyLine :: ByteString -> (ByteString, ByteString)
splitAtEmptyLine ByteString
s =
let blank :: ByteString
blank = ByteString
"\r\n\r\n"
(ByteString
before, ByteString
after) = ByteString -> ByteString -> (ByteString, ByteString)
breakOn (ByteString -> ByteString
BS.toStrict ByteString
blank) ByteString
s
in case ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
blank ByteString
after of
Maybe ByteString
Nothing -> (ByteString
before, ByteString
after)
Just ByteString
after' -> (ByteString -> ByteString -> ByteString
BS.append ByteString
before ByteString
"\r\n", ByteString
after')