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 Int -> Int -> Bool
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 (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) ByteString
bs
            | Bool
otherwise = (Int -> ByteString -> (ByteString, ByteString)
spanS' (Int
n Int -> Int -> Int
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 Int -> Int -> Bool
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ByteString
bs

crlf :: L.ByteString
crlf :: ByteString
crlf = [Char] -> ByteString
L.pack [Char]
"\r\n"

crlfcrlf :: L.ByteString
crlfcrlf :: ByteString
crlfcrlf = [Char] -> ByteString
L.pack [Char]
"\r\n\r\n"

blankLine :: L.ByteString
blankLine :: ByteString
blankLine = [Char] -> ByteString
L.pack [Char]
"\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
(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, ReadPrec [BodyPart]
ReadPrec BodyPart
Int -> ReadS BodyPart
ReadS [BodyPart]
(Int -> ReadS BodyPart)
-> ReadS [BodyPart]
-> ReadPrec BodyPart
-> ReadPrec [BodyPart]
-> Read 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 -> [Char]
(Int -> BodyPart -> ShowS)
-> (BodyPart -> [Char]) -> ([BodyPart] -> ShowS) -> Show BodyPart
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [BodyPart] -> ShowS
$cshowList :: [BodyPart] -> ShowS
show :: BodyPart -> [Char]
$cshow :: BodyPart -> [Char]
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 :: [Char] -> Int64 -> [Char] -> ByteString -> IO (Bool, Int64, [Char])
defaultFileSaver [Char]
tmpDir Int64
diskQuota [Char]
filename ByteString
b
  | [Char] -> Bool
pathSeparator [Char]
filename = [Char] -> IO (Bool, Int64, [Char])
forall a. HasCallStack => [Char] -> a
error ([Char]
"Filename contains path separators: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> [Char]
show [Char]
filename)
  | Bool
otherwise =
    do ([Char]
fn, Handle
h) <- [Char] -> [Char] -> IO ([Char], Handle)
openBinaryTempFile [Char]
tmpDir [Char]
filename
       (Bool
trunc, Int64
len) <- Int64 -> Handle -> ByteString -> IO (Bool, Int64)
hPutLimit Int64
diskQuota Handle
h ByteString
b
       Handle -> IO ()
hClose Handle
h
       (Bool, Int64, [Char]) -> IO (Bool, Int64, [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
trunc, Int64
len, [Char]
fn)
 where
   pathSeparator :: String -> Bool
   pathSeparator :: [Char] -> Bool
pathSeparator [Char]
template = (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Char
x-> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\') [Char]
template

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

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

defaultInputIter [Char] -> Int64 -> [Char] -> ByteString -> IO (Bool, Int64, [Char])
fileSaver [Char]
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 Int64 -> Int64 -> Int64
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) -> InputIter -> IO InputIter
forall (m :: * -> *) a. Monad m => a -> m a
return (InputIter -> IO InputIter) -> InputIter -> IO InputIter
forall a b. (a -> b) -> a -> b
$ Maybe ([Char], Input) -> [Char] -> InputIter
Failed Maybe ([Char], Input)
forall a. Maybe a
Nothing ([Char]
"Reached header quota of " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int64 -> [Char]
forall a. Show a => a -> [Char]
show Int64
maxHeader [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" bytes.")
          | Bool
otherwise ->
              case Parsec [Char] () [([Char], [Char])]
-> [Char] -> [Char] -> Either ParseError [([Char], [Char])]
forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse Parsec [Char] () [([Char], [Char])]
pHeaders (ByteString -> [Char]
LU.toString ByteString
bs) (ByteString -> [Char]
LU.toString ByteString
bs) of
                (Left ParseError
e) -> InputIter -> IO InputIter
forall (m :: * -> *) a. Monad m => a -> m a
return (InputIter -> IO InputIter) -> InputIter -> IO InputIter
forall a b. (a -> b) -> a -> b
$ Maybe ([Char], Input) -> [Char] -> InputIter
Failed Maybe ([Char], Input)
forall a. Maybe a
Nothing (ParseError -> [Char]
forall a. Show a => a -> [Char]
show ParseError
e)
                (Right [([Char], [Char])]
hs) ->
                    InputIter -> IO InputIter
forall (m :: * -> *) a. Monad m => a -> m a
return (InputIter -> IO InputIter) -> InputIter -> IO InputIter
forall a b. (a -> b) -> a -> b
$ [([Char], [Char])] -> (Work -> IO InputIter) -> InputIter
HeaderResult [([Char], [Char])]
hs
                               (([Char]
 -> Int64 -> [Char] -> ByteString -> IO (Bool, Int64, [Char]))
-> [Char]
-> Int64
-> Int64
-> Int64
-> Int64
-> Int64
-> Int64
-> Work
-> IO InputIter
defaultInputIter [Char] -> Int64 -> [Char] -> ByteString -> IO (Bool, Int64, [Char])
fileSaver [Char]
tmpDir Int64
diskCount Int64
ramCount (Int64
headerCount Int64 -> Int64 -> Int64
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 = (Bool, Int64) -> IO (Bool, Int64)
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 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
S.length ByteString
c)) Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
maxCount =
        do Handle -> ByteString -> IO ()
S.hPut Handle
h (Int -> ByteString -> ByteString
S.take (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
maxCount Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
count)) ByteString
c)
           (Bool, Int64) -> IO (Bool, Int64)
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 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int -> Int64
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 ([Char], Input)
i [Char]
e) -> InputIter -> IO InputIter
forall (m :: * -> *) a. Monad m => a -> m a
return (InputIter -> IO InputIter) -> InputIter -> IO InputIter
forall a b. (a -> b) -> a -> b
$ Maybe ([Char], Input) -> [Char] -> InputIter
Failed Maybe ([Char], Input)
i [Char]
e
         (HeaderResult [([Char], [Char])]
hs Work -> IO InputIter
cont) ->
          let ctype :: ContentType
ctype = ContentType -> Maybe ContentType -> ContentType
forall a. a -> Maybe a -> a
fromMaybe ContentType
defaultInputType ([([Char], [Char])] -> Maybe ContentType
forall (m :: * -> *).
MonadFail m =>
[([Char], [Char])] -> m ContentType
getContentType [([Char], [Char])]
hs) in
          case [([Char], [Char])] -> Maybe ContentDisposition
forall (m :: * -> *).
MonadFail m =>
[([Char], [Char])] -> m ContentDisposition
getContentDisposition [([Char], [Char])]
hs of
              Just (ContentDisposition [Char]
"form-data" [([Char], [Char])]
ps) -> do
                  let eb' :: Either [Char] ByteString
eb' = case [([Char], [Char])] -> Maybe ContentTransferEncoding
forall (m :: * -> *).
MonadFail m =>
[([Char], [Char])] -> m ContentTransferEncoding
getContentTransferEncoding [([Char], [Char])]
hs of
                            Maybe ContentTransferEncoding
Nothing -> ByteString -> Either [Char] ByteString
forall a b. b -> Either a b
Right ByteString
b
                            Just (ContentTransferEncoding [Char]
"7bit") ->
                                -- We don't bother checking that the data
                                -- really is 7bit-only
                                ByteString -> Either [Char] ByteString
forall a b. b -> Either a b
Right ByteString
b
                            Just (ContentTransferEncoding [Char]
"8bit") ->
                                ByteString -> Either [Char] ByteString
forall a b. b -> Either a b
Right ByteString
b
                            Just (ContentTransferEncoding [Char]
"binary") ->
                                ByteString -> Either [Char] ByteString
forall a b. b -> Either a b
Right ByteString
b
                            Just (ContentTransferEncoding [Char]
"base64") ->
                                ByteString -> Either [Char] ByteString
forall a b. b -> Either a b
Right (ByteString -> Either [Char] ByteString)
-> ByteString -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
decodeLenient ByteString
b
                            -- TODO: Support quoted-printable
                            Just ContentTransferEncoding
cte ->
                                [Char] -> Either [Char] ByteString
forall a b. a -> Either a b
Left ([Char]
"Bad content-transfer-encoding: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ContentTransferEncoding -> [Char]
forall a. Show a => a -> [Char]
show ContentTransferEncoding
cte)
                  case Either [Char] ByteString
eb' of
                      Right ByteString
b' ->
                          Work -> IO InputIter
cont (ContentType -> [([Char], [Char])] -> ByteString -> Work
BodyWork ContentType
ctype [([Char], [Char])]
ps ByteString
b')
                      Left [Char]
err ->
                          InputIter -> IO InputIter
forall (m :: * -> *) a. Monad m => a -> m a
return (InputIter -> IO InputIter) -> InputIter -> IO InputIter
forall a b. (a -> b) -> a -> b
$ Maybe ([Char], Input) -> [Char] -> InputIter
Failed Maybe ([Char], Input)
forall a. Maybe a
Nothing [Char]
err
              Maybe ContentDisposition
cd -> InputIter -> IO InputIter
forall (m :: * -> *) a. Monad m => a -> m a
return (InputIter -> IO InputIter) -> InputIter -> IO InputIter
forall a b. (a -> b) -> a -> b
$ Maybe ([Char], Input) -> [Char] -> InputIter
Failed Maybe ([Char], Input)
forall a. Maybe a
Nothing ([Char]
"Expected content-disposition: form-data but got " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe ContentDisposition -> [Char]
forall a. Show a => a -> [Char]
show Maybe ContentDisposition
cd)
         (BodyResult {}) -> InputIter -> IO InputIter
forall (m :: * -> *) a. Monad m => a -> m a
return (InputIter -> IO InputIter) -> InputIter -> IO InputIter
forall a b. (a -> b) -> a -> b
$ Maybe ([Char], Input) -> [Char] -> InputIter
Failed Maybe ([Char], Input)
forall a. Maybe a
Nothing [Char]
"bodyPartToInput: Got unexpected BodyResult."

bodyPartsToInputs :: InputWorker -> [BodyPart] -> IO ([(String,Input)], Maybe String)
bodyPartsToInputs :: (Work -> IO InputIter)
-> [BodyPart] -> IO ([([Char], Input)], Maybe [Char])
bodyPartsToInputs Work -> IO InputIter
_ [] =
    ([([Char], Input)], Maybe [Char])
-> IO ([([Char], Input)], Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Maybe [Char]
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 ([Char], Input)
mInput [Char]
e) ->
             case Maybe ([Char], Input)
mInput of
               Maybe ([Char], Input)
Nothing  -> ([([Char], Input)], Maybe [Char])
-> IO ([([Char], Input)], Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
e)
               (Just ([Char], Input)
i) -> ([([Char], Input)], Maybe [Char])
-> IO ([([Char], Input)], Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([([Char], Input)
i], [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
e)
         (BodyResult ([Char], Input)
i Work -> IO InputIter
cont) ->
             do ([([Char], Input)]
is, Maybe [Char]
err) <- (Work -> IO InputIter)
-> [BodyPart] -> IO ([([Char], Input)], Maybe [Char])
bodyPartsToInputs Work -> IO InputIter
cont [BodyPart]
bs
                ([([Char], Input)], Maybe [Char])
-> IO ([([Char], Input)], Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (([Char], Input)
i([Char], Input) -> [([Char], Input)] -> [([Char], Input)]
forall a. a -> [a] -> [a]
:[([Char], Input)]
is, Maybe [Char]
err)
         (HeaderResult [([Char], [Char])]
_ Work -> IO InputIter
_) ->
             ([([Char], Input)], Maybe [Char])
-> IO ([([Char], Input)], Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"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 ([([Char], Input)], Maybe [Char])
multipartBody Work -> IO InputIter
inputWorker ByteString
boundary ByteString
s =
    do let ([BodyPart]
bodyParts, Maybe [Char]
mErr) = ByteString -> ByteString -> ([BodyPart], Maybe [Char])
parseMultipartBody ByteString
boundary ByteString
s
       ([([Char], Input)]
inputs, Maybe [Char]
mErr2) <- (Work -> IO InputIter)
-> [BodyPart] -> IO ([([Char], Input)], Maybe [Char])
bodyPartsToInputs Work -> IO InputIter
inputWorker [BodyPart]
bodyParts
       ([([Char], Input)], Maybe [Char])
-> IO ([([Char], Input)], Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([([Char], Input)]
inputs, Maybe [Char]
mErr2 Maybe [Char] -> Maybe [Char] -> Maybe [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe [Char]
mErr)

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

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

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

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

dropLine :: L.ByteString -> L.ByteString
dropLine :: ByteString -> ByteString
dropLine = Int64 -> ByteString -> ByteString
L.drop Int64
2 (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Bool) -> ByteString -> ByteString
dropWhileS (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
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 = [Char] -> ByteString
L.pack [Char]
"--" ByteString -> ByteString -> Bool
`L.isPrefixOf` ByteString
s

splitParts :: L.ByteString -> L.ByteString -> ([BodyPart], Maybe String)
splitParts :: ByteString -> ByteString -> ([BodyPart], Maybe [Char])
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 -> ([], Maybe [Char]
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 [Char]
e) = ByteString -> ByteString -> ([BodyPart], Maybe [Char])
splitParts ByteString
boundary ByteString
s'
                in (BodyPart
pBodyPart -> [BodyPart] -> [BodyPart]
forall a. a -> [a] -> [a]
:[BodyPart]
ps, Maybe [Char]
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 (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
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 (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Bool
L.isPrefixOf ([Char] -> ByteString
L.pack [Char]
"\r\n--" ByteString -> ByteString -> ByteString
`L.append` ByteString
boundary)) ByteString
s of
      (ByteString
x,ByteString
y) | ([Char] -> ByteString
L.pack [Char]
"\r\n--" ByteString -> ByteString -> ByteString
`L.append` ByteString
boundary ByteString -> ByteString -> ByteString
`L.append` ([Char] -> ByteString
L.pack [Char]
"--"))
                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 -> Maybe (ByteString, ByteString)
forall a. Maybe a
Nothing
                      | Bool
otherwise    -> (ByteString, ByteString) -> Maybe (ByteString, ByteString)
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 (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
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 -> Maybe (ByteString, ByteString)
forall a. Maybe a
Nothing
                      | Bool
otherwise    -> (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
before, Int64 -> ByteString -> ByteString
L.drop Int64
2 ByteString
after)
{-# INLINE splitAtCRLF #-}