{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE OverloadedStrings #-}

module Network.QPACK.Instruction (
  -- * Encoder instructions
    HIndex(..)
  , EncoderInstruction(..)
  , InsIndex
  , encodeEncoderInstructions
  , decodeEncoderInstructions
  , decodeEncoderInstructions'
  , encodeEI
  , decodeEI
  -- * Decoder instructions
  , DecoderInstruction(..)
  , encodeDecoderInstructions
  , decodeDecoderInstructions
  , encodeDI
  , decodeDI
  ) where

import qualified Data.ByteString.Char8 as BS8
import Data.CaseInsensitive
import Network.ByteOrder
import Network.HPACK.Internal
import Network.HPACK.Token
import qualified UnliftIO.Exception as E

import Imports
import Network.QPACK.Types
import Network.QPACK.Table.Static

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

type InsIndex = Either AbsoluteIndex InsRelativeIndex

data EncoderInstruction = SetDynamicTableCapacity Int
                        | InsertWithNameReference InsIndex HeaderValue
                        | InsertWithoutNameReference Token HeaderValue
                        | Duplicate InsRelativeIndex
                        deriving (EncoderInstruction -> EncoderInstruction -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EncoderInstruction -> EncoderInstruction -> Bool
$c/= :: EncoderInstruction -> EncoderInstruction -> Bool
== :: EncoderInstruction -> EncoderInstruction -> Bool
$c== :: EncoderInstruction -> EncoderInstruction -> Bool
Eq)

instance Show EncoderInstruction where
    show :: EncoderInstruction -> String
show (SetDynamicTableCapacity Offset
n) = String
"SetDynamicTableCapacity " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Offset
n
    show (InsertWithNameReference (Left AbsoluteIndex
aidx) HeaderValue
v) = String
"InsertWithNameReference \"" forall a. [a] -> [a] -> [a]
++ HeaderValue -> String
BS8.unpack (Entry -> HeaderValue
entryHeaderName (AbsoluteIndex -> Entry
toStaticEntry AbsoluteIndex
aidx)) forall a. [a] -> [a] -> [a]
++ String
"\" \"" forall a. [a] -> [a] -> [a]
++ HeaderValue -> String
BS8.unpack HeaderValue
v forall a. [a] -> [a] -> [a]
++ String
"\""
    show (InsertWithNameReference (Right (InsRelativeIndex Offset
idx)) HeaderValue
v) = String
"InsertWithNameReference (DynRel " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Offset
idx forall a. [a] -> [a] -> [a]
++ String
") \"" forall a. [a] -> [a] -> [a]
++ HeaderValue -> String
BS8.unpack HeaderValue
v forall a. [a] -> [a] -> [a]
++ String
"\""
    show (InsertWithoutNameReference Token
t HeaderValue
v) = String
"InsertWithoutNameReference \"" forall a. [a] -> [a] -> [a]
++ HeaderValue -> String
BS8.unpack (forall s. CI s -> s
foldedCase (Token -> CI HeaderValue
tokenKey Token
t)) forall a. [a] -> [a] -> [a]
++ String
"\" \"" forall a. [a] -> [a] -> [a]
++ HeaderValue -> String
BS8.unpack HeaderValue
v forall a. [a] -> [a] -> [a]
++ String
"\""
    show (Duplicate (InsRelativeIndex Offset
idx)) = String
"Duplicate (DynRel " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Offset
idx forall a. [a] -> [a] -> [a]
++ String
")"

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

encodeEncoderInstructions :: [EncoderInstruction] -> Bool -> IO ByteString
encodeEncoderInstructions :: [EncoderInstruction] -> Bool -> IO HeaderValue
encodeEncoderInstructions [EncoderInstruction]
eis Bool
huff = Offset -> (WriteBuffer -> IO ()) -> IO HeaderValue
withWriteBuffer Offset
4096 forall a b. (a -> b) -> a -> b
$ \WriteBuffer
wbuf ->
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (WriteBuffer -> Bool -> EncoderInstruction -> IO ()
encodeEI WriteBuffer
wbuf Bool
huff) [EncoderInstruction]
eis

encodeEI :: WriteBuffer -> Bool -> EncoderInstruction -> IO ()
encodeEI :: WriteBuffer -> Bool -> EncoderInstruction -> IO ()
encodeEI WriteBuffer
wbuf Bool
_    (SetDynamicTableCapacity Offset
cap) = WriteBuffer -> (Word8 -> Word8) -> Offset -> Offset -> IO ()
encodeI WriteBuffer
wbuf Word8 -> Word8
set001 Offset
5 Offset
cap
encodeEI WriteBuffer
wbuf Bool
huff (InsertWithNameReference InsIndex
hidx HeaderValue
v) = do
    let (Word8 -> Word8
set, Offset
idx) = case InsIndex
hidx of
          Left  (AbsoluteIndex Offset
i)    -> (Word8 -> Word8
set11, Offset
i)
          Right (InsRelativeIndex Offset
i) -> (Word8 -> Word8
set1,  Offset
i)
    WriteBuffer -> (Word8 -> Word8) -> Offset -> Offset -> IO ()
encodeI WriteBuffer
wbuf Word8 -> Word8
set Offset
6 Offset
idx
    WriteBuffer
-> Bool
-> (Word8 -> Word8)
-> (Word8 -> Word8)
-> Offset
-> HeaderValue
-> IO ()
encodeS WriteBuffer
wbuf Bool
huff forall a. a -> a
id Word8 -> Word8
set1 Offset
7 HeaderValue
v
encodeEI WriteBuffer
wbuf Bool
huff (InsertWithoutNameReference Token
k HeaderValue
v) = do
    WriteBuffer
-> Bool
-> (Word8 -> Word8)
-> (Word8 -> Word8)
-> Offset
-> HeaderValue
-> IO ()
encodeS WriteBuffer
wbuf Bool
huff Word8 -> Word8
set01 Word8 -> Word8
set001 Offset
5 forall a b. (a -> b) -> a -> b
$ forall s. CI s -> s
foldedCase forall a b. (a -> b) -> a -> b
$ Token -> CI HeaderValue
tokenKey Token
k
    WriteBuffer
-> Bool
-> (Word8 -> Word8)
-> (Word8 -> Word8)
-> Offset
-> HeaderValue
-> IO ()
encodeS WriteBuffer
wbuf Bool
huff forall a. a -> a
id    Word8 -> Word8
set1   Offset
7 HeaderValue
v
encodeEI WriteBuffer
wbuf Bool
_    (Duplicate (InsRelativeIndex Offset
idx)) = WriteBuffer -> (Word8 -> Word8) -> Offset -> Offset -> IO ()
encodeI WriteBuffer
wbuf Word8 -> Word8
set000 Offset
5 Offset
idx

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

decodeEncoderInstructions' :: ByteString -> IO ([EncoderInstruction], ByteString)
decodeEncoderInstructions' :: HeaderValue -> IO ([EncoderInstruction], HeaderValue)
decodeEncoderInstructions' HeaderValue
bs = do
    let bufsiz :: Offset
bufsiz = Offset
4096
    ForeignPtr Word8
gcbuf <- forall a. Offset -> IO (ForeignPtr a)
mallocPlainForeignPtrBytes Offset
4096
    HuffmanDecoder
-> HeaderValue -> IO ([EncoderInstruction], HeaderValue)
decodeEncoderInstructions (ForeignPtr Word8 -> Offset -> HuffmanDecoder
decodeH ForeignPtr Word8
gcbuf Offset
bufsiz) HeaderValue
bs

decodeEncoderInstructions :: HuffmanDecoder -> ByteString -> IO ([EncoderInstruction],ByteString)
decodeEncoderInstructions :: HuffmanDecoder
-> HeaderValue -> IO ([EncoderInstruction], HeaderValue)
decodeEncoderInstructions HuffmanDecoder
hufdec HeaderValue
bs = forall a. HeaderValue -> (ReadBuffer -> IO a) -> IO a
withReadBuffer HeaderValue
bs forall a b. (a -> b) -> a -> b
$ forall {c}.
([EncoderInstruction] -> c) -> ReadBuffer -> IO (c, HeaderValue)
loop forall a. a -> a
id
  where
    loop :: ([EncoderInstruction] -> c) -> ReadBuffer -> IO (c, HeaderValue)
loop [EncoderInstruction] -> c
build ReadBuffer
rbuf = do
        Offset
n <- forall a. Readable a => a -> IO Offset
remainingSize ReadBuffer
rbuf
        if Offset
n forall a. Eq a => a -> a -> Bool
== Offset
0 then do
            let eis :: c
eis = [EncoderInstruction] -> c
build []
            forall (m :: * -> *) a. Monad m => a -> m a
return (c
eis, HeaderValue
"")
          else do
            forall a. Readable a => a -> IO ()
save ReadBuffer
rbuf
            Either BufferOverrun EncoderInstruction
er <- forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
E.try forall a b. (a -> b) -> a -> b
$ HuffmanDecoder -> ReadBuffer -> IO EncoderInstruction
decodeEI HuffmanDecoder
hufdec ReadBuffer
rbuf
            case Either BufferOverrun EncoderInstruction
er of
              Right EncoderInstruction
r -> ([EncoderInstruction] -> c) -> ReadBuffer -> IO (c, HeaderValue)
loop ([EncoderInstruction] -> c
build forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EncoderInstruction
r forall a. a -> [a] -> [a]
:)) ReadBuffer
rbuf
              Left BufferOverrun
