module Network.Wai.Handler.Warp.HTTP2.HPACK (
hpackEncodeHeader
, hpackEncodeHeaderLoop
, hpackDecodeHeader
, just
) where
import qualified Control.Exception as E
import Control.Monad (unless)
import Data.ByteString (ByteString)
import Network.HPACK hiding (Buffer)
import Network.HPACK.Token
import qualified Network.HTTP.Types as H
import Network.HTTP2
import Network.Wai.Handler.Warp.HTTP2.Types
import Network.Wai.Handler.Warp.PackInt
import qualified Network.Wai.Handler.Warp.Settings as S
import Network.Wai.Handler.Warp.Types
strategy :: EncodeStrategy
strategy = EncodeStrategy { compressionAlgo = Linear, useHuffman = False }
hpackEncodeHeader :: Context -> Buffer -> BufSize
-> InternalInfo -> S.Settings
-> H.Status -> (TokenHeaderList,ValueTable)
-> IO (TokenHeaderList, Int)
hpackEncodeHeader Context{..} buf siz ii settings s (ths0,tbl) = do
let !defServer = S.settingsServerName settings
!ths1 = addHeader tokenServer defServer tbl ths0
date <- getDate ii
let !ths2 = addHeader tokenDate date tbl ths1
!status = packStatus s
!ths3 = (tokenStatus, status) : ths2
encodeTokenHeader buf siz strategy True encodeDynamicTable ths3
addHeader :: Token -> ByteString -> ValueTable -> TokenHeaderList -> TokenHeaderList
addHeader t v tbl ths = case getHeaderValue t tbl of
Nothing -> (t,v) : ths
Just _ -> ths
hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize -> TokenHeaderList
-> IO (TokenHeaderList, Int)
hpackEncodeHeaderLoop Context{..} buf siz hs =
encodeTokenHeader buf siz strategy False encodeDynamicTable hs
hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO (TokenHeaderList, ValueTable)
hpackDecodeHeader hdrblk Context{..} = do
tbl@(_,vt) <- decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl
unless (checkRequestHeader vt) $
E.throwIO $ ConnectionError ProtocolError "the header key is illegal"
return tbl
where
handl IllegalHeaderName =
E.throwIO $ ConnectionError ProtocolError "the header key is illegal"
handl _ =
E.throwIO $ ConnectionError CompressionError "cannot decompress the header"
checkRequestHeader :: ValueTable -> Bool
checkRequestHeader reqvt
| getHeaderValue tokenStatus reqvt /= Nothing = False
| getHeaderValue tokenPath reqvt == Nothing = False
| getHeaderValue tokenMethod reqvt == Nothing = False
| getHeaderValue tokenAuthority reqvt == Nothing = False
| getHeaderValue tokenConnection reqvt /= Nothing = False
| just (getHeaderValue tokenTE reqvt) (/= "trailers") = False
| otherwise = True
just :: Maybe a -> (a -> Bool) -> Bool
just Nothing _ = False
just (Just x) p
| p x = True
| otherwise = False