module Happstack.Server.Internal.Multipart where

import           Control.Monad                   (MonadPlus(mplus))
import           Data.ByteString.Base64.Lazy
import qualified Data.ByteString.Lazy.Char8      as L
import           Data.ByteString.Lazy.Internal   (ByteString(Chunk, Empty))
import qualified Data.ByteString.Lazy.UTF8       as LU
import qualified Data.ByteString.Char8           as S
import           Data.Maybe                      (fromMaybe)
import           Data.Int                        (Int64)
import           Text.ParserCombinators.Parsec   (parse)
import           Happstack.Server.Internal.Types (Input(..))
import           Happstack.Server.Internal.RFC822Headers
import           System.IO                        (Handle, hClose, openBinaryTempFile)

-- | similar to the normal 'span' function, except the predicate gets the whole rest of the lazy bytestring, not just one character.
--
-- TODO: this function has not been profiled.
spanS :: (L.ByteString -> Bool) -> L.ByteString -> (L.ByteString, L.ByteString)
spanS :: (ByteString -> Bool) -> ByteString -> (ByteString, ByteString)
spanS ByteString -> Bool
f ByteString
cs0 = Int -> ByteString -> (ByteString, ByteString)
spanS' Int
0 ByteString
cs0
  where spanS' :: Int -> ByteString -> (ByteString, ByteString)
spanS' Int
_ ByteString
Empty = (ByteString
Empty, ByteString
Empty)
        spanS' Int
n bs :: ByteString
bs@(Chunk ByteString
c ByteString
cs)
            | Int
n forall a. Ord a => a -> a -> Bool
>= ByteString -> Int
S.length ByteString
c =
                let (ByteString
x, ByteString
y) = Int -> ByteString -> (ByteString, ByteString)
spanS' Int
0 ByteString
cs
                in (ByteString -> ByteString -> ByteString
Chunk ByteString
c ByteString
x, ByteString
y)
            | Bool -> Bool
not (ByteString -> Bool
f (ByteString -> ByteString -> ByteString
Chunk (Int -> ByteString -> ByteString
S.drop Int
n ByteString
c) ByteString
cs)) = Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) ByteString
bs
            | Bool
otherwise = (Int -> ByteString -> (ByteString, ByteString)
spanS' (Int
n forall a. Num a => a -> a -> a
+ Int
1) ByteString
bs)
{-# INLINE spanS #-}

takeWhileS :: (L.ByteString -> Bool) -> L.ByteString -> L.ByteString
takeWhileS :: (ByteString -> Bool) -> ByteString -> ByteString
takeWhileS ByteString -> Bool
f ByteString
cs0 = Int -> ByteString -> ByteString
takeWhile' Int
0 ByteString
cs0
  where takeWhile' :: Int -> ByteString -> ByteString
takeWhile' Int
_ ByteString
Empty = ByteString
Empty
        takeWhile' Int
n bs :: ByteString
bs@(Chunk ByteString
c ByteString
cs)
            | Int
n forall a. Ord a => a -> a -> Bool
>= ByteString -> Int
S.length ByteString
c = ByteString -> ByteString -> ByteString
Chunk ByteString
c (Int -> ByteString -> ByteString
takeWhile' Int
0 ByteString
cs)
            | Bool -> Bool
not (ByteString -> Bool
f (ByteString -> ByteString -> ByteString
Chunk (Int -> ByteString -> ByteString
S.drop Int
n ByteString
c) ByteString
cs)) = (ByteString -> ByteString -> ByteString
Chunk (Int -> ByteString -> ByteString
S.take Int
n ByteString
c) ByteString
Empty)
            | Bool
otherwise = Int -> ByteString -> ByteString
takeWhile' (Int
n forall a. Num a => a -> a -> a
+ Int
1) ByteString
bs

crlf :: L.ByteString
crlf :: ByteString
crlf = String -> ByteString
L.pack String
"\r\n"

crlfcrlf :: L.ByteString
crlfcrlf :: ByteString
crlfcrlf = String -> ByteString
L.pack String
"\r\n\r\n"

blankLine :: L.ByteString
blankLine :: ByteString
blankLine = String -> ByteString
L.pack String
"\r\n\r\n"

