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