BufferOverrun -> do
                  forall a. Readable a => a -> IO ()
goBack ReadBuffer
rbuf
                  Offset
rn <- forall a. Readable a => a -> IO Offset
remainingSize ReadBuffer
rbuf
                  HeaderValue
left <- forall a. Readable a => a -> Offset -> IO HeaderValue
extractByteString ReadBuffer
rbuf Offset
rn
                  let eis :: c
eis = [EncoderInstruction] -> c
build []
                  forall (m :: * -> *) a. Monad m => a -> m a
return (c
eis, HeaderValue
left)

decodeEI :: HuffmanDecoder -> ReadBuffer -> IO EncoderInstruction
decodeEI :: HuffmanDecoder -> ReadBuffer -> IO EncoderInstruction
decodeEI HuffmanDecoder
hufdec ReadBuffer
rbuf = do
    Word8
w8 <- forall a. Readable a => a -> IO Word8
read8 ReadBuffer
rbuf
    if Word8
w8 forall a. Bits a => a -> Offset -> Bool
`testBit` Offset
7 then
        ReadBuffer -> Word8 -> HuffmanDecoder -> IO EncoderInstruction
decodeInsertWithNameReference ReadBuffer
rbuf Word8
w8 HuffmanDecoder
hufdec
      else if Word8