dropWhileS :: (L.ByteString -> Bool) -> L.ByteString -> L.ByteString
dropWhileS :: (ByteString -> Bool) -> ByteString -> ByteString
dropWhileS ByteString -> Bool
f ByteString
cs0 = ByteString -> ByteString
dropWhile' ByteString
cs0
    where dropWhile' :: ByteString -> ByteString
dropWhile' ByteString
bs
              | ByteString -> Bool
L.null ByteString
bs  = ByteString
bs
              | ByteString -> Bool
f ByteString
bs       = ByteString -> ByteString
dropWhile' (Int64 -> ByteString -> ByteString
L.drop Int64
1 ByteString
bs)
              | Bool
otherwise  = ByteString
bs

data BodyPart = BodyPart L.ByteString L.ByteString  -- ^ headers body
    deriving (BodyPart -> BodyPart -> Bool
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
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
Ord, ReadPrec [BodyPart]
ReadPrec BodyPart
Int -> ReadS BodyPart
ReadS [BodyPart]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BodyPart]
$creadListPrec :: ReadPrec [BodyPart]
readPrec :: ReadPrec BodyPart
$creadPrec :: ReadPrec BodyPart
readList :: ReadS [BodyPart]
$creadList :: ReadS [BodyPart]
readsPrec :: Int -> ReadS BodyPart
$creadsPrec :: Int -> ReadS BodyPart
Read, Int -> BodyPart -> ShowS
[BodyPart] -> ShowS
BodyPart -> String
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)

data Work
    = BodyWork ContentType [(String, String)] L.ByteString
    | HeaderWork L.ByteString

type InputWorker = Work -> IO InputIter

data InputIter
    = Failed (Maybe (String, Input)) String
    | BodyResult (String, Input) InputWorker
    | HeaderResult [Header] InputWorker

type FileSaver = FilePath               -- ^ tempdir
                -> Int64                -- ^ quota
                -> FilePath             -- ^ filename of field
                -> L.ByteString         -- ^ content to save
                -> IO (Bool, Int64 , FilePath)  -- ^ truncated?, saved bytes, saved filename

defaultFileSaver :: FilePath -> Int64 -> FilePath -> ByteString -> IO (Bool, Int64, FilePath)
defaultFileSaver :: String -> Int64 -> String -> ByteString -> IO (Bool, Int64, String)
defaultFileSaver String
tmpDir Int64
diskQuota String
filename ByteString
b
  | String -> Bool
pathSeparator String
filename = forall a. HasCallStack => String -> a
error (String
"Filename contains path separators: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
filename)
  | Bool
otherwise =
    do (String
fn, Handle
h) <- String -> String -> IO (String, Handle)
openBinaryTempFile String
tmpDir String
filename
       (Bool
trunc, Int64
len) <- Int64 -> Handle -> ByteString -> IO (Bool, Int64)
hPutLimit Int64
diskQuota Handle
h ByteString
b
       Handle -> IO ()
hClose Handle
h
       forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
trunc, Int64
len, String
fn)
 where
   pathSeparator :: String -> Bool
   pathSeparator :: String -> Bool
pathSeparator String
template = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Char
x-> Char
x forall a. Eq a => a -> a -> Bool
== Char
'/' Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'\\') String
template

defaultInputIter :: FileSaver -> FilePath -> Int64 -> Int64 -> Int64 -> Int64 -> Int64 -> Int64 -> Work -> IO InputIter
defaultInputIter :: (String
 -> Int64 -> String -> ByteString -> IO (Bool, Int64, String))
-> String
-> Int64
-> Int64
-> Int64
-> Int64
-> Int64
-> Int64
-> Work
-> IO InputIter
defaultInputIter String -> Int64 -> String -> ByteString -> IO (Bool, Int64, String)
fileSaver String
tmpDir Int64
diskCount Int64
ramCount Int64
headerCount Int64
maxDisk Int64
maxRAM Int64
maxHeader (BodyWork ContentType
ctype [(String, String)]
ps ByteString
b)
    | Int64
diskCount forall a. Ord a => a -> a -> Bool
> Int64
maxDisk = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe (String, Input) -> String -> InputIter
Failed forall a. Maybe a
Nothing (String
"diskCount (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int64
diskCount forall a. [a] -> [a] -> [a]
++ String
") is greater than maxDisk (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int64
maxDisk  forall a. [a] -> [a] -> [a]
++ String
")")
    | Int64
