{-# LANGUAGE ExistentialQuantification #-}
{-# OPTIONS_HADDOCK hide #-}

module Network.TLS.Compression (
    CompressionC (..),
    Compression (..),
    CompressionID,
    nullCompression,
    NullCompression,

    -- * member redefined for the class abstraction
    compressionID,
    compressionDeflate,
    compressionInflate,

    -- * helper
    compressionIntersectID,
) where

import Control.Arrow (first)
import Network.TLS.Imports
import Network.TLS.Types (CompressionID)

-- | supported compression algorithms need to be part of this class
class CompressionC a where
    compressionCID :: a -> CompressionID
    compressionCDeflate :: a -> ByteString -> (a, ByteString)
    compressionCInflate :: a -> ByteString -> (a, ByteString)

-- | every compression need to be wrapped in this, to fit in structure
data Compression = forall a. CompressionC a => Compression a

-- | return the associated ID for this algorithm
compressionID :: Compression -> CompressionID
compressionID :: Compression -> CompressionID
compressionID (Compression a
c) = a -> CompressionID
forall a. CompressionC a => a -> CompressionID
compressionCID a
c

-- | deflate (compress) a bytestring using a compression context and return the result
-- along with the new compression context.
compressionDeflate :: ByteString -> Compression -> (Compression, ByteString)
compressionDeflate :: ByteString -> Compression -> (Compression, ByteString)
compressionDeflate ByteString
bytes (Compression a
c) = (a -> Compression) -> (a, ByteString) -> (Compression, ByteString)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a -> Compression
forall a. CompressionC a => a -> Compression
Compression ((a, ByteString) -> (Compression, ByteString))
-> (a, ByteString) -> (Compression, ByteString)
forall a b. (a -> b) -> a -> b
$ a -> ByteString -> (a, ByteString)
forall a. CompressionC a => a -> ByteString -> (a, ByteString)
compressionCDeflate a
c ByteString
bytes

-- | inflate (decompress) a bytestring using a compression context and return the result
-- along the new compression context.
compressionInflate :: ByteString -> Compression -> (Compression, ByteString)
compressionInflate :: ByteString -> Compression -> (Compression, ByteString)
compressionInflate ByteString
bytes (Compression a
c) = (a -> Compression) -> (a, ByteString) -> (Compression, ByteString)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a -> Compression
forall a. CompressionC a => a -> Compression
Compression ((a, ByteString) -> (Compression, ByteString))
-> (a, ByteString) -> (Compression, ByteString)
forall a b. (a -> b) -> a -> b
$ a -> ByteString -> (a, ByteString)
forall a. CompressionC a => a -> ByteString -> (a, ByteString)
compressionCInflate a
c ByteString
bytes

instance Show Compression where
    show :: Compression -> String
show = CompressionID -> String
forall a. Show a => a -> String
show (CompressionID -> String)
-> (Compression -> CompressionID) -> Compression -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compression -> CompressionID
compressionID
instance Eq Compression where
    == :: Compression -> Compression -> Bool
(==) Compression
c1 Compression
c2 = Compression -> CompressionID
compressionID Compression
c1 CompressionID -> CompressionID -> Bool
forall a. Eq a => a -> a -> Bool
== Compression -> CompressionID
compressionID Compression
c2

-- | intersect a list of ids commonly given by the other side with a list of compression
-- the function keeps the list of compression in order, to be able to find quickly the prefered
-- compression.
compressionIntersectID :: [Compression] -> [Word8] -> [Compression]
compressionIntersectID :: [Compression] -> [CompressionID] -> [Compression]
compressionIntersectID [Compression]
l [CompressionID]
ids = (Compression -> Bool) -> [Compression] -> [Compression]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Compression
c -> Compression -> CompressionID
compressionID Compression
c CompressionID -> [CompressionID] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CompressionID]
ids) [Compression]
l

-- | This is the default compression which is a NOOP.
data NullCompression = NullCompression

instance CompressionC NullCompression where
    compressionCID :: NullCompression -> CompressionID
compressionCID NullCompression
_ = CompressionID
0
    compressionCDeflate :: NullCompression -> ByteString -> (NullCompression, ByteString)
compressionCDeflate NullCompression
s ByteString
b = (NullCompression
s, ByteString
b)
    compressionCInflate :: NullCompression -> ByteString -> (NullCompression, ByteString)
compressionCInflate NullCompression
s ByteString
b = (NullCompression
s, ByteString
b)

-- | default null compression
nullCompression :: Compression
nullCompression :: Compression
nullCompression = NullCompression -> Compression
forall a. CompressionC a => a -> Compression
Compression NullCompression
NullCompression