{-# 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 (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)

-- | Read a multi-part message from a 'ByteString'.
parseMultipartBody :: String -- ^ Boundary
                   -> 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)

-- | Read a multi-part message from a 'Handle'.
--   Fails on parse errors.
hGetMultipartBody :: String -- ^ Boundary
                  -> 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]

--
-- * Splitting into multipart parts.
--

-- | Split a multipart message into the multipart parts.
splitParts :: ByteString -- ^ The boundary, without the initial dashes
           -> 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

-- | Drop everything up to and including the first line starting
--   with the boundary.
dropPreamble :: ByteString -- ^ The boundary, without the initial dashes
             -> 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

-- | 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 :: 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)

-- | 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 :: 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

--
-- * RFC 2046 CRLF
--

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

-- | 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 :: 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')