ramCount  forall a. Ord a => a -> a -> Bool
> Int64
maxRAM  = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe (String, Input) -> String -> InputIter
Failed forall a. Maybe a
Nothing (String
"ramCount ("  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int64
ramCount  forall a. [a] -> [a] -> [a]
++ String
") is greater than maxRAM ("  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int64
maxRAM   forall a. [a] -> [a] -> [a]
++ String
")")
    | Bool
otherwise =
        case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"filename" [(String, String)]
ps of
          Maybe String
Nothing ->
              let (ByteString
b',ByteString
rest) = Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt (Int64
maxRAM forall a. Num a => a -> a -> a
- Int64
ramCount) ByteString
b
                  input :: (String, Input)
input = (forall a. a -> Maybe a -> a
fromMaybe String
"" forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"name" [(String, String)]
ps
                          , Input { inputValue :: Either String ByteString
inputValue       = (forall a b. b -> Either a b
Right ByteString
b')
                                  , inputFilename :: Maybe String
inputFilename    = forall a. Maybe a
Nothing
                                  , inputContentType :: ContentType
inputContentType = ContentType
ctype })
              in if ByteString -> Bool
L.null ByteString
rest
                  then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (String, Input) -> (Work -> IO InputIter) -> InputIter
BodyResult (String, Input)
input ((String
 -> Int64 -> String -> ByteString -> IO (Bool, Int64, String))
-> String
-> Int64
-> Int64
-> Int64
-> Int64
-> Int64
-> Int64
-> Work
-> IO InputIter
defaultInputIter String -> Int64 -> String -> ByteString -> IO (Bool, Int64, String)
fileSaver String
tmpDir Int64
diskCount (Int64
ramCount forall a. Num a => a -> a -> a
+ ByteString -> Int64
L.length ByteString
b) Int64
headerCount Int64
maxDisk Int64
maxRAM Int64
maxHeader)
                  else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe (String, Input) -> String -> InputIter
Failed (forall a. a -> Maybe a
Just (String, Input)
input) (String
"Reached RAM quota of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int64
maxRAM forall a. [a] -> [a] -> [a]
++ String
" bytes.")

          (Just String
filename) ->
              do (Bool
trunc, Int64
len, String
fn) <- String -> Int64 -> String -> ByteString -> IO (Bool, Int64, String)
fileSaver String
tmpDir (Int64
maxDisk forall a. Num a => a -> a -> a
- Int64
diskCount) String
filename ByteString
b
                 let input :: (String, Input)
input = ( forall a. a -> Maybe a -> a
fromMaybe String
"" forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"name" [(String, String)]
ps
                             , Input { inputValue :: Either String ByteString
inputValue       = forall a b. a -> Either a b
Left String
fn
                                     , inputFilename :: Maybe String
inputFilename    = (forall a. a -> Maybe a
Just String
filename)
                                     , inputContentType :: ContentType
inputContentType = ContentType
ctype })
                 if Bool
trunc
                    then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe (String, Input) -> String -> InputIter
Failed (forall a. a -> Maybe a
Just (String, Input)
input) (String
"Reached disk quota of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int64
maxDisk forall a. [a] -> [a] -> [a]
++ String
" bytes.")
                    else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (String, Input) -> (Work -> IO InputIter) -> InputIter
BodyResult (String, Input)
input ((String
 -> Int64 -> String -> ByteString -> IO (Bool, Int64, String))
-> String
-> Int64
-> Int64
-> Int64
-> Int64
-> Int64
-> Int64
-> Work
-> IO InputIter
defaultInputIter String -> Int64 -> String -> ByteString -> IO (Bool, Int64, String)
fileSaver String
tmpDir (Int64
diskCount forall a. Num a => a -> a -> a
+ Int64
len) Int64
ramCount Int64
headerCount Int64
maxDisk Int64
maxRAM Int64
maxHeader)

defaultInputIter String -> Int64 -> String -> ByteString -> IO (Bool, Int64, String)
fileSaver String
tmpDir Int64
diskCount Int64
ramCount Int64
headerCount Int64
maxDisk Int64
maxRAM Int64
maxHeader (HeaderWork ByteString
bs) =
    case Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt (Int64
maxHeader forall a. Num a => a -> a -> a
- Int64
headerCount) ByteString
bs of
      (ByteString
_hs, ByteString
rest)
          | Bool -> Bool
not (ByteString -> Bool
L.null ByteString
rest) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe (String, Input) -> String -> InputIter
Failed forall a. Maybe a
Nothing (String
"Reached header quota of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int64
maxHeader forall a. [a] -> [a] -> [a]
++ String
" bytes.")
          | Bool
otherwise ->
              case forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parser [(String, String)]
pHeaders (ByteString -> String
LU.toString ByteString
bs) (ByteString -> String
LU.toString ByteString
bs) of
                (Left ParseError
e) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe (String, Input) -> String -> InputIter
Failed forall a. Maybe a
Nothing (forall a. Show a => a -> String
show ParseError
e)
                (Right [(String, String)]
hs) ->
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(String, String)] -> (Work -> IO InputIter) -> InputIter
HeaderResult [(String, String)]
hs
                               ((String
 -> Int64 -> String -> ByteString -> IO (Bool, Int64, String))
-> String
-> Int64
-> Int64
-> Int64
-> Int64
-> Int64
-> Int64
-> Work
-> IO InputIter
defaultInputIter String -> Int64 -> String -> ByteString -> IO (Bool, Int64, String)
fileSaver String
tmpDir Int64
diskCount Int64
ramCount (Int64
headerCount forall a. Num a => a -> a -> a
+ (ByteString -> Int64
L.length ByteString
bs)) Int64
maxDisk Int64
maxRAM Int64
maxHeader)
{-# INLINE defaultInputIter #-}

hPutLimit :: Int64 -> Handle -> L.ByteString -> IO (Bool, Int64)
hPutLimit :: Int64 -> Handle -> ByteString -> IO (Bool, Int64)
hPutLimit Int64
maxCount Handle
h ByteString
bs = Int64 -> Handle -> Int64 -> ByteString -> IO (Bool, Int64)
hPutLimit' Int64
maxCount Handle
h Int64
0 ByteString
bs
{-# INLINE hPutLimit #-}

hPutLimit' :: Int64 -> Handle -> Int64 -> L.ByteString -> IO (Bool, Int64)
hPutLimit' :: Int64 -> Handle -> Int64 -> ByteString -> IO (Bool, Int64)
hPutLimit' Int64
_maxCount Handle
_h Int64
count ByteString
Empty = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Int64
count)
hPutLimit'  Int64
maxCount Handle
h  Int64
count (Chunk ByteString
c ByteString
cs)
    | (Int64
count forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
S.length ByteString
c)) forall a. Ord a => a -> a -> Bool
> Int64
maxCount =
        do Handle -> ByteString -> IO ()
