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

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

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

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

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

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

      -- check if we are at the beginning of a boundary, if so, we
      -- won’t have a \r\n
      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)

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

--
-- * RFC 2046 CRLF
--

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

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