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

module Network.HTTP2.Arch.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.Arch.Context
import Network.HTTP2.Arch.Types
import Network.HTTP2.Frame

-- $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
IORef Bool
IORef BufferSize
IORef (Maybe BufferSize)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar BufferSize
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef BufferSize
myStreamId :: Context -> IORef BufferSize
continued :: Context -> IORef (Maybe BufferSize)
concurrency :: Context -> IORef BufferSize
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar BufferSize
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef BufferSize
myStreamId :: IORef BufferSize
continued :: IORef (Maybe BufferSize)
concurrency :: IORef BufferSize
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef 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
IORef Bool
IORef BufferSize
IORef (Maybe BufferSize)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar BufferSize
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef BufferSize
myStreamId :: IORef BufferSize
continued :: IORef (Maybe BufferSize)
concurrency :: IORef BufferSize
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar BufferSize
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef BufferSize
myStreamId :: Context -> IORef BufferSize
continued :: Context -> IORef (Maybe BufferSize)
concurrency :: Context -> IORef BufferSize
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef 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 -> HTTP2Error
StreamErrorIsSent ErrorCode
ProtocolError BufferSize
sid

hpackDecodeTrailer :: HeaderBlockFragment -> StreamId -> Context -> IO HeaderTable
hpackDecodeTrailer :: ByteString -> BufferSize -> Context -> IO HeaderTable
hpackDecodeTrailer ByteString
hdrblk BufferSize
sid Context{TVar BufferSize
IORef Bool
IORef BufferSize
IORef (Maybe BufferSize)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar BufferSize
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef BufferSize
myStreamId :: IORef BufferSize
continued :: IORef (Maybe BufferSize)
concurrency :: IORef BufferSize
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar BufferSize
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef BufferSize
myStreamId :: Context -> IORef BufferSize
continued :: Context -> IORef (Maybe BufferSize)
concurrency :: Context -> IORef BufferSize
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef 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 -> HTTP2Error
StreamErrorIsSent ErrorCode
ProtocolError BufferSize
sid
    handl DecodeError
_ =
        forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ ErrorCode -> BufferSize -> HTTP2Error
StreamErrorIsSent ErrorCode
CompressionError BufferSize
sid

{-# 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