S.hPut Handle
h (Int -> ByteString -> ByteString
S.take (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
maxCount forall a. Num a => a -> a -> a
- Int64
count)) ByteString
c)
           forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Int64
maxCount)
    | Bool
otherwise =
        do Handle -> ByteString -> IO ()
S.hPut Handle
h ByteString
c
           Int64 -> Handle -> Int64 -> ByteString -> IO (Bool, Int64)
hPutLimit' Int64
maxCount Handle
h (Int64
count forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
S.length ByteString
c)) ByteString
cs
{-# INLINE hPutLimit' #-}

-- FIXME: can we safely use L.unpack, or do we need to worry about encoding issues in the headers?
bodyPartToInput :: InputWorker -> BodyPart -> IO InputIter -- (Either String (String,Input))
bodyPartToInput :: (Work -> IO InputIter) -> BodyPart -> IO InputIter
bodyPartToInput Work -> IO InputIter
inputWorker (BodyPart ByteString
rawHS ByteString
b) =
    do InputIter
r <- Work -> IO InputIter
inputWorker (ByteString -> Work
HeaderWork ByteString
rawHS)
       case InputIter
r of
         (Failed Maybe (String, Input)
i String
e) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe (String, Input) -> String -> InputIter
Failed Maybe (String, Input)
i String
e
         (HeaderResult [(String, String)]
hs Work -> IO InputIter
cont) ->
          let ctype :: ContentType
ctype = forall a. a -> Maybe a -> a
fromMaybe ContentType
defaultInputType (forall (m :: * -> *).
MonadFail m =>
[(String, String)] -> m ContentType
getContentType [(String, String)]
hs) in
          case forall (m :: * -> *).
MonadFail m =>
[(String, String)] -> m ContentDisposition
getContentDisposition [(String, String)]
hs of
              Just (ContentDisposition String
"form-data" [(String, String)]
ps) -> do
                  let eb' :: Either String ByteString
eb' = case forall (m :: * -> *).
MonadFail m =>
[(String, String)] -> m ContentTransferEncoding
getContentTransferEncoding [(String, String)]
hs of
                            Maybe ContentTransferEncoding
Nothing -> forall a b. b -> Either a b
Right ByteString
b
                            Just (ContentTransferEncoding String
"7bit") ->
                                -- We don't bother checking that the data
                                -- really is 7bit-only
                                forall a b. b -> Either a b
Right ByteString
b
                            Just (ContentTransferEncoding String
"8bit") ->
                                forall a b. b -> Either a b
Right ByteString
b
                            Just (ContentTransferEncoding String
"binary") ->
                                forall a b. b -> Either a b
Right ByteString
b
                            Just (ContentTransferEncoding String
"base64") ->
                                forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
decodeLenient ByteString
b
                            -- TODO: Support quoted-printable
                            Just ContentTransferEncoding
cte ->
                                forall a b. a -> Either a b
Left (String
"Bad content-transfer-encoding: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ContentTransferEncoding
cte)
                  case Either String ByteString
eb' of
                      Right ByteString
b' ->
                          Work -> IO InputIter
cont (ContentType -> [(String, String)] -> ByteString -> Work
BodyWork ContentType
ctype [(String, String)]
ps ByteString
b')
                      Left String
err ->
                          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe (String, Input) -> String -> InputIter
Failed forall a. Maybe a
Nothing String
err
              Maybe ContentDisposition
cd -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe (String, Input) -> String -> InputIter
Failed forall a. Maybe a
Nothing (String
"Expected content-disposition: form-data but got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Maybe ContentDisposition
cd)
         (BodyResult {}) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe (String, Input) -> String -> InputIter
Failed forall a. Maybe a
Nothing String
"bodyPartToInput: Got unexpected BodyResult."

bodyPartsToInputs :: InputWorker -> [BodyPart] -> IO ([(String,Input)], Maybe String)
bodyPartsToInputs :: (Work -> IO InputIter)
-> [BodyPart] -> IO ([(String, Input)], Maybe String)
bodyPartsToInputs Work -> IO InputIter
_ [] =
    forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. Maybe a
Nothing)
bodyPartsToInputs Work -> IO InputIter
inputWorker (BodyPart
b:[BodyPart]
bs) =
    do InputIter
r <- (Work -> IO InputIter) -> BodyPart -> IO InputIter
bodyPartToInput Work -> IO InputIter
inputWorker BodyPart
b
       case InputIter
r of
         (Failed Maybe (String, Input)
mInput String
e) ->
             case Maybe (String, Input)
mInput of
               Maybe (String, Input)
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. a -> Maybe a
Just String
e)
               (Just (String, Input)
i) -> forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, Input)
i], forall a. a -> Maybe a
Just String
e)
         (BodyResult (String, Input)
i Work -> IO InputIter
cont) ->
             do ([(String, Input)]
is, Maybe String
err) <- (Work -> IO InputIter)
-> [BodyPart] -> IO ([(String, Input)], Maybe String)
bodyPartsToInputs Work -> IO InputIter
cont [BodyPart]
bs
                forall (m :: * -> *) a. Monad m => a -> m a
