content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE OverloadedStrings #-}
  
  module HPACKDecode (
      run,
      Result (..),
      EncodeStrategy (..),
      defaultEncodeStrategy,
      CompressionAlgo (..),
  ) where
  
  #if __GLASGOW_HASKELL__ < 709
  import Control.Applicative ((<$>))
  #endif
  import Control.Exception
  import Control.Monad (when)
  import qualified Data.ByteString.Base16 as B16
  import qualified Data.ByteString.Char8 as B8
  import Data.List (sort)
  import Network.HPACK
  import Network.HPACK.Table
  
  import JSON
  
  newtype Conf = Conf
      { debug :: Bool
      }
  
  data Result = Pass | Fail String deriving (Eq, Show)
  
  run :: Bool -> Test -> IO Result
  run _ (Test _ []) = return Pass
  run d (Test _ ccs) = do
      -- 'size c' must not be used. Initial value is defaultDynamicTableSize!
      withDynamicTableForDecoding defaultDynamicTableSize 4096 $ \dyntbl -> do
          let conf = Conf{debug = d}
          testLoop conf ccs dyntbl
  
  testLoop
      :: Conf
      -> [Case]
      -> DynamicTable
      -> IO Result
  testLoop _ [] _ = return Pass
  testLoop conf (c : cs) dyntbl = do
      res <- test conf c dyntbl
      case res of
          Nothing -> testLoop conf cs dyntbl
          Just e -> return $ Fail e
  
  test
      :: Conf
      -> Case
      -> DynamicTable
      -> IO (Maybe String)
  test conf c dyntbl = do
      -- context is destructive!!!
      when (debug conf) $ do
          putStrLn "--------------------------------"
          putStrLn "---- Input header list"
          printHeaderList $ sort hs
          putStrLn "---- Input header table"
          printDynamicTable dyntbl
          putStrLn "---- Input Hex"
          B8.putStrLn wirehex
      case size c of
          Nothing -> return ()
          Just siz -> renewDynamicTable siz dyntbl
      x <- try $ decodeHeader dyntbl inp
      case x of
          Left e -> return $ Just $ show (e :: DecodeError)
          Right hs' -> do
              let pass = sort hs == sort hs'
              if pass
                  then return Nothing
                  else
                      return $
                          Just $
                              "Headers are different in "
                                  ++ B8.unpack wirehex
                                  ++ ":\n"
                                  ++ show hs
                                  ++ "\n"
                                  ++ show hs'
    where
      wirehex = wire c
      inp = B16.decodeLenient wirehex
      hs = headers c
  
  -- | Printing '[Header]'.
  printHeaderList :: [Header] -> IO ()
  printHeaderList hs = mapM_ printHeader hs
    where
      printHeader (k, v) = do
          B8.putStr $ original k
          putStr ": "
          B8.putStr v
          putStr "\n"
  