w8 forall a. Bits a => a -> Offset -> Bool
`testBit` Offset
6 then
        ReadBuffer -> HuffmanDecoder -> IO EncoderInstruction
decodeInsertWithoutNameReference ReadBuffer
rbuf HuffmanDecoder
hufdec
      else if Word8
w8 forall a. Bits a => a -> Offset -> Bool
`testBit` Offset
5 then
        ReadBuffer -> Word8 -> IO EncoderInstruction
decodeSetDynamicTableCapacity ReadBuffer
rbuf Word8
w8
      else
        ReadBuffer -> Word8 -> IO EncoderInstruction
decodeDuplicate ReadBuffer
rbuf Word8
w8

decodeInsertWithNameReference :: ReadBuffer -> Word8 -> HuffmanDecoder -> IO EncoderInstruction
decodeInsertWithNameReference :: ReadBuffer -> Word8 -> HuffmanDecoder -> IO EncoderInstruction
decodeInsertWithNameReference ReadBuffer
rbuf Word8
w8 HuffmanDecoder
hufdec = do
    Offset
idx <- Offset -> Word8 -> ReadBuffer -> IO Offset
decodeI Offset
6 (Word8
w8 forall a. Bits a => a -> a -> a
.&. Word8
0b00111111) ReadBuffer
rbuf
    let hidx :: InsIndex
hidx | Word8
w8 forall a. Bits a => a -> Offset -> Bool
`testBit` Offset
6 = forall a b. a -> Either a b
Left (Offset -> AbsoluteIndex
AbsoluteIndex Offset
idx)
             | Bool
otherwise      = forall a b. b -> Either a b
Right (Offset -> InsRelativeIndex
InsRelativeIndex Offset
idx)
    HeaderValue
v <- (Word8 -> Word8)
-> (Word8 -> Bool)
-> Offset
-> HuffmanDecoder
-> ReadBuffer
-> IO HeaderValue
decodeS (forall a. Bits a => a -> a -> a
.&. Word8
0b01111111) (forall a. Bits a => a -> Offset -> Bool
`testBit` Offset
7) Offset
7 HuffmanDecoder
hufdec ReadBuffer
rbuf
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ InsIndex -> HeaderValue -> EncoderInstruction
InsertWithNameReference InsIndex
hidx HeaderValue
v