return ((String, Input)
iforall a. a -> [a] -> [a]
:[(String, Input)]
is, Maybe String
err)
         (HeaderResult [(String, String)]
_ Work -> IO InputIter
_) ->
             forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. a -> Maybe a
Just String
"InputWorker is broken. Returned a HeaderResult when a BodyResult was required.")

multipartBody :: InputWorker -> L.ByteString -> L.ByteString -> IO ([(String, Input)], Maybe String)
multipartBody :: (Work -> IO InputIter)
-> ByteString -> ByteString -> IO ([(String, Input)], Maybe String)
multipartBody Work -> IO InputIter
inputWorker ByteString
boundary ByteString
s =
    do let ([BodyPart]
bodyParts, Maybe String
mErr) = ByteString -> ByteString -> ([BodyPart], Maybe String)
parseMultipartBody ByteString
boundary ByteString
s
       ([(String, Input)]
inputs, Maybe String
mErr2) <- (Work -> IO InputIter)
-> [BodyPart] -> IO ([(String, Input)], Maybe String)
bodyPartsToInputs Work -> IO InputIter
inputWorker [BodyPart]
bodyParts
       forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, Input)]
inputs, Maybe String
mErr2 forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe String
mErr)

-- | Packs a string into an Input of type "text/plain"
simpleInput :: String -> Input
simpleInput :: String -> Input
simpleInput String
v
    = Input { inputValue :: Either String ByteString
inputValue       = forall a b. b -> Either a b
Right (String -> ByteString
L.pack String
v)
            , inputFilename :: Maybe String
inputFilename    = forall a. Maybe a
Nothing
            , inputContentType :: ContentType
inputContentType = ContentType
defaultInputType
            }

