{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Network.HTTP2.H2.HPACK (
    hpackEncodeHeader,
    hpackEncodeHeaderLoop,
    hpackDecodeHeader,
    hpackDecodeTrailer,
    just,
    fixHeaders,
) where

import qualified Control.Exception as E
import Network.ByteOrder
import qualified Network.HTTP.Types as H

import Imports
import Network.HPACK
import Network.HPACK.Token
import Network.HTTP2.Frame
import Network.HTTP2.H2.Context
import Network.HTTP2.H2.Types

-- $setup
-- >>> :set -XOverloadedStrings

----------------------------------------------------------------

fixHeaders :: H.ResponseHeaders -> H.ResponseHeaders
fixHeaders :: ResponseHeaders -> ResponseHeaders
fixHeaders ResponseHeaders
hdr = ResponseHeaders -> ResponseHeaders
deleteUnnecessaryHeaders ResponseHeaders
hdr

deleteUnnecessaryHeaders :: H.ResponseHeaders -> H.ResponseHeaders
deleteUnnecessaryHeaders :: ResponseHeaders -> ResponseHeaders
deleteUnnecessaryHeaders 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 :: [H.HeaderName]
headersToBeRemoved :: [HeaderName]
headersToBeRemoved =
    [ HeaderName
H.hConnection
    , HeaderName
"Transfer-Encoding"
    -- Keep-Alive
    -- Proxy-Connection
    -- Upgrade
    ]

----------------------------------------------------------------

strategy :: EncodeStrategy
strategy :: EncodeStrategy
strategy = EncodeStrategy{compressionAlgo :: CompressionAlgo
compressionAlgo = CompressionAlgo
Linear, useHuffman :: Bool
useHuffman = Bool
False}

-- Set-Cookie: contains only one cookie value.
-- So, we don't need to split it.
hpackEncodeHeader
    :: Context
    -> Buffer
    -> BufferSize
    -> TokenHeaderList
    -> IO (TokenHeaderList, Int)
hpackEncodeHeader :: Context
-> Buffer
-> BufferSize
-> TokenHeaderList
-> IO (TokenHeaderList, BufferSize)
hpackEncodeHeader 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)
hpackEncodeHeaderLoop :: Context
-> Buffer
-> BufferSize
-> TokenHeaderList
-> IO (TokenHeaderList, BufferSize)
hpackEncodeHeaderLoop 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 HeaderTable
hpackDecodeHeader :: ByteString -> BufferSize -> Context -> IO HeaderTable
hpackDecodeHeader ByteString
hdrblk BufferSize
sid Context
ctx = do
    tbl :: HeaderTable
tbl@(TokenHeaderList
_, ValueTable
vt) <- ByteString -> BufferSize -> Context -> IO HeaderTable
hpackDecodeTrailer ByteString
hdrblk BufferSize
sid Context
ctx
    if Context -> Bool
isClient Context
ctx Bool -> Bool -> Bool
|| ValueTable -> Bool
checkRequestHeader ValueTable
vt
        then HeaderTable -> IO HeaderTable
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HeaderTable
tbl
        else HTTP2Error -> IO HeaderTable
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO HeaderTable) -> HTTP2Error -> IO HeaderTable
forall a b. (a -> b) -> a -> b
$ ErrorCode -> BufferSize -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
ProtocolError BufferSize
sid ReasonPhrase
"illegal header"

hpackDecodeTrailer
    :: HeaderBlockFragment -> StreamId -> Context -> IO HeaderTable
hpackDecodeTrailer :: ByteString -> BufferSize -> Context -> IO HeaderTable
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 HeaderTable
decodeTokenHeader DynamicTable
decodeDynamicTable ByteString
hdrblk IO HeaderTable -> (DecodeError -> IO HeaderTable) -> IO HeaderTable
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` DecodeError -> IO HeaderTable
forall {a}. DecodeError -> IO a
handl
  where
    handl :: DecodeError -> IO a
handl DecodeError
IllegalHeaderName =
        HTTP2Error -> IO a
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO a) -> HTTP2Error -> IO 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 -> IO a
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO a) -> HTTP2Error -> IO a
forall a b. (a -> b) -> a -> b
$ ErrorCode -> BufferSize -> ReasonPhrase -> HTTP2Error
StreamErrorIsSent ErrorCode
CompressionError BufferSize
sid ReasonPhrase
msg

{-# INLINE checkRequestHeader #-}
checkRequestHeader :: ValueTable -> Bool
checkRequestHeader :: ValueTable -> Bool
checkRequestHeader 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
getHeaderValue Token
tokenStatus ValueTable
reqvt
    mScheme :: Maybe ByteString
mScheme = Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenScheme ValueTable
reqvt
    mPath :: Maybe ByteString
mPath = Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenPath ValueTable
reqvt
    mMethod :: Maybe ByteString
mMethod = Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenMethod ValueTable
reqvt
    mConnection :: Maybe ByteString
mConnection = Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenConnection ValueTable
reqvt
    mTE :: Maybe ByteString
mTE = Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenTE ValueTable
reqvt
    mAuthority :: Maybe ByteString
mAuthority = Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenAuthority ValueTable
reqvt
    mHost :: Maybe ByteString
mHost = Token -> ValueTable -> Maybe ByteString
getHeaderValue 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