decodeInsertWithoutNameReference :: ReadBuffer -> HuffmanDecoder -> IO EncoderInstruction
decodeInsertWithoutNameReference :: ReadBuffer -> HuffmanDecoder -> IO EncoderInstruction
decodeInsertWithoutNameReference ReadBuffer
rbuf HuffmanDecoder
hufdec = do
    forall a. Readable a => a -> Offset -> IO ()
ff ReadBuffer
rbuf (-Offset
1)
    HeaderValue
k <- (Word8 -> Word8)
-> (Word8 -> Bool)
-> Offset
-> HuffmanDecoder
-> ReadBuffer
-> IO HeaderValue
decodeS (forall a. Bits a => a -> a -> a
.&. Word8
0b00011111) (forall a. Bits a => a -> Offset -> Bool
`testBit` Offset
5) Offset
5 HuffmanDecoder
hufdec ReadBuffer
rbuf
    HeaderValue
v <- (Word8 -> Word8)
-> (Word8 -> Bool)
-> Offset
-> HuffmanDecoder
-> ReadBuffer
-> IO HeaderValue
decodeS (forall a. Bits a => a -> a -> a
.&. Word8
0b01111111) (forall a. Bits a => a -> Offset -> Bool
`testBit` Offset
7) Offset
7 HuffmanDecoder
hufdec ReadBuffer
rbuf
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Token -> HeaderValue -> EncoderInstruction
InsertWithoutNameReference (HeaderValue -> Token
toToken HeaderValue
k)  HeaderValue
v

decodeSetDynamicTableCapacity :: ReadBuffer -> Word8 -> IO EncoderInstruction
decodeSetDynamicTableCapacity :: ReadBuffer -> Word8 -> IO EncoderInstruction
decodeSetDynamicTableCapacity ReadBuffer
rbuf Word8
w8 =
    Offset -> EncoderInstruction
SetDynamicTableCapacity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Offset -> Word8 -> ReadBuffer -> IO Offset
decodeI Offset
5 (Word8
w8 forall a. Bits a => a -> a -> a
.&. Word8
0b00011111) ReadBuffer
rbuf

decodeDuplicate :: ReadBuffer -> Word8 -> IO EncoderInstruction
decodeDuplicate :: ReadBuffer -> Word8 -> IO EncoderInstruction
decodeDuplicate ReadBuffer
rbuf Word8
w8 =
    InsRelativeIndex -> EncoderInstruction
Duplicate forall b c a. (b -> c) -> (a -> b) -> a -> c
. Offset -> InsRelativeIndex
InsRelativeIndex forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Offset -> Word8 -> ReadBuffer -> IO Offset
decodeI Offset
5 (Word8
w8 forall a. Bits a => a -> a -> a
.&. Word8
0b00011111) ReadBuffer
rbuf

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

data DecoderInstruction = SectionAcknowledgement Int
                        | StreamCancellation Int
                        | InsertCountIncrement Int
                        deriving (DecoderInstruction -> DecoderInstruction -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DecoderInstruction -> DecoderInstruction -> Bool
$c/= :: DecoderInstruction -> DecoderInstruction -> Bool
== :: DecoderInstruction -> DecoderInstruction -> Bool
$c== :: DecoderInstruction -> DecoderInstruction -> Bool
Eq, Offset -> DecoderInstruction -> ShowS
[DecoderInstruction] -> ShowS
DecoderInstruction -> String
forall a.
(Offset -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DecoderInstruction] -> ShowS
$cshowList :: [DecoderInstruction] -> ShowS
show :: DecoderInstruction -> String
$cshow :: DecoderInstruction -> String
showsPrec :: Offset -> DecoderInstruction -> ShowS
$cshowsPrec :: Offset -> DecoderInstruction -> ShowS
Show)

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

encodeDecoderInstructions :: [DecoderInstruction] -> IO ByteString
encodeDecoderInstructions :: [DecoderInstruction] -> IO HeaderValue
encodeDecoderInstructions [DecoderInstruction]
dis = Offset -> (WriteBuffer -> IO ()) -> IO HeaderValue
withWriteBuffer Offset
4096 forall a b. (a -> b) -> a -> b
$ \WriteBuffer
wbuf ->
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (WriteBuffer -> DecoderInstruction -> IO ()
encodeDI WriteBuffer
wbuf) [DecoderInstruction]
dis