-- | The default content-type for variables.
defaultInputType :: ContentType
defaultInputType :: ContentType
defaultInputType = String -> String -> [(String, String)] -> ContentType
ContentType String
"text" String
"plain" [] -- FIXME: use some default encoding?

parseMultipartBody :: L.ByteString -> L.ByteString -> ([BodyPart], Maybe String)
parseMultipartBody :: ByteString -> ByteString -> ([BodyPart], Maybe String)
parseMultipartBody ByteString
boundary ByteString
s =
    case ByteString -> ByteString -> (ByteString, Maybe String)
dropPreamble ByteString
boundary ByteString
s of
      (ByteString
_partData, Just String
e)  -> ([], forall a. a -> Maybe a
Just String
e)
      (ByteString
partData,  Maybe String
Nothing) -> ByteString -> ByteString -> ([BodyPart], Maybe String)
splitParts ByteString
boundary ByteString
partData

dropPreamble :: L.ByteString -> L.ByteString -> (L.ByteString, Maybe String)
dropPreamble :: ByteString -> ByteString -> (ByteString, Maybe String)
dropPreamble ByteString
b ByteString
s | ByteString -> ByteString -> Bool
isBoundary ByteString
b ByteString
s = (ByteString -> ByteString
dropLine ByteString
s, forall a. Maybe a
Nothing)
                 | ByteString -> Bool
L.null ByteString
s = (ByteString
s, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
"Boundary " forall a. [a] -> [a] -> [a]
++ ByteString -> String
L.unpack ByteString
b forall a. [a] -> [a] -> [a]
++ String
" not found.")
                 | Bool
otherwise = ByteString -> ByteString -> (ByteString, Maybe String)
dropPreamble ByteString
b (ByteString -> ByteString
dropLine ByteString
s)

dropLine :: L.ByteString -> L.ByteString
dropLine :: ByteString -> ByteString
dropLine = Int64 -> ByteString -> ByteString
L.drop Int64
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Bool) -> ByteString -> ByteString
dropWhileS (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Bool
L.isPrefixOf ByteString
crlf)

-- | Check whether a string starts with two dashes followed by
--   the given boundary string.
isBoundary :: L.ByteString -- ^ The boundary, without the initial dashes
           -> L.ByteString
           -> Bool
isBoundary :: ByteString -> ByteString -> Bool
isBoundary ByteString
b ByteString
s = ByteString -> Bool
startsWithDashes ByteString
s Bool -> Bool -> Bool
&& ByteString
b ByteString -> ByteString -> Bool
`L.isPrefixOf` Int64 -> ByteString -> ByteString
L.drop Int64
2 ByteString
s

-- | Checks whether a string starts with two dashes.
startsWithDashes :: L.ByteString -> Bool
startsWithDashes :: ByteString -> Bool
startsWithDashes ByteString
s = String -> ByteString
L.pack String
"--" ByteString -> ByteString -> Bool
`L.isPrefixOf` ByteString
s

splitParts :: L.ByteString -> L.ByteString -> ([BodyPart], Maybe String)
splitParts :: ByteString -> ByteString -> ([BodyPart], Maybe String)
splitParts ByteString
boundary ByteString
s =
--    | not (isBoundary boundary s) = ([], Just $ "Missing boundary: " ++ L.unpack boundary ++ "\n" ++ L.unpack s)
    case ByteString -> Bool
L.null ByteString
s of
      Bool
True -> ([], forall a. Maybe a
Nothing)
      Bool
False ->
          case ByteString -> ByteString -> (BodyPart, ByteString)
