QIFSpec.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module QPACK.QIFSpec where

import Conduit hiding (yield)
import Control.Concurrent
import Control.Concurrent.STM
import qualified Control.Exception as E
import Control.Monad
import Data.Attoparsec.ByteString (Parser)
import qualified Data.Attoparsec.ByteString as P
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import Data.Conduit.Attoparsec
import Network.QUIC (StreamId)
import System.IO
import Test.Hspec

import Network.QPACK

spec :: Spec
spec = do
    describe "simple decoder" $ do
        it "decodes well" $ do
            forM_ ["fb-req-hq", "fb-resp-hq", "netbsd-hq"] $ \svc ->
                forM_ ["f5", "ls-qpack", "nghttp3", "proxygen", "qthingey", "quinn"] $ \impl -> do
                    putStrLn $ impl ++ " with " ++ svc
                    let inp = "qifs/encoded/qpack-05/" ++ impl ++ "/" ++ svc ++ ".out.4096.0.0"
                        out = "qifs/qifs/" ++ svc ++ ".qif"
                    test inp out

data Block = Block Int ByteString deriving (Show)

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

test :: FilePath -> FilePath -> IO ()
test efile qfile = do
    (dec, insthdr) <- newQDecoderS defaultQDecoderConfig (\_ -> return ()) False
    q <- newTQueueIO
    let recv = atomically $ readTQueue q
        send x = atomically $ writeTQueue q x
    mvar <- newEmptyMVar
    withFile qfile ReadMode $ \h -> do
        tid <- forkIO $ decode dec h recv mvar
        runConduitRes
            (sourceFile efile .| conduitParser block .| mapM_C (liftIO . switch send insthdr))
        takeMVar mvar
        killThread tid

switch
    :: (Block -> IO ())
    -> EncoderInstructionHandlerS
    -> (PositionRange, Block)
    -> IO ()
switch send insthdr (_, blk@(Block n bs))
    | n == 0 = do
        insthdr bs
        yield
    | otherwise = send blk

decode
    :: (StreamId -> ByteString -> IO [Header])
    -> Handle
    -> IO Block
    -> MVar ()
    -> IO ()
decode dec h recv mvar = loop
  where
    loop = do
        hdr' <- fromCaseSensitive <$> headerlist h
        if null hdr'
            then
                putMVar mvar ()
            else do
                Block n bs <- recv
                hdr <- dec n bs
                hdr `shouldBe` hdr'
                loop

fromCaseSensitive :: [Header] -> [Header]
fromCaseSensitive = map (\(k, v) -> (foldedCase $ mk k, v))

block :: Parser Block
block = do
    num <- toInt <$> P.take 8
    len <- toInt <$> P.take 4
    dat <- P.take len
    return $ Block num dat

toInt :: ByteString -> Int
toInt bs = BS.foldl' f 0 bs
  where
    f n w8 = n * 256 + fromIntegral w8

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

headerlist :: Handle -> IO [Header]
headerlist h = loop id
  where
    loop b = do
        ml <- line h
        case ml of
            Nothing -> return $ b []
            Just l
                | l == "" -> return $ b []
                | otherwise -> do
                    let (k, v0) = BS8.break (== '\t') l
                        v = BS8.drop 1 v0
                    loop (b . ((mk k, v) :))

line :: Handle -> IO (Maybe ByteString)
line h = do
    el <- E.try $ BS8.hGetLine h
    case el of
        Left (_ :: E.IOException) -> return Nothing
        Right l
            | BS8.take 1 l == "#" -> line h
            | otherwise -> return $ Just l