Issue 22/haskell implementation of sky node

.gitignore

@@ -36,3 +36,4 @@ TAGS
 
 # Cache and other dev setup files
 .direnv/
+*/dist-newstyle/*

merkle-patricia-trie/.envrc

@@ -0,0 +1,2 @@
+watch_file *.cabal
+use flake

merkle-patricia-trie/CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for merkle-patricia-trie
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

merkle-patricia-trie/flake.nix

@@ -0,0 +1,30 @@
+{
+  inputs = {
+    flake-utils.url = "github:numtide/flake-utils";
+    nixpkgs.url = "github:nixos/nixpkgs/nixos-unstable";
+  };
+  outputs = { self, nixpkgs, flake-utils, ... }: flake-utils.lib.eachDefaultSystem (system:
+    let
+      pkgs = import nixpkgs { inherit system; };
+      overlay = final: prev: {
+        merkle-patricia-trie = final.callCabal2nix "merkle-patricia-trie" ./. { };
+      };
+      haskPkgs = pkgs.haskellPackages.extend overlay;
+    in
+    {
+      devShells.default = haskPkgs.shellFor {
+        packages = p: [
+          p.merkle-patricia-trie
+        ];
+        nativeBuildInputs = with haskPkgs; [
+          cabal-install
+          haskell-language-server
+          hlint
+        ];
+        shellHook = ''
+          echo "Welcome"
+        '';
+      };
+    }
+  );
+}

merkle-patricia-trie/lib/Data/Internal/RecursionSchemes.hs

@@ -0,0 +1,84 @@
+module Data.Internal.RecursionSchemes where
+
+import Control.Arrow ((&&&))
+
+-- | Y-combinator or fixed point combinator for types
+newtype Term f = In {out :: f (Term f)}
+
+-- | Type of functions from a container `f a` to the collapsed value `a`.
+-- | Basically it's a type of functions for cata-morphisms a.k.a. folds.
+type Algebra f a = f a -> a
+
+-- | Type of functions from a value `a` to the unfolded container `f a`
+-- | Basically it's a type of functions for ana-morphisms a.k.a. unfolds.
+type CoAlgebra f a = a -> f a
+
+-- | Type of functions for folds with extra context of `Term f` we're currently working on,
+-- | and value `a` to the collapsed value `a` a.k.a. para-morphisms.
+type RAlgebra f a = f (Term f, a) -> a
+
+-- | Type of functions for unfolds that can be either terminated on `Term f` or continued on value `a`,
+-- | a.k.a. apo-morphism
+type RCoAlgebra f a = a -> f (Either (Term f) a)
+
+-- | Attributeted version of `Term f`. Used to hold the "history" of the fold that is currently going on.
+-- | Helper data type for the histo-morphism
+data Attr f a = Attr
+  { attribute :: a,
+    hole :: f (Attr f a)
+  }
+
+-- | Type of functions for folds that remembers their "history" as they go through the recursion,
+-- | a.k.a. histo-morphism
+type CVAlgebra f a = f (Attr f a) -> a
+
+-- | The dual of Attr for futu-morphisms, a.k.a. unfolds with control flow
+data CoAttr f a
+  = Automatic a
+  | Manual (f (CoAttr f a))
+
+-- | Type of functions for unfold that has control over the flow of the unfold, a.k.a. futu-morphism
+type CVCoAlgebra f a = a -> f (CoAttr f a)
+
+-- | Histomorphism
+histo :: forall f a. (Functor f) => CVAlgebra f a -> Term f -> a
+histo h = attribute . go
+  where
+    go :: Term f -> Attr f a
+    go = uncurry Attr . (h &&& id) . fmap go . out
+
+-- | Catamorphism
+cata :: (Functor f) => Algebra f a -> Term f -> a
+cata f = histo (f . fmap attribute)
+
+-- | Helper function to transform 'Term f -> f a -> a' into 'RAlgebra f a'
+transform :: forall f a. (Functor f) => (Term f -> f a -> a) -> RAlgebra f a
+transform h fta = h term fa
+  where
+    term = In $ fmap fst fta
+    fa = fmap snd fta
+
+-- | Paramorphism
+para :: forall f a. (Functor f) => RAlgebra f a -> Term f -> a
+para f = histo (f . fmap go)
+  where
+    go :: Attr f a -> (Term f, a)
+    go (Attr a h) = (In (fmap (fst . go) h), a)
+
+-- | Futumorphism
+futu :: forall f a. (Functor f) => CVCoAlgebra f a -> a -> Term f
+futu f = In . fmap go . f
+  where
+    go :: CoAttr f a -> Term f
+    go (Automatic a) = futu f a -- continue through this level
+    go (Manual g) = In (fmap go g) -- omit folding this level, delegating to the worker
+
+-- | Anamorphism
+ana :: (Functor f) => CoAlgebra f a -> a -> Term f
+ana f = futu (fmap Automatic . f)
+
+-- | Apomorphism
+apo :: (Functor f) => RCoAlgebra f a -> a -> Term f
+apo f = futu (fmap (either termToCoAttr Automatic) . f)
+  where
+    termToCoAttr = Manual . fmap termToCoAttr . out

merkle-patricia-trie/lib/Data/Internal/Trie.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Data.Internal.Trie where
+
+import Data.Bits
+import Data.Internal.RecursionSchemes
+import Data.Kind (Type)
+import Prelude hiding (lookup)
+
+data TrieF k h v a
+  = Empty
+  | Leaf {key :: k, value :: v}
+  | -- | Branch node stores branching bit `bBit` and longest common prefix `pref`
+    Branch {height :: h, prefix :: k, left :: a, right :: a}
+  deriving (Show, Eq, Functor)
+
+-- | Constraint for Trie key and height. Provides default methods for calculating neccessary info.
+class (FiniteBits k, Bits k, Num k, Integral k, Integral (TrieHeight k), Bits (TrieHeight k), Num (TrieHeight k)) => TrieKey k where
+  -- | This will allow us to enforce the height of the trie depending on it's key
+  type TrieHeight k :: Type
+
+  -- | Discards bits not in the mask
+  mask :: k -> k -> k
+  mask k m = k .&. (m - 1)
+
+  -- | Finds the first bit on which prefixes disagree.
+  commonBranchingBit :: k -> k -> k
+  commonBranchingBit p1 p2 = lowesBit (p1 `xor` p2)
+    where
+      lowesBit :: k -> k
+      lowesBit x = x .&. (-x)
+
+  -- | Masks key using supplied branching bit and compares to prefix
+  matchPrefix :: k -> k -> k -> Bool
+  matchPrefix key prefix bBit = mask key bBit == prefix
+
+  -- | Converts height 'TrieHeight k' into the branching bit 'k'
+  heightToBBit :: TrieHeight k -> k
+  heightToBBit = (2 ^)
+
+  -- | Converts branching bit 'k' into height 'TrieHeight k'
+  bBitToHeight :: k -> TrieHeight k
+  bBitToHeight = floor . logBase (2.0 :: Double) . fromIntegral
+
+  -- | Tests whether the desired bit is zero
+  zeroBit :: k -> k -> Bool
+  zeroBit k m = not (k `testBit` fromIntegral (bBitToHeight m))
+
+-- | Type alias for TrieF
+type TrieF' k v = TrieF k (TrieHeight k) v
+
+-- | Type alias for Trie
+type Trie k v = Term (TrieF' k v)
+
+-- | Smart constructor for Branch node
+branch :: (TrieKey k, h ~ TrieHeight k) => k -> k -> a -> a -> TrieF k h v a
+branch bBit = Branch (bBitToHeight bBit)
+
+-- | Decides how to join two tries based on prefixes(i.e. either as left or right child)
+join :: (TrieKey k) => k -> Trie k v -> k -> Trie k v -> Trie k v
+join p1 t1 p2 t2 =
+  if zeroBit p1 bBit
+    then In $ branch bBit (mask p1 bBit) t1 t2
+    else In $ branch bBit (mask p1 bBit) t2 t1
+  where
+    bBit = commonBranchingBit p1 p2

merkle-patricia-trie/lib/Data/MerkleTrie.hs

@@ -0,0 +1,105 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+-- need this because we need to specify type family in the deriving context
+{-# LANGUAGE StandaloneDeriving #-}
+-- need this to allow type family in the deriving context
+{-# LANGUAGE UndecidableInstances #-}
+
+module Data.MerkleTrie
+  ( proof,
+    validate,
+    computeRootHash,
+    merkelize,
+    MerkleProof (..),
+    MerkleTrie (..),
+  )
+where
+
+import Crypto.Hash (Blake2b_256, Digest, hash)
+import Data.ByteString.Char8 (pack)
+import Data.Trie
+
+data MerkleTrie k v = MerkleTrie
+  { rootHash :: Digest Blake2b_256,
+    trie :: Trie k v
+  }
+
+data MerkleProof k v = MerkleProof
+  { targetKey :: k,
+    targetValue :: v,
+    keyPath :: [(TrieHeight k, k)],
+    siblingHashes :: [Digest Blake2b_256]
+  }
+
+deriving instance (Eq k, Eq v, Eq (TrieHeight k)) => Eq (MerkleProof k v)
+
+deriving instance (Show k, Show v, Show (TrieHeight k)) => Show (MerkleProof k v)
+
+-- TODO: replace the 'show' with binary serialization
+computeHash :: (Show a) => a -> Digest Blake2b_256
+computeHash = hash . pack . show
+
+computeRootHash :: forall k v. (Show k, Show v, Show (TrieHeight k)) => Trie k v -> Digest Blake2b_256
+computeRootHash = cata go
+  where
+    go :: Algebra (TrieF' k v) (Digest Blake2b_256)
+    go Empty = computeHash "EmptyTrie"
+    go Leaf {..} = computeHash (key, value)
+    go Branch {..} = computeHash (height, prefix, left, right)
+
+merkelize :: (Show k, Show v, Show (TrieHeight k)) => Trie k v -> MerkleTrie k v
+merkelize trie = let rootHash = computeRootHash trie in MerkleTrie rootHash trie
+
+-- | Generate a Merkle proof for a given key in the trie
+-- Yeah, this variant always constructs whole proof even if the key is not there
+proof :: forall k v. (Show k, Show (TrieHeight k), Show v, TrieKey k) => k -> Trie k v -> Maybe (MerkleProof k v)
+proof k t = let r = cata go t in if fst r then snd r else Nothing
+  where
+    -- Bool to signify if the key was in the structure
+    go :: Algebra (TrieF' k v) (Bool, Maybe (MerkleProof k v))
+    go Empty = (False, Nothing)
+    -- for every leaf we just compute merkle proof
+    go Leaf {..} =
+      let targetKey = key
+          targetValue = value
+          keyPath = []
+          siblingHashes = [computeHash (key, value) | key /= k]
+       in (key == k, Just $ MerkleProof {..})
+    go (Branch h p (bl, Just pl) (br, Just pr))
+      -- if one of the proofs containt the key, it means it comes from a path that we're interested in
+      -- it also means, that this node is in the path
+      | pl.targetKey == k =
+          let targetKey = pl.targetKey
+              targetValue = pl.targetValue
+              keyPath = (h, p) : pl.keyPath
+              siblingHashes = pr.siblingHashes <> pl.siblingHashes
+           in (bl, Just $ MerkleProof {..})
+      | pr.targetKey == k =
+          let targetKey = pr.targetKey
+              targetValue = pr.targetValue
+              keyPath = (h, p) : pr.keyPath
+              siblingHashes = pr.siblingHashes <> pl.siblingHashes
+           in (br, Just $ MerkleProof {..})
+      -- otherwise it doesn't matter what key we pick, we're interested only in hash
+      | otherwise =
+          let targetKey = pl.targetKey
+              targetValue = pl.targetValue
+              keyPath = []
+              -- in this case there is always one element in the path list
+              siblingHashes = [computeHash (h, p, head pl.siblingHashes, head pr.siblingHashes)]
+           in (False, Just $ MerkleProof {..})
+    go Branch {} = (False, Nothing)
+
+-- | Validate a Merkle proof against the root hash of the trie
+validate :: (Show k, Show (TrieHeight k), Show v, TrieKey k) => MerkleProof k v -> Digest Blake2b_256 -> Bool
+validate MerkleProof {..} rootHash =
+  rootHash
+    == foldr
+      ( \((h, p), hs) acc ->
+          if zeroBit targetKey (heightToBBit h)
+            then computeHash (h, p, acc, hs)
+            else computeHash (h, p, hs, acc)
+      )
+      (computeHash (targetKey, targetValue))
+      (reverse $ zip keyPath siblingHashes)