{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wno-type-defaults #-}

module Bitcoin.CompactFilter (
    BlockFilter,
    blockFilter,
    BlockFilterHeader,
    blockFilterHeader,
    filterHeaderToHex,
    filterHeaderFromHex,
    genesisHeader,
    filterContents,
    encodeFilter,
    isMember,
) where

import Control.Monad (replicateM, (>=>))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Strict (StateT, evalStateT)
import qualified Control.Monad.Trans.State.Strict as St
import Data.Bits (shiftL, shiftR, testBit)
import Data.Bitstream (Bitstream, Right)
import qualified Data.Bitstream as BiS
import Data.Bool (bool)
import Data.ByteArray.Hash (
    SipHash (..),
    SipKey (..),
    sipHash,
 )
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Foldable (foldl')
import Data.List (sort)
import Data.Serialize (
    Get,
    Serialize (..),
    decode,
    encode,
    getWord16le,
    getWord32le,
    getWord64le,
    getWord8,
    putByteString,
    putWord16le,
    putWord32le,
    putWord64le,
    putWord8,
    runGet,
 )
import Data.Text (Text)
import Data.Word (Word64, Word8)
import Haskoin.Block (
    Block,
    BlockHash,
    blockHeader,
    blockTxns,
    headerHash,
 )
import Haskoin.Crypto (Hash256, doubleSHA256)
import Haskoin.Script (Script (..), ScriptOp (..))
import Haskoin.Transaction (scriptOutput, txOut)
import Haskoin.Util (decodeHex, encodeHex)

-- | SIP hash parameter
paramP :: Int
paramP :: Int
paramP = 19

-- | SIP hash parameter
paramM :: Word64
paramM :: Word64
paramM = 784931

-- | Hashes of scripts in the block
newtype BlockFilter = BlockFilter
    { -- | Get the list of hashes in increasing order
      BlockFilter -> [Word64]
blockFilter :: [Word64]
    }
    deriving (BlockFilter -> BlockFilter -> Bool
(BlockFilter -> BlockFilter -> Bool)
-> (BlockFilter -> BlockFilter -> Bool) -> Eq BlockFilter
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlockFilter -> BlockFilter -> Bool
$c/= :: BlockFilter -> BlockFilter -> Bool
== :: BlockFilter -> BlockFilter -> Bool
$c== :: BlockFilter -> BlockFilter -> Bool
Eq, Int -> BlockFilter -> ShowS
[BlockFilter] -> ShowS
BlockFilter -> String
(Int -> BlockFilter -> ShowS)
-> (BlockFilter -> String)
-> ([BlockFilter] -> ShowS)
-> Show BlockFilter
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BlockFilter] -> ShowS
$cshowList :: [BlockFilter] -> ShowS
show :: BlockFilter -> String
$cshow :: BlockFilter -> String
showsPrec :: Int -> BlockFilter -> ShowS
$cshowsPrec :: Int -> BlockFilter -> ShowS
Show)

-- | Number of elements in the filter
blockFilterSize :: BlockFilter -> CompactSize
blockFilterSize :: BlockFilter -> CompactSize
blockFilterSize = Int -> CompactSize
CompactSize (Int -> CompactSize)
-> (BlockFilter -> Int) -> BlockFilter -> CompactSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word64] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Word64] -> Int)
-> (BlockFilter -> [Word64]) -> BlockFilter -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockFilter -> [Word64]
blockFilter

