{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
module Network.Wai.Parse
( parseHttpAccept
, parseRequestBody
, RequestBodyType (..)
, getRequestBodyType
, sinkRequestBody
, sinkRequestBodyEx
, BackEnd
, lbsBackEnd
, tempFileBackEnd
, tempFileBackEndOpts
, Param
, File
, FileInfo (..)
, parseContentType
, ParseRequestBodyOptions
, defaultParseRequestBodyOptions
, noLimitParseRequestBodyOptions
, parseRequestBodyEx
, setMaxRequestKeyLength
, clearMaxRequestKeyLength
, setMaxRequestNumFiles
, clearMaxRequestNumFiles
, setMaxRequestFileSize
, clearMaxRequestFileSize
, setMaxRequestFilesSize
, clearMaxRequestFilesSize
, setMaxRequestParmsSize
, clearMaxRequestParmsSize
, setMaxHeaderLines
, clearMaxHeaderLines
, setMaxHeaderLineLength
, clearMaxHeaderLineLength
#if TEST
, Bound (..)
, findBound
, sinkTillBound
, killCR
, killCRLF
, takeLine
#endif
) where
import Prelude hiding (lines)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import Data.CaseInsensitive (mk)
import Control.Exception (catchJust)
import qualified Control.Exception as E
import Control.Monad (guard, unless, when)
import Control.Monad.Trans.Resource (InternalState, allocate, register, release, runInternalState)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.Function (fix, on)
import Data.IORef
import Data.Int (Int64)
import Data.List (sortBy)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Word (Word8)
import Network.HTTP.Types (hContentType)
import qualified Network.HTTP.Types as H
import Network.Wai
import System.Directory (getTemporaryDirectory, removeFile)
import System.IO (hClose, openBinaryTempFile)
import System.IO.Error (isDoesNotExistError)
#if MIN_VERSION_http2(3,0,0)
import Network.HTTP2.Frame (ErrorCodeId (..), HTTP2Error (..))
#else
import Network.HTTP2 (ErrorCodeId (..), HTTP2Error (..))
#endif
breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
breakDiscard :: Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard Word8
w ByteString
s =
let (ByteString
x, ByteString
y) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
w) ByteString
s
in (ByteString
x, Int -> ByteString -> ByteString
S.drop Int
1 ByteString
y)
parseHttpAccept :: S.ByteString -> [S.ByteString]
parseHttpAccept :: ByteString -> [ByteString]
parseHttpAccept = ((ByteString, (Double, Int)) -> ByteString)
-> [(ByteString, (Double, Int))] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, (Double, Int)) -> ByteString
forall a b. (a, b) -> a
fst
([(ByteString, (Double, Int))] -> [ByteString])
-> (ByteString -> [(ByteString, (Double, Int))])
-> ByteString
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, (Double, Int))
-> (ByteString, (Double, Int)) -> Ordering)
-> [(ByteString, (Double, Int))] -> [(ByteString, (Double, Int))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Double, Int) -> (Double, Int) -> Ordering
rcompare ((Double, Int) -> (Double, Int) -> Ordering)
-> ((ByteString, (Double, Int)) -> (Double, Int))
-> (ByteString, (Double, Int))
-> (ByteString, (Double, Int))
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (ByteString, (Double, Int)) -> (Double, Int)
forall a b. (a, b) -> b
snd)
([(ByteString, (Double, Int))] -> [(ByteString, (Double, Int))])
-> (ByteString -> [(ByteString, (Double, Int))])
-> ByteString
-> [(ByteString, (Double, Int))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> (ByteString, (Double, Int)))
-> [ByteString] -> [(ByteString, (Double, Int))]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString, Double) -> (ByteString, (Double, Int))
forall a. (ByteString, a) -> (ByteString, (a, Int))
addSpecificity ((ByteString, Double) -> (ByteString, (Double, Int)))
-> (ByteString -> (ByteString, Double))
-> ByteString
-> (ByteString, (Double, Int))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> (ByteString, Double)
forall b. (Read b, Fractional b) => ByteString -> (ByteString, b)
grabQ)
([ByteString] -> [(ByteString, (Double, Int))])
-> (ByteString -> [ByteString])
-> ByteString
-> [(ByteString, (Double, Int))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> [ByteString]
S.split Word8
44
where
rcompare :: (Double,Int) -> (Double,Int) -> Ordering
rcompare :: (Double, Int) -> (Double, Int) -> Ordering
rcompare = ((Double, Int) -> (Double, Int) -> Ordering)
-> (Double, Int) -> (Double, Int) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Double, Int) -> (Double, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
addSpecificity :: (ByteString, a) -> (ByteString, (a, Int))
addSpecificity (ByteString
s, a
q) =
let semicolons :: Int
semicolons = Word8 -> ByteString -> Int
S.count Word8
0x3B ByteString
s
stars :: Int
stars = Word8 -> ByteString -> Int
S.count Word8
0x2A ByteString
s
in (ByteString
s, (a
q, Int
semicolons Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
stars))
grabQ :: ByteString -> (ByteString, b)
grabQ ByteString
s =
let (ByteString
s', ByteString
q) = ByteString -> ByteString -> (ByteString, ByteString)
S.breakSubstring ByteString
";q=" ((Word8 -> Bool) -> ByteString -> ByteString
S.filter (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/=Word8
0x20) ByteString
s)
q' :: ByteString
q' = (Word8 -> Bool) -> ByteString -> ByteString
S.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/=Word8
0x3B) (Int -> ByteString -> ByteString
S.drop Int
3 ByteString
q)
in (ByteString
s', ByteString -> b
forall p. (Read p, Fractional p) => ByteString -> p
readQ ByteString
q')
readQ :: ByteString -> p
readQ ByteString
s = case ReadS p
forall a. Read a => ReadS a
reads ReadS p -> ReadS p
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
S8.unpack ByteString
s of
(p
x, [Char]
_):[(p, [Char])]
_ -> p
x
[(p, [Char])]
_ -> p
1.0
lbsBackEnd :: Monad m => ignored1 -> ignored2 -> m S.ByteString -> m L.ByteString
lbsBackEnd :: ignored1 -> ignored2 -> m ByteString -> m ByteString
lbsBackEnd ignored1
_ ignored2
_ m ByteString
popper =
([ByteString] -> [ByteString]) -> m ByteString
loop [ByteString] -> [ByteString]
forall a. a -> a
id
where
loop :: ([ByteString] -> [ByteString]) -> m ByteString
loop [ByteString] -> [ByteString]
front = do
ByteString
bs <- m ByteString
popper
if ByteString -> Bool
S.null ByteString
bs
then ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
L.fromChunks ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
front []
else ([ByteString] -> [ByteString]) -> m ByteString
loop (([ByteString] -> [ByteString]) -> m ByteString)
-> ([ByteString] -> [ByteString]) -> m ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
front ([ByteString] -> [ByteString])
-> ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
bsByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:)
tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> IO S.ByteString -> IO FilePath
tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> IO ByteString -> IO [Char]
tempFileBackEnd = IO [Char]
-> [Char]
-> InternalState
-> ignored1
-> ignored2
-> IO ByteString
-> IO [Char]
forall ignored1 ignored2.
IO [Char]
-> [Char]
-> InternalState
-> ignored1
-> ignored2
-> IO ByteString
-> IO [Char]
tempFileBackEndOpts IO [Char]
getTemporaryDirectory [Char]
"webenc.buf"
tempFileBackEndOpts :: IO FilePath
-> String
-> InternalState
-> ignored1
-> ignored2
-> IO S.ByteString
-> IO FilePath
tempFileBackEndOpts :: IO [Char]
-> [Char]
-> InternalState
-> ignored1
-> ignored2
-> IO ByteString
-> IO [Char]
tempFileBackEndOpts IO [Char]
getTmpDir [Char]
pattrn InternalState
internalState ignored1
_ ignored2
_ IO ByteString
popper = do
(ReleaseKey
key, ([Char]
fp, Handle
h)) <- (ResourceT IO (ReleaseKey, ([Char], Handle))
-> InternalState -> IO (ReleaseKey, ([Char], Handle)))
-> InternalState
-> ResourceT IO (ReleaseKey, ([Char], Handle))
-> IO (ReleaseKey, ([Char], Handle))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ResourceT IO (ReleaseKey, ([Char], Handle))
-> InternalState -> IO (ReleaseKey, ([Char], Handle))
forall (m :: * -> *) a. ResourceT m a -> InternalState -> m a
runInternalState InternalState
internalState (ResourceT IO (ReleaseKey, ([Char], Handle))
-> IO (ReleaseKey, ([Char], Handle)))
-> ResourceT IO (ReleaseKey, ([Char], Handle))
-> IO (ReleaseKey, ([Char], Handle))
forall a b. (a -> b) -> a -> b
$ IO ([Char], Handle)
-> (([Char], Handle) -> IO ())
-> ResourceT IO (ReleaseKey, ([Char], Handle))
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate IO ([Char], Handle)
it (Handle -> IO ()
hClose (Handle -> IO ())
-> (([Char], Handle) -> Handle) -> ([Char], Handle) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], Handle) -> Handle
forall a b. (a, b) -> b
snd)
ReleaseKey
_ <- ResourceT IO ReleaseKey -> InternalState -> IO ReleaseKey
forall (m :: * -> *) a. ResourceT m a -> InternalState -> m a
runInternalState (IO () -> ResourceT IO ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register (IO () -> ResourceT IO ReleaseKey)
-> IO () -> ResourceT IO ReleaseKey
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
removeFileQuiet [Char]
fp) InternalState
internalState
(IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
ByteString
bs <- IO ByteString
popper
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Handle -> ByteString -> IO ()
S.hPut Handle
h ByteString
bs
IO ()
loop
ReleaseKey -> IO ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release ReleaseKey
key
[Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
fp
where
it :: IO ([Char], Handle)
it = do
[Char]
tempDir <- IO [Char]
getTmpDir
[Char] -> [Char] -> IO ([Char], Handle)
openBinaryTempFile [Char]
tempDir [Char]
pattrn
removeFileQuiet :: [Char] -> IO ()
removeFileQuiet [Char]
fp = (IOError -> Maybe ()) -> IO () -> (() -> IO ()) -> IO ()
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError)
([Char] -> IO ()
removeFile [Char]
fp)
(IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
data ParseRequestBodyOptions = ParseRequestBodyOptions
{
ParseRequestBodyOptions -> Maybe Int
prboKeyLength :: Maybe Int
,
ParseRequestBodyOptions -> Maybe Int
prboMaxNumFiles :: Maybe Int
,
ParseRequestBodyOptions -> Maybe Int64
prboMaxFileSize :: Maybe Int64
,
ParseRequestBodyOptions -> Maybe Int64
prboMaxFilesSize :: Maybe Int64
,
ParseRequestBodyOptions -> Maybe Int
prboMaxParmsSize :: Maybe Int
,
:: Maybe Int
,
:: Maybe Int }
setMaxRequestKeyLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestKeyLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestKeyLength Int
l ParseRequestBodyOptions
p = ParseRequestBodyOptions
p { prboKeyLength :: Maybe Int
prboKeyLength=Int -> Maybe Int
forall a. a -> Maybe a
Just Int
l }
clearMaxRequestKeyLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestKeyLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestKeyLength ParseRequestBodyOptions
p = ParseRequestBodyOptions
p { prboKeyLength :: Maybe Int
prboKeyLength=Maybe Int
forall a. Maybe a
Nothing }
setMaxRequestNumFiles :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestNumFiles :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestNumFiles Int
l ParseRequestBodyOptions
p = ParseRequestBodyOptions
p { prboMaxNumFiles :: Maybe Int
prboMaxNumFiles=Int -> Maybe Int
forall a. a -> Maybe a
Just Int
l }
clearMaxRequestNumFiles :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestNumFiles :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestNumFiles ParseRequestBodyOptions
p = ParseRequestBodyOptions
p { prboMaxNumFiles :: Maybe Int
prboMaxNumFiles=Maybe Int
forall a. Maybe a
Nothing }
setMaxRequestFileSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestFileSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestFileSize Int64
l ParseRequestBodyOptions
p = ParseRequestBodyOptions
p { prboMaxFileSize :: Maybe Int64
prboMaxFileSize=Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
l }
clearMaxRequestFileSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestFileSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestFileSize ParseRequestBodyOptions
p = ParseRequestBodyOptions
p { prboMaxFileSize :: Maybe Int64
prboMaxFileSize=Maybe Int64
forall a. Maybe a
Nothing }
setMaxRequestFilesSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestFilesSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestFilesSize Int64
l ParseRequestBodyOptions
p = ParseRequestBodyOptions
p { prboMaxFilesSize :: Maybe Int64
prboMaxFilesSize=Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
l }
clearMaxRequestFilesSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestFilesSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestFilesSize ParseRequestBodyOptions
p = ParseRequestBodyOptions
p { prboMaxFilesSize :: Maybe Int64
prboMaxFilesSize=Maybe Int64
forall a. Maybe a
Nothing }
setMaxRequestParmsSize :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestParmsSize :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestParmsSize Int
l ParseRequestBodyOptions
p = ParseRequestBodyOptions
p { prboMaxParmsSize :: Maybe Int
prboMaxParmsSize=Int -> Maybe Int
forall a. a -> Maybe a
Just Int
l }
clearMaxRequestParmsSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestParmsSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestParmsSize ParseRequestBodyOptions
p = ParseRequestBodyOptions
p { prboMaxParmsSize :: Maybe Int
prboMaxParmsSize=Maybe Int
forall a. Maybe a
Nothing }
setMaxHeaderLines :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
Int
l ParseRequestBodyOptions
p = ParseRequestBodyOptions
p { prboMaxHeaderLines :: Maybe Int
prboMaxHeaderLines=Int -> Maybe Int
forall a. a -> Maybe a
Just Int
l }
clearMaxHeaderLines:: ParseRequestBodyOptions -> ParseRequestBodyOptions
ParseRequestBodyOptions
p = ParseRequestBodyOptions
p { prboMaxHeaderLines :: Maybe Int
prboMaxHeaderLines=Maybe Int
forall a. Maybe a
Nothing }
setMaxHeaderLineLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
Int
l ParseRequestBodyOptions
p = ParseRequestBodyOptions
p { prboMaxHeaderLineLength :: Maybe Int
prboMaxHeaderLineLength=Int -> Maybe Int
forall a. a -> Maybe a
Just Int
l }
clearMaxHeaderLineLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions
ParseRequestBodyOptions
p = ParseRequestBodyOptions
p { prboMaxHeaderLineLength :: Maybe Int
prboMaxHeaderLineLength=Maybe Int
forall a. Maybe a
Nothing }
defaultParseRequestBodyOptions :: ParseRequestBodyOptions
defaultParseRequestBodyOptions :: ParseRequestBodyOptions
defaultParseRequestBodyOptions = ParseRequestBodyOptions :: Maybe Int
-> Maybe Int
-> Maybe Int64
-> Maybe Int64
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> ParseRequestBodyOptions
ParseRequestBodyOptions
{ prboKeyLength :: Maybe Int
prboKeyLength=Int -> Maybe Int
forall a. a -> Maybe a
Just Int
32
, prboMaxNumFiles :: Maybe Int
prboMaxNumFiles=Int -> Maybe Int
forall a. a -> Maybe a
Just Int
10
, prboMaxFileSize :: Maybe Int64
prboMaxFileSize=Maybe Int64
forall a. Maybe a
Nothing
, prboMaxFilesSize :: Maybe Int64
prboMaxFilesSize=Maybe Int64
forall a. Maybe a
Nothing
, prboMaxParmsSize :: Maybe Int
prboMaxParmsSize=Int -> Maybe Int
forall a. a -> Maybe a
Just Int
65336
, prboMaxHeaderLines :: Maybe Int
prboMaxHeaderLines=Int -> Maybe Int
forall a. a -> Maybe a
Just Int
32
, prboMaxHeaderLineLength :: Maybe Int
prboMaxHeaderLineLength=Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8190 }
noLimitParseRequestBodyOptions :: ParseRequestBodyOptions
noLimitParseRequestBodyOptions :: ParseRequestBodyOptions
noLimitParseRequestBodyOptions = ParseRequestBodyOptions :: Maybe Int
-> Maybe Int
-> Maybe Int64
-> Maybe Int64
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> ParseRequestBodyOptions
ParseRequestBodyOptions
{ prboKeyLength :: Maybe Int
prboKeyLength=Maybe Int
forall a. Maybe a
Nothing
, prboMaxNumFiles :: Maybe Int
prboMaxNumFiles=Maybe Int
forall a. Maybe a
Nothing
, prboMaxFileSize :: Maybe Int64
prboMaxFileSize=Maybe Int64
forall a. Maybe a
Nothing
, prboMaxFilesSize :: Maybe Int64
prboMaxFilesSize=Maybe Int64
forall a. Maybe a
Nothing
, prboMaxParmsSize :: Maybe Int
prboMaxParmsSize=Maybe Int
forall a. Maybe a
Nothing
, prboMaxHeaderLines :: Maybe Int
prboMaxHeaderLines=Maybe Int
forall a. Maybe a
Nothing
, prboMaxHeaderLineLength :: Maybe Int
prboMaxHeaderLineLength=Maybe Int
forall a. Maybe a
Nothing }
data FileInfo c = FileInfo
{ FileInfo c -> ByteString
fileName :: S.ByteString
, FileInfo c -> ByteString
fileContentType :: S.ByteString
, FileInfo c -> c
fileContent :: c
}
deriving (FileInfo c -> FileInfo c -> Bool
(FileInfo c -> FileInfo c -> Bool)
-> (FileInfo c -> FileInfo c -> Bool) -> Eq (FileInfo c)
forall c. Eq c => FileInfo c -> FileInfo c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileInfo c -> FileInfo c -> Bool
$c/= :: forall c. Eq c => FileInfo c -> FileInfo c -> Bool
== :: FileInfo c -> FileInfo c -> Bool
$c== :: forall c. Eq c => FileInfo c -> FileInfo c -> Bool
Eq, Int -> FileInfo c -> ShowS
[FileInfo c] -> ShowS
FileInfo c -> [Char]
(Int -> FileInfo c -> ShowS)
-> (FileInfo c -> [Char])
-> ([FileInfo c] -> ShowS)
-> Show (FileInfo c)
forall c. Show c => Int -> FileInfo c -> ShowS
forall c. Show c => [FileInfo c] -> ShowS
forall c. Show c => FileInfo c -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FileInfo c] -> ShowS
$cshowList :: forall c. Show c => [FileInfo c] -> ShowS
show :: FileInfo c -> [Char]
$cshow :: forall c. Show c => FileInfo c -> [Char]
showsPrec :: Int -> FileInfo c -> ShowS
$cshowsPrec :: forall c. Show c => Int -> FileInfo c -> ShowS
Show)
type Param = (S.ByteString, S.ByteString)
type File y = (S.ByteString, FileInfo y)
type BackEnd a = S.ByteString
-> FileInfo ()
-> IO S.ByteString
-> IO a
data RequestBodyType
=
UrlEncoded
|
Multipart S.ByteString
getRequestBodyType :: Request -> Maybe RequestBodyType
getRequestBodyType :: Request -> Maybe RequestBodyType
getRequestBodyType Request
req = do
ByteString
ctype' <- HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
req
let (ByteString
ctype, [(ByteString, ByteString)]
attrs) = ByteString -> (ByteString, [(ByteString, ByteString)])
parseContentType ByteString
ctype'
case ByteString
ctype of
ByteString
"application/x-www-form-urlencoded" -> RequestBodyType -> Maybe RequestBodyType
forall (m :: * -> *) a. Monad m => a -> m a
return RequestBodyType
UrlEncoded
ByteString
"multipart/form-data" | Just ByteString
bound <- ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"boundary" [(ByteString, ByteString)]
attrs -> RequestBodyType -> Maybe RequestBodyType
forall (m :: * -> *) a. Monad m => a -> m a
return (RequestBodyType -> Maybe RequestBodyType)
-> RequestBodyType -> Maybe RequestBodyType
forall a b. (a -> b) -> a -> b
$ ByteString -> RequestBodyType
Multipart ByteString
bound
ByteString
_ -> Maybe RequestBodyType
forall a. Maybe a
Nothing
parseContentType :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)])
parseContentType :: ByteString -> (ByteString, [(ByteString, ByteString)])
parseContentType ByteString
a = do
let (ByteString
ctype, ByteString
b) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
semicolon) ByteString
a
attrs :: [(ByteString, ByteString)]
attrs = ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> ByteString -> [(ByteString, ByteString)]
goAttrs [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> a
id (ByteString -> [(ByteString, ByteString)])
-> ByteString -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.drop Int
1 ByteString
b
in (ByteString
ctype, [(ByteString, ByteString)]
attrs)
where
semicolon :: Word8
semicolon = Word8
59
equals :: Word8
equals = Word8
61
space :: Word8
space = Word8
32
dq :: ByteString -> ByteString
dq ByteString
s = if ByteString -> Int
S.length ByteString
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2 Bool -> Bool -> Bool
&& ByteString -> Word8
S.head ByteString
s Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
34 Bool -> Bool -> Bool
&& ByteString -> Word8
S.last ByteString
s Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
34
then ByteString -> ByteString
S.tail (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
S.init ByteString
s
else ByteString
s
goAttrs :: ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> ByteString -> [(ByteString, ByteString)]
goAttrs [(ByteString, ByteString)] -> [(ByteString, ByteString)]
front ByteString
bs
| ByteString -> Bool
S.null ByteString
bs = [(ByteString, ByteString)] -> [(ByteString, ByteString)]
front []
| Bool
otherwise =
let (ByteString
x, ByteString
rest) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
semicolon) ByteString
bs
in ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> ByteString -> [(ByteString, ByteString)]
goAttrs ([(ByteString, ByteString)] -> [(ByteString, ByteString)]
front ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)]
-> [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> (ByteString, ByteString)
goAttr ByteString
x(ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
:)) (ByteString -> [(ByteString, ByteString)])
-> ByteString -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.drop Int
1 ByteString
rest
goAttr :: ByteString -> (ByteString, ByteString)
goAttr ByteString
bs =
let (ByteString
k, ByteString
v') = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
equals) ByteString
bs
v :: ByteString
v = Int -> ByteString -> ByteString
S.drop Int
1 ByteString
v'
in (ByteString -> ByteString
strip ByteString
k, ByteString -> ByteString
dq (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
strip ByteString
v)
strip :: ByteString -> ByteString
strip = (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
space) (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.breakEnd (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
space)
parseRequestBody :: BackEnd y
-> Request
-> IO ([Param], [File y])
parseRequestBody :: BackEnd y -> Request -> IO ([(ByteString, ByteString)], [File y])
parseRequestBody = ParseRequestBodyOptions
-> BackEnd y
-> Request
-> IO ([(ByteString, ByteString)], [File y])
forall y.
ParseRequestBodyOptions
-> BackEnd y
-> Request
-> IO ([(ByteString, ByteString)], [File y])
parseRequestBodyEx ParseRequestBodyOptions
noLimitParseRequestBodyOptions
parseRequestBodyEx :: ParseRequestBodyOptions
-> BackEnd y
-> Request
-> IO ([Param], [File y])
parseRequestBodyEx :: ParseRequestBodyOptions
-> BackEnd y
-> Request
-> IO ([(ByteString, ByteString)], [File y])
parseRequestBodyEx ParseRequestBodyOptions
o BackEnd y
s Request
r =
case Request -> Maybe RequestBodyType
getRequestBodyType Request
r of
Maybe RequestBodyType
Nothing -> ([(ByteString, ByteString)], [File y])
-> IO ([(ByteString, ByteString)], [File y])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
Just RequestBodyType
rbt -> ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO ByteString
-> IO ([(ByteString, ByteString)], [File y])
forall y.
ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO ByteString
-> IO ([(ByteString, ByteString)], [File y])
sinkRequestBodyEx ParseRequestBodyOptions
o BackEnd y
s RequestBodyType
rbt (Request -> IO ByteString
requestBody Request
r)
sinkRequestBody :: BackEnd y
-> RequestBodyType
-> IO S.ByteString
-> IO ([Param], [File y])
sinkRequestBody :: BackEnd y
-> RequestBodyType
-> IO ByteString
-> IO ([(ByteString, ByteString)], [File y])
sinkRequestBody = ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO ByteString
-> IO ([(ByteString, ByteString)], [File y])
forall y.
ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO ByteString
-> IO ([(ByteString, ByteString)], [File y])
sinkRequestBodyEx ParseRequestBodyOptions
noLimitParseRequestBodyOptions
sinkRequestBodyEx :: ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO S.ByteString
-> IO ([Param], [File y])
sinkRequestBodyEx :: ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO ByteString
-> IO ([(ByteString, ByteString)], [File y])
sinkRequestBodyEx ParseRequestBodyOptions
o BackEnd y
s RequestBodyType
r IO ByteString
body = do
IORef ([(ByteString, ByteString)], [File y])
ref <- ([(ByteString, ByteString)], [File y])
-> IO (IORef ([(ByteString, ByteString)], [File y]))
forall a. a -> IO (IORef a)
newIORef ([], [])
let add :: Either (ByteString, ByteString) (File y) -> IO ()
add Either (ByteString, ByteString) (File y)
x = IORef ([(ByteString, ByteString)], [File y])
-> (([(ByteString, ByteString)], [File y])
-> (([(ByteString, ByteString)], [File y]), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef ([(ByteString, ByteString)], [File y])
ref ((([(ByteString, ByteString)], [File y])
-> (([(ByteString, ByteString)], [File y]), ()))
-> IO ())
-> (([(ByteString, ByteString)], [File y])
-> (([(ByteString, ByteString)], [File y]), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \([(ByteString, ByteString)]
y, [File y]
z) ->
case Either (ByteString, ByteString) (File y)
x of
Left (ByteString, ByteString)
y' -> (((ByteString, ByteString)
y'(ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
:[(ByteString, ByteString)]
y, [File y]
z), ())
Right File y
z' -> (([(ByteString, ByteString)]
y, File y
z'File y -> [File y] -> [File y]
forall a. a -> [a] -> [a]
:[File y]
z), ())
ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO ByteString
-> (Either (ByteString, ByteString) (File y) -> IO ())
-> IO ()
forall y.
ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO ByteString
-> (Either (ByteString, ByteString) (File y) -> IO ())
-> IO ()
conduitRequestBodyEx ParseRequestBodyOptions
o BackEnd y
s RequestBodyType
r IO ByteString
body Either (ByteString, ByteString) (File y) -> IO ()
add
(\([(ByteString, ByteString)]
a, [File y]
b) -> ([(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [a] -> [a]
reverse [(ByteString, ByteString)]
a, [File y] -> [File y]
forall a. [a] -> [a]
reverse [File y]
b)) (([(ByteString, ByteString)], [File y])
-> ([(ByteString, ByteString)], [File y]))
-> IO ([(ByteString, ByteString)], [File y])
-> IO ([(ByteString, ByteString)], [File y])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef ([(ByteString, ByteString)], [File y])
-> IO ([(ByteString, ByteString)], [File y])
forall a. IORef a -> IO a
readIORef IORef ([(ByteString, ByteString)], [File y])
ref
conduitRequestBodyEx :: ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO S.ByteString
-> (Either Param (File y) -> IO ())
-> IO ()
conduitRequestBodyEx :: ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO ByteString
-> (Either (ByteString, ByteString) (File y) -> IO ())
-> IO ()
conduitRequestBodyEx ParseRequestBodyOptions
o BackEnd y
_ RequestBodyType
UrlEncoded IO ByteString
rbody Either (ByteString, ByteString) (File y) -> IO ()
add = do
let loop :: Int -> ([ByteString] -> [ByteString]) -> IO ByteString
loop Int
size [ByteString] -> [ByteString]
front = do
ByteString
bs <- IO ByteString
rbody
if ByteString -> Bool
S.null ByteString
bs
then ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
front []
else do
let newsize :: Int
newsize = Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
bs
case ParseRequestBodyOptions -> Maybe Int
prboMaxParmsSize ParseRequestBodyOptions
o of
Just Int
maxSize -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
newsize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Maximum size of parameters exceeded"
Maybe Int
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Int -> ([ByteString] -> [ByteString]) -> IO ByteString
loop Int
newsize (([ByteString] -> [ByteString]) -> IO ByteString)
-> ([ByteString] -> [ByteString]) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
front ([ByteString] -> [ByteString])
-> ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
bsByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:)
ByteString
bs <- Int -> ([ByteString] -> [ByteString]) -> IO ByteString
loop Int
0 [ByteString] -> [ByteString]
forall a. a -> a
id
((ByteString, ByteString) -> IO ())
-> [(ByteString, ByteString)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Either (ByteString, ByteString) (File y) -> IO ()
add (Either (ByteString, ByteString) (File y) -> IO ())
-> ((ByteString, ByteString)
-> Either (ByteString, ByteString) (File y))
-> (ByteString, ByteString)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString)
-> Either (ByteString, ByteString) (File y)
forall a b. a -> Either a b
Left) ([(ByteString, ByteString)] -> IO ())
-> [(ByteString, ByteString)] -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, ByteString)]
H.parseSimpleQuery ByteString
bs
conduitRequestBodyEx ParseRequestBodyOptions
o BackEnd y
backend (Multipart ByteString
bound) IO ByteString
rbody Either (ByteString, ByteString) (File y) -> IO ()
add =
ParseRequestBodyOptions
-> BackEnd y
-> ByteString
-> IO ByteString
-> (Either (ByteString, ByteString) (File y) -> IO ())
-> IO ()
forall y.
ParseRequestBodyOptions
-> BackEnd y
-> ByteString
-> IO ByteString
-> (Either (ByteString, ByteString) (File y) -> IO ())
-> IO ()
parsePiecesEx ParseRequestBodyOptions
o BackEnd y
backend ([Char] -> ByteString
S8.pack [Char]
"--" ByteString -> ByteString -> ByteString
`S.append` ByteString
bound) IO ByteString
rbody Either (ByteString, ByteString) (File y) -> IO ()
add
takeLine :: Maybe Int -> Source -> IO (Maybe S.ByteString)
takeLine :: Maybe Int -> Source -> IO (Maybe ByteString)
takeLine Maybe Int
maxlen Source
src =
ByteString -> IO (Maybe ByteString)
go ByteString
""
where
go :: ByteString -> IO (Maybe ByteString)
go ByteString
front = do
ByteString
bs <- Source -> IO ByteString
readSource Source
src
case Maybe Int
maxlen of
Just Int
maxlen' -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
front Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxlen') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError (ErrorCode -> ErrorCodeId
UnknownErrorCode ErrorCode
431)
ByteString
"Request Header Fields Too Large"
Maybe Int
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
if ByteString -> Bool
S.null ByteString
bs
then ByteString -> IO (Maybe ByteString)
close ByteString
front
else ByteString -> ByteString -> IO (Maybe ByteString)
push ByteString
front ByteString
bs
close :: ByteString -> IO (Maybe ByteString)
close ByteString
front = Source -> ByteString -> IO ()
leftover Source
src ByteString
front IO () -> IO (Maybe ByteString) -> IO (Maybe ByteString)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
push :: ByteString -> ByteString -> IO (Maybe ByteString)
push ByteString
front ByteString
bs = do
let (ByteString
x, ByteString
y) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
10) ByteString
bs
in if ByteString -> Bool
S.null ByteString
y
then ByteString -> IO (Maybe ByteString)
go (ByteString -> IO (Maybe ByteString))
-> ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString
front ByteString -> ByteString -> ByteString
`S.append` ByteString
x
else do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Source -> ByteString -> IO ()
leftover Source
src (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.drop Int
1 ByteString
y
let res :: ByteString
res = ByteString
front ByteString -> ByteString -> ByteString
`S.append` ByteString
x
case Maybe Int
maxlen of
Just Int
maxlen' -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
res Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxlen') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError (ErrorCode -> ErrorCodeId
UnknownErrorCode ErrorCode
431)
ByteString
"Request Header Fields Too Large"
Maybe Int
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> (ByteString -> Maybe ByteString)
-> ByteString
-> IO (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> IO (Maybe ByteString))
-> ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
killCR ByteString
res
takeLines' :: Maybe Int -> Maybe Int -> Source -> IO [S.ByteString]
takeLines' :: Maybe Int -> Maybe Int -> Source -> IO [ByteString]
takeLines' Maybe Int
lineLength Maybe Int
maxLines Source
source =
[ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse ([ByteString] -> [ByteString])
-> IO [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteString] -> Maybe Int -> Maybe Int -> Source -> IO [ByteString]
takeLines'' [] Maybe Int
lineLength Maybe Int
maxLines Source
source
takeLines''
:: [S.ByteString]
-> Maybe Int
-> Maybe Int
-> Source
-> IO [S.ByteString]
takeLines'' :: [ByteString] -> Maybe Int -> Maybe Int -> Source -> IO [ByteString]
takeLines'' [ByteString]
lines Maybe Int
lineLength Maybe Int
maxLines Source
src = do
case Maybe Int
maxLines of
Just Int
maxLines' ->
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
lines Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxLines') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Too many lines in mime/multipart header"
Maybe Int
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe ByteString
res <- Maybe Int -> Source -> IO (Maybe ByteString)
takeLine Maybe Int
lineLength Source
src
case Maybe ByteString
res of
Maybe ByteString
Nothing -> [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString]
lines
Just ByteString
l
| ByteString -> Bool
S.null ByteString
l -> [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString]
lines
| Bool
otherwise -> [ByteString] -> Maybe Int -> Maybe Int -> Source -> IO [ByteString]
takeLines'' (ByteString
lByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
lines) Maybe Int
lineLength Maybe Int
maxLines Source
src
data Source = Source (IO S.ByteString) (IORef S.ByteString)
mkSource :: IO S.ByteString -> IO Source
mkSource :: IO ByteString -> IO Source
mkSource IO ByteString
f = do
IORef ByteString
ref <- ByteString -> IO (IORef ByteString)
forall a. a -> IO (IORef a)
newIORef ByteString
S.empty
Source -> IO Source
forall (m :: * -> *) a. Monad m => a -> m a
return (Source -> IO Source) -> Source -> IO Source
forall a b. (a -> b) -> a -> b
$ IO ByteString -> IORef ByteString -> Source
Source IO ByteString
f IORef ByteString
ref
readSource :: Source -> IO S.ByteString
readSource :: Source -> IO ByteString
readSource (Source IO ByteString
f IORef ByteString
ref) = do
ByteString
bs <- IORef ByteString
-> (ByteString -> (ByteString, ByteString)) -> IO ByteString
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef ByteString
ref ((ByteString -> (ByteString, ByteString)) -> IO ByteString)
-> (ByteString -> (ByteString, ByteString)) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ByteString
bs -> (ByteString
S.empty, ByteString
bs)
if ByteString -> Bool
S.null ByteString
bs
then IO ByteString
f
else ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
leftover :: Source -> S.ByteString -> IO ()
leftover :: Source -> ByteString -> IO ()
leftover (Source IO ByteString
_ IORef ByteString
ref) = IORef ByteString -> ByteString -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ByteString
ref
parsePiecesEx :: ParseRequestBodyOptions
-> BackEnd y
-> S.ByteString
-> IO S.ByteString
-> (Either Param (File y) -> IO ())
-> IO ()
parsePiecesEx :: ParseRequestBodyOptions
-> BackEnd y
-> ByteString
-> IO ByteString
-> (Either (ByteString, ByteString) (File y) -> IO ())
-> IO ()
parsePiecesEx ParseRequestBodyOptions
o BackEnd y
sink ByteString
bound IO ByteString
rbody Either (ByteString, ByteString) (File y) -> IO ()
add =
IO ByteString -> IO Source
mkSource IO ByteString
rbody IO Source -> (Source -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Int -> Int -> Int64 -> Source -> IO ()
loop Int
0 Int
0 Int
0 Int64
0
where
loop :: Int -> Int -> Int -> Int64 -> Source -> IO ()
loop :: Int -> Int -> Int -> Int64 -> Source -> IO ()
loop Int
numParms Int
numFiles Int
parmSize Int64
filesSize Source
src = do
Maybe ByteString
_boundLine <- Maybe Int -> Source -> IO (Maybe ByteString)
takeLine (ParseRequestBodyOptions -> Maybe Int
prboMaxHeaderLineLength ParseRequestBodyOptions
o) Source
src
[ByteString]
res' <- Maybe Int -> Maybe Int -> Source -> IO [ByteString]
takeLines' (ParseRequestBodyOptions -> Maybe Int
prboMaxHeaderLineLength ParseRequestBodyOptions
o)
(ParseRequestBodyOptions -> Maybe Int
prboMaxHeaderLines ParseRequestBodyOptions
o) Source
src
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
res') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let ls' :: [(HeaderName, ByteString)]
ls' = (ByteString -> (HeaderName, ByteString))
-> [ByteString] -> [(HeaderName, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> (HeaderName, ByteString)
parsePair [ByteString]
res'
let x :: Maybe (Maybe ByteString, ByteString, Maybe ByteString)
x = do
ByteString
cd <- HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
contDisp [(HeaderName, ByteString)]
ls'
let ct :: Maybe ByteString
ct = HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
contType [(HeaderName, ByteString)]
ls'
let attrs :: [(ByteString, ByteString)]
attrs = ByteString -> [(ByteString, ByteString)]
parseAttrs ByteString
cd
ByteString
name <- ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"name" [(ByteString, ByteString)]
attrs
(Maybe ByteString, ByteString, Maybe ByteString)
-> Maybe (Maybe ByteString, ByteString, Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString
ct, ByteString
name, ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"filename" [(ByteString, ByteString)]
attrs)
case Maybe (Maybe ByteString, ByteString, Maybe ByteString)
x of
Just (Maybe ByteString
mct, ByteString
name, Just ByteString
filename) -> do
case ParseRequestBodyOptions -> Maybe Int
prboKeyLength ParseRequestBodyOptions
o of
Just Int
maxKeyLength ->
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
name Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxKeyLength) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Filename is too long"
Maybe Int
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
case ParseRequestBodyOptions -> Maybe Int
prboMaxNumFiles ParseRequestBodyOptions
o of
Just Int
maxFiles -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
numFiles Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxFiles) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Maximum number of files exceeded"
Maybe Int
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
let ct :: ByteString
ct = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"application/octet-stream" Maybe ByteString
mct
fi0 :: FileInfo ()
fi0 = ByteString -> ByteString -> () -> FileInfo ()
forall c. ByteString -> ByteString -> c -> FileInfo c
FileInfo ByteString
filename ByteString
ct ()
fs :: [Int64]
fs = [Maybe Int64] -> [Int64]
forall a. [Maybe a] -> [a]
catMaybes [ ParseRequestBodyOptions -> Maybe Int64
prboMaxFileSize ParseRequestBodyOptions
o
, Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
subtract Int64
filesSize (Int64 -> Int64) -> Maybe Int64 -> Maybe Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseRequestBodyOptions -> Maybe Int64
prboMaxFilesSize ParseRequestBodyOptions
o ]
mfs :: Maybe Int64
mfs = if [Int64] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int64]
fs then Maybe Int64
forall a. Maybe a
Nothing else Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (Int64 -> Maybe Int64) -> Int64 -> Maybe Int64
forall a b. (a -> b) -> a -> b
$ [Int64] -> Int64
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int64]
fs
((Bool
wasFound, Int64
fileSize), y
y) <- ByteString
-> ByteString
-> FileInfo ()
-> BackEnd y
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), y)
forall y.
ByteString
-> ByteString
-> FileInfo ()
-> BackEnd y
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), y)
sinkTillBound' ByteString
bound ByteString
name FileInfo ()
fi0 BackEnd y
sink Source
src Maybe Int64
mfs
let newFilesSize :: Int64
newFilesSize = Int64
filesSize Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
fileSize
Either (ByteString, ByteString) (File y) -> IO ()
add (Either (ByteString, ByteString) (File y) -> IO ())
-> Either (ByteString, ByteString) (File y) -> IO ()
forall a b. (a -> b) -> a -> b
$ File y -> Either (ByteString, ByteString) (File y)
forall a b. b -> Either a b
Right (ByteString
name, FileInfo ()
fi0 { fileContent :: y
fileContent = y
y })
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wasFound (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int64 -> Source -> IO ()
loop Int
numParms (Int
numFiles Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
parmSize Int64
newFilesSize Source
src
Just (Maybe ByteString
_ct, ByteString
name, Maybe ByteString
Nothing) -> do
case ParseRequestBodyOptions -> Maybe Int
prboKeyLength ParseRequestBodyOptions
o of
Just Int
maxKeyLength ->
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
name Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxKeyLength) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Parameter name is too long"
Maybe Int
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
let seed :: a -> a
seed = a -> a
forall a. a -> a
id
let iter :: ([a] -> c) -> a -> m ([a] -> c)
iter [a] -> c
front a
bs = ([a] -> c) -> m ([a] -> c)
forall (m :: * -> *) a. Monad m => a -> m a
return (([a] -> c) -> m ([a] -> c)) -> ([a] -> c) -> m ([a] -> c)
forall a b. (a -> b) -> a -> b
$ [a] -> c
front ([a] -> c) -> ([a] -> [a]) -> [a] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) a
bs
((Bool
wasFound, Int64
_fileSize), [ByteString] -> [ByteString]
front) <- ByteString
-> (([ByteString] -> [ByteString])
-> ByteString -> IO ([ByteString] -> [ByteString]))
-> ([ByteString] -> [ByteString])
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), [ByteString] -> [ByteString])
forall x.
ByteString
-> (x -> ByteString -> IO x)
-> x
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), x)
sinkTillBound ByteString
bound ([ByteString] -> [ByteString])
-> ByteString -> IO ([ByteString] -> [ByteString])
forall (m :: * -> *) a c.
Monad m =>
([a] -> c) -> a -> m ([a] -> c)
iter [ByteString] -> [ByteString]
forall a. a -> a
seed Source
src
(Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> Maybe Int -> Maybe Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseRequestBodyOptions -> Maybe Int
prboMaxParmsSize ParseRequestBodyOptions
o)
let bs :: ByteString
bs = [ByteString] -> ByteString
S.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
front []
let x' :: (ByteString, ByteString)
x' = (ByteString
name, ByteString
bs)
let newParmSize :: Int
newParmSize = Int
parmSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
name Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
bs
case ParseRequestBodyOptions -> Maybe Int
prboMaxParmsSize ParseRequestBodyOptions
o of
Just Int
maxParmSize -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
newParmSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxParmSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Maximum size of parameters exceeded"
Maybe Int
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Either (ByteString, ByteString) (File y) -> IO ()
add (Either (ByteString, ByteString) (File y) -> IO ())
-> Either (ByteString, ByteString) (File y) -> IO ()
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString)
-> Either (ByteString, ByteString) (File y)
forall a b. a -> Either a b
Left (ByteString, ByteString)
x'
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wasFound (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int64 -> Source -> IO ()
loop (Int
numParms Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
numFiles
Int
newParmSize Int64
filesSize Source
src
Maybe (Maybe ByteString, ByteString, Maybe ByteString)
_ -> do
let seed :: ()
seed = ()
iter :: () -> p -> m ()
iter () p
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
((Bool
wasFound, Int64
_fileSize), ()) <- ByteString
-> (() -> ByteString -> IO ())
-> ()
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), ())
forall x.
ByteString
-> (x -> ByteString -> IO x)
-> x
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), x)
sinkTillBound ByteString
bound () -> ByteString -> IO ()
forall (m :: * -> *) p. Monad m => () -> p -> m ()
iter ()
seed Source
src Maybe Int64
forall a. Maybe a
Nothing
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wasFound (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int64 -> Source -> IO ()
loop Int
numParms Int
numFiles Int
parmSize Int64
filesSize Source
src
where
contDisp :: HeaderName
contDisp = ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk (ByteString -> HeaderName) -> ByteString -> HeaderName
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
S8.pack [Char]
"Content-Disposition"
contType :: HeaderName
contType = ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk (ByteString -> HeaderName) -> ByteString -> HeaderName
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
S8.pack [Char]
"Content-Type"
parsePair :: ByteString -> (HeaderName, ByteString)
parsePair ByteString
s =
let (ByteString
x, ByteString
y) = Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard Word8
58 ByteString
s
in (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk ByteString
x, (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
32) ByteString
y)
data Bound = FoundBound S.ByteString S.ByteString
| NoBound
| PartialBound
deriving (Bound -> Bound -> Bool
(Bound -> Bound -> Bool) -> (Bound -> Bound -> Bool) -> Eq Bound
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bound -> Bound -> Bool
$c/= :: Bound -> Bound -> Bool
== :: Bound -> Bound -> Bool
$c== :: Bound -> Bound -> Bool
Eq, Int -> Bound -> ShowS
[Bound] -> ShowS
Bound -> [Char]
(Int -> Bound -> ShowS)
-> (Bound -> [Char]) -> ([Bound] -> ShowS) -> Show Bound
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Bound] -> ShowS
$cshowList :: [Bound] -> ShowS
show :: Bound -> [Char]
$cshow :: Bound -> [Char]
showsPrec :: Int -> Bound -> ShowS
$cshowsPrec :: Int -> Bound -> ShowS
Show)
findBound :: S.ByteString -> S.ByteString -> Bound
findBound :: ByteString -> ByteString -> Bound
findBound ByteString
b ByteString
bs = (ByteString, ByteString) -> Bound
handleBreak ((ByteString, ByteString) -> Bound)
-> (ByteString, ByteString) -> Bound
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> (ByteString, ByteString)
S.breakSubstring ByteString
b ByteString
bs
where
handleBreak :: (ByteString, ByteString) -> Bound
handleBreak (ByteString
h, ByteString
t)
| ByteString -> Bool
S.null ByteString
t = [Int] -> Bound
go [Int
lowBound..ByteString -> Int
S.length ByteString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
| Bool
otherwise = ByteString -> ByteString -> Bound
FoundBound ByteString
h (ByteString -> Bound) -> ByteString -> Bound
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.drop (ByteString -> Int
S.length ByteString
b) ByteString
t
lowBound :: Int
lowBound = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S.length ByteString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
S.length ByteString
b
go :: [Int] -> Bound
go [] = Bound
NoBound
go (Int
i:[Int]
is)
| [Int] -> [Int] -> Bool
mismatch [Int
0..ByteString -> Int
S.length ByteString
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] [Int
i..ByteString -> Int
S.length ByteString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] = [Int] -> Bound
go [Int]
is
| Bool
otherwise =
let endI :: Int
endI = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
b
in if Int
endI Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> ByteString -> Int
S.length ByteString
bs
then Bound
PartialBound
else ByteString -> ByteString -> Bound
FoundBound (Int -> ByteString -> ByteString
S.take Int
i ByteString
bs) (Int -> ByteString -> ByteString
S.drop Int
endI ByteString
bs)
mismatch :: [Int] -> [Int] -> Bool
mismatch [] [Int]
_ = Bool
False
mismatch [Int]
_ [] = Bool
False
mismatch (Int
x:[Int]
xs) (Int
y:[Int]
ys)
| ByteString -> Int -> Word8
S.index ByteString
b Int
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Int -> Word8
S.index ByteString
bs Int
y = [Int] -> [Int] -> Bool
mismatch [Int]
xs [Int]
ys
| Bool
otherwise = Bool
True
sinkTillBound' :: S.ByteString
-> S.ByteString
-> FileInfo ()
-> BackEnd y
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), y)
sinkTillBound' :: ByteString
-> ByteString
-> FileInfo ()
-> BackEnd y
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), y)
sinkTillBound' ByteString
bound ByteString
name FileInfo ()
fi BackEnd y
sink Source
src Maybe Int64
max' = do
(IO ByteString
next, IO (Bool, Int64)
final) <- ByteString
-> Source -> Maybe Int64 -> IO (IO ByteString, IO (Bool, Int64))
wrapTillBound ByteString
bound Source
src Maybe Int64
max'
y
y <- BackEnd y
sink ByteString
name FileInfo ()
fi IO ByteString
next
(Bool, Int64)
b <- IO (Bool, Int64)
final
((Bool, Int64), y) -> IO ((Bool, Int64), y)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, Int64)
b, y
y)
data WTB = WTBWorking (S.ByteString -> S.ByteString)
| WTBDone Bool
wrapTillBound :: S.ByteString
-> Source
-> Maybe Int64
-> IO (IO S.ByteString, IO (Bool, Int64))
wrapTillBound :: ByteString
-> Source -> Maybe Int64 -> IO (IO ByteString, IO (Bool, Int64))
wrapTillBound ByteString
bound Source
src Maybe Int64
max' = do
IORef WTB
ref <- WTB -> IO (IORef WTB)
forall a. a -> IO (IORef a)
newIORef (WTB -> IO (IORef WTB)) -> WTB -> IO (IORef WTB)
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString) -> WTB
WTBWorking ByteString -> ByteString
forall a. a -> a
id
IORef Int64
sref <- Int64 -> IO (IORef Int64)
forall a. a -> IO (IORef a)
newIORef (Int64
0 :: Int64)
(IO ByteString, IO (Bool, Int64))
-> IO (IO ByteString, IO (Bool, Int64))
forall (m :: * -> *) a. Monad m => a -> m a
return (IORef WTB -> IORef Int64 -> IO ByteString
go IORef WTB
ref IORef Int64
sref, IORef WTB -> IORef Int64 -> IO (Bool, Int64)
forall b. IORef WTB -> IORef b -> IO (Bool, b)
final IORef WTB
ref IORef Int64
sref)
where
final :: IORef WTB -> IORef b -> IO (Bool, b)
final IORef WTB
ref IORef b
sref = do
WTB
x <- IORef WTB -> IO WTB
forall a. IORef a -> IO a
readIORef IORef WTB
ref
case WTB
x of
WTBWorking ByteString -> ByteString
_ -> [Char] -> IO (Bool, b)
forall a. HasCallStack => [Char] -> a
error [Char]
"wrapTillBound did not finish"
WTBDone Bool
y -> do
b
siz <- IORef b -> IO b
forall a. IORef a -> IO a
readIORef IORef b
sref
(Bool, b) -> IO (Bool, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
y, b
siz)
go :: IORef WTB -> IORef Int64 -> IO ByteString
go IORef WTB
ref IORef Int64
sref = do
WTB
state <- IORef WTB -> IO WTB
forall a. IORef a -> IO a
readIORef IORef WTB
ref
case WTB
state of
WTBDone Bool
_ -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
S.empty
WTBWorking ByteString -> ByteString
front -> do
ByteString
bs <- Source -> IO ByteString
readSource Source
src
Int64
cur <- IORef Int64 -> (Int64 -> (Int64, Int64)) -> IO Int64
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int64
sref ((Int64 -> (Int64, Int64)) -> IO Int64)
-> (Int64 -> (Int64, Int64)) -> IO Int64
forall a b. (a -> b) -> a -> b
$ \ Int64
cur ->
let new :: Int64
new = Int64
cur 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
bs) in (Int64
new, Int64
new)
case Maybe Int64
max' of
Just Int64
max'' | Int64
cur Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
max'' ->
HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError (ErrorCode -> ErrorCodeId
UnknownErrorCode ErrorCode
413) ByteString
"Payload Too Large"
Maybe Int64
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
if ByteString -> Bool
S.null ByteString
bs
then do
IORef WTB -> WTB -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef WTB
ref (WTB -> IO ()) -> WTB -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> WTB
WTBDone Bool
False
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
front ByteString
bs
else ByteString -> IO ByteString
push (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
front ByteString
bs
where
push :: ByteString -> IO ByteString
push ByteString
bs = do
case ByteString -> ByteString -> Bound
findBound ByteString
bound ByteString
bs of
FoundBound ByteString
before ByteString
after -> do
let before' :: ByteString
before' = ByteString -> ByteString
killCRLF ByteString
before
Source -> ByteString -> IO ()
leftover Source
src ByteString
after
IORef WTB -> WTB -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef WTB
ref (WTB -> IO ()) -> WTB -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> WTB
WTBDone Bool
True
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
before'
Bound
NoBound -> do
let (ByteString
toEmit, ByteString -> ByteString
front') =
if Bool -> Bool
not (ByteString -> Bool
S8.null ByteString
bs) Bool -> Bool -> Bool
&& ByteString -> Char
S8.last ByteString
bs Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\r',Char
'\n']
then let (ByteString
x, ByteString
y) = Int -> ByteString -> (ByteString, ByteString)
S.splitAt (ByteString -> Int
S.length ByteString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) ByteString
bs
in (ByteString
x, ByteString -> ByteString -> ByteString
S.append ByteString
y)
else (ByteString
bs, ByteString -> ByteString
forall a. a -> a
id)
IORef WTB -> WTB -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef WTB
ref (WTB -> IO ()) -> WTB -> IO ()
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString) -> WTB
WTBWorking ByteString -> ByteString
front'
if ByteString -> Bool
S.null ByteString
toEmit
then IORef WTB -> IORef Int64 -> IO ByteString
go IORef WTB
ref IORef Int64
sref
else ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
toEmit
Bound
PartialBound -> do
IORef WTB -> WTB -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef WTB
ref (WTB -> IO ()) -> WTB -> IO ()
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString) -> WTB
WTBWorking ((ByteString -> ByteString) -> WTB)
-> (ByteString -> ByteString) -> WTB
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString
S.append ByteString
bs
IORef WTB -> IORef Int64 -> IO ByteString
go IORef WTB
ref IORef Int64
sref
sinkTillBound :: S.ByteString
-> (x -> S.ByteString -> IO x)
-> x
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), x)
sinkTillBound :: ByteString
-> (x -> ByteString -> IO x)
-> x
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), x)
sinkTillBound ByteString
bound x -> ByteString -> IO x
iter x
seed0 Source
src Maybe Int64
max' = do
(IO ByteString
next, IO (Bool, Int64)
final) <- ByteString
-> Source -> Maybe Int64 -> IO (IO ByteString, IO (Bool, Int64))
wrapTillBound ByteString
bound Source
src Maybe Int64
max'
let loop :: x -> IO x
loop x
seed = do
ByteString
bs <- IO ByteString
next
if ByteString -> Bool
S.null ByteString
bs
then x -> IO x
forall (m :: * -> *) a. Monad m => a -> m a
return x
seed
else x -> ByteString -> IO x
iter x
seed ByteString
bs IO x -> (x -> IO x) -> IO x
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= x -> IO x
loop
x
seed <- x -> IO x
loop x
seed0
(Bool, Int64)
b <- IO (Bool, Int64)
final
((Bool, Int64), x) -> IO ((Bool, Int64), x)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, Int64)
b, x
seed)
parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)]
parseAttrs :: ByteString -> [(ByteString, ByteString)]
parseAttrs = (ByteString -> (ByteString, ByteString))
-> [ByteString] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> (ByteString, ByteString)
go ([ByteString] -> [(ByteString, ByteString)])
-> (ByteString -> [ByteString])
-> ByteString
-> [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> [ByteString]
S.split Word8
59
where
tw :: ByteString -> ByteString
tw = (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
32)
dq :: ByteString -> ByteString
dq ByteString
s = if ByteString -> Int
S.length ByteString
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2 Bool -> Bool -> Bool
&& ByteString -> Word8
S.head ByteString
s Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
34 Bool -> Bool -> Bool
&& ByteString -> Word8
S.last ByteString
s Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
34
then ByteString -> ByteString
S.tail (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
S.init ByteString
s
else ByteString
s
go :: ByteString -> (ByteString, ByteString)
go ByteString
s =
let (ByteString
x, ByteString
y) = Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard Word8
61 ByteString
s
in (ByteString -> ByteString
tw ByteString
x, ByteString -> ByteString
dq (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
tw ByteString
y)
killCRLF :: S.ByteString -> S.ByteString
killCRLF :: ByteString -> ByteString
killCRLF ByteString
bs
| ByteString -> Bool
S.null ByteString
bs Bool -> Bool -> Bool
|| ByteString -> Word8
S.last ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
10 = ByteString
bs
| Bool
otherwise = ByteString -> ByteString
killCR (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
S.init ByteString
bs
killCR :: S.ByteString -> S.ByteString
killCR :: ByteString -> ByteString
killCR ByteString
bs
| ByteString -> Bool
S.null ByteString
bs Bool -> Bool -> Bool
|| ByteString -> Word8
S.last ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
13 = ByteString
bs
| Bool
otherwise = ByteString -> ByteString
S.init ByteString
bs