commit 2b44bfc32034fb7a92779dee26aca673305068df
parent d02914e2af82bc6003b212da07f48d5c3f18f60b
Author: Jared Tobin <jared@jtobin.ca>
Date: Wed, 4 Jul 2018 10:16:05 +1200
Add blockchain exercise.
Diffstat:
2 files changed, 103 insertions(+), 7 deletions(-)
diff --git a/20180525_pearson/Hash.hs b/20180525_pearson/Hash.hs
@@ -36,16 +36,12 @@ hash8 (fmap C.ord -> bytes) = show (L.foldl' alg 0 bytes) where
Just val -> val
hash16 :: String -> String
-hash16 input = hash0 <> hash1 where
- hash0 = hash8 input
- hash1 = hash8 modified
-
- mbytes = case fmap C.ord input of
+hash16 input = hash8 input <> hash8 modified where
+ modified = fmap C.chr mbytes
+ mbytes = case fmap C.ord input of
[] -> []
(h:t) -> (h + 1) `mod` 256 : t
- modified = fmap C.chr mbytes
-
main :: IO ()
main = do
print (hash8 "Programming Praxis")
diff --git a/20180529_blockchain/Blockchain.hs b/20180529_blockchain/Blockchain.hs
@@ -0,0 +1,100 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+
+import Data.Char as C
+import Data.List as L (foldl')
+import Data.Monoid ((<>))
+import qualified Data.Map.Strict as MS
+
+hash8 :: String -> String
+hash8 (fmap C.ord -> bytes) = show (L.foldl' alg 0 bytes) where
+ alg acc byte =
+ let key = (acc + byte) `mod` 256
+ in case MS.lookup key ptable of
+ Nothing -> error "hash8: missing key"
+ Just val -> val
+
+ ptable = MS.fromList $
+ zip [0..255]
+ [ 1, 87, 49, 12, 176, 178, 102, 166, 121, 193, 6, 84, 249, 230, 44, 163
+ , 14, 197, 213, 181, 161, 85, 218, 80, 64, 239, 24, 226, 236, 142, 38
+ , 200 , 110, 177, 104, 103, 141, 253, 255, 50, 77, 101, 81, 18, 45, 96
+ , 31, 222 , 25, 107, 190, 70, 86, 237, 240, 34, 72, 242, 20, 214, 244
+ , 227, 149, 235, 97, 234, 57, 22, 60, 250, 82, 175, 208, 5, 127, 199, 111
+ , 62, 135, 248 , 174, 169, 211, 58, 66, 154, 106, 195, 245, 171, 17, 187
+ , 182, 179, 0, 243 , 132, 56, 148, 75, 128, 133, 158, 100, 130, 126, 91
+ , 13, 153, 246, 216, 219 , 119, 68, 223, 78, 83, 88, 201, 99, 122, 11
+ , 92, 32, 136, 114, 52, 10, 138, 30, 48, 183, 156, 35, 61, 26, 143, 74
+ , 251, 94, 129, 162, 63, 152, 170, 7, 115, 167, 241, 206, 3, 150, 55
+ , 59, 151, 220, 90, 53, 23, 131, 125, 173, 15, 238, 79, 95, 89, 16, 105
+ , 137, 225, 224, 217, 160, 37, 123, 118, 73, 2, 157, 46, 116, 9, 145
+ , 134, 228, 207, 212, 202, 215, 69, 229, 27, 188, 67, 124, 168, 252, 42
+ , 4, 29, 108, 21, 247, 19, 205, 39, 203, 233, 40, 186, 147, 198, 192
+ , 155, 33, 164, 191, 98, 204, 165, 180, 117, 76, 140, 36, 210, 172, 41
+ , 54, 159, 8, 185, 232, 113, 196, 231, 47, 146, 120, 51, 65, 28, 144
+ , 254, 221, 93, 189, 194, 139, 112, 43, 71, 109, 184, 209
+ ]
+
+hash16 :: String -> String
+hash16 input = hash8 input <> hash8 modified where
+ modified = fmap C.chr mbytes
+ mbytes = case fmap C.ord input of
+ [] -> []
+ (h:t) -> (h + 1) `mod` 256 : t
+
+data Block = Block {
+ index :: !Int
+ , datum :: String
+ , phash :: String
+ , chash :: String
+ } deriving Show
+
+newtype Blockchain = Blockchain {
+ chain :: [Block]
+ } deriving Show
+
+genesis :: Block
+genesis = Block {..} where
+ index = 0
+ datum = "Something something Times something something bailout"
+ phash = "0"
+ chash = hash16 (show index <> datum <> phash)
+
+adjoin :: String -> Blockchain -> Maybe Blockchain
+adjoin str Blockchain {..} = case chain of
+ [] -> Nothing
+ (Block {..} : _) -> Just $
+ let nindex = succ index
+ ndatum = str
+ nphash = chash
+ nchash = hash16 (show nindex <> ndatum <> nphash)
+ block = Block nindex ndatum nphash nchash
+ in Blockchain (block : chain)
+
+validate :: Blockchain -> Bool
+validate Blockchain {..} = L.foldl' alg True chain where
+ alg !acc block@Block {..}
+ | chash == hash16 (show index <> datum <> phash) = acc && True
+ | otherwise = error ("invalid block: " <> show block)
+
+test :: Blockchain
+test = do
+ let gen = Blockchain [genesis]
+
+ bchain =
+ adjoin "shawn sends jared two bucks" gen
+ >>= adjoin "jared sends shawn three bucks"
+ >>= adjoin "jared sends rachel one buck"
+ >>= adjoin "rachel sends shawn one buck"
+
+ case bchain of
+ Nothing -> error "impossible"
+ Just bc -> bc
+
+main :: IO ()
+main = do
+ mapM_ print (chain test)
+ print (validate test)
+
