{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.HTTP2.Server.HPACK (
hpackEncodeHeader
, hpackEncodeHeaderLoop
, hpackDecodeHeader
, hpackDecodeTrailer
, just
, fixHeaders
) where
import qualified Control.Exception as E
import Data.ByteString.Internal (unsafeCreate)
import Foreign.Ptr (plusPtr)
import Foreign.Storable (poke)
import Network.ByteOrder
import qualified Network.HTTP.Types as H
import Imports
import Network.HPACK
import Network.HPACK.Token
import Network.HTTP2
import Network.HTTP2.Server.Context
fixHeaders :: H.Status -> H.ResponseHeaders -> H.ResponseHeaders
Status
st ResponseHeaders
hdr = (HeaderName
":status", Status -> ByteString
packStatus Status
st) (HeaderName, ByteString) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ResponseHeaders -> ResponseHeaders
deleteUnnecessaryHeaders ResponseHeaders
hdr
packStatus :: H.Status -> ByteString
packStatus :: Status -> ByteString
packStatus Status
status = Int -> (Ptr Word8 -> IO ()) -> ByteString
unsafeCreate Int
3 ((Ptr Word8 -> IO ()) -> ByteString)
-> (Ptr Word8 -> IO ()) -> ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> do
Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
p (Int -> Word8
toW8 Int
r2)
Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1) (Int -> Word8
toW8 Int
r1)
Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
2) (Int -> Word8
toW8 Int
r0)
where
toW8 :: Int -> Word8
toW8 :: Int -> Word8
toW8 Int
n = Word8
48 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
!s :: Int
s = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Status -> Int
H.statusCode Status
status
(!Int
q0,!Int
r0) = Int
s Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
10
(!Int
q1,!Int
r1) = Int
q0 Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
10
!r2 :: Int
r2 = Int
q1 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
10
deleteUnnecessaryHeaders :: H.ResponseHeaders -> H.ResponseHeaders
ResponseHeaders
hdr = ((HeaderName, ByteString) -> Bool)
-> ResponseHeaders -> ResponseHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (HeaderName, ByteString) -> 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]
= [ HeaderName
H.hConnection
, HeaderName
"Transfer-Encoding"
]
strategy :: EncodeStrategy
strategy :: EncodeStrategy
strategy = EncodeStrategy :: CompressionAlgo -> Bool -> EncodeStrategy
EncodeStrategy { compressionAlgo :: CompressionAlgo
compressionAlgo = CompressionAlgo
Linear, useHuffman :: Bool
useHuffman = Bool
False }
hpackEncodeHeader :: Context -> Buffer -> BufferSize
-> TokenHeaderList
-> IO (TokenHeaderList, Int)
Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
TQueue Control
TQueue Input
DynamicTable
PriorityTree Output
StreamTable
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> PriorityTree Output
inputQ :: Context -> TQueue Input
serverStreamId :: Context -> IORef Int
clientStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
priorityTreeSize :: Context -> IORef Int
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: PriorityTree Output
inputQ :: TQueue Input
serverStreamId :: IORef Int
clientStreamId :: IORef Int
continued :: IORef (Maybe Int)
priorityTreeSize :: IORef Int
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
..} Ptr Word8
buf Int
siz TokenHeaderList
ths =
Ptr Word8
-> Int
-> EncodeStrategy
-> Bool
-> DynamicTable
-> TokenHeaderList
-> IO (TokenHeaderList, Int)
encodeTokenHeader Ptr Word8
buf Int
siz EncodeStrategy
strategy Bool
True DynamicTable
encodeDynamicTable TokenHeaderList
ths
hpackEncodeHeaderLoop :: Context -> Buffer -> BufferSize
-> TokenHeaderList
-> IO (TokenHeaderList, Int)
Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
TQueue Control
TQueue Input
DynamicTable
PriorityTree Output
StreamTable
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: PriorityTree Output
inputQ :: TQueue Input
serverStreamId :: IORef Int
clientStreamId :: IORef Int
continued :: IORef (Maybe Int)
priorityTreeSize :: IORef Int
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> PriorityTree Output
inputQ :: Context -> TQueue Input
serverStreamId :: Context -> IORef Int
clientStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
priorityTreeSize :: Context -> IORef Int
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
..} Ptr Word8
buf Int
siz TokenHeaderList
hs =
Ptr Word8
-> Int
-> EncodeStrategy
-> Bool
-> DynamicTable
-> TokenHeaderList
-> IO (TokenHeaderList, Int)
encodeTokenHeader Ptr Word8
buf Int
siz EncodeStrategy
strategy Bool
False DynamicTable
encodeDynamicTable TokenHeaderList
hs
hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO HeaderTable
ByteString
hdrblk Context
ctx = do
tbl :: HeaderTable
tbl@(TokenHeaderList
_,ValueTable
vt) <- ByteString -> Context -> IO HeaderTable
hpackDecodeTrailer ByteString
hdrblk Context
ctx
if ValueTable -> Bool
checkRequestHeader ValueTable
vt then
HeaderTable -> IO HeaderTable
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
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"the header key is illegal"
hpackDecodeTrailer :: HeaderBlockFragment -> Context -> IO HeaderTable
hpackDecodeTrailer :: ByteString -> Context -> IO HeaderTable
hpackDecodeTrailer ByteString
hdrblk Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
TQueue Control
TQueue Input
DynamicTable
PriorityTree Output
StreamTable
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: PriorityTree Output
inputQ :: TQueue Input
serverStreamId :: IORef Int
clientStreamId :: IORef Int
continued :: IORef (Maybe Int)
priorityTreeSize :: IORef Int
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> PriorityTree Output
inputQ :: Context -> TQueue Input
serverStreamId :: Context -> IORef Int
clientStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
priorityTreeSize :: Context -> IORef Int
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
..} = 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
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"the header key is illegal"
handl DecodeError
_ =
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
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
CompressionError ByteString
"cannot decompress the header"
{-# 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 = Bool
True
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
{-# INLINE just #-}
just :: Maybe a -> (a -> Bool) -> Bool
just :: 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