{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.HTTP2.H2.HPACK (
hpackEncodeHeader,
hpackEncodeHeaderLoop,
hpackDecodeHeader,
hpackDecodeTrailer,
just,
fixHeaders,
) where
import Network.ByteOrder
import Network.HTTP.Semantics
import Network.HTTP.Types
import qualified UnliftIO.Exception as E
import Imports
import Network.HPACK
import Network.HTTP2.Frame
import Network.HTTP2.H2.Context
import Network.HTTP2.H2.Types
fixHeaders :: ResponseHeaders -> ResponseHeaders
ResponseHeaders
hdr = ResponseHeaders -> ResponseHeaders
deleteUnnecessaryHeaders ResponseHeaders
hdr
deleteUnnecessaryHeaders :: ResponseHeaders -> ResponseHeaders
ResponseHeaders
hdr = (Header -> Bool) -> ResponseHeaders -> ResponseHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter Header -> Bool
forall {b}. (HeaderName, b) -> Bool
del ResponseHeaders
hdr
where
del :: (HeaderName, b) -> Bool
del (HeaderName
k, b
_) = HeaderName
k HeaderName -> [HeaderName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [HeaderName]
headersToBeRemoved
headersToBeRemoved :: [HeaderName]
=
[ HeaderName
hConnection
, HeaderName
"Transfer-Encoding"
]
strategy :: EncodeStrategy
strategy :: EncodeStrategy
strategy = EncodeStrategy{compressionAlgo :: CompressionAlgo
compressionAlgo = CompressionAlgo
Linear, useHuffman :: Bool
useHuffman = Bool
False}
hpackEncodeHeader
:: Context
-> Buffer
-> BufferSize
-> TokenHeaderList
-> IO (TokenHeaderList, Int)
Context{TVar BufferSize
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef BufferSize
IORef (Maybe BufferSize)
IORef RxFlow
IORef Settings
SockAddr
Rate
TQueue Control
TQueue (Output Stream)
DynamicTable
Settings
RoleInfo
Role
role :: Role
roleInfo :: RoleInfo
mySettings :: Settings
myFirstSettings :: IORef Bool
peerSettings :: IORef Settings
oddStreamTable :: TVar OddStreamTable
evenStreamTable :: TVar EvenStreamTable
continued :: IORef (Maybe BufferSize)
myStreamId :: TVar BufferSize
peerStreamId :: IORef BufferSize
outputBufferLimit :: IORef BufferSize
outputQ :: TQueue (Output Stream)
outputQStreamID :: TVar BufferSize
controlQ :: TQueue Control
encodeDynamicTable :: DynamicTable
decodeDynamicTable :: DynamicTable
txFlow :: TVar TxFlow
rxFlow :: IORef RxFlow
pingRate :: Rate
settingsRate :: Rate
emptyFrameRate :: Rate
rstRate :: Rate
mySockAddr :: SockAddr
peerSockAddr :: SockAddr
role :: Context -> Role
roleInfo :: Context -> RoleInfo
mySettings :: Context -> Settings
myFirstSettings :: Context -> IORef Bool
peerSettings :: Context -> IORef Settings
oddStreamTable :: Context -> TVar OddStreamTable
evenStreamTable :: Context -> TVar EvenStreamTable
continued :: Context -> IORef (Maybe BufferSize)
myStreamId :: Context -> TVar BufferSize
peerStreamId :: Context -> IORef BufferSize
outputBufferLimit :: Context -> IORef BufferSize
outputQ :: Context -> TQueue (Output Stream)
outputQStreamID :: Context -> TVar BufferSize
controlQ :: Context -> TQueue Control
encodeDynamicTable :: Context -> DynamicTable
decodeDynamicTable :: Context -> DynamicTable
txFlow :: Context -> TVar TxFlow
rxFlow :: Context -> IORef RxFlow
pingRate :: Context -> Rate
settingsRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
rstRate :: Context -> Rate
mySockAddr :: Context -> SockAddr
peerSockAddr :: Context -> SockAddr
..} Buffer
buf BufferSize
siz TokenHeaderList
ths =
Buffer
-> BufferSize
-> EncodeStrategy
-> Bool
-> DynamicTable
-> TokenHeaderList
-> IO (TokenHeaderList, BufferSize)
encodeTokenHeader Buffer
buf BufferSize
siz EncodeStrategy
strategy Bool
True DynamicTable
encodeDynamicTable TokenHeaderList
ths
hpackEncodeHeaderLoop
:: Context
-> Buffer
-> BufferSize
-> TokenHeaderList
-> IO (TokenHeaderList, Int)
Context{TVar BufferSize
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef BufferSize
IORef (Maybe BufferSize)
IORef RxFlow
IORef Settings
SockAddr
Rate
TQueue Control
TQueue (Output Stream)
DynamicTable
Settings
RoleInfo
Role
role :: Context -> Role
roleInfo :: Context -> RoleInfo
mySettings :: Context -> Settings
myFirstSettings :: Context -> IORef Bool
peerSettings :: Context -> IORef Settings
oddStreamTable :: Context -> TVar OddStreamTable
evenStreamTable :: Context -> TVar EvenStreamTable
continued :: Context -> IORef (Maybe BufferSize)
myStreamId :: Context -> TVar BufferSize
peerStreamId :: Context -> IORef BufferSize
outputBufferLimit :: Context -> IORef BufferSize
outputQ :: Context -> TQueue (Output Stream)
outputQStreamID :: Context -> TVar BufferSize
controlQ :: Context -> TQueue Control
encodeDynamicTable :: Context -> DynamicTable
decodeDynamicTable :: Context -> DynamicTable
txFlow :: Context -> TVar TxFlow
rxFlow :: Context -> IORef RxFlow
pingRate :: Context -> Rate
settingsRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
rstRate :: Context -> Rate
mySockAddr :: Context -> SockAddr
peerSockAddr :: Context -> SockAddr
role :: Role
roleInfo :: RoleInfo
mySettings :: Settings
myFirstSettings :: IORef Bool
peerSettings :: IORef Settings
oddStreamTable :: TVar OddStreamTable
evenStreamTable :: TVar EvenStreamTable
continued :: IORef (Maybe BufferSize)
myStreamId :: TVar BufferSize
peerStreamId :: IORef BufferSize
outputBufferLimit :: IORef BufferSize
outputQ :: TQueue (Output Stream)
outputQStreamID :: TVar BufferSize
controlQ :: TQueue Control
encodeDynamicTable :: DynamicTable
decodeDynamicTable :: DynamicTable
txFlow :: TVar TxFlow
rxFlow :: IORef RxFlow
pingRate :: Rate
settingsRate :: Rate
emptyFrameRate :: Rate
rstRate :: Rate
mySockAddr :: SockAddr
peerSockAddr :: SockAddr
..} Buffer
buf BufferSize
siz TokenHeaderList
hs =
Buffer
-> BufferSize
-> EncodeStrategy
-> Bool
-> DynamicTable
-> TokenHeaderList
-> IO (TokenHeaderList, BufferSize)
encodeTokenHeader Buffer
buf BufferSize
siz EncodeStrategy
strategy Bool
False DynamicTable
encodeDynamicTable TokenHeaderList
hs
hpackDecodeHeader
:: HeaderBlockFragment -> StreamId -> Context -> IO TokenHeaderTable
ByteString
hdrblk BufferSize
sid Context
ctx = do
tbl :: TokenHeaderTable
tbl@(TokenHeaderList
_, ValueTable
vt) <- ByteString -> BufferSize -> Context -> IO TokenHeaderTable
hpackDecodeTrailer ByteString
hdrblk BufferSize
sid Context
ctx
if Context -> Bool
isClient Context
ctx Bool -> Bool -> Bool
|| ValueTable -> Bool
checkRequestHeader ValueTable
vt
then TokenHeaderTable -> IO TokenHeaderTable
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TokenHeaderTable
tbl
else HTTP2Error -> IO TokenHeaderTable
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO TokenHeaderTable)
-> HTTP2Error -> IO TokenHeaderTable
forall a b. (a -> b) -> a -> b
$ ErrorCode -> BufferSize -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
ProtocolError BufferSize
sid ReasonPhrase
"illegal header"
hpackDecodeTrailer
:: HeaderBlockFragment -> StreamId -> Context -> IO TokenHeaderTable
hpackDecodeTrailer :: ByteString -> BufferSize -> Context -> IO TokenHeaderTable
hpackDecodeTrailer ByteString
hdrblk BufferSize
sid Context{TVar BufferSize
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef BufferSize
IORef (Maybe BufferSize)
IORef RxFlow
IORef Settings
SockAddr
Rate
TQueue Control
TQueue (Output Stream)
DynamicTable
Settings
RoleInfo
Role
role :: Context -> Role
roleInfo :: Context -> RoleInfo
mySettings :: Context -> Settings
myFirstSettings :: Context -> IORef Bool
peerSettings :: Context -> IORef Settings
oddStreamTable :: Context -> TVar OddStreamTable
evenStreamTable :: Context -> TVar EvenStreamTable
continued :: Context -> IORef (Maybe BufferSize)
myStreamId :: Context -> TVar BufferSize
peerStreamId :: Context -> IORef BufferSize
outputBufferLimit :: Context -> IORef BufferSize
outputQ :: Context -> TQueue (Output Stream)
outputQStreamID :: Context -> TVar BufferSize
controlQ :: Context -> TQueue Control
encodeDynamicTable :: Context -> DynamicTable
decodeDynamicTable :: Context -> DynamicTable
txFlow :: Context -> TVar TxFlow
rxFlow :: Context -> IORef RxFlow
pingRate :: Context -> Rate
settingsRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
rstRate :: Context -> Rate
mySockAddr :: Context -> SockAddr
peerSockAddr :: Context -> SockAddr
role :: Role
roleInfo :: RoleInfo
mySettings :: Settings
myFirstSettings :: IORef Bool
peerSettings :: IORef Settings
oddStreamTable :: TVar OddStreamTable
evenStreamTable :: TVar EvenStreamTable
continued :: IORef (Maybe BufferSize)
myStreamId :: TVar BufferSize
peerStreamId :: IORef BufferSize
outputBufferLimit :: IORef BufferSize
outputQ :: TQueue (Output Stream)
outputQStreamID :: TVar BufferSize
controlQ :: TQueue Control
encodeDynamicTable :: DynamicTable
decodeDynamicTable :: DynamicTable
txFlow :: TVar TxFlow
rxFlow :: IORef RxFlow
pingRate :: Rate
settingsRate :: Rate
emptyFrameRate :: Rate
rstRate :: Rate
mySockAddr :: SockAddr
peerSockAddr :: SockAddr
..} = DynamicTable -> ByteString -> IO TokenHeaderTable
decodeTokenHeader DynamicTable
decodeDynamicTable ByteString
hdrblk IO TokenHeaderTable
-> (DecodeError -> IO TokenHeaderTable) -> IO TokenHeaderTable
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` DecodeError -> IO TokenHeaderTable
forall {m :: * -> *} {a}. MonadIO m => DecodeError -> m a
handl
where
handl :: DecodeError -> m a
handl DecodeError
IllegalHeaderName =
HTTP2Error -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> m a) -> HTTP2Error -> m a
forall a b. (a -> b) -> a -> b
$ ErrorCode -> BufferSize -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
ProtocolError BufferSize
sid ReasonPhrase
"illegal trailer"
handl DecodeError
e = do
let msg :: ReasonPhrase
msg = String -> ReasonPhrase
forall a. IsString a => String -> a
fromString (String -> ReasonPhrase) -> String -> ReasonPhrase
forall a b. (a -> b) -> a -> b
$ DecodeError -> String
forall a. Show a => a -> String
show DecodeError
e
HTTP2Error -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> m a) -> HTTP2Error -> m a
forall a b. (a -> b) -> a -> b
$ ErrorCode -> BufferSize -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
CompressionError BufferSize
sid ReasonPhrase
msg
{-# INLINE checkRequestHeader #-}
checkRequestHeader :: ValueTable -> Bool
ValueTable
reqvt
| Maybe ByteString -> (ByteString -> Bool) -> Bool
forall a. Maybe a -> (a -> Bool) -> Bool
just Maybe ByteString
mMethod (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"CONNECT") = Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ByteString
mPath Bool -> Bool -> Bool
&& Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ByteString
mScheme
| Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
mStatus = Bool
False
| Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ByteString
mMethod = Bool
False
| Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ByteString
mScheme = Bool
False
| Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ByteString
mPath = Bool
False
| Maybe ByteString
mPath Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"" = Bool
False
| Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
mConnection = Bool
False
| Maybe ByteString -> (ByteString -> Bool) -> Bool
forall a. Maybe a -> (a -> Bool) -> Bool
just Maybe ByteString
mTE (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"trailers") = Bool
False
| Bool
otherwise = Maybe ByteString -> Maybe ByteString -> Bool
checkAuth Maybe ByteString
mAuthority Maybe ByteString
mHost
where
mStatus :: Maybe ByteString
mStatus = Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenStatus ValueTable
reqvt
mScheme :: Maybe ByteString
mScheme = Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenScheme ValueTable
reqvt
mPath :: Maybe ByteString
mPath = Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenPath ValueTable
reqvt
mMethod :: Maybe ByteString
mMethod = Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenMethod ValueTable
reqvt
mConnection :: Maybe ByteString
mConnection = Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenConnection ValueTable
reqvt
mTE :: Maybe ByteString
mTE = Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenTE ValueTable
reqvt
mAuthority :: Maybe ByteString
mAuthority = Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenAuthority ValueTable
reqvt
mHost :: Maybe ByteString
mHost = Token -> ValueTable -> Maybe ByteString
getFieldValue Token
tokenHost ValueTable
reqvt
checkAuth :: Maybe ByteString -> Maybe ByteString -> Bool
checkAuth :: Maybe ByteString -> Maybe ByteString -> Bool
checkAuth Maybe ByteString
Nothing Maybe ByteString
Nothing = Bool
False
checkAuth (Just ByteString
a) (Just ByteString
h) | ByteString
a ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
h = Bool
False
checkAuth Maybe ByteString
_ Maybe ByteString
_ = Bool
True
{-# INLINE just #-}
just :: Maybe a -> (a -> Bool) -> Bool
just :: forall a. Maybe a -> (a -> Bool) -> Bool
just Maybe a
Nothing a -> Bool
_ = Bool
False
just (Just a
x) a -> Bool
p
| a -> Bool
p a
x = Bool
True
| Bool
otherwise = Bool
False