newtype BlockFilterHeader = BlockFilterHeader {BlockFilterHeader -> Hash256
getBFHeader :: Hash256}
    deriving (BlockFilterHeader -> BlockFilterHeader -> Bool
(BlockFilterHeader -> BlockFilterHeader -> Bool)
-> (BlockFilterHeader -> BlockFilterHeader -> Bool)
-> Eq BlockFilterHeader
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlockFilterHeader -> BlockFilterHeader -> Bool
$c/= :: BlockFilterHeader -> BlockFilterHeader -> Bool
== :: BlockFilterHeader -> BlockFilterHeader -> Bool
$c== :: BlockFilterHeader -> BlockFilterHeader -> Bool
Eq, Int -> BlockFilterHeader -> ShowS
[BlockFilterHeader] -> ShowS
BlockFilterHeader -> String
(Int -> BlockFilterHeader -> ShowS)
-> (BlockFilterHeader -> String)
-> ([BlockFilterHeader] -> ShowS)
-> Show BlockFilterHeader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BlockFilterHeader] -> ShowS
$cshowList :: [BlockFilterHeader] -> ShowS
show :: BlockFilterHeader -> String
$cshow :: BlockFilterHeader -> String
showsPrec :: Int -> BlockFilterHeader -> ShowS
$cshowsPrec :: Int -> BlockFilterHeader -> ShowS
Show, Eq BlockFilterHeader
Eq BlockFilterHeader =>
(BlockFilterHeader -> BlockFilterHeader -> Ordering)
-> (BlockFilterHeader -> BlockFilterHeader -> Bool)
-> (BlockFilterHeader -> BlockFilterHeader -> Bool)
-> (BlockFilterHeader -> BlockFilterHeader -> Bool)
-> (BlockFilterHeader -> BlockFilterHeader -> Bool)
-> (BlockFilterHeader -> BlockFilterHeader -> BlockFilterHeader)
-> (BlockFilterHeader -> BlockFilterHeader -> BlockFilterHeader)
-> Ord BlockFilterHeader
BlockFilterHeader -> BlockFilterHeader -> Bool
BlockFilterHeader -> BlockFilterHeader -> Ordering
BlockFilterHeader -> BlockFilterHeader -> BlockFilterHeader
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BlockFilterHeader -> BlockFilterHeader -> BlockFilterHeader
$cmin :: BlockFilterHeader -> BlockFilterHeader -> BlockFilterHeader
max :: BlockFilterHeader -> BlockFilterHeader -> BlockFilterHeader
$cmax :: BlockFilterHeader -> BlockFilterHeader -> BlockFilterHeader
>= :: BlockFilterHeader -> BlockFilterHeader -> Bool
$c>= :: BlockFilterHeader -> BlockFilterHeader -> Bool
> :: BlockFilterHeader -> BlockFilterHeader -> Bool
$c> :: BlockFilterHeader -> BlockFilterHeader -> Bool
<= :: BlockFilterHeader -> BlockFilterHeader -> Bool
$c<= :: BlockFilterHeader -> BlockFilterHeader -> Bool
< :: BlockFilterHeader -> BlockFilterHeader -> Bool
$c< :: BlockFilterHeader -> BlockFilterHeader -> Bool
compare :: BlockFilterHeader -> BlockFilterHeader -> Ordering
$ccompare :: BlockFilterHeader -> BlockFilterHeader -> Ordering
$cp1Ord :: Eq BlockFilterHeader
Ord, Get BlockFilterHeader
Putter BlockFilterHeader
Putter BlockFilterHeader
-> Get BlockFilterHeader -> Serialize BlockFilterHeader
forall t. Putter t -> Get t -> Serialize t
get :: Get BlockFilterHeader
$cget :: Get BlockFilterHeader
put :: Putter BlockFilterHeader
$cput :: Putter BlockFilterHeader
Serialize)

filterHeaderToHex :: BlockFilterHeader -> Text
filterHeaderToHex :: BlockFilterHeader -> Text
filterHeaderToHex = ByteString -> Text
encodeHex (ByteString -> Text)
-> (BlockFilterHeader -> ByteString) -> BlockFilterHeader -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BS.reverse (ByteString -> ByteString)
-> (BlockFilterHeader -> ByteString)
-> BlockFilterHeader
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash256 -> ByteString
forall a. Serialize a => a -> ByteString
encode (Hash256 -> ByteString)
-> (BlockFilterHeader -> Hash256)
-> BlockFilterHeader
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockFilterHeader -> Hash256
getBFHeader

filterHeaderFromHex :: Text -> Either String BlockFilterHeader
filterHeaderFromHex :: Text -> Either String BlockFilterHeader
filterHeaderFromHex = Either String ByteString
-> (ByteString -> Either String ByteString)
-> Maybe ByteString
-> Either String ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String ByteString
forall a b. a -> Either a b
Left "Invalid hex") ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (Maybe ByteString -> Either String ByteString)
-> (Text -> Maybe ByteString) -> Text -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe ByteString
decodeHex (Text -> Either String ByteString)
-> (ByteString -> Either String BlockFilterHeader)
-> Text
-> Either String BlockFilterHeader
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ByteString -> Either String BlockFilterHeader
forall a. Serialize a => ByteString -> Either String a
decode (ByteString -> Either String BlockFilterHeader)
-> (ByteString -> ByteString)
-> ByteString
-> Either String BlockFilterHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BS.reverse

genesisHeader :: BlockFilterHeader
Right genesisHeader :: BlockFilterHeader
genesisHeader = Hash256 -> BlockFilterHeader
BlockFilterHeader (Hash256 -> BlockFilterHeader)
-> Either String Hash256 -> Either String BlockFilterHeader
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String Hash256
forall a. Serialize a => ByteString -> Either String a
decode (Int -> Word8 -> ByteString
BS.replicate 32 0x0)

