{-# 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 = forall a. (a -> Bool) -> [a] -> [a]
filter forall {b}. (HeaderName, b) -> Bool
del ResponseHeaders
hdr
  where
    del :: (HeaderName, b) -> Bool
del (HeaderName
k, b
_) = HeaderName
k 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
peerSockAddr :: Context -> SockAddr
mySockAddr :: Context -> SockAddr
rstRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxFlow :: Context -> IORef RxFlow
txFlow :: Context -> TVar TxFlow
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar BufferSize
outputQ :: Context -> TQueue (Output Stream)
outputBufferLimit :: Context -> IORef BufferSize
peerStreamId :: Context -> IORef BufferSize
myStreamId :: Context -> TVar BufferSize
continued :: Context -> IORef (Maybe BufferSize)
evenStreamTable :: Context -> TVar EvenStreamTable
oddStreamTable :: Context -> TVar OddStreamTable
peerSettings :: Context -> IORef Settings
myFirstSettings :: Context -> IORef Bool
mySettings :: Context -> Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
peerSockAddr :: SockAddr
mySockAddr :: SockAddr
rstRate :: Rate
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxFlow :: IORef RxFlow
txFlow :: TVar TxFlow
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar BufferSize
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef BufferSize
peerStreamId :: IORef BufferSize
myStreamId :: TVar BufferSize
continued :: IORef (Maybe BufferSize)
evenStreamTable :: TVar EvenStreamTable
oddStreamTable :: TVar OddStreamTable
peerSettings :: IORef Settings
myFirstSettings :: IORef Bool
mySettings :: Settings
roleInfo :: RoleInfo
role :: Role
..} 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
peerSockAddr :: SockAddr
mySockAddr :: SockAddr
rstRate :: Rate
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxFlow :: IORef RxFlow
txFlow :: TVar TxFlow
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar BufferSize
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef BufferSize
peerStreamId :: IORef BufferSize
myStreamId :: TVar BufferSize
continued :: IORef (Maybe BufferSize)
evenStreamTable :: TVar EvenStreamTable
oddStreamTable :: TVar OddStreamTable
peerSettings :: IORef Settings
myFirstSettings :: IORef Bool
mySettings :: Settings
roleInfo :: RoleInfo
role :: Role
peerSockAddr :: Context -> SockAddr
mySockAddr :: Context -> SockAddr
rstRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxFlow :: Context -> IORef RxFlow
txFlow :: Context -> TVar TxFlow
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar BufferSize
outputQ :: Context -> TQueue (Output Stream)
outputBufferLimit :: Context -> IORef BufferSize
peerStreamId :: Context -> IORef BufferSize
myStreamId :: Context -> TVar BufferSize
continued :: Context -> IORef (Maybe BufferSize)
evenStreamTable :: Context -> TVar EvenStreamTable
oddStreamTable :: Context -> TVar OddStreamTable
peerSettings :: Context -> IORef Settings
myFirstSettings :: Context -> IORef Bool
mySettings :: Context -> Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} 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 forall (m :: * -> *) a. Monad m => a -> m a
return HeaderTable
tbl
        else forall e a. Exception e => e -> IO a
E.throwIO 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
peerSockAddr :: SockAddr
mySockAddr :: SockAddr
rstRate :: Rate
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxFlow :: IORef RxFlow
txFlow :: TVar TxFlow
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar BufferSize
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef BufferSize
peerStreamId :: IORef BufferSize
myStreamId :: TVar BufferSize
continued :: IORef (Maybe BufferSize)
evenStreamTable :: TVar EvenStreamTable
oddStreamTable :: TVar OddStreamTable
peerSettings :: IORef Settings
myFirstSettings :: IORef Bool
mySettings :: Settings
roleInfo :: RoleInfo
role :: Role
peerSockAddr :: Context -> SockAddr
mySockAddr :: Context -> SockAddr
rstRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxFlow :: Context -> IORef RxFlow
txFlow :: Context -> TVar TxFlow
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar BufferSize
outputQ :: Context -> TQueue (Output Stream)
outputBufferLimit :: Context -> IORef BufferSize
peerStreamId :: Context -> IORef BufferSize
myStreamId :: Context -> TVar BufferSize
continued :: Context -> IORef (Maybe BufferSize)
evenStreamTable :: Context -> TVar EvenStreamTable
oddStreamTable :: Context -> TVar OddStreamTable
peerSettings :: Context -> IORef Settings
myFirstSettings :: Context -> IORef Bool
mySettings :: Context -> Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} = DynamicTable -> ByteString -> IO HeaderTable
decodeTokenHeader DynamicTable
decodeDynamicTable ByteString
hdrblk forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` forall {a}. DecodeError -> IO a
handl
  where
    handl :: DecodeError -> IO a
handl DecodeError
IllegalHeaderName =
        forall e a. Exception e => e -> IO a
E.throwIO 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 = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show DecodeError
e
        forall e a. Exception e => e -> IO a
E.throwIO 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
    | forall a. Maybe a -> (a -> Bool) -> Bool
just Maybe ByteString
mMethod (forall a. Eq a => a -> a -> Bool
== ByteString
"CONNECT") = forall a. Maybe a -> Bool
isNothing Maybe ByteString
mPath Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe ByteString
mScheme
    | forall a. Maybe a -> Bool
isJust Maybe ByteString
mStatus = Bool
False
    | forall a. Maybe a -> Bool
isNothing Maybe ByteString
mMethod = Bool
False
    | forall a. Maybe a -> Bool
isNothing Maybe ByteString
mScheme = Bool
False
    | forall a. Maybe a -> Bool
isNothing Maybe ByteString
mPath = Bool
False
    | Maybe ByteString
mPath forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ByteString
"" = Bool
False
    | forall a. Maybe a -> Bool
isJust Maybe ByteString
mConnection = Bool
False
    | forall a. Maybe a -> (a -> Bool) -> Bool
just Maybe ByteString
mTE (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 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