{-# 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)
paramP :: Int
paramP :: Int
paramP = 19
paramM :: Word64
paramM :: Word64
paramM = 784931
newtype BlockFilter = BlockFilter
{
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)
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 = { :: 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
= 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
= 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 = 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)
blockFilterHeader ::
BlockFilterHeader ->
BlockFilter ->
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
filterContents ::
[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
encodeFilter ::
[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
isMember ::
BlockHash ->
[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 ::
Int ->
[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