module Happstack.Server.HTTP.Multipart
(
MultiPart(..), BodyPart(..), Header
, parseMultipartBody, hGetMultipartBody
, ContentType(..), ContentTransferEncoding(..)
, ContentDisposition(..)
, parseContentType
, parseContentTransferEncoding
, parseContentDisposition
, getContentType
, getContentTransferEncoding
, getContentDisposition
, splitAtEmptyLine
, splitAtCRLF
, splitParts
) where
import Control.Monad
import Data.Int (Int64)
import Data.Maybe
import System.IO (Handle)
import Happstack.Server.HTTP.RFC822Headers
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.ByteString.Lazy.Char8 (ByteString)
data MultiPart = MultiPart [BodyPart]
deriving (Show, Read, Eq, Ord)
data BodyPart = BodyPart [Header] ByteString
deriving (Show, Read, Eq, Ord)
parseMultipartBody :: String
-> ByteString -> Maybe MultiPart
parseMultipartBody b s =
do
ps <- splitParts (BS.pack b) s
liftM MultiPart $ mapM parseBodyPart ps
hGetMultipartBody :: String
-> Handle
-> IO MultiPart
hGetMultipartBody b h =
do
s <- BS.hGetContents h
case parseMultipartBody b s of
Nothing -> fail "Error parsing multi-part message"
Just m -> return m
parseBodyPart :: ByteString -> Maybe BodyPart
parseBodyPart s =
do
(hdr,bdy) <- splitAtEmptyLine s
hs <- parseM pHeaders "<input>" (BS.unpack hdr)
return $ BodyPart hs bdy
splitParts :: ByteString
-> ByteString
-> Maybe [ByteString]
splitParts b s = dropPreamble b s >>= spl
where
spl x = case splitAtBoundary b x of
Nothing -> Nothing
Just (s1,d,s2) | isClose b d -> Just [s1]
| otherwise -> spl s2 >>= Just . (s1:)
dropPreamble :: ByteString
-> ByteString
-> Maybe ByteString
dropPreamble b s | isBoundary b s = fmap snd (splitAtCRLF s)
| otherwise = dropLine s >>= dropPreamble b
splitAtBoundary :: ByteString
-> ByteString
-> Maybe (ByteString,ByteString,ByteString)
splitAtBoundary b s = spl 0
where
spl i = case findCRLF (BS.drop i s) of
Nothing -> Nothing
Just (j,l) | isBoundary b s2 -> Just (s1,d,s3)
| otherwise -> spl (i+j+l)
where
s1 = BS.take (i+j) s
s2 = BS.drop (i+j+l) s
(d,s3) = splitAtCRLF_ s2
isBoundary :: ByteString
-> ByteString
-> Bool
isBoundary b s = startsWithDashes s && b `BS.isPrefixOf` BS.drop 2 s
isClose :: ByteString
-> ByteString
-> Bool
isClose b = startsWithDashes . BS.drop (2+BS.length b)
startsWithDashes :: ByteString -> Bool
startsWithDashes s = BS.pack "--" `BS.isPrefixOf` s
dropLine :: ByteString -> Maybe ByteString
dropLine = fmap snd . splitAtCRLF
splitAtEmptyLine :: ByteString -> Maybe (ByteString, ByteString)
splitAtEmptyLine s | startsWithCRLF s = Just (BS.empty, dropCRLF s)
| otherwise = spl 0
where
spl i = case findCRLF (BS.drop i s) of
Nothing -> Nothing
Just (j,l) | startsWithCRLF s2 -> Just (s1, dropCRLF s2)
| otherwise -> spl (i+j+l)
where (s1,s2) = BS.splitAt (i+j+l) s
splitAtCRLF :: ByteString
-> Maybe (ByteString,ByteString)
splitAtCRLF s = case findCRLF s of
Nothing -> Nothing
Just (i,l) -> Just (s1, BS.drop l s2)
where (s1,s2) = BS.splitAt i s
splitAtCRLF_ :: ByteString -> (ByteString,ByteString)
splitAtCRLF_ s = fromMaybe (s,BS.empty) (splitAtCRLF s)
findCRLF :: ByteString
-> Maybe (Int64,Int64)
findCRLF s =
case findCRorLF s of
Nothing -> Nothing
Just j | BS.null (BS.drop (j+1) s) -> Just (j,1)
Just j -> case (BS.index s j, BS.index s (j+1)) of
('\r','\n') -> Just (j,2)
_ -> Just (j,1)
findCRorLF :: ByteString -> Maybe Int64
findCRorLF = BS.findIndex (\c -> c == '\n' || c == '\r')
startsWithCRLF :: ByteString -> Bool
startsWithCRLF s = not (BS.null s) && (c == '\n' || c == '\r')
where c = BS.index s 0
dropCRLF :: ByteString -> ByteString
dropCRLF s | BS.null s = BS.empty
| BS.null (BS.drop 1 s) = BS.empty
| c0 == '\r' && c1 == '\n' = BS.drop 2 s
| otherwise = BS.drop 1 s
where c0 = BS.index s 0
c1 = BS.index s 1