Haskell でブロックチェーンのようなデータ構造が作れないか考えた時のメモ．ほぼお遊び．

Hashable 型クラス

まず次のようなデータ型を考える．

data MyHash a b

これはハッシュ方法を表すデータ型である．ハッシュ方法は，Hashable 型クラスの提供するメソッド hash を実装することによって表すことにする．

{-# LANGUAGE MultiParamTypeClasses #-}

class Hashable a b h where
  hash :: h -> a -> b

MultiParamTypeClasses 拡張は，このように引数が複数ある (a, b, h) 型クラスを定義することを許す．

h は，ただハッシュ方法を表す型を区別するためだけのものである．本当は単に hash :: a -> b としたいところだが，これだと h の型を指定することができない．

さて今 MyHash String ByteString について考える．これは String から ByteString へのハッシュ方法を表している．hash の実装は，簡単のため単に reverse して pack するだけとする（果たしてハッシュと言えるのか）．

{-# LANGUAGE FlexibleInstances #-}

import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BL8
 
instance Hashable String ByteString (MyHash String ByteString) where
  hash _ s = BL8.pack (reverse s)

FlexibleInstances 拡張は，このように型コンストラクタ (MyHash) に具体型 (String, ByteString) を入れた型に対してのインスタンス宣言などを許す．

実際に hash を試してみる．

> :t hash
hash :: Hashable a b h => h -> a -> b
> let p = undefined :: MyHash String ByteString
> hash p "data" :: ByteString
"atad"

hash の 1 つめの引数は，単に型を指定するだけのものである．そのためここでは p = undefined に MyHash String ByteString という型をつけて渡している．undefined を使わなくて良い方法を後に示す．

p の型は MyHash String ByteString であるから，hash p "data" の型は ByteString に決定しそうに見える．しかし実際には決まらない．

> let p = undefined :: MyHash String ByteString
> hash p "data"

<interactive>:1:1: error:
    • Non type-variable argument
        in the constraint: Hashable [Char] b (MyHash String ByteString)
      (Use FlexibleContexts to permit this)
    • When checking the inferred type
        it :: forall b. Hashable [Char] b (MyHash String ByteString) => b

もしかしたら instance Hashable String Int (MyHash String ByteString) のようなインスタンスがあるかもしれないからである．実際このようなインスタンス宣言は有効である．

そこで，Hashable 型クラスに次のような関数従属を追加する．

{-# LANGUAGE FunctionalDependencies #-}

class Hashable a b h | h -> a, h -> b where
  hash :: h -> a -> b

FunctionalDependencies 拡張は，関数従属を記述することを許す．関数従属は，| に続いて a -> b のように記述する．これは，a から b がただ一つ定まるということを主張する．

今回は，型 h (例えば MyHash String ByteString) から a (String), b (ByteString) が定まるという従属関係をクラスに追加している．

> let p = undefined :: MyHash String ByteString
> hash p "data"
"atad"

型 h から a, b が一意に定まるということを主張してしまったので，もはや MyHash String ByteString について a や b が異なるインスタンスを定義することはできない．

例えば，instance Hashable String Int (MyHash String ByteString) を追加すると，conflict していると文句を言われる．

Main.hs:19:10: error:
    Functional dependencies conflict between instance declarations:
      instance Hashable String ByteString (MyHash String ByteString)
        -- Defined at Main.hs:19:10
      instance Hashable String Int (MyHash String ByteString)
        -- Defined at Main.hs:22:10

もちろん instance Hashable String ByteString (MyHash String ByteString) を削除して instance Hashable String Int (MyHash String ByteString) に変えることは可能である．しかし Int を返す hash を定義したいならば instance Hashable String Int (MyHash String Int) とするべきである．

Data.Proxy を利用する

hash の 1 つめの引数に型をつけた undefined を渡すのはあまり気持ちよくない．そこで base パッケージ (>= 4.7.0.0) の Data.Proxy にある Proxy を用いる．

Proxy は単に次のような型である．

data Proxy t = Proxy

ある型 t を Proxy で包むと，Proxy という値コンストラクタで Proxy t 型の値 Proxy が生成できるようになる．それだけである．

> :m + Data.Proxy
> Proxy :: Proxy Int
Proxy
> Proxy :: Proxy (MyHash String ByteString)
Proxy

これを用いて Hashable クラスを次のように変更する．

import Data.Proxy (Proxy(..))

class Hashable a b h | h -> a, h -> b where
  hash :: Proxy h -> a -> b

すると hash は次のように使える．

> let p = Proxy :: Proxy (MyHash String ByteString)
> hash p "data"
"atad"

いちいち Proxy をつけるのは面倒だが，undefined を使う必要がなくなった．

ここまでのプログラム

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}

import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BL8

import Data.Proxy (Proxy(..))

data MyHash a b

class Hashable a b h | h -> a, h -> b where
  hash :: Proxy h -> a -> b

instance Hashable String ByteString (MyHash String ByteString) where
  hash _ s = BL8.pack (reverse s)

Blockchain データ型

本題．ブロックチェーンとは，分散型台帳（データベース）の仕組みの一つである．この語は広義的であるが，ここでは単純に次のようなリストを表すということにする．

f:id:CyLomw:20170421202538p:plain

すなわち，リストの各要素（ブロック）が 1 つ前の要素（ブロック）のハッシュ値を持つようなリストである．要素を追加するときには，１つ前の要素のハッシュ値を計算し持たせる．リスト中の要素を変更する場合は，それ以降のすべての要素についてハッシュを計算し直さなければならない．

ビットコインなどのシステムでは，ブロックを作成するために時間のかかる計算を行わなければならないようにして，リスト中の要素の改竄を防いでいる．

ここでのブロックチェーンは単にリストであるので，次のように表すことができる．ただし，データはリストの先頭に追加していくものとする．

newtype Blockchain h b a = Blockchain [(a, b)]
  deriving (Show)

a は保存するデータの型，b はハッシュ値の型，h はハッシュ方法を表す型とする．

リストの要素の型は (a, b) である．これをハッシュして b にしなければならないため，ハッシュ関数の型は (a, b) -> b である．

今回は a を String, b を ByteString とする．h については MyHash を使い回すとすると，hash の型は Proxy ... -> (String, ByteString) -> ByteString でなければならないため，インスタンス定義を次のように変更する¹．

instance Hashable (String, ByteString) ByteString
    (MyHash (String, ByteString) ByteString) where
  hash _ (s, bs) = (BL8.pack $ reverse s) `BL.append` bs

今回も単純に reverse して pack して append するだけとした．

Blockchain 値コンストラクタは非公開にするであろうから，最初のブロックを作成する関数 genesis を作成する．

{-# LANGUAGE FlexibleContexts #-}

genesis :: Hashable (a, b) b h => a -> b -> Blockchain h b a
genesis x y = Blockchain [(x, y)]

FlexibleContexts 拡張は型クラス制約の制限を緩くする．この拡張がないと Hashable (a, b) b h => という制約は記述できない．

次に，ブロックを追加する関数 bcons を作成する．

bcons :: Hashable (a, b) b h
      => a -> Blockchain h b a -> Blockchain h b a
bcons x (Blockchain xs) = Blockchain $ (x, hashed):xs
  where hashed = hash (Proxy :: Proxy h) (head xs)

これはコンパイルが通らない．これについては，Scoped type variablesが必要になるとき - maoeのブログに詳しい．よくわからない場合は，関数の型宣言内で使用した型変数 (a, b, h) のスコープ（寿命）はその型宣言内だけであり，関数本体では使えない，と考えても良いかもしれない．

ScopedTypeVariables 拡張を用いると型変数のスコープを関数本体まで持ち込むことができる．ただし，明示的に forall を記述する必要がある．

{-# LANGUAGE ScopedTypeVariables #-}

bcons :: forall a b h. Hashable (a, b) b h
      => a -> Blockchain h b a -> Blockchain h b a
bcons x (Blockchain xs) = Blockchain $ (x, hashed):xs
  where hashed = hash (Proxy :: Proxy h) (head xs)

ところで，xs が空リストの場合 head が失敗するためこのままだと危険である．ただ，Blockchain 値コンストラクタを非公開にすれば，最小のブロックチェーンの作成は genesis のみによって行われるため head が失敗することは避けられる．もう一つの方法は NonEmpty を使うことである．

ここまでのプログラム

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BL8

import Data.Proxy (Proxy(..))

data MyHash a b

class Hashable a b h | h -> a, h -> b where
  hash :: Proxy h -> a -> b

instance Hashable (String, ByteString) ByteString
    (MyHash (String, ByteString) ByteString) where
  hash _ (s, bs) = (BL8.pack $ reverse s) `BL.append` bs

newtype Blockchain h b a = Blockchain [(a, b)]
  deriving (Show)

genesis :: Hashable (a, b) b h => a -> b -> Blockchain h b a
genesis x y = Blockchain [(x, y)]

bcons :: forall a b h. Hashable (a, b) b h
      => a -> Blockchain h b a -> Blockchain h b a
bcons x (Blockchain xs) = Blockchain $ (x, hashed):xs
  where hashed = hash (Proxy :: Proxy h) (head xs)

NonEmpty リストを利用する

NonEmpty リストは名前の通り空でないリストである．そのため head は常に安全となる．NonEmpty リストは base パッケージ 4.9.0.0 で追加された．

NonEmpty リストは次のように使うことができる．

> :m + Data.List.Nonempty
> 1 :| []
1 :| []
> 2 <| (1 :| [])
2 :| [1]
> 3 <| (2 :| [1])
3 :| [2, 1]
> Data.List.NonEmpty.head $ 3 <| (2 :| [1])
3
> toList $ 3 :| [2, 1]
[3,2,1]

即ち NonEmpty リストは 頭 :| [尻尾] という構造をしている．最小の（長さ１の）リストは 頭 :| [] である．リストの先頭への追加は <| 演算子（あるいは cons）で行う．

これを用いるとプログラム（の一部）は次のように書き換えられる．

import Data.List.NonEmpty (NonEmpty(..), (<|))
import qualified Data.List.NonEmpty as NE

newtype Blockchain h b a = Blockchain (NonEmpty (a, b))
  deriving (Show)

genesis :: Hashable (a, b) b h => a -> b -> Blockchain h b a
genesis x y = Blockchain $ (x, y) :| []

bcons :: forall a b h. Hashable (a, b) b h
      => a -> Blockchain h b a -> Blockchain h b a
bcons x (Blockchain xs) = Blockchain $ (x, hashed) <| xs
  where hashed = hash (Proxy :: Proxy h) (NE.head xs)

テスト

実際にブロックチェーンを構築してみる．

最初に次のような別名を定義しておくことをお勧めする．

type BC hc b a = Blockchain (hc (a, b) b) b a

genesis と bcons を用いてブロックチェーンが構築できることを確かめる．

test1 :: BC MyHash ByteString String
test1 = genesis "genesis-block" BL.empty

test2 :: BC MyHash ByteString String
test2 = bcons "2nd-block" test1

test3 :: BC MyHash ByteString String
test3 = bcons "3rd-block" test2

> test3
Blockchain (("3rd-block","kcolb-dn2kcolb-siseneg")
  :| [("2nd-block","kcolb-siseneg"),("genesis-block","")])

2 番目のブロックの文字列 (“2nd-block”) を変更したとすると，3 番目のブロックのハッシュ値も変更しなければならないことがわかる．

ブロックチェーンをチェックする関数 check を作成してみよう．

import Data.Foldable (foldrM)
import Data.Maybe (isJust)

check :: forall a b h. (Hashable (a, b) b h, Eq b)
      => Blockchain h b a -> b -> Bool
check (Blockchain xs) initHash = isJust $ foldrM checkf initHash xs
    where checkf (x, y) prevHash
            | prevHash == y = Just $ hash (Proxy :: Proxy h) (x, y)
            | otherwise     = Nothing

check は foldrM を用いてリストの右からハッシュをチェックする．即ち，1 つ前のデータのハッシュと現在のデータの保持しているハッシュ値が等しいかどうか (prevHash == y) を順にチェックしていく．foldrM は foldr の変種で，モナドが扱える．ここでは Maybe モナドを利用し，不正な値があった場合は Nothing を出すようにしている．

> check test3 BL.empty
True
> check test3 (BL8.pack "illegal initial hash")
False

また，ブロックチェーンを変更する関数は次のように作成できる．

import qualified Data.Foldable as FD
import qualified Data.Traversable as TS

instance Foldable (Blockchain h b) where
  foldr f z (Blockchain xs) = foldr (f. fst) z xs

mapAccumR :: forall a b c d h k. (Hashable (a, b) b h, Hashable (d, b) b k)
          => (c -> a -> (c, d)) -> c -> Blockchain h b a
          -> (c, Blockchain k b d)
mapAccumR f z (Blockchain xs) = (fst res1, Blockchain res2)
  where (res1, res2) = TS.mapAccumR g (z, Nothing) xs
        g (x, prevHashMaybe) (y, oldHash) =
          let prevHash = maybe oldHash id prevHashMaybe
              (acc, val) = f x y
              hashed = hash (Proxy :: Proxy k) (val, prevHash)
          in  ((acc, Just hashed), (val, prevHash))

mapAccumR' :: forall a b c d e h k.
              (Hashable (a, b) b h, Hashable (d, e) e k)
           => (c -> a -> (c, d)) -> c -> Blockchain h b a -> e
           -> (c, Blockchain k e d)
mapAccumR' f z (Blockchain xs) initHash = (fst res1, Blockchain res2)
  where (res1, res2) = TS.mapAccumR g (z, initHash) xs
        g (x, prevHash) (y, _) =
          let (acc, val) = f x y
              hashed = hash (Proxy :: Proxy k) (val, prevHash)
          in  ((acc, hashed), (val, prevHash))

renovate :: Hashable (a, b) b h
         => Blockchain h b a -> Int -> a -> Blockchain h b a
renovate bc n y = snd $ mapAccumR f (FD.length bc - 1) bc
  where f m x = (m - 1, if m == n then y else x)

補助関数 mapAccumR は，ブロックチェーンリストを右から走査し，関数を適用しながらブロックチェーンを再構築する．f :: c -> a -> (c, d) において c はアキュムレータ，a はリストの（ハッシュを除く）要素，d はリストの（ハッシュを除く）新しい要素である．また mapAccumR' は最初のハッシュ値を新しく指定できる別種である．

例えば，次のようにすると test3 の各文字列の末尾に 100 から始まるインデックスをつけることができる．

> snd $ mapAccumR (\acc s -> (succ acc, s ++ show acc)) 100 test3
Blockchain (("3rd-block102","101kcolb-dn2001kcolb-siseneg")
  :| [("2nd-block101","001kcolb-siseneg"),("genesis-block100","")])

renovate は，ブロックチェーンリストの先頭 (0) から数えて n 番目の要素を変更する．即ち，0 番目から n - 1 番目までの要素の持つハッシュ値は全て変更される．

> renovate test3 1 "MAKE AMERICA GREAT AGAIN"
Blockchain (("3rd-block","NIAGA TAERG ACIREMA EKAMkcolb-siseneg")
  :| [("MAKE AMERICA GREAT AGAIN","kcolb-siseneg"),("genesis-block","")])

プログラム全体

他に幾つかの関数などを追加し，モジュールとメインプログラムに分割した．

Blockchain.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Blockchain(
  Hashable(..),
  Blockchain,
  BC,
  genesis,
  bcons,
  mapAccumR,
  mapAccumR',
  bcmap,
  renovate,
  modify,
  check,
  toList,
  toList',
  toNonEmpty,
  toNonEmpty',
  fromNonEmpty
  ) where

import Data.Foldable (foldrM)
import qualified Data.Foldable as FD
import Data.List.NonEmpty (NonEmpty(..), (<|))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (isJust)
import Data.Proxy (Proxy(..))
import qualified Data.Traversable as TS

class Hashable a b h | h -> a, h -> b where
  hash :: Proxy h -> a -> b

newtype Blockchain h b a = Blockchain (NonEmpty (a, b))
  deriving (Eq, Ord, Read, Show)

instance Foldable (Blockchain h b) where
  foldr f z (Blockchain xs) = foldr (f. fst) z xs

type BC hc b a = Blockchain (hc (a, b) b) b a

genesis :: Hashable (a, b) b h => a -> b -> Blockchain h b a
genesis x y = Blockchain $ (x, y) :| []

bcons :: forall a b h. Hashable (a, b) b h
      => a -> Blockchain h b a -> Blockchain h b a
bcons x (Blockchain xs) = Blockchain $ (x, hashed) <| xs
  where hashed = hash (Proxy :: Proxy h) (NE.head xs)

mapAccumR :: forall a b c d h k. (Hashable (a, b) b h, Hashable (d, b) b k)
          => (c -> a -> (c, d)) -> c -> Blockchain h b a
          -> (c, Blockchain k b d)
mapAccumR f z (Blockchain xs) = (fst res1, Blockchain res2)
  where (res1, res2) = TS.mapAccumR g (z, Nothing) xs
        g (x, prevHashMaybe) (y, oldHash) =
          let prevHash = maybe oldHash id prevHashMaybe
              (acc, val) = f x y
              hashed = hash (Proxy :: Proxy k) (val, prevHash)
          in  ((acc, Just hashed), (val, prevHash))

mapAccumR' :: forall a b c d e h k.
              (Hashable (a, b) b h, Hashable (d, e) e k)
           => (c -> a -> (c, d)) -> c -> Blockchain h b a -> e
           -> (c, Blockchain k e d)
mapAccumR' f z (Blockchain xs) initHash = (fst res1, Blockchain res2)
  where (res1, res2) = TS.mapAccumR g (z, initHash) xs
        g (x, prevHash) (y, _) =
          let (acc, val) = f x y
              hashed = hash (Proxy :: Proxy k) (val, prevHash)
          in  ((acc, hashed), (val, prevHash))

bcmap :: (Hashable (a, b) b h, Hashable (d, b) b k)
      => (a -> d) -> Blockchain h b a -> Blockchain k b d
bcmap f = snd . mapAccumR (\_ x -> ((), f x)) ()

modify :: Hashable (a, b) b h
       => Blockchain h b a -> Int -> (a -> a) -> Blockchain h b a
modify bc n f = snd $ mapAccumR g (FD.length bc - 1) bc
  where g m x = (m - 1, if m == n then f x else x)

renovate :: Hashable (a, b) b h
         => Blockchain h b a -> Int -> a -> Blockchain h b a
renovate bc n = modify bc n . const

check :: forall a b h. (Hashable (a, b) b h, Eq b)
      => Blockchain h b a -> b -> Bool
check (Blockchain xs) initHash = isJust $ foldrM checkf initHash xs
    where checkf (x, y) prevHash
            | prevHash == y = Just $ hash (Proxy :: Proxy h) (x, y)
            | otherwise     = Nothing

toList :: Blockchain h b a -> [a]
toList = FD.toList

toList' :: Blockchain h b a -> [(a, b)]
toList' (Blockchain xs) = NE.toList xs

toNonEmpty :: Blockchain h b a -> NonEmpty a
toNonEmpty (Blockchain xs) = NE.map fst xs

toNonEmpty' :: Blockchain h b a -> NonEmpty (a, b)
toNonEmpty' (Blockchain xs) = xs

fromNonEmpty :: forall a b h. Hashable (a, b) b h
             => NonEmpty a -> b -> Blockchain h b a
fromNonEmpty xs initHash = Blockchain $ snd $ TS.mapAccumR f initHash xs
  where f prevHash x =
          (hash (Proxy :: Proxy h) (x, prevHash), (x, prevHash))

Main.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Main where

import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BL8

import qualified Blockchain as BC

main :: IO ()
main = return ()

data MyHash a b

instance BC.Hashable (String, ByteString) ByteString
    (MyHash (String, ByteString) ByteString) where
  hash _ (s, bs) = (BL8.pack $ reverse s) `BL.append` bs

instance BC.Hashable (Int, ByteString) ByteString
    (MyHash (Int, ByteString) ByteString) where
  hash _ (x, bs) = (BL8.pack $ reverse (show x)) `BL.append` bs

test1 :: BC.BC MyHash ByteString String
test1 = BC.genesis "genesis-block" BL.empty

test2 :: BC.BC MyHash ByteString String
test2 = BC.bcons "2nd-block" test1

test3 :: BC.BC MyHash ByteString String
test3 = BC.bcons "3rd-block" test2

test4 :: BC.BC MyHash ByteString Int
test4 = BC.bcmap length test3

演習問題

SHA パッケージ等を用いて SHA-256 等でハッシュするようにせよ．
data BCData = BCData { content :: ByteString, nonce:: Int } 等のようなデータ型を用いるブロックチェーンを作成し，新しいブロックを作成する際に適当な条件を満たす nonce を求めるようにせよ．例えば，ハッシュした結果の先頭 n ビットが 0 であるような nonce を求めるようにする．この仕組みは PoW (Proof of Work) と呼ばれる．

途中まで String -> ByteString でいいと思っていたがこれだとリストが容易に改竄されてしまうことに気づいた↩

猫野詩梨帳

かわいいはかしこい

Haskell でブロックチェーンのような構造を考える

Hashable 型クラス

Data.Proxy を利用する

ここまでのプログラム

Blockchain データ型

ここまでのプログラム

NonEmpty リストを利用する

テスト

プログラム全体

演習問題