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)
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
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
| L.ByteString
type InputWorker = Work -> IO InputIter
data InputIter
= Failed (Maybe (String, Input)) String
| BodyResult (String, Input) InputWorker
| [Header] InputWorker
type FileSaver = FilePath
-> Int64
-> FilePath
-> L.ByteString
-> IO (Bool, Int64 , FilePath)
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' #-}
bodyPartToInput :: InputWorker -> BodyPart -> IO InputIter
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") ->
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
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)
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
}
defaultInputType :: ContentType
defaultInputType :: ContentType
defaultInputType = [Char] -> [Char] -> [([Char], [Char])] -> ContentType
ContentType "text" "plain" []
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)
isBoundary :: L.ByteString
-> 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
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 =
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 #-}
splitAtCRLF :: ByteString
-> Maybe (ByteString,ByteString)
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 #-}