-- | Calculate the header for the block filter
blockFilterHeader ::
    -- | previous header
    BlockFilterHeader ->
    -- | current filter
    BlockFilter ->
    BlockFilterHeader
blockFilterHeader :: BlockFilterHeader -> BlockFilter -> BlockFilterHeader
blockFilterHeader prev :: BlockFilterHeader
prev bf :: BlockFilter
bf =
    Hash256 -> BlockFilterHeader
BlockFilterHeader (Hash256 -> BlockFilterHeader)
-> (ByteString -> Hash256) -> ByteString -> BlockFilterHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Hash256
forall b. ByteArrayAccess b => b -> Hash256
doubleSHA256 (ByteString -> BlockFilterHeader)
-> ByteString -> BlockFilterHeader
forall a b. (a -> b) -> a -> b
$
        (Hash256 -> ByteString
forall a. Serialize a => a -> ByteString
encode (Hash256 -> ByteString)
-> (ByteString -> Hash256) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Hash256
forall b. ByteArrayAccess b => b -> Hash256
doubleSHA256) (BlockFilter -> ByteString
forall a. Serialize a => a -> ByteString
encode BlockFilter
bf) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Hash256 -> ByteString
forall a. Serialize a => a -> ByteString
encode (BlockFilterHeader -> Hash256
getBFHeader BlockFilterHeader
prev)

instance Serialize BlockFilter where
    put :: Putter BlockFilter
put bf :: BlockFilter
bf = Putter CompactSize
forall t. Serialize t => Putter t
put (BlockFilter -> CompactSize
blockFilterSize BlockFilter
bf) PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter ByteString
putByteString (Int -> [Word64] -> ByteString
constructGCS Int
paramP ([Word64] -> ByteString) -> [Word64] -> ByteString
forall a b. (a -> b) -> a -> b
$ BlockFilter -> [Word64]
blockFilter BlockFilter
bf)
    get :: Get BlockFilter
