Chain.hs

{-# LANGUAGE OverloadedStrings #-}

module Chain where

import Text.Printf                   (printf)
import Data.ByteString       as BS   (ByteString)
import Data.ByteString.Char8 as BS   (pack, unpack)
import Data.Semigroup                ((<>))
import Crypto.Hash.SHA1      as SHA1
import Prelude               as P
import Text.Show.Pretty      as PP

-- A Blockchain:
--  - contains data that may be interpreted as smart contracts
--  - contains the hash of the previous block
--  - contains a hash of itself, using the previous hash
-- The fact that the self hash is created with the previous hash makes the chain tamper-proof

-- The Blockchain type is just a list of Block's.
-- We wouldn't use a List in a production impl, 
-- because they have O(n) for indexing
type Blockchain = [Block]

data Block = Block { 
  bIndex     :: BIndex,     -- index of this block in the chain
  bPrevHash  :: BHash,      -- hash of previous block
  bTimestamp :: BTimestamp, -- when this block was created
  bData      :: BData,      -- this block's data
  bHash      :: BHash       -- this block's hash
} deriving (Eq, Show)

type BIndex     = Int
type BHash      = String
type BTimestamp = String
type BData      = String


-- The root block in our system

genesisBlock :: Block
genesisBlock =
 let idx      = 0
     prevHash = "0"
     ts       = "2017-03-05 10:49:02.084473 PST"
     bdata    = "GENESIS BLOCK DATA"
     bhash    = calculateHash idx prevHash ts bdata
 in Block idx prevHash ts bdata bhash

genesisBlockchain :: Blockchain
genesisBlockchain = [genesisBlock] 

calculateHash :: BIndex -> BHash -> BTimestamp -> BData -> BHash
calculateHash i p t d = concat $ map (printf "%02x") $ hashed
  where 
    hashed = BS.unpack . SHA1.hash . BS.pack $ combined
    combined = concat [show i, p, t, d]

addBlock :: BTimestamp -> BData -> Blockchain -> Blockchain
addBlock ts bd bc = bc ++ [makeNextBlock bc ts bd]

makeNextBlock :: Blockchain -> BTimestamp -> BData -> Block
makeNextBlock bc ts bd =
  let (i, ph, _, _, h) = nextBlockInfo bc ts bd
  in Block i ph ts bd h

nextBlockInfo :: Blockchain -> BTimestamp -> BData -> (BIndex, BHash, BTimestamp, BData, BHash)
nextBlockInfo bc ts bd =
  let prev = getLastCommittedBlock bc
      i    = bIndex prev + 1
      ph   = bHash prev
  in (i, ph, ts, bd, (calculateHash i ph ts bd))

getLastCommittedBlock :: Blockchain -> Block
getLastCommittedBlock bc = bc !! (length bc - 1)

isValidBlock :: Block -> Block -> Either String ()
isValidBlock validBlock checkBlock = 
  if bIndex validBlock + 1 /= bIndex checkBlock
    then fail "invalid bIndex"
  else if bHash  validBlock /= bPrevHash checkBlock
    then fail "invalid bPrevHash"
  else if hashBlock checkBlock /= bHash checkBlock
    then fail "invalid bHash"
  else
    Right ()
  where
    fail msg    = Left (msg <> " " <> show (bIndex validBlock + 1))
    hashBlock b = calculateHash (bIndex b) (bPrevHash b) (bTimestamp b) (bData b)

isValidBlockchain :: Blockchain -> Either String ()
isValidBlockchain bc =
  if length bc == 0
    then Left "empty blockchain"
  else if length bc == 1 && (bc !! 0 /= genesisBlock)
    then Left "invalid genesis block"
  else 
    Right ()

renderBlockchain :: Blockchain -> String
renderBlockchain = PP.ppShow

Main.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Chain

main :: IO ()
main = putStrLn $ renderBlockchain exampleValidBlockchain

exampleValidBlockchain :: Blockchain
exampleValidBlockchain = 
  foldl (\acc (ts, d) -> (addBlock ts d acc)) genesisBlockchain [
    ("2017-06-11 15:49:02.084473 PST", "June 11 data"),
    ("2017-06-12 15:49:02.084473 PST", "June 12 data"),
    ("2017-06-13 15:49:02.084473 PST", "June 13 data"),
    ("2017-06-14 15:49:02.084473 PST", "June 14 data"),
    ("2017-06-15 15:49:02.084473 PST", "June 15 data")
  ]
exampleInvalidBlockChain :: Blockchain
exampleInvalidBlockChain = []