├── Setup.hs ├── doc ├── network_schema.png ├── information_flow.png ├── network_example.png ├── request_per_deficit_function.png ├── network_example_hires_amoeba_n359_5-10-3cluster.png ├── network_schema.dot ├── information_flow.dot └── request_per_deficit_function.nb ├── util ├── draw_network_graph ├── list-todo ├── connections ├── hsloc └── launch ├── LICENCE.md ├── src ├── Main │ ├── MultiExecutable.hs │ ├── NodeExecutable.hs │ ├── DrawingExecutable.hs │ ├── BootstrapExecutable.hs │ ├── Node.hs │ ├── MessageClient.hs │ ├── Multi.hs │ ├── Bootstrap.hs │ └── Drawing.hs ├── Types.hs ├── Utilities │ ├── Unsafe.hs │ ├── Debug.hs │ ├── IOQueue.hs │ ├── Concurrency.hs │ ├── Networking.hs │ └── Databases.hs ├── Types │ ├── Lens.hs │ ├── Misc.hs │ ├── Signal.hs │ └── Config.hs ├── Config │ ├── OptionModifier.hs │ ├── Default.hs │ ├── AddressParser.hs │ ├── Getter.hs │ ├── Verify.hs │ ├── ConfigFile.hs │ └── CmdArgParser.hs ├── Utilities.hs ├── Node.hs ├── Housekeeping.hs ├── NodePool.hs ├── Bootstrap.hs ├── ClientPool.hs ├── Client.hs └── Server.hs ├── BRANCHING.md ├── .travis.yml ├── amoeba.cfg.sample ├── amoeba.cabal ├── DIFFICULTIES.md ├── Makefile └── README.md /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /doc/network_schema.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/quchen/amoeba/HEAD/doc/network_schema.png -------------------------------------------------------------------------------- /doc/information_flow.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/quchen/amoeba/HEAD/doc/information_flow.png -------------------------------------------------------------------------------- /doc/network_example.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/quchen/amoeba/HEAD/doc/network_example.png -------------------------------------------------------------------------------- /util/draw_network_graph: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | neato -Tpng network_graph.dot > network_graph.png -------------------------------------------------------------------------------- /doc/request_per_deficit_function.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/quchen/amoeba/HEAD/doc/request_per_deficit_function.png -------------------------------------------------------------------------------- /doc/network_example_hires_amoeba_n359_5-10-3cluster.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/quchen/amoeba/HEAD/doc/network_example_hires_amoeba_n359_5-10-3cluster.png -------------------------------------------------------------------------------- /util/list-todo: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # List all "TODO" entries in the source folder 4 | 5 | find ../src -name '*.hs' -print0 | xargs -0 -- grep --color=always "TODO" -------------------------------------------------------------------------------- /LICENCE.md: -------------------------------------------------------------------------------- 1 | Licence 2 | ======= 3 | 4 | Written 2014 by David Luposchainsky, all rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without modification, 7 | are permitted provided that the following conditions are met: 8 | 9 | 1. Do whatever you want to. -------------------------------------------------------------------------------- /util/connections: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # Periodically print the number of TCP connections open by 'bootstrap'. Useful 4 | # to check for socket leaks. 5 | 6 | echo "Open TCP connections by '$1':" 7 | while true; do 8 | sleep 1; 9 | lsof -iTCP -a -c$1 | wc -l; 10 | done -------------------------------------------------------------------------------- /src/Main/MultiExecutable.hs: -------------------------------------------------------------------------------- 1 | -- | Main module for the multi client executable. 2 | -- 3 | -- Tiny wrapper to isolate the Amoeba library and its dependencies from the 4 | -- Amoeba executables, which then only depend on Base and the Amoeba library, 5 | -- while the latter contains all the transitive dependencies. 6 | 7 | module Main (main) where 8 | 9 | import qualified Main.Multi as M 10 | 11 | main :: IO () 12 | main = M.main -------------------------------------------------------------------------------- /src/Main/NodeExecutable.hs: -------------------------------------------------------------------------------- 1 | -- | Main module for the single client executable. 2 | -- 3 | -- Tiny wrapper to isolate the Amoeba library and its dependencies from the 4 | -- Amoeba executables, which then only depend on Base and the Amoeba library, 5 | -- while the latter contains all the transitive dependencies. 6 | 7 | module Main (main) where 8 | 9 | import qualified Main.Node as M 10 | 11 | main :: IO () 12 | main = M.main -------------------------------------------------------------------------------- /src/Main/DrawingExecutable.hs: -------------------------------------------------------------------------------- 1 | -- | Main module for the drawing server executable. 2 | -- 3 | -- Tiny wrapper to isolate the Amoeba library and its dependencies from the 4 | -- Amoeba executables, which then only depend on Base and the Amoeba library, 5 | -- while the latter contains all the transitive dependencies. 6 | 7 | module Main (main) where 8 | 9 | import qualified Main.Drawing as M 10 | 11 | main :: IO () 12 | main = M.main -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | -- | Meta-module. Reexports everything in Types/ except the Lens module. 2 | 3 | module Types ( 4 | -- Explicitly export modules since Haddock doesn't seem to like importing 5 | -- them all under an alias and exporting the alias 6 | module Types.Misc 7 | , module Types.Config 8 | , module Types.Signal 9 | ) where 10 | 11 | import Types.Misc 12 | import Types.Config 13 | import Types.Signal 14 | -------------------------------------------------------------------------------- /src/Main/BootstrapExecutable.hs: -------------------------------------------------------------------------------- 1 | -- | Main module for the bootstrap server executable. 2 | -- 3 | -- Tiny wrapper to isolate the Amoeba library and its dependencies from the 4 | -- Amoeba executables, which then only depend on Base and the Amoeba library, 5 | -- while the latter contains all the transitive dependencies. 6 | 7 | module Main (main) where 8 | 9 | import qualified Main.Bootstrap as M 10 | 11 | main :: IO () 12 | main = M.main -------------------------------------------------------------------------------- /util/hsloc: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # Get the current number of Haskell source lines in the project 4 | 5 | echo -n "Haskell SLOC: " 6 | # SED: 7 | # Line starts with * whitespace 8 | # Then: possibly a comment 9 | # Comment: "--" followed by either nothing or by whitespace and arbitrary text 10 | # EOL 11 | AMOEBA_ROOT=$(dirname $0)/../ 12 | find $AMOEBA_ROOT -name '*.hs' | xargs cat | sed '/^\s*\(--\(\s\+.*\)\?\)\?$/d' | wc -l -------------------------------------------------------------------------------- /src/Main/Node.hs: -------------------------------------------------------------------------------- 1 | -- | Main entry module point for an ordinary node. 2 | 3 | module Main.Node (main) where 4 | 5 | import Control.Concurrent.Async 6 | import Control.Exception 7 | 8 | import Node 9 | import Types 10 | import Utilities 11 | import qualified Config.Getter as Config 12 | 13 | -- | Start a single node. 14 | main :: IO () 15 | main = do 16 | 17 | config <- Config.node 18 | 19 | prepareOutputBuffers 20 | (output, oThread) <- outputThread (_maxChanSize config) 21 | startNode Nothing output config 22 | `finally` cancel oThread 23 | -------------------------------------------------------------------------------- /BRANCHING.md: -------------------------------------------------------------------------------- 1 | Git branching model 2 | =================== 3 | 4 | - **stable**: Reasonably stable versions without obvious or neck-breaking bugs. 5 | The **stable** branch contains releases, and no development 6 | happens on this branch. All commits on it are merges of 7 | **master**. 8 | - **master**: "Nightly build" level of stability; merges **develop** branches, 9 | and stable commits can be merged into **stable**. Although no 10 | source-level development happens here, commits may contain edits 11 | of meta files (such as the readme or build options). 12 | - **develop**: Main branch for development. Often contains broken or extremely 13 | buggy builds, excessive debug messages, hacks etc. -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | ghc: 7.8 3 | 4 | 5 | # Install GHC 7.8.2 on Travis using hvr's repo, see 6 | # https://github.com/hvr/multi-ghc-travis 7 | before_install: 8 | - ghc --version 9 | - cabal --version 10 | - sudo add-apt-repository -y ppa:hvr/ghc 11 | - sudo apt-get update 12 | - sudo apt-get install cabal-install-1.20 13 | - export PATH=/opt/cabal/1.20/bin:$PATH 14 | - ghc --version 15 | - cabal --version 16 | 17 | install: 18 | # Travis automatically calls cabal update 19 | - make cabal-noupdate 20 | - export PATH=$PWD/.cabal-sandbox/bin:$PATH 21 | 22 | script: 23 | - make fast 24 | 25 | after_success: 26 | - cabal install hscolour 27 | - make haddock 28 | # run tests 29 | 30 | 31 | 32 | notifications: 33 | email: false -------------------------------------------------------------------------------- /src/Utilities/Unsafe.hs: -------------------------------------------------------------------------------- 1 | -- | Functions for ad-hoc debugging. 2 | -- 3 | -- While the exported interface is safe to use, the functionality provided 4 | -- is far from being suitable for production. 5 | module Unsafe ( 6 | inc 7 | , dec 8 | , value 9 | , yellCounter 10 | ) where 11 | 12 | 13 | import System.IO.Unsafe 14 | import Control.Concurrent.STM 15 | 16 | 17 | 18 | import Utilities 19 | 20 | 21 | 22 | counter :: TVar Integer 23 | counter = unsafePerformIO (newTVarIO 0) 24 | 25 | -- | Increment counter 26 | inc :: IO () 27 | inc = atomically (modifyTVar counter (+1)) 28 | 29 | -- | Decrement counter 30 | dec :: IO () 31 | dec = atomically (modifyTVar counter (subtract 1)) 32 | 33 | value :: IO Integer 34 | value = atomically (readTVar counter) 35 | 36 | -- | Print counter contents 37 | yellCounter :: IO () 38 | yellCounter = do x <- value 39 | yell 45 ("Unsafe counter value: " ++ show x) 40 | -------------------------------------------------------------------------------- /doc/network_schema.dot: -------------------------------------------------------------------------------- 1 | #define LDC [color = "#BF0000"] 2 | #define NORMAL [color = "#004280"] 3 | 4 | #define yel_light [color = "#E6A500"] 5 | #define yel_dark [color = "#CC8000"] 6 | 7 | digraph G { 8 | 9 | node [color = gray70, fontname = "Courier"] 10 | 11 | node [shape = ellipse] 12 | A [label = "Node A"] 13 | B [label = "Node B"] 14 | C [label = "Node C"] 15 | D [label = "Node D"] 16 | E [label = "Node E"] 17 | 18 | node [shape = box] 19 | Draw [label = "Drawing\nserver"] 20 | BS [label = "Bootstrap\nserver"] 21 | 22 | 23 | 24 | 25 | edge [len = 2] 26 | 27 | A -> B NORMAL 28 | A -> D NORMAL 29 | A -> E NORMAL 30 | 31 | B -> A NORMAL 32 | B -> D NORMAL 33 | 34 | C -> D NORMAL 35 | C -> E NORMAL 36 | 37 | D -> C NORMAL 38 | D -> E NORMAL 39 | 40 | E -> C NORMAL 41 | E -> B NORMAL 42 | E -> A NORMAL 43 | 44 | 45 | 46 | edge [len = 1.5] 47 | 48 | BS -> D LDC 49 | BS -> C LDC 50 | 51 | Draw -> A LDC 52 | } -------------------------------------------------------------------------------- /util/launch: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # This file provides a couple of shortcuts for setting up Amoeba networks for 4 | # testing. 5 | 6 | cd .. 7 | case "$1" in 8 | "bss1" ) 9 | ./bootstrap -p 20000 -n10 --bootstrap 127.0.0.1:20000 --verbosity=debug 10 | ;; 11 | "bss2" ) 12 | ./bootstrap -p 20020 -n10 --bootstrap 127.0.0.1:20020 --verbosity=debug 13 | ;; 14 | "bss3" ) 15 | ./bootstrap -p 20040 -n10 --bootstrap 127.0.0.1:20040 --verbosity=debug 16 | ;; 17 | "multi1" ) 18 | ulimit -n 4000 19 | ./amoeba_multi -p 20100 -n 100 --bootstrap 127.0.0.1:20000 --verbosity=debug 20 | ;; 21 | "multi2" ) 22 | ulimit -n 4000 23 | ./amoeba_multi -p 20200 -n 100 --bootstrap 127.0.0.1:20020 --verbosity=debug 24 | ;; 25 | "multi3" ) 26 | ulimit -n 4000 27 | ./amoeba_multi -p 20300 -n 100 --bootstrap 127.0.0.1:20040 --verbosity=debug 28 | ;; 29 | *) 30 | echo "Unsupported option given" 31 | ;; 32 | esac 33 | -------------------------------------------------------------------------------- /src/Utilities/Debug.hs: -------------------------------------------------------------------------------- 1 | -- | Functions that are only used for debugging. This file should be safely 2 | -- removable in stable releases. 3 | 4 | module Utilities.Debug where 5 | 6 | 7 | 8 | 9 | import Control.Monad 10 | import Control.Monad.Trans 11 | import Control.Exception 12 | 13 | import Text.Printf 14 | 15 | 16 | 17 | -- | Easily print colored text for debugging 18 | yell :: MonadIO io => Int -> String -> io () 19 | yell n text = liftIO (printf "\ESC[%dm%d - %s\ESC[0m\n" n n text) 20 | 21 | 22 | 23 | -- | Catch all exceptions, "yell" their contents, and rethrow them. 24 | yellAndRethrow :: (MonadIO io) 25 | => Int 26 | -> (String -> String) -- ^ Modify error message, e.g. (++ "foo") 27 | -> IO () 28 | -> io () 29 | yellAndRethrow n f = liftIO . handle handler 30 | where handler :: SomeException -> IO () 31 | handler (SomeException e) = yell n (f (show e)) >> throw e 32 | 33 | 34 | 35 | -- | Mandatory silly catchall function. Intended to be used as a safety net 36 | -- only, not as a cpeap getaway :-) 37 | catchAll :: IO a -> IO () 38 | catchAll x = void x `catch` handler 39 | where handler :: SomeException -> IO () 40 | handler _ = return () 41 | -------------------------------------------------------------------------------- /src/Types/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- For makeFields 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE TypeSynonymInstances #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# OPTIONS_HADDOCK show-extensions #-} 9 | 10 | 11 | -- | Defines optics (lens library) for various Amoeba types. Intended to be 12 | -- imported qualified. 13 | -- 14 | -- This module is predominantly generated automatically by Template Haskell. 15 | -- For documentation on what the different fields do, have a look at the 16 | -- documentation in the other 'Types' modules. 17 | module Types.Lens where 18 | 19 | import Control.Lens 20 | import Types 21 | import Utilities.IOQueue 22 | 23 | 24 | 25 | -- Various types 26 | makeLenses ''BootstrapConfig 27 | makeLenses ''Client 28 | makeLenses ''DrawingConfig 29 | makeLenses ''Environment 30 | makeLenses ''MultiConfig 31 | makeLenses ''Node 32 | makeLenses ''NodeConfig 33 | makeLenses ''PChan 34 | makeLenses ''PoolConfig 35 | 36 | 37 | -- Types with overloaded fields, e.g. "has node config subfield" 38 | makeFields ''BootstrapConfig 39 | makeFields ''DrawingConfig 40 | makeFields ''MultiConfig 41 | 42 | 43 | -- Isomorphisms (newtypes) 44 | makeIso ''IOQueue 45 | makeIso ''Microseconds 46 | makeIso ''Timestamp -------------------------------------------------------------------------------- /src/Types/Misc.hs: -------------------------------------------------------------------------------- 1 | -- | Types that don't fit in any of the specialized modules. 2 | 3 | module Types.Misc where 4 | 5 | 6 | 7 | -- | How many messages should be printed? 8 | data Verbosity = Chatty -- ^ Everything, e.g. passing bounces, keep-alive 9 | -- signals. Very verbose. 10 | | Debug -- ^ Various status messages, e.g. gaining and losing 11 | -- neighbours 12 | | Default -- ^ Useful for normal execution, e.g. node deficit, 13 | -- chat messages 14 | | Quiet -- ^ Only messages intended for display, i.e. chat 15 | | Mute -- ^ Nothing, node just serves as a network helper 16 | deriving (Eq, Ord, Show) 17 | -- Note: Order matters in order to make `myVerbosity > x` work! 18 | 19 | 20 | 21 | -- | Unique identifier for upstream nodes. 22 | newtype From = From { getFrom :: Integer } 23 | deriving (Eq, Ord) 24 | 25 | instance Show From where 26 | show (From i) = "From #" ++ show i 27 | 28 | 29 | 30 | -- | Encodes in what relationship two nodes stand to each other 31 | data NodeRelationship = IsSelf 32 | | IsDownstreamNeighbour 33 | | IsUnrelated 34 | deriving (Eq, Ord, Show) -------------------------------------------------------------------------------- /src/Config/OptionModifier.hs: -------------------------------------------------------------------------------- 1 | -- | Types and typeclasses to modify a given configuration 2 | 3 | module Config.OptionModifier where 4 | 5 | import Data.Monoid 6 | import Control.Lens 7 | 8 | 9 | 10 | -- | Represents a modification of a configuration type. An 'OptionModifier' is 11 | -- conceptually a "set field X to value Y" operation that can be applied to 12 | -- some default data. 13 | -- 14 | -- Considering its 'Monoid' instance, this is equivalent to 15 | -- @'Dual' ('Endo' a)@, i.e. functions added to the right of '<>' are used 16 | -- later in the pipeline, prioritizing their changes over previous ones. 17 | newtype OptionModifier a = OptionModifier { applyOptionModifier :: a -> a } 18 | 19 | instance Monoid (OptionModifier a) where 20 | mempty = OptionModifier id 21 | mappend (OptionModifier x) (OptionModifier y) = OptionModifier (y . x) 22 | 23 | 24 | 25 | -- | Lift a modifier of a subfield to a modifier of the entire field. 26 | -- 27 | -- For example, a 'Types.Config.BootstrapConfig' contains a 28 | -- 'Types.Config.NodeConfig'. @'liftModifier' nodeConfig@ will then be a 29 | -- modifier for a 'BootstrapConfig'defined by modifying its 'NodeConfig' 30 | -- subfield. 31 | liftModifier :: Setting (->) b b a a 32 | -> OptionModifier a 33 | -> OptionModifier b 34 | liftModifier l (OptionModifier f) = OptionModifier (l %~ f) -------------------------------------------------------------------------------- /src/Main/MessageClient.hs: -------------------------------------------------------------------------------- 1 | -- | Main entry point for the message client, which allows sending text messages 2 | -- over the Amoeba network. 3 | 4 | module Main (main) where 5 | 6 | 7 | import Control.Monad 8 | 9 | import Data.Binary (Binary) 10 | 11 | import Pipes 12 | import qualified Data.ByteString as BS 13 | import qualified Pipes.Binary as P 14 | import qualified Pipes.Network.TCP as P 15 | import qualified Pipes.Prelude as P 16 | 17 | import Utilities (connectToNode, makeTimestamp, encodeMany) 18 | import Types 19 | 20 | 21 | 22 | server = To $ Node "127.0.0.1" 20000 23 | 24 | 25 | 26 | main :: IO () 27 | main = do 28 | putStrLn "Message injection client" 29 | putStrLn "Enter \"quit\" to quit" 30 | putStrLn "" 31 | connectToNode server $ \(socket, addr) -> do 32 | putStrLn $ "Connected to " ++ show server 33 | runEffect $ P.stdinLn >-> handle >-> encodeMany >-> send socket 34 | 35 | 36 | 37 | handle :: MonadIO io => Pipe String Signal io () 38 | handle = P.takeWhile (/= "quit") >-> P.mapM dispatch 39 | where dispatch msg = do 40 | liftIO $ putStrLn $ "Sending \"" ++ msg ++ "\"" 41 | signal msg 42 | signal msg = do 43 | t <- makeTimestamp 44 | return $ (Normal . Flood t . TextMessage) msg 45 | 46 | 47 | 48 | send :: (MonadIO io) => P.Socket -> Consumer BS.ByteString io () 49 | send = P.toSocket 50 | -------------------------------------------------------------------------------- /src/Main/Multi.hs: -------------------------------------------------------------------------------- 1 | -- | Main entry point for the multi-node client. 2 | -- 3 | -- Launches a node pool without further services. In other words, it's like a 4 | -- bootstrap server without the bootstrapping part. 5 | 6 | {-# LANGUAGE NumDecimals #-} 7 | 8 | module Main.Multi (main) where 9 | 10 | import Control.Concurrent 11 | import Control.Concurrent.Async 12 | import Control.Exception 13 | import Control.Monad 14 | import qualified Data.Traversable as T 15 | import Text.Printf 16 | 17 | import NodePool 18 | import Utilities 19 | import qualified Config.Getter as Config 20 | 21 | import Control.Lens.Operators 22 | import qualified Types.Lens as L 23 | 24 | import Types (Microseconds(..)) 25 | 26 | 27 | 28 | main :: IO () 29 | main = multiNodeMain 30 | 31 | multiNodeMain :: IO () 32 | multiNodeMain = do 33 | 34 | config <- Config.multi 35 | 36 | prepareOutputBuffers 37 | (output, oThread) <- outputThread (config ^. L.nodeConfig . L.maxChanSize) 38 | (`finally` cancel oThread) $ do 39 | 40 | let poolSize = config ^. L.poolConfig . L.poolSize 41 | printf "Starting pool with %d nodes" poolSize 42 | 43 | ldc <- newChan 44 | npThread <- async (nodePool poolSize 45 | (config ^. L.nodeConfig) 46 | ldc 47 | output 48 | Nothing) -- No termination trigger 49 | 50 | void (forever (delay (Microseconds 10e8))) 51 | `finally` (wait npThread >>= T.traverse cancel) -------------------------------------------------------------------------------- /doc/information_flow.dot: -------------------------------------------------------------------------------- 1 | // CPP because GraphViz doesn't support custom styles 2 | #define NETWORK [color = "#BF0000"] 3 | #define STM [color = "#004280"] 4 | #define PARAMETER [color = "#E6A500", style = dashed] 5 | 6 | 7 | 8 | digraph G { 9 | 10 | node [shape = box, fontname = "Courier", color = gray70] 11 | nodesep = 0.33 12 | ranksep = 0.5 13 | 14 | subgraph cluster_node { 15 | 16 | label = "Node X" 17 | color = black 18 | labelloc = t 19 | 20 | Server 21 | Worker1 [label = "Worker A"] 22 | Worker2 [label = "Worker B"] 23 | Worker3 [label = "Worker C"] 24 | 25 | Client1 [label = "Client S"] 26 | Client2 [label = "Client T"] 27 | Client3 [label = "Client U"] 28 | 29 | CP [label = "Client pool"] 30 | 31 | ClientChannels [label = "STC\nST1C\nSTSC", shape = ellipse] 32 | 33 | 34 | 35 | 36 | Server -> Worker1 PARAMETER 37 | Server -> Worker2 PARAMETER 38 | Server -> Worker3 PARAMETER 39 | 40 | 41 | Worker1 -> ClientChannels STM 42 | Worker2 -> ClientChannels STM 43 | Worker3 -> ClientChannels STM 44 | 45 | ClientChannels -> Client1 STM 46 | ClientChannels -> Client2 STM 47 | ClientChannels -> Client3 STM 48 | 49 | 50 | 51 | 52 | subgraph _cp { 53 | rank = "same" 54 | CP -> ClientChannels [rank = same] STM 55 | } 56 | 57 | 58 | } 59 | 60 | Dsn1 [label = "Node S"] 61 | Dsn2 [label = "Node T"] 62 | Dsn3 [label = "Node U"] 63 | 64 | Client1 -> Dsn1 NETWORK 65 | Client2 -> Dsn2 NETWORK 66 | Client3 -> Dsn3 NETWORK 67 | 68 | Usn1 [label = "Node A"] 69 | Usn2 [label = "Node B"] 70 | Usn3 [label = "Node C"] 71 | 72 | Usn1 -> Worker1 NETWORK 73 | Usn2 -> Worker2 NETWORK 74 | Usn3 -> Worker3 NETWORK 75 | Usn1 -> Server [style = dashed] NETWORK 76 | Usn2 -> Server [style = dashed] NETWORK 77 | Usn3 -> Server [style = dashed] NETWORK 78 | 79 | 80 | } -------------------------------------------------------------------------------- /src/Config/Default.hs: -------------------------------------------------------------------------------- 1 | -- | Default configurations, used by the command line arguments parser. This 2 | -- module is intended to be used qualified, e.g. as \"Default\" to make nice 3 | -- names such as \"Default.'nodeConfig'\". 4 | 5 | {-# LANGUAGE NumDecimals #-} 6 | {-# OPTIONS_HADDOCK show-extensions #-} 7 | 8 | module Config.Default where 9 | 10 | 11 | import qualified Data.Set as Set 12 | 13 | import Types 14 | 15 | 16 | 17 | -- | Default node configuration 18 | nodeConfig :: NodeConfig 19 | nodeConfig = NodeConfig { 20 | _serverPort = 21000 21 | , _maxNeighbours = 10 22 | , _minNeighbours = 5 23 | , _maxChanSize = 100 24 | , _hardBounces = 2 25 | , _acceptP = 0.5 26 | , _maxSoftBounces = 10 27 | , _shortTickRate = 1e5 28 | , _mediumTickRate = 3e5 29 | , _longTickRate = 1e6 30 | , _poolTimeout = 5 31 | , _verbosity = Default 32 | , _bootstrapServers = Set.empty 33 | , _floodMessageCache = 1024 34 | } 35 | 36 | 37 | 38 | -- | Default node pool configuration 39 | poolConfig :: PoolConfig 40 | poolConfig = PoolConfig { 41 | 42 | _poolSize = 8 43 | 44 | } 45 | 46 | 47 | 48 | -- | Default multi-node client configuration 49 | multiConfig :: MultiConfig 50 | multiConfig = MultiConfig { 51 | _multiconfigNodeConfig = nodeConfig 52 | , _multiconfigPoolConfig = poolConfig 53 | } 54 | 55 | 56 | 57 | -- | Default drawing server configuration 58 | drawingConfig :: DrawingConfig 59 | drawingConfig = DrawingConfig { 60 | _drawEvery = 1e7 61 | , _drawFilename = "network_graph.dot" 62 | , _drawTimeout = 33 -- 33 seconds = 3 drawing attempts before timeout 63 | , _drawingconfigNodeConfig = nodeConfig 64 | , _drawingconfigPoolConfig = poolConfig 65 | } 66 | 67 | 68 | 69 | -- | Default bootstrap server configuration 70 | bootstrapConfig :: BootstrapConfig 71 | bootstrapConfig = BootstrapConfig { 72 | _restartEvery = 5 73 | , _restartMinimumPeriod = 1e6 74 | , _bootstrapconfigNodeConfig = nodeConfig 75 | , _bootstrapconfigPoolConfig = poolConfig 76 | } 77 | -------------------------------------------------------------------------------- /src/Utilities.hs: -------------------------------------------------------------------------------- 1 | -- | Functions needed over a large range of other modules. 2 | 3 | module Utilities ( 4 | 5 | module Utilities.Debug 6 | , module Utilities.Concurrency 7 | , module Utilities.Databases 8 | , module Utilities.IOQueue 9 | , module Utilities.Networking 10 | 11 | -- * Various utilities 12 | , whenM 13 | , ifM 14 | , whileM 15 | , pluralS 16 | , mergeLists 17 | , showT 18 | , iSqrt 19 | 20 | ) where 21 | 22 | 23 | 24 | import Control.Monad 25 | 26 | import qualified Data.Text as T 27 | 28 | import Utilities.Concurrency 29 | import Utilities.Databases 30 | import Utilities.Debug 31 | import Utilities.IOQueue 32 | import Utilities.Networking 33 | 34 | 35 | 36 | -- | Monadic version of 'when'. 37 | whenM :: Monad m => m Bool -> m () -> m () 38 | whenM mp m = mp >>= \p -> when p m 39 | 40 | 41 | 42 | -- | Monadic version of 'IfThenElse'. 43 | ifM :: Monad m => m Bool -> m a -> m a -> m a 44 | ifM mp x y = mp >>= \p -> if p then x else y 45 | 46 | 47 | 48 | -- | Repeatedly executes a monadic action until its contents evaluate to False. 49 | whileM :: Monad m => (a -> Bool) -> m a -> m () 50 | whileM p m = go 51 | where go = m >>= \x -> when (p x) go 52 | 53 | 54 | 55 | 56 | -- | To add an \"s\" in print statements if the first argument is 1. 57 | -- 58 | -- >>> printf "%d minute%s remaining" n (pluralS n) 59 | pluralS :: (Eq a, Num a) => a -> String 60 | pluralS 1 = "" 61 | pluralS _ = "s" 62 | 63 | 64 | 65 | -- | Merges two lists by alternatingly taking one element of each. Overflow is 66 | -- appended as bulk. 67 | -- 68 | -- > mergeLists [a,b] [w,x,y,z] == [a,w,b,x,y,z] 69 | mergeLists :: [a] -> [a] -> [a] 70 | mergeLists [] ys = ys 71 | mergeLists (x:xs) ys = x : mergeLists ys xs 72 | 73 | 74 | 75 | -- | 'T.Text' version of 'show'. 76 | showT :: Show a => a -> T.Text 77 | showT = T.pack . show 78 | 79 | 80 | 81 | -- | Reasonably accurate version of an integer square root, used to model 82 | -- diminishing returns for small values (e.g. neighbour counts). 83 | -- 84 | -- This function is total, and returns 0 for inputs smaller than zero. 85 | iSqrt :: Integral int => int -> int 86 | iSqrt n = round (sqrt (max 0 (fromIntegral n :: Double))) -------------------------------------------------------------------------------- /src/Config/AddressParser.hs: -------------------------------------------------------------------------------- 1 | -- | Parses a string of the form @123.123.123.123:54321@ to a 'To'. 2 | 3 | -- TODO: Allow arbitrary hostnames, in particular IPv6 and DNS 4 | 5 | {-# LANGUAGE MultiWayIf #-} 6 | {-# LANGUAGE TupleSections #-} 7 | {-# OPTIONS_HADDOCK show-extensions #-} 8 | 9 | module Config.AddressParser (parseAddress) where 10 | 11 | import Text.Parsec hiding (many, (<|>)) 12 | import Text.Parsec.String 13 | import qualified Text.Parsec.Token as P 14 | import Text.Parsec.Language (haskellDef) 15 | import Control.Applicative 16 | import Control.Monad 17 | import Control.Monad.Identity 18 | import Text.Printf 19 | 20 | import Types 21 | 22 | 23 | 24 | -- | Haskell grammar based lexer. 25 | lexer :: P.GenTokenParser String u Identity 26 | lexer = P.makeTokenParser haskellDef 27 | 28 | 29 | -- | General 'Int' parser. 30 | intP :: Parser Int 31 | intP = fromIntegral <$> P.integer lexer 32 | 33 | 34 | 35 | -- | Parse an Int between 0 and 2^16-1 = 65536 (inclusive). 36 | portP :: Parser Int 37 | portP = do p <- intP 38 | let minPort = 0 39 | maxPort = 2^(16::Int)-1 40 | if | p < minPort -> parserFail "Port < 0" 41 | | p > maxPort -> parserFail "Port > 65535" 42 | | otherwise -> return p 43 | 44 | 45 | 46 | -- | Parser for an IPv4 address. 47 | ipv4P :: Parser (Int, Int, Int, Int) 48 | ipv4P = (,,,) <$> ipv4NumberP <* dot 49 | <*> ipv4NumberP <* dot 50 | <*> ipv4NumberP <* dot 51 | <*> ipv4NumberP 52 | 53 | 54 | 55 | -- | Discard a literal \".\" 56 | dot :: Parser () 57 | dot = void (char '.') 58 | 59 | 60 | 61 | -- | Discard a literal \":\" 62 | colon :: Parser () 63 | colon = void (char ':') 64 | 65 | 66 | 67 | -- | Parse an Int between 0 and 255 (inclusive). 68 | ipv4NumberP :: Parser Int 69 | ipv4NumberP = do p <- intP 70 | if | p < 0 -> parserFail "IPv4 part < 0" 71 | | p > 255 -> parserFail "IPv4 part > 255" 72 | | otherwise -> return p 73 | 74 | 75 | -- | Parser for "To" data. 76 | toP :: Parser To 77 | toP = try toP' errMsg where 78 | toP' = do (a,b,c,d) <- ipv4P 79 | let host = printf "%d.%d.%d.%d" a b c d 80 | colon 81 | port <- portP 82 | return (To (Node host port)) 83 | errMsg = "IPv4+port address of the form 127.0.0.1:12345" 84 | 85 | 86 | 87 | parseAddress :: String -> Either ParseError To 88 | parseAddress = parse toP "" -------------------------------------------------------------------------------- /src/Utilities/IOQueue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# OPTIONS_HADDOCK show-extensions #-} 3 | 4 | module Utilities.IOQueue ( 5 | IOQueue(..) 6 | , OutMsg(..) 7 | , outputThread 8 | ) where 9 | 10 | import Control.Concurrent.Async 11 | import Control.Concurrent.STM 12 | import Control.Monad 13 | import System.IO 14 | 15 | 16 | -- | Wrapper around the queue to the output thread 17 | newtype IOQueue = IOQueue { _ioQueue :: TBQueue OutMsg } 18 | 19 | -- | Used to send a message to the terminal via 'IOQueue's. 20 | data OutMsg = STDOUT String 21 | | STDERR String 22 | | STDLOG String 23 | 24 | -- | Set up the decicated IO thread. Forks said thread, and returns a "TBQueue" 25 | -- to it, along with the "ThreadId" of the thread (which may be useful for 26 | -- killing it). 27 | -- 28 | -- Sends messages tagged as 'STDOUT' to stdout, 29 | -- 'STDERR' to stderr, and 30 | -- 'STDLOG' to stderr. 31 | -- 32 | -- Note: This does not change the buffering behaviour of STDERR, which is 33 | -- unbuffered by default. 34 | outputThread :: Int -- ^ Number of actions that can be queued 35 | -> IO ( IOQueue -- Channel 36 | , Async () -- Thread ID of the spawned printer thread 37 | ) -- ^ See source for doc 38 | outputThread size = do 39 | checkOutputBuffers 40 | q <- newTBQueueIO size 41 | thread <- async (dispatchSignals q) 42 | return (IOQueue q, thread) 43 | 44 | where dispatchSignals q = forever $ atomically (readTBQueue q) >>= \case 45 | STDOUT s -> hPutStrLn stdout s 46 | STDERR s -> hPutStrLn stderr s 47 | STDLOG s -> hPutStrLn stderr s 48 | 49 | 50 | 51 | -- | Check whether the output buffers are set properly, i.e. are buffered. 52 | checkOutputBuffers :: IO () 53 | checkOutputBuffers = do 54 | 55 | hGetBuffering stdout >>= \case 56 | NoBuffering -> err "STDOUT" 57 | _else -> return () 58 | 59 | hGetBuffering stderr >>= \case 60 | NoBuffering -> err "STDERR" 61 | _else -> return () 62 | 63 | where 64 | 65 | err buffer = hPutStr stderr (buffer ++ " unbuffered! You may want to\ 66 | \ change it to buffered for performance\ 67 | \ reasons (e.g. using \ 68 | \ Utilities.prepareOutputBuffers).") -------------------------------------------------------------------------------- /src/Config/Getter.hs: -------------------------------------------------------------------------------- 1 | -- | (Only) API to read configurations from all available sources. Intended as 2 | -- a qualified import, e.g. as \"Config\". 3 | -- 4 | -- Throws an exception on failure (which hopefully crashes the program unless 5 | -- I get the glorious idea of a catchall for some reason). 6 | 7 | {-# LANGUAGE OverloadedStrings #-} 8 | 9 | module Config.Getter ( 10 | node 11 | , bootstrap 12 | , drawing 13 | , multi 14 | ) where 15 | 16 | import qualified Data.Traversable as T 17 | import Data.Monoid 18 | import Control.Monad 19 | import qualified Data.Text as Text 20 | import qualified Data.Text.IO as Text 21 | 22 | import Control.Lens.Operators 23 | import qualified Types.Lens as L 24 | 25 | import qualified Config.ConfigFile as File 26 | import qualified Config.CmdArgParser as CmdArg 27 | import qualified Config.Default as Default 28 | import qualified Config.Verify as Verify 29 | import Config.OptionModifier 30 | import Types 31 | 32 | 33 | 34 | runModifier :: config -- ^ Default config 35 | -> [IO (OptionModifier config)] -- ^ List of modifiers 36 | -> IO config 37 | runModifier defaultConfig ioMods = do 38 | mods <- (fmap mconcat . T.sequenceA) ioMods 39 | return (applyOptionModifier mods defaultConfig) 40 | 41 | 42 | 43 | node :: IO NodeConfig 44 | node = do let mods = [ File.nodeModifier, CmdArg.nodeModifier ] 45 | cfg <- runModifier Default.nodeConfig mods 46 | Verify.node cfg 47 | printIfVerbose cfg cfg 48 | return cfg 49 | 50 | 51 | 52 | bootstrap :: IO BootstrapConfig 53 | bootstrap = do let mods = [ File.bootstrapModifier, CmdArg.bootstrapModifier ] 54 | cfg <- runModifier Default.bootstrapConfig mods 55 | Verify.bootstrap cfg 56 | printIfVerbose (cfg ^. L.nodeConfig) cfg 57 | return cfg 58 | 59 | 60 | 61 | drawing :: IO DrawingConfig 62 | drawing = do let mods = [ File.drawingModifier, CmdArg.drawingModifier ] 63 | cfg <- runModifier Default.drawingConfig mods 64 | Verify.drawing cfg 65 | printIfVerbose (cfg ^. L.nodeConfig) cfg 66 | return cfg 67 | 68 | 69 | 70 | multi :: IO MultiConfig 71 | multi = do let mods = [ File.multiModifier, CmdArg.multiModifier ] 72 | cfg <- runModifier Default.multiConfig mods 73 | Verify.multi cfg 74 | printIfVerbose (cfg ^. L.nodeConfig) cfg 75 | return cfg 76 | 77 | 78 | -- | Print a configuration if the predicate is met. 79 | printIfVerbose :: PrettyShow config => NodeConfig -> config -> IO () 80 | printIfVerbose nodeCfg cfg = 81 | when (nodeCfg ^. L.verbosity >= Debug) 82 | (Text.putStrLn (Text.unlines 83 | [ "\ESC[31m### Configuration: #############\ESC[0m" 84 | , pretty cfg 85 | , "\ESC[31m##################################\ESC[0m" 86 | ])) -------------------------------------------------------------------------------- /src/Node.hs: -------------------------------------------------------------------------------- 1 | -- | A node is a single participant in an Amoeba network. 2 | 3 | module Node (startNode) where 4 | 5 | 6 | 7 | import Control.Applicative 8 | import Control.Concurrent.Async 9 | import Control.Concurrent.STM 10 | import Control.Exception (assert) 11 | import qualified Data.Map as Map 12 | import qualified Data.Set as Set 13 | import Text.Printf 14 | 15 | import qualified Pipes.Concurrent as P 16 | 17 | import qualified Network.Socket as NS 18 | import qualified Pipes.Network.TCP as PN 19 | 20 | import Bootstrap 21 | import ClientPool 22 | import Server 23 | import Types 24 | import Utilities 25 | 26 | 27 | 28 | -- | Node main function. Bootstraps, launches server loop, client pool, 29 | -- IO thread. 30 | startNode :: Maybe (PChan NormalSignal) -- ^ Local direct connection (LDC) 31 | -> IOQueue -- ^ Channel to output thread 32 | -> NodeConfig 33 | -> IO () 34 | startNode ldc output config = do 35 | 36 | let port = _serverPort config 37 | 38 | PN.listen (PN.Host "127.0.0.1") (show port) $ \(socket, addr) -> do 39 | 40 | (selfHost, selfPort) <- getSelfInfo addr 41 | assert (port == read selfPort) 42 | (return ()) 43 | let self = To (Node selfHost port) 44 | 45 | bootstrap config self 46 | 47 | env <- initEnvironment self ldc output config 48 | 49 | yell 32 $ "Node server listening on " ++ show self 50 | withAsync (server env socket) $ \serverThread -> 51 | withAsync (clientPool env) $ \_ -> 52 | wait serverThread 53 | 54 | 55 | 56 | -- | Retrieve own server address 57 | getSelfInfo :: PN.SockAddr -> IO (PN.HostName, PN.ServiceName) 58 | getSelfInfo addr = fromJust' <$> NS.getNameInfo flags True True addr 59 | where flags = [ NS.NI_NUMERICHOST -- "IP address, not DNS" 60 | , NS.NI_NUMERICSERV -- "Port as a number please" 61 | ] 62 | fromJust' (Just x, Just y) = (x,y) 63 | fromJust' (x, y) = 64 | let msg = "Address lookup failed! This is a bug.\ 65 | \ (Host: %s, Port: %s)" 66 | in error (printf msg (show x) (show y)) 67 | 68 | 69 | 70 | -- | Initializes node environment by setting up the communication channels etc. 71 | initEnvironment :: To -- ^ Own address 72 | -> Maybe (PChan NormalSignal) -- ^ Local direct connection 73 | -> IOQueue -- ^ Channel to output thread 74 | -> NodeConfig 75 | -> IO Environment 76 | initEnvironment node ldc output config = Environment 77 | 78 | <$> newTVarIO Map.empty -- Known nodes 79 | <*> newTVarIO Set.empty -- Nodes known by 80 | <*> spawn buffer -- Channel read by all clients 81 | <*> pure output -- Channel to the IO thread 82 | <*> newTVarIO Set.empty -- Previously handled queries 83 | <*> pure node -- Own server's address 84 | <*> pure ldc -- (Maybe) local direct connection 85 | <*> pure config 86 | 87 | where size = _maxChanSize config 88 | buffer = P.Bounded size 89 | 90 | 91 | 92 | 93 | 94 | -------------------------------------------------------------------------------- /src/Config/Verify.hs: -------------------------------------------------------------------------------- 1 | -- | Verifies whether the invariants of a configuration are satisfied, in order 2 | -- to avoid nonsense program behaviour because of human error. 3 | -- 4 | -- This module is intended to be used qualified, e.g. as \"Verify\" to 5 | -- make nice names such as \"Verify.'nodeArgs'\". 6 | 7 | {-# LANGUAGE DeriveDataTypeable #-} 8 | {-# LANGUAGE FlexibleContexts #-} 9 | {-# OPTIONS_HADDOCK show-extensions #-} 10 | 11 | module Config.Verify ( 12 | node 13 | , multi 14 | , bootstrap 15 | , drawing 16 | ) where 17 | 18 | 19 | import Control.Exception 20 | import Data.Typeable 21 | import Control.Monad 22 | 23 | import qualified Control.Lens as L 24 | import Control.Lens.Operators 25 | import qualified Types.Lens as L 26 | 27 | import Types.Config 28 | 29 | 30 | 31 | 32 | data ConfigError = PortRange 33 | | TickRates 34 | | PoolTimeout 35 | | PoolSize 36 | | RestartEvery 37 | deriving (Show, Typeable) 38 | 39 | instance Exception ConfigError 40 | 41 | 42 | 43 | -- | Verify integrity of a 'NodeConfig'. 44 | node :: NodeConfig -> IO () 45 | node config = sequence_ [portRange, tickRates, poolTimeout, poolSize] 46 | 47 | where 48 | -- Is the server port in range? 49 | portRange = unless (inRange minPort maxPort p) (throwIO PortRange) 50 | where p = config ^. L.serverPort 51 | minPort = 0 52 | maxPort = 2^(16 :: Int) - 1 53 | inRange a b x = 54 | let (lo,hi) = (min a b, max a b) 55 | in x >= lo && x <= hi 56 | 57 | -- Are the tickrates in the right order? 58 | -- (small <= medium <= long) 59 | tickRates = unless (isSorted rates) (throwIO TickRates) 60 | where rates = map (config ^.) [ L.shortTickRate 61 | , L.mediumTickRate 62 | , L.longTickRate 63 | ] 64 | isSorted xs = and (zipWith (<=) xs (tail xs)) 65 | -- TODO: Test ^ 66 | 67 | -- Timeouts must be longer than the long tickrate (and should be so 68 | -- by a factor of about 3, nyquist etc.) 69 | poolTimeout = when (ltr > tout) (throwIO PoolTimeout) 70 | where ltr = config ^. L.longTickRate 71 | tout = config ^. L.poolTimeout 72 | 73 | -- minimum <= maximum neighbours 74 | poolSize = when (minN > maxN) (throwIO PoolSize) 75 | where minN = config ^. L.minNeighbours 76 | maxN = config ^. L.maxNeighbours 77 | 78 | 79 | 80 | -- | Verify integrity of a configuration that contains a 'NodeConfig'. 81 | containedNode :: L.HasNodeConfig nodeConfig NodeConfig 82 | => nodeConfig 83 | -> IO () 84 | containedNode = node . L.view L.nodeConfig 85 | 86 | 87 | 88 | -- | Verify integrity of a 'MultiConfig'. 89 | multi :: MultiConfig -> IO () 90 | multi = containedNode 91 | 92 | 93 | 94 | -- | Verify integrity of a 'BootstrapConfig'. 95 | bootstrap :: BootstrapConfig -> IO () 96 | bootstrap = containedNode 97 | 98 | 99 | 100 | -- | Verify integrity of a 'DrawingConfig'. 101 | drawing :: DrawingConfig -> IO () 102 | drawing = containedNode -------------------------------------------------------------------------------- /src/Utilities/Concurrency.hs: -------------------------------------------------------------------------------- 1 | -- | Functions for working with the concurrent parts of the program. 2 | 3 | module Utilities.Concurrency ( 4 | 5 | -- * General concurrency 6 | toIO 7 | , toIO' 8 | , prepareOutputBuffers 9 | , delay 10 | , timeout 11 | 12 | -- * Termination triggers 13 | , newTerminationTrigger 14 | , waitForTrigger 15 | , runTrigger 16 | , TerminationTrigger 17 | 18 | -- * Pipe-based communication channels 19 | , spawn 20 | , outputThread 21 | ) where 22 | 23 | 24 | import Control.Monad.Trans 25 | import Control.Concurrent hiding (yield) 26 | import Control.Concurrent.STM 27 | import Control.Monad 28 | import Data.Functor 29 | import System.IO 30 | import qualified System.Timeout 31 | 32 | 33 | import qualified Pipes.Concurrent as P 34 | 35 | -- import qualified Control.Lens as L 36 | import Control.Lens.Operators 37 | import qualified Types.Lens as L 38 | 39 | import Types 40 | import Utilities.IOQueue 41 | 42 | 43 | 44 | 45 | -- | Send a message depending on the verbosity level. 46 | toIO :: Environment 47 | -> Verbosity 48 | -> OutMsg 49 | -> STM () 50 | toIO env verbosity msg = when p (writeTBQueue (env ^. L.io . L.ioQueue) 51 | msg) 52 | where p = verbosity >= env ^. L.config . L.verbosity 53 | 54 | 55 | 56 | -- | Send a message to an "IOQueue" directly (ignoring verbosity). 57 | toIO' :: IOQueue 58 | -> OutMsg 59 | -> IO () 60 | toIO' ioq msg = atomically (writeTBQueue (ioq ^. L.ioQueue) msg) 61 | 62 | 63 | 64 | -- | Identical to 'P.spawn'', but uses the typesfe 'PChan' type instead of 65 | -- @(,,)@. 66 | spawn :: P.Buffer a -> IO (PChan a) 67 | spawn buffer = toPChan <$> P.spawn' buffer 68 | where toPChan (output, input, seal) = PChan output input seal 69 | 70 | 71 | 72 | -- | Used by the client pool. When the 'MVar' contained is filled, an arbitrary 73 | -- node will be terminated. 74 | newtype TerminationTrigger = TerminationTrigger (MVar ()) 75 | 76 | 77 | 78 | -- | Create a new termination trigger. 79 | newTerminationTrigger :: IO TerminationTrigger 80 | newTerminationTrigger = fmap TerminationTrigger newEmptyMVar 81 | 82 | 83 | 84 | -- | Blocks until the trigger is triggered. 85 | waitForTrigger :: TerminationTrigger -> IO () 86 | waitForTrigger (TerminationTrigger mVar) = takeMVar mVar 87 | 88 | 89 | 90 | -- | Tries to trigger the termination trigger. Does nothing if it's currently 91 | -- already triggered. 92 | runTrigger :: TerminationTrigger -> IO () 93 | runTrigger (TerminationTrigger mVar) = void (tryPutMVar mVar ()) 94 | 95 | 96 | 97 | -- | Prepares the output buffers for logging text by making them line-buffered. 98 | -- 99 | -- (STDERR in particular is unbuffered by default.) 100 | prepareOutputBuffers :: IO () 101 | prepareOutputBuffers = do hSetBuffering stdout LineBuffering 102 | hSetBuffering stderr LineBuffering 103 | 104 | 105 | 106 | -- | Convert 'Integer' to 'Int', truncating if the input it too large. 107 | maxBounded :: Integer -> Int 108 | maxBounded x | x > fromIntegral maxInt = maxInt 109 | | otherwise = fromIntegral x 110 | where maxInt = maxBound 111 | 112 | 113 | 114 | -- | 'MonadIO' version of 'threadDelay'. Wait for a maximum of 115 | -- @'maxBound' :: Int@ seconds, and truncates larger input. 116 | delay :: MonadIO io => Microseconds -> io () 117 | delay (Microseconds us) = liftIO (threadDelay t) 118 | where t = maxBounded us 119 | 120 | 121 | 122 | -- | 'System.IO.timeout' working with 'Microseconds'. Timeouts larger than 123 | -- @'maxBound' :: Int@ will be truncated. 124 | timeout :: Microseconds -> IO a -> IO (Maybe a) 125 | timeout (Microseconds us) action = System.Timeout.timeout t action 126 | where t = maxBounded us -------------------------------------------------------------------------------- /src/Housekeeping.hs: -------------------------------------------------------------------------------- 1 | -- | Watch the databases and clean up dead or orphaned entries. 2 | 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# OPTIONS_HADDOCK show-extensions #-} 5 | 6 | module Housekeeping (dsnHousekeeping) where 7 | 8 | import Control.Concurrent.Async 9 | import Control.Concurrent.STM hiding (check) 10 | import qualified Data.Foldable as F 11 | import Control.Monad 12 | import qualified Data.Map as Map 13 | import Data.Maybe 14 | import qualified Data.Traversable as T 15 | 16 | import qualified Pipes.Concurrent as P 17 | 18 | import Control.Lens.Operators 19 | import qualified Control.Lens as L 20 | import qualified Types.Lens as L 21 | 22 | import Types 23 | import Utilities 24 | 25 | 26 | 27 | 28 | 29 | -- | Housekeeping of the downstream node database. Makes sure other nodes know 30 | -- this node is still running and has them as its neighbour, removes dead 31 | -- DSNs. 32 | dsnHousekeeping :: Environment -> IO () 33 | dsnHousekeeping env = forever $ do 34 | t <- makeTimestamp 35 | removeTimedOutDsn env t 36 | removeTerminatedDsn env 37 | prune env 38 | sendKeepAlive env t 39 | delay (env ^. L.config . L.mediumTickRate) 40 | 41 | 42 | 43 | -- | Remove timed out nodes from the DSN DB. 44 | removeTimedOutDsn :: Environment 45 | -> Timestamp 46 | -> IO () 47 | removeTimedOutDsn env (Timestamp now) = do 48 | 49 | let dsnDB = env ^. L.downstream 50 | dsns <- atomically (readTVar dsnDB) 51 | 52 | let (kill, keep) = Map.partition isTimedOut dsns 53 | F.for_ kill (^! L.clientAsync . L.act cancel) 54 | atomically (writeTVar dsnDB keep) 55 | 56 | unless (Map.null kill) $ atomically $ toIO env Debug $ 57 | STDLOG "Downstream neighbour housekilled. This is likely a bug, as\ 58 | \ clients should clean themselves up after termination." 59 | -- TODO: Verify this claim 60 | 61 | where 62 | 63 | isTimedOut client = 64 | let Timestamp clientTimestamp = client ^. L.clientTimestamp 65 | threshold = env ^. L.config . L.poolTimeout 66 | in now - clientTimestamp > threshold 67 | 68 | 69 | 70 | -- | Remove nodes whose threads have terminated from the DSB DB. 71 | removeTerminatedDsn :: Environment -> IO () 72 | removeTerminatedDsn env = do 73 | 74 | let dsnDB = env ^. L.downstream 75 | dsns <- atomically (readTVar dsnDB) 76 | 77 | polledClients <- T.traverse (poll . L.view L.clientAsync) dsns 78 | let deadNodes = Map.filter isDead polledClients 79 | isDead = isJust 80 | 81 | atomically $ modifyTVar dsnDB (`Map.difference` deadNodes) 82 | 83 | unless (Map.null deadNodes) $ 84 | atomically . toIO env Debug $ 85 | STDLOG "Client housekilled. This may be a bug\ 86 | \ (client should cleanup itself)." 87 | -- TODO: Verify this claim 88 | 89 | 90 | 91 | -- | If the DSN pool is larger than the minimum amount of neighbours, ask 92 | -- random DSNs whether the connection can be dropped. 93 | -- 94 | -- (The amount of DSNs contacted is equivalent to the excess of connections.) 95 | prune :: Environment -> IO () 96 | prune env = atomically $ do 97 | usnSize <- usnDBSize env 98 | let minN = env ^. L.config . L.minNeighbours 99 | excess = usnSize - minN 100 | prunes = iSqrt 101 | F.for_ [1..prunes excess] 102 | (\_i -> P.send (env ^. L.st1c . L.pOutput) 103 | Prune) 104 | 105 | 106 | 107 | -- | Send 'KeepAlive' signals to downstream nodes (DSNs) so they can update 108 | -- their "last heard of" timestamp 109 | sendKeepAlive :: Environment -> Timestamp -> IO () 110 | sendKeepAlive env (Timestamp now) = do 111 | 112 | -- Get a map of all registered downstream clients 113 | clients <- atomically (readTVar (env ^. L.downstream)) 114 | 115 | -- Find out which ones haven't been contacted in a while 116 | let needKeepAlive = Map.filter needsRefreshing clients 117 | 118 | F.for_ needKeepAlive sendSignal 119 | 120 | where 121 | 122 | lastHeard client = let Timestamp t = client ^. L.clientTimestamp 123 | in now - t 124 | threshold = env ^. L.config . L.poolTimeout . L.to (`quot` 4) -- TODO: make the factor an option 125 | needsRefreshing client = lastHeard client >= threshold 126 | sendSignal node = atomically (P.send (node ^. L.stsc . L.pOutput) 127 | KeepAlive) 128 | -------------------------------------------------------------------------------- /src/NodePool.hs: -------------------------------------------------------------------------------- 1 | -- | Maintains a number of completely independent nodes, and allows sending 2 | -- signals to them easily. 3 | -- 4 | -- Useful to add certain services to the network without requiring them to 5 | -- manage their own connections. For example, a bootstrap server can use a 6 | -- node pool to always keep up a certain amount of trusted nodes in the 7 | -- network that it can use to help other nodes make an initial connection. 8 | 9 | module NodePool (nodePool) where 10 | 11 | 12 | 13 | import Control.Concurrent.Async 14 | import Control.Concurrent.Chan 15 | import Control.Exception 16 | import Control.Monad 17 | import qualified Data.Traversable as T 18 | 19 | import Pipes 20 | import qualified Pipes.Concurrent as P 21 | 22 | import Control.Lens.Operators 23 | -- import qualified Control.Lens as L 24 | import qualified Types.Lens as L 25 | 26 | import Node 27 | import Types 28 | import Utilities 29 | 30 | 31 | 32 | -- | Start a node pool of a certain size, and provide a channel to 33 | -- communitcate with (random nodes in) it. Forks multiple nodes with 34 | -- intermediate delays, and returns their threads. 35 | nodePool :: Int -- ^ Number of nodes in the pool (also the port range) 36 | -> NodeConfig -- ^ Configuration for a single node. Of particular 37 | -- importance is the port (nodes will be spawned 38 | -- in the range [port+1, port+range]). 39 | -> Chan NormalSignal 40 | -- ^ Local direct connection to one node (taking 41 | -- turns). 'Chan' instead of 'TQueue' because of the 42 | -- lack of fairness in STM. 43 | -> IOQueue -- ^ Channel to output thread 44 | -> Maybe TerminationTrigger 45 | -- ^ If the 'MVar' contained in the 'TerminationTrigger' is 46 | -- filled, a node is killed (and a new one is started by 47 | -- its janitor). 48 | -> IO [Async ()] -- ^ Janitor threads (for cancellation when 49 | -- encapsulated in larger programs) 50 | nodePool n config ldc output m'terminate = 51 | T.for [1..n] $ \portOffset -> do 52 | -- Give nodes in the pool consecutive numbers, starting with 53 | -- + 1 54 | jThread <- async (janitor (config & L.serverPort +~ portOffset) 55 | ldc 56 | output 57 | m'terminate) 58 | delay (config ^. L.mediumTickRate) 59 | return jThread 60 | 61 | 62 | 63 | -- | Spawn a new node, restart it should it crash, and listen for signals 64 | -- sent to it. 65 | -- 66 | -- The termination parameter is useful to make the pool replace old nodes, for 67 | -- example the initial bootstrap nodes are very interconnected, which is not 68 | -- desirable. Restarting these nodes when there's an actual network leads to 69 | -- more natural neighbourships. 70 | janitor :: NodeConfig 71 | -> Chan NormalSignal -- ^ Local direct connection 72 | -> IOQueue -- ^ Channel to output thread 73 | -> Maybe TerminationTrigger 74 | -> IO () 75 | janitor config fromPool output m'terminate = yellCatchall . forever $ do 76 | toNode <- spawn (P.Bounded (config ^. L.maxChanSize)) 77 | (`catches` handlers) $ 78 | withAsync (startNode (Just toNode) output config) $ \node -> 79 | withAsync (fromPool `pipeTo` toNode) $ \_chanPipe -> 80 | case m'terminate of 81 | Just t -> withAsync (terminationWatch t node) (\_ -> wait node) 82 | Nothing -> wait node 83 | 84 | where 85 | handlers = [ Handler asyncException ] 86 | asyncException ThreadKilled = return () 87 | asyncException e = throwIO e 88 | yellCatchall = handle (\(SomeException e) -> 89 | yell 41 ("Janitor crashed! Exception: " ++ show e)) 90 | 91 | 92 | 93 | -- | Send everything from one channel to the other 94 | pipeTo :: Chan NormalSignal -- ^ From 95 | -> PChan NormalSignal -- ^ To 96 | -> IO () 97 | pipeTo input output = runEffect (fromChan input >-> P.toOutput toChan) where 98 | fromChan chan = forever (liftIO (readChan chan) >>= yield) 99 | toChan = output ^. L.pOutput 100 | 101 | 102 | 103 | -- | Terminate a thread when the MVar is filled, and block until this happens. 104 | terminationWatch :: TerminationTrigger -> Async () -> IO () 105 | terminationWatch trigger thread = do waitForTrigger trigger 106 | cancel thread 107 | -------------------------------------------------------------------------------- /src/Bootstrap.hs: -------------------------------------------------------------------------------- 1 | -- | Provides functions for the client to connect to a Bootstrap server in order 2 | -- to make the initial connection to the network. 3 | 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE DeriveDataTypeable #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# OPTIONS_HADDOCK show-extensions #-} 9 | 10 | module Bootstrap (bootstrap) where 11 | 12 | 13 | 14 | import Control.Concurrent.Async 15 | import Control.Exception 16 | import Control.Monad 17 | import Data.Monoid 18 | import qualified Data.Set as Set 19 | import Data.Typeable 20 | import GHC.IO.Exception (ioe_description) 21 | import System.Random 22 | 23 | import qualified Data.Text as T 24 | import qualified Data.Text.IO as T 25 | 26 | import Control.Lens.Operators 27 | import qualified Control.Lens as L 28 | import qualified Types.Lens as L 29 | 30 | import Types 31 | import Utilities 32 | 33 | 34 | 35 | data BootstrapError = BadResponse 36 | | NoResponse 37 | deriving (Typeable) 38 | 39 | instance Show BootstrapError where 40 | show BadResponse = "Bad response" 41 | show NoResponse = "No response" 42 | 43 | instance Exception BootstrapError 44 | 45 | 46 | 47 | -- | Send '_maxNeighbours' 'BootstrapRequest's to bootstrap servers, and repeat 48 | -- the process until each neighbour has issued one successful one. 49 | bootstrap :: NodeConfig 50 | -> To -- Own address so other nodes can connect 51 | -> IO () 52 | bootstrap config self = do T.putStrLn "Starting bootstrap" 53 | _ <- mapConcurrently (const dispatch) [1..maxN] 54 | T.putStrLn "Bootstrap finished" 55 | 56 | where 57 | 58 | maxN = config ^. L.maxNeighbours 59 | 60 | retryBootstrap = delay (config ^. L.longTickRate) >> dispatch 61 | 62 | dispatch = do 63 | 64 | bsServer <- getBootstrapServer config 65 | 66 | let catchMulti action = catches action [ bootstrapErrorH 67 | , ioExceptionH 68 | ] 69 | 70 | bootstrapErrorH = Handler $ \case 71 | BadResponse -> do 72 | T.putStrLn (T.unwords 73 | [ "Bad response from bootstrap server" 74 | , showBss <> "." 75 | , "This is a bug This is a bug if the server" 76 | , "is actually a bootstrap server." 77 | ]) 78 | retryBootstrap 79 | NoResponse -> do 80 | T.putStrLn (T.unwords 81 | [ "No response from bootstrap server" 82 | , showBss 83 | , "(although it is online)." 84 | , "This is a bug if the server actually is" 85 | , "a bootstrap server." 86 | ]) 87 | retryBootstrap 88 | 89 | ioExceptionH = Handler $ \(e :: IOException) -> do 90 | T.putStrLn (T.unwords 91 | [ "Could not connect to bootstrap server" 92 | , showBss 93 | , "(" <> T.pack (ioe_description e) <> ")." 94 | , "Is it online?" 95 | ]) 96 | retryBootstrap 97 | 98 | showBss :: T.Text 99 | showBss = let To (Node h p) = bsServer 100 | in T.pack h <> ":" <> showT p 101 | 102 | tout = config ^. L.poolTimeout 103 | 104 | catchMulti (connectToNode bsServer (\(s, _) -> 105 | request tout s (BootstrapRequest self) >>= \case 106 | Just OK -> return () 107 | Just _ -> throwIO BadResponse 108 | Nothing -> throwIO NoResponse)) 109 | 110 | 111 | 112 | -- | Find the address of a suitable bootstrap server. 113 | -- TODO: Make bootstrap server selection a little more complex :-) 114 | getBootstrapServer :: NodeConfig -> IO To 115 | getBootstrapServer = L.view (L.bootstrapServers . L.to randomSetElement) 116 | -- Fallback entry: return (To (Node "127.0.0.1" 20000)) 117 | 118 | 119 | 120 | randomSetElement :: Set.Set a -> IO a 121 | randomSetElement set = do 122 | when (Set.null set) (error "No bootstrap servers known") -- TODO: This is beyond awful 123 | fmap (\i -> Set.elemAt i set) 124 | (randomRIO (0, Set.size set - 1)) 125 | -------------------------------------------------------------------------------- /amoeba.cfg.sample: -------------------------------------------------------------------------------- 1 | # Amoeba configuration file. 2 | # Works well with Python syntax highlighting. 3 | 4 | 5 | 6 | 7 | ################################################################################ 8 | ##### General node ########################################################### 9 | ################################################################################ 10 | 11 | ## Common settings 12 | 13 | # The server port is where the node is going to listen for incoming data. 14 | # For pool-based network services (bootstrap server etc) it is the start of the 15 | # port range to be used for all the clients. 16 | serverPort = 21000 17 | 18 | 19 | # Minimum/maximum number of neighbours a client may have in each direction. 20 | # A client will attempt to get a minimum of neighbours on its own, accept more 21 | # neighbours after that to help other nodes, but reject new requests once it is 22 | # over the maximum threshold. 23 | minNeighbours = 5 24 | maxNeighbours = 10 25 | 26 | 27 | # Amount of output generated. Possible settings: 28 | # "mute": Messages only when the house is burning down 29 | # "quiet": Only the most pressing messages 30 | # "default": Messages useful for operation as an ordinary clinet 31 | # "debug": Include messages about important events and values 32 | # "chatty": Even minor events generate notices 33 | verbosity = "debug" # Don't forget the quotes! 34 | 35 | 36 | # Bootstrap servers to make an initial connection to the network. 37 | # Can be either a single entry or a list of entries, e.g. 38 | # 39 | # bootstrapServers = "127.0.0.1:20000" 40 | # bootstrapServers = [ "127.0.0.1:20000","127.0.0.2:12345" ] 41 | # (Quotes are important!) 42 | # 43 | # Note that this is overwritten (and not appended) when there are multiple 44 | # configuration files in multiple locations. 45 | bootstrapServers = "127.0.0.1:20000" 46 | 47 | 48 | 49 | ## Rarely used settings 50 | 51 | 52 | # Maximum number of elements in the internal communication channels. Provides 53 | # a buffer with an upper memory bound. On the order of neighbours^2 should be 54 | # plenty. 55 | maxChanSize = 100 56 | 57 | 58 | # Number of times an edge request is guaranteed to bounce throug the network 59 | # before entering the probabilistic acceptance phase. 60 | # 61 | # Ideally, this, combined with the expected travel length given by acceptP 62 | # below, should be around the expected network diameter. 63 | hardBounces = 3 64 | 65 | 66 | # Chance an edge request is accepted, given that it is in probabilistic 67 | # acceptance phase. To avoid indefinite bouncing there is a hard cutoff on the 68 | # number of these events. 69 | acceptP = 0.5 70 | maxSoftBounces = 10 71 | 72 | 73 | # Period length of various internal loops. 74 | # Unit: Int of microseconds 75 | shortTickRate = 1e5 76 | mediumTickRate = 3e5 77 | longTickRate = 10e5 78 | 79 | 80 | # Time after which an Amoeba network connection is regarded as timed out, and 81 | # its worker/client is terminated. 82 | # Unit: Int of microseconds 83 | poolTimeout = 5e6 84 | 85 | 86 | # Number of past flood messages to store in order to avoid processing 87 | # duplicates. 88 | floodMessageCache = 1024 89 | 90 | 91 | 92 | ################################################################################ 93 | ##### Special services ####################################################### 94 | ################################################################################ 95 | 96 | # Each of the {} blocks below allow all the options given above in them, with 97 | # higher priority. 98 | 99 | 100 | 101 | # Number of nodes to have. 102 | poolSize = 10 103 | 104 | 105 | 106 | # Multi-node client 107 | multi { 108 | } 109 | 110 | 111 | 112 | # Bootstrap server 113 | bootstrap { 114 | 115 | serverPort = 20000 116 | 117 | # Restart a node in the node pool once every N bootstrap requests. This 118 | # is supposed to break up high interconnectedness in the bootstrap pool. 119 | # (One new node sends out maxNeighbours bootstrap requests, so pick 120 | # this quantity on the order of maxNeighbours*10.) 121 | restartEvery = 50 122 | 123 | # Minimum amount of time to wait for a node restart. (To avoid restarting 124 | # the entire pool if a lot of nodes connect all of a sudden.) 125 | # Unit: Int of microseconds 126 | restartMinimumPeriod = 1e6 127 | 128 | } 129 | 130 | 131 | 132 | # Drawing server 133 | drawing { 134 | 135 | poolSize = 10 136 | 137 | # Send out requests and draw the currently known network periodically 138 | # Unit: Int of microseconds 139 | drawEvery = 10e6 140 | 141 | # Time after which a node times out after not sending new data to the 142 | # drawing server. Should be at least twice as large as the drawEvery 143 | # setting. 144 | # Unit: Int of microseconds 145 | drawTimeout = 33e6 146 | 147 | # Filename to save the network state under 148 | drawFilename = "network_graph.dot" 149 | 150 | } 151 | -------------------------------------------------------------------------------- /amoeba.cabal: -------------------------------------------------------------------------------- 1 | name: amoeba 2 | version: 0.0.0.201405061 3 | synopsis: Distributed network client and utilities to set it up and 4 | investigate its behaviour 5 | description: Amœba is a program for setting up a distributed network. 6 | The name comes from the hope that eventually, the network 7 | will be so robust that you can poke any of its parts 8 | without endangering its overall integrity. 9 | homepage: https://github.com/quchen/amoeba 10 | bug-reports: https://github.com/quchen/amoeba/issues 11 | license: PublicDomain 12 | license-file: LICENCE.md 13 | author: David Luposchainsky 14 | maintainer: David Luposchainsky 15 | category: Cloud, Distributed Computing, Network 16 | build-type: Simple 17 | cabal-version: >=1.20 18 | Stability: alpha 19 | Tested-With: GHC == 7.8.2 20 | extra-source-files: BRANCHING.md 21 | DIFFICULTIES.md 22 | LICENCE.md 23 | README.md 24 | doc/information_flow.dot 25 | doc/information_flow.png 26 | doc/network_example.png 27 | doc/network_schema.dot 28 | doc/network_schema.png 29 | 30 | source-repository head 31 | type: git 32 | location: https://github.com/quchen/amoeba 33 | 34 | 35 | 36 | library 37 | 38 | hs-source-dirs: src 39 | ghc-options: -O2 -W 40 | default-language: Haskell2010 41 | other-extensions: TemplateHaskell 42 | -- TH requires explicit mentioning in some cases, see 43 | -- https://ghc.haskell.org/trac/ghc/wiki/GHC-7.8-FAQ 44 | 45 | build-depends: async == 2.0.* 46 | , base == 4.7.* 47 | , binary == 0.7.* 48 | , bytestring == 0.10.* 49 | , configurator == 0.2.* 50 | , containers == 0.5.* 51 | , exceptions == 0.3.* 52 | , lens == 4.1.* 53 | , mtl == 2.1.* 54 | , network == 2.4.* 55 | , network-simple == 0.3.* 56 | , optparse-applicative == 0.7.* 57 | , parsec == 3.1.* 58 | , pipes == 4.1.* 59 | , pipes-binary == 0.4.* 60 | , pipes-concurrency == 2.0.* 61 | , pipes-network == 0.6.* 62 | , pipes-parse == 3.0.* 63 | , random == 1.0.* 64 | , stm == 2.4.* 65 | , text == 1.1.* 66 | , time == 1.4.* 67 | 68 | exposed-modules: Main.Bootstrap 69 | , Main.Drawing 70 | , Main.Multi 71 | , Main.Node 72 | 73 | other-modules: Bootstrap 74 | , Client 75 | , ClientPool 76 | , Config.AddressParser 77 | , Config.CmdArgParser 78 | , Config.ConfigFile 79 | , Config.Default 80 | , Config.Getter 81 | , Config.OptionModifier 82 | , Config.Verify 83 | , Housekeeping 84 | , Node 85 | , NodePool 86 | , Server 87 | , Types 88 | , Types.Config 89 | , Types.Lens 90 | , Types.Misc 91 | , Types.Signal 92 | , Utilities 93 | , Utilities.Concurrency 94 | , Utilities.Databases 95 | , Utilities.Debug 96 | , Utilities.IOQueue 97 | , Utilities.Networking 98 | , Utilities.Unsafe 99 | 100 | 101 | 102 | executable amoeba 103 | build-depends: amoeba, base 104 | default-language: Haskell2010 105 | main-is: src/Main/NodeExecutable.hs 106 | 107 | executable multi 108 | build-depends: amoeba, base 109 | default-language: Haskell2010 110 | main-is: src/Main/MultiExecutable.hs 111 | 112 | executable bootstrap 113 | build-depends: amoeba, base 114 | default-language: Haskell2010 115 | main-is: src/Main/BootstrapExecutable.hs 116 | 117 | executable drawing 118 | build-depends: amoeba, base 119 | default-language: Haskell2010 120 | main-is: src/Main/DrawingExecutable.hs 121 | -------------------------------------------------------------------------------- /DIFFICULTIES.md: -------------------------------------------------------------------------------- 1 | What's difficult about this project? 2 | ==================================== 3 | 4 | Every time I try to explain what's so hard about writing this network 5 | application, I don't really remember the difficulties with enough detail to 6 | explain them. 7 | 8 | 9 | 10 | 11 | Debugging is awful 12 | ------------------ 13 | 14 | Due to the nature of the network, a single client is mostly meaningless. This 15 | makes debugging hard: things cannot very easily be observed in isolation. 16 | 17 | 1. I had a case where I wanted to reduce communication between nodes to a 18 | minimum to filter out a bad signal (well-typed, but issued at the wrong time 19 | to an unsuspecting neighbour). The problem with disabling all other messages 20 | meant that nodes don't send keep-alive messages anymore, making downstream 21 | neighbours unable to detect whether their upstream partners were dead; the 22 | upstream contingent of nodes kept filling, until no new connections could be 23 | accepted. At this point the network structure breaks down, and the behaviour 24 | of the entire network is undefined. 25 | 26 | 2. A memory+socket+thread leak that took me months to fix seemed to form only 27 | after speeding up the bootstrap server by a factor of ten, and then letting 28 | it run for over ten minutes. Simple changes, along with running the program 29 | for ten minutes again to see their effects, often improved - but never 30 | fixed - the issue. There were many cases in which the development cycle was 31 | just excruciatingly long. 32 | 33 | 3. It is often not sufficient to identify one bug (by accident while reading the 34 | code again to my cat, for example) to fix the program: when multiple bugs 35 | come together, "fixing" one of them may not be enough to observably improve 36 | anything. After correcting something, this left me in odd situations: 37 | 38 | - Did I really fix the bug, or just change some code, potentially 39 | introducing new bugs that will bite me later? 40 | 41 | - The program didn't change; did I simply waste my time? 42 | 43 | - The code seems conceptually right to me now after the change; am I 44 | thinking about the whole thing the wrong way, now that it didn't help? 45 | 46 | - Should I roll back my change and try fixing something else instead, hoping 47 | to modify only small code pieces so I can pin down the error location? 48 | Yes? Work lost, potentially good fix lost. No? See previous points. 49 | 50 | 4. Getting good logs is next to impossible. Reading a single node's log is easy 51 | and clear, but does not show what other nodes thought when inducing this 52 | behaviour. Reading all logs at the same time produces a large amount of 53 | output in which it is very hard to tell cause, effect and correlation and 54 | random chance apart. 55 | 56 | 57 | 58 | 59 | 60 | Emergent properties 61 | ------------------- 62 | 63 | Although the individual rules of communication are simple, multiple nodes 64 | together develop what is known as emergent behaviour: complex patterns that are 65 | not obvious by merely looking at the rules the individual follows. An example of 66 | this are timing problems: when nodes don't time out fast enough, new connections 67 | may not be able to be formed in due time, leaving nodes orphaned sometimes. An 68 | orphan does not know of any neighbours, so it is lost; the only solution in this 69 | case is a full restart of the node (equivalent to killing and replacing it). 70 | 71 | 72 | 73 | 74 | 75 | Bootstrapping 76 | ------------- 77 | 78 | To create a network nodes have to connect to it in order to create a network 79 | nodes have to connect to it in order to create ... 80 | 81 | You get the gist. The current solution is to have a bootstrapping server with 82 | special "gullible" nodes that act like normal nodes, but take instructions from 83 | their parent without questioning. When starting the bootstrap server, this 84 | so-called node pool will be very interconnected, because there is no network 85 | other than itself yet. Since the network structure is static, this 86 | interconnectedness stays the same even after many independent nodes are 87 | connected; the node pool fills up and many requests never bounce outside of the 88 | bootstrap server's sub-network. This is of course undesirable. 89 | 90 | In order to avoid this problem, the bootstrapping server restarts single nodes 91 | in its pool periodically, so that they can form fresh connections to nodes 92 | outside of the pool; the goal is having the node pool be connected to very 93 | distant parts of the network to avoid clustering. But when should this restart 94 | happen? 95 | 96 | - Periodically: When a lot of nodes connect within one period, the pool's 97 | sub-network fills up all the way, making it difficult to form new connections 98 | to the network. 99 | 100 | - Every `n` new nodes: Suppose the pool has `k` nodes; when `k*n` new clients 101 | connect simultaneously, the server restarts its entire pool at once and loses 102 | its connection to the network. 103 | 104 | The best solution is probably a hybrid: restart a node on every `n` new clients, 105 | require a period of at least `t` to pass since the last event. -------------------------------------------------------------------------------- /src/ClientPool.hs: -------------------------------------------------------------------------------- 1 | -- | The client pool keeps track of running clients, requests new connections 2 | -- when there's a deficit, and cleans up terminated ones. 3 | 4 | {-# LANGUAGE MultiWayIf #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# OPTIONS_HADDOCK show-extensions #-} 7 | 8 | module ClientPool (clientPool) where 9 | 10 | import Control.Concurrent.Async 11 | import Control.Concurrent.STM 12 | import Control.Monad 13 | import Data.List (intercalate) 14 | import Text.Printf 15 | 16 | import Pipes 17 | import qualified Pipes.Concurrent as P 18 | import qualified Pipes.Prelude as P 19 | 20 | import Control.Lens.Operators 21 | import qualified Control.Lens as L 22 | import qualified Types.Lens as L 23 | 24 | import Housekeeping 25 | import Types 26 | import Utilities 27 | 28 | 29 | 30 | -- | Set up the client pool by forking the housekeeping thread, and then start 31 | -- the client pool loop. 32 | clientPool :: Environment -> IO () 33 | clientPool env = withAsync hkeep $ \_ -> fillPool env 34 | where hkeep = dsnHousekeeping env 35 | 36 | 37 | -- | Watch the count of nodes in the database, and issue 'EdgeRequest's 38 | -- to fill the ranks if necessary. 39 | fillPool :: Environment -> IO () 40 | fillPool env = runEffect (balanceEdges env >-> P.map edgeRequest >-> dispatch) 41 | 42 | where 43 | 44 | -- Send signal to the single worker channel 45 | dispatch :: Consumer NormalSignal IO () 46 | dispatch = P.toOutput (env ^. L.st1c . L.pOutput) 47 | 48 | -- Create an EdgeRequest from a Direction 49 | edgeRequest :: Direction 50 | -> NormalSignal 51 | edgeRequest dir = EdgeRequest self (EdgeData dir hardBounces) 52 | where self = env ^. L.self 53 | hardBounces = HardBounce (env ^. L.config . L.hardBounces) 54 | 55 | 56 | 57 | -- | Watch the database of upstream and downstream neighbours. If there is a 58 | -- deficit in one of them, generate the 'Direction' of the new edge to 59 | -- construct. 60 | balanceEdges :: Environment -> Producer Direction IO r 61 | balanceEdges env = forever $ do 62 | 63 | delay (env ^. L.config . L.mediumTickRate) 64 | 65 | (usnDeficit, dsnDeficit) <- liftIO . atomically $ do 66 | 67 | usnCount <- usnDBSize env 68 | dsnCount <- dsnDBSize env 69 | 70 | -- Gather all DSN node ports 71 | dsns <- env ^. L.downstream . L.to readTVar 72 | let traverseKeys = L.itraversed . L.asIndex 73 | port = L.to getTo . L.port 74 | dsnPorts = dsns ^.. traverseKeys . port 75 | 76 | -- Print status message: "Network connections: upstream 7/(5..10), 77 | -- downstream 5/(5..10)"to indicate there are 7 of a minimum of 5, 78 | -- and a maximum of 10, upstream connections (and similarly for 79 | -- downstream). 80 | (toIO env Debug . STDLOG) 81 | (printf "[%s] Network connections:\ 82 | \ upstream %*d/(%d..%d),\ 83 | \ downstream %*d/(%d..%d)\ 84 | \ %s" 85 | (colouredNumber serverPort) 86 | maxNDigits usnCount minN maxN 87 | maxNDigits dsnCount minN maxN 88 | (showL (map colouredNumber dsnPorts))) 89 | 90 | -- Note that both these values can, and often are, negative! 91 | return ( minN - usnCount 92 | , minN - dsnCount 93 | ) 94 | 95 | each (mergeLists (replicate (requests dsnDeficit) Outgoing) 96 | (replicate (requests usnDeficit) Incoming)) 97 | 98 | 99 | where config = env ^. L.config 100 | minN = config ^. L.minNeighbours 101 | maxN = config ^. L.maxNeighbours 102 | maxNDigits = round (logBase 10 (fromIntegral maxN :: Double)) + 1 :: Int 103 | serverPort = config ^. L.serverPort 104 | 105 | 106 | 107 | -- Convert a deficit in nodes into a number of edge requests to be 108 | -- sent out. This is done because in order not to flood the network, 109 | -- the number of requests should not be too high: it might take 110 | -- multiple ticks of 'balanceEdges' to establish a new connection, 111 | -- and lots of requests will be sent out in that time. 112 | 113 | -- The current value table starts like this: 114 | -- 0 -> 0 115 | -- 1-2 -> 1 116 | -- 3-6 -> 2 117 | -- 7-13 -> 3 118 | -- 119 | -- This function has to be total, and not only work for positive 120 | -- integers. 121 | requests = iSqrt 122 | 123 | 124 | 125 | -- | Show a number in colour. 126 | colouredNumber :: Int -> String 127 | colouredNumber n = printf "\ESC[3%dm%d\ESC[0m" (n `rem` 8 + 1) n 128 | 129 | -- | Like List's Show instance, but won't recursively show 130 | -- list elements (therefore avoiding "\ESC..." in the output). 131 | showL :: [String] -> String 132 | showL x = "[" ++ intercalate ", " x ++ "]" -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ################################################################################ 2 | ### CONFIGURATION ############################################################ 3 | ################################################################################ 4 | 5 | 6 | 7 | # Environment 8 | NUM_CORES=$(shell grep -c ^processor /proc/cpuinfo) 9 | 10 | # Executable filenames 11 | MAIN_NODE=amoeba 12 | MAIN_MULTI=amoeba_multi 13 | MAIN_BS=bootstrap 14 | MAIN_DRAW=drawing 15 | 16 | 17 | # Directories 18 | SRC-D=src 19 | MAIN-D=$(SRC-D)/Main 20 | DOC-D=doc 21 | 22 | # GHC flags 23 | PARALLEL_GHC=-j$(NUM_CORES) 24 | OPTIMIZE=-O2 25 | PROF=-prof -auto-all -caf-all 26 | WARN=-Wall -fwarn-tabs -fwarn-incomplete-uni-patterns 27 | THREADED=-threaded 28 | DYNAMIC=-dynamic 29 | 30 | # Cabal flags 31 | PARALLEL_CABAL=-j$(NUM_CORES) 32 | 33 | # Executables 34 | CABAL=cabal 35 | GHC=cabal exec ghc -- $(THREADED) $(PARALLEL_GHC) -i$(SRC-D) $(WARN) $(DYNAMIC) 36 | GHCI=cabal exec ghci -- -i$(SRC-D) $(WARN) 37 | HLINT=hlint --colour 38 | PAGER=less -R 39 | SHELL=bash 40 | 41 | 42 | 43 | ################################################################################ 44 | ### SCRIPT - here be dragons ################################################## 45 | ################################################################################ 46 | 47 | 48 | 49 | .PHONY : noop 50 | noop: 51 | @echo "No target specified. Possible choices:" 52 | 53 | @ # Taken from http://stackoverflow.com/a/9524878/1106679 54 | @ # Display all build targets in this makefile 55 | @make -qp | awk -F':' '/^[a-zA-Z0-9][^$$#\/\t=]*:([^=]|$$)/ {split($$1,A,/ /);for(i in A)print A[i]}' 56 | 57 | 58 | 59 | 60 | # Set cabal/sandbox up 61 | .PHONY : cabal-init 62 | cabal-init : cabal-update cabal-noupdate 63 | 64 | 65 | 66 | # Done automatically by Travis, provided for manual calls to cabal-init 67 | .PHONY : cabal-update 68 | cabal-update : 69 | $(CABAL) update 70 | 71 | 72 | 73 | .PHONY : cabal-noupdate 74 | cabal-noupdate : 75 | $(CABAL) sandbox init 76 | $(CABAL) install $(PARALLEL_CABAL) --only-dependencies --ghc-options=-w 77 | $(CABAL) configure 78 | 79 | 80 | 81 | # Release quality build 82 | RELEASE_FLAGS=$(OPTIMIZE) 83 | .PHONY : release 84 | release : 85 | @echo -e "\e[32mSingle client\e[0m" 86 | $(GHC) $(RELEASE_FLAGS) -o $(MAIN_NODE) $(MAIN-D)/NodeExecutable.hs 87 | @echo -e "\e[32mMultiple clients\e[0m" 88 | $(GHC) $(RELEASE_FLAGS) -o $(MAIN_MULTI) $(MAIN-D)/MultiExecutable.hs 89 | @echo -e "\e[32mBootstrap server\e[0m" 90 | $(GHC) $(RELEASE_FLAGS) -o $(MAIN_BS) $(MAIN-D)/BootstrapExecutable.hs 91 | @echo -e "\e[32mDrawing server\e[0m" 92 | $(GHC) $(RELEASE_FLAGS) -o $(MAIN_DRAW) $(MAIN-D)/DrawingExecutable.hs 93 | 94 | 95 | # Fully optimize with profiling support 96 | PROF_FLAGS=$(OPTIMIZE) $(PROF) 97 | .PHONY : prof 98 | prof : 99 | @echo -e "\e[32mSingle client\e[0m" 100 | $(GHC) $(PROF_FLAGS) -o $(MAIN_NODE) $(MAIN-D)/NodeExecutable.hs 101 | @echo -e "\e[32mMultiple clients\e[0m" 102 | $(GHC) $(PROF_FLAGS) -o $(MAIN_MULTI) $(MAIN-D)/MultiExecutable.hs 103 | @echo -e "\e[32mBootstrap server\e[0m" 104 | $(GHC) $(PROF_FLAGS) -o $(MAIN_BS) $(MAIN-D)/BootstrapExecutable.hs 105 | @echo -e "\e[32mDrawing server\e[0m" 106 | $(GHC) $(PROF_FLAGS) -o $(MAIN_DRAW) $(MAIN-D)/DrawingExecutable.hs 107 | 108 | 109 | # Minimize compilation time 110 | FAST_FLAGS= 111 | .PHONY : fast 112 | fast : 113 | @echo -e "\e[32mSingle client\e[0m" 114 | $(GHC) $(FAST_FLAGS) -o $(MAIN_NODE) $(MAIN-D)/NodeExecutable.hs 115 | @echo -e "\e[32mMultiple clients\e[0m" 116 | $(GHC) $(FAST_FLAGS) -o $(MAIN_MULTI) $(MAIN-D)/MultiExecutable.hs 117 | @echo -e "\e[32mBootstrap server\e[0m" 118 | $(GHC) $(FAST_FLAGS) -o $(MAIN_BS) $(MAIN-D)/BootstrapExecutable.hs 119 | @echo -e "\e[32mDrawing server\e[0m" 120 | $(GHC) $(FAST_FLAGS) -o $(MAIN_DRAW) $(MAIN-D)/DrawingExecutable.hs 121 | 122 | 123 | 124 | # Typecheck and warn, but don't link 125 | NOLINK_FLAGS=-no-link 126 | .PHONY : nolink 127 | nolink : 128 | @echo -e "\e[32mSingle client\e[0m" 129 | $(GHC) $(NOLINK_FLAGS) -o $(MAIN_NODE) $(MAIN-D)/NodeExecutable.hs 130 | @echo -e "\e[32mMultiple clients\e[0m" 131 | $(GHC) $(NOLINK_FLAGS) -o $(MAIN_MULTI) $(MAIN-D)/MultiExecutable.hs 132 | @echo -e "\e[32mBootstrap server\e[0m" 133 | $(GHC) $(NOLINK_FLAGS) -o $(MAIN_BS) $(MAIN-D)/BootstrapExecutable.hs 134 | @echo -e "\e[32mDrawing server\e[0m" 135 | $(GHC) $(NOLINK_FLAGS) -o $(MAIN_DRAW) $(MAIN-D)/DrawingExecutable.hs 136 | 137 | 138 | 139 | # Documentation 140 | .PHONY : doc 141 | doc : haddock 142 | cat $(DOC-D)/information_flow.dot | cpp | dot -Tpng > $(DOC-D)/information_flow.png 143 | cat $(DOC-D)/network.dot | cpp | neato -Tpng > $(DOC-D)/network.png 144 | 145 | .PHONY : haddock 146 | haddock : 147 | cabal haddock --internal --hyperlink-source 148 | 149 | 150 | # HLint 151 | .PHONY : hlint 152 | hlint : 153 | find $(SRC-D) -name "*.hs" -print0 | xargs -0 $(HLINT) | $(PAGER) 154 | 155 | # GHCi 156 | .PHONY : repl 157 | repl : 158 | $(GHCI) 159 | 160 | 161 | .PHONY : clean 162 | clean : 163 | find $(SRC-D) -name "*.hi" -delete 164 | find $(SRC-D) -name "*.o" -delete 165 | find $(SRC-D) -name "*.p_hi" -delete 166 | find $(SRC-D) -name "*.p_o" -delete 167 | find $(SRC-D) -name "*.dyn_hi" -delete 168 | find $(SRC-D) -name "*.dyn_o" -delete 169 | rm -f $(MAIN_NODE) 170 | rm -f $(MAIN_MULTI) 171 | rm -f $(MAIN_BS) 172 | rm -f $(MAIN_DRAW) 173 | -------------------------------------------------------------------------------- /src/Utilities/Networking.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE NumDecimals #-} 4 | {-# OPTIONS_HADDOCK show-extensions #-} 5 | 6 | -- | Networking functions. 7 | 8 | module Utilities.Networking ( 9 | connectToNode 10 | , listenOnNode 11 | , disconnect 12 | , sender 13 | , receiver 14 | , send 15 | , receive 16 | , request 17 | ) where 18 | 19 | import Control.Applicative 20 | import Control.Monad 21 | import Control.Monad.Catch (MonadCatch) 22 | import qualified Data.ByteString as BS 23 | 24 | import Pipes 25 | import qualified Network.Simple.TCP as N 26 | import qualified Network.Socket.ByteString as NSB 27 | import qualified Pipes.Binary as P 28 | import qualified Pipes.Parse as P 29 | import qualified Pipes.Prelude as P 30 | import Data.Binary 31 | 32 | import qualified Control.Lens as L 33 | import Control.Lens.Operators 34 | import qualified Types.Lens as L 35 | 36 | import Types 37 | import Utilities.Concurrency 38 | 39 | 40 | 41 | 42 | -- | 'Node'-based version of 'P.connect'. Automatically closes when the 43 | -- operation terminates or throws. 44 | connectToNode :: (MonadIO io, MonadCatch io) 45 | => To 46 | -> ((N.Socket, N.SockAddr) -> io r) 47 | -> io r 48 | connectToNode (To node) = N.connect (node ^. L.host) 49 | (node ^. L.port . L.to show) 50 | 51 | 52 | 53 | -- | Close a connection. 54 | disconnect :: (MonadIO io) 55 | => N.Socket 56 | -> io () 57 | disconnect s = liftIO (N.closeSock s) 58 | 59 | 60 | 61 | -- | 'Node'-based version of 'P.listen' 62 | listenOnNode :: (MonadIO io, MonadCatch io) 63 | => Node 64 | -> ((N.Socket, N.SockAddr) -> io r) 65 | -> io r 66 | listenOnNode node = N.listen (node ^. L.host . L.to N.Host) 67 | (node ^. L.port . L.to show ) 68 | 69 | 70 | 71 | -- | Continuously encode and send data to a 'N.Socket'. 72 | sender :: (MonadIO io, Binary b) 73 | => Microseconds 74 | -> N.Socket 75 | -> Consumer b io ServerResponse 76 | sender t s = encodeMany >-> toSocketTimeout t s 77 | 78 | 79 | 80 | -- | Continuously encode the given "Bin.Binary" instance and sends each result 81 | -- downstream in "BS.ByteString" chunks. 82 | -- 83 | -- (Sent a pull request to Pipes-Binary for adding this.) 84 | encodeMany :: (Monad m, Binary x) => Pipe x BS.ByteString m ServerResponse 85 | encodeMany = err <$ for cat P.encode 86 | --P.map (BSL.toStrict . Put.runPut . put) 87 | where err = Error "Encoding failure, likely a bug" 88 | -- TODO: Remove this case somehow 89 | 90 | 91 | 92 | -- | Same as 'PN.toSocketTimeout', but returns 'Timeout' instead of throwing an 93 | -- "IOError". 94 | toSocketTimeout :: (MonadIO io) 95 | => Microseconds -- ^ Timeout 96 | -> N.Socket 97 | -> Consumer BS.ByteString io ServerResponse 98 | toSocketTimeout t socket = loop where 99 | loop = do bs <- await 100 | liftIO (timeout t (NSB.sendAll socket bs)) >>= \case 101 | Just _ -> loop 102 | Nothing -> return Timeout 103 | 104 | 105 | 106 | -- | Continuously receive and decode data from a 'N.Socket'. 107 | -- 108 | -- Returns if the connection is closed, times out, or decoding fails. 109 | receiver :: (MonadIO io, Binary b) 110 | => Microseconds 111 | -> N.Socket 112 | -> Producer b io ServerResponse 113 | receiver t s = decoded where 114 | 115 | input = fromSocketTimeout t s 4096 116 | 117 | decoded = P.evalStateT (L.zoom P.decoded P.draw) input >>= \case 118 | Nothing -> return DecodeError 119 | Just x -> yield x >> decoded 120 | 121 | 122 | 123 | -- | Same as 'PN.fromSocketTimeout', but issues 'ServerResponse' instead of 124 | -- throwing an "IOError". 125 | fromSocketTimeout :: (MonadIO io) 126 | => Microseconds -- ^ Timeout 127 | -> N.Socket 128 | -> Int -- ^ Number of bytes to read at once 129 | -> Producer' BS.ByteString io ServerResponse 130 | fromSocketTimeout t socket nBytes = loop where 131 | loop = liftIO (timeout t (N.recv socket nBytes)) >>= \case 132 | Just (Just bs) -> yield bs >> loop 133 | Just Nothing -> return ConnectionClosed 134 | Nothing -> return Timeout 135 | 136 | 137 | 138 | -- TODO: Requester. Continuously send data downstream and gather results. 139 | 140 | 141 | 142 | -- | Receives a single piece of "Binary" data from a "N.Socket". 143 | receive :: (MonadIO io, Binary b) 144 | => Microseconds -- ^ Timeout 145 | -> N.Socket 146 | -> io (Maybe b) 147 | receive t s = runEffect ((P.head . void . receiver t) s) 148 | 149 | 150 | 151 | -- | Sends a single piece of data to a "N.Socket". 152 | send :: (MonadIO io, Binary b) 153 | => Microseconds 154 | -> N.Socket 155 | -> b 156 | -> io () 157 | send t s x = runEffect (yield x >-> void (sender t s)) 158 | 159 | 160 | 161 | -- | Sends a single piece of data to a "N.Socket", and waits for a response. 162 | -- The timeout applies to both the sending and receiving stages independently. 163 | request :: (MonadIO io, Binary a, Binary b) 164 | => Microseconds -- ^ Timeout 165 | -> N.Socket 166 | -> a 167 | -> io (Maybe b) 168 | request t s x = send t s x >> receive t s 169 | -------------------------------------------------------------------------------- /src/Utilities/Databases.hs: -------------------------------------------------------------------------------- 1 | -- | Functions to query the upstream/downstream databases 2 | 3 | -- TODO: The USN/DSN API could probably be refactored significantly by using 4 | -- optics. 5 | 6 | module Utilities.Databases ( 7 | 8 | -- * General 9 | makeTimestamp 10 | 11 | 12 | -- * USN DB 13 | , insertUsn 14 | , deleteUsn 15 | , isUsn 16 | , usnDBSize 17 | , isRoomForUsn 18 | 19 | 20 | -- * DSN DB 21 | , insertDsn 22 | , deleteDsn 23 | , isDsn 24 | , dsnDBSize 25 | , isRoomForDsn 26 | , dumpDsnDB 27 | , updateDsnTimestamp 28 | , nodeRelationship 29 | 30 | 31 | -- * Flood signal DB 32 | , knownFlood 33 | , insertFlood 34 | 35 | ) where 36 | 37 | 38 | import Control.Concurrent.STM 39 | import Control.Monad.Trans 40 | import qualified Data.Map as Map 41 | import Data.Map (Map) 42 | import qualified Data.Set as Set 43 | import Data.Set (Set) 44 | import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime) 45 | 46 | import Control.Lens.Operators 47 | import qualified Control.Lens as L 48 | 49 | import Types 50 | import qualified Types.Lens as L 51 | 52 | 53 | 54 | 55 | 56 | -- ############################################################################# 57 | -- ## General functions ###################################################### 58 | -- ############################################################################# 59 | 60 | 61 | 62 | -- | Create a timestamp, internally represented as a unix timestamp of 63 | -- microseconds. 64 | makeTimestamp :: (MonadIO m) => m Timestamp 65 | makeTimestamp = liftIO (fmap toTimestamp getPOSIXTime) where 66 | 67 | toTimestamp :: POSIXTime -> Timestamp 68 | toTimestamp = Timestamp . Microseconds . round . (* 1e6) 69 | 70 | -- This seems to be the cleanest way to get something that is easily an 71 | -- instance of Binary and comparable to seconds. Better suggestions heartily 72 | -- welcome. 73 | 74 | -- This will overflow in a decent amount of time if Int64 is used as an 75 | -- intermediate representation, since the maximum 64-bit 76 | -- Int is 9,223,372,036,854,775,807 (9e18), and microsecond timestamps are in 77 | -- the order of magnitude of 14,000,000,000,000,000 (1e16). 78 | 79 | 80 | 81 | 82 | 83 | -- ############################################################################# 84 | -- ## USN DB handling ######################################################## 85 | -- ############################################################################# 86 | 87 | 88 | 89 | -- | Insert a USN into the DB. 90 | insertUsn :: Environment -> From -> STM () 91 | insertUsn env from = modifyUsnDB env (Set.insert from) 92 | 93 | 94 | 95 | -- | Delete a USN from the DB. 96 | deleteUsn :: Environment -> From -> STM () 97 | deleteUsn env from = modifyUsnDB env (Set.delete from) 98 | 99 | 100 | 101 | -- | Modify the entire USN DB with a function. Used as a general interface for 102 | -- smaller functions. 103 | modifyUsnDB :: Environment -> (Set From -> Set From) -> STM () 104 | modifyUsnDB env = modifyTVar' db 105 | where db = L.view L.upstream env 106 | 107 | 108 | -- | Query the entire USN DB. Used as a general interface for smaller functions. 109 | queryUsnDB :: Environment -> (Set From -> a) -> STM a 110 | queryUsnDB env query = fmap query (readTVar db) 111 | where db = env ^. L.upstream 112 | 113 | 114 | 115 | -- | Retrieve the current USN DB size. 116 | usnDBSize :: Environment -> STM Int 117 | usnDBSize env = queryUsnDB env Set.size 118 | 119 | 120 | 121 | -- | Check whether a USN is in the DB. 122 | isUsn :: Environment -> From -> STM Bool 123 | isUsn env from = queryUsnDB env (Set.member from) 124 | 125 | 126 | 127 | -- | Check whether another USN can be added to the DB without exceeding the 128 | -- neighbour limit. 129 | isRoomForUsn :: Environment -> STM Bool 130 | isRoomForUsn env = fmap (maxSize >) (usnDBSize env) 131 | where maxSize = env ^. L.config . L.maxNeighbours . L.to fromIntegral 132 | 133 | 134 | 135 | 136 | 137 | -- ############################################################################# 138 | -- ## DSN DB handling ######################################################## 139 | -- ############################################################################# 140 | 141 | 142 | 143 | -- | 'Set' of all known DSN. 144 | dumpDsnDB :: Environment -> STM (Set To) 145 | dumpDsnDB env = fmap Map.keysSet 146 | (readTVar (env ^. L.downstream)) 147 | 148 | 149 | 150 | -- | Query the entire DSN DB. Used as a general interface for smaller functions. 151 | queryDsnDB :: Environment -> (Map To Client -> a) -> STM a 152 | queryDsnDB env query = fmap query (readTVar db) 153 | where db = env ^. L.downstream 154 | 155 | 156 | 157 | 158 | 159 | -- | Determine the current size of a database 160 | dsnDBSize :: Environment -> STM Int 161 | dsnDBSize env = queryDsnDB env Map.size 162 | 163 | 164 | 165 | -- | Check whether there is room to add another node to the pool. 166 | isRoomForDsn :: Environment -> STM Bool 167 | isRoomForDsn env = fmap (maxSize >) (dsnDBSize env) 168 | where maxSize = env ^. L.config . L.maxNeighbours . L.to fromIntegral 169 | 170 | 171 | 172 | 173 | -- | Is the USN in the DB? 174 | -- 175 | -- (Defined in terms of "nodeRelationship", mainly to provide an analogon for 176 | -- "isUsn".) 177 | isDsn :: Environment -> To -> STM Bool 178 | isDsn env to = fmap (== IsDownstreamNeighbour) 179 | (nodeRelationship env to) 180 | 181 | 182 | 183 | -- | Insert/update a DSN. 184 | insertDsn :: Environment 185 | -> To -- ^ DSN address 186 | -> Client -- ^ Local client connecting to this address 187 | -> STM () 188 | insertDsn env to client = modifyTVar (env ^. L.downstream) 189 | (Map.insert to client) 190 | 191 | 192 | 193 | -- | Remove a DSN from the DB. 194 | deleteDsn :: Environment -> To -> STM () 195 | deleteDsn env to = modifyTVar (env ^. L.downstream) 196 | (Map.delete to) 197 | 198 | 199 | 200 | -- | Update the "last communicated with" timestmap in the DSN DB. 201 | updateDsnTimestamp :: Environment -> To -> Timestamp -> STM () 202 | updateDsnTimestamp env to t = modifyTVar (env ^. L.downstream) 203 | (Map.adjust (L.clientTimestamp .~ t) 204 | to) 205 | 206 | 207 | 208 | -- | What is the relationship between this node and another one? A node must not 209 | -- connect to itself or to known neighbours multiple times. 210 | -- 211 | -- Due to the fact that an "EdgeRequest" does not contain the upstream address 212 | -- of the connection to be established, it cannot be checked whether the node 213 | -- is already an upstream neighbour directly; timeouts will have to take care 214 | -- of that. 215 | nodeRelationship :: Environment 216 | -> To 217 | -> STM NodeRelationship 218 | nodeRelationship env to 219 | | to == env ^. L.self = return IsSelf 220 | | otherwise = do isDSN <- fmap (Map.member to) 221 | (readTVar (env ^. L.downstream)) 222 | return (if isDSN then IsDownstreamNeighbour 223 | else IsUnrelated) 224 | 225 | 226 | 227 | 228 | 229 | -- ############################################################################# 230 | -- ## Flood signal DB handling ############################################### 231 | -- ############################################################################# 232 | 233 | 234 | 235 | -- | Check whether a flood signal is already in the DB. 236 | knownFlood :: Environment -> (Timestamp, FloodSignal) -> STM Bool 237 | knownFlood env tfSignal = fmap (Set.member tfSignal) 238 | (env ^. L.handledFloods . L.to readTVar) 239 | 240 | 241 | 242 | -- | Insert a new flood signal into the DB. Deletes an old one if the DB is 243 | -- full. 244 | insertFlood :: Environment -> (Timestamp, FloodSignal) -> STM () 245 | insertFlood env tfSignal = modifyTVar (env ^. L.handledFloods) 246 | (prune . Set.insert tfSignal) 247 | 248 | where -- Delete the oldest entry if the DB is full 249 | prune :: Set a -> Set a 250 | prune db | Set.size db > dbMaxSize = Set.deleteMin db 251 | | otherwise = db 252 | 253 | dbMaxSize = env ^. L.config . L.floodMessageCache -------------------------------------------------------------------------------- /src/Main/Bootstrap.hs: -------------------------------------------------------------------------------- 1 | -- | Main entry point for the bootstrap server. 2 | -- 3 | -- Starts a bootstrap server, which is the entry point for new nodes into the 4 | -- network. 5 | -- 6 | -- The configuration is set like an ordinary node. The server port is what 7 | -- will become the bootstrap server's port, and the rest of the configuration 8 | -- is passed over to the node pool, which will open nodes at successive ports. 9 | 10 | {-# LANGUAGE LambdaCase #-} 11 | {-# LANGUAGE BangPatterns #-} 12 | {-# OPTIONS_HADDOCK show-extensions #-} 13 | 14 | module Main.Bootstrap (main) where 15 | 16 | import Control.Concurrent hiding (yield) 17 | import Control.Concurrent.Async 18 | import Control.Exception 19 | import Control.Monad 20 | import qualified Data.Traversable as T 21 | import Text.Printf 22 | 23 | import Pipes.Network.TCP (Socket) 24 | import qualified Pipes.Network.TCP as PN 25 | 26 | import Control.Lens.Operators 27 | import qualified Control.Lens as L 28 | import qualified Types.Lens as L 29 | 30 | import NodePool 31 | import Types 32 | import Utilities 33 | import qualified Config.Getter as Config 34 | 35 | 36 | 37 | main :: IO () 38 | main = bootstrapServerMain 39 | 40 | 41 | 42 | bootstrapServerMain :: IO () 43 | bootstrapServerMain = do 44 | 45 | config <- Config.bootstrap 46 | 47 | 48 | prepareOutputBuffers 49 | (output, oThread) <- outputThread (config ^. L.nodeConfig . L.maxChanSize) 50 | (`finally` cancel oThread) $ do 51 | 52 | let poolSize = config ^. L.poolConfig . L.poolSize 53 | ldc <- newChan 54 | terminationTrigger <- newTerminationTrigger 55 | npThread <- async (nodePool poolSize 56 | (config ^. L.nodeConfig) 57 | ldc 58 | output 59 | (Just terminationTrigger)) 60 | 61 | toIO' output (STDLOG (printf "Starting bootstrap server with %d nodes" 62 | poolSize)) 63 | (restart, rThread) <- restarter (config ^. L.restartMinimumPeriod) 64 | terminationTrigger 65 | (`finally` cancel rThread) $ do 66 | 67 | bootstrapServer config output ldc restart 68 | `finally` (wait npThread >>= T.traverse cancel) 69 | 70 | 71 | 72 | -- | Stores an action that restarts a random node. Provided mostly for more 73 | -- explicit naming. 74 | newtype Restarter = Restarter { runRestarter :: IO () } 75 | 76 | 77 | 78 | -- | Restart nodes in the own pool as more external nodes connect. This ensures 79 | -- that the bootstrap server pool won't predominantly connect to itself, but 80 | -- open up to the general network over time. 81 | -- 82 | -- Waits a certain amount of time, and then kills a random pool node when a 83 | -- new node is bootstrapped. 84 | -- 85 | -- Blocks as much as 'tryPutMVar' does. 86 | restarter :: Microseconds -- ^ Minimum amount of time between 87 | -- consecutive restarts 88 | -> TerminationTrigger -- ^ Will make the pool kill a pool node when 89 | -- filled. Written to by the restarter, 90 | -- read by the node pool. 91 | -> IO (Restarter, Async ()) -- ^ Thread async, and restart trigger 92 | -- that when executed restarts a 93 | -- (semi-random) node. 94 | restarter minPeriod trigger = do 95 | 96 | -- When the below MVar is filled, the TerminationTrigger will be 97 | -- triggered. However, allow this to happen only after a minimum period 98 | -- of time has passed since the last restart. 99 | restartMVar <- newEmptyMVar 100 | thread <- async . forever $ do 101 | delay minPeriod 102 | _ <- takeMVar restartMVar 103 | yell 44 "Restart triggered!" 104 | runTrigger trigger 105 | 106 | let restartAction = Restarter (void (tryPutMVar restartMVar ())) 107 | 108 | return (restartAction, thread) 109 | 110 | 111 | 112 | bootstrapServer :: BootstrapConfig 113 | -> IOQueue 114 | -> Chan NormalSignal 115 | -> Restarter -- ^ Restarting action, see 'restarter' 116 | -> IO () 117 | bootstrapServer config ioq ldc restart = 118 | PN.listen (PN.Host "127.0.0.1") 119 | (config ^. L.nodeConfig . L.serverPort . L.to show) 120 | (\(sock, addr) -> do 121 | toIO' ioq (STDLOG (printf "Bootstrap server listening on %s" 122 | (show addr))) 123 | bssLoop config ioq 1 sock ldc restart) 124 | 125 | 126 | 127 | -- | BSS = bootstrap server 128 | bssLoop 129 | :: BootstrapConfig -- ^ Configuration to determine how many requests to 130 | -- send out per new node 131 | -> IOQueue 132 | -> Int -- ^ Number of total clients served 133 | -> Socket -- ^ Socket to listen on for bootstrap requests 134 | -> Chan NormalSignal -- ^ LDC to the node pool 135 | -> Restarter -- ^ Restarting action, see 'restarter' 136 | -> IO r 137 | bssLoop config ioq counter' serverSock ldc restart = go counter' where 138 | 139 | 140 | -- Number of times this loop runs with simplified settings 141 | -- to help the node pool buildup. 142 | preRestart = (*) (config ^. L.poolConfig . L.poolSize) 143 | (config ^. L.nodeConfig . L.maxNeighbours) 144 | 145 | go !counter = do 146 | 147 | let 148 | 149 | -- The first couple of new nodes should not bounce, as there are 150 | -- not enough nodes to relay the requests (hence the queues fill 151 | -- up and the nodes block indefinitely. 152 | nodeConfig | counter <= preRestart = L.set L.hardBounces 0 cfg 153 | | otherwise = cfg 154 | where cfg = config ^. L.nodeConfig 155 | 156 | -- If nodes are restarted when the server goes up there are 157 | -- multi-connections to non-existing nodes, and the network dies off 158 | -- after a couple of cycles for some reason. Disable restarting for 159 | -- the first couple of nodes. 160 | attemptRestart 161 | | counter <= preRestart = return () 162 | | counter `isMultipleOf` (config ^. L.restartEvery) = 163 | runRestarter restart 164 | | otherwise = return () 165 | 166 | a `isMultipleOf` b | b > 0 = a `rem` b == 0 167 | | otherwise = True 168 | -- This default ensures that even 169 | -- nonsensical config options don't 170 | -- make the program misbehave. 171 | -- Instead, they just restart on 172 | -- every new node (if the minimum 173 | -- restarting time has passed). 174 | 175 | bootstrapRequestH socket node = do 176 | dispatchSignal nodeConfig node ldc 177 | send tout socket OK 178 | 179 | tout = config ^. L.nodeConfig . L.poolTimeout 180 | 181 | _tid <- PN.acceptFork serverSock $ \(clientSock, _clientAddr) -> 182 | receive tout clientSock >>= \case 183 | Just (BootstrapRequest benefactor) -> do 184 | toIO' ioq 185 | (STDLOG (printf "Sending requests on behalf\ 186 | \ of %s" 187 | (show benefactor))) 188 | bootstrapRequestH clientSock benefactor 189 | attemptRestart 190 | toIO' ioq (STDLOG (printf "Request %d served" 191 | counter)) 192 | Just _other_signal -> do 193 | toIO' ioq (STDLOG "Non-BootstrapRequest signal\ 194 | \ received") 195 | _no_signal -> do 196 | toIO' ioq (STDLOG "No signal received") 197 | 198 | go (counter+1) 199 | 200 | 201 | 202 | -- | Send bootstrap requests on behalf of the new node to the node pool 203 | dispatchSignal :: NodeConfig 204 | -> To -- ^ Benefactor, i.e. 'BootstrapRequest' issuer's server 205 | -- address 206 | -> Chan NormalSignal 207 | -> IO () 208 | dispatchSignal config to ldc = order Incoming >> order Outgoing 209 | where order dir = writeChan ldc (edgeRequest config to dir) 210 | 211 | 212 | 213 | -- | Construct a new edge request 214 | edgeRequest :: NodeConfig 215 | -> To 216 | -> Direction 217 | -> NormalSignal 218 | edgeRequest config to dir = EdgeRequest to edgeData 219 | where edgeData = EdgeData dir bounceParam 220 | bounceParam = HardBounce (config ^. L.hardBounces) -------------------------------------------------------------------------------- /src/Types/Signal.hs: -------------------------------------------------------------------------------- 1 | -- | Signal types, i.e. the protocol used. 2 | 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# OPTIONS_HADDOCK show-extensions #-} 6 | 7 | module Types.Signal where 8 | 9 | 10 | import GHC.Generics (Generic) 11 | import Control.Concurrent.Async (Async) 12 | import Text.Printf 13 | import Data.Set (Set) 14 | 15 | import Data.Binary 16 | import Pipes.Concurrent as P 17 | 18 | import Data.Configurator () -- For Microseconds instance 19 | import Data.Configurator.Types (Configured) 20 | 21 | 22 | -- | Top-level signal type. This is what is typically exchanged between nodes. 23 | data Signal = 24 | 25 | Normal NormalSignal 26 | 27 | -- | Signals that are handled in a special way. For example 'Handshake' 28 | -- signals have to be processed because when they are received the other 29 | -- node is by definition not an upstream neighbour yet. 30 | | Special SpecialSignal 31 | 32 | deriving (Eq, Ord, Show, Generic) 33 | 34 | instance Binary Signal 35 | 36 | 37 | -- | Signal to be executed by a node, e.g. print a message, search for new 38 | -- neighbours etc. 39 | data NormalSignal = 40 | 41 | -- | Query to add an edge to the network. The 'To' parameter is the 42 | -- issuing node's server address. 43 | -- 44 | -- The name has been chosen because when an edge request is complete, 45 | -- the graph of nodes will have a new edge. 46 | EdgeRequest To EdgeData 47 | 48 | -- | Signals meant to be considered by every node in the network. 49 | | Flood Timestamp FloodSignal 50 | 51 | -- | Sent to downstream nodes so the timestamps are refreshed, and the 52 | -- node is kept in the books as a living upstream neighbour 53 | | KeepAlive 54 | 55 | -- | Current node is shutting down, remove it from your upstream 56 | -- neighbour pool. 57 | | ShuttingDown 58 | 59 | -- | To avoid unnecessarily many connections, the "Prune" signal asks a 60 | -- DSN whether the connection can be dropped without making it cross 61 | -- its minimum connection threshold. 62 | | Prune 63 | 64 | deriving (Eq, Ord, Generic) 65 | 66 | instance Show NormalSignal where 67 | show KeepAlive = "KeepAlive" 68 | show Prune = "Prune" 69 | show ShuttingDown = "ShuttingDown" 70 | show (Flood t s) = printf "Flood %s %s" (show t) (show s) 71 | show (EdgeRequest to ed) = printf "EdgeRequest { %s, %s }" (show to) (show ed) 72 | 73 | instance Binary NormalSignal 74 | 75 | 76 | 77 | 78 | -- | These signals will be distributed over the entire network, with every node 79 | -- distributing them to all its downstream neighbours. 80 | data FloodSignal = 81 | 82 | -- | Simple text message 83 | TextMessage String 84 | 85 | -- | Used to send a drawing server a full list of all neighbours. The 86 | -- address is of the painting server. 87 | | SendNeighbourList To 88 | 89 | deriving (Eq, Ord, Show, Generic) 90 | 91 | instance Binary FloodSignal 92 | 93 | 94 | 95 | 96 | 97 | 98 | -- | Sent back to the client in response to an icoming signal 99 | data ServerResponse = 100 | 101 | -- | Server response if the command received will be processed 102 | OK 103 | 104 | -- | Generic error 105 | | Error String 106 | 107 | -- | Confirmation that dropping the connection is alright 108 | | PruneOK 109 | 110 | -- | Sent to node that tries to connect without being a registered 111 | -- upstream neighbour. 112 | | Ignore 113 | 114 | -- | Signal OK, but can't be accepted for some reason. This is the 115 | -- equivalent of 'Ignore' for commands that do not need an existing 116 | -- neighbourship, such as 'Handshake'. 117 | | Denied 118 | 119 | -- | Signal not allowed. Issued for example when an ordinary node 120 | -- receives a 'BootstrapRequest'. 121 | | Illegal 122 | 123 | -- | The signal was received, but couldn't be decoded to the appropriate 124 | -- format 125 | | DecodeError 126 | 127 | | Timeout 128 | 129 | | ConnectionClosed 130 | 131 | deriving (Eq, Ord, Show, Generic) 132 | 133 | instance Binary ServerResponse 134 | 135 | 136 | 137 | 138 | -- | Classifies special signals in order to process them differently. For 139 | -- example, many of them do not need the sending node to be known in order 140 | -- to be processed. 141 | data SpecialSignal = 142 | 143 | -- | Initial request sent from a future client to a bootstrap server. 144 | -- The 'Node' parameter allows other nodes to connect. 145 | BootstrapRequest To 146 | 147 | -- | Ask another node to initiate a handshake 148 | | HandshakeRequest To 149 | 150 | -- | Initiates a handshake, with the goal of adding the recipient as a 151 | -- downstream neighbour. 152 | | Handshake 153 | 154 | -- | Own address and list of DSNs sent to the drawing server. Represents 155 | -- one node in the network graph. 156 | | NeighbourList To (Set To) 157 | 158 | deriving (Eq, Ord, Show, Generic) 159 | 160 | instance Binary SpecialSignal 161 | 162 | 163 | 164 | 165 | 166 | -- | An edge request consists of the direction of the edge to construct, and 167 | -- a bounce parameter to keep track of how far the request travels through the 168 | -- network. 169 | data EdgeData = EdgeData { 170 | _direction :: Direction 171 | , _bounceParam :: BounceParameter 172 | } 173 | deriving (Eq, Ord, Generic) 174 | 175 | instance Show EdgeData where 176 | show EdgeData { _bounceParam = bp, _direction = dir } = 177 | printf "%s edge (%s)" (show dir) showBp 178 | 179 | where 180 | 181 | showBp :: String 182 | showBp = case bp of 183 | HardBounce n -> printf "%d bounce%s left" 184 | n 185 | (if n /= 1 then "s" else "") 186 | SoftBounce n p -> printf "bounces: %d, accept: %.2f" n p 187 | 188 | instance Binary EdgeData 189 | 190 | 191 | 192 | -- | Stores how many times an 'EdgeRequest' should be bounced on. A hard bounce 193 | -- means the bounces are guaranteed to happen a certain number of times, 194 | -- a soft bounce happens with a certain probability. The 'Word' parameter of 195 | -- soft bounces is to provide a hard upper bound for bounces that aren't 196 | -- accepted a certain number of times. 197 | -- 198 | -- > HardBounce 10 -- Will bounce 10 times before entering soft bounce mode 199 | -- > SoftBounce 3 0.8 -- Will be accepted with probability 0.8. It was bounced 200 | -- > -- 3 times already without being accepted. 201 | data BounceParameter = HardBounce Word 202 | | SoftBounce Word Double 203 | deriving (Eq, Ord, Generic) 204 | 205 | instance Binary BounceParameter 206 | 207 | 208 | 209 | 210 | 211 | 212 | -- | Direction of a query that establishes a new connection 213 | data Direction = Outgoing | Incoming 214 | deriving (Eq, Ord, Show, Generic) 215 | 216 | instance Binary Direction 217 | 218 | 219 | 220 | -- | Node address clients can send data to. Used to ensure downstream data is 221 | -- sent only to appropriate handles. 222 | newtype To = To { getTo :: Node } 223 | deriving (Eq, Ord, Generic) 224 | 225 | instance Show To where 226 | show (To node) = "->" ++ show node 227 | 228 | instance Binary To 229 | 230 | 231 | 232 | -- | Uniquely identifies a node in a network by providing the address of its 233 | -- server. 234 | data Node = Node { _host :: String -- ^ Hostname 235 | , _port :: Int -- ^ Port 236 | } -- See Network.Simple.TCP for docs 237 | deriving (Eq, Ord, Generic) 238 | 239 | instance Show Node where 240 | show n = "Node " ++ _host n ++ ":" ++ show (_port n) 241 | 242 | instance Binary Node 243 | 244 | 245 | 246 | newtype Timestamp = Timestamp Microseconds 247 | deriving (Eq, Ord, Show, Generic) 248 | 249 | instance Binary Timestamp 250 | 251 | 252 | 253 | -- | Unifies everything the list of known nodes has to store 254 | data Client = Client { 255 | _clientTimestamp :: Timestamp -- ^ Last downstream contact, used to 256 | -- issue 'KeepAlive' signals so the DSN 257 | -- doesn't consider its upstream 258 | -- neighbour dead. 259 | , _clientAsync :: Async () -- ^ Client thread 260 | , _stsc :: PChan NormalSignal -- ^ Direct channel, e.g. to send 261 | -- 'KeepAlive' signals to a 262 | -- specific client. (stsc = 263 | -- server to single client) 264 | } 265 | 266 | 267 | 268 | -- | Pipe-based concurrent chan. Unifies read/write ends and sealing operation. 269 | -- Used as a better wrapper around them than the default @(,,)@ returned from 270 | -- 'P.spawn''. 271 | data PChan a = PChan { _pOutput :: P.Output a 272 | , _pInput :: P.Input a 273 | , _pSeal :: STM () 274 | } 275 | 276 | 277 | newtype Microseconds = Microseconds Integer 278 | deriving (Eq, Ord, Show, Num, Read, Integral 279 | , Real, Enum, Configured, Generic) 280 | 281 | instance Binary Microseconds -------------------------------------------------------------------------------- /src/Main/Drawing.hs: -------------------------------------------------------------------------------- 1 | -- | Main entry point for the drawing server. 2 | -- 3 | -- The drawing server asks willing nodes to send it a list of all neighbours. 4 | -- The collective information can then be used to analyze the large-scale 5 | -- structure of the entire network. 6 | -- 7 | -- Local abbreviations: 8 | -- STG = Server to graph. 9 | 10 | {-# LANGUAGE LambdaCase #-} 11 | {-# LANGUAGE OverloadedStrings #-} 12 | {-# OPTIONS_HADDOCK show-extensions #-} 13 | 14 | module Main.Drawing (main) where 15 | 16 | import Control.Concurrent 17 | import Control.Concurrent.STM 18 | import Control.Concurrent.Async 19 | import Control.Exception 20 | import Control.Monad 21 | import Data.List (intercalate) 22 | import qualified Data.Foldable as F 23 | import Data.Map (Map) 24 | import qualified Data.Map as Map 25 | import Data.Set (Set) 26 | import qualified Data.Traversable as T 27 | import Text.Printf 28 | 29 | import qualified Network.Simple.TCP as N 30 | import qualified Pipes.Concurrent as P 31 | 32 | import Control.Lens.Operators 33 | import qualified Control.Lens as L 34 | import qualified Types.Lens as L 35 | 36 | import NodePool 37 | import Types 38 | import Utilities 39 | import qualified Config.Getter as Config 40 | 41 | 42 | 43 | 44 | 45 | main :: IO () 46 | main = drawingServerMain 47 | 48 | 49 | 50 | -- | Main entry point of the drawing server. 51 | drawingServerMain :: IO () 52 | drawingServerMain = do 53 | 54 | config <- Config.drawing 55 | 56 | prepareOutputBuffers 57 | (output, oThread) <- outputThread (config ^. L.nodeConfig . L.maxChanSize) 58 | (`finally` cancel oThread) $ do 59 | 60 | let poolSize = config ^. L.poolConfig . L.poolSize 61 | ldc <- newChan 62 | npThread <- async (nodePool poolSize 63 | (config ^. L.nodeConfig) 64 | ldc 65 | output 66 | Nothing) -- No termination trigger 67 | 68 | printf "Starting drawing server with %d nodes\n"poolSize 69 | drawingServer config output ldc 70 | `finally` (wait npThread >>= T.traverse cancel) 71 | 72 | 73 | 74 | -- | Setup for the drawing server before it starts looping. 75 | drawingServer :: DrawingConfig 76 | -> IOQueue 77 | -> Chan NormalSignal -- ^ Local direct connection to the node pool 78 | -> IO () 79 | drawingServer config ioq ldc = do 80 | -- Server to graph worker 81 | stg <- spawn (config ^. L.nodeConfig . L.maxChanSize . L.to P.Bounded) 82 | wThread <- async (graphWorker config ioq stg) 83 | (`finally` cancel wThread) $ do 84 | 85 | let port = config ^. L.nodeConfig . L.serverPort 86 | N.listen (N.Host "127.0.0.1") (show port) $ \(socket, _addr) -> do 87 | let selfTo = To (Node "127.0.0.1" port) 88 | tout = config ^. L.nodeConfig . L.poolTimeout 89 | aThread <- async (networkAsker config 90 | (config ^. L.poolConfig . L.poolSize) 91 | selfTo 92 | ldc) 93 | incomingLoop tout ioq stg socket 94 | `finally` cancel aThread 95 | 96 | 97 | 98 | -- | Drawing server loop; does the actual work after being set up by 99 | -- "drawingServer". 100 | incomingLoop :: Microseconds -- ^ Connection timeout 101 | -> IOQueue 102 | -> PChan (To, Set To) -- ^ (Node, DSNs of that node) 103 | -> N.Socket -- ^ Socket for incoming connections (used by nodes to 104 | -- contact the drawing server upon request) 105 | -> IO () 106 | incomingLoop tout _ioq stg serverSock = forever $ 107 | N.acceptFork serverSock $ \(clientSock, _clientAddr) -> 108 | receive tout clientSock >>= \case 109 | 110 | -- Good answer 111 | Just (NeighbourList node neighbours) -> do 112 | -- toIO' ioq (putStrLn ("Received node data from" ++ show node)) 113 | (atomically . void) (P.send (stg ^. L.pOutput) 114 | (node, neighbours)) 115 | 116 | -- Invalid answer 117 | Just _invalid -> return () -- toIO' ioq (putStrLn "Invalid signal received") 118 | 119 | -- No answer 120 | Nothing -> return () -- toIO' ioq (putStrLn "No signal received") 121 | 122 | 123 | 124 | 125 | -- | Listen on the incoming "PChan" and merge new information into the graph. 126 | graphWorker :: DrawingConfig 127 | -> IOQueue 128 | -> PChan (To, Set To) 129 | -> IO () 130 | graphWorker config ioq stg = do 131 | t'graph <- newTVarIO (Graph Map.empty) 132 | dThread <- async (graphDrawer config ioq t'graph) 133 | (`finally` cancel dThread) $ do 134 | forever $ makeTimestamp >>= \t -> atomically $ do 135 | Just (node, neighbours) <- P.recv (_pInput stg) -- TODO: Error handling on Nothing 136 | modifyTVar t'graph (insertNode t node neighbours) 137 | 138 | 139 | 140 | -- | Read the graph and compiles it to .dot format 141 | graphDrawer :: DrawingConfig 142 | -> IOQueue 143 | -> TVar (Graph To) 144 | -> IO () 145 | graphDrawer config ioq t'graph = (initialDelay >>) . forever $ do 146 | delay (config ^. L.drawEvery) 147 | cleanup config t'graph 148 | graph <- atomically (readTVar t'graph) 149 | let graphSize (Graph g) = Map.size g 150 | s = graphSize graph 151 | (toIO' ioq . STDLOG) (printf "Drawing graph. Current network size: %d nodes\n" s) 152 | writeFile (config ^. L.drawFilename) 153 | (graphToDot graph) 154 | 155 | where 156 | -- Delay the drawer a bit initially, so the 'networkAsker' can do 157 | -- its job first. If this isn't done, the drawer might draw the old 158 | -- state, while pretty much at the same time the new network 159 | -- answers come in. 160 | initialDelay = delay (config ^. L.nodeConfig . L.longTickRate) 161 | 162 | 163 | 164 | -- | Remove edges that haven't been updated in some time. 165 | cleanup :: DrawingConfig 166 | -> TVar (Graph To) 167 | -> IO () 168 | cleanup config t'graph = do 169 | t <- makeTimestamp 170 | let timedOut (Timestamp now) (Timestamp lastInput, _) = 171 | now - lastInput > config ^. L.drawTimeout 172 | atomically (modifyTVar t'graph (filterEdges (not . timedOut t))) 173 | 174 | 175 | 176 | -- | Periodically send out flood messages to get the network data 177 | networkAsker :: DrawingConfig 178 | -> Int -- ^ Own node pool size 179 | -> To -- ^ Own address for reverse connection 180 | -> Chan NormalSignal -- ^ LDC to the pool 181 | -> IO () 182 | networkAsker config poolSize toSelf ldc = forever $ do 183 | delay (_drawEvery config) 184 | t <- makeTimestamp 185 | let signal = Flood t (SendNeighbourList toSelf) 186 | F.for_ [1..poolSize] 187 | (\_i -> writeChan ldc signal) 188 | 189 | 190 | 191 | 192 | -- | Graph consisting of a set of nodes, each having a set of neighbours. 193 | data Graph a = Graph (Map a (Timestamp, Set a)) 194 | 195 | 196 | 197 | 198 | -- ############################################################################# 199 | -- ### Dot-file generation ################################################### 200 | -- ############################################################################# 201 | 202 | 203 | -- | Dirty string-based hacks to convert a Graph to .dot 204 | graphToDot :: Graph To -> String 205 | graphToDot (Graph g) = 206 | dotBoilerplate . intercalate "\n" . map (vertexToDot . stripTimestamp) $ Map.assocs g 207 | where stripTimestamp (a, (_t, b)) = (a,b) 208 | 209 | 210 | vertexToDot :: (To, Set To) -> String 211 | vertexToDot (start, ends) = F.foldMap (edgeToDot start) ends 212 | 213 | edgeToDot :: To -> To -> String 214 | edgeToDot from to = 215 | printf "\t\"%s\" -> \"%s\"\n" 216 | (show' from) 217 | (show' to) 218 | where show' :: To -> String 219 | show' (To (Node _host port)) = printf "%d" port 220 | -- TODO: print host as well (cut out for brevity/local testing) 221 | 222 | 223 | 224 | -- | Add meta info to a list of edges to make them into a proper .dot file 225 | dotBoilerplate :: String -> String 226 | dotBoilerplate str = 227 | "digraph G {\n\ 228 | \ node [shape = box, color = gray, fontname = \"Courier\"];\n\ 229 | \ edge [fontname = \"Courier\", len = 6];\n\ 230 | \ " ++ str ++ "\ 231 | \}\n" 232 | 233 | 234 | 235 | -- ############################################################################# 236 | -- ### Graph modifying API ################################################### 237 | -- ############################################################################# 238 | 239 | 240 | -- | Filter a graph's edges by a predicate. 241 | filterEdges :: ((Timestamp, Set To) -> Bool) -> Graph To -> Graph To 242 | filterEdges p (Graph g) = Graph (Map.filter p g) 243 | 244 | 245 | 246 | -- | Insert/replace node information in the graph. 247 | insertNode :: Timestamp 248 | -> To -- ^ Node 249 | -> (Set To) -- ^ List of DSNs 250 | -> Graph To 251 | -> Graph To 252 | insertNode t node neighbours (Graph g) = Graph (Map.insert node 253 | (t, neighbours) 254 | g) -------------------------------------------------------------------------------- /doc/request_per_deficit_function.nb: -------------------------------------------------------------------------------- 1 | (* Content-type: application/vnd.wolfram.mathematica *) 2 | 3 | (*** Wolfram Notebook File ***) 4 | (* http://www.wolfram.com/nb *) 5 | 6 | (* CreatedBy='Mathematica 9.0' *) 7 | 8 | (*CacheID: 234*) 9 | (* Internal cache information: 10 | NotebookFileLineBreakTest 11 | NotebookFileLineBreakTest 12 | NotebookDataPosition[ 157, 7] 13 | NotebookDataLength[ 9272, 236] 14 | NotebookOptionsPosition[ 8715, 213] 15 | NotebookOutlinePosition[ 9151, 230] 16 | CellTagsIndexPosition[ 9108, 227] 17 | WindowFrame->Normal*) 18 | 19 | (* Beginning of Notebook Content *) 20 | Notebook[{ 21 | 22 | Cell[CellGroupData[{ 23 | Cell["Requests per deficit function", "Title", 24 | CellChangeTimes->{{3.608447870642378*^9, 3.60844787495508*^9}}], 25 | 26 | Cell[TextData[{ 27 | "This is a playground to test various curves for sending out a number edge \ 28 | requests based on how large the deficit is. The result is used in ", 29 | StyleBox["ClientPool.hs", "Input"], 30 | "." 31 | }], "Text", 32 | CellChangeTimes->{{3.60844787918286*^9, 3.60844796406995*^9}}], 33 | 34 | Cell[CellGroupData[{ 35 | 36 | Cell[BoxData[{ 37 | RowBox[{"f", "=", 38 | RowBox[{ 39 | RowBox[{"{", 40 | RowBox[{"x", ",", "a"}], "}"}], "\[Function]", 41 | SuperscriptBox["x", 42 | FractionBox["1", "a"]]}]}], "\[IndentingNewLine]", 43 | RowBox[{"Manipulate", "[", "\[IndentingNewLine]", "\t", 44 | RowBox[{ 45 | RowBox[{"Column", "[", 46 | RowBox[{"{", "\[IndentingNewLine]", "\t\t", 47 | RowBox[{ 48 | RowBox[{"f", "[", 49 | RowBox[{"x", ",", "a"}], "]"}], ",", "\[IndentingNewLine]", "\t\t", 50 | RowBox[{"Show", "[", "\[IndentingNewLine]", "\t\t\t", 51 | RowBox[{ 52 | RowBox[{"Plot", "[", "\[IndentingNewLine]", "\t\t\t\t", 53 | RowBox[{ 54 | RowBox[{"f", "[", 55 | RowBox[{"x", ",", "a"}], "]"}], ",", "\[IndentingNewLine]", 56 | "\t\t\t\t", 57 | RowBox[{"{", 58 | RowBox[{"x", ",", "0", ",", "20"}], "}"}], ",", 59 | "\[IndentingNewLine]", "\t\t\t\t", 60 | RowBox[{"AxesOrigin", "\[Rule]", 61 | RowBox[{"{", 62 | RowBox[{"0", ",", "0"}], "}"}]}], ",", "\[IndentingNewLine]", 63 | "\t\t\t\t", 64 | RowBox[{"PlotRange", "\[Rule]", 65 | RowBox[{"{", 66 | RowBox[{"0", ",", 67 | RowBox[{ 68 | RowBox[{"f", "[", 69 | RowBox[{"20", ",", "a"}], "]"}], "+", "0.2"}]}], "}"}]}], ",", 70 | "\[IndentingNewLine]", "\t\t\t\t", 71 | RowBox[{"PlotStyle", "\[Rule]", 72 | RowBox[{"ColorData", "[", 73 | RowBox[{"1", ",", "2"}], "]"}]}]}], "]"}], ",", 74 | "\[IndentingNewLine]", "\t\t\t", 75 | RowBox[{"DiscretePlot", "[", "\[IndentingNewLine]", "\t\t\t\t", 76 | RowBox[{ 77 | RowBox[{"Round", "[", 78 | RowBox[{"f", "[", 79 | RowBox[{"x", ",", "a"}], "]"}], "]"}], ",", "\[IndentingNewLine]", 80 | "\t\t\t\t", 81 | RowBox[{"{", 82 | RowBox[{"x", ",", "0", ",", "20"}], "}"}], ",", 83 | "\[IndentingNewLine]", "\t\t\t\t", 84 | RowBox[{"AxesOrigin", "\[Rule]", 85 | RowBox[{"{", 86 | RowBox[{"0", ",", "0"}], "}"}]}]}], "]"}], ",", 87 | "\[IndentingNewLine]", "\t\t\t", 88 | RowBox[{"FrameLabel", "\[Rule]", 89 | RowBox[{"{", 90 | RowBox[{"\"\\"", ",", "\"\\""}], "}"}]}], ",", 91 | "\[IndentingNewLine]", "\t\t\t", 92 | RowBox[{"Frame", "\[Rule]", 93 | RowBox[{"{", 94 | RowBox[{ 95 | RowBox[{"{", 96 | RowBox[{"True", ",", "False"}], "}"}], ",", 97 | RowBox[{"{", 98 | RowBox[{"True", ",", "False"}], "}"}]}], "}"}]}], ",", 99 | "\[IndentingNewLine]", "\t\t\t", 100 | RowBox[{"FrameStyle", "\[Rule]", 101 | RowBox[{"(", 102 | RowBox[{"FontFamily", "\[Rule]", "\"\\""}], ")"}]}]}], 103 | "]"}], ",", "\[IndentingNewLine]", "\t\t", 104 | RowBox[{"Grid", "[", "\[IndentingNewLine]", "\t\t\t", 105 | RowBox[{ 106 | RowBox[{ 107 | RowBox[{"Table", "[", "\[IndentingNewLine]", "\t\t\t", 108 | RowBox[{ 109 | RowBox[{"{", 110 | RowBox[{"x", ",", 111 | RowBox[{"f", "[", 112 | RowBox[{"x", ",", "a"}], "]"}], ",", " ", 113 | RowBox[{"Round", "[", 114 | RowBox[{"f", "[", 115 | RowBox[{"x", ",", "a"}], "]"}], "]"}]}], "}"}], ",", 116 | "\[IndentingNewLine]", "\t\t\t", 117 | RowBox[{"{", 118 | RowBox[{"x", ",", "0", ",", "20"}], "}"}]}], "]"}], "//", "N"}], 119 | ",", "\[IndentingNewLine]", "\t\t\t", 120 | RowBox[{"Dividers", "\[Rule]", 121 | RowBox[{"{", 122 | RowBox[{"All", ",", "False"}], "}"}]}]}], "]"}]}], "}"}], "]"}], 123 | ",", "\[IndentingNewLine]", "\t", 124 | RowBox[{"{", 125 | RowBox[{ 126 | RowBox[{"{", 127 | RowBox[{"a", ",", "2"}], "}"}], ",", "0.3", ",", "10"}], "}"}]}], 128 | "\[IndentingNewLine]", "]"}]}], "Input", 129 | CellChangeTimes->{{3.608446056499584*^9, 3.608446235229559*^9}, { 130 | 3.608446285722701*^9, 3.608446328229951*^9}, {3.608446362604904*^9, 131 | 3.608446447374867*^9}, {3.6084464931348457`*^9, 3.608446856580196*^9}, { 132 | 3.608447475957097*^9, 3.608447598297036*^9}, {3.608447631912513*^9, 133 | 3.60844766184778*^9}, {3.6084477014318743`*^9, 3.608447794467187*^9}, { 134 | 3.608447973676813*^9, 3.608447977985524*^9}, {3.608448011591436*^9, 135 | 3.608448146232175*^9}}], 136 | 137 | Cell[BoxData[ 138 | RowBox[{"Function", "[", 139 | RowBox[{ 140 | RowBox[{"{", 141 | RowBox[{"x", ",", "a"}], "}"}], ",", 142 | SuperscriptBox["x", 143 | RowBox[{"1", "/", "a"}]]}], "]"}]], "Output", 144 | CellChangeTimes->{{3.608446675450251*^9, 3.608446689574566*^9}, { 145 | 3.60844672419319*^9, 3.608446752754876*^9}, 3.608446785187414*^9, { 146 | 3.608446824642942*^9, 3.608446857056904*^9}, {3.608447488737824*^9, 147 | 3.608447598938727*^9}, {3.608447643710908*^9, 3.608447662250793*^9}, { 148 | 3.6084477080823097`*^9, 3.608447794963251*^9}, 3.608447979743218*^9, { 149 | 3.608448013354518*^9, 3.608448047086751*^9}, {3.608448079585223*^9, 150 | 3.608448100568301*^9}, 3.608448146595787*^9}], 151 | 152 | Cell[BoxData[ 153 | TagBox[ 154 | StyleBox[ 155 | DynamicModuleBox[{$CellContext`a$$ = 2, Typeset`show$$ = True, 156 | Typeset`bookmarkList$$ = {}, Typeset`bookmarkMode$$ = "Menu", 157 | Typeset`animator$$, Typeset`animvar$$ = 1, Typeset`name$$ = 158 | "\"untitled\"", Typeset`specs$$ = {{{ 159 | Hold[$CellContext`a$$], 2}, 0.3, 10}}, Typeset`size$$ = { 160 | 447., {415., 424.}}, Typeset`update$$ = 0, Typeset`initDone$$, 161 | Typeset`skipInitDone$$ = True, $CellContext`a$39547$$ = 0}, 162 | DynamicBox[Manipulate`ManipulateBoxes[ 163 | 1, StandardForm, "Variables" :> {$CellContext`a$$ = 2}, 164 | "ControllerVariables" :> { 165 | Hold[$CellContext`a$$, $CellContext`a$39547$$, 0]}, 166 | "OtherVariables" :> { 167 | Typeset`show$$, Typeset`bookmarkList$$, Typeset`bookmarkMode$$, 168 | Typeset`animator$$, Typeset`animvar$$, Typeset`name$$, 169 | Typeset`specs$$, Typeset`size$$, Typeset`update$$, Typeset`initDone$$, 170 | Typeset`skipInitDone$$}, "Body" :> Column[{ 171 | $CellContext`f[$CellContext`x, $CellContext`a$$], 172 | Show[ 173 | Plot[ 174 | $CellContext`f[$CellContext`x, $CellContext`a$$], {$CellContext`x, 175 | 0, 20}, AxesOrigin -> {0, 0}, 176 | PlotRange -> {0, $CellContext`f[20, $CellContext`a$$] + 0.2}, 177 | PlotStyle -> ColorData[1, 2]], 178 | DiscretePlot[ 179 | Round[ 180 | $CellContext`f[$CellContext`x, $CellContext`a$$]], \ 181 | {$CellContext`x, 0, 20}, AxesOrigin -> {0, 0}], 182 | FrameLabel -> {"deficit", "requests"}, 183 | Frame -> {{True, False}, {True, False}}, 184 | FrameStyle -> (FontFamily -> "Helvetica")], 185 | Grid[ 186 | N[ 187 | Table[{$CellContext`x, 188 | $CellContext`f[$CellContext`x, $CellContext`a$$], 189 | Round[ 190 | $CellContext`f[$CellContext`x, $CellContext`a$$]]}, \ 191 | {$CellContext`x, 0, 20}]], Dividers -> {All, False}]}], 192 | "Specifications" :> {{{$CellContext`a$$, 2}, 0.3, 10}}, "Options" :> {}, 193 | "DefaultOptions" :> {}], 194 | ImageSizeCache->{515., {480., 489.}}, 195 | SingleEvaluation->True], 196 | Deinitialization:>None, 197 | DynamicModuleValues:>{}, 198 | SynchronousInitialization->True, 199 | UnsavedVariables:>{Typeset`initDone$$}, 200 | UntrackedVariables:>{Typeset`size$$}], "Manipulate", 201 | Deployed->True, 202 | StripOnInput->False], 203 | Manipulate`InterpretManipulate[1]]], "Output", 204 | CellChangeTimes->{{3.608446675450251*^9, 3.608446689574566*^9}, { 205 | 3.60844672419319*^9, 3.608446752754876*^9}, 3.608446785187414*^9, { 206 | 3.608446824642942*^9, 3.608446857056904*^9}, {3.608447488737824*^9, 207 | 3.608447598938727*^9}, {3.608447643710908*^9, 3.608447662250793*^9}, { 208 | 3.6084477080823097`*^9, 3.608447794963251*^9}, 3.608447979743218*^9, { 209 | 3.608448013354518*^9, 3.608448047086751*^9}, {3.608448079585223*^9, 210 | 3.608448100568301*^9}, 3.608448146632207*^9}] 211 | }, Open ]] 212 | }, Open ]] 213 | }, 214 | WindowSize->{1362, 1003}, 215 | WindowMargins->{{0, Automatic}, {Automatic, 0}}, 216 | Magnification:>FEPrivate`If[ 217 | FEPrivate`Equal[FEPrivate`$VersionNumber, 6.], 1.5, 1.5 Inherited], 218 | FrontEndVersion->"9.0 for Linux x86 (64-bit) (November 20, 2012)", 219 | StyleDefinitions->"Default.nb" 220 | ] 221 | (* End of Notebook Content *) 222 | 223 | (* Internal cache information *) 224 | (*CellTagsOutline 225 | CellTagsIndex->{} 226 | *) 227 | (*CellTagsIndex 228 | CellTagsIndex->{} 229 | *) 230 | (*NotebookFileOutline 231 | Notebook[{ 232 | Cell[CellGroupData[{ 233 | Cell[579, 22, 111, 1, 138, "Title"], 234 | Cell[693, 25, 280, 6, 77, "Text"], 235 | Cell[CellGroupData[{ 236 | Cell[998, 35, 4186, 99, 762, "Input"], 237 | Cell[5187, 136, 663, 13, 106, "Output"], 238 | Cell[5853, 151, 2834, 58, 1015, "Output"] 239 | }, Open ]] 240 | }, Open ]] 241 | } 242 | ] 243 | *) 244 | 245 | (* End of internal cache information *) 246 | -------------------------------------------------------------------------------- /src/Client.hs: -------------------------------------------------------------------------------- 1 | -- | A client represents one connection to a downstream node. 2 | 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# OPTIONS_HADDOCK show-extensions #-} 5 | 6 | 7 | module Client ( 8 | startHandshakeH 9 | ) where 10 | 11 | 12 | 13 | 14 | import Control.Applicative 15 | import Control.Concurrent.Async 16 | import Control.Concurrent.STM 17 | import Control.Exception 18 | import Control.Monad 19 | import Data.Monoid 20 | import Text.Printf 21 | 22 | import Pipes 23 | import Pipes.Network.TCP (Socket) 24 | import qualified Pipes.Concurrent as P 25 | 26 | import Control.Lens.Operators 27 | -- import qualified Control.Lens as L 28 | import qualified Types.Lens as L 29 | 30 | import Types 31 | import Utilities 32 | 33 | 34 | 35 | -- | Initiate a handshake with a remote node, with the purpose of adding it as 36 | -- a downstream neighbour and launching a new client. 37 | -- 38 | -- Counterpart of 'Server.handshakeH'. 39 | -- 40 | -- The procedure is as follows: 41 | -- 42 | -- 1. Open a connection to the new node and send it the 'Handshake' signal. 43 | -- 2. When the answer is 'OK', attempt to launch a new client. If not, close 44 | -- the connection and stop. 45 | -- 3. With its 'OK', the downstream node stated that it has space and reserved 46 | -- a slot for the new connection. Therefore, a new client can be spawned, 47 | -- but will only done so if this node has room for it, and the downstream 48 | -- neighbour is not yet known. 49 | -- 4. Spawn a new client with the connection just opened. 50 | startHandshakeH :: Environment 51 | -> To -- ^ Node to add 52 | -> IO () 53 | startHandshakeH env to = 54 | let tout = env ^. L.config . L.poolTimeout 55 | in connectToNode to $ \(socket, _addr) -> 56 | (request tout socket (Special Handshake) >>= \case 57 | Just OK -> newClient env to socket -- OK will be sent back by 58 | -- newClient after checking 59 | -- for permission 60 | x -> do send tout socket (Error "Bad handshake") 61 | errorPrint env (printf "Handshake signal response: %s" 62 | (show x))) 63 | 64 | 65 | 66 | -- | Check whether everything is alright on this end of the connection, and 67 | -- start the client in that case. 68 | newClient :: Environment 69 | -> To -- ^ Target address (for bookkeeping) 70 | -> Socket -- ^ Connection 71 | -> IO () 72 | newClient env to socket = ifM allowed 73 | (send tout socket OK >> goClient) 74 | (send tout socket Ignore) 75 | 76 | where 77 | 78 | tout = env ^. L.config . L.poolTimeout 79 | 80 | goClient = (`finally` cleanup) $ do 81 | time <- makeTimestamp 82 | stsc <- spawn (P.Bounded (env ^. L.config . L.maxChanSize)) 83 | withAsync (clientLoop env socket to stsc) $ \thread -> do 84 | -- (Client waits until its entry is in the DB 85 | -- before it starts working.) 86 | let client = Client time thread stsc 87 | proceed <- atomically $ do 88 | -- Double check whether the DSN is already known. Since 89 | -- this is in an STM block, it is *guaranteed* that 90 | -- nothing is overwritten. 91 | isNew <- not <$> isDsn env to 92 | when isNew (insertDsn env to client) 93 | return isNew 94 | when proceed (wait thread) 95 | 96 | -- Check whether the client is allowed, and log the event accordingly 97 | allowed = atomically $ nodeRelationship env to >>= \case 98 | IsSelf -> do 99 | toIO env Debug (STDERR "Tried to launch client to self") 100 | return False 101 | IsDownstreamNeighbour -> do 102 | toIO env Debug (STDERR "Tried to launch client to already known node") 103 | return False 104 | IsUnrelated -> do 105 | isRoom <- isRoomForDsn env 106 | if not isRoom 107 | then do toIO env Debug (STDERR "No room for new client") 108 | return False 109 | else return True 110 | 111 | -- Remove the DSN from the DB and tell it about that 112 | cleanup = do atomically (deleteDsn env to) 113 | send tout socket (Normal ShuttingDown) 114 | 115 | 116 | 117 | -- | Main client function; read the communication channels and execute orders. 118 | clientLoop :: Environment 119 | -> Socket -- ^ Connection to use (created by the handshake process) 120 | -> To -- ^ Node the 'Socket' connects to. Only used for 121 | -- bookkeeping, in order to keep the client pool up to 122 | -- date. 123 | -> PChan NormalSignal -- ^ Channel to this client 124 | -> IO () 125 | clientLoop env socket to stsc = do 126 | waitForDBEntry >>= \case 127 | Nothing -> return () -- Timeout before DB entry appears 128 | Just () -> runEffect (P.fromInput input >-> signalH env socket to) 129 | 130 | where input = mconcat [ env ^. L.st1c . L.pInput 131 | , stsc ^. L.pInput 132 | ] 133 | 134 | -- Retry until the client is inserted into the DB. 135 | -- Hack to allow forking the client and having it insert its 136 | -- own async in the DB (so it can clean up when it terminates). 137 | -- Since there is no DB entry to check, the timeout is added 138 | -- explicitly here as well. 139 | waitForDBEntry = timeout timeoutT 140 | (atomically (whenM (not <$> isDsn env to) 141 | retry)) 142 | 143 | timeoutT = env ^. L.config . L.poolTimeout 144 | 145 | 146 | 147 | -- | Send signals downstream, and handle the server's response. 148 | signalH :: (MonadIO io) 149 | => Environment 150 | -> Socket 151 | -> To 152 | -> Consumer NormalSignal io () 153 | signalH env socket to = go where 154 | terminate = return () 155 | go = await >>= request tout socket . Normal >>= \case 156 | Just OK -> ok env to >> go 157 | Just PruneOK -> pruneOK env >> terminate 158 | Just (Error e) -> genericError env e >> terminate 159 | Just Ignore -> ignore env >> terminate 160 | Just Denied -> denied env >> terminate 161 | Just Illegal -> illegal env >> terminate 162 | Just DecodeError -> decodeError env >> terminate 163 | Just Timeout -> timeoutError env >> terminate 164 | Just ConnectionClosed -> cClosed env >> terminate 165 | Nothing -> noResponse env >> terminate 166 | 167 | tout = env ^. L.config . L.poolTimeout 168 | 169 | 170 | 171 | 172 | -- | Response to sending a signal to a server successfully. (Updates the "last 173 | -- successfully sent signal to" timestamp.) 174 | ok :: (MonadIO io) 175 | => Environment 176 | -> To -- ^ Target downstream neighbour 177 | -> io () 178 | ok env to = liftIO (do t <- makeTimestamp 179 | atomically (updateDsnTimestamp env to t)) 180 | 181 | 182 | 183 | errorPrint :: (MonadIO io) 184 | => Environment 185 | -> String 186 | -> io () 187 | errorPrint env = liftIO . atomically . toIO env Debug . STDLOG 188 | -- TODO: Rename this function, since it only reports the results to 189 | -- STDLOG; the messages aren't errors of this client after all, but 190 | -- a result of the DSN's behaviour 191 | 192 | 193 | 194 | pruneOK :: (MonadIO io) 195 | => Environment 196 | -> io () 197 | pruneOK env = errorPrint env "Pruning confirmed, terminating client" 198 | 199 | 200 | 201 | -- | A downstream node has received a signal from this node without having it 202 | -- in its list of upstream neighbours. A a result, it tells the issuing client 203 | -- that it will ignore its requests. 204 | -- 205 | -- The purpose of this is twofold: 206 | -- 207 | -- - Nodes can only be contacted by other registered nodes. A malicious 208 | -- network of other nodes cannot nuke a node with illegal requests, 209 | -- because it will just ignore all the illegally created ones. 210 | -- 211 | -- - If a node doesn't send a signal for too long, it will time out. When it 212 | -- starts sending new signals, it will be told that it was dropped. 213 | ignore :: (MonadIO io) 214 | => Environment 215 | -> io () 216 | ignore env = errorPrint env "Server ignores this node, terminating client" 217 | 218 | 219 | 220 | -- | Server sent back a generic error, see docs for 'Error' 221 | genericError :: (MonadIO io) 222 | => Environment 223 | -> String 224 | -> io () 225 | genericError env e = errorPrint env $ "Generic error encountered, terminating\ 226 | \ client (" ++ e ++ ")" 227 | 228 | 229 | 230 | -- | Server denied a valid request, see docs for 'Denied' 231 | denied :: (MonadIO io) 232 | => Environment 233 | -> io () 234 | denied env = errorPrint env "Server denied the request, terminating client" 235 | 236 | 237 | 238 | -- | Server denied a valid request, see docs for 'Denied' 239 | illegal :: (MonadIO io) 240 | => Environment 241 | -> io () 242 | illegal env = errorPrint env "Signal illegal, terminating client" 243 | 244 | 245 | 246 | -- | Server did not respond 247 | noResponse :: (MonadIO io) 248 | => Environment 249 | -> io () 250 | noResponse env = errorPrint env "Server did not respond, terminating client" 251 | 252 | 253 | 254 | -- | Decoding the response unsuccessul 255 | decodeError :: (MonadIO io) 256 | => Environment 257 | -> io () 258 | decodeError env = errorPrint env "Signal decoding error, terminating client" 259 | 260 | 261 | 262 | -- | Timeout 263 | timeoutError :: (MonadIO io) 264 | => Environment 265 | -> io () 266 | timeoutError env = errorPrint env "Timeout before response, terminating client" 267 | 268 | 269 | 270 | -- | Connection closed by downstream 271 | cClosed :: (MonadIO io) 272 | => Environment 273 | -> io () 274 | cClosed env = errorPrint env "The remote host has closed the connection,\ 275 | \ terminating client" -------------------------------------------------------------------------------- /src/Config/ConfigFile.hs: -------------------------------------------------------------------------------- 1 | -- | Read configuration settings from a configuration file. 2 | -- 3 | -- The potential locations of these files are hardcoded here, 4 | -- in the (non-exposed) '@configFiles@ value. 5 | 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE ViewPatterns #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | {-# OPTIONS_HADDOCK show-extensions #-} 10 | 11 | module Config.ConfigFile ( 12 | nodeModifier 13 | , bootstrapModifier 14 | , drawingModifier 15 | , multiModifier 16 | ) where 17 | 18 | import Data.Char (toLower) 19 | import Data.Monoid 20 | import Data.Functor 21 | import Control.Monad.Reader 22 | import qualified Data.Set as Set 23 | 24 | import qualified Data.Configurator as C 25 | import qualified Data.Configurator.Types as C 26 | import qualified Data.Text as Text 27 | import qualified Data.Traversable as T 28 | 29 | import Control.Lens hiding (to) 30 | import qualified Types.Lens as L 31 | 32 | import qualified Types as Ty 33 | import Config.OptionModifier 34 | import qualified Config.AddressParser as AP 35 | 36 | 37 | -- | Files to read the config from. The later in the list, the higher the 38 | -- precedence of the contained settings. 39 | configFiles :: [C.Worth FilePath] 40 | configFiles = [ C.Optional "$(HOME)/.local/share/amoeba/amoeba.cfg" 41 | , C.Optional "$(HOME)/.amoeba.cfg" 42 | , C.Optional "amoeba.cfg" 43 | ] 44 | 45 | 46 | 47 | -- | Get the node option modifier from the top level of the configuration file 48 | nodeModifier :: IO (OptionModifier Ty.NodeConfig) 49 | nodeModifier = C.load configFiles >>= runReaderT (nodeModifier' []) 50 | 51 | -- | Get the bootstrap option modifier by first reading the top level of the 52 | -- configuration file, and then overwriting the values obtained by what is 53 | -- found under the \"bootstrap\" prefix. 54 | bootstrapModifier :: IO (OptionModifier Ty.BootstrapConfig) 55 | bootstrapModifier = C.load configFiles >>= runReaderT bootstrapModifier' 56 | 57 | -- | Get the drawing option modifier by first reading the top level of the 58 | -- configuration file, and then overwriting the values obtained by what is 59 | -- found under the \"drawing\" prefix. 60 | drawingModifier :: IO (OptionModifier Ty.DrawingConfig) 61 | drawingModifier = C.load configFiles >>= runReaderT drawingModifier' 62 | 63 | -- | Get the multi option modifier by first reading the top level of the 64 | -- configuration file, and then overwriting the values obtained by what is 65 | -- found under the \"multi\" prefix. 66 | multiModifier :: IO (OptionModifier Ty.MultiConfig) 67 | multiModifier = C.load configFiles >>= runReaderT multiModifier' 68 | 69 | 70 | 71 | 72 | 73 | -- | Get the pool node modifier given a certain "Prefix". 74 | nodeModifier' :: Prefixes -> ReaderT C.Config IO (OptionModifier Ty.NodeConfig) 75 | nodeModifier' prefixes = (fmap mconcat . T.sequenceA) mods where 76 | mods = map ($ prefixes) 77 | [ serverPort 78 | , minNeighbours 79 | , maxNeighbours 80 | , maxChanSize 81 | , hardBounces 82 | , acceptP 83 | , maxSoftBounces 84 | , shortTickRate 85 | , mediumTickRate 86 | , longTickRate 87 | , poolTimeout 88 | , verbosity 89 | , bootstrapServers 90 | , floodMessageCache 91 | ] 92 | 93 | 94 | 95 | -- | Get the pool modifier given a certain "Prefix". 96 | poolModifier' :: Prefixes -> ReaderT C.Config IO (OptionModifier Ty.PoolConfig) 97 | poolModifier' prefixes = (fmap mconcat . T.sequenceA) mods where 98 | mods = map ($ prefixes) [ poolSize ] 99 | 100 | 101 | 102 | noPrefix :: [a] 103 | noPrefix = [] 104 | 105 | 106 | 107 | -- | Read the general config, before overwriting it with values with the 108 | -- @bootstrap@ prefix, i.e. for the @foo@ setting first looks for @foo@ and 109 | -- then for @bootstrap.foo@. 110 | bootstrapModifier' :: ReaderT C.Config IO (OptionModifier Ty.BootstrapConfig) 111 | bootstrapModifier' = (fmap mconcat . T.sequenceA) mods where 112 | mods = [ liftModifier L.nodeConfig <$> nodeModifier' noPrefix 113 | , liftModifier L.poolConfig <$> poolModifier' noPrefix 114 | , restartEvery prefix 115 | , restartMinimumPeriod prefix 116 | , liftModifier L.nodeConfig <$> nodeModifier' prefix 117 | , liftModifier L.poolConfig <$> poolModifier' prefix 118 | ] 119 | prefix = ["bootstrap"] 120 | 121 | 122 | 123 | -- | Same as "bootstrapModifier", but for the drawing server (using the 124 | -- @drawing@ prefix). 125 | drawingModifier' :: ReaderT C.Config IO (OptionModifier Ty.DrawingConfig) 126 | drawingModifier' = (fmap mconcat . T.sequenceA) mods where 127 | mods = [ liftModifier L.nodeConfig <$> nodeModifier' noPrefix 128 | , liftModifier L.poolConfig <$> poolModifier' noPrefix 129 | , drawEvery prefix 130 | , drawFilename prefix 131 | , drawTimeout prefix 132 | , liftModifier L.nodeConfig <$> nodeModifier' prefix 133 | , liftModifier L.poolConfig <$> poolModifier' prefix 134 | ] 135 | prefix = ["drawing"] 136 | 137 | 138 | 139 | -- | Same as "bootstrapModifier", but for the multi client (using the 140 | -- @multi@ prefix). 141 | multiModifier' :: ReaderT C.Config IO (OptionModifier Ty.MultiConfig) 142 | multiModifier' = (fmap mconcat . T.sequenceA) mods where 143 | mods = [ liftModifier L.nodeConfig <$> nodeModifier' noPrefix 144 | , liftModifier L.poolConfig <$> poolModifier' noPrefix 145 | , liftModifier L.nodeConfig <$> nodeModifier' prefix 146 | , liftModifier L.poolConfig <$> poolModifier' prefix 147 | ] 148 | prefix = ["multi"] 149 | 150 | 151 | 152 | -- | A prefix is what leads to an option in a hierarchy; they're similar to 153 | -- parent directories. For example the expression "foo.bar.qux" corresponds to 154 | -- @[\"foo\", \"bar\"] :: Prefixes@, with the option name being @qux@. 155 | type Prefixes = [C.Name] 156 | 157 | 158 | 159 | -- | Look up a certain setting, possibly with a list of parent prefixes. 160 | lookupC :: C.Configured a 161 | => Prefixes -- ^ List of prefixes, e.g. ["foo", "bar"] for foo.bar.* 162 | -> C.Name -- ^ Option name 163 | -> ReaderT C.Config IO (Maybe a) 164 | lookupC prefixes name = ask >>= \cfg -> liftIO (C.lookup cfg fullName) where 165 | fullName | null prefixes = name 166 | | otherwise = Text.intercalate "." prefixes <> "." <> name 167 | 168 | 169 | 170 | -- | Convert a field and a value to an 'OptionModifier' to set that field to 171 | -- that value. 'mempty' if no value is given. 172 | toSetter :: ASetter a a c b -- ^ Lens to a field 173 | -> Maybe b -- ^ New value of the field 174 | -> OptionModifier a -- ^ 'OptionModifier' to apply the lens 175 | toSetter l (Just x) = OptionModifier (l .~ x) 176 | toSetter _ Nothing = mempty 177 | 178 | 179 | 180 | -- | Get an option that cannot have wrong values (besides type mismatches). 181 | -- For example, the verbosity option only supports a handful of words and not 182 | -- all strings, so it is not a simple option. The number of neighbours on the 183 | -- other hand can be any value. 184 | getSimpleOption :: C.Configured b 185 | => ASetter a a c b 186 | -> C.Name 187 | -> Prefixes 188 | -> ReaderT C.Config IO (OptionModifier a) 189 | getSimpleOption l name prefixes = fmap (toSetter l) 190 | (lookupC prefixes name) 191 | 192 | 193 | 194 | -- Node config specific 195 | 196 | serverPort, minNeighbours, maxNeighbours, maxChanSize, verbosity, hardBounces, 197 | acceptP, maxSoftBounces, shortTickRate, mediumTickRate, longTickRate, 198 | poolTimeout, floodMessageCache, bootstrapServers 199 | :: Prefixes -> ReaderT C.Config IO (OptionModifier Ty.NodeConfig) 200 | 201 | serverPort = getSimpleOption L.serverPort "serverPort" 202 | minNeighbours = getSimpleOption L.minNeighbours "minNeighbours" 203 | maxNeighbours = getSimpleOption L.maxNeighbours "maxNeighbours" 204 | maxChanSize = getSimpleOption L.maxChanSize "maxChanSize" 205 | hardBounces = getSimpleOption L.hardBounces "hardBounces" 206 | acceptP = getSimpleOption L.acceptP "acceptP" 207 | maxSoftBounces = getSimpleOption L.maxSoftBounces "maxSoftBounces" 208 | shortTickRate = getSimpleOption L.shortTickRate "shortTickRate" 209 | mediumTickRate = getSimpleOption L.mediumTickRate "mediumTickRate" 210 | longTickRate = getSimpleOption L.longTickRate "longTickRate" 211 | poolTimeout = getSimpleOption L.poolTimeout "poolTimeout" 212 | floodMessageCache = getSimpleOption L.floodMessageCache "floodMessageCache" 213 | 214 | verbosity prefixes = fmap (toSetter L.verbosity) verbosity' 215 | 216 | where 217 | 218 | verbosity' :: ReaderT C.Config IO (Maybe Ty.Verbosity) 219 | verbosity' = fmap (maybe Nothing parseVerbosity) 220 | (lookupC prefixes "verbosity") 221 | 222 | parseVerbosity :: String -> Maybe Ty.Verbosity 223 | parseVerbosity (map toLower -> x) 224 | | x == "mute" = Just Ty.Mute 225 | | x == "quiet" = Just Ty.Quiet 226 | | x == "default" = Just Ty.Default 227 | | x == "debug" = Just Ty.Debug 228 | | x == "chatty" = Just Ty.Chatty 229 | | otherwise = Nothing 230 | 231 | bootstrapServers prefixes = fmap appendBSS bootstrapServers' 232 | 233 | where 234 | 235 | appendBSS x = OptionModifier (L.bootstrapServers <>~ x) 236 | 237 | bootstrapServers' :: ReaderT C.Config IO (Set.Set Ty.To) 238 | bootstrapServers' = fmap m'valueToTo 239 | (lookupC prefixes "bootstrapServers") 240 | 241 | m'valueToTo :: Maybe C.Value -> Set.Set Ty.To 242 | m'valueToTo = maybe Set.empty valueToTo 243 | 244 | -- Convert a "C.Value" to a "Set.Set" of "Ty.To" addresses. 245 | valueToTo :: C.Value -> Set.Set Ty.To 246 | valueToTo (C.String text) = 247 | either (const Set.empty) 248 | Set.singleton 249 | (parseAddrText text) 250 | valueToTo (C.List vals) = foldr go Set.empty vals where 251 | go (C.String text) xs = case parseAddrText text of 252 | Right to -> Set.insert to xs 253 | Left _r -> xs 254 | go _else xs = xs 255 | valueToTo _else = Set.empty 256 | 257 | parseAddrText = AP.parseAddress . Text.unpack 258 | 259 | 260 | 261 | -- Node pool specific 262 | 263 | poolSize :: Prefixes -> ReaderT C.Config IO (OptionModifier Ty.PoolConfig) 264 | poolSize = getSimpleOption L.poolSize "poolSize" 265 | 266 | 267 | 268 | -- Bootstrap server specific 269 | 270 | restartEvery, restartMinimumPeriod 271 | :: Prefixes -> ReaderT C.Config IO (OptionModifier Ty.BootstrapConfig) 272 | 273 | restartEvery = getSimpleOption L.restartEvery "restartEvery" 274 | restartMinimumPeriod = getSimpleOption L.restartMinimumPeriod "restartMinimumPeriod" 275 | 276 | 277 | 278 | -- Drawing server specific 279 | 280 | drawEvery, drawFilename, drawTimeout 281 | :: Prefixes -> ReaderT C.Config IO (OptionModifier Ty.DrawingConfig) 282 | 283 | drawEvery = getSimpleOption L.drawEvery "drawEvery" 284 | drawFilename = getSimpleOption L.drawFilename "drawFilename" 285 | 286 | drawTimeout prefixes = 287 | fmap (toSetter L.drawTimeout . fmap Ty.Microseconds) 288 | (lookupC prefixes "drawTimeout") 289 | -------------------------------------------------------------------------------- /src/Types/Config.hs: -------------------------------------------------------------------------------- 1 | -- | Environment/configuration types. 2 | 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Types.Config ( 6 | 7 | 8 | -- * Environment 9 | Environment (..) 10 | 11 | 12 | -- * Configurations 13 | 14 | , NodeConfig (..) 15 | , PoolConfig (..) 16 | , BootstrapConfig (..) 17 | , MultiConfig (..) 18 | , DrawingConfig (..) 19 | 20 | , PrettyShow (..) 21 | 22 | ) where 23 | 24 | 25 | 26 | import Control.Concurrent.STM 27 | import Data.Set (Set, toList) 28 | import Data.Map (Map) 29 | import Data.Monoid 30 | import qualified Data.Text as T 31 | import Data.Word 32 | 33 | import Types.Signal 34 | import Types.Misc 35 | import Utilities.IOQueue (IOQueue) 36 | 37 | 38 | 39 | 40 | 41 | -- ############################################################################# 42 | -- ### Environment ########################################################### 43 | -- ############################################################################# 44 | 45 | 46 | 47 | -- | State of the local node. Consists of a variety of communication channels, 48 | -- the address of the node's server, and an initial program configuration. 49 | data Environment = Environment { 50 | 51 | -- Mutable environment 52 | 53 | -- | Neighbours the current node knows, and when they have last been 54 | -- sent a signal 55 | _downstream :: TVar (Map To Client) 56 | 57 | -- | Nodes the current node knows it's a downstream neighbour of, or 58 | -- equivalently the set of upstream neighbours of the current node. 59 | -- Also carries a timestamp to keep track of when the last signal was 60 | -- received. 61 | , _upstream :: TVar (Set From) 62 | 63 | -- | Channel read by all clients. Sending a signal here will 64 | -- semi-randomly reach one of them. 65 | , _st1c :: PChan NormalSignal 66 | 67 | -- | Queue read only by the IO thread, who executes the actions one 68 | -- by one. This prevents interleaved messages in concurrent settings. 69 | , _io :: IOQueue 70 | 71 | -- | Timestamped signals that have already been handled by the current 72 | -- node, and can thus be ignored if they come in again. 73 | , _handledFloods :: TVar (Set (Timestamp, FloodSignal)) 74 | -- Order of the tuple matters so that Timestamp is the 75 | -- most significant in the Set's Ord type, and 76 | -- Set.deleteMin works properly! 77 | 78 | -- | Own hostname/port 79 | , _self :: To 80 | 81 | -- | Local direct connection (LDC) to a node. Used by "NodePool". 82 | , _ldc :: Maybe (PChan NormalSignal) 83 | 84 | -- | Program start configuration 85 | , _config :: NodeConfig 86 | 87 | } 88 | 89 | 90 | 91 | 92 | 93 | -- ############################################################################# 94 | -- ### Configs ############################################################### 95 | -- ############################################################################# 96 | 97 | 98 | 99 | -- | Configuration parameters accessible before anything goes online. 100 | data NodeConfig = NodeConfig { 101 | 102 | _serverPort :: !Int -- ^ Port to open the server socket on 103 | 104 | , _maxNeighbours :: !Int -- ^ The maximum number of neighbours. No 105 | -- new ones will be accepted once it's 106 | -- full. 107 | 108 | , _minNeighbours :: !Int -- ^ The minimum number of neighbours. If 109 | -- the current number is smaller issue 110 | -- announce signals. 111 | 112 | , _maxChanSize :: !Int -- ^ How many entries the bounded 113 | -- communication channels can hold 114 | 115 | , _hardBounces :: !Word -- ^ Number of initial bounces 116 | 117 | , _acceptP :: !Double -- ^ Edge request acceptance probability 118 | -- for the second bounce phase. 119 | 120 | , _maxSoftBounces :: !Word -- ^ How many times a soft-bounced request 121 | -- is maximally relayed before it is 122 | -- rejected 123 | 124 | , _shortTickRate :: !Microseconds -- ^ Tick interval for "short" loops. 125 | 126 | , _mediumTickRate :: !Microseconds -- ^ Tick interval for "medium" loops, 127 | -- for example the client pool or the 128 | -- keep-alive loops. 129 | 130 | , _longTickRate :: !Microseconds -- ^ Tick interval for "long" loops. 131 | 132 | , _poolTimeout :: !Microseconds -- ^ Number of seconds before a 133 | -- non-responding node is considered 134 | -- gone 135 | 136 | , _verbosity :: !Verbosity -- ^ Determines quantity of messages 137 | -- printed 138 | 139 | , _bootstrapServers :: Set To -- ^ Addresses of bootstrap servers 140 | -- statically known 141 | 142 | , _floodMessageCache :: !Int -- ^ Number of past flood messages to 143 | -- store so duplicates can be discarded 144 | 145 | } deriving (Show) 146 | 147 | 148 | 149 | -- | Node pool configuration 150 | data PoolConfig = PoolConfig { 151 | 152 | _poolSize :: Int -- ^ Number of nodes in the server's pool 153 | 154 | } deriving (Show) 155 | 156 | 157 | 158 | -- | Configuration of the bootstrap server 159 | data BootstrapConfig = BootstrapConfig { 160 | 161 | _bootstrapconfigNodeConfig :: NodeConfig 162 | -- Lens will create 'nodeConfig' out of this, stripped of the lowercase 163 | -- prefix. 164 | 165 | , _bootstrapconfigPoolConfig :: PoolConfig 166 | -- dito 167 | 168 | , _restartEvery :: !Int -- ^ Every n bootstrap requests one client is 169 | -- restarted at random 170 | 171 | , _restartMinimumPeriod :: !Microseconds -- ^ Limit the maximal frequency 172 | -- at which restarts can happen 173 | 174 | } deriving (Show) 175 | 176 | 177 | 178 | -- | Multi client config 179 | data MultiConfig = MultiConfig { 180 | 181 | _multiconfigNodeConfig :: NodeConfig 182 | -- Lens will create 'nodeConfig' out of this, stripped of the lowercase 183 | -- prefix. 184 | 185 | , _multiconfigPoolConfig :: PoolConfig 186 | -- dito 187 | 188 | } deriving (Show) 189 | 190 | 191 | 192 | -- | Drawing server config 193 | data DrawingConfig = DrawingConfig { 194 | 195 | _drawingconfigNodeConfig :: NodeConfig 196 | -- Lens will create 'nodeConfig' out of this, stripped of the lowercase 197 | -- prefix. 198 | 199 | , _drawingconfigPoolConfig :: PoolConfig 200 | -- dito 201 | 202 | , _drawEvery :: !Microseconds -- ^ Interval for sending out neighbour list 203 | -- requests and drawing the currently 204 | -- known state of the network 205 | 206 | , _drawFilename :: FilePath -- ^ Filename for the @.dot@ file 207 | 208 | , _drawTimeout :: !Microseconds -- ^ If no new information is received 209 | -- within this timeout, the node will 210 | -- be considered dead and removed from 211 | -- the graph. 212 | 213 | } deriving (Show) 214 | 215 | 216 | 217 | -- | 'Show' for prettyprinting. 218 | class Show a => PrettyShow a where 219 | pretty :: a -> T.Text 220 | pretty = T.pack . show 221 | 222 | instance PrettyShow Int where 223 | pretty = pretty . (fromIntegral :: Int -> Integer) 224 | 225 | instance PrettyShow Word where 226 | pretty = pretty . (fromIntegral :: Word -> Integer) 227 | 228 | -- What a mess. Surely there's a better implementation. 229 | instance PrettyShow Integer where 230 | pretty = T.intercalate "," 231 | . reverse 232 | . map T.reverse 233 | . chunksOf 3 234 | . T.reverse 235 | . T.pack 236 | . show 237 | 238 | where chunksOf n xs = case T.splitAt n xs of 239 | (as, bs) | T.null bs -> [as] 240 | | otherwise -> as : chunksOf n bs 241 | 242 | instance PrettyShow Double 243 | instance PrettyShow Verbosity 244 | instance PrettyShow To 245 | instance PrettyShow Microseconds where 246 | pretty (Microseconds us) = pretty us <> " µs" 247 | 248 | instance Show a => PrettyShow (Set a) 249 | instance Show a => PrettyShow [a] 250 | 251 | 252 | instance PrettyShow NodeConfig where 253 | pretty cfg = (T.intercalate "\n" . map mconcat) 254 | [ ["Server port: " <> pretty (_serverPort cfg)] 255 | 256 | , [ "Min/max neighbours: " 257 | , pretty (_minNeighbours cfg) 258 | , "/" 259 | , pretty (_maxNeighbours cfg) 260 | ] 261 | 262 | , [ "Maximum channel size: " 263 | , pretty (_maxChanSize cfg) 264 | ] 265 | 266 | , [ "Hard bounces/" 267 | , "soft bounce acceptance probability/" 268 | , "maximum number of soft bounces: " 269 | , pretty (_hardBounces cfg) 270 | , "/" 271 | , pretty (_acceptP cfg) 272 | , "/" 273 | , pretty (_maxSoftBounces cfg) 274 | ] 275 | 276 | , [ "Tick rates (short/medium/long): " 277 | , pretty (_shortTickRate cfg) 278 | , "/" 279 | , pretty (_mediumTickRate cfg) 280 | , "/" 281 | , pretty (_longTickRate cfg) 282 | ] 283 | 284 | , [ "Pool timeout: " 285 | , pretty (_poolTimeout cfg) 286 | ] 287 | 288 | , [ "Verbosity: " 289 | , pretty (_verbosity cfg) 290 | ] 291 | 292 | , [ "Boostrap servers: " 293 | , pretty (toList (_bootstrapServers cfg)) 294 | ] 295 | 296 | , [ "Flood message cache size: " 297 | , pretty (_floodMessageCache cfg) 298 | ] 299 | ] 300 | 301 | instance PrettyShow PoolConfig where 302 | pretty cfg = "Node pool size: " <> pretty (_poolSize cfg) 303 | 304 | instance PrettyShow BootstrapConfig where 305 | pretty cfg = T.intercalate "\n" 306 | [ pretty (_bootstrapconfigNodeConfig cfg) 307 | , pretty (_bootstrapconfigPoolConfig cfg) 308 | , "Restart every number of bootstrap requests: " 309 | <> pretty (_restartEvery cfg) 310 | , "Minimum time between restarts: " 311 | <> pretty (_restartMinimumPeriod cfg) 312 | ] 313 | 314 | instance PrettyShow MultiConfig where 315 | pretty cfg = T.intercalate "\n" 316 | [ pretty (_multiconfigNodeConfig cfg) 317 | , pretty (_multiconfigPoolConfig cfg) 318 | ] 319 | 320 | instance PrettyShow DrawingConfig where 321 | pretty cfg = T.intercalate "\n" 322 | [ pretty (_drawingconfigNodeConfig cfg) 323 | , pretty (_drawingconfigPoolConfig cfg) 324 | , "Draw every µs: " <> pretty (_drawEvery cfg) 325 | , "Graph output filename: " <> pretty (_drawFilename cfg) 326 | , "Drawing node orphaned timeout: " <> pretty (_drawTimeout cfg) 327 | ] 328 | -------------------------------------------------------------------------------- /src/Config/CmdArgParser.hs: -------------------------------------------------------------------------------- 1 | -- | Parser for command line arguments. The idea is to use the parser to 2 | -- generate option modifier functions that can then be applied to the default 3 | -- options. 4 | -- 5 | -- This module is intended to be used qualified, e.g. as \"CmdArgParser\" to 6 | -- make nice names such as \"CmdArgParser.'nodeModifier'\". 7 | 8 | module Config.CmdArgParser ( 9 | nodeModifier 10 | , multiModifier 11 | , bootstrapModifier 12 | , drawingModifier 13 | ) where 14 | 15 | import Options.Applicative 16 | import Data.Monoid 17 | import Text.Printf 18 | import qualified Data.Set as Set 19 | import qualified Data.Traversable as T 20 | import Data.Char (toLower) 21 | import Text.Read (readEither) 22 | 23 | import Control.Lens 24 | 25 | import qualified Types as Ty 26 | import qualified Types.Lens as L 27 | import Config.OptionModifier 28 | import qualified Config.AddressParser as AddressParser 29 | 30 | 31 | 32 | runArgParser :: Parser a -- ^ Parser 33 | -> String -- ^ Short help description 34 | -> String -- ^ Long help description 35 | -> IO a 36 | runArgParser parser shortDescr longDescr = execParser parser' where 37 | parser' = info (helper <*> parser) infoMod 38 | infoMod = mconcat 39 | [ fullDesc 40 | , progDesc shortDescr 41 | , header longDescr 42 | ] 43 | 44 | 45 | 46 | nodeModifier :: IO (OptionModifier Ty.NodeConfig) 47 | nodeModifier = runArgParser nodeModifier' s l where 48 | s = "Amoeba client" 49 | l = "Launch a single node in an Amoeba network" 50 | 51 | 52 | 53 | multiModifier :: IO (OptionModifier Ty.MultiConfig) 54 | multiModifier = runArgParser multiModifier' s l where 55 | s = "Amoeba multi-node client" 56 | l = "Launch multiple independent Amoeba nodes" 57 | 58 | 59 | 60 | bootstrapModifier :: IO (OptionModifier Ty.BootstrapConfig) 61 | bootstrapModifier = runArgParser bootstrapModifier' s l where 62 | s = "Amoeba bootstrap server" 63 | l = "Start a bootstrap server to allow new nodes to\ 64 | \ connect to an existing network" 65 | 66 | 67 | 68 | drawingModifier :: IO (OptionModifier Ty.DrawingConfig) 69 | drawingModifier = runArgParser drawingModifier' s l where 70 | s = "Amoeba bootstrap server" 71 | l = "Start a bootstrap server to allow new nodes to connect to an\ 72 | \ existing network" 73 | 74 | 75 | 76 | -- ############################################################################# 77 | -- ### Parsers ############################################################### 78 | -- ############################################################################# 79 | 80 | 81 | 82 | nodeModifier' :: Parser (OptionModifier Ty.NodeConfig) 83 | nodeModifier' = (fmap mconcat . T.sequenceA) mods where 84 | mods = [ port 85 | , minNeighbours 86 | , maxNeighbours 87 | , maxChanSize 88 | , bounces 89 | , acceptP 90 | , maxSoftBounces 91 | , shortTickRate 92 | , mediumTickRate 93 | , longTickRate 94 | , poolTimeout 95 | , verbosity 96 | , bootstrapServer 97 | , floodCacheSize 98 | ] 99 | 100 | 101 | 102 | poolModifier' :: Parser (OptionModifier Ty.PoolConfig) 103 | poolModifier' = (fmap mconcat . T.sequenceA) mods where 104 | mods = [ poolSize ] 105 | 106 | 107 | 108 | bootstrapModifier' :: Parser (OptionModifier Ty.BootstrapConfig) 109 | bootstrapModifier' = (fmap mconcat . T.sequenceA) mods where 110 | mods = [ restartEvery 111 | , restartMinimumPeriod 112 | , liftModifier L.nodeConfig <$> nodeModifier' 113 | , liftModifier L.poolConfig <$> poolModifier' 114 | ] 115 | 116 | 117 | 118 | multiModifier' :: Parser (OptionModifier Ty.MultiConfig) 119 | multiModifier' = (fmap mconcat . T.sequenceA) mods where 120 | mods = [ liftModifier L.nodeConfig <$> nodeModifier' 121 | , liftModifier L.poolConfig <$> poolModifier' 122 | ] 123 | 124 | 125 | 126 | drawingModifier' :: Parser (OptionModifier Ty.DrawingConfig) 127 | drawingModifier' = (fmap mconcat . T.sequenceA) mods where 128 | mods = [ liftModifier L.nodeConfig <$> nodeModifier' 129 | , liftModifier L.poolConfig <$> poolModifier' 130 | , drawingInterval 131 | , drawingFilename 132 | , drawingTimeout 133 | ] 134 | 135 | 136 | 137 | -- ############################################################################# 138 | -- ### Parser bits ########################################################### 139 | -- ############################################################################# 140 | 141 | 142 | 143 | defaultValue :: Monoid m => Parser m 144 | defaultValue = pure mempty 145 | 146 | 147 | 148 | -- | Convert a field and a value to an 'OptionModifier' to set that field to 149 | -- that value. 150 | toSetter :: ASetter a a c b -- ^ Lens to a field 151 | -> b -- ^ New value of the field 152 | -> OptionModifier a -- ^ 'OptionModifier' to apply the lens 153 | toSetter l x = OptionModifier (l .~ x) 154 | 155 | 156 | 157 | port :: Parser (OptionModifier Ty.NodeConfig) 158 | port = v <|> defaultValue where 159 | v = toSetter L.serverPort <$> (option . mconcat) 160 | [ long "port" 161 | , short 'p' 162 | , metavar "PORT" 163 | , help "Server port" 164 | ] 165 | 166 | 167 | 168 | restartEvery :: Parser (OptionModifier Ty.BootstrapConfig) 169 | restartEvery = v <|> defaultValue where 170 | v = toSetter L.restartEvery <$> (nullOption . mconcat) 171 | [ reader positive 172 | , long "restart-every" 173 | , metavar "(Int > 0)" 174 | , help "Restart a random pool node every n new nodes." 175 | , hidden 176 | ] 177 | 178 | 179 | 180 | 181 | drawingInterval :: Parser (OptionModifier Ty.DrawingConfig) 182 | drawingInterval = v <|> defaultValue where 183 | v = toSetter L.drawEvery <$> (nullOption . mconcat) 184 | [ reader positive 185 | , long "draw-every" 186 | , metavar "[µs]" 187 | , help "Tickrate for drawing the current network to file\ 188 | \ and sending out neighbour information requests." 189 | , hidden 190 | ] 191 | 192 | 193 | 194 | drawingTimeout :: Parser (OptionModifier Ty.DrawingConfig) 195 | drawingTimeout = v <|> defaultValue where 196 | v = toSetter L.drawTimeout . fromIntegral <$> (nullOption . mconcat) 197 | [ reader (positive :: String -> ReadM Integer) 198 | , long "draw-timeout" 199 | , metavar "[µs]" 200 | , help "Timeout for removing nodes that haven't sent data to the\ 201 | \ drawing server" 202 | , hidden 203 | ] 204 | 205 | 206 | 207 | drawingFilename :: Parser (OptionModifier Ty.DrawingConfig) 208 | drawingFilename = v <|> defaultValue where 209 | v = toSetter L.drawFilename <$> (strOption . mconcat) 210 | [ long "drawing-filename" 211 | , metavar "(filename)" 212 | , help "File to write the network data to" 213 | ] 214 | 215 | 216 | 217 | restartMinimumPeriod :: Parser (OptionModifier Ty.BootstrapConfig) 218 | restartMinimumPeriod = v <|> defaultValue where 219 | v = toSetter L.restartMinimumPeriod <$> (nullOption . mconcat) 220 | [ reader positive 221 | , long "restart-minperiod" 222 | , metavar "[µs]" 223 | , help "Restart a random pool node every n new nodes.\ 224 | \ (Note that a restart is one new node by itself\ 225 | \ already.)" 226 | , hidden 227 | ] 228 | 229 | 230 | 231 | poolSize :: Parser (OptionModifier Ty.PoolConfig) 232 | poolSize = v <|> defaultValue where 233 | v = toSetter L.poolSize <$> (nullOption . mconcat) 234 | [ reader positive 235 | , long "poolsize" 236 | , short 'n' 237 | , metavar "(Int > 0)" 238 | , help "Number of nodes in the pool" 239 | ] 240 | 241 | 242 | 243 | minNeighbours :: Parser (OptionModifier Ty.NodeConfig) 244 | minNeighbours = v <|> defaultValue where 245 | v = toSetter L.minNeighbours <$> (nullOption . mconcat) 246 | [ reader positive 247 | , long "minn" 248 | , metavar "(Int > 0)" 249 | , help "Minimum amount of neighbours (up-/downstream\ 250 | \ separate)" 251 | ] 252 | 253 | 254 | 255 | maxNeighbours :: Parser (OptionModifier Ty.NodeConfig) 256 | maxNeighbours = v <|> defaultValue where 257 | v = toSetter L.maxNeighbours <$> (nullOption . mconcat) 258 | [ reader positive 259 | , long "maxn" 260 | , metavar "(Int > 0)" 261 | , help "Maximum amount of neighbours (up-/downstream\ 262 | \ separate)" 263 | ] 264 | 265 | 266 | maxChanSize :: Parser (OptionModifier Ty.NodeConfig) 267 | maxChanSize = v <|> defaultValue where 268 | v = toSetter L.maxChanSize <$> (nullOption . mconcat) 269 | [ reader positive 270 | , long "chansize" 271 | , metavar "(Int > 0)" 272 | , help "Maximum communication channel size" 273 | , hidden 274 | ] 275 | 276 | 277 | floodCacheSize :: Parser (OptionModifier Ty.NodeConfig) 278 | floodCacheSize = v <|> defaultValue where 279 | v = toSetter L.floodMessageCache <$> (nullOption . mconcat) 280 | [ reader nonnegative 281 | , long "floodcache" 282 | , metavar "(Int >= 0)" 283 | , help "Number of past flood messages to cache" 284 | , hidden 285 | ] 286 | 287 | 288 | bounces :: Parser (OptionModifier Ty.NodeConfig) 289 | bounces = v <|> defaultValue where 290 | v = toSetter L.hardBounces <$> (nullOption . mconcat) 291 | [ reader nonnegative 292 | , long "hardbounces" 293 | , metavar "(Int >= 0)" 294 | , help "Minimum edge search hard bounces" 295 | , hidden 296 | ] 297 | 298 | 299 | maxSoftBounces :: Parser (OptionModifier Ty.NodeConfig) 300 | maxSoftBounces = v <|> defaultValue where 301 | v = toSetter L.maxSoftBounces <$> (nullOption . mconcat) 302 | [ reader positive 303 | , long "hbounce" 304 | , metavar "(Int > 0)" 305 | , help "Maximum edge search soft bounces" 306 | , hidden 307 | ] 308 | 309 | 310 | acceptP :: Parser (OptionModifier Ty.NodeConfig) 311 | acceptP = v <|> defaultValue where 312 | v = toSetter L.acceptP <$> (nullOption . mconcat) 313 | [ reader probability 314 | , long "acceptp" 315 | , metavar "(0 < p <= 1)" 316 | , help "Edge request soft bounce acceptance probability" 317 | , hidden 318 | ] 319 | 320 | 321 | shortTickRate :: Parser (OptionModifier Ty.NodeConfig) 322 | shortTickRate = v <|> defaultValue where 323 | v = toSetter L.shortTickRate <$> (nullOption . mconcat) 324 | [ reader positive 325 | , long "stick" 326 | , metavar "[µs]" 327 | , help "Tick rate of short loops" 328 | , hidden 329 | ] 330 | 331 | 332 | mediumTickRate :: Parser (OptionModifier Ty.NodeConfig) 333 | mediumTickRate = v <|> defaultValue where 334 | v = toSetter L.mediumTickRate <$> (nullOption . mconcat) 335 | [ reader positive 336 | , long "mtick" 337 | , metavar "[µs]" 338 | , help "Tick rate of medium loops" 339 | , hidden 340 | ] 341 | 342 | 343 | longTickRate :: Parser (OptionModifier Ty.NodeConfig) 344 | longTickRate = v <|> defaultValue where 345 | v = toSetter L.longTickRate <$> (nullOption . mconcat) 346 | [ reader positive 347 | , long "ltick" 348 | , metavar "[µs]" 349 | , help "Tick rate of long loops" 350 | , hidden 351 | ] 352 | 353 | 354 | poolTimeout :: Parser (OptionModifier Ty.NodeConfig) 355 | poolTimeout = v <|> defaultValue where 356 | v = toSetter L.poolTimeout <$> (nullOption . mconcat) 357 | [ reader positive 358 | , long "timeout" 359 | , metavar "[µs]" 360 | , help "Timeout for removal of nodes from the USN/DSN pool" 361 | , hidden 362 | ] 363 | 364 | 365 | verbosity :: Parser (OptionModifier Ty.NodeConfig) 366 | verbosity = v <|> defaultValue where 367 | v = toSetter L.verbosity <$> (nullOption . mconcat) 368 | [ reader readVerbosity 369 | , long "verbosity" 370 | , metavar "(mute|quiet|default|debug|chatty)" 371 | , help "Verbosity level, increasing from left to right" 372 | ] 373 | 374 | 375 | 376 | -- | Append arg parsed BSS address to config 377 | bootstrapServer :: Parser (OptionModifier Ty.NodeConfig) 378 | bootstrapServer = v <|> defaultValue where 379 | v = appendBSS <$> (nullOption . mconcat) 380 | [ reader readAddress 381 | , long "bootstrap" 382 | , metavar "(hostname)" 383 | , help "Bootstrap server address" 384 | ] 385 | appendBSS x = OptionModifier (L.bootstrapServers <>~ x) 386 | 387 | 388 | 389 | 390 | 391 | -- ############################################################################# 392 | -- ### Readers ############################################################### 393 | -- ############################################################################# 394 | 395 | 396 | 397 | -- | Numerical value between 0 and 1 (inclusive) 398 | probability :: (Num a, Ord a, Read a) => String -> ReadM a 399 | probability x = case readEither x of 400 | Right y | y >= 0 && y <= 1 -> pure y 401 | Right _ -> readerError (printf "Bad probability %s; 0 <= p <= 1" x) 402 | Left _ -> readerError (printf "Parse error on double %s" x) 403 | 404 | 405 | 406 | -- | Strictly positive numerical value 407 | positive :: (Num a, Ord a, Read a) => String -> ReadM a 408 | positive x = case readEither x of 409 | Right y | y > 0 -> pure y 410 | Right _ -> readerError (printf "Positive number expected (%s given)" x) 411 | Left _ -> readerError (printf "Parse error on integer %s" x) 412 | 413 | 414 | 415 | -- | Non-negative numerical value 416 | nonnegative :: (Num a, Ord a, Read a) => String -> ReadM a 417 | nonnegative x = case readEither x of 418 | Right y | y >= 0 -> pure y 419 | Right _ -> readerError (printf "Nonnegative number expected (%s given)" x) 420 | Left _ -> readerError (printf "Parse error on integer %s" x) 421 | 422 | 423 | 424 | readVerbosity :: String -> ReadM Ty.Verbosity 425 | readVerbosity x = case map toLower x of 426 | "mute" -> pure Ty.Mute 427 | "quiet" -> pure Ty.Quiet 428 | "default" -> pure Ty.Default 429 | "debug" -> pure Ty.Debug 430 | "chatty" -> pure Ty.Chatty 431 | _else -> readerError (printf "Unrecognized verbosity level \"%d\"" x) 432 | 433 | 434 | 435 | readAddress :: String -> ReadM (Set.Set Ty.To) 436 | readAddress s = case AddressParser.parseAddress s of 437 | Left e -> readerError ("Bad address: " ++ show e) 438 | Right addr -> pure (Set.singleton addr) 439 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Amœba 2 | ====== 3 | 4 | Amœba is a program for setting up a distributed network. The name comes from 5 | the hope that eventually, the network will be so robust that you can poke any of 6 | its parts without endangering its overall integrity. 7 | 8 | This is how a small network looks like. It consists of 359 nodes, each trying to 9 | maintain 5-10 incoming and outgoing connections. Initially, three independent 10 | clusters were created; the last 30 nodes knew of these clusters and joined them 11 | together over the course of a minute. Darker colours indicate a more central 12 | role of a node in the network ([betweenness centrality][wiki-betweenness]). 13 | Click for higher resolution. 14 | 15 | [![(Picture missing, uh oh)](doc/network_example.png)][network-hires] 16 | 17 | [network-hires]: doc/network_example_hires_amoeba_n359_5-10-3cluster.png 18 | 19 | 20 | 21 | The current development stage is unstable alpha. 22 | 23 | Branch | Status 24 | :-----: | :-----: 25 | master | [![(Travis image broken)](https://travis-ci.org/quchen/amoeba.png?branch=master)][travis] 26 | develop | [![(Travis image broken)](https://travis-ci.org/quchen/amoeba.png?branch=develop)][travis] 27 | 28 | 29 | 30 | [travis]: https://travis-ci.org/quchen/amoeba 31 | [wiki-betweenness]: http://en.wikipedia.org/wiki/Betweenness_centrality 32 | 33 | 34 | 35 | 36 | 37 | Explanation in simple terms 38 | --------------------------- 39 | 40 | (This section is for you if you're wondering what the fuzz about the above 41 | crumbled up piece of strings and dots is.) 42 | 43 | I was always superficially fascinated by complex systems and networks, most 44 | notably by what is called *emergence*: the appearance of complex behaviour in 45 | systems made up from simple rules. A single ant does not do anything complex, 46 | and neither do ten of them. Put a thousand together though and you will discover 47 | that, although each is still individually doing the same things as before, it 48 | will amount to something much bigger than what you would have expected from the 49 | individual: complex structures of air tunnels or [fungus farms][leafcutter]. 50 | Another example is any living organism: even if you understood how every cell 51 | worked exactly, you still would have no idea about whether (or why) putting them 52 | together in some way can make up the organism that I am right now, typing this 53 | paragraph. 54 | 55 | Networks also exhibit a lot of emergent properties, and contrary to living 56 | organisms they are much more suitable to being simulated and applied by 57 | computers. A network in this sense is simply a number of constituents with 58 | connections to other constituents. These networks can consist of people (where 59 | conncetions can be "who likes who" or "have met each other at some point"), 60 | computers ("connected over the internet", "contains parts made by the same 61 | manufacturer"), languages ("what words can be used after others") and many other 62 | things. 63 | 64 | Amœba is a program that creates a computer network. I came up with the idea 65 | around the time of the first Bitcoin boom in 2013; the Torrent network did also 66 | seem somewhat interesting to me. So I thought "why not implement a basic version 67 | of something like that yourself?" - generously estimating 500 lines of code to 68 | get the core done. Months and thousands of lines of code added/removed/edited 69 | later, a satisfying first version is still just barely on the horizon, but it's 70 | finished enough to be able to play around with it. The "crumbled up piece of 71 | strings and dots" above is a snapshot of an Amœba network, a few seconds before 72 | I terminated half of it to see whether it would survive that without clustering 73 | into many disconnected components. Research has begun! :-) 74 | 75 | [leafcutter]: https://en.wikipedia.org/wiki/Leaf_cutter_ant 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | Planned features 84 | ---------------- 85 | 86 | - Anonymity: every node only knows about its immediate neighbours. Unless 87 | explicitly added, the origin of a signal sent over the network is untraceable. 88 | 89 | - The network should be as robust as possible against malicious participants. 90 | 91 | - Even large network outages should not lead to disconnected components. 92 | 93 | - Neat live graph drawing to have a global view of the entire network (or at 94 | least the nodes choosing to be published). 95 | 96 | Also see the [issues list][issues] on GitHub. 97 | 98 | [issues]: https://github.com/quchen/amoeba/issues 99 | 100 | 101 | 102 | 103 | 104 | Research goals 105 | -------------- 106 | 107 | - Structure 108 | 109 | - What node degrees are necessary for a robust network? 110 | 111 | - How long, if possible, does it take an almost dead node to heal again? 112 | 113 | - How does the network diameter scale with number of participants? This is 114 | important to ensure the shortest paths between arbitrary nodes stay short, 115 | ensuring fast message delivery. 116 | 117 | - What are the timescales for bootstrapping the network, adding or removing 118 | one node or many nodes? 119 | 120 | - How do two disconnected network components meld together when a connection 121 | is introduced? 122 | 123 | - Integrity 124 | 125 | - What attacks can be prevented by design? 126 | 127 | - Worst case scenarios: what are malicious participants allowed to do? 128 | 129 | 130 | These goals are subject to certain constraints: 131 | 132 | - A node only knows its immediate neighbours. (No global knowledge hacks.) 133 | 134 | - Network dynamics are static: a link is only broken by technical failure, and 135 | not as part of the network dynamics. 136 | 137 | 138 | 139 | 140 | 141 | Network description 142 | ------------------- 143 | 144 | 145 | ![(Picture missing, uh oh)](doc/network_schema.png 146 | "Network structure of a small system") 147 | 148 | The picture shows the network structure of a small Amœba network. Blue arrows 149 | are ordinary connections, while red ones stand for local direct connections, 150 | used by special network services. 151 | 152 | 153 | 154 | ### Normal nodes 155 | 156 | - All nodes run identical programs. 157 | 158 | - Each node has a number of upstream and downstream neighbours, which are 159 | allowed to send data to the current node, or accept data sent by it, 160 | respectively. It has no knowledge about the network other than its neighbours. 161 | 162 | - Nodes have a minimum and maximum number of neighbours for both upstream and 163 | downstream connections (independent of each other). If there is a deficit of 164 | connections, nodes will request new neighbours from the network; if there is a 165 | surplus, no new connections will be accepted; if there is neither, no requests 166 | will be sent, but incoming requests will be processed. 167 | 168 | - If a node has a deficit in connections, it will randomly tell one of its 169 | neighbours of it. This is called an *edge request*, and contains its own 170 | address, and parameters determining how far the request should travel through 171 | the network. The edge request is relayed by receiving nodes a number of times, 172 | passing it on to one of their own downstream neighbours, until eventually one 173 | of them accepts the request, and establishes the desired connection with the 174 | initially issuing node. 175 | 176 | The number of edge requests depending on the deficit is currently a simple 177 | square root: 178 | 179 | ![(Picture missing, uh oh)](doc/request_per_deficit_function.png) 180 | 181 | - Nodes will attempt to minimize the number of connections above the minimum by 182 | *pruning*. They will do so by telling downstream neighbours of their wish to 183 | drop the connection, which will be accepted if this can be done without making 184 | the partner go below the minimum limit. 185 | 186 | - Initial connection is made using a special bootstrap service, see the section 187 | below. 188 | 189 | - To look at the large scale structure of the network, a special request can be 190 | made by a special graph plot server. This request makes every client send a 191 | list of all its neighbours to the plot server. (This is strictly a debugging 192 | tool, since it opens the door for a truckload of attacks.) 193 | 194 | 195 | 196 | ### Special services 197 | 198 | A central point in node design is that they reject signals from unregistered 199 | origins, so that spamming a single node from outside does not affect the network 200 | at all. 201 | 202 | However, this is sometimes too restrictive: for some services, it makes sense to 203 | be able to issue signals, despite them not being part of the network. To solve 204 | this problem, nodes can be spawned with a special direct communication channel 205 | that can be used to send messages to it directly. 206 | 207 | 208 | 209 | #### Bootstrap server 210 | 211 | A bootstrap server is the first contact a node makes after startup, and issues 212 | edge requests on behalf of its client. 213 | 214 | 215 | 216 | #### Drawing server 217 | 218 | The drawing server's purpose is creating a map of the network to study its 219 | structure. Issues a signal that makes every (willing) node of the network send 220 | it a list of their downstream neighbours. 221 | 222 | 223 | 224 | 225 | 226 | Known vulnerabilities and immunities 227 | ------------------------------------ 228 | 229 | This is a list of known and feasible attacks on the current design: 230 | 231 | - Malicious single nodes 232 | 233 | - DDoS: Spamming the network with loads of trashy messages. Especially 234 | flooding signals (such as text messages) have a very large impact compared 235 | to the single signal they are issued with. Furthermore messages are 236 | anonymous, so if you have N neighbours, you can at least send N messages per 237 | malicious node without any possible spam protection being able to jump in. 238 | 239 | - Spamming the bootstrap server with requests yields an arbitrary amount of 240 | new edge requests, allowing a node to quickly connect to a large part of the 241 | network. 242 | 243 | - The drawing server capabilities are currently available to everyone, and not 244 | just legitimate drawing servers. In other words, getting a list of all nodes 245 | is trivial. 246 | 247 | - *Resistent*: SlowLoris attacks. Since signal sizes are relatively small, 248 | connection timeouts can be short. 249 | 250 | - Node crawling: Although nodes only retain the addresses of downstream 251 | neighbours (remember the upstream connection is one-way, clients will not 252 | send or handle signals issued the wrong way), edge requests carry valid 253 | server addresses and traverse part of the network before they are accepted. 254 | Specialized nodes could simply store all valid addresses they encounter. 255 | This is completely undetectable by other nodes and, while not dangerous on 256 | its own, can lead to knowledge about all of the network's participants. The 257 | node database could be shared with malicious nodes that could harness that 258 | information for attacks on the network. 259 | 260 | - There is no message size limit at the moment. A node will read incoming data 261 | until the connection for a single signal times out. 262 | 263 | - Malicious sub-networks 264 | 265 | - Nodes accepting all edge requests they encounter can build up a connection 266 | to a large portion of the network. This opens the door for new attacks: 267 | 268 | - Filtering: Certain signals could be thrown away, for example edge requests 269 | from a certain IP range so that no new nodes can connect to the network 270 | 271 | - Altering signals 272 | 273 | - A test where two neighbours compare some of their neighbours and drop common 274 | ones could battle the possibility of nodes gathering up too many connections 275 | illegally. 276 | 277 | - Bootstrap takeover: if an attacker manages to replace all neighbours (both 278 | up- and downstream) of a bootstrap server's pool, all new nodes connecting 279 | via that server will be relayed into the malicious network. 280 | 281 | - Malicious swarms - right now it's trivial to spawn thousands of new nodes 282 | simultaneously. No matter how many honest nodes there are, it is very easy to 283 | drown them in a network controlled by a few actors behaving like they are 284 | many. 285 | 286 | - Killing all bootstrap servers makes it impossible to discover the network. 287 | 288 | 289 | 290 | 291 | 292 | Documentation 293 | ------------- 294 | 295 | 296 | 297 | ### Client structure 298 | 299 | The picture below sketches the flow of information in a single Amœba client. 300 | 301 | - Network connections are shown in red. Nodes first connect to another node's 302 | server (dashed red), which then relays them to their own private worker in the 303 | target node (by spawning a new worker, yellow dashed), at which point the data 304 | flows directly from node to worker. 305 | 306 | - Workers take input from upstream nodes and formulate a response based on them. 307 | This response is then sent over the internal channels (blue) to the clients. 308 | 309 | - Clients have persistent connections to downstream neighbours open (red network 310 | connections), and send the instructions received from the channels to them. 311 | 312 | - The client pool watches internal databases to determine whether there are 313 | enough workers and clients. If not, it instructs existing clients to send 314 | requests for further neighbours. 315 | 316 | ![(Picture missing, uh oh)](doc/information_flow.png 317 | "Flow of information in an Amœba client") 318 | 319 | 320 | 321 | ### The protocol 322 | 323 | The protocol type used by Amœba can be found in `src/Types/Signal.hs`. All 324 | signals are sent downstream, with one exception where relevant data actually 325 | flows upstream. Unless otherwise noted, the server answers signals with a 326 | `ServerSignal`, which can basically be `OK` or one of multiple possible errors. 327 | A usual request consists of a node sending a signal downstream and waiting for 328 | the response, terminating the worker if it is not positive. 329 | 330 | Signals are divided in two main groups, normal and special. Normal signals are 331 | what usual nodes routinely use: 332 | 333 | - `EdgeRequest` contains information for establishing a new edge in the network 334 | - `KeepAlive` is sent in case there haven't been any useful signals, but the 335 | connection should not time out 336 | - `ShuttingDown` is sent as a courtesy to other nodes, so they can remove a 337 | terminating node before the timeout kicks in 338 | - `Flood` signals are distributed to every node in the network. Current 339 | instances are text messages and a request to send a `NeighbourList` to a 340 | drawing server. 341 | - `Prune` is a request to downstream neighbours to drop the connection. This is 342 | an effort to keep the number of connections as low as possible, and the 343 | request will be accepted if dropping the connection does not cross the minimum 344 | threshold. 345 | 346 | Normal signals are filtered: only when they're coming from known upstream nodes 347 | they are processed. Special signals circumvent this, as some processes 348 | inherently require unknown nodes to establish connections. 349 | 350 | - `BootstrapRequest` is sent to the bootstrap server, and instructs it to send 351 | out `EdgeRequest`s on behalf of the contacting node. 352 | - `Handshake` is what actually establishes a new connection. Sent to a new 353 | downstream neighbour, it adds the issuer to its list of known nodes and 354 | answers with `OK`; the issuer then does its own bookkeeping, and answers back 355 | `OK` as well, finalizing the deal with mutual agreement. 356 | - `HandshakeRequest`s prompt another node to send back a `Handshake`. This 357 | allows `Handshake` to be used to establish incoming connections, not just 358 | outgoing ones by sending it directly. 359 | - `NeighbourList` is sent from nodes to the drawing server. It contains the list 360 | of downstream neighbours. 361 | 362 | 363 | 364 | ### Terminology, abbreviations 365 | 366 | These may help reading the source comments: 367 | 368 | Name | Meaning 369 | -----------: | ----------------------------------------------------------------- 370 | _* | Accessor functions that don't do any computation otherwise. When dependencies permit, the lenses generated from these are used. 371 | *H | Handler. Signals or commands are delegated to these for processing. 372 | BSS | Bootstrap server 373 | DSN | Downstream node, i.e. a neighbouring node the current sends commands do. (S, T, U in the picture above.) 374 | LDC | Local direct connection. Used by the node pool to send signals directly to its nodes instead of taking a detour over the network. 375 | ST1C | Server to one (unspecified/arbitrary) client channel 376 | STC | Server to client channel 377 | STSC | Server to specific client channel 378 | USN | Upstream node, i.e. a neighbouring node the current gets commands sent by. (A, B, C in the picture above.) 379 | 380 | Sometimes, I like to use capital letters at the end of identifiers to tag 381 | functions with a purpose. This is usually local to a single module. If you see 382 | suspiciously looking names like `fooX` or `barL`, have a look at the module's 383 | head comment. -------------------------------------------------------------------------------- /src/Server.hs: -------------------------------------------------------------------------------- 1 | -- | The server is the main part of a node. It accepts incoming requests, and 2 | -- distributes the responses to the clients. 3 | -- 4 | -- The suffix \"H\" stands for "Handler", which is a function that reacts 5 | -- directly to an incoming signal's instructions. 6 | 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE TupleSections #-} 9 | {-# LANGUAGE ViewPatterns #-} 10 | {-# OPTIONS_HADDOCK show-extensions #-} 11 | 12 | module Server (server) where 13 | 14 | import Control.Applicative 15 | import Control.Concurrent.Async 16 | import Control.Concurrent.STM 17 | import Control.Exception 18 | import Control.Monad 19 | import qualified Data.Foldable as F 20 | import System.Random 21 | import Text.Printf 22 | 23 | import Pipes 24 | import Pipes.Network.TCP (Socket) 25 | import qualified Pipes.Concurrent as P 26 | import qualified Pipes.Network.TCP as PN 27 | import qualified Pipes.Prelude as P 28 | 29 | import Control.Lens.Operators 30 | import qualified Control.Lens as L 31 | import qualified Types.Lens as L 32 | 33 | import Client 34 | import Types 35 | import Utilities 36 | 37 | 38 | 39 | server :: Environment 40 | -> Socket -- ^ Socket to listen on 41 | -> IO () 42 | server env serverSocket = do 43 | 44 | -- The counter will assign each node a unique name. 45 | counter <- newTVarIO 0 46 | 47 | withAsync (workerLdc env) $ \_ldcThread -> forever $ do 48 | 49 | from <- atomically $ do 50 | c <- readTVar counter 51 | modifyTVar' counter (+1) 52 | return (From c) 53 | 54 | PN.acceptFork serverSocket $ \(clientSocket, addr) -> do 55 | (atomically . toIO env Debug . STDLOG) 56 | (printf "New worker %s from %s" 57 | (show from) 58 | (show addr)) 59 | terminationReason <- worker env from clientSocket 60 | (atomically . toIO env Debug . STDLOG) 61 | (printf "Worker %s from %s terminated (%s)" 62 | (show from) 63 | (show addr) 64 | (show terminationReason)) 65 | 66 | 67 | 68 | -- | Handles 'Signal's coming in from the network and sends back the server's 69 | -- response. 70 | worker :: Environment 71 | -> From -- ^ Unique worker ID 72 | -> Socket -- ^ Incoming connection 73 | -> IO ServerResponse 74 | worker env from socket = 75 | 76 | (`finally` release) . runEffect $ receiver tout socket 77 | >-> dispatch 78 | >-> terminator 79 | >-> sender tout socket 80 | 81 | where 82 | 83 | tout = env ^. L.config . L.poolTimeout 84 | 85 | dispatch :: Pipe Signal ServerResponse IO r 86 | dispatch = P.mapM $ \case 87 | Normal normal -> normalH env from normal 88 | Special special -> specialH env from socket special 89 | 90 | -- Pipes incoming signals on, but terminates afterwards if the last 91 | -- one was an error. In other words it's similar P.takeWhile, but 92 | -- passes on the first failing element before returning it. 93 | terminator :: Pipe ServerResponse ServerResponse IO ServerResponse 94 | terminator = do 95 | signal <- await 96 | yield signal 97 | case signal of 98 | OK -> terminator 99 | err -> return err 100 | 101 | release = atomically (deleteUsn env from) 102 | 103 | 104 | 105 | -- | Handles "Signal"s coming in from the LDC (local direct connection). 106 | -- Used by node pools; only accepts a handful of signals. 107 | workerLdc :: Environment 108 | -> IO () 109 | workerLdc env@(L.view L.ldc -> Just ldc) = 110 | 111 | runEffect (input >-> dispatch >-> P.drain) 112 | -- Since there is no USN to send the 113 | -- ServerResponse back to, discard 114 | -- the answers to LDC signals. 115 | 116 | where 117 | 118 | input :: Producer NormalSignal IO () 119 | input = P.fromInput (ldc ^. L.pInput) 120 | 121 | dispatch :: Pipe NormalSignal ServerResponse IO r 122 | dispatch = P.mapM $ \case 123 | EdgeRequest to edge -> edgeBounceH env to edge 124 | Flood tStamp fSignal -> floodSignalH env (tStamp, fSignal) 125 | _else -> return (Error "Bad LDC signal") 126 | 127 | workerLdc _noLdc = return () 128 | 129 | 130 | 131 | -- | Handle normal signals, as sent by an upstream neighbour. ("non-normal" 132 | -- signals include bootstrap requests and the like.) 133 | normalH :: Environment 134 | -> From 135 | -> NormalSignal 136 | -> IO ServerResponse 137 | normalH env from signal = 138 | atomically (isUsn env from) >>= \case True -> continue 139 | False -> deny 140 | 141 | where 142 | 143 | continue = case signal of 144 | EdgeRequest to edge -> edgeBounceH env to edge 145 | Flood tStamp fSignal -> floodSignalH env (tStamp, fSignal) 146 | KeepAlive -> keepAliveH env from 147 | ShuttingDown -> shuttingDownH env from 148 | Prune -> pruneH env 149 | 150 | deny = do 151 | atomically . toIO env Debug . STDLOG $ 152 | "Illegally contacted by " ++ show from ++ "; ignoring" 153 | return Ignore 154 | 155 | 156 | 157 | -- | Handler for special signals, such as "BootstrapRequest"s and "Handshake"s. 158 | specialH :: Environment 159 | -> From 160 | -> Socket 161 | -> SpecialSignal 162 | -> IO ServerResponse 163 | specialH env from socket signal = case signal of 164 | BootstrapRequest {} -> illegalBootstrapSignalH env 165 | NeighbourList {} -> illegalNeighbourListSignalH env 166 | Handshake -> incomingHandshakeH env from socket 167 | HandshakeRequest to -> do void (async (Client.startHandshakeH env to)) 168 | return OK 169 | -- NB: The above async terminates when the 170 | -- worker created by it does, or is not 171 | -- created at all. See 172 | -- 'Client.startHandshakeH'. 173 | 174 | 175 | 176 | -- | Print a log message and generate an "Illegal" "ServerResponse". 177 | illegal :: Environment 178 | -> String 179 | -> IO ServerResponse 180 | illegal env msg = do (atomically . toIO env Debug . STDLOG) msg 181 | return Illegal 182 | 183 | 184 | 185 | illegalBootstrapSignalH :: Environment 186 | -> IO ServerResponse 187 | illegalBootstrapSignalH env = 188 | illegal env "BootstrapRequest signal received on a normal server" 189 | 190 | 191 | 192 | illegalNeighbourListSignalH :: Environment 193 | -> IO ServerResponse 194 | illegalNeighbourListSignalH env = 195 | illegal env "NeighbourList signal received on a normal server" 196 | 197 | 198 | 199 | -- | Acknowledges an incoming KeepAlive signal, which is effectively a no-op, 200 | -- apart from that it (like any other signal) refreshes the "last heard of 201 | -- timestamp" via the check in "normalH". 202 | keepAliveH :: Environment 203 | -> From 204 | -> IO ServerResponse 205 | keepAliveH env from = do 206 | (atomically . toIO env Chatty . STDLOG) 207 | (printf "KeepAlive signal received from %s" 208 | (show from)) 209 | -- This is *very* chatty, probably too much so. 210 | return OK 211 | 212 | 213 | 214 | -- | Check whether a "FloodSignal" has already been received; execute and 215 | -- redistribute it if not. 216 | floodSignalH :: Environment 217 | -> (Timestamp, FloodSignal) 218 | -> IO ServerResponse 219 | floodSignalH env tfSignal@(timestamp, fSignal) = do 220 | 221 | knownIO <- atomically $ do 222 | knownSTM <- knownFlood env tfSignal 223 | when (not knownSTM) $ do 224 | insertFlood env tfSignal 225 | 226 | -- Broadcast message to all downstream neighbours 227 | broadcast <- broadcastOutput env 228 | void (P.send broadcast 229 | (Flood timestamp fSignal)) 230 | return knownSTM 231 | 232 | case (knownIO, fSignal) of 233 | (True, _) -> return OK 234 | (_, SendNeighbourList painter) -> neighbourListH env painter 235 | (_, TextMessage message) -> textMessageH env message 236 | 237 | 238 | 239 | -- | Retrieve all STSC (server-to-single-client) "P.Output"s and concatenate 240 | -- them to a single broadcast channel. 241 | broadcastOutput :: Environment 242 | -> STM (P.Output NormalSignal) 243 | broadcastOutput env = 244 | F.foldMap (^. L.stsc . L.pOutput) <$> (env ^. L.downstream . L.to readTVar) 245 | 246 | 247 | 248 | -- | Print a text message 249 | textMessageH :: Environment 250 | -> String 251 | -> IO ServerResponse 252 | textMessageH env msg = do 253 | atomically (toIO env Quiet (STDOUT msg)) 254 | return OK 255 | 256 | 257 | 258 | -- | Send a list of neighbours to the painting server. 259 | neighbourListH :: Environment 260 | -> To 261 | -> IO ServerResponse 262 | neighbourListH env painter = do 263 | let tout = env ^. L.config . L.poolTimeout 264 | connectToNode painter $ \(socket, _) -> do 265 | atomically (toIO env Chatty (STDLOG "Processing painter request")) 266 | let self = env ^. L.self 267 | dsns <- atomically (dumpDsnDB env) 268 | send tout socket (NeighbourList self dsns) 269 | return OK 270 | 271 | 272 | 273 | -- | An upstream neighbour is shutting down; terminate the local worker. 274 | shuttingDownH :: Environment 275 | -> From 276 | -> IO ServerResponse 277 | shuttingDownH env from = atomically $ do 278 | toIO env Debug . STDLOG $ 279 | "Shutdown notice from " ++ show from 280 | return ConnectionClosed 281 | -- NB: Cleanup of the USN DB happens when the worker shuts down 282 | 283 | 284 | 285 | -- | A USN wants to terminate the connection because it has too mans DSNs. 286 | -- Check whether this can be done without dropping the USN count below the 287 | -- minimum number of neighbours, and terminate the worker if this is the case. 288 | pruneH :: Environment 289 | -> IO ServerResponse 290 | pruneH env = atomically $ do 291 | usnSize <- usnDBSize env 292 | let minN = env ^. L.config . L.minNeighbours 293 | if usnSize > minN 294 | then 295 | -- Send back a special "OK" signal that terminates the 296 | -- connection 297 | return PruneOK 298 | else 299 | -- "OK" means "do not terminate the worker" here! 300 | return OK 301 | 302 | 303 | 304 | -- | Bounce 'EdgeRequest's through the network in order to make new connections. 305 | -- The idea behind this behaviour is that a new connection should be as long 306 | -- as possible, i.e. ideally establish a link to an entirely different part of 307 | -- the network, which prevents clustering. 308 | -- 309 | -- When a node receives an incoming ("Hey, I'm here, please make me your 310 | -- neighbour") or outgoing ("I need more neighbours") request, it either 311 | -- accepts it or bounces the request on to a downstream neighbour that repeats 312 | -- the process. The procedure has two phases: 313 | -- 314 | -- 1. In phase 1, a counter will keep track of how many bounces have 315 | -- occurred. For example, a signal may contain the information "bounce 316 | -- me 5 times". This makes sure the signal traverses the network a 317 | -- certain amount, so the signal doesn't just stay in the issuing node's 318 | -- neighbourhood. 319 | -- Because of its definite "bounce on" nature, these are also referred to 320 | -- as "hard bounces". 321 | -- 322 | -- 2. Phase 2 is like phase 1, but instead of a counter, there's a denial 323 | -- probability. If there's room and the node rolls to keep the signal, 324 | -- it will do what its contents say. If there is no room or the node 325 | -- rolls to deny the request, it is bounced on once again, but with a 326 | -- reduced denial probability. This leads to an approximately 327 | -- exponentially distributed bounce-on-length in phase 2. This solves the 328 | -- issue of having a long chain of nodes, where only having phase one 329 | -- would reach the same node every time. 330 | -- Because of the probabilistic travelling distance of these bounces, 331 | -- they are also referred to as "soft bounces". 332 | 333 | edgeBounceH :: Environment 334 | -> To 335 | -> EdgeData 336 | -> IO ServerResponse 337 | 338 | -- Phase 1 ends: Hard bounce counter reaches 0, start soft bounce phase 339 | edgeBounceH env origin (EdgeData dir (HardBounce 0)) = 340 | edgeBounceH env 341 | origin 342 | (EdgeData dir 343 | (SoftBounce 0 344 | (env ^. L.config . L.acceptP))) 345 | 346 | -- Phase 1: Hard bounce, bounce on. 347 | edgeBounceH env origin (EdgeData dir (HardBounce n)) = do 348 | 349 | let buildSignal = EdgeRequest origin . EdgeData dir 350 | nMax = env ^. L.config . L.hardBounces 351 | 352 | atomically $ do 353 | 354 | _ <- P.send (env ^. L.st1c . L.pOutput) 355 | (buildSignal (HardBounce (min (n - 1) nMax))) 356 | -- Cap the number of hard 357 | -- bounces with the current 358 | -- node's configuration to 359 | -- prevent "maxBound bounces 360 | -- left" attacks 361 | (toIO env Chatty . STDLOG) 362 | (printf "Hardbounced %s request from %s (%d left)" 363 | (show dir) 364 | (show origin) 365 | n) 366 | 367 | return OK 368 | 369 | -- Phase 2: either accept or bounce on with adjusted acceptance 370 | -- probability. 371 | -- 372 | -- (Note that bouncing on always decreases the denial probability, even in case 373 | -- the reason was not enough room.) 374 | edgeBounceH env origin (EdgeData dir (SoftBounce n p)) = do 375 | 376 | (isRoom, relationship) <- atomically $ do 377 | 378 | -- Make sure not to connect to itself or to already known nodes 379 | rel <- nodeRelationship env origin 380 | 381 | -- Check whether there is room for another connection. Note that 382 | -- an Incoming request will construct a downstream neighbour from 383 | -- this node, so the database lookups are flipped. 384 | room <- case dir of 385 | Incoming -> isRoomForDsn env 386 | Outgoing -> isRoomForUsn env 387 | 388 | return (room, rel) 389 | 390 | -- Roll whether to accept the query first, then check whether there's 391 | -- room. In case of failure, bounce on. 392 | acceptEdge <- (< p) <$> randomRIO (0, 1 :: Double) 393 | 394 | case (relationship, dir) of 395 | 396 | -- Don't connect to self 397 | (IsSelf, _) -> atomically $ do 398 | toIO env Chatty . STDLOG $ 399 | "Edge to self requested, bouncing" 400 | bounceReset 401 | 402 | -- Don't connect to the same node multiple times 403 | (IsDownstreamNeighbour, Incoming) -> atomically $ do 404 | -- In case you're wondering about the seemingly different 405 | -- directions in that pattern (Incoming+Downstream): The 406 | -- direction is from the viewpoint of the requestee, while the 407 | -- relationship to that node is seen from the current node. 408 | (toIO env Chatty . STDLOG) 409 | (printf "Edge to %s already exists, bouncing" 410 | (show origin)) 411 | bounceOn -- TODO: bounceReset here to avoid clustering? 412 | 413 | -- No room 414 | _ | not isRoom -> atomically $ do 415 | let -- Direction of the edge (not) to be as seen from the 416 | -- current node. Accepting an Outgoing request would 417 | -- produce an incoming connection for example. 418 | relativeDir Outgoing = "incoming" 419 | relativeDir Incoming = "outgoing" 420 | (toIO env Chatty . STDLOG) 421 | (printf "No room for another %s connection to handle\ 422 | \ the %s request" 423 | (relativeDir dir) 424 | (show dir)) 425 | bounceOn 426 | 427 | -- Request randomly denied 428 | _ | not acceptEdge -> atomically $ do 429 | toIO env Chatty . STDLOG $ 430 | "Random bounce (accept: p = " ++ show p ++ ")" 431 | bounceOn 432 | 433 | -- Try accepting an Outgoing request 434 | (_, Outgoing) -> do 435 | atomically . toIO env Chatty . STDLOG $ 436 | "Outgoing edge request accepted, sending handshake\ 437 | \ request" ++ show dir 438 | sendHandshakeRequest env origin 439 | 440 | -- Try accepting an Incoming request 441 | (_, Incoming) -> do 442 | atomically . toIO env Chatty . STDLOG $ 443 | "Incoming edge request accepted, starting handshake" 444 | void $ Client.startHandshakeH env origin 445 | -- TODO: Bounce on if failed, otherwise an almost saturated 446 | -- network won't allow new nodes 447 | 448 | return OK -- The upstream neighbour that relayed the EdgeRequest has 449 | -- nothing to do with whether the handshake fails etc. 450 | 451 | 452 | where 453 | 454 | 455 | buildSignal = EdgeRequest origin . EdgeData dir 456 | 457 | 458 | -- Build "bounce on" action to relay signal if necessary 459 | bounceOn | n >= env ^. L.config . L.maxSoftBounces = 460 | toIO env Chatty . STDLOG $ 461 | "Too many bounces, swallowing" 462 | | otherwise = 463 | let p' = max p (env ^. L.config . L.acceptP) 464 | -- ^^ The relayed acceptance probability is at least as 465 | -- high as the one the relaying node uses. This 466 | -- prevents "small p" attacks that bounce 467 | -- indefinitely. 468 | in void (P.send (env ^. L.st1c . L.pOutput) 469 | (buildSignal (SoftBounce (n+1) p'))) 470 | 471 | -- Build "bounce again from the beginning" signal. This is invoked 472 | -- if an EdgeRequest reaches the issuing node again. 473 | bounceReset = let b = env ^. L.config . L.hardBounces 474 | in void (P.send (env ^. L.st1c . L.pOutput) 475 | (buildSignal (HardBounce b))) 476 | -- TODO: Maybe swallowing the request in this case makes more sense. 477 | -- The node is spamming the network with requests anyway after 478 | -- all. 479 | 480 | 481 | 482 | -- | Prompt another node to start a handshake in order to be added as its 483 | -- downstream neighbour. 484 | sendHandshakeRequest :: Environment 485 | -> To 486 | -> IO () 487 | sendHandshakeRequest env to = do 488 | connectToNode to $ \(socket, _addr) -> do 489 | request tout socket signal >>= \case 490 | Just OK -> return () 491 | _else -> return () 492 | -- Nothing to do here, the handshake is a one-way command, 493 | -- waiting for response is just a courtesy 494 | 495 | where signal = env ^. L.self . L.to (Special . HandshakeRequest) 496 | tout = env ^. L.config . L.poolTimeout 497 | 498 | 499 | 500 | -- | Handle an incoming handshake, i.e. a remote node wants to add this node 501 | -- as its downstream neighbour. 502 | -- 503 | -- Counterpart of 'Client.startHandshakeH'. 504 | -- 505 | -- The procedure is as follows: 506 | -- 507 | -- 1. Check whether there is space for another upstream neighbour; if yes, 508 | -- then add it to the pool temporarily. 509 | -- 2. Send back an OK signal, "I'm ready to take your connection". 510 | -- 3. If the upstream node acknowledged this OK signal, it responds with an OK 511 | -- on its own. The function terminates, the temporary neighbourship is made 512 | -- permanent, and the connection can stay open and both parties know that 513 | -- the other one has done their part. 514 | -- 4. If something goes wrong, remove the temporary partner and terminate. 515 | incomingHandshakeH :: Environment 516 | -> From 517 | -> Socket 518 | -> IO ServerResponse 519 | incomingHandshakeH env from socket = do 520 | inserted <- atomically $ do 521 | ifM (isRoomForUsn env) 522 | (insertUsn env from >> return True) 523 | (return False) 524 | 525 | if inserted 526 | then send tout socket OK >> receive tout socket >>= \case 527 | Just OK -> return OK 528 | x -> (return . Error) (errMsg x) 529 | else (return . Error) errNoRoom 530 | 531 | where errMsg x = "Incoming handshake denied:\ 532 | \ server response <" ++ show x ++ ">" 533 | errNoRoom = "No room for another USN" 534 | tout = env ^. L.config . L.poolTimeout 535 | --------------------------------------------------------------------------------