get = Get CompactSize
forall t. Serialize t => Get t
get Get CompactSize
-> (CompactSize -> Get BlockFilter) -> Get BlockFilter
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Word64] -> BlockFilter) -> Get [Word64] -> Get BlockFilter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Word64] -> BlockFilter
BlockFilter (Get [Word64] -> Get BlockFilter)
-> (CompactSize -> Get [Word64]) -> CompactSize -> Get BlockFilter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Get [Word64]
getGolombRiceSet Int
paramP (Int -> Get [Word64])
-> (CompactSize -> Int) -> CompactSize -> Get [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompactSize -> Int
unCompactSize

-- | Calculate the list of scripts which belong in the BIP158 block filter
filterContents ::
    -- | previous output scripts spent in this block
    [ByteString] ->
    Block ->
    [ByteString]
filterContents :: [ByteString] -> Block -> [ByteString]
filterContents prev :: [ByteString]
prev b :: Block
b = (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter ByteString -> Bool
scriptFilter [ByteString]
prev [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ByteString]
these
  where
    these :: [ByteString]
these = (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter ByteString -> Bool
scriptFilter ([ByteString] -> [ByteString])
-> ([TxOut] -> [ByteString]) -> [TxOut] -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut -> ByteString) -> [TxOut] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxOut -> ByteString
scriptOutput ([TxOut] -> [ByteString]) -> [TxOut] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Block -> [Tx]
blockTxns Block
b [Tx] -> (Tx -> [TxOut]) -> [TxOut]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx -> [TxOut]
txOut
    scriptFilter :: ByteString -> Bool
scriptFilter scr :: ByteString
scr = Bool -> Bool
not (ByteString -> Bool
BS.null ByteString
scr) Bool -> Bool -> Bool
&& ByteString -> Bool
contentFilter ByteString
scr

    contentFilter :: ByteString -> Bool
contentFilter bs :: ByteString
bs = case ByteString -> Either String Script
forall a. Serialize a => ByteString -> Either String a
decode ByteString
bs of
        Right (Script (OP_RETURN : _)) -> Bool
False
        _ -> Bool
True

-- | Construct a BIP158 filter from a block
encodeFilter ::
    -- | output scripts spent in this block
    [ByteString] ->
    Block ->
    BlockFilter
encodeFilter :: [ByteString] -> Block -> BlockFilter
encodeFilter os :: [ByteString]
os b :: Block
b = [Word64] -> BlockFilter
BlockFilter [Word64]
s
  where
    h :: BlockHash
h = BlockHeader -> BlockHash
headerHash (BlockHeader -> BlockHash) -> BlockHeader -> BlockHash
forall a b. (a -> b) -> a -> b
$ Block -> BlockHeader
blockHeader Block
b
    bs :: [ByteString]
bs = [ByteString] -> [ByteString]
forall a. Ord a => [a] -> [a]
toSet ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Block -> [ByteString]
filterContents [ByteString]
os Block
b
    s :: [Word64]
s = SipKey -> Word64 -> Int -> [ByteString] -> [Word64]
hashedSetConstruct (BlockHash -> SipKey
sipKey BlockHash
h) Word64
paramM ([ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
bs) [ByteString]
bs

-- | Test membership.  The test succeeds if /any/ of the scripts matches the block filter.
isMember ::
    BlockHash ->
    -- | Scripts we want to match against the filter
    [ByteString] ->
    BlockFilter ->
    Bool
isMember :: BlockHash -> [ByteString] -> BlockFilter -> Bool
isMember h :: BlockHash
h bs :: [ByteString]
bs (BlockFilter bf :: [Word64]
bf) = [Word64] -> [Word64] -> Bool
orderedScan [Word64]
hs [Word64]
bf
  where
    k :: SipKey
k = BlockHash -> SipKey
sipKey BlockHash
h
    hs :: [Word64]
hs = SipKey -> Word64 -> Int -> [ByteString] -> [Word64]
hashedSetConstruct SipKey
k Word64
paramM ([Word64] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word64]
bf) [ByteString]
bs

orderedScan :: [Word64] -> [Word64] -> Bool
orderedScan :: [Word64] -> [Word64] -> Bool
orderedScan xs :: [Word64]
xs@(x :: Word64
x : xs' :: [Word64]
xs') hs :: [Word64]
hs@(h :: Word64
h : hs' :: [Word64]
hs')
    | Word64
x Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
h = [Word64] -> [Word64] -> Bool
orderedScan [Word64]
xs [Word64]
hs'
    | Word64
x Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
h = [Word64] -> [Word64] -> Bool
orderedScan [Word64]
xs' [Word64]
hs
    | Bool
otherwise = Bool
True
orderedScan _ _ = Bool
False

type GetBits = StateT [Bool] Get

getGolombRiceSet :: Int -> Int -> Get [Word64]
getGolombRiceSet :: Int -> Int -> Get [Word64]
getGolombRiceSet p :: Int
p n :: Int
n = ([Word64] -> [Word64]) -> Get [Word64] -> Get [Word64]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Word64] -> [Word64]
forall a. Num a => [a] -> [a]
unDiffs (Get [Word64] -> Get [Word64])
-> (GetBits [Word64] -> Get [Word64])
-> GetBits [Word64]
-> Get [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GetBits [Word64] -> Get [Word64]
forall a. GetBits a -> Get a
evalBitstream (GetBits [Word64] -> Get [Word64])
-> GetBits [Word64] -> Get [Word64]
forall a b. (a -> b) -> a -> b
$ Int -> StateT [Bool] Get Word64 -> GetBits [Word64]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n StateT [Bool] Get Word64
getEncoded
  where
    getEncoded :: StateT [Bool] Get Word64
getEncoded = do
        Word64
q <- StateT [Bool] Get Word64
unaryPart
        Word64
r <- [Bool] -> Word64
forall a. Num a => [Bool] -> a
fromBits ([Bool] -> Word64)
-> StateT [Bool] Get [Bool] -> StateT [Bool] Get Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> StateT [Bool] Get [Bool]
getBits Int
p
        Word64 -> StateT [Bool] Get Word64
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> StateT [Bool] Get Word64)
-> Word64 -> StateT [Bool] Get Word64
forall a b. (a -> b) -> a -> b
$ Word64
q Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* 2 Word64 -> Int -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
p Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
r

unaryPart :: GetBits Word64
unaryPart :: StateT [Bool] Get Word64
unaryPart = Word64 -> StateT [Bool] Get Word64
forall b. Num b => b -> StateT [Bool] Get b
go 0
  where
    go :: b -> StateT [Bool] Get b
go q :: b
q = StateT [Bool] Get Bool
getBit StateT [Bool] Get Bool
-> (Bool -> StateT [Bool] Get b) -> StateT [Bool] Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StateT [Bool] Get b
-> StateT [Bool] Get b -> Bool -> StateT [Bool] Get b
forall a. a -> a -> Bool -> a
bool (b -> StateT [Bool] Get b
forall (m :: * -> *) a. Monad m => a -> m a
return b
q) (b -> StateT [Bool] Get b
go (b -> StateT [Bool] Get b) -> b -> StateT [Bool] Get b
forall a b. (a -> b) -> a -> b
$ b
q b -> b -> b
forall a. Num a => a -> a -> a
+ 1)
    getBit :: StateT [Bool] Get Bool
getBit = [Bool] -> Bool
forall a. [a] -> a
head ([Bool] -> Bool)
-> StateT [Bool] Get [Bool] -> StateT [Bool] Get Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> StateT [Bool] Get [Bool]
getBits 1

evalBitstream :: GetBits a -> Get a
evalBitstream :: GetBits a -> Get a
evalBitstream = (GetBits a -> [Bool] -> Get a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` [Bool]
forall a. Monoid a => a
mempty)

getBits :: Int -> GetBits [Bool]
getBits :: Int -> StateT [Bool] Get [Bool]
getBits n :: Int
n = do
    [Bool]
bs <- StateT [Bool] Get [Bool]
forall (m :: * -> *) s. Monad m => StateT s m s
St.get
    let l :: Int
l = [Bool] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bool]
bs
        (q :: Int
q, r :: Int
r) = (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` 8

        combine :: [[Bool]] -> [Bool] -> [Bool]
combine m :: [[Bool]]
m t :: [Bool]
t = [Bool]
bs [Bool] -> [Bool] -> [Bool]
forall a. Semigroup a => a -> a -> a
<> [[Bool]] -> [Bool]
forall a. Monoid a => [a] -> a
mconcat [[Bool]]
m [Bool] -> [Bool] -> [Bool]
forall a. Semigroup a => a -> a -> a
<> [Bool]
t

        lastByte :: StateT [Bool] Get [Bool]
lastByte
            | Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 = StateT [Bool] Get [Bool]
getBs StateT [Bool] Get [Bool]
-> ([Bool] -> StateT [Bool] Get [Bool]) -> StateT [Bool] Get [Bool]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> [Bool] -> StateT [Bool] Get [Bool]
forall (m :: * -> *) a. Monad m => Int -> [a] -> StateT [a] m [a]
takeSome Int
r
            | Bool
otherwise = [Bool]
forall a. Monoid a => a
mempty [Bool] -> StateT [Bool] Get () -> StateT [Bool] Get [Bool]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Bool] -> StateT [Bool] Get ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
St.put [Bool]
forall a. Monoid a => a
mempty

        getBs :: StateT [Bool] Get [Bool]
getBs = Word8 -> [Bool]
byteBits (Word8 -> [Bool])
-> StateT [Bool] Get Word8 -> StateT [Bool] Get [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8 -> StateT [Bool] Get Word8
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Word8
getWord8
        takeSome :: Int -> [a] -> StateT [a] m [a]
takeSome m :: Int
m xs :: [a]
xs = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
m [a]
xs [a] -> StateT [a] m () -> StateT [a] m [a]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [a] -> StateT [a] m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
St.put (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
m [a]
xs)

    if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
l
        then Int -> [Bool] -> StateT [Bool] Get [Bool]
forall (m :: * -> *) a. Monad m => Int -> [a] -> StateT [a] m [a]
takeSome Int
n [Bool]
bs
        else [[Bool]] -> [Bool] -> [Bool]
combine ([[Bool]] -> [Bool] -> [Bool])
-> StateT [Bool] Get [[Bool]]
-> StateT [Bool] Get ([Bool] -> [Bool])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> StateT [Bool] Get [Bool] -> StateT [Bool] Get [[Bool]]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
q StateT [Bool] Get [Bool]
getBs StateT [Bool] Get ([Bool] -> [Bool])
-> StateT [Bool] Get [Bool] -> StateT [Bool] Get [Bool]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT [Bool] Get [Bool]
lastByte

sipKey :: BlockHash -> SipKey
sipKey :: BlockHash -> SipKey
sipKey h :: BlockHash
h = Word64 -> Word64 -> SipKey
SipKey Word64
k1 Word64
k2
  where
    Right (k1 :: Word64
k1, k2 :: Word64
k2) = Get (Word64, Word64)
-> ByteString -> Either String (Word64, Word64)
forall a. Get a -> ByteString -> Either String a
runGet Get (Word64, Word64)
word64Pair (ByteString -> Either String (Word64, Word64))
-> ByteString -> Either String (Word64, Word64)
forall a b. (a -> b) -> a -> b
$ BlockHash -> ByteString
forall a. Serialize a => a -> ByteString
encode BlockHash
h
    word64Pair :: Get (Word64, Word64)
word64Pair = (,) (Word64 -> Word64 -> (Word64, Word64))
-> Get Word64 -> Get (Word64 -> (Word64, Word64))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord64le Get (Word64 -> (Word64, Word64))
-> Get Word64 -> Get (Word64, Word64)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word64
getWord64le

hashToRange :: Word64 -> SipKey -> ByteString -> Word64
hashToRange :: Word64 -> SipKey -> ByteString -> Word64
hashToRange f :: Word64
f k :: SipKey
k bs :: ByteString
bs = Word64
v
  where
    SipHash h :: Word64
h = SipKey -> ByteString -> SipHash
forall ba. ByteArrayAccess ba => SipKey -> ba -> SipHash
sipHash SipKey
k ByteString
bs
    v :: Word64
v = Integer -> Integer -> Word64
remap (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
f) (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
h)

    remap :: Integer -> Integer -> Word64
    remap :: Integer -> Integer -> Word64
remap x :: Integer
x y :: Integer
y = Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word64) -> Integer -> Word64
forall a b. (a -> b) -> a -> b
$ (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
y) Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` 64

hashedSetConstruct :: SipKey -> Word64 -> Int -> [ByteString] -> [Word64]
hashedSetConstruct :: SipKey -> Word64 -> Int -> [ByteString] -> [Word64]
hashedSetConstruct k :: SipKey
k m :: Word64
m n :: Int
n bs :: [ByteString]
bs = [Word64] -> [Word64]
forall a. Ord a => [a] -> [a]
toSet ([Word64] -> [Word64]) -> [Word64] -> [Word64]
forall a b. (a -> b) -> a -> b
$ Word64 -> SipKey -> ByteString -> Word64
hashToRange Word64
f SipKey
k (ByteString -> Word64) -> [ByteString] -> [Word64]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteString]
bs
  where
    f :: Word64
f = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
m

toSet :: Ord a => [a] -> [a]
toSet :: [a] -> [a]
toSet = [a] -> [a]
dedup ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. Ord a => [a] -> [a]
sort
  where
    dedup :: [a] -> [a]
dedup = \case
        (x0 :: a
x0 : xs :: [a]
xs@(x1 :: a
x1 : _))
            | a
x0 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x1 -> [a] -> [a]
dedup [a]
xs
            | Bool
otherwise -> a
x0 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
dedup [a]
xs
        xs :: [a]
xs -> [a]
xs

constructGCS ::
    -- | modulus
    Int ->
    -- | sorted list of input values
    [Word64] ->
    ByteString
constructGCS :: Int -> [Word64] -> ByteString
constructGCS p :: Int
p =
    Bitstream Right -> ByteString
forall d.
(Bitstream (Bitstream d), Bitstream (Packet d)) =>
Bitstream d -> ByteString
BiS.toByteString
        (Bitstream Right -> ByteString)
-> ([Word64] -> Bitstream Right) -> [Word64] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64 -> Bitstream Right) -> [Word64] -> Bitstream Right
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int -> Word64 -> Bitstream Right
golombRiceEncode Int
p)
        ([Word64] -> Bitstream Right)
-> ([Word64] -> [Word64]) -> [Word64] -> Bitstream Right
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word64] -> [Word64]
forall a. Num a => [a] -> [a]
diffs

diffs :: Num a => [a] -> [a]
diffs :: [a] -> [a]
diffs xs :: [a]
xs = (a -> a -> a) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (-) [a]
xs (0 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs)

unDiffs :: Num a => [a] -> [a]
unDiffs :: [a] -> [a]
unDiffs (x :: a
x : xs :: [a]
xs) = (a -> a -> a) -> a -> [a] -> [a]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl a -> a -> a
forall a. Num a => a -> a -> a
(+) a
x [a]
xs
unDiffs [] = []

golombRiceEncode :: Int -> Word64 -> Bitstream Right
golombRiceEncode :: Int -> Word64 -> Bitstream Right
golombRiceEncode p :: Int
p v :: Word64
v = Bitstream Right
x Bitstream Right -> Bitstream Right -> Bitstream Right
forall a. Semigroup a => a -> a -> a
<> Bool -> Bitstream Right
forall α. Bitstream α => Bool -> α
BiS.singleton Bool
False Bitstream Right -> Bitstream Right -> Bitstream Right
forall a. Semigroup a => a -> a -> a
<> Bitstream Right
y
  where
    q :: Integer
q = Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ Word64
v Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
p
    x :: Bitstream Right
x = Integer -> Bool -> Bitstream Right
forall n α. (Integral n, Bitstream α) => n -> Bool -> α
BiS.replicate Integer
q Bool
True
    y :: Bitstream Right
y = Int -> Word64 -> Bitstream Right
forall n β α.
(Integral n, Integral β, Bits β, Bitstream α) =>
n -> β -> α
BiS.fromNBits Int
p Word64
v

fromBits :: Num a => [Bool] -> a
fromBits :: [Bool] -> a
fromBits = (a -> Bool -> a) -> a -> [Bool] -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' a -> Bool -> a
forall a. Num a => a -> Bool -> a
onBit 0
  where
    onBit :: a -> Bool -> a
onBit n :: a
n b :: Bool
b = 2 a -> a -> a
forall a. Num a => a -> a -> a
* a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a -> Bool -> a
forall a. a -> a -> Bool -> a
bool 0 1 Bool
b

byteBits :: Word8 -> [Bool]
byteBits :: Word8 -> [Bool]
byteBits b :: Word8
b = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
b (Int -> Bool) -> [Int] -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> [Int]
forall a. [a] -> [a]
reverse [0 .. 7]

newtype CompactSize = CompactSize {CompactSize -> Int
unCompactSize :: Int} deriving (CompactSize -> CompactSize -> Bool
(CompactSize -> CompactSize -> Bool)
-> (CompactSize -> CompactSize -> Bool) -> Eq CompactSize
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CompactSize -> CompactSize -> Bool
$c/= :: CompactSize -> CompactSize -> Bool
== :: CompactSize -> CompactSize -> Bool
$c== :: CompactSize -> CompactSize -> Bool
Eq, Eq CompactSize
Eq CompactSize =>
(CompactSize -> CompactSize -> Ordering)
-> (CompactSize -> CompactSize -> Bool)
-> (CompactSize -> CompactSize -> Bool)
-> (CompactSize -> CompactSize -> Bool)
-> (CompactSize -> CompactSize -> Bool)
-> (CompactSize -> CompactSize -> CompactSize)
-> (CompactSize -> CompactSize -> CompactSize)
-> Ord CompactSize
CompactSize -> CompactSize -> Bool
CompactSize -> CompactSize -> Ordering
CompactSize -> CompactSize -> CompactSize
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CompactSize -> CompactSize -> CompactSize
$cmin :: CompactSize -> CompactSize -> CompactSize
max :: CompactSize -> CompactSize -> CompactSize
$cmax :: CompactSize -> CompactSize -> CompactSize
>= :: CompactSize -> CompactSize -> Bool
$c>= :: CompactSize -> CompactSize -> Bool
> :: CompactSize -> CompactSize -> Bool
$c> :: CompactSize -> CompactSize -> Bool
<= :: CompactSize -> CompactSize -> Bool
$c<= :: CompactSize -> CompactSize -> Bool
< :: CompactSize -> CompactSize -> Bool
$c< :: CompactSize -> CompactSize -> Bool
compare :: CompactSize -> CompactSize -> Ordering
$ccompare :: CompactSize -> CompactSize -> Ordering
$cp1Ord :: Eq CompactSize
Ord, Int -> CompactSize
CompactSize -> Int
CompactSize -> [CompactSize]
CompactSize -> CompactSize
CompactSize -> CompactSize -> [CompactSize]
CompactSize -> CompactSize -> CompactSize -> [CompactSize]
(CompactSize -> CompactSize)
-> (CompactSize -> CompactSize)
-> (Int -> CompactSize)
-> (CompactSize -> Int)
-> (CompactSize -> [CompactSize])
-> (CompactSize -> CompactSize -> [CompactSize])
-> (CompactSize -> CompactSize -> [CompactSize])
-> (CompactSize -> CompactSize -> CompactSize -> [CompactSize])
-> Enum CompactSize
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: CompactSize -> CompactSize -> CompactSize -> [CompactSize]
$cenumFromThenTo :: CompactSize -> CompactSize -> CompactSize -> [CompactSize]
enumFromTo :: CompactSize -> CompactSize -> [CompactSize]
$cenumFromTo :: CompactSize -> CompactSize -> [CompactSize]
enumFromThen :: CompactSize -> CompactSize -> [CompactSize]
$cenumFromThen :: CompactSize -> CompactSize -> [CompactSize]
enumFrom :: CompactSize -> [CompactSize]
$cenumFrom :: CompactSize -> [CompactSize]
fromEnum :: CompactSize -> Int
$cfromEnum :: CompactSize -> Int
toEnum :: Int -> CompactSize
$ctoEnum :: Int -> CompactSize
pred :: CompactSize -> CompactSize
$cpred :: CompactSize -> CompactSize
succ :: CompactSize -> CompactSize
$csucc :: CompactSize -> CompactSize
Enum, Integer -> CompactSize
CompactSize -> CompactSize
CompactSize -> CompactSize -> CompactSize
(CompactSize -> CompactSize -> CompactSize)
-> (CompactSize -> CompactSize -> CompactSize)
-> (CompactSize -> CompactSize -> CompactSize)
-> (CompactSize -> CompactSize)
-> (CompactSize -> CompactSize)
-> (CompactSize -> CompactSize)
-> (Integer -> CompactSize)
-> Num CompactSize
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> CompactSize
$cfromInteger :: Integer -> CompactSize
signum :: CompactSize -> CompactSize
$csignum :: CompactSize -> CompactSize
abs :: CompactSize -> CompactSize
$cabs :: CompactSize -> CompactSize
negate :: CompactSize -> CompactSize
$cnegate :: CompactSize -> CompactSize
* :: CompactSize -> CompactSize -> CompactSize
$c* :: CompactSize -> CompactSize -> CompactSize
- :: CompactSize -> CompactSize -> CompactSize
$c- :: CompactSize -> CompactSize -> CompactSize
+ :: CompactSize -> CompactSize -> CompactSize
$c+ :: CompactSize -> CompactSize -> CompactSize
Num, Num CompactSize
Ord CompactSize
(Num CompactSize, Ord CompactSize) =>
(CompactSize -> Rational) -> Real CompactSize
CompactSize -> Rational
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
toRational :: CompactSize -> Rational
$ctoRational :: CompactSize -> Rational
$cp2Real :: Ord CompactSize
$cp1Real :: Num CompactSize
Real, Enum CompactSize
Real CompactSize
(Real CompactSize, Enum CompactSize) =>
(CompactSize -> CompactSize -> CompactSize)
-> (CompactSize -> CompactSize -> CompactSize)
-> (CompactSize -> CompactSize -> CompactSize)
-> (CompactSize -> CompactSize -> CompactSize)
-> (CompactSize -> CompactSize -> (CompactSize, CompactSize))
-> (CompactSize -> CompactSize -> (CompactSize, CompactSize))
-> (CompactSize -> Integer)
-> Integral CompactSize
CompactSize -> Integer
CompactSize -> CompactSize -> (CompactSize, CompactSize)
CompactSize -> CompactSize -> CompactSize
forall a.
(Real a, Enum a) =>
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
toInteger :: CompactSize -> Integer
$ctoInteger :: CompactSize -> Integer
divMod :: CompactSize -> CompactSize -> (CompactSize, CompactSize)
$cdivMod :: CompactSize -> CompactSize -> (CompactSize, CompactSize)
quotRem :: CompactSize -> CompactSize -> (CompactSize, CompactSize)
$cquotRem :: CompactSize -> CompactSize -> (CompactSize, CompactSize)
mod :: CompactSize -> CompactSize -> CompactSize
$cmod :: CompactSize -> CompactSize -> CompactSize
div :: CompactSize -> CompactSize -> CompactSize
$cdiv :: CompactSize -> CompactSize -> CompactSize
rem :: CompactSize -> CompactSize -> CompactSize
$crem :: CompactSize -> CompactSize -> CompactSize
quot :: CompactSize -> CompactSize -> CompactSize
$cquot :: CompactSize -> CompactSize -> CompactSize
$cp2Integral :: Enum CompactSize
$cp1Integral :: Real CompactSize
Integral)

instance Serialize CompactSize where
    get :: Get CompactSize
get = Int -> CompactSize
CompactSize (Int -> CompactSize) -> Get Int -> Get CompactSize
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Get Word8
getWord8 Get Word8 -> (Word8 -> Get Int) -> Get Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get Int
forall a a. (Integral a, Num a) => a -> Get a
getCS)
      where
        getCS :: a -> Get a
getCS s :: a
s
            | a
s a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< 253 = a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Get a) -> a -> Get a
forall a b. (a -> b) -> a -> b
$ a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
s
            | a
s a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== 253 = Word16 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> a) -> Get Word16 -> Get a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16le
            | a
s a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== 254 = Word32 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> a) -> Get Word32 -> Get a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32le
            | Bool
otherwise = Word64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> a) -> Get Word64 -> Get a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord64le

    put :: Putter CompactSize
put (CompactSize n :: Int
n)
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = String -> PutM ()
forall a. HasCallStack => String -> a
error (String -> PutM ()) -> String -> PutM ()
forall a b. (a -> b) -> a -> b
$ "Invalid CompactSize: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 253 = Putter Word8
putWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
bound16 = Putter Word8
putWord8 253 PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Word16
putWord16le (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
bound32 = Putter Word8
putWord8 254 PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Word32
putWord32le (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
        | Bool
otherwise = Putter Word8
putWord8 255 PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Word64
putWord64le (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
      where
        bound16 :: Int
bound16 = 1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` 16
        bound32 :: Int
bound32 = 1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` 32