encodeDI :: WriteBuffer -> DecoderInstruction -> IO ()
encodeDI :: WriteBuffer -> DecoderInstruction -> IO ()
encodeDI WriteBuffer
wbuf (SectionAcknowledgement Offset
n) = WriteBuffer -> (Word8 -> Word8) -> Offset -> Offset -> IO ()
encodeI WriteBuffer
wbuf Word8 -> Word8
set1  Offset
7 Offset
n
encodeDI WriteBuffer
wbuf (StreamCancellation Offset
n)    = WriteBuffer -> (Word8 -> Word8) -> Offset -> Offset -> IO ()
encodeI WriteBuffer
wbuf Word8 -> Word8
set01 Offset
6 Offset
n
encodeDI WriteBuffer
wbuf (InsertCountIncrement Offset
n)  = WriteBuffer -> (Word8 -> Word8) -> Offset -> Offset -> IO ()
encodeI WriteBuffer
wbuf forall a. a -> a
id    Offset
6 Offset
n

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

decodeDecoderInstructions :: ByteString -> IO ([DecoderInstruction],ByteString)
decodeDecoderInstructions :: HeaderValue -> IO ([DecoderInstruction], HeaderValue)
decodeDecoderInstructions HeaderValue
bs = forall a. HeaderValue -> (ReadBuffer -> IO a) -> IO a
withReadBuffer HeaderValue
bs forall a b. (a -> b) -> a -> b
$ forall {c}.
([DecoderInstruction] -> c) -> ReadBuffer -> IO (c, HeaderValue)
loop forall a. a -> a
id
  where
    loop :: ([DecoderInstruction] -> c) -> ReadBuffer -> IO (c, HeaderValue)
loop [DecoderInstruction] -> c
build ReadBuffer
rbuf = do
        Offset
n <- forall a. Readable a => a -> IO Offset
remainingSize ReadBuffer
rbuf
        if Offset
n forall a. Eq a => a -> a -> Bool
== Offset
0 then do
            let dis :: c
dis = [DecoderInstruction] -> c
build []
            forall (m :: * -> *) a. Monad m => a -> m a
return (c
dis, HeaderValue
"")
          else do
            forall a. Readable a => a -> IO ()
save ReadBuffer
rbuf
            Either BufferOverrun DecoderInstruction
er <- forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
E.try forall a b. (a -> b) -> a -> b
$ ReadBuffer -> IO DecoderInstruction
decodeDI ReadBuffer
rbuf
            case Either BufferOverrun DecoderInstruction
er of
              Right DecoderInstruction
r -> ([DecoderInstruction] -> c) -> ReadBuffer -> IO (c, HeaderValue)
loop ([DecoderInstruction] -> c
build forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DecoderInstruction
r forall a. a -> [a] -> [a]
:)) ReadBuffer
rbuf
              Left BufferOverrun
BufferOverrun -> do
                  forall a. Readable a => a -> IO ()
goBack ReadBuffer
rbuf
                  Offset
rn <- forall a. Readable a => a -> IO Offset
remainingSize ReadBuffer
rbuf
                  HeaderValue
left <- forall a. Readable a => a -> Offset -> IO HeaderValue
extractByteString ReadBuffer
rbuf Offset
rn
                  let dis :: c
dis = [DecoderInstruction] -> c
build []
                  forall (m :: * -> *) a. Monad m => a -> m a
return (c
dis, HeaderValue
left)

decodeDI :: ReadBuffer -> IO DecoderInstruction
decodeDI :: ReadBuffer -> IO DecoderInstruction
decodeDI ReadBuffer
rbuf = do
    Word8
w8 <- forall a. Readable a => a -> IO Word8
read8 ReadBuffer
rbuf
    if Word8
w8 forall a. Bits a => a -> Offset -> Bool
`testBit` Offset
7 then
        Offset -> DecoderInstruction
SectionAcknowledgement forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Offset -> Word8 -> ReadBuffer -> IO Offset
decodeI Offset
7 (Word8
w8 forall a. Bits a => a -> a -> a
.&. Word8
0b01111111) ReadBuffer
rbuf
      else do
        Offset
i <- Offset -> Word8 -> ReadBuffer -> IO Offset
decodeI Offset
6 (Word8
w8 forall a. Bits a => a -> a -> a
.&. Word8
0b00111111) ReadBuffer
rbuf
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Word8
w8 forall a. Bits a => a -> Offset -> Bool
`testBit` Offset
6 then Offset -> DecoderInstruction
StreamCancellation Offset
i else Offset -> DecoderInstruction
InsertCountIncrement Offset
i