├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── legion.cabal ├── src ├── Lib.hs └── Server.hs ├── stack.yaml └── test └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | .HTF/ 21 | *.log 22 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This is the simple Travis configuration, which is intended for use 2 | # on applications which do not require cross-platform and 3 | # multiple-GHC-version support. For more information and other 4 | # options, see: 5 | # 6 | # https://docs.haskellstack.org/en/stable/travis_ci/ 7 | # 8 | # Copy these contents into the root directory of your Github project in a file 9 | # named .travis.yml 10 | 11 | # Use new container infrastructure to enable caching 12 | sudo: false 13 | 14 | # Do not choose a language; we provide our own build tools. 15 | language: generic 16 | 17 | # Caching so the next build will be fast too. 18 | cache: 19 | directories: 20 | - $HOME/.stack 21 | 22 | # Ensure necessary system libraries are present 23 | addons: 24 | apt: 25 | packages: 26 | - libgmp-dev 27 | 28 | before_install: 29 | # Download and unpack the stack executable 30 | - mkdir -p ~/.local/bin 31 | - export PATH=$HOME/.local/bin:$PATH 32 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 33 | 34 | install: 35 | # Build dependencies 36 | - stack --no-terminal --install-ghc test --only-dependencies 37 | 38 | script: 39 | # Build the package, its tests, and its docs and run the tests 40 | - stack --no-terminal test --skip-ghc-check 41 | 42 | notifications: 43 | email: 44 | recipients: 45 | - avipress@gmail.com 46 | on_success: change # default: change 47 | on_failure: always # default: always 48 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Avi Press 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Legion - a simple blockchain implementation 2 | 3 | [![Build Status](https://travis-ci.org/aviaviavi/legion.svg?branch=master)](https://travis-ci.org/aviaviavi/legion) 4 | 5 | An as-simple-as-possible blockchain server inspired by [naivechain](https://github.com/lhartikk/naivechain), but written in Haskell. Spinning up several 6 | Legion nodes creates a peer to peer network that syncronizes the block chain across the network. 7 | 8 | Prereqs: To compile from source, you'll need [stack](https://docs.haskellstack.org/en/stable/README/). 9 | 10 | Alternatively, you can get a precompiled [pre-release binary](https://github.com/aviaviavi/legion/releases). Note: if you download the binary 11 | from github, you'll need to mark it executable by running: 12 | ``` 13 | $ chmod +x legion-exe 14 | ``` 15 | 16 | ### Usage: 17 | 18 | ``` 19 | $ stack exec legion-exe [http port] [p2p port] [optional: `seedhost:seedP2PPort`] 20 | 21 | ``` 22 | 23 | ### Examples: 24 | 25 | ``` 26 | $ stack exec legion-exe 8001 9001 27 | ``` 28 | By default, legion will log what it's doing to standard out. In another terminal window: 29 | ``` 30 | $ stack exec legion-exe 8002 9002 localhost:9001 31 | ``` 32 | 33 | Alternatively, you grab the binaries from the github releases, and run that directly rather than via `stack exec` 34 | 35 | The 3rd argument tells the node where a seed node can be found to bootstrap the connection to the 36 | peer to peer network. The current state of the (valid) blockchain will be fetched from all servers, and it will automatically 37 | keep itself updated and post its own updated to others. 38 | 39 | Now that 2 nodes are now synced, and you can view the current chain from either node at http://localhost:$httpPort/chain, eg http://localhost:8001/chain 40 | 41 | Add a new block to the blockchain via a POST request to /block: 42 | 43 | ``` 44 | $ curl -H "Content-Type: application/json" -X POST -d '{"blockBody": "this is the data for the next block"}' http://localhost:8001/block 45 | ``` 46 | 47 | 48 | 49 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | module Main where 7 | 8 | import System.Environment (getArgs) 9 | import System.IO (stdout) 10 | import System.Log.Formatter 11 | import System.Log.Handler (setFormatter) 12 | import System.Log.Handler.Simple 13 | import System.Log.Logger 14 | import Server 15 | 16 | -- sets up a logger to stdout as well as legion${port}.log 17 | -- the argument to the logger is mostly just a convenient way to have unique log files if we run 18 | -- several instances locally 19 | initLogger :: String -> IO () 20 | initLogger port = let logPriority = DEBUG 21 | format lh = return $ setFormatter lh (simpleLogFormatter "[$time : $loggername : $prio] $msg") 22 | in 23 | streamHandler stdout logPriority >>= format >>= \s -> 24 | fileHandler ("legion" ++ port ++ ".log") logPriority >>= format >>= \h -> 25 | updateGlobalLogger rootLoggerName $ setLevel logPriority . setHandlers [s, h] 26 | 27 | main :: IO () 28 | main = do 29 | args <- getArgs >>= \a -> case a of 30 | [h,p] -> return $ MainArgs h p Nothing 31 | [h,p,i] -> return $ MainArgs h p $ Just i 32 | _ -> fail "Usage:\n\n$ legion-exe httpPort p2pPort [optional bootstrap p2p address]\n\n\n" 33 | _ <- initLogger $ p2pPort args 34 | runLegion args 35 | 36 | 37 | -------------------------------------------------------------------------------- /legion.cabal: -------------------------------------------------------------------------------- 1 | name: legion 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/aviaviavi/legion#readme 6 | author: Avi Press 7 | maintainer: avipress@gmail.com 8 | copyright: 2017 Avi 9 | category: Web 10 | build-type: Simple 11 | extra-source-files: README.md 12 | cabal-version: >=1.10 13 | 14 | library 15 | hs-source-dirs: src 16 | exposed-modules: Lib, Server 17 | default-language: Haskell2010 18 | build-depends: GenericPretty 19 | , HTTP >= 4000.3.6 20 | , Spock >= 0.11 21 | , aeson 22 | , async 23 | , base >= 4.7 && < 5 24 | , binary 25 | , bytestring 26 | , cryptohash 27 | , distributed-process 28 | , distributed-process-p2p 29 | , either 30 | , hslogger 31 | , mtl 32 | , tasty >= 0.11.2 33 | , tasty-hunit >= 0.9.2 34 | , text 35 | , time 36 | 37 | executable legion-exe 38 | hs-source-dirs: app 39 | main-is: Main.hs 40 | default-language: Haskell2010 41 | build-depends: GenericPretty 42 | , HTTP >= 4000.3.6 43 | , Spock >= 0.11 44 | , aeson 45 | , async 46 | , base >= 4.7 && < 5 47 | , binary 48 | , bytestring 49 | , cryptohash 50 | , distributed-process 51 | , distributed-process-p2p 52 | , either 53 | , hslogger 54 | , legion 55 | , mtl 56 | , tasty >= 0.11.2 57 | , tasty-hunit >= 0.9.2 58 | , text 59 | , time 60 | 61 | test-suite legion-test 62 | type: exitcode-stdio-1.0 63 | hs-source-dirs: app test 64 | main-is: Spec.hs 65 | default-language: Haskell2010 66 | build-depends: HTTP >= 4000.3.6 67 | , HTTP >= 4000.3.6 68 | , Spock >= 0.11 69 | , aeson 70 | , async 71 | , base 72 | , base >= 4.7 && < 5 73 | , bytestring 74 | , cryptohash 75 | , legion 76 | , mtl 77 | , tasty >= 0.11.2 78 | , tasty >= 0.11.2 79 | , tasty >= 0.11.2 80 | , tasty-hunit >= 0.9.2 81 | , tasty-hunit >= 0.9.2 82 | , text 83 | , time 84 | 85 | -------------------------------------------------------------------------------- /src/Lib.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | module Lib where 7 | 8 | import Control.Monad.Trans 9 | import Crypto.Hash ( Digest 10 | , SHA256 11 | , digestFromByteString 12 | ) 13 | import Crypto.Hash.SHA256 14 | import Text.Read (readMaybe) 15 | import Data.Aeson 16 | import Data.Binary 17 | import Data.ByteString.Char8 (pack) 18 | import Data.Time.Clock.POSIX 19 | import GHC.Generics 20 | import Text.PrettyPrint.GenericPretty 21 | 22 | -- the main data type for our blockchain 23 | data Block = Block { index :: Int 24 | , previousHash :: String 25 | , timestamp :: Int 26 | , blockData :: String 27 | , nonce :: Int 28 | , blockHash :: String 29 | } deriving (Show, Read, Eq, Generic) 30 | 31 | -- http params to add a block to the chain 32 | newtype BlockArgs = BlockArgs{blockBody :: String} 33 | deriving (Show, Eq, Generic) 34 | 35 | instance ToJSON BlockArgs 36 | instance FromJSON BlockArgs 37 | instance ToJSON Block 38 | instance FromJSON Block 39 | instance Binary Block 40 | instance Out Block 41 | 42 | -- unix timestamp as an int 43 | epoch :: IO Int 44 | epoch = round `fmap` getPOSIXTime 45 | 46 | -- hashes a string and returns a hex digest 47 | sha256 :: String -> Maybe (Digest SHA256) 48 | sha256 = digestFromByteString . hash . pack 49 | 50 | -- abstracted hash function that takes a string 51 | -- to hash and returns a hex string 52 | hashString :: String -> String 53 | hashString = 54 | maybe (error "Something went wrong generating a hash") show . sha256 55 | 56 | calculateBlockHash :: Block -> String 57 | calculateBlockHash (Block i p t b n _) = 58 | hashString $ concat [show i, p, show t, b, show n] 59 | 60 | -- returns a copy of the block with the hash set 61 | setBlockHash :: Block -> Block 62 | setBlockHash block = block {blockHash = calculateBlockHash block} 63 | 64 | -- returns a copy of the block with a valid nonce and hash set 65 | setNonceAndHash :: Block -> Block 66 | setNonceAndHash block = setBlockHash $ block {nonce = findNonce block} 67 | 68 | -- Rudimentary proof-of-work (POW): ensures that a block hash 69 | -- is less than a certain value (i.e. contains a certain 70 | -- amount of leading zeroes). 71 | -- In our case, it's 4 leading zeroes. We're using the Integer type 72 | -- since the current target is higher than the max for Int. 73 | -- POW is useful because with this imposed difficulty to add values to 74 | -- the blockchain, it becomes exponentially less feasible to edit the 75 | -- chain - one would need to regenerate an entirely new valid chain 76 | -- after the edited block(s) 77 | difficultyTarget :: Integer 78 | difficultyTarget = 79 | 0x0000ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff 80 | 81 | -- checks whether the provided block hash satisfies 82 | -- our PoW requirement 83 | satisfiesPow :: String -> Bool 84 | satisfiesPow bHash = 85 | maybe 86 | (error $ "Something is wrong with the provided hash: " ++ bHash) 87 | (< difficultyTarget) 88 | (readMaybe ("0x" ++ bHash) :: Maybe Integer) 89 | 90 | -- Recursively finds a nonce that satisfies the difficulty target 91 | -- If our blockHash already satisfies the PoW, return the current nonce 92 | -- If not, increment the nonce and try again 93 | -- TODO - Handle nonce overflow. 94 | findNonce :: Block -> Int 95 | findNonce block = do 96 | let bHash = calculateBlockHash block 97 | currentNonce = nonce block 98 | if satisfiesPow bHash 99 | then currentNonce 100 | else findNonce $ block {nonce = currentNonce + 1} 101 | 102 | -- a hardcoded initial block, we need this to make sure all 103 | -- nodes have the same starting point, so we have a hard coded 104 | -- frame of reference to detect validity 105 | initialBlock :: Block 106 | initialBlock = do 107 | let block = Block 0 "0" 0 "initial data" 0 "" 108 | setNonceAndHash block 109 | 110 | -- a new block is valid if its index is 1 higher, its 111 | -- previous hash points to our last block, and its hash is computed 112 | -- correctly 113 | isValidNewBlock :: Block -> Block -> Bool 114 | isValidNewBlock prev next 115 | | index prev + 1 == index next && 116 | blockHash prev == previousHash next && 117 | blockHash next == calculateBlockHash next && 118 | satisfiesPow (blockHash next) = True 119 | | otherwise = False 120 | 121 | -- a chain is valid if it starts with our hardcoded initial 122 | -- block and every block is valid with respect to the previous 123 | isValidChain :: [Block] -> Bool 124 | isValidChain chain = case chain of 125 | [] -> True 126 | [x] -> x == initialBlock 127 | (x:xs) -> 128 | let blockPairs = zip chain xs in 129 | x == initialBlock && 130 | all (uncurry isValidNewBlock) blockPairs 131 | 132 | -- return the next block given a previous block and some data to put in it 133 | mineBlockFrom :: (MonadIO m) => Block -> String -> m Block 134 | mineBlockFrom lastBlock stringData = do 135 | time <- liftIO epoch 136 | let block = Block { index = index lastBlock + 1 137 | , previousHash = blockHash lastBlock 138 | , timestamp = time 139 | , blockData = stringData 140 | , nonce = 0 141 | , blockHash = "will be changed" 142 | } 143 | return $ setNonceAndHash block 144 | -------------------------------------------------------------------------------- /src/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | module Server where 8 | 9 | import Control.Concurrent (threadDelay) 10 | import Control.Concurrent.Async 11 | import Control.Distributed.Process 12 | import Control.Distributed.Process.Node 13 | import Control.Monad (forever) 14 | import Control.Monad.Trans 15 | import Data.IORef 16 | import Data.Maybe 17 | import GHC.Generics 18 | import Lib 19 | import System.Log.Logger 20 | import Text.PrettyPrint.GenericPretty 21 | import Web.Spock 22 | import Web.Spock.Config 23 | 24 | import qualified Control.Distributed.Backend.P2P as P2P 25 | import qualified Data.Binary as B 26 | import qualified Data.Text as T 27 | 28 | -- args for running the main application 29 | data MainArgs = MainArgs { httpPort :: String 30 | , p2pPort :: String 31 | , seedNode :: Maybe String 32 | } 33 | 34 | data MySession = EmptySession 35 | 36 | -- the state for our application, to be used as a spock state 37 | data BlockChainState = BlockChainState { blockChainState :: IORef [Block] 38 | , node :: LocalNode 39 | , pid :: ProcessId 40 | } deriving (Generic) 41 | 42 | -- ADT for data that will be sent across the P2P network 43 | data BlockUpdate = UpdateData Block | ReplaceData [Block] | RequestChain deriving (Generic) 44 | instance B.Binary BlockUpdate 45 | 46 | liftDebug :: (MonadIO m) => String -> m () 47 | liftDebug str = liftIO $ debugM "legion" (show str) 48 | 49 | p2pServiceName :: String 50 | p2pServiceName = "updateservice" 51 | 52 | -- explicit entry point to run the application, which is useful 53 | -- for our tests 54 | runLegion :: MainArgs -> IO () 55 | runLegion args = do 56 | liftDebug "starting" 57 | (localNode, procId) <- runP2P (p2pPort args) (seedNode args) (return ()) 58 | ref <- maybe (newIORef [initialBlock]) (const $ newIORef []) (seedNode args) 59 | spockCfg <- defaultSpockCfg EmptySession PCNoDatabase (BlockChainState ref localNode procId) 60 | _ <- async $ runSpock (read (httpPort args) :: Int) (spock spockCfg Server.app) 61 | -- wait for messages to come in from the p2p network and respond to them 62 | runProcess localNode $ do 63 | getSelfPid >>= register p2pServiceName 64 | liftIO $ threadDelay 1000000 65 | _ <- if isJust $ seedNode args 66 | then do 67 | liftDebug "this is not the initial node, requesting a chain" 68 | requestChain localNode 69 | else liftDebug "this is the initial node, not requesting a chain" 70 | forever $ do 71 | message <- expect :: Process BlockUpdate 72 | liftDebug "got a message..." 73 | case message of 74 | (ReplaceData chain) -> do 75 | liftDebug $ "got some stuff to replace: " ++ show chain 76 | replaceChain ref chain 77 | (UpdateData block) -> do 78 | liftDebug $ "got some stuff to add: " ++ show block 79 | addBlock ref block 80 | RequestChain -> do 81 | liftDebug "got chain request" 82 | sendChain localNode ref 83 | 84 | -- Type alias 85 | type Get stateType returnType 86 | = forall m. 87 | (SpockState m ~ stateType, MonadIO m, HasSpock m) 88 | => m returnType 89 | 90 | -- retrieve the current block chain 91 | getBlockChain :: Get BlockChainState [Block] 92 | getBlockChain = do 93 | (BlockChainState chain _ _) <- getState 94 | liftIO $ readIORef chain 95 | 96 | -- retrieve the most recent block in the chain 97 | getLatestBlock :: Get BlockChainState Block 98 | getLatestBlock = fmap last getBlockChain 99 | 100 | -- add a block to our blockchain, if it's valid 101 | addBlock :: MonadIO m => IORef [Block] -> Block -> m () 102 | addBlock ref block = do 103 | chain <- liftIO $ readIORef ref 104 | if isValidNewBlock (last chain) block 105 | then do 106 | liftDebug "adding new block" 107 | _ <- liftIO $ atomicModifyIORef' ref $ \b -> (b ++ [block], b ++ [block]) 108 | return () 109 | else 110 | liftDebug "new block not valid. skipping" 111 | 112 | -- given some data, create a valid block 113 | mineBlock :: (SpockState m ~ BlockChainState, MonadIO m, HasSpock m) => String -> m Block 114 | mineBlock stringData = do 115 | lastBlock <- getLatestBlock 116 | mineBlockFrom lastBlock stringData 117 | 118 | -- if this chain is valid and longer than what we have, update it. 119 | replaceChain :: MonadIO m => IORef [Block] -> [Block] -> m () 120 | replaceChain chainRef newChain = do 121 | currentChain <- liftIO $ readIORef chainRef 122 | if (not . isValidChain) newChain || length currentChain >= length newChain 123 | then liftDebug $ "chain is not valid for updating!: " ++ show newChain 124 | else do 125 | setChain <- liftIO $ atomicModifyIORef' chainRef $ const (newChain, newChain) 126 | liftDebug ("updated chain: " ++ show setChain) 127 | 128 | -- ask other nodes for their chains 129 | requestChain :: MonadIO m => LocalNode -> m () 130 | requestChain localNode = liftIO $ runProcess localNode $ do 131 | liftDebug "requesting chain" 132 | P2P.nsendPeers p2pServiceName RequestChain 133 | 134 | -- sends the entire chain to all nodes in the network. 135 | -- receiving nodes should update if this chain is newer than what they have 136 | sendChain :: MonadIO m => LocalNode -> IORef [Block] -> m () 137 | sendChain localNode chainRef = liftIO $ runProcess localNode $ do 138 | liftDebug "emitting chain" 139 | chain <- liftIO $ readIORef chainRef 140 | P2P.nsendPeers p2pServiceName $ ReplaceData chain 141 | 142 | runP2P port bootstrapNode = P2P.bootstrapNonBlocking "127.0.0.1" port (maybeToList $ P2P.makeNodeId `fmap` bootstrapNode) initRemoteTable 143 | 144 | -- spock http endpoint 145 | app :: SpockM () MySession BlockChainState () 146 | app = do 147 | get root $ 148 | text "Legion Blockchain Node" 149 | post "block" $ do 150 | (BlockChainState ref localNode _) <- getState 151 | (blockString :: BlockArgs) <- jsonBody' 152 | liftDebug $ show blockString 153 | block <- mineBlock . blockBody $ blockString 154 | _ <- addBlock ref block 155 | chain <- getBlockChain 156 | liftDebug $ show chain 157 | liftIO $ runProcess localNode $ P2P.nsendPeers p2pServiceName $ UpdateData block 158 | text . T.pack . pretty $ chain 159 | get "chain" $ do 160 | chain <- getBlockChain 161 | text . T.pack . pretty $ chain 162 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-8.12 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [distributed-process-p2p-0.1.3.2, distributed-process-monad-control-0.5.1.2] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.3" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Control.Concurrent (threadDelay) 4 | import Control.Concurrent.Async 5 | import Data.Aeson 6 | import Data.ByteString.Lazy.Char8 (unpack) 7 | import Lib 8 | import Network.HTTP 9 | import Server 10 | import Test.Tasty 11 | import Test.Tasty.HUnit 12 | import Text.Printf 13 | 14 | main :: IO () 15 | main = defaultMain tests 16 | 17 | tests :: TestTree 18 | tests = testGroup "Tests" [unitTests, integrationTests] 19 | 20 | unitTests :: TestTree 21 | unitTests = 22 | testGroup "Unit tests" [testCase "valid chain" testValidChain] 23 | 24 | integrationTests :: TestTree 25 | integrationTests = 26 | testGroup "Integration Test" [testCase "basic chain syncing" testBasicSync] 27 | 28 | testValidChain :: IO () 29 | testValidChain = do 30 | let b = initialBlock 31 | assertBool "block eq" $ b == b 32 | assertBool "empty chains are valid" $ isValidChain [] 33 | assertBool "base chain is valid" $ isValidChain [b] 34 | assertBool "two init blocks are invalid" $ not $ isValidChain [b, b] 35 | goodBlock <- mineBlockFrom b "asdfasdf" 36 | assertBool "actually good chain" $ isValidChain [b, goodBlock] 37 | 38 | testBasicSync :: IO () 39 | testBasicSync = 40 | let webPorts = ["8001", "8002"] 41 | p2pPorts = ["9001", "9002"] 42 | args = MainArgs (head webPorts) (head p2pPorts) Nothing 43 | args' = 44 | MainArgs (last webPorts) (last p2pPorts) $ 45 | Just ("127.0.0.1:" ++ head p2pPorts) 46 | in do _ <- async $ runLegion args 47 | _ <- async $ runLegion args' 48 | -- wait to let the servers initialize 49 | threadDelay 3000000 50 | _ <- allChainsHaveLength webPorts 1 51 | let blockArgs = unpack . encode $ BlockArgs "some data" 52 | print blockArgs 53 | _ <- 54 | simpleHTTP 55 | (postRequestWithBody 56 | (localAPI (head webPorts) "block") 57 | "application/json" 58 | blockArgs) >>= 59 | fmap (take 10000) . getResponseBody 60 | threadDelay 1000000 61 | _ <- allChainsHaveLength webPorts 2 62 | _ <- 63 | simpleHTTP 64 | (postRequestWithBody 65 | (localAPI (last webPorts) "block") 66 | "application/json" 67 | blockArgs) 68 | threadDelay 1000000 69 | _ <- allChainsHaveLength webPorts 3 70 | return () 71 | 72 | localAPI :: String -> String -> String 73 | localAPI = printf "http://127.0.0.1:%s/%s" 74 | 75 | allChainsHaveLength :: [String] -> Int -> IO () 76 | allChainsHaveLength ports len = do 77 | lengths <- mapM getChainLength ports 78 | assertBool ("all have length " ++ show len) $ all (== len) lengths 79 | 80 | getChainLength :: String -> IO Int 81 | getChainLength serverPort = do 82 | body <- 83 | simpleHTTP (getRequest (localAPI serverPort "chain")) >>= 84 | fmap (take 10000) . getResponseBody 85 | let parsedBody = read body :: [Block] 86 | print parsedBody 87 | return $ length parsedBody 88 | --------------------------------------------------------------------------------