splitPart ByteString
boundary ByteString
s of
            (BodyPart
p, ByteString
s') ->
                let ([BodyPart]
ps,Maybe String
e) = ByteString -> ByteString -> ([BodyPart], Maybe String)
splitParts ByteString
boundary ByteString
s'
                in (BodyPart
pforall a. a -> [a] -> [a]
:[BodyPart]
ps, Maybe String
e)
{-# INLINE splitParts #-}

splitPart :: L.ByteString -> L.ByteString -> (BodyPart, L.ByteString)
splitPart :: ByteString -> ByteString -> (BodyPart, ByteString)
splitPart ByteString
boundary ByteString
s =
    case ByteString -> (ByteString, ByteString)
splitBlank ByteString
s of
      (ByteString
headers, ByteString
rest) ->
          case ByteString -> ByteString -> (ByteString, ByteString)
splitBoundary ByteString
boundary (Int64 -> ByteString -> ByteString
L.drop Int64
4 ByteString
rest) of
            (ByteString
body, ByteString
rest') -> (ByteString -> ByteString -> BodyPart
BodyPart (ByteString -> ByteString -> ByteString
L.append ByteString
headers ByteString
crlf) ByteString
body, ByteString
rest')
{-# INLINE splitPart #-}


splitBlank :: L.ByteString -> (L.ByteString, L.ByteString)
splitBlank :: ByteString -> (ByteString, ByteString)
splitBlank ByteString
s = (ByteString -> Bool) -> ByteString -> (ByteString, ByteString)
spanS (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Bool
L.isPrefixOf ByteString
crlfcrlf) ByteString
s
{-# INLINE splitBlank #-}


splitBoundary :: L.ByteString -> L.ByteString -> (L.ByteString, L.ByteString)
splitBoundary :: ByteString -> ByteString -> (ByteString, ByteString)
splitBoundary ByteString
boundary ByteString
s =
    case (ByteString -> Bool) -> ByteString -> (ByteString, ByteString)
spanS (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Bool
L.isPrefixOf (String -> ByteString
L.pack String
"\r\n--" ByteString -> ByteString -> ByteString
`L.append` ByteString
boundary)) ByteString
s of
      (ByteString
x,ByteString
y) | (String -> ByteString
L.pack String
"\r\n--" ByteString -> ByteString -> ByteString
`L.append` ByteString
boundary ByteString -> ByteString -> ByteString
`L.append` (String -> ByteString
L.pack String
"--"))
                ByteString -> ByteString -> Bool
`L.isPrefixOf` ByteString
y -> (ByteString
x, ByteString
L.empty)
            | Bool
otherwise -> (ByteString
x, ByteString -> ByteString
dropLine (Int64 -> ByteString -> ByteString
L.drop Int64
2 ByteString
y))
{-# INLINE splitBoundary #-}

splitAtEmptyLine :: L.ByteString -> Maybe (L.ByteString, L.ByteString)
splitAtEmptyLine :: ByteString -> Maybe (ByteString, ByteString)
splitAtEmptyLine ByteString
s =
    case ByteString -> (ByteString, ByteString)
splitBlank ByteString
s of
      (ByteString
before, ByteString
after) | ByteString -> Bool
L.null ByteString
after -> forall a. Maybe a
Nothing
                      | Bool
otherwise    -> forall a. a -> Maybe a
Just (ByteString -> ByteString -> ByteString
L.append ByteString
before ByteString
crlf, Int64 -> ByteString -> ByteString
L.drop Int64
4 ByteString
after)
{-# INLINE splitAtEmptyLine #-}

-- | Split a string at the first CRLF. The CRLF is not included
--   in any of the returned strings.
splitAtCRLF :: ByteString -- ^ String to split.
            -> Maybe (ByteString,ByteString)
            -- ^  Returns 'Nothing' if there is no CRLF.
splitAtCRLF :: ByteString -> Maybe (ByteString, ByteString)
splitAtCRLF ByteString
s =
    case (ByteString -> Bool) -> ByteString -> (ByteString, ByteString)
spanS (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Bool
L.isPrefixOf ByteString
crlf) ByteString
s of
      (ByteString
before, ByteString
after) | ByteString -> Bool
L.null ByteString
after -> forall a. Maybe a
Nothing
                      | Bool
otherwise    -> forall a. a -> Maybe a
Just (ByteString
before, Int64 -> ByteString -> ByteString
L.drop Int64
2 ByteString
after)
{-# INLINE splitAtCRLF #-}