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 f :: ByteString -> Bool
f cs0 :: ByteString
cs0 = Int -> ByteString -> (ByteString, ByteString)
spanS' 0 ByteString
cs0
  where spanS' :: Int -> ByteString -> (ByteString, ByteString)
spanS' _ Empty = (ByteString
Empty, ByteString
Empty)
        spanS' n :: Int
n bs :: ByteString
bs@(Chunk c :: ByteString
c cs :: ByteString
cs)
            | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= ByteString -> Int
S.length ByteString
c =
                let (x :: ByteString
x, y :: ByteString
y) = Int -> ByteString -> (ByteString, ByteString)
spanS' 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
+ 1) ByteString
bs)
{-# INLINE spanS #-}

takeWhileS :: (L.ByteString -> Bool) -> L.ByteString -> L.ByteString
takeWhileS :: (ByteString -> Bool) -> ByteString -> ByteString
takeWhileS f :: ByteString -> Bool
f cs0 :: ByteString
cs0 = Int -> ByteString -> ByteString
takeWhile' 0 ByteString
cs0
  where takeWhile' :: Int -> ByteString -> ByteString
takeWhile' _ Empty = ByteString
Empty
        takeWhile' n :: Int
n bs :: ByteString
bs@(Chunk c :: ByteString
c cs :: 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' 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
+ 1) ByteString
bs

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

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

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

dropWhileS :: (L.ByteString -> Bool) -> L.ByteString -> L.ByteString
dropWhileS :: (ByteString -> Bool) -> ByteString -> ByteString
dropWhileS f :: ByteString -> Bool
f cs0 :: ByteString
cs0 = ByteString -> ByteString
dropWhile' ByteString
cs0
    where dropWhile' :: ByteString -> ByteString
dropWhile' bs :: ByteString
bs
              | ByteString -> Bool
L.null ByteString
bs  = ByteString
bs
              | ByteString -> Bool
f ByteString
bs       = ByteString -> ByteString
dropWhile' (Int64 -> ByteString -> ByteString
L.drop 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 tmpDir :: [Char]
tmpDir diskQuota :: Int64
diskQuota filename :: [Char]
filename b :: ByteString
b
  | [Char] -> Bool
pathSeparator [Char]
filename = [Char] -> IO (Bool, Int64, [Char])
forall a. HasCallStack => [Char] -> a
error ("Filename contains path separators: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> [Char]
show [Char]
filename)
  | Bool
otherwise =
    do (fn :: [Char]
fn, h :: Handle
h) <- [Char] -> [Char] -> IO ([Char], Handle)
openBinaryTempFile [Char]
tmpDir [Char]
filename
       (trunc :: Bool
trunc, len :: 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 template :: [Char]
template = (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\x :: Char
x-> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '/' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\\') [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 fileSaver :: [Char] -> Int64 -> [Char] -> ByteString -> IO (Bool, Int64, [Char])
fileSaver tmpDir :: [Char]
tmpDir diskCount :: Int64
diskCount ramCount :: Int64
ramCount headerCount :: Int64
headerCount maxDisk :: Int64
maxDisk maxRAM :: Int64
maxRAM maxHeader :: Int64
maxHeader (BodyWork ctype :: ContentType
ctype ps :: [([Char], [Char])]
ps b :: 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 ("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]
++ ") 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]
++ ")")
    | 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 ("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]
++ ") 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]
++ ")")
    | Bool
otherwise =
        case [Char] -> [([Char], [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "filename" [([Char], [Char])]
ps of
          Nothing ->
              let (b' :: ByteString
b',rest :: 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 "" (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 "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) ("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]
++ " bytes.")

          (Just filename :: [Char]
filename) ->
              do (trunc :: Bool
trunc, len :: Int64
len, fn :: [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 "" (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 "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) ("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]
++ " 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 fileSaver :: [Char] -> Int64 -> [Char] -> ByteString -> IO (Bool, Int64, [Char])
fileSaver tmpDir :: [Char]
tmpDir diskCount :: Int64
diskCount ramCount :: Int64
ramCount headerCount :: Int64
headerCount maxDisk :: Int64
maxDisk maxRAM :: Int64
maxRAM maxHeader :: Int64
maxHeader (HeaderWork bs :: 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
      (_hs :: ByteString
_hs, rest :: 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 ("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]
++ " 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 e :: 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 hs :: [([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 maxCount :: Int64
maxCount h :: Handle
h bs :: ByteString
bs = Int64 -> Handle -> Int64 -> ByteString -> IO (Bool, Int64)
hPutLimit' Int64
maxCount Handle
h 0 ByteString
bs
{-# INLINE hPutLimit #-}

hPutLimit' :: Int64 -> Handle -> Int64 -> L.ByteString -> IO (Bool, Int64)
hPutLimit' :: Int64 -> Handle -> Int64 -> ByteString -> IO (Bool, Int64)
hPutLimit' _maxCount :: Int64
_maxCount _h :: Handle
_h count :: Int64
count Empty = (Bool, Int64) -> IO (Bool, Int64)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Int64
count)
hPutLimit'  maxCount :: Int64
maxCount h :: Handle
h  count :: Int64
count (Chunk c :: ByteString
c cs :: 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 inputWorker :: Work -> IO InputIter
inputWorker (BodyPart rawHS :: ByteString
rawHS b :: ByteString
b) =
    do InputIter
r <- Work -> IO InputIter
inputWorker (ByteString -> Work
HeaderWork ByteString
rawHS)
       case InputIter
r of
         (Failed i :: Maybe ([Char], Input)
i e :: [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 hs :: [([Char], [Char])]
hs cont :: 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 "form-data" ps :: [([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
                            Nothing -> ByteString -> Either [Char] ByteString
forall a b. b -> Either a b
Right ByteString
b
                            Just (ContentTransferEncoding "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 "8bit") ->
                                ByteString -> Either [Char] ByteString
forall a b. b -> Either a b
Right ByteString
b
                            Just (ContentTransferEncoding "binary") ->
                                ByteString -> Either [Char] ByteString
forall a b. b -> Either a b
Right ByteString
b
                            Just (ContentTransferEncoding "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 cte :: ContentTransferEncoding
cte ->
                                [Char] -> Either [Char] ByteString
forall a b. a -> Either a b
Left ("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 b' :: ByteString
b' ->
                          Work -> IO InputIter
cont (ContentType -> [([Char], [Char])] -> ByteString -> Work
BodyWork ContentType
ctype [([Char], [Char])]
ps ByteString
b')
                      Left err :: [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
              cd :: 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 ("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 "bodyPartToInput: Got unexpected BodyResult."

bodyPartsToInputs :: InputWorker -> [BodyPart] -> IO ([(String,Input)], Maybe String)
bodyPartsToInputs :: (Work -> IO InputIter)
-> [BodyPart] -> IO ([([Char], Input)], Maybe [Char])
bodyPartsToInputs _ [] =
    ([([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 inputWorker :: Work -> IO InputIter
inputWorker (b :: BodyPart
b:bs :: [BodyPart]
bs) =
    do InputIter
r <- (Work -> IO InputIter) -> BodyPart -> IO InputIter
bodyPartToInput Work -> IO InputIter
inputWorker BodyPart
b
       case InputIter
r of
         (Failed mInput :: Maybe ([Char], Input)
mInput e :: [Char]
e) ->
             case Maybe ([Char], Input)
mInput of
               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 i :: ([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 i :: ([Char], Input)
i cont :: Work -> IO InputIter
cont) ->
             do (is :: [([Char], Input)]
is, err :: 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], 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 "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 inputWorker :: Work -> IO InputIter
inputWorker boundary :: ByteString
boundary s :: ByteString
s =
    do let (bodyParts :: [BodyPart]
bodyParts, mErr :: Maybe [Char]
mErr) = ByteString -> ByteString -> ([BodyPart], Maybe [Char])
parseMultipartBody ByteString
boundary ByteString
s
       (inputs :: [([Char], Input)]
inputs, mErr2 :: 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 v :: [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 "text" "plain" [] -- FIXME: use some default encoding?

parseMultipartBody :: L.ByteString -> L.ByteString -> ([BodyPart], Maybe String)
parseMultipartBody :: ByteString -> ByteString -> ([BodyPart], Maybe [Char])
parseMultipartBody boundary :: ByteString
boundary s :: ByteString
s =
    case ByteString -> ByteString -> (ByteString, Maybe [Char])
dropPreamble ByteString
boundary ByteString
s of
      (_partData :: ByteString
_partData, Just e :: [Char]
e)  -> ([], [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
e)
      (partData :: ByteString
partData,  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 b :: ByteString
b s :: 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
$ "Boundary " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
L.unpack ByteString
b [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ " 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 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 b :: ByteString
b s :: ByteString
s = ByteString -> Bool
startsWithDashes ByteString
s Bool -> Bool -> Bool
&& ByteString
b ByteString -> ByteString -> Bool
`L.isPrefixOf` Int64 -> ByteString -> ByteString
L.drop 2 ByteString
s

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

splitParts :: L.ByteString -> L.ByteString -> ([BodyPart], Maybe String)
splitParts :: ByteString -> ByteString -> ([BodyPart], Maybe [Char])
splitParts boundary :: ByteString
boundary s :: ByteString
s =
--    | not (isBoundary boundary s) = ([], Just $ "Missing boundary: " ++ L.unpack boundary ++ "\n" ++ L.unpack s)
    case ByteString -> Bool
L.null ByteString
s of
      True -> ([], Maybe [Char]
forall a. Maybe a
Nothing)
      False ->
          case ByteString -> ByteString -> (BodyPart, ByteString)
splitPart ByteString
boundary ByteString
s of
            (p :: BodyPart
p, s' :: ByteString
s') ->
                let (ps :: [BodyPart]
ps,e :: 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 boundary :: ByteString
boundary s :: ByteString
s =
    case ByteString -> (ByteString, ByteString)
splitBlank ByteString
s of
      (headers :: ByteString
headers, rest :: ByteString
rest) ->
          case ByteString -> ByteString -> (ByteString, ByteString)
splitBoundary ByteString
boundary (Int64 -> ByteString -> ByteString
L.drop 4 ByteString
rest) of
            (body :: ByteString
body, rest' :: 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 s :: 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 boundary :: ByteString
boundary s :: 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 "\r\n--" ByteString -> ByteString -> ByteString
`L.append` ByteString
boundary)) ByteString
s of
      (x :: ByteString
x,y :: ByteString
y) | ([Char] -> ByteString
L.pack "\r\n--" ByteString -> ByteString -> ByteString
`L.append` ByteString
boundary ByteString -> ByteString -> ByteString
`L.append` ([Char] -> ByteString
L.pack "--"))
                ByteString -> ByteString -> Bool
`L.isPrefixOf` ByteString
y -> (ByteString
x, ByteString
L.empty)
            | Bool
otherwise -> (ByteString
x, ByteString -> ByteString
dropLine (Int64 -> ByteString -> ByteString
L.drop 2 ByteString
y))
{-# INLINE splitBoundary #-}

splitAtEmptyLine :: L.ByteString -> Maybe (L.ByteString, L.ByteString)
splitAtEmptyLine :: ByteString -> Maybe (ByteString, ByteString)
splitAtEmptyLine s :: ByteString
s =
    case ByteString -> (ByteString, ByteString)
splitBlank ByteString
s of
      (before :: ByteString
before, after :: 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 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 s :: 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
      (before :: ByteString
before, after :: 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 2 ByteString
after)
{-# INLINE splitAtCRLF #-}