From b8be20b86e03dec07cd44ecd06ff980017ca401a Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sun, 17 May 2020 01:24:56 +0200 Subject: [PATCH 01/88] begin implementation of message sending --- Hash2Pub/Hash2Pub.cabal | 2 +- Hash2Pub/src/Hash2Pub/DHTProtocol.hs | 48 ++++++++++++++++++++++++++++ 2 files changed, 49 insertions(+), 1 deletion(-) diff --git a/Hash2Pub/Hash2Pub.cabal b/Hash2Pub/Hash2Pub.cabal index 084b096..e3aa4c1 100644 --- a/Hash2Pub/Hash2Pub.cabal +++ b/Hash2Pub/Hash2Pub.cabal @@ -46,7 +46,7 @@ category: Network extra-source-files: CHANGELOG.md common deps - build-depends: base ^>=4.12.0.0, containers ^>=0.6.0.1, bytestring, utf8-string ^>=1.0.1.1, network ^>=2.8.0.1, time ^>=1.8.0.2, cmdargs ^>= 0.10, cryptonite ^>= 0.25, memory, async, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute + build-depends: base ^>=4.12.0.0, containers ^>=0.6.0.1, bytestring, utf8-string ^>=1.0.1.1, network ^>=2.8.0.1, time ^>=1.8.0.2, cmdargs ^>= 0.10, cryptonite ^>= 0.25, memory, async, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl ghc-options: -Wall diff --git a/Hash2Pub/src/Hash2Pub/DHTProtocol.hs b/Hash2Pub/src/Hash2Pub/DHTProtocol.hs index a90c304..4688d39 100644 --- a/Hash2Pub/src/Hash2Pub/DHTProtocol.hs +++ b/Hash2Pub/src/Hash2Pub/DHTProtocol.hs @@ -23,6 +23,8 @@ import qualified Data.Map as Map import Data.Time.Clock.POSIX import Network.Socket hiding (send, sendTo, recv, recvFrom) import Network.Socket.ByteString +import System.Timeout +import Control.Monad.State.Strict import Hash2Pub.FediChord ( NodeID @@ -210,6 +212,52 @@ markCacheEntryAsVerified timestamp = Map.adjust adjustFunc adjustFunc (ProxyEntry _ (Just entry)) = adjustFunc entry adjustFunc entry = entry +-- ====== message send and receive operations ====== + +requestQueryID :: NodeState -> NodeID -> IO NodeState +-- 1. do a local lookup for the l closest nodes +-- 2. create l sockets +-- 3. send a message async concurrently to all l nodes +-- 4. collect the results, insert them into cache +-- 5. repeat until FOUND (problem: new entries not necessarily already in cache, explicitly compare with closer results) +requestQueryID ns targetID = do + cacheSnapshot <- readIORef $ getNodeCacheRef ns + let localResult = queryLocalCache ns cacheSnapshot (fromMaybe 1 $ getLNumBestNodes ns) targetID + -- FOUND can only be returned if targetID is owned by local node + case localResult of + FOUND thisNode -> return thisNode + FORWARD nodeSet -> + sockets <- mapM (\resultNode -> mkSendSocket (domain result) (dhtPort resultNode)) $ Set.toList nodeSet + -- ToDo: process results immediately instead of waiting for the last one to finish, see https://stackoverflow.com/a/38815224/9198613 + responses = mapM + +sendRequestTo :: Int -- ^ timeout in seconds + -> Int -- ^ number of retries + -> FediChordMessage -- ^ the message to be sent + -> Socket -- ^ connected socket to use for sending + -> IO (Set.Set FediChordMessage) -- ^ responses +sendRequestTo timeout attempts msg sock = do + let requests = serialiseMessage 1200 msg + -- ToDo: make attempts and timeout configurable + attempts 3 . timeout 5000 $ do + where + -- state reingeben: state = noch nicht geackte messages, result = responses + sendAndAck :: Socket -> StateT (Map.Map Integer BS.ByteString) IO (Set.Set FediChordMessage) + sendAndAck sock = do + remainingSends <- get + sendMany sock $ Map.elems remainingSends + -- timeout pro receive socket, danach catMaybes + -- wichtig: Pakete können dupliziert werden, dh es können mehr ACKs als gesendete parts ankommen + replicateM + + + + +-- idea: send all parts at once +-- Set/ Map with unacked parts +-- then recv with timeout for |unackedParts| attempts, receive acked parts from set/ map +-- how to manage individual retries? nested "attempts" + -- | retry an IO action at most *i* times until it delivers a result attempts :: Int -- ^ number of retries *i* -> IO (Maybe a) -- ^ action to retry From 8b01ad2f379fceb17d4dc4e1d6c2b666cd6f02a8 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sun, 17 May 2020 01:44:58 +0200 Subject: [PATCH 02/88] remove unnecessary directory level --- Hash2Pub/.gitignore => .gitignore | 0 Hash2Pub/CHANGELOG.md => CHANGELOG.md | 0 Hash2Pub/FediChord.asn1 => FediChord.asn1 | 0 Hash2Pub/Hash2Pub.cabal => Hash2Pub.cabal | 0 Hash2Pub/LICENSE => LICENSE | 0 Hash2Pub/Setup.hs => Setup.hs | 0 Hash2Pub/default.nix => default.nix | 0 Hash2Pub/democlient.hs => democlient.hs | 0 Hash2Pub/demoserver.hs => demoserver.hs | 0 Hash2Pub/hashtest.hs => hashtest.hs | 0 Hash2Pub/shell.nix => shell.nix | 0 {Hash2Pub/src => src}/CacheEdgeCases.hs | 0 {Hash2Pub/src => src}/Hash2Pub/ASN1Coding.hs | 0 {Hash2Pub/src => src}/Hash2Pub/DHTProtocol.hs | 0 {Hash2Pub/src => src}/Hash2Pub/FediChord.hs | 0 {Hash2Pub/src => src}/Hash2Pub/Main.hs | 0 {Hash2Pub/src => src}/Hash2Pub/Utils.hs | 0 {Hash2Pub/src => src}/asn1test.hs | 0 {Hash2Pub/test => test}/FediChordSpec.hs | 0 {Hash2Pub/test => test}/Specs.hs | 0 20 files changed, 0 insertions(+), 0 deletions(-) rename Hash2Pub/.gitignore => .gitignore (100%) rename Hash2Pub/CHANGELOG.md => CHANGELOG.md (100%) rename Hash2Pub/FediChord.asn1 => FediChord.asn1 (100%) rename Hash2Pub/Hash2Pub.cabal => Hash2Pub.cabal (100%) rename Hash2Pub/LICENSE => LICENSE (100%) rename Hash2Pub/Setup.hs => Setup.hs (100%) rename Hash2Pub/default.nix => default.nix (100%) rename Hash2Pub/democlient.hs => democlient.hs (100%) rename Hash2Pub/demoserver.hs => demoserver.hs (100%) rename Hash2Pub/hashtest.hs => hashtest.hs (100%) rename Hash2Pub/shell.nix => shell.nix (100%) rename {Hash2Pub/src => src}/CacheEdgeCases.hs (100%) rename {Hash2Pub/src => src}/Hash2Pub/ASN1Coding.hs (100%) rename {Hash2Pub/src => src}/Hash2Pub/DHTProtocol.hs (100%) rename {Hash2Pub/src => src}/Hash2Pub/FediChord.hs (100%) rename {Hash2Pub/src => src}/Hash2Pub/Main.hs (100%) rename {Hash2Pub/src => src}/Hash2Pub/Utils.hs (100%) rename {Hash2Pub/src => src}/asn1test.hs (100%) rename {Hash2Pub/test => test}/FediChordSpec.hs (100%) rename {Hash2Pub/test => test}/Specs.hs (100%) diff --git a/Hash2Pub/.gitignore b/.gitignore similarity index 100% rename from Hash2Pub/.gitignore rename to .gitignore diff --git a/Hash2Pub/CHANGELOG.md b/CHANGELOG.md similarity index 100% rename from Hash2Pub/CHANGELOG.md rename to CHANGELOG.md diff --git a/Hash2Pub/FediChord.asn1 b/FediChord.asn1 similarity index 100% rename from Hash2Pub/FediChord.asn1 rename to FediChord.asn1 diff --git a/Hash2Pub/Hash2Pub.cabal b/Hash2Pub.cabal similarity index 100% rename from Hash2Pub/Hash2Pub.cabal rename to Hash2Pub.cabal diff --git a/Hash2Pub/LICENSE b/LICENSE similarity index 100% rename from Hash2Pub/LICENSE rename to LICENSE diff --git a/Hash2Pub/Setup.hs b/Setup.hs similarity index 100% rename from Hash2Pub/Setup.hs rename to Setup.hs diff --git a/Hash2Pub/default.nix b/default.nix similarity index 100% rename from Hash2Pub/default.nix rename to default.nix diff --git a/Hash2Pub/democlient.hs b/democlient.hs similarity index 100% rename from Hash2Pub/democlient.hs rename to democlient.hs diff --git a/Hash2Pub/demoserver.hs b/demoserver.hs similarity index 100% rename from Hash2Pub/demoserver.hs rename to demoserver.hs diff --git a/Hash2Pub/hashtest.hs b/hashtest.hs similarity index 100% rename from Hash2Pub/hashtest.hs rename to hashtest.hs diff --git a/Hash2Pub/shell.nix b/shell.nix similarity index 100% rename from Hash2Pub/shell.nix rename to shell.nix diff --git a/Hash2Pub/src/CacheEdgeCases.hs b/src/CacheEdgeCases.hs similarity index 100% rename from Hash2Pub/src/CacheEdgeCases.hs rename to src/CacheEdgeCases.hs diff --git a/Hash2Pub/src/Hash2Pub/ASN1Coding.hs b/src/Hash2Pub/ASN1Coding.hs similarity index 100% rename from Hash2Pub/src/Hash2Pub/ASN1Coding.hs rename to src/Hash2Pub/ASN1Coding.hs diff --git a/Hash2Pub/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs similarity index 100% rename from Hash2Pub/src/Hash2Pub/DHTProtocol.hs rename to src/Hash2Pub/DHTProtocol.hs diff --git a/Hash2Pub/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs similarity index 100% rename from Hash2Pub/src/Hash2Pub/FediChord.hs rename to src/Hash2Pub/FediChord.hs diff --git a/Hash2Pub/src/Hash2Pub/Main.hs b/src/Hash2Pub/Main.hs similarity index 100% rename from Hash2Pub/src/Hash2Pub/Main.hs rename to src/Hash2Pub/Main.hs diff --git a/Hash2Pub/src/Hash2Pub/Utils.hs b/src/Hash2Pub/Utils.hs similarity index 100% rename from Hash2Pub/src/Hash2Pub/Utils.hs rename to src/Hash2Pub/Utils.hs diff --git a/Hash2Pub/src/asn1test.hs b/src/asn1test.hs similarity index 100% rename from Hash2Pub/src/asn1test.hs rename to src/asn1test.hs diff --git a/Hash2Pub/test/FediChordSpec.hs b/test/FediChordSpec.hs similarity index 100% rename from Hash2Pub/test/FediChordSpec.hs rename to test/FediChordSpec.hs diff --git a/Hash2Pub/test/Specs.hs b/test/Specs.hs similarity index 100% rename from Hash2Pub/test/Specs.hs rename to test/Specs.hs From 4e62bb08f8fde8b942a34eef046ed160dbf811c1 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 18 May 2020 23:59:44 +0200 Subject: [PATCH 03/88] add readme --- Readme.md | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 Readme.md diff --git a/Readme.md b/Readme.md new file mode 100644 index 0000000..3c7dbe5 --- /dev/null +++ b/Readme.md @@ -0,0 +1,17 @@ +# Hash2Pub + +***This is heavily WIP and does not provide any useful functionality yet***. +I aim for always having the master branch at a state where it builds and tests pass. + +A fully-decentralised relay for global hashtag federation in [ActivityPub](https://activitypub.rocks) based on a distributed hash table. +It allows querying and subscribing to all posts of a certain hashtag and is implemented in Haskell. + +This is the practical implementation of the concept presented in the paper [Decentralised Hashtag Search and Subscription for Federated Social Networks](https://git.orlives.de/schmittlauch/paper_hashtag_federation). A 30 minutes [introduction talk](https://conf.tube/videos/watch/340eb706-28c0-4a43-9364-700297ca96cb) is available as well. + +The ASN.1 module schema used for DHT messages can be found in `FediChord.asn1`. + +## Building + +The project and its developent environment are built with [Nix](https://nixos.org/nix/). + +The development environment can be entered with `nix-shell`. Then the project can be built with `cabal build` from within the environment, or using `nix-shell --command "cabal build"` to do both steps at once. From 84bcd676ae76730c178b2885ae0aa91f4d774d70 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 19 May 2020 16:30:56 +0200 Subject: [PATCH 04/88] move protocol data definitions to own module to prevent cyclic imports --- Hash2Pub.cabal | 2 +- src/Hash2Pub/ASN1Coding.hs | 5 +- src/Hash2Pub/DHTProtocol.hs | 95 +++-------------------------------- src/Hash2Pub/ProtocolTypes.hs | 94 ++++++++++++++++++++++++++++++++++ 4 files changed, 106 insertions(+), 90 deletions(-) create mode 100644 src/Hash2Pub/ProtocolTypes.hs diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal index e3aa4c1..bf4d856 100644 --- a/Hash2Pub.cabal +++ b/Hash2Pub.cabal @@ -55,7 +55,7 @@ library import: deps -- Modules exported by the library. - exposed-modules: Hash2Pub.FediChord, Hash2Pub.DHTProtocol, Hash2Pub.ASN1Coding + exposed-modules: Hash2Pub.FediChord, Hash2Pub.DHTProtocol, Hash2Pub.ASN1Coding, Hash2Pub.ProtocolTypes -- Modules included in this library but not exported. other-modules: Hash2Pub.Utils diff --git a/src/Hash2Pub/ASN1Coding.hs b/src/Hash2Pub/ASN1Coding.hs index faa653f..d11073d 100644 --- a/src/Hash2Pub/ASN1Coding.hs +++ b/src/Hash2Pub/ASN1Coding.hs @@ -18,7 +18,7 @@ import Safe import Hash2Pub.FediChord import Hash2Pub.Utils -import Hash2Pub.DHTProtocol +import Hash2Pub.ProtocolTypes import Debug.Trace @@ -77,6 +77,9 @@ chunkLength numParts totalSize = ceiling $ (realToFrac totalSize :: Double) / re -- The number of parts per message is limited to 150 for DOS protection reasons. -- The returned byte strings might exceed the desired maximum length, as only the payload (and not all of them) -- can be split into multiple parts. +-- +-- The return type is a Map from part number to encoded part, to be able to acknowledge +-- an encoded part without having to decode its number. serialiseMessage :: Int -- maximum message size in bytes -> FediChordMessage -- mesage to be serialised in preparation for sending -> Map.Map Integer BS.ByteString -- list of ASN.1 DER encoded messages together representing diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 4688d39..1f3fabc 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -20,11 +20,15 @@ module Hash2Pub.DHTProtocol import Data.Maybe (maybe, fromMaybe) import qualified Data.Set as Set import qualified Data.Map as Map +import qualified Data.ByteString as BS import Data.Time.Clock.POSIX import Network.Socket hiding (send, sendTo, recv, recvFrom) import Network.Socket.ByteString import System.Timeout import Control.Monad.State.Strict +import Control.Concurrent.STM +import Control.Concurrent.STM.TQueue +import Control.Concurrent.STM.TBQueue import Hash2Pub.FediChord ( NodeID @@ -42,17 +46,13 @@ import Hash2Pub.FediChord , localCompare ) +import Hash2Pub.ASN1Coding +import Hash2Pub.ProtocolTypes + import Debug.Trace (trace) -- === queries === -data QueryResponse = FORWARD (Set.Set RemoteCacheEntry) -- ^return closest nodes from local cache. - -- whole cache entry is returned for making - -- the entry time stamp available to the - -- protocol serialiser - | FOUND NodeState -- ^node is the responsible node for queried ID - deriving (Show, Eq) - -- TODO: evaluate more fine-grained argument passing to allow granular locking -- | look up an ID to either claim responsibility for it or return the closest l nodes from the local cache queryLocalCache :: NodeState -> NodeCache -> Int -> NodeID -> QueryResponse @@ -82,87 +82,6 @@ queryLocalCache ownState nCache lBestNodes targetID Nothing -> Set.empty Just nPred@(RemoteCacheEntry ns ts) -> Set.insert nPred $ closestPredecessor (remainingLookups-1) (nid ns) --- === protocol serialisation data types - -data Action = - QueryID - | Join - | Leave - | Stabilise - | Ping - deriving (Show, Eq, Enum) - -data FediChordMessage = - Request { - requestID :: Integer - , sender :: NodeState - , parts :: Integer - , part :: Integer - -- ^ part starts at 0 - , action :: Action - , payload :: Maybe ActionPayload - } - | Response { - responseTo :: Integer - , senderID :: NodeID - , parts :: Integer - , part :: Integer - , action :: Action - , payload :: Maybe ActionPayload - } deriving (Show, Eq) - -data ActionPayload = - QueryIDRequestPayload { - queryTargetID :: NodeID - , queryLBestNodes :: Integer - } - | JoinRequestPayload - | LeaveRequestPayload { - leaveSuccessors :: [NodeID] - , leavePredecessors :: [NodeID] - } - | StabiliseRequestPayload - | PingRequestPayload - | QueryIDResponsePayload { - queryResult :: QueryResponse - } - | JoinResponsePayload { - joinSuccessors :: [NodeID] - , joinPredecessors :: [NodeID] - , joinCache :: [RemoteCacheEntry] - } - | LeaveResponsePayload - | StabiliseResponsePayload { - stabiliseSuccessors :: [NodeID] - , stabilisePredecessors :: [NodeID] - } - | PingResponsePayload { - pingNodeStates :: [NodeState] - } - deriving (Show, Eq) - --- | global limit of parts per message used when (de)serialising messages. --- Used to limit the impact of DOS attempts with partial messages. -maximumParts :: Num a => a -maximumParts = 150 - --- | dedicated data type for cache entries sent to or received from the network, --- as these have to be considered as unvalidated. Also helps with separation of trust. -data RemoteCacheEntry = RemoteCacheEntry NodeState POSIXTime - deriving (Show, Eq) - -instance Ord RemoteCacheEntry where - (RemoteCacheEntry ns1 _) `compare` (RemoteCacheEntry ns2 _) = nid ns1 `compare` nid ns2 - -toRemoteCacheEntry :: CacheEntry -> Maybe RemoteCacheEntry -toRemoteCacheEntry (NodeEntry _ ns ts) = Just $ RemoteCacheEntry ns ts -toRemoteCacheEntry (ProxyEntry _ (Just entry@NodeEntry{})) = toRemoteCacheEntry entry -toRemoteCacheEntry _ = Nothing - --- helper function for use in tests -remoteNode_ :: RemoteCacheEntry -> NodeState -remoteNode_ (RemoteCacheEntry ns _) = ns - -- cache operations -- | update or insert a 'RemoteCacheEntry' into the cache, diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs new file mode 100644 index 0000000..4271174 --- /dev/null +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -0,0 +1,94 @@ +module Hash2Pub.ProtocolTypes where + +import qualified Data.Set as Set +import Data.Time.Clock.POSIX (POSIXTime) + +import Hash2Pub.FediChord + +data QueryResponse = FORWARD (Set.Set RemoteCacheEntry) -- ^return closest nodes from local cache. + -- whole cache entry is returned for making + -- the entry time stamp available to the + -- protocol serialiser + | FOUND NodeState -- ^node is the responsible node for queried ID + deriving (Show, Eq) + +-- === protocol serialisation data types + +data Action = + QueryID + | Join + | Leave + | Stabilise + | Ping + deriving (Show, Eq, Enum) + +data FediChordMessage = + Request { + requestID :: Integer + , sender :: NodeState + , parts :: Integer + , part :: Integer + -- ^ part starts at 0 + , action :: Action + , payload :: Maybe ActionPayload + } + | Response { + responseTo :: Integer + , senderID :: NodeID + , parts :: Integer + , part :: Integer + , action :: Action + , payload :: Maybe ActionPayload + } deriving (Show, Eq) + +data ActionPayload = + QueryIDRequestPayload { + queryTargetID :: NodeID + , queryLBestNodes :: Integer + } + | JoinRequestPayload + | LeaveRequestPayload { + leaveSuccessors :: [NodeID] + , leavePredecessors :: [NodeID] + } + | StabiliseRequestPayload + | PingRequestPayload + | QueryIDResponsePayload { + queryResult :: QueryResponse + } + | JoinResponsePayload { + joinSuccessors :: [NodeID] + , joinPredecessors :: [NodeID] + , joinCache :: [RemoteCacheEntry] + } + | LeaveResponsePayload + | StabiliseResponsePayload { + stabiliseSuccessors :: [NodeID] + , stabilisePredecessors :: [NodeID] + } + | PingResponsePayload { + pingNodeStates :: [NodeState] + } + deriving (Show, Eq) + +-- | global limit of parts per message used when (de)serialising messages. +-- Used to limit the impact of DOS attempts with partial messages. +maximumParts :: Num a => a +maximumParts = 150 + +-- | dedicated data type for cache entries sent to or received from the network, +-- as these have to be considered as unvalidated. Also helps with separation of trust. +data RemoteCacheEntry = RemoteCacheEntry NodeState POSIXTime + deriving (Show, Eq) + +instance Ord RemoteCacheEntry where + (RemoteCacheEntry ns1 _) `compare` (RemoteCacheEntry ns2 _) = nid ns1 `compare` nid ns2 + +toRemoteCacheEntry :: CacheEntry -> Maybe RemoteCacheEntry +toRemoteCacheEntry (NodeEntry _ ns ts) = Just $ RemoteCacheEntry ns ts +toRemoteCacheEntry (ProxyEntry _ (Just entry@NodeEntry{})) = toRemoteCacheEntry entry +toRemoteCacheEntry _ = Nothing + +-- helper function for use in tests +remoteNode_ :: RemoteCacheEntry -> NodeState +remoteNode_ (RemoteCacheEntry ns _) = ns From 8d18f952cd12db6b8383f585f15d11cbf4f3d224 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 19 May 2020 17:53:13 +0200 Subject: [PATCH 05/88] implement send-receive-acknowledge-retry loop for requests --- src/Hash2Pub/DHTProtocol.hs | 78 +++++++++++++++++++++++++------------ 1 file changed, 54 insertions(+), 24 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 486721c..95ad9e8 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -121,41 +121,71 @@ markCacheEntryAsVerified timestamp = Map.adjust adjustFunc -- ====== message send and receive operations ====== -requestQueryID :: NodeState -> NodeID -> IO NodeState --- 1. do a local lookup for the l closest nodes --- 2. create l sockets --- 3. send a message async concurrently to all l nodes --- 4. collect the results, insert them into cache --- 5. repeat until FOUND (problem: new entries not necessarily already in cache, explicitly compare with closer results) -requestQueryID ns targetID = do - cacheSnapshot <- readIORef $ getNodeCacheRef ns - let localResult = queryLocalCache ns cacheSnapshot (fromMaybe 1 $ getLNumBestNodes ns) targetID - -- FOUND can only be returned if targetID is owned by local node - case localResult of - FOUND thisNode -> return thisNode - FORWARD nodeSet -> - sockets <- mapM (\resultNode -> mkSendSocket (domain result) (dhtPort resultNode)) $ Set.toList nodeSet - -- ToDo: process results immediately instead of waiting for the last one to finish, see https://stackoverflow.com/a/38815224/9198613 - responses = mapM +--requestQueryID :: NodeState -> NodeID -> IO NodeState +---- 1. do a local lookup for the l closest nodes +---- 2. create l sockets +---- 3. send a message async concurrently to all l nodes +---- 4. collect the results, insert them into cache +---- 5. repeat until FOUND (problem: new entries not necessarily already in cache, explicitly compare with closer results) +--requestQueryID ns targetID = do +-- cacheSnapshot <- readIORef $ getNodeCacheRef ns +-- let localResult = queryLocalCache ns cacheSnapshot (fromMaybe 1 $ getLNumBestNodes ns) targetID +-- -- FOUND can only be returned if targetID is owned by local node +-- case localResult of +-- FOUND thisNode -> return thisNode +-- FORWARD nodeSet -> +-- sockets <- mapM (\resultNode -> mkSendSocket (domain result) (dhtPort resultNode)) $ Set.toList nodeSet +-- -- ToDo: process results immediately instead of waiting for the last one to finish, see https://stackoverflow.com/a/38815224/9198613 +-- responses = mapM +-- | Generic function for sending a request over a connected socket and collecting the response. +-- Serialises the message and tries to deliver its parts for a number of attempts within a specified timeout. sendRequestTo :: Int -- ^ timeout in seconds -> Int -- ^ number of retries -> FediChordMessage -- ^ the message to be sent -> Socket -- ^ connected socket to use for sending -> IO (Set.Set FediChordMessage) -- ^ responses -sendRequestTo timeout attempts msg sock = do +sendRequestTo timeoutMillis numAttempts msg sock = do let requests = serialiseMessage 1200 msg + -- create a queue for passing received response messages back, even after a timeout + responseQ <- newTBQueueIO $ 2*maximumParts -- keep room for duplicate packets + -- start sendAndAck with timeout -- ToDo: make attempts and timeout configurable - attempts 3 . timeout 5000 $ do + attempts numAttempts . timeout timeoutMillis $ sendAndAck responseQ sock requests + -- after timeout, check received responses, delete them from unacked message set/ map and rerun senAndAck with that if necessary. + recvdParts <- atomically $ flushTBQueue responseQ + -- PLACEHOLDER + pure Set.empty where -- state reingeben: state = noch nicht geackte messages, result = responses - sendAndAck :: Socket -> StateT (Map.Map Integer BS.ByteString) IO (Set.Set FediChordMessage) - sendAndAck sock = do - remainingSends <- get + sendAndAck :: TBQueue FediChordMessage -- ^ the queue for putting in the received responses + -> Socket -- ^ the socket used for sending and receiving for this particular remote node + -> Map.Map Integer BS.ByteString -- ^ the remaining unacked request parts + -> IO () + sendAndAck responseQueue sock remainingSends = do sendMany sock $ Map.elems remainingSends - -- timeout pro receive socket, danach catMaybes - -- wichtig: Pakete können dupliziert werden, dh es können mehr ACKs als gesendete parts ankommen - replicateM + -- if all requests have been acked/ responded to, return prematurely + recvLoop responseQueue remainingSends Set.empty + recvLoop :: TBQueue FediChordMessage -- ^ the queue for putting in the received responses + -> Map.Map Integer BS.ByteString -- ^ the remaining unacked request parts + -> Set.Set Integer -- ^ already received response part numbers + -> IO () + recvLoop responseQueue remainingSends' receivedPartNums = do + -- 65535 is maximum length of UDP packets, as long as + -- no IPv6 jumbograms are used + response <- deserialiseMessage <$> recv sock 65535 + case response of + -- drop errors + Left _ -> recvLoop responseQueue remainingSends' receivedPartNums + Right msg -> do + atomically $ writeTBQueue responseQueue msg + let + newRemaining = Map.delete (part msg) remainingSends' + newReceivedParts = Set.insert (part msg) receivedPartNums + -- ToDo: handle responses with more parts than the request + if Map.null newRemaining && Set.size receivedPartNums == fromIntegral (parts msg) + then pure () + else recvLoop responseQueue newRemaining receivedPartNums From c31baa36359aec67c0dfba5c3763eba8407bb781 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 19 May 2020 17:55:40 +0200 Subject: [PATCH 06/88] run stylish --- src/Hash2Pub/ASN1Coding.hs | 4 +- src/Hash2Pub/DHTProtocol.hs | 36 +++++----- src/Hash2Pub/FediChord.hs | 108 +++++++++++++----------------- src/Hash2Pub/ProtocolTypes.hs | 119 ++++++++++++++++------------------ 4 files changed, 124 insertions(+), 143 deletions(-) diff --git a/src/Hash2Pub/ASN1Coding.hs b/src/Hash2Pub/ASN1Coding.hs index 01fbb1d..fbb74cb 100644 --- a/src/Hash2Pub/ASN1Coding.hs +++ b/src/Hash2Pub/ASN1Coding.hs @@ -3,7 +3,7 @@ module Hash2Pub.ASN1Coding where import Control.Exception (displayException) -import Data.ASN1.BinaryEncoding -- asn1-encoding package +import Data.ASN1.BinaryEncoding import Data.ASN1.Encoding import Data.ASN1.Error () import Data.ASN1.Parse @@ -17,8 +17,8 @@ import Data.Time.Clock.POSIX () import Safe import Hash2Pub.FediChord -import Hash2Pub.Utils import Hash2Pub.ProtocolTypes +import Hash2Pub.Utils import Debug.Trace diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 95ad9e8..ecc701c 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -15,29 +15,31 @@ module Hash2Pub.DHTProtocol ) where -import Control.Concurrent.STM -import Control.Concurrent.STM.TQueue -import Control.Concurrent.STM.TBQueue -import qualified Data.ByteString as BS -import qualified Data.Map as Map -import Data.Maybe (fromMaybe, maybe) -import qualified Data.Set as Set +import Control.Concurrent.STM +import Control.Concurrent.STM.TBQueue +import Control.Concurrent.STM.TQueue +import qualified Data.ByteString as BS +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, maybe) +import qualified Data.Set as Set import Data.Time.Clock.POSIX -import Network.Socket hiding (recv, recvFrom, send, sendTo) +import Network.Socket hiding (recv, recvFrom, send, + sendTo) import Network.Socket.ByteString import System.Timeout import Hash2Pub.ASN1Coding -import Hash2Pub.FediChord (CacheEntry (..), NodeCache, NodeID, - NodeState (..), - cacheGetNodeStateUnvalidated, - cacheLookup, cacheLookupPred, - cacheLookupSucc, getPredecessors, - getSuccessors, localCompare, - putPredecessors, putSuccessors) +import Hash2Pub.FediChord (CacheEntry (..), NodeCache, + NodeID, NodeState (..), + cacheGetNodeStateUnvalidated, + cacheLookup, cacheLookupPred, + cacheLookupSucc, + getPredecessors, getSuccessors, + localCompare, putPredecessors, + putSuccessors) import Hash2Pub.ProtocolTypes -import Debug.Trace (trace) +import Debug.Trace (trace) -- === queries === @@ -136,7 +138,7 @@ markCacheEntryAsVerified timestamp = Map.adjust adjustFunc -- FORWARD nodeSet -> -- sockets <- mapM (\resultNode -> mkSendSocket (domain result) (dhtPort resultNode)) $ Set.toList nodeSet -- -- ToDo: process results immediately instead of waiting for the last one to finish, see https://stackoverflow.com/a/38815224/9198613 --- responses = mapM +-- responses = mapM -- | Generic function for sending a request over a connected socket and collecting the response. -- Serialises the message and tries to deliver its parts for a number of attempts within a specified timeout. diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 78dc711..479d90d 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -122,58 +122,43 @@ a `localCompare` b -- | represents a node and all its important state -data NodeState = NodeState { - nid :: NodeID - , domain :: String - -- ^ full public domain name the node is reachable under - , ipAddr :: HostAddress6 - -- the node's public IPv6 address - , dhtPort :: PortNumber - -- ^ port of the DHT itself - , apPort :: Maybe PortNumber - -- ^ port of the ActivityPub relay and storage service - -- might have to be queried first - , vServerID :: Integer - -- ^ ID of this vserver - - -- ==== internal state ==== - , internals :: Maybe InternalNodeState - -- ^ data not present in the representation of remote nodes - -- is put into its own type. - -- This is usually @Nothing@ for all remote nodes. - } deriving (Show, Eq) +data NodeState = NodeState + { nid :: NodeID + , domain :: String + -- ^ full public domain name the node is reachable under + , ipAddr :: HostAddress6 + -- the node's public IPv6 address + , dhtPort :: PortNumber + -- ^ port of the DHT itself + , apPort :: Maybe PortNumber + -- ^ port of the ActivityPub relay and storage service + , vServerID :: Integer + -- ^ ID of this vserver + , internals :: Maybe InternalNodeState + -- ^ data not present in the representation of remote nodes + } + deriving (Show, Eq) -- | encapsulates all data and parameters that are not present for remote nodes -data InternalNodeState = InternalNodeState { - nodeCache :: IORef NodeCache - -- ^ EpiChord node cache with expiry times for nodes - -- as the map is ordered, lookups for the closes preceding node can be done using @lookupLT@. - -- encapsulated into an IORef for allowing concurrent reads without locking - , cacheWriteQueue :: TQueue (NodeCache -> NodeCache) - -- ^ cache updates are not written directly to the 'nodeCache' but queued and - -- only processed by a single writer thread to prevent lost updates. - -- All nodeCache modifying functions have to be partially applied enough before - -- being put into the queue. - -- - , successors :: [NodeID] -- could be a set instead as these are ordered as well - -- ^ successor nodes in ascending order by distance - , predecessors :: [NodeID] - -- ^ predecessor nodes in ascending order by distance - ----- protocol parameters ----- - -- TODO: evaluate moving these somewhere else - , kNeighbours :: Int - -- ^ desired length of predecessor and successor list - -- needs to be parameterisable for simulation purposes - , lNumBestNodes :: Int - -- ^ number of best next hops to provide - -- needs to be parameterisable for simulation purposes - , pNumParallelQueries :: Int - -- ^ number of parallel sent queries - -- needs to be parameterisable for simulation purposes - , jEntriesPerSlice :: Int - -- ^ number of desired entries per cache slice - -- needs to be parameterisable for simulation purposes - } deriving (Show, Eq) +data InternalNodeState = InternalNodeState + { nodeCache :: IORef NodeCache + -- ^ EpiChord node cache with expiry times for nodes + , cacheWriteQueue :: TQueue (NodeCache -> NodeCache) + -- ^ cache updates are not written directly to the 'nodeCache' but queued and + , successors :: [NodeID] -- could be a set instead as these are ordered as well + -- ^ successor nodes in ascending order by distance + , predecessors :: [NodeID] + -- ^ predecessor nodes in ascending order by distance + , kNeighbours :: Int + -- ^ desired length of predecessor and successor list + , lNumBestNodes :: Int + -- ^ number of best next hops to provide + , pNumParallelQueries :: Int + -- ^ number of parallel sent queries + , jEntriesPerSlice :: Int + -- ^ number of desired entries per cache slice + } + deriving (Show, Eq) -- | defining Show instances to be able to print NodeState for debug purposes instance Typeable a => Show (IORef a) where @@ -230,12 +215,8 @@ getLNumBestNodes = getInternals_ lNumBestNodes type NodeCache = Map.Map NodeID CacheEntry -- |an entry of the 'nodeCache' can hold 2 different kinds of data -data CacheEntry = - -- | an entry representing its validation status, the node state and its timestamp - NodeEntry Bool NodeState POSIXTime - -- | a proxy field for closing the ring structure, indicating the lookup shall be - -- resumed at the given @NodeID@ unless the @ProxyEntry@ itself holds a @NodeEntry@ - | ProxyEntry (NodeID, ProxyDirection) (Maybe CacheEntry) +data CacheEntry = NodeEntry Bool NodeState POSIXTime + | ProxyEntry (NodeID, ProxyDirection) (Maybe CacheEntry) deriving (Show, Eq) -- | as a compromise, only NodeEntry components are ordered by their NodeID @@ -247,7 +228,9 @@ instance Ord CacheEntry where extractID (NodeEntry _ eState _) = nid eState extractID (ProxyEntry _ _) = error "proxy entries should never appear outside of the NodeCache" -data ProxyDirection = Backwards | Forwards deriving (Show, Eq) +data ProxyDirection = Backwards + | Forwards + deriving (Show, Eq) instance Enum ProxyDirection where toEnum (-1) = Backwards @@ -430,11 +413,12 @@ byteStringToUInteger bs = sum $ parsedBytes 0 bs -- persist them on disk so they can be used for all following bootstraps -- | configuration values used for initialising the FediChord DHT -data FediChordConf = FediChordConf { - confDomain :: String - , confIP :: HostAddress6 - , confDhtPort :: Int - } deriving (Show, Eq) +data FediChordConf = FediChordConf + { confDomain :: String + , confIP :: HostAddress6 + , confDhtPort :: Int + } + deriving (Show, Eq) -- | initialise data structures, compute own IDs and bind to listening socket -- ToDo: load persisted state, thus this function already operates in IO diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index 4271174..de51fad 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -1,74 +1,69 @@ module Hash2Pub.ProtocolTypes where -import qualified Data.Set as Set -import Data.Time.Clock.POSIX (POSIXTime) +import qualified Data.Set as Set +import Data.Time.Clock.POSIX (POSIXTime) -import Hash2Pub.FediChord +import Hash2Pub.FediChord -data QueryResponse = FORWARD (Set.Set RemoteCacheEntry) -- ^return closest nodes from local cache. - -- whole cache entry is returned for making - -- the entry time stamp available to the - -- protocol serialiser - | FOUND NodeState -- ^node is the responsible node for queried ID - deriving (Show, Eq) +data QueryResponse = FORWARD (Set.Set RemoteCacheEntry) + | FOUND NodeState + deriving (Show, Eq) -- === protocol serialisation data types -data Action = - QueryID - | Join - | Leave - | Stabilise - | Ping - deriving (Show, Eq, Enum) +data Action = QueryID + | Join + | Leave + | Stabilise + | Ping + deriving (Show, Eq, Enum) -data FediChordMessage = - Request { - requestID :: Integer - , sender :: NodeState - , parts :: Integer - , part :: Integer - -- ^ part starts at 0 - , action :: Action - , payload :: Maybe ActionPayload - } - | Response { - responseTo :: Integer - , senderID :: NodeID - , parts :: Integer - , part :: Integer - , action :: Action - , payload :: Maybe ActionPayload - } deriving (Show, Eq) +data FediChordMessage = Request + { requestID :: Integer + , sender :: NodeState + , parts :: Integer + , part :: Integer + -- ^ part starts at 0 + , action :: Action + , payload :: Maybe ActionPayload + } + | Response + { responseTo :: Integer + , senderID :: NodeID + , parts :: Integer + , part :: Integer + , action :: Action + , payload :: Maybe ActionPayload + } + deriving (Show, Eq) -data ActionPayload = - QueryIDRequestPayload { - queryTargetID :: NodeID - , queryLBestNodes :: Integer - } - | JoinRequestPayload - | LeaveRequestPayload { - leaveSuccessors :: [NodeID] - , leavePredecessors :: [NodeID] - } - | StabiliseRequestPayload - | PingRequestPayload - | QueryIDResponsePayload { - queryResult :: QueryResponse - } - | JoinResponsePayload { - joinSuccessors :: [NodeID] - , joinPredecessors :: [NodeID] - , joinCache :: [RemoteCacheEntry] - } - | LeaveResponsePayload - | StabiliseResponsePayload { - stabiliseSuccessors :: [NodeID] - , stabilisePredecessors :: [NodeID] - } - | PingResponsePayload { - pingNodeStates :: [NodeState] - } +data ActionPayload = QueryIDRequestPayload + { queryTargetID :: NodeID + , queryLBestNodes :: Integer + } + | JoinRequestPayload + | LeaveRequestPayload + { leaveSuccessors :: [NodeID] + , leavePredecessors :: [NodeID] + } + | StabiliseRequestPayload + | PingRequestPayload + | QueryIDResponsePayload + { queryResult :: QueryResponse + } + | JoinResponsePayload + { joinSuccessors :: [NodeID] + , joinPredecessors :: [NodeID] + , joinCache :: [RemoteCacheEntry] + } + | LeaveResponsePayload + | StabiliseResponsePayload + { stabiliseSuccessors :: [NodeID] + , stabilisePredecessors :: [NodeID] + } + | PingResponsePayload + { pingNodeStates :: [NodeState] + } deriving (Show, Eq) -- | global limit of parts per message used when (de)serialising messages. From beffab99a0b11a7a01553541a4d64253845a83ca Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 19 May 2020 19:50:36 +0200 Subject: [PATCH 07/88] clarify counting of FediChordMessage parts --- FediChord.asn1 | 4 ++-- src/Hash2Pub/ProtocolTypes.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/FediChord.asn1 b/FediChord.asn1 index 7c53cb0..dda8bdc 100644 --- a/FediChord.asn1 +++ b/FediChord.asn1 @@ -10,8 +10,8 @@ Request ::= SEQUENCE { action Action, requestID INTEGER, sender NodeState, - parts INTEGER (0..150), -- number of message parts - part INTEGER (0..150), -- part number of this message, starts at 1 + parts INTEGER (1..150), -- number of message parts + part INTEGER (1..150), -- part number of this message, starts at 1 actionPayload CHOICE { queryIDRequestPayload QueryIDRequestPayload, joinRequestPayload JoinRequestPayload, diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index de51fad..c7453ab 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -23,7 +23,7 @@ data FediChordMessage = Request , sender :: NodeState , parts :: Integer , part :: Integer - -- ^ part starts at 0 + -- ^ part starts at 1 , action :: Action , payload :: Maybe ActionPayload } From f6c252d3144e8666a3214364312b6ec0b34e4085 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 20 May 2020 18:37:56 +0200 Subject: [PATCH 08/88] sending a queryID request compiles (untested) --- FediChord.asn1 | 4 +- Hash2Pub.cabal | 2 +- src/Hash2Pub/DHTProtocol.hs | 102 +++++++++++++++++++++++----------- src/Hash2Pub/FediChord.hs | 2 + src/Hash2Pub/ProtocolTypes.hs | 6 +- test/FediChordSpec.hs | 8 +-- 6 files changed, 83 insertions(+), 41 deletions(-) diff --git a/FediChord.asn1 b/FediChord.asn1 index dda8bdc..b80b15a 100644 --- a/FediChord.asn1 +++ b/FediChord.asn1 @@ -8,7 +8,7 @@ Action ::= ENUMERATED {queryID, join, leave, stabilise, ping} Request ::= SEQUENCE { action Action, - requestID INTEGER, + requestID INTEGER (0..4294967295), -- arbitrarily restricting to an unsigned 32bit integer sender NodeState, parts INTEGER (1..150), -- number of message parts part INTEGER (1..150), -- part number of this message, starts at 1 @@ -25,7 +25,7 @@ Request ::= SEQUENCE { -- request and response instead of explicit flag Response ::= SEQUENCE { - responseTo INTEGER, + responseTo INTEGER (0..4294967295), -- arbitrarily restricting to an unsigned 32bit integer senderID NodeID, parts INTEGER (0..150), part INTEGER (0..150), diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal index bf4d856..f1533f4 100644 --- a/Hash2Pub.cabal +++ b/Hash2Pub.cabal @@ -46,7 +46,7 @@ category: Network extra-source-files: CHANGELOG.md common deps - build-depends: base ^>=4.12.0.0, containers ^>=0.6.0.1, bytestring, utf8-string ^>=1.0.1.1, network ^>=2.8.0.1, time ^>=1.8.0.2, cmdargs ^>= 0.10, cryptonite ^>= 0.25, memory, async, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl + build-depends: base ^>=4.12.0.0, containers ^>=0.6.0.1, bytestring, utf8-string ^>=1.0.1.1, network ^>=2.8.0.1, time ^>=1.8.0.2, cmdargs ^>= 0.10, cryptonite ^>= 0.25, memory, async, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random ghc-options: -Wall diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index ecc701c..d594b1f 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -7,7 +7,7 @@ module Hash2Pub.DHTProtocol , markCacheEntryAsVerified , RemoteCacheEntry(..) , toRemoteCacheEntry - , remoteNode_ + , remoteNode , Action(..) , ActionPayload(..) , FediChordMessage(..) @@ -15,17 +15,25 @@ module Hash2Pub.DHTProtocol ) where +import Control.Concurrent.Async import Control.Concurrent.STM import Control.Concurrent.STM.TBQueue import Control.Concurrent.STM.TQueue +import Control.Monad (foldM, forM, forM_) import qualified Data.ByteString as BS +import Data.Either (rights) +import Data.Foldable (foldl') +import Data.IORef import qualified Data.Map as Map -import Data.Maybe (fromMaybe, maybe) +import Data.Maybe (fromJust, fromMaybe, mapMaybe, + maybe) import qualified Data.Set as Set import Data.Time.Clock.POSIX import Network.Socket hiding (recv, recvFrom, send, sendTo) import Network.Socket.ByteString +import Safe +import System.Random import System.Timeout import Hash2Pub.ASN1Coding @@ -34,9 +42,13 @@ import Hash2Pub.FediChord (CacheEntry (..), NodeCache, cacheGetNodeStateUnvalidated, cacheLookup, cacheLookupPred, cacheLookupSucc, + getCacheWriteQueue, + getLNumBestNodes, + getNodeCacheRef, getPredecessors, getSuccessors, - localCompare, putPredecessors, - putSuccessors) + localCompare, mkSendSocket, + mkServerSocket, + putPredecessors, putSuccessors) import Hash2Pub.ProtocolTypes import Debug.Trace (trace) @@ -123,36 +135,71 @@ markCacheEntryAsVerified timestamp = Map.adjust adjustFunc -- ====== message send and receive operations ====== ---requestQueryID :: NodeState -> NodeID -> IO NodeState ----- 1. do a local lookup for the l closest nodes ----- 2. create l sockets ----- 3. send a message async concurrently to all l nodes ----- 4. collect the results, insert them into cache ----- 5. repeat until FOUND (problem: new entries not necessarily already in cache, explicitly compare with closer results) ---requestQueryID ns targetID = do --- cacheSnapshot <- readIORef $ getNodeCacheRef ns --- let localResult = queryLocalCache ns cacheSnapshot (fromMaybe 1 $ getLNumBestNodes ns) targetID --- -- FOUND can only be returned if targetID is owned by local node --- case localResult of --- FOUND thisNode -> return thisNode --- FORWARD nodeSet -> --- sockets <- mapM (\resultNode -> mkSendSocket (domain result) (dhtPort resultNode)) $ Set.toList nodeSet --- -- ToDo: process results immediately instead of waiting for the last one to finish, see https://stackoverflow.com/a/38815224/9198613 --- responses = mapM +requestQueryID :: NodeState -> NodeID -> IO NodeState +-- 1. do a local lookup for the l closest nodes +-- 2. create l sockets +-- 3. send a message async concurrently to all l nodes +-- 4. collect the results, insert them into cache +-- 5. repeat until FOUND (problem: new entries not necessarily already in cache, explicitly compare with closer results) +requestQueryID ns targetID = do + firstCacheSnapshot <- readIORef $ fromJust . getNodeCacheRef $ ns + lookupLoop firstCacheSnapshot + where + lookupLoop :: NodeCache -> IO NodeState + lookupLoop cacheSnapshot = do + let localResult = queryLocalCache ns cacheSnapshot (fromMaybe 1 $ getLNumBestNodes ns) targetID + -- FOUND can only be returned if targetID is owned by local node + case localResult of + FOUND thisNode -> pure thisNode + FORWARD nodeSet -> do + -- create connected sockets to all query targets + sockets <- mapM (\resultNode -> mkSendSocket (domain resultNode) (dhtPort resultNode)) $ remoteNode <$> Set.toList nodeSet + -- ToDo: make attempts and timeout configurable + queryThreads <- mapM (async . sendRequestTo 5000 3 (lookupMessage targetID)) sockets + -- ToDo: process results immediately instead of waiting for the last one to finish, see https://stackoverflow.com/a/38815224/9198613 + -- ToDo: exception handling, maybe log them + responses <- (mconcat . fmap Set.elems) . rights <$> mapM waitCatch queryThreads + -- insert new cache entries both into global cache as well as in local copy, to make sure it is already up to date at next lookup + now <- getPOSIXTime + newLCache <- foldM (\oldCache resp -> do + let entriesToInsert = case queryResult <$> payload resp of + Just (FOUND result1) -> [addCacheEntryPure now (RemoteCacheEntry result1 now)] + Just (FORWARD resultset) -> addCacheEntryPure now <$> Set.elems resultset + _ -> [] + -- forward entries to global cache + forM_ entriesToInsert $ \entry -> atomically $ writeTQueue (fromJust . getCacheWriteQueue $ ns) entry + -- insert entries into local cache copy + pure $ foldl' ( + \oldLCache insertFunc -> insertFunc oldLCache + ) oldCache entriesToInsert + ) cacheSnapshot responses + + -- check for a FOUND and return it + let foundResp = headMay . mapMaybe (\resp -> case queryResult <$> payload resp of + Just (FOUND ns') -> Just ns' + _ -> Nothing + ) $ responses + -- if no FOUND, recursively call lookup again + maybe (lookupLoop newLCache) pure foundResp + + -- todo: random request ID + lookupMessage targetID rID = Request rID ns 1 1 QueryID (Just $ pl ns targetID) + pl ns' targetID' = QueryIDRequestPayload { queryTargetID = targetID', queryLBestNodes = fromIntegral . fromJust . getLNumBestNodes $ ns } -- | Generic function for sending a request over a connected socket and collecting the response. -- Serialises the message and tries to deliver its parts for a number of attempts within a specified timeout. sendRequestTo :: Int -- ^ timeout in seconds -> Int -- ^ number of retries - -> FediChordMessage -- ^ the message to be sent + -> (Integer -> FediChordMessage) -- ^ the message to be sent, still needing a requestID -> Socket -- ^ connected socket to use for sending -> IO (Set.Set FediChordMessage) -- ^ responses -sendRequestTo timeoutMillis numAttempts msg sock = do - let requests = serialiseMessage 1200 msg +sendRequestTo timeoutMillis numAttempts msgIncomplete sock = do + -- give the message a random request ID + randomID <- randomRIO (0, 2^32-1) + let requests = serialiseMessage 1200 $ msgIncomplete randomID -- create a queue for passing received response messages back, even after a timeout responseQ <- newTBQueueIO $ 2*maximumParts -- keep room for duplicate packets -- start sendAndAck with timeout - -- ToDo: make attempts and timeout configurable attempts numAttempts . timeout timeoutMillis $ sendAndAck responseQ sock requests -- after timeout, check received responses, delete them from unacked message set/ map and rerun senAndAck with that if necessary. recvdParts <- atomically $ flushTBQueue responseQ @@ -190,13 +237,6 @@ sendRequestTo timeoutMillis numAttempts msg sock = do else recvLoop responseQueue newRemaining receivedPartNums - - --- idea: send all parts at once --- Set/ Map with unacked parts --- then recv with timeout for |unackedParts| attempts, receive acked parts from set/ map --- how to manage individual retries? nested "attempts" - -- | retry an IO action at most *i* times until it delivers a result attempts :: Int -- ^ number of retries *i* -> IO (Maybe a) -- ^ action to retry diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 479d90d..ca87945 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -24,6 +24,7 @@ module Hash2Pub.FediChord ( , getPredecessors , putPredecessors , getLNumBestNodes + , getCacheWriteQueue , NodeCache , CacheEntry(..) , cacheGetNodeStateUnvalidated @@ -43,6 +44,7 @@ module Hash2Pub.FediChord ( , fediChordInit , nodeStateInit , mkServerSocket + , mkSendSocket , resolve , cacheWriter ) where diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index c7453ab..936832d 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -84,6 +84,6 @@ toRemoteCacheEntry (NodeEntry _ ns ts) = Just $ RemoteCacheEntry ns ts toRemoteCacheEntry (ProxyEntry _ (Just entry@NodeEntry{})) = toRemoteCacheEntry entry toRemoteCacheEntry _ = Nothing --- helper function for use in tests -remoteNode_ :: RemoteCacheEntry -> NodeState -remoteNode_ (RemoteCacheEntry ns _) = ns +-- | extract the 'NodeState' from a 'RemoteCacheEntry' +remoteNode :: RemoteCacheEntry -> NodeState +remoteNode (RemoteCacheEntry ns _) = ns diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index 50f0d66..7889c75 100644 --- a/test/FediChordSpec.hs +++ b/test/FediChordSpec.hs @@ -138,12 +138,12 @@ spec = do queryLocalCache <$> exampleLocalNode <*> pure emptyCache <*> pure 1 <*> pure (toNodeID 2342) `shouldReturn` FORWARD Set.empty it "works on a cache with less entries than needed" $ do (FORWARD nodeset) <- queryLocalCache <$> exampleLocalNode <*> cacheWith2Entries <*> pure 4 <*> pure (toNodeID 2^(9::Integer)+5) - Set.map (nid . remoteNode_) nodeset `shouldBe` Set.fromList [ nid1, nid2 ] + Set.map (nid . remoteNode) nodeset `shouldBe` Set.fromList [ nid1, nid2 ] it "works on a cache with sufficient entries" $ do (FORWARD nodeset1) <- queryLocalCache <$> exampleLocalNode <*> cacheWith4Entries <*> pure 3 <*> pure (toNodeID 2^(9::Integer)+5) (FORWARD nodeset2) <- queryLocalCache <$> exampleLocalNode <*> cacheWith4Entries <*> pure 1 <*> pure (toNodeID 2^(9::Integer)+5) - Set.map (nid . remoteNode_) nodeset1 `shouldBe` Set.fromList [nid4, nid2, nid3] - Set.map (nid . remoteNode_) nodeset2 `shouldBe` Set.fromList [nid4] + Set.map (nid . remoteNode) nodeset1 `shouldBe` Set.fromList [nid4, nid2, nid3] + Set.map (nid . remoteNode) nodeset2 `shouldBe` Set.fromList [nid4] it "recognises the node's own responsibility" $ do FOUND selfQueryRes <- queryLocalCache <$> node1 <*> cacheWith4Entries <*> pure 3 <*> pure nid1 nid <$> node1 `shouldReturn` nid selfQueryRes @@ -151,7 +151,7 @@ spec = do nid <$> node1 `shouldReturn` nid responsibilityResult it "does not fail on nodes without neighbours (initial state)" $ do (FORWARD nodeset) <- queryLocalCache <$> exampleLocalNode <*> cacheWith4Entries <*> pure 3 <*> pure (toNodeID 11) - Set.map (nid . remoteNode_ ) nodeset `shouldBe` Set.fromList [nid4, nid2, nid3] + Set.map (nid . remoteNode ) nodeset `shouldBe` Set.fromList [nid4, nid2, nid3] describe "Messages can be encoded to and decoded from ASN.1" $ do -- define test messages From 99a2b0ba09f3fb3e88f9abd020cde3a03a6501a4 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 20 May 2020 19:27:15 +0200 Subject: [PATCH 09/88] add instance deriving instructions --- src/Hash2Pub/FediChord.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index ca87945..fd26b6f 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {- | @@ -84,7 +85,7 @@ idBits = 256 -- -- for being able to check value bounds, the constructor should not be used directly -- and new values are created via @toNodeID@ (newtype constructors cannot be hidden) -newtype NodeID = NodeID { getNodeID :: Integer } deriving (Eq, Show, Enum) +newtype NodeID = NodeID { getNodeID :: Integer } deriving stock (Show, Eq) deriving newtype Enum -- |smart data constructor for NodeID that throws a runtime exception for out-of-bounds values. -- When needing a runtime-safe constructor with drawbacks, try @fromInteger@ From fe673dc25553d4ffe6cdc86f55f20df838f614c1 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Thu, 21 May 2020 21:13:58 +0200 Subject: [PATCH 10/88] make NodeState a typeclasse, define setters and getters on its representations contributes to #20 --- FediChord.asn1 | 2 +- src/Hash2Pub/FediChord.hs | 92 ++++++++++++++++++++++++++++----------- 2 files changed, 68 insertions(+), 26 deletions(-) diff --git a/FediChord.asn1 b/FediChord.asn1 index b80b15a..254fc95 100644 --- a/FediChord.asn1 +++ b/FediChord.asn1 @@ -44,7 +44,7 @@ NodeState ::= SEQUENCE { domain Domain, ipAddr OCTET STRING (SIZE(16)), dhtPort INTEGER, - apPort INTEGER, + servicePort INTEGER, vServerID INTEGER (0..255) } diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index fd26b6f..c5a7c43 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -125,26 +125,26 @@ a `localCompare` b -- | represents a node and all its important state -data NodeState = NodeState - { nid :: NodeID - , domain :: String +data RemoteNodeState = RemoteNodeState + { nid :: NodeID + , domain :: String -- ^ full public domain name the node is reachable under - , ipAddr :: HostAddress6 + , ipAddr :: HostAddress6 -- the node's public IPv6 address - , dhtPort :: PortNumber + , dhtPort :: PortNumber -- ^ port of the DHT itself - , apPort :: Maybe PortNumber - -- ^ port of the ActivityPub relay and storage service - , vServerID :: Integer + , servicePort :: PortNumber + -- ^ port of the service provided on top of the DHT + , vServerID :: Integer -- ^ ID of this vserver - , internals :: Maybe InternalNodeState - -- ^ data not present in the representation of remote nodes } deriving (Show, Eq) --- | encapsulates all data and parameters that are not present for remote nodes -data InternalNodeState = InternalNodeState - { nodeCache :: IORef NodeCache +-- | represents a node and encapsulates all data and parameters that are not present for remote nodes +data LocalNodeState = LocalNodeState + { nodeState :: RemoteNodeState + -- ^ represents common data present both in remote and local node representations + , nodeCache :: IORef NodeCache -- ^ EpiChord node cache with expiry times for nodes , cacheWriteQueue :: TQueue (NodeCache -> NodeCache) -- ^ cache updates are not written directly to the 'nodeCache' but queued and @@ -163,6 +163,60 @@ data InternalNodeState = InternalNodeState } deriving (Show, Eq) +-- | class for various NodeState representations, providing +-- getters and setters for common values +class NodeState a where + -- getters for common properties + getNid :: a -> NodeID + getDomain :: a -> String + getIpAddr :: a -> HostAddress6 + getDhtPort :: a -> PortNumber + getServicePort :: a -> PortNumber + getVServerID :: a -> Integer + -- setters for common properties + setNid :: NodeID -> a -> a + setDomain :: String -> a -> a + setIpAddr :: HostAddress6 -> a -> a + setDhtPort :: PortNumber -> a -> a + setServicePort :: PortNumber -> a -> a + setVServerID :: Integer -> a -> a + +instance NodeState RemoteNodeState where + getNid = nid + getDomain = domain + getIpAddr = ipAddr + getDhtPort = dhtPort + getServicePort = servicePort + getVServerID = vServerID + setNid nid' ns = ns {nid = nid'} + setDomain domain' ns = ns {domain = domain'} + setIpAddr ipAddr' ns = ns {ipAddr = ipAddr'} + setDhtPort dhtPort' ns = ns {dhtPort = dhtPort'} + setServicePort servicePort' ns = ns {servicePort = servicePort'} + setVServerID vServerID' ns = ns {vServerID = vServerID'} + +-- | helper function for setting values on the 'RemoteNodeState' contained in the 'LocalNodeState' +propagateNodeStateSet_ :: (RemoteNodeState -> RemoteNodeState) -> LocalNodeState -> LocalNodeState +propagateNodeStateSet_ func ns = let + newNs = func $ nodeState ns + in + ns {nodeState = newNs} + + +instance NodeState LocalNodeState where + getNid = getNid . nodeState + getDomain = getDomain . nodeState + getIpAddr = getIpAddr . nodeState + getDhtPort = getDhtPort . nodeState + getServicePort = getServicePort . nodeState + getVServerID = getVServerID . nodeState + setNid nid' = propagateNodeStateSet_ $ setNid nid' + setDomain domain' = propagateNodeStateSet_ $ setDomain domain' + setIpAddr ipAddr' = propagateNodeStateSet_ $ setIpAddr ipAddr' + setDhtPort dhtPort' = propagateNodeStateSet_ $ setDhtPort dhtPort' + setServicePort servicePort' = propagateNodeStateSet_ $ setServicePort servicePort' + setVServerID vServerID' = propagateNodeStateSet_ $ setVServerID vServerID' + -- | defining Show instances to be able to print NodeState for debug purposes instance Typeable a => Show (IORef a) where show x = show (typeOf x) @@ -170,18 +224,6 @@ instance Typeable a => Show (IORef a) where instance Typeable a => Show (TQueue a) where show x = show (typeOf x) --- | extract a value from the internals of a 'NodeState' -getInternals_ :: (InternalNodeState -> a) -> NodeState -> Maybe a -getInternals_ func ns = func <$> internals ns - --- could be done better with lenses --- | convenience function that updates an internal value of a NodeState -putInternals_ :: (InternalNodeState -> InternalNodeState) -> NodeState -> NodeState -putInternals_ func ns = let - newInternals = func <$> internals ns - in - ns {internals = newInternals } - -- | convenience function for extracting the 'NodeCache' from a 'NodeState' getNodeCacheRef :: NodeState -> Maybe (IORef NodeCache) getNodeCacheRef = getInternals_ nodeCache From e8091b0a293f9c05450ce1eabb5c4258a5526aa6 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Thu, 21 May 2020 23:38:50 +0200 Subject: [PATCH 11/88] change all function definitions to new NodeState types - adjust implementation contributes to #20 --- src/Hash2Pub/ASN1Coding.hs | 23 ++++---- src/Hash2Pub/DHTProtocol.hs | 40 ++++++------- src/Hash2Pub/FediChord.hs | 102 ++++++++++++---------------------- src/Hash2Pub/ProtocolTypes.hs | 10 ++-- 4 files changed, 70 insertions(+), 105 deletions(-) diff --git a/src/Hash2Pub/ASN1Coding.hs b/src/Hash2Pub/ASN1Coding.hs index fbb74cb..47492ef 100644 --- a/src/Hash2Pub/ASN1Coding.hs +++ b/src/Hash2Pub/ASN1Coding.hs @@ -186,15 +186,15 @@ encodePayload payload'@PingResponsePayload{} = : concatMap encodeNodeState (pingNodeStates payload') <> [End Sequence] -encodeNodeState :: NodeState -> [ASN1] +encodeNodeState :: NodeState a => a -> [ASN1] encodeNodeState ns = [ Start Sequence - , IntVal (getNodeID . nid $ ns) - , ASN1String . asn1CharacterString Visible $ domain ns - , OctetString (ipAddrAsBS $ ipAddr ns) - , IntVal (toInteger . dhtPort $ ns) - , IntVal (maybe 0 toInteger $ apPort ns) - , IntVal (vServerID ns) + , IntVal (getNodeID . getNid $ ns) + , ASN1String . asn1CharacterString Visible $ getDomain ns + , OctetString (ipAddrAsBS $ getIpAddr ns) + , IntVal (toInteger . getDhtPort $ ns) + , IntVal (toInteger . getServicePort $ ns) + , IntVal (getVServerID ns) , End Sequence ] @@ -328,22 +328,21 @@ parseNull = do Null -> pure () x -> throwParseError $ "Expected Null but got " <> show x -parseNodeState :: ParseASN1 NodeState +parseNodeState :: ParseASN1 RemoteNodeState parseNodeState = onNextContainer Sequence $ do nid' <- fromInteger <$> parseInteger domain' <- parseString ip' <- bsAsIpAddr <$> parseOctets dhtPort' <- fromInteger <$> parseInteger - apPort' <- fromInteger <$> parseInteger + servicePort' <- fromInteger <$> parseInteger vServer' <- parseInteger - pure NodeState { + pure RemoteNodeState { nid = nid' , domain = domain' , dhtPort = dhtPort' - , apPort = if apPort' == 0 then Nothing else Just apPort' + , servicePort = servicePort' , vServerID = vServer' , ipAddr = ip' - , internals = Nothing } diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index d594b1f..29f3b13 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -37,18 +37,15 @@ import System.Random import System.Timeout import Hash2Pub.ASN1Coding -import Hash2Pub.FediChord (CacheEntry (..), NodeCache, +import Hash2Pub.FediChord (CacheEntry (..), + LocalNodeState (..), NodeCache, NodeID, NodeState (..), + RemoteNodeState (..), cacheGetNodeStateUnvalidated, cacheLookup, cacheLookupPred, - cacheLookupSucc, - getCacheWriteQueue, - getLNumBestNodes, - getNodeCacheRef, - getPredecessors, getSuccessors, - localCompare, mkSendSocket, - mkServerSocket, - putPredecessors, putSuccessors) + cacheLookupSucc, localCompare, + mkSendSocket, mkServerSocket, + setPredecessors, setSuccessors) import Hash2Pub.ProtocolTypes import Debug.Trace (trace) @@ -57,22 +54,22 @@ import Debug.Trace (trace) -- TODO: evaluate more fine-grained argument passing to allow granular locking -- | look up an ID to either claim responsibility for it or return the closest l nodes from the local cache -queryLocalCache :: NodeState -> NodeCache -> Int -> NodeID -> QueryResponse +queryLocalCache :: LocalNodeState -> NodeCache -> Int -> NodeID -> QueryResponse queryLocalCache ownState nCache lBestNodes targetID -- as target ID falls between own ID and first predecessor, it is handled by this node - | (targetID `localCompare` ownID) `elem` [LT, EQ] && not (null preds) && (targetID `localCompare` head preds == GT) = FOUND ownState + | (targetID `localCompare` ownID) `elem` [LT, EQ] && maybe False (\p -> targetID `localCompare` p == GT) (headMay preds) = FOUND . toRemoteNodeState $ ownState -- my interpretation: the "l best next hops" are the l-1 closest preceding nodes and -- the closest succeeding node (like with the p initiated parallel queries | otherwise = FORWARD $ closestSuccessor `Set.union` closestPredecessors where - preds = fromMaybe [] $ getPredecessors ownState - ownID = nid ownState + ownID = getNid ownState + preds = predecessors ownState closestSuccessor :: Set.Set RemoteCacheEntry closestSuccessor = maybe Set.empty Set.singleton $ toRemoteCacheEntry =<< cacheLookupSucc targetID nCache closestPredecessors :: Set.Set RemoteCacheEntry - closestPredecessors = closestPredecessor (lBestNodes-1) $ nid ownState + closestPredecessors = closestPredecessor (lBestNodes-1) $ getNid ownState closestPredecessor :: (Integral n, Show n) => n -> NodeID -> Set.Set RemoteCacheEntry closestPredecessor 0 _ = Set.empty closestPredecessor remainingLookups lastID @@ -135,19 +132,19 @@ markCacheEntryAsVerified timestamp = Map.adjust adjustFunc -- ====== message send and receive operations ====== -requestQueryID :: NodeState -> NodeID -> IO NodeState +requestQueryID :: LocalNodeState -> NodeID -> IO RemoteNodeState -- 1. do a local lookup for the l closest nodes -- 2. create l sockets -- 3. send a message async concurrently to all l nodes -- 4. collect the results, insert them into cache -- 5. repeat until FOUND (problem: new entries not necessarily already in cache, explicitly compare with closer results) requestQueryID ns targetID = do - firstCacheSnapshot <- readIORef $ fromJust . getNodeCacheRef $ ns + firstCacheSnapshot <- readIORef . nodeCacheRef $ ns lookupLoop firstCacheSnapshot where - lookupLoop :: NodeCache -> IO NodeState + lookupLoop :: NodeCache -> IO RemoteNodeState lookupLoop cacheSnapshot = do - let localResult = queryLocalCache ns cacheSnapshot (fromMaybe 1 $ getLNumBestNodes ns) targetID + let localResult = queryLocalCache ns cacheSnapshot (lNumBestNodes ns) targetID -- FOUND can only be returned if targetID is owned by local node case localResult of FOUND thisNode -> pure thisNode @@ -167,7 +164,7 @@ requestQueryID ns targetID = do Just (FORWARD resultset) -> addCacheEntryPure now <$> Set.elems resultset _ -> [] -- forward entries to global cache - forM_ entriesToInsert $ \entry -> atomically $ writeTQueue (fromJust . getCacheWriteQueue $ ns) entry + forM_ entriesToInsert $ \entry -> atomically $ writeTQueue (cacheWriteQueue ns) entry -- insert entries into local cache copy pure $ foldl' ( \oldLCache insertFunc -> insertFunc oldLCache @@ -182,9 +179,8 @@ requestQueryID ns targetID = do -- if no FOUND, recursively call lookup again maybe (lookupLoop newLCache) pure foundResp - -- todo: random request ID - lookupMessage targetID rID = Request rID ns 1 1 QueryID (Just $ pl ns targetID) - pl ns' targetID' = QueryIDRequestPayload { queryTargetID = targetID', queryLBestNodes = fromIntegral . fromJust . getLNumBestNodes $ ns } + lookupMessage targetID rID = Request rID (toRemoteNodeState ns) 1 1 QueryID (Just $ pl ns targetID) + pl ns' targetID' = QueryIDRequestPayload { queryTargetID = targetID', queryLBestNodes = fromIntegral . lNumBestNodes $ ns } -- | Generic function for sending a request over a connected socket and collecting the response. -- Serialises the message and tries to deliver its parts for a number of attempts within a specified timeout. diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index c5a7c43..565d09b 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -17,15 +17,10 @@ module Hash2Pub.FediChord ( , getNodeID , toNodeID , NodeState (..) - , InternalNodeState (..) - , getNodeCacheRef - , putNodeCache - , getSuccessors - , putSuccessors - , getPredecessors - , putPredecessors - , getLNumBestNodes - , getCacheWriteQueue + , LocalNodeState (..) + , RemoteNodeState (..) + , setSuccessors + , setPredecessors , NodeCache , CacheEntry(..) , cacheGetNodeStateUnvalidated @@ -144,7 +139,7 @@ data RemoteNodeState = RemoteNodeState data LocalNodeState = LocalNodeState { nodeState :: RemoteNodeState -- ^ represents common data present both in remote and local node representations - , nodeCache :: IORef NodeCache + , nodeCacheRef :: IORef NodeCache -- ^ EpiChord node cache with expiry times for nodes , cacheWriteQueue :: TQueue (NodeCache -> NodeCache) -- ^ cache updates are not written directly to the 'nodeCache' but queued and @@ -180,6 +175,7 @@ class NodeState a where setDhtPort :: PortNumber -> a -> a setServicePort :: PortNumber -> a -> a setVServerID :: Integer -> a -> a + toRemoteNodeState :: a -> RemoteNodeState instance NodeState RemoteNodeState where getNid = nid @@ -194,6 +190,7 @@ instance NodeState RemoteNodeState where setDhtPort dhtPort' ns = ns {dhtPort = dhtPort'} setServicePort servicePort' ns = ns {servicePort = servicePort'} setVServerID vServerID' ns = ns {vServerID = vServerID'} + toRemoteNodeState = id -- | helper function for setting values on the 'RemoteNodeState' contained in the 'LocalNodeState' propagateNodeStateSet_ :: (RemoteNodeState -> RemoteNodeState) -> LocalNodeState -> LocalNodeState @@ -216,6 +213,7 @@ instance NodeState LocalNodeState where setDhtPort dhtPort' = propagateNodeStateSet_ $ setDhtPort dhtPort' setServicePort servicePort' = propagateNodeStateSet_ $ setServicePort servicePort' setVServerID vServerID' = propagateNodeStateSet_ $ setVServerID vServerID' + toRemoteNodeState = nodeState -- | defining Show instances to be able to print NodeState for debug purposes instance Typeable a => Show (IORef a) where @@ -224,43 +222,19 @@ instance Typeable a => Show (IORef a) where instance Typeable a => Show (TQueue a) where show x = show (typeOf x) --- | convenience function for extracting the 'NodeCache' from a 'NodeState' -getNodeCacheRef :: NodeState -> Maybe (IORef NodeCache) -getNodeCacheRef = getInternals_ nodeCache +-- | convenience function that updates the successors of a 'LocalNodeState' +setSuccessors :: [NodeID] -> LocalNodeState -> LocalNodeState +setSuccessors succ' ns = ns {successors = succ'} --- | convenience function for updating the 'NodeCache' on 'NodeState' s that have --- internals. --- NodeStates without a cache (without internals) are returned unchanged -putNodeCache :: IORef NodeCache -> NodeState -> NodeState -putNodeCache nc = putInternals_ (\i -> i {nodeCache = nc}) - -getCacheWriteQueue :: NodeState -> Maybe (TQueue (NodeCache -> NodeCache)) -getCacheWriteQueue = getInternals_ cacheWriteQueue - --- | convenience function for extracting the @successors@ from a 'NodeState' -getSuccessors :: NodeState -> Maybe [NodeID] -getSuccessors = getInternals_ successors - --- | convenience function that updates the successors of a NodeState -putSuccessors :: [NodeID] -> NodeState -> NodeState -putSuccessors succ' = putInternals_ (\i -> i {successors = succ'}) - --- | convenience function for extracting the @predecessors@ from a 'NodeState' -getPredecessors :: NodeState -> Maybe [NodeID] -getPredecessors = getInternals_ predecessors - --- | convenience function that updates the predecessors of a NodeState -putPredecessors :: [NodeID] -> NodeState -> NodeState -putPredecessors pred' = putInternals_ (\i -> i {predecessors = pred'}) - --- | convenience function for extracting the @lNumBestNodes@ from a 'NodeState' -getLNumBestNodes :: NodeState -> Maybe Int -getLNumBestNodes = getInternals_ lNumBestNodes +-- | convenience function that updates the predecessors of a 'LocalNodeState' +setPredecessors :: [NodeID] -> LocalNodeState -> LocalNodeState +setPredecessors pred' ns = ns {predecessors = pred'} type NodeCache = Map.Map NodeID CacheEntry --- |an entry of the 'nodeCache' can hold 2 different kinds of data -data CacheEntry = NodeEntry Bool NodeState POSIXTime +-- | An entry of the 'nodeCache' can hold 2 different kinds of data. +-- Type variable @a@ should be of type class 'NodeState', but I do not want to use GADTs here. +data CacheEntry = NodeEntry Bool RemoteNodeState POSIXTime | ProxyEntry (NodeID, ProxyDirection) (Maybe CacheEntry) deriving (Show, Eq) @@ -270,7 +244,7 @@ instance Ord CacheEntry where a `compare` b = compare (extractID a) (extractID b) where - extractID (NodeEntry _ eState _) = nid eState + extractID (NodeEntry _ eState _) = getNid eState extractID (ProxyEntry _ _) = error "proxy entries should never appear outside of the NodeCache" data ProxyDirection = Backwards @@ -350,7 +324,7 @@ cacheLookupPred = lookupWrapper Map.lookupLT Map.lookupLE Backwards -- transfer difference now - entry to other node -- | return the @NodeState@ data from a cache entry without checking its validation status -cacheGetNodeStateUnvalidated :: CacheEntry -> NodeState +cacheGetNodeStateUnvalidated :: CacheEntry -> RemoteNodeState cacheGetNodeStateUnvalidated (NodeEntry _ nState _) = nState cacheGetNodeStateUnvalidated (ProxyEntry _ (Just entry)) = cacheGetNodeStateUnvalidated entry cacheGetNodeStateUnvalidated _ = error "trying to pure empty node state, please report a bug" @@ -467,30 +441,30 @@ data FediChordConf = FediChordConf -- | initialise data structures, compute own IDs and bind to listening socket -- ToDo: load persisted state, thus this function already operates in IO -fediChordInit :: FediChordConf -> IO (Socket, NodeState) +fediChordInit :: FediChordConf -> IO (Socket, LocalNodeState) fediChordInit conf = do initialState <- nodeStateInit conf - serverSock <- mkServerSocket (ipAddr initialState) (dhtPort initialState) + serverSock <- mkServerSocket (getIpAddr initialState) (getDhtPort initialState) pure (serverSock, initialState) -- | initialises the 'NodeState' for this local node. -- Separated from 'fediChordInit' to be usable in tests. -nodeStateInit :: FediChordConf -> IO NodeState +nodeStateInit :: FediChordConf -> IO LocalNodeState nodeStateInit conf = do cacheRef <- newIORef initCache q <- atomically newTQueue let - initialState = NodeState { + containedState = RemoteNodeState { domain = confDomain conf , ipAddr = confIP conf , nid = genNodeID (confIP conf) (confDomain conf) 0 , dhtPort = toEnum $ confDhtPort conf - , apPort = Nothing + , servicePort = 0 , vServerID = 0 - , internals = Just internalsInit } - internalsInit = InternalNodeState { - nodeCache = cacheRef + initialState = LocalNodeState { + nodeState = containedState + , nodeCacheRef = cacheRef , cacheWriteQueue = q , successors = [] , predecessors = [] @@ -501,7 +475,7 @@ nodeStateInit conf = do } pure initialState ---fediChordJoin :: NodeState -- ^ the local 'NodeState' +--fediChordJoin :: LocalNodeState -- ^ the local 'NodeState' -- -> (String, PortNumber) -- ^ domain and port of a bootstrapping node -- -> Socket -- ^ socket used for sending and receiving the join message -- -> IO Either String NodeState -- ^ the joined 'NodeState' after a successful @@ -514,19 +488,15 @@ nodeStateInit conf = do -- | cache updater thread that waits for incoming NodeCache update instructions on -- the node's cacheWriteQueue and then modifies the NodeCache as the single writer. -cacheWriter :: NodeState -> IO () +cacheWriter :: LocalNodeState -> IO () cacheWriter ns = do - let writeQueue' = getCacheWriteQueue ns - case writeQueue' of - Nothing -> pure () - Just writeQueue -> forever $ do - f <- atomically $ readTQueue writeQueue - let - refModifier :: NodeCache -> (NodeCache, ()) - refModifier nc = (f nc, ()) - maybe (pure ()) ( - \ref -> atomicModifyIORef' ref refModifier - ) $ getNodeCacheRef ns + let writeQueue' = cacheWriteQueue ns + forever $ do + f <- atomically $ readTQueue writeQueue' + let + refModifier :: NodeCache -> (NodeCache, ()) + refModifier nc = (f nc, ()) + atomicModifyIORef' (nodeCacheRef ns) refModifier -- ====== network socket operations ====== diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index 936832d..275d58f 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -6,7 +6,7 @@ import Data.Time.Clock.POSIX (POSIXTime) import Hash2Pub.FediChord data QueryResponse = FORWARD (Set.Set RemoteCacheEntry) - | FOUND NodeState + | FOUND RemoteNodeState deriving (Show, Eq) -- === protocol serialisation data types @@ -20,7 +20,7 @@ data Action = QueryID data FediChordMessage = Request { requestID :: Integer - , sender :: NodeState + , sender :: RemoteNodeState , parts :: Integer , part :: Integer -- ^ part starts at 1 @@ -62,7 +62,7 @@ data ActionPayload = QueryIDRequestPayload , stabilisePredecessors :: [NodeID] } | PingResponsePayload - { pingNodeStates :: [NodeState] + { pingNodeStates :: [RemoteNodeState] } deriving (Show, Eq) @@ -73,7 +73,7 @@ maximumParts = 150 -- | dedicated data type for cache entries sent to or received from the network, -- as these have to be considered as unvalidated. Also helps with separation of trust. -data RemoteCacheEntry = RemoteCacheEntry NodeState POSIXTime +data RemoteCacheEntry = RemoteCacheEntry RemoteNodeState POSIXTime deriving (Show, Eq) instance Ord RemoteCacheEntry where @@ -85,5 +85,5 @@ toRemoteCacheEntry (ProxyEntry _ (Just entry@NodeEntry{})) = toRemoteCacheEntry toRemoteCacheEntry _ = Nothing -- | extract the 'NodeState' from a 'RemoteCacheEntry' -remoteNode :: RemoteCacheEntry -> NodeState +remoteNode :: RemoteCacheEntry -> RemoteNodeState remoteNode (RemoteCacheEntry ns _) = ns From bbe7078369b0f5fc55e945deb414c67c1fe46cf6 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Fri, 22 May 2020 00:05:17 +0200 Subject: [PATCH 12/88] adjust tests to work with new NodeState types closes #20 --- test/FediChordSpec.hs | 24 ++++++++++-------------- 1 file changed, 10 insertions(+), 14 deletions(-) diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index 7889c75..784c14e 100644 --- a/test/FediChordSpec.hs +++ b/test/FediChordSpec.hs @@ -55,14 +55,13 @@ spec = do it "can be initialised" $ print exampleNodeState it "can be initialised partly and then modified later" $ do - let ns = NodeState { + let ns = RemoteNodeState { nid = undefined , domain = exampleNodeDomain , ipAddr = exampleIp , dhtPort = 2342 - , apPort = Nothing + , servicePort = 513 , vServerID = undefined - , internals = Nothing } nsReady = ns { nid = genNodeID (ipAddr ns) (domain ns) 3 @@ -121,9 +120,7 @@ spec = do let emptyCache = initCache nid1 = toNodeID 2^(23::Integer)+1 - node1 = do - eln <- exampleLocalNode -- is at 2^23.00000017198264 = 8388609 - pure $ putPredecessors [nid4] $ eln {nid = nid1} + node1 = setPredecessors [nid4] . setNid nid1 <$> exampleLocalNode nid2 = toNodeID 2^(230::Integer)+12 node2 = exampleNodeState { nid = nid2} nid3 = toNodeID 2^(25::Integer)+10 @@ -131,7 +128,7 @@ spec = do nid4 = toNodeID 2^(9::Integer)+100 node4 = exampleNodeState { nid = nid4} cacheWith2Entries :: IO NodeCache - cacheWith2Entries = addCacheEntryPure 10 <$> (RemoteCacheEntry <$> node1 <*> pure 10) <*> pure (addCacheEntryPure 10 (RemoteCacheEntry node2 10) emptyCache) + cacheWith2Entries = addCacheEntryPure 10 <$> (RemoteCacheEntry <$> (toRemoteNodeState <$> node1) <*> pure 10) <*> pure (addCacheEntryPure 10 (RemoteCacheEntry node2 10) emptyCache) cacheWith4Entries = addCacheEntryPure 10 (RemoteCacheEntry node3 10) <$> (addCacheEntryPure 10 (RemoteCacheEntry node4 10) <$> cacheWith2Entries) it "works on an empty cache" $ do queryLocalCache <$> exampleLocalNode <*> pure emptyCache <*> pure 3 <*> pure (toNodeID 2^(9::Integer)+5) `shouldReturn` FORWARD Set.empty @@ -146,9 +143,9 @@ spec = do Set.map (nid . remoteNode) nodeset2 `shouldBe` Set.fromList [nid4] it "recognises the node's own responsibility" $ do FOUND selfQueryRes <- queryLocalCache <$> node1 <*> cacheWith4Entries <*> pure 3 <*> pure nid1 - nid <$> node1 `shouldReturn` nid selfQueryRes + getNid <$> node1 `shouldReturn` getNid selfQueryRes FOUND responsibilityResult <- queryLocalCache <$> node1 <*> cacheWith4Entries <*> pure 3 <*> pure (toNodeID 2^(22::Integer)) - nid <$> node1 `shouldReturn` nid responsibilityResult + getNid <$> node1 `shouldReturn` getNid responsibilityResult it "does not fail on nodes without neighbours (initial state)" $ do (FORWARD nodeset) <- queryLocalCache <$> exampleLocalNode <*> cacheWith4Entries <*> pure 3 <*> pure (toNodeID 11) Set.map (nid . remoteNode ) nodeset `shouldBe` Set.fromList [nid4, nid2, nid3] @@ -243,18 +240,17 @@ spec = do -- some example data -exampleNodeState :: NodeState -exampleNodeState = NodeState { +exampleNodeState :: RemoteNodeState +exampleNodeState = RemoteNodeState { nid = toNodeID 12 , domain = exampleNodeDomain , ipAddr = exampleIp , dhtPort = 2342 - , apPort = Nothing + , servicePort = 513 , vServerID = 0 - , internals = Nothing } -exampleLocalNode :: IO NodeState +exampleLocalNode :: IO LocalNodeState exampleLocalNode = nodeStateInit $ FediChordConf { confDomain = "example.social" , confIP = exampleIp From d5841d13fd93d9f2806cea677e399c6e1c40f8f1 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Fri, 22 May 2020 22:02:41 +0200 Subject: [PATCH 13/88] extract queryID message sending function so it can be used for first join --- src/Hash2Pub/DHTProtocol.hs | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 29f3b13..d59ec06 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -12,6 +12,8 @@ module Hash2Pub.DHTProtocol , ActionPayload(..) , FediChordMessage(..) , maximumParts + , sendQueryIdMessage + , requestQueryID ) where @@ -152,7 +154,7 @@ requestQueryID ns targetID = do -- create connected sockets to all query targets sockets <- mapM (\resultNode -> mkSendSocket (domain resultNode) (dhtPort resultNode)) $ remoteNode <$> Set.toList nodeSet -- ToDo: make attempts and timeout configurable - queryThreads <- mapM (async . sendRequestTo 5000 3 (lookupMessage targetID)) sockets + queryThreads <- mapM (async . sendQueryIdMessage targetID ns) sockets -- ToDo: process results immediately instead of waiting for the last one to finish, see https://stackoverflow.com/a/38815224/9198613 -- ToDo: exception handling, maybe log them responses <- (mconcat . fmap Set.elems) . rights <$> mapM waitCatch queryThreads @@ -179,8 +181,15 @@ requestQueryID ns targetID = do -- if no FOUND, recursively call lookup again maybe (lookupLoop newLCache) pure foundResp - lookupMessage targetID rID = Request rID (toRemoteNodeState ns) 1 1 QueryID (Just $ pl ns targetID) - pl ns' targetID' = QueryIDRequestPayload { queryTargetID = targetID', queryLBestNodes = fromIntegral . lNumBestNodes $ ns } + +sendQueryIdMessage :: NodeID -- ^ target key ID to look up + -> LocalNodeState -- ^ node state of the node doing the query + -> Socket -- ^ connected socket to use for sending + -> IO (Set.Set FediChordMessage) -- ^ responses +sendQueryIdMessage targetID ns = sendRequestTo 5000 3 (lookupMessage targetID ns) + where + lookupMessage targetID ns rID = Request rID (toRemoteNodeState ns) 1 1 QueryID (Just $ pl ns targetID) + pl ns' targetID' = QueryIDRequestPayload { queryTargetID = targetID', queryLBestNodes = fromIntegral . lNumBestNodes $ ns } -- | Generic function for sending a request over a connected socket and collecting the response. -- Serialises the message and tries to deliver its parts for a number of attempts within a specified timeout. From e3bfa26ddba3dc011bfdc414960d278fca0ca5a1 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 25 May 2020 22:00:22 +0200 Subject: [PATCH 14/88] join request + large FediChord refactoring - implement sending of initial join request sending, response parsing and cache population (untested but compiles) - refactor basic types and their functions into Hash2Pub.FediChordTypes to prevent import loops, leaving Hash2Pub.FediChord to contain the high level actions called from Main --- Hash2Pub.cabal | 2 +- src/Hash2Pub/ASN1Coding.hs | 2 +- src/Hash2Pub/DHTProtocol.hs | 171 ++++++++---- src/Hash2Pub/FediChord.hs | 461 +++------------------------------ src/Hash2Pub/FediChordTypes.hs | 428 ++++++++++++++++++++++++++++++ src/Hash2Pub/ProtocolTypes.hs | 10 +- 6 files changed, 607 insertions(+), 467 deletions(-) create mode 100644 src/Hash2Pub/FediChordTypes.hs diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal index f1533f4..2286385 100644 --- a/Hash2Pub.cabal +++ b/Hash2Pub.cabal @@ -55,7 +55,7 @@ library import: deps -- Modules exported by the library. - exposed-modules: Hash2Pub.FediChord, Hash2Pub.DHTProtocol, Hash2Pub.ASN1Coding, Hash2Pub.ProtocolTypes + exposed-modules: Hash2Pub.FediChord, Hash2Pub.FediChordTypes, Hash2Pub.DHTProtocol, Hash2Pub.ASN1Coding, Hash2Pub.ProtocolTypes -- Modules included in this library but not exported. other-modules: Hash2Pub.Utils diff --git a/src/Hash2Pub/ASN1Coding.hs b/src/Hash2Pub/ASN1Coding.hs index 47492ef..abf749b 100644 --- a/src/Hash2Pub/ASN1Coding.hs +++ b/src/Hash2Pub/ASN1Coding.hs @@ -16,7 +16,7 @@ import qualified Data.Set as Set import Data.Time.Clock.POSIX () import Safe -import Hash2Pub.FediChord +import Hash2Pub.FediChordTypes import Hash2Pub.ProtocolTypes import Hash2Pub.Utils diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index d59ec06..7b07785 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -14,6 +14,11 @@ module Hash2Pub.DHTProtocol , maximumParts , sendQueryIdMessage , requestQueryID + , requestJoin + , queryIdLookupLoop + , resolve + , mkSendSocket + , mkServerSocket ) where @@ -24,8 +29,11 @@ import Control.Concurrent.STM.TQueue import Control.Monad (foldM, forM, forM_) import qualified Data.ByteString as BS import Data.Either (rights) -import Data.Foldable (foldl') +import Data.Foldable (foldl', foldr') import Data.IORef +import Data.IP (IPv6, fromHostAddress6, + toHostAddress6) +import Data.List (sortBy) import qualified Data.Map as Map import Data.Maybe (fromJust, fromMaybe, mapMaybe, maybe) @@ -39,15 +47,15 @@ import System.Random import System.Timeout import Hash2Pub.ASN1Coding -import Hash2Pub.FediChord (CacheEntry (..), +import Hash2Pub.FediChordTypes (CacheEntry (..), LocalNodeState (..), NodeCache, NodeID, NodeState (..), RemoteNodeState (..), cacheGetNodeStateUnvalidated, cacheLookup, cacheLookupPred, cacheLookupSucc, localCompare, - mkSendSocket, mkServerSocket, - setPredecessors, setSuccessors) + localCompare, setPredecessors, + setSuccessors) import Hash2Pub.ProtocolTypes import Debug.Trace (trace) @@ -134,52 +142,85 @@ markCacheEntryAsVerified timestamp = Map.adjust adjustFunc -- ====== message send and receive operations ====== -requestQueryID :: LocalNodeState -> NodeID -> IO RemoteNodeState +-- | send a join request and return the joined 'LocalNodeState' including neighbours +requestJoin :: NodeState a => a -- ^ currently responsible node to be contacted + -> LocalNodeState -- ^ joining NodeState + -> IO (Maybe LocalNodeState) -- ^ node after join with all its new information +requestJoin toJoinOn ownState = do + sock <- mkSendSocket (getDomain toJoinOn) (getDhtPort toJoinOn) + responses <- sendRequestTo 5000 3 (\rid -> Request rid (toRemoteNodeState ownState) 1 1 Join (Just JoinRequestPayload)) sock + joinedStateUnsorted <- foldM + (\nsAcc msg -> case payload msg of + Nothing -> pure nsAcc + Just msgPl -> do + -- add transfered cache entries to global NodeCache + queueAddEntries (joinCache msgPl) nsAcc + -- add received predecessors and successors + let + addPreds ns' = setPredecessors (foldr' (:) (predecessors ns') (joinPredecessors msgPl)) ns' + addSuccs ns' = setSuccessors (foldr' (:) (successors ns') (joinSuccessors msgPl)) ns' + pure $ addSuccs . addPreds $ nsAcc + ) + -- reset predecessors and successors + (setPredecessors [] . setSuccessors [] $ ownState) + responses + if responses == Set.empty + then pure Nothing + -- sort successors and predecessors + else pure . Just . setSuccessors (sortBy localCompare $ successors joinedStateUnsorted) . setPredecessors (sortBy localCompare $ predecessors joinedStateUnsorted) $ joinedStateUnsorted + + +-- | Send a 'QueryID' 'Request' for getting the node that handles a certain key ID. +requestQueryID :: LocalNodeState -- ^ NodeState of the querying node + -> NodeID -- ^ target key ID to look up + -> IO RemoteNodeState -- ^ the node responsible for handling that key -- 1. do a local lookup for the l closest nodes -- 2. create l sockets -- 3. send a message async concurrently to all l nodes -- 4. collect the results, insert them into cache -- 5. repeat until FOUND (problem: new entries not necessarily already in cache, explicitly compare with closer results) +-- TODO: deal with lookup failures requestQueryID ns targetID = do firstCacheSnapshot <- readIORef . nodeCacheRef $ ns - lookupLoop firstCacheSnapshot - where - lookupLoop :: NodeCache -> IO RemoteNodeState - lookupLoop cacheSnapshot = do - let localResult = queryLocalCache ns cacheSnapshot (lNumBestNodes ns) targetID - -- FOUND can only be returned if targetID is owned by local node - case localResult of - FOUND thisNode -> pure thisNode - FORWARD nodeSet -> do - -- create connected sockets to all query targets - sockets <- mapM (\resultNode -> mkSendSocket (domain resultNode) (dhtPort resultNode)) $ remoteNode <$> Set.toList nodeSet - -- ToDo: make attempts and timeout configurable - queryThreads <- mapM (async . sendQueryIdMessage targetID ns) sockets - -- ToDo: process results immediately instead of waiting for the last one to finish, see https://stackoverflow.com/a/38815224/9198613 - -- ToDo: exception handling, maybe log them - responses <- (mconcat . fmap Set.elems) . rights <$> mapM waitCatch queryThreads - -- insert new cache entries both into global cache as well as in local copy, to make sure it is already up to date at next lookup - now <- getPOSIXTime - newLCache <- foldM (\oldCache resp -> do - let entriesToInsert = case queryResult <$> payload resp of - Just (FOUND result1) -> [addCacheEntryPure now (RemoteCacheEntry result1 now)] - Just (FORWARD resultset) -> addCacheEntryPure now <$> Set.elems resultset - _ -> [] - -- forward entries to global cache - forM_ entriesToInsert $ \entry -> atomically $ writeTQueue (cacheWriteQueue ns) entry - -- insert entries into local cache copy - pure $ foldl' ( - \oldLCache insertFunc -> insertFunc oldLCache - ) oldCache entriesToInsert - ) cacheSnapshot responses + queryIdLookupLoop firstCacheSnapshot ns targetID - -- check for a FOUND and return it - let foundResp = headMay . mapMaybe (\resp -> case queryResult <$> payload resp of - Just (FOUND ns') -> Just ns' - _ -> Nothing - ) $ responses - -- if no FOUND, recursively call lookup again - maybe (lookupLoop newLCache) pure foundResp +-- | like 'requestQueryID, but allows passing of a custom cache, e.g. for joining +queryIdLookupLoop :: NodeCache -> LocalNodeState -> NodeID -> IO RemoteNodeState +queryIdLookupLoop cacheSnapshot ns targetID = do + let localResult = queryLocalCache ns cacheSnapshot (lNumBestNodes ns) targetID + -- FOUND can only be returned if targetID is owned by local node + case localResult of + FOUND thisNode -> pure thisNode + FORWARD nodeSet -> do + -- create connected sockets to all query targets + sockets <- mapM (\resultNode -> mkSendSocket (getDomain resultNode) (getDhtPort resultNode)) $ remoteNode <$> Set.toList nodeSet + -- ToDo: make attempts and timeout configurable + queryThreads <- mapM (async . sendQueryIdMessage targetID ns) sockets + -- ToDo: process results immediately instead of waiting for the last one to finish, see https://stackoverflow.com/a/38815224/9198613 + -- ToDo: exception handling, maybe log them + responses <- (mconcat . fmap Set.elems) . rights <$> mapM waitCatch queryThreads + -- insert new cache entries both into global cache as well as in local copy, to make sure it is already up to date at next lookup + now <- getPOSIXTime + newLCache <- foldM (\oldCache resp -> do + let entriesToInsert = case queryResult <$> payload resp of + Just (FOUND result1) -> [addCacheEntryPure now (RemoteCacheEntry result1 now)] + Just (FORWARD resultset) -> addCacheEntryPure now <$> Set.elems resultset + _ -> [] + -- forward entries to global cache + forM_ entriesToInsert $ \entry -> atomically $ writeTQueue (cacheWriteQueue ns) entry + -- insert entries into local cache copy + pure $ foldl' ( + \oldLCache insertFunc -> insertFunc oldLCache + ) oldCache entriesToInsert + ) cacheSnapshot responses + + -- check for a FOUND and return it + let foundResp = headMay . mapMaybe (\resp -> case queryResult <$> payload resp of + Just (FOUND ns') -> Just ns' + _ -> Nothing + ) $ responses + -- if no FOUND, recursively call lookup again + maybe (queryIdLookupLoop newLCache ns targetID) pure foundResp sendQueryIdMessage :: NodeID -- ^ target key ID to look up @@ -208,8 +249,7 @@ sendRequestTo timeoutMillis numAttempts msgIncomplete sock = do attempts numAttempts . timeout timeoutMillis $ sendAndAck responseQ sock requests -- after timeout, check received responses, delete them from unacked message set/ map and rerun senAndAck with that if necessary. recvdParts <- atomically $ flushTBQueue responseQ - -- PLACEHOLDER - pure Set.empty + pure $ Set.fromList recvdParts where -- state reingeben: state = noch nicht geackte messages, result = responses sendAndAck :: TBQueue FediChordMessage -- ^ the queue for putting in the received responses @@ -242,6 +282,14 @@ sendRequestTo timeoutMillis numAttempts msgIncomplete sock = do else recvLoop responseQueue newRemaining receivedPartNums +-- | enqueue a list of RemoteCacheEntries to be added to the global NodeCache +queueAddEntries :: [RemoteCacheEntry] + -> LocalNodeState + -> IO () +queueAddEntries entries ns = do + now <- getPOSIXTime + forM_ entries $ \entry -> atomically $ writeTQueue (cacheWriteQueue ns) $ addCacheEntryPure now entry + -- | retry an IO action at most *i* times until it delivers a result attempts :: Int -- ^ number of retries *i* -> IO (Maybe a) -- ^ action to retry @@ -252,3 +300,38 @@ attempts i action = do case actionResult of Nothing -> attempts (i-1) action Just res -> pure $ Just res + +-- ====== network socket operations ====== + +-- | resolve a specified host and return the 'AddrInfo' for it. +-- If no hostname or IP is specified, the 'AddrInfo' can be used to bind to all +-- addresses; +-- if no port is specified an arbitrary free port is selected. +resolve :: Maybe String -- ^ hostname or IP address to be resolved + -> Maybe PortNumber -- ^ port number of either local bind or remote + -> IO AddrInfo +resolve host port = let + hints = defaultHints { addrFamily = AF_INET6, addrSocketType = Datagram + , addrFlags = [AI_PASSIVE] } + in + head <$> getAddrInfo (Just hints) host (show <$> port) + +-- | create an unconnected UDP Datagram 'Socket' bound to the specified address +mkServerSocket :: HostAddress6 -> PortNumber -> IO Socket +mkServerSocket ip port = do + sockAddr <- addrAddress <$> resolve (Just $ show . fromHostAddress6 $ ip) (Just port) + sock <- socket AF_INET6 Datagram defaultProtocol + setSocketOption sock IPv6Only 1 + bind sock sockAddr + pure sock + +-- | create a UDP datagram socket, connected to a destination. +-- The socket gets an arbitrary free local port assigned. +mkSendSocket :: String -- ^ destination hostname or IP + -> PortNumber -- ^ destination port + -> IO Socket -- ^ a socket with an arbitrary source port +mkSendSocket dest destPort = do + destAddr <- addrAddress <$> resolve (Just dest) (Just destPort) + sendSock <- socket AF_INET6 Datagram defaultProtocol + setSocketOption sendSock IPv6Only 1 + pure sendSock diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 565d09b..540267c 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} {- | Module : FediChord Description : An opinionated implementation of the EpiChord DHT by Leong et al. @@ -46,8 +45,10 @@ module Hash2Pub.FediChord ( ) where import Control.Exception +import Data.Foldable (foldr') import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, isJust, mapMaybe) +import qualified Data.Set as Set import Data.Time.Clock.POSIX import Network.Socket @@ -66,379 +67,12 @@ import Data.Typeable (Typeable (..), typeOf) import Data.Word import qualified Network.ByteOrder as NetworkBytes +import Hash2Pub.DHTProtocol +import Hash2Pub.FediChordTypes import Hash2Pub.Utils import Debug.Trace (trace) --- define protocol constants --- | static definition of ID length in bits -idBits :: Integer -idBits = 256 - --- |NodeIDs are Integers wrapped in a newtype, to be able to redefine --- their instance behaviour --- --- for being able to check value bounds, the constructor should not be used directly --- and new values are created via @toNodeID@ (newtype constructors cannot be hidden) -newtype NodeID = NodeID { getNodeID :: Integer } deriving stock (Show, Eq) deriving newtype Enum - --- |smart data constructor for NodeID that throws a runtime exception for out-of-bounds values. --- When needing a runtime-safe constructor with drawbacks, try @fromInteger@ -toNodeID :: Integer -> NodeID -toNodeID i = assert (i >= getNodeID minBound && i <= getNodeID maxBound) $ NodeID i - --- |NodeIDs are bounded by the value range of an unsigned Integer of length 'idBits' -instance Bounded NodeID where - minBound = NodeID 0 - maxBound = NodeID (2^idBits - 1) - --- |calculations with NodeIDs are modular arithmetic operations -instance Num NodeID where - a + b = NodeID $ (getNodeID a + getNodeID b) `mod` (getNodeID maxBound + 1) - a * b = NodeID $ (getNodeID a * getNodeID b) `mod` (getNodeID maxBound + 1) - a - b = NodeID $ (getNodeID a - getNodeID b) `mod` (getNodeID maxBound + 1) - -- |safe constructor for NodeID values with the drawback, that out-of-bound values are wrapped around - -- with modulo to fit in the allowed value space. For runtime checking, look at @toNodeID@. - fromInteger i = NodeID $ i `mod` (getNodeID maxBound + 1) - signum = NodeID . signum . getNodeID - abs = NodeID . abs . getNodeID -- ToDo: make sure that at creation time only IDs within the range are used - --- | use normal strict monotonic ordering of integers, realising the ring structure --- is done in the @NodeCache@ implementation -instance Ord NodeID where - a `compare` b = getNodeID a `compare` getNodeID b - --- | local comparison of 2 node IDs, only relevant for determining a successor or predecessor on caches with just 2 nodes -localCompare :: NodeID -> NodeID -> Ordering -a `localCompare` b - | getNodeID a == getNodeID b = EQ - | wayForwards > wayBackwards = GT - | otherwise = LT - where - wayForwards = getNodeID (b - a) - wayBackwards = getNodeID (a - b) - - --- | represents a node and all its important state -data RemoteNodeState = RemoteNodeState - { nid :: NodeID - , domain :: String - -- ^ full public domain name the node is reachable under - , ipAddr :: HostAddress6 - -- the node's public IPv6 address - , dhtPort :: PortNumber - -- ^ port of the DHT itself - , servicePort :: PortNumber - -- ^ port of the service provided on top of the DHT - , vServerID :: Integer - -- ^ ID of this vserver - } - deriving (Show, Eq) - --- | represents a node and encapsulates all data and parameters that are not present for remote nodes -data LocalNodeState = LocalNodeState - { nodeState :: RemoteNodeState - -- ^ represents common data present both in remote and local node representations - , nodeCacheRef :: IORef NodeCache - -- ^ EpiChord node cache with expiry times for nodes - , cacheWriteQueue :: TQueue (NodeCache -> NodeCache) - -- ^ cache updates are not written directly to the 'nodeCache' but queued and - , successors :: [NodeID] -- could be a set instead as these are ordered as well - -- ^ successor nodes in ascending order by distance - , predecessors :: [NodeID] - -- ^ predecessor nodes in ascending order by distance - , kNeighbours :: Int - -- ^ desired length of predecessor and successor list - , lNumBestNodes :: Int - -- ^ number of best next hops to provide - , pNumParallelQueries :: Int - -- ^ number of parallel sent queries - , jEntriesPerSlice :: Int - -- ^ number of desired entries per cache slice - } - deriving (Show, Eq) - --- | class for various NodeState representations, providing --- getters and setters for common values -class NodeState a where - -- getters for common properties - getNid :: a -> NodeID - getDomain :: a -> String - getIpAddr :: a -> HostAddress6 - getDhtPort :: a -> PortNumber - getServicePort :: a -> PortNumber - getVServerID :: a -> Integer - -- setters for common properties - setNid :: NodeID -> a -> a - setDomain :: String -> a -> a - setIpAddr :: HostAddress6 -> a -> a - setDhtPort :: PortNumber -> a -> a - setServicePort :: PortNumber -> a -> a - setVServerID :: Integer -> a -> a - toRemoteNodeState :: a -> RemoteNodeState - -instance NodeState RemoteNodeState where - getNid = nid - getDomain = domain - getIpAddr = ipAddr - getDhtPort = dhtPort - getServicePort = servicePort - getVServerID = vServerID - setNid nid' ns = ns {nid = nid'} - setDomain domain' ns = ns {domain = domain'} - setIpAddr ipAddr' ns = ns {ipAddr = ipAddr'} - setDhtPort dhtPort' ns = ns {dhtPort = dhtPort'} - setServicePort servicePort' ns = ns {servicePort = servicePort'} - setVServerID vServerID' ns = ns {vServerID = vServerID'} - toRemoteNodeState = id - --- | helper function for setting values on the 'RemoteNodeState' contained in the 'LocalNodeState' -propagateNodeStateSet_ :: (RemoteNodeState -> RemoteNodeState) -> LocalNodeState -> LocalNodeState -propagateNodeStateSet_ func ns = let - newNs = func $ nodeState ns - in - ns {nodeState = newNs} - - -instance NodeState LocalNodeState where - getNid = getNid . nodeState - getDomain = getDomain . nodeState - getIpAddr = getIpAddr . nodeState - getDhtPort = getDhtPort . nodeState - getServicePort = getServicePort . nodeState - getVServerID = getVServerID . nodeState - setNid nid' = propagateNodeStateSet_ $ setNid nid' - setDomain domain' = propagateNodeStateSet_ $ setDomain domain' - setIpAddr ipAddr' = propagateNodeStateSet_ $ setIpAddr ipAddr' - setDhtPort dhtPort' = propagateNodeStateSet_ $ setDhtPort dhtPort' - setServicePort servicePort' = propagateNodeStateSet_ $ setServicePort servicePort' - setVServerID vServerID' = propagateNodeStateSet_ $ setVServerID vServerID' - toRemoteNodeState = nodeState - --- | defining Show instances to be able to print NodeState for debug purposes -instance Typeable a => Show (IORef a) where - show x = show (typeOf x) - -instance Typeable a => Show (TQueue a) where - show x = show (typeOf x) - --- | convenience function that updates the successors of a 'LocalNodeState' -setSuccessors :: [NodeID] -> LocalNodeState -> LocalNodeState -setSuccessors succ' ns = ns {successors = succ'} - --- | convenience function that updates the predecessors of a 'LocalNodeState' -setPredecessors :: [NodeID] -> LocalNodeState -> LocalNodeState -setPredecessors pred' ns = ns {predecessors = pred'} - -type NodeCache = Map.Map NodeID CacheEntry - --- | An entry of the 'nodeCache' can hold 2 different kinds of data. --- Type variable @a@ should be of type class 'NodeState', but I do not want to use GADTs here. -data CacheEntry = NodeEntry Bool RemoteNodeState POSIXTime - | ProxyEntry (NodeID, ProxyDirection) (Maybe CacheEntry) - deriving (Show, Eq) - --- | as a compromise, only NodeEntry components are ordered by their NodeID --- while ProxyEntry components should never be tried to be ordered. -instance Ord CacheEntry where - - a `compare` b = compare (extractID a) (extractID b) - where - extractID (NodeEntry _ eState _) = getNid eState - extractID (ProxyEntry _ _) = error "proxy entries should never appear outside of the NodeCache" - -data ProxyDirection = Backwards - | Forwards - deriving (Show, Eq) - -instance Enum ProxyDirection where - toEnum (-1) = Backwards - toEnum 1 = Forwards - toEnum _ = error "no such ProxyDirection" - fromEnum Backwards = - 1 - fromEnum Forwards = 1 - ---- useful function for getting entries for a full cache transfer -cacheEntries :: NodeCache -> [CacheEntry] -cacheEntries ncache = mapMaybe extractNodeEntries $ Map.elems ncache - where - extractNodeEntries (ProxyEntry _ possibleEntry) = possibleEntry - --- | An empty @NodeCache@ needs to be initialised with 2 proxy entries, --- linking the modular name space together by connecting @minBound@ and @maxBound@ -initCache :: NodeCache -initCache = Map.fromList $ proxyEntry <$> [(maxBound, (minBound, Forwards)), (minBound, (maxBound, Backwards))] - where - proxyEntry (from,to) = (from, ProxyEntry to Nothing) - --- | Maybe returns the cache entry stored at given key -cacheLookup :: NodeID -- ^lookup key - -> NodeCache -- ^lookup cache - -> Maybe CacheEntry -cacheLookup key cache = case Map.lookup key cache of - Just (ProxyEntry _ result) -> result - res -> res - --- | a wrapper around lookup functions, making the lookup redirectable by a @ProxyEntry@ --- to simulate a modular ring -lookupWrapper :: (NodeID -> NodeCache -> Maybe (NodeID, CacheEntry)) -> (NodeID -> NodeCache -> Maybe (NodeID, CacheEntry)) -> ProxyDirection -> NodeID -> NodeCache -> Maybe CacheEntry -lookupWrapper f fRepeat direction key cache = - case f key cache of - -- the proxy entry found holds a - Just (_, ProxyEntry _ (Just entry@NodeEntry{})) -> Just entry - -- proxy entry holds another proxy entry, this should not happen - Just (_, ProxyEntry _ (Just (ProxyEntry _ _))) -> Nothing - -- proxy entry without own entry is a pointer on where to continue - -- if lookup direction is the same as pointer direction: follow pointer - Just (foundKey, ProxyEntry (pointerID, pointerDirection) Nothing) -> - let newKey = if pointerDirection == direction - then pointerID - else foundKey + (fromInteger . toInteger . fromEnum $ direction) - in if cacheNotEmpty cache - then lookupWrapper fRepeat fRepeat direction newKey cache - else Nothing - -- normal entries are returned - Just (_, entry@NodeEntry{}) -> Just entry - Nothing -> Nothing - where - cacheNotEmpty :: NodeCache -> Bool - cacheNotEmpty cache' = (Map.size cache' > 2) -- there are more than the 2 ProxyEntries - || isJust ( cacheLookup minBound cache') -- or one of the ProxyEntries holds a node - || isJust (cacheLookup maxBound cache') - --- | find the successor node to a given key on a modular EpiChord ring cache. --- Note: The EpiChord definition of "successor" includes the node at the key itself, --- if existing. -cacheLookupSucc :: NodeID -- ^lookup key - -> NodeCache -- ^ring cache - -> Maybe CacheEntry -cacheLookupSucc = lookupWrapper Map.lookupGE Map.lookupGE Forwards - --- | find the predecessor node to a given key on a modular EpiChord ring cache. -cacheLookupPred :: NodeID -- ^lookup key - -> NodeCache -- ^ring cache - -> Maybe CacheEntry -cacheLookupPred = lookupWrapper Map.lookupLT Map.lookupLE Backwards - --- clean up cache entries: once now - entry > maxAge --- transfer difference now - entry to other node - --- | return the @NodeState@ data from a cache entry without checking its validation status -cacheGetNodeStateUnvalidated :: CacheEntry -> RemoteNodeState -cacheGetNodeStateUnvalidated (NodeEntry _ nState _) = nState -cacheGetNodeStateUnvalidated (ProxyEntry _ (Just entry)) = cacheGetNodeStateUnvalidated entry -cacheGetNodeStateUnvalidated _ = error "trying to pure empty node state, please report a bug" - --- | converts a 'HostAddress6' IP address to a big-endian strict ByteString -ipAddrAsBS :: HostAddress6 -> BS.ByteString -ipAddrAsBS (a, b, c, d) = mconcat $ fmap NetworkBytes.bytestring32 [a, b, c, d] - --- | converts a ByteString in big endian order to an IPv6 address 'HostAddress6' -bsAsIpAddr :: BS.ByteString -> HostAddress6 -bsAsIpAddr bytes = (a,b,c,d) - where - a:b:c:d:_ = fmap NetworkBytes.word32 . chunkBytes 4 $ bytes - - --- | generates a 256 bit long NodeID using SHAKE128, represented as ByteString -genNodeIDBS :: HostAddress6 -- ^a node's IPv6 address - -> String -- ^a node's 1st and 2nd level domain name - -> Word8 -- ^the used vserver ID - -> BS.ByteString -- ^the NodeID as a 256bit ByteString big-endian unsigned integer -genNodeIDBS ip nodeDomain vserver = - hashIpaddrUpper `BS.append` hashID nodeDomain' `BS.append` hashIpaddLower - where - vsBS = BS.pack [vserver] -- attention: only works for vserver IDs up to 255 - ipaddrNet = BS.take 8 (ipAddrAsBS ip) `BS.append` vsBS - nodeDomain' = BSU.fromString nodeDomain `BS.append` vsBS - hashID bstr = BS.pack . BA.unpack $ (hash bstr :: Digest (SHAKE128 128)) - (hashIpaddrUpper, hashIpaddLower) = BS.splitAt 64 $ hashID ipaddrNet - - --- | generates a 256 bit long @NodeID@ using SHAKE128 -genNodeID :: HostAddress6 -- ^a node's IPv6 address - -> String -- ^a node's 1st and 2nd level domain name - -> Word8 -- ^the used vserver ID - -> NodeID -- ^the generated @NodeID@ -genNodeID ip nodeDomain vs = NodeID . byteStringToUInteger $ genNodeIDBS ip nodeDomain vs - --- | generates a 256 bit long key identifier, represented as ByteString, for looking up its data on the DHT -genKeyIDBS :: String -- ^the key string - -> BS.ByteString -- ^the key ID represented as a @ByteString@ -genKeyIDBS key = BS.pack . BA.unpack $ (hash (BSU.fromString key) :: Digest SHA3_256) - --- | generates a 256 bit long key identifier for looking up its data on the DHT -genKeyID :: String -- ^the key string - -> NodeID -- ^the key ID -genKeyID = NodeID . byteStringToUInteger . genKeyIDBS - - --- | parses the bit pattern of a ByteString as an unsigned Integer in Big Endian order --- by iterating it byte-wise from the back and shifting the byte values according to their offset -byteStringToUInteger :: BS.ByteString -> Integer -byteStringToUInteger bs = sum $ parsedBytes 0 bs - where - parsedBytes :: Integer -> BS.ByteString -> [ Integer ] - parsedBytes offset uintBs = case BS.unsnoc uintBs of - Nothing -> [] - Just (bs', w) -> parseWithOffset offset w : parsedBytes (offset+1) bs' - - parseWithOffset :: Integer -> Word8 -> Integer - parseWithOffset 0 word = toInteger word -- a shift of 0 is always 0 - parseWithOffset offset word = toInteger word * 2^(8 * offset) - - - --- TODO: complete rewrite --- |checks wether the cache entries fulfill the logarithmic EpiChord invariant --- of having j entries per slice, and creates a list of necessary lookup actions. --- Should be invoked periodically. ---checkCacheSlices :: NodeState -> IO [()] ---checkCacheSlices state = case getNodeCache state of --- -- don't do anything on nodes without a cache --- Nothing -> pure [()] --- Just cache' -> checkSlice jEntries (nid state) startBound lastSucc =<< readIORef cache' --- -- TODO: do the same for predecessors --- where --- jEntries = fromMaybe 0 $ getInternals_ jEntriesPerSlice state --- lastSucc = last <$> maybeEmpty (fromMaybe [] $ getSuccessors state) --- startBound = NodeID 2^(255::Integer) + nid state --- checkSlice :: Int -> NodeID -> NodeID -> Maybe NodeID -> NodeCache -> [IO ()] --- checkSlice _ _ _ Nothing _ = [] --- checkSlice j ownID upperBound (Just lastSuccNode) cache --- | upperBound < lastSuccNode = [] --- | otherwise = --- -- continuously half the DHT namespace, take the upper part as a slice, --- -- check for existing entries in that slice and create a lookup action --- -- and recursively do this on the lower half. --- -- recursion edge case: all successors/ predecessors need to be in the --- -- first slice. --- let --- diff = getNodeID $ upperBound - ownID --- lowerBound = ownID + NodeID (diff `div` 2) --- in --- -- TODO: replace empty IO actions with actual lookups to middle of slice --- -- TODO: validate ID before adding to cache --- case Map.lookupLT upperBound cache of --- Nothing -> pure () : checkSlice j ownID lowerBound (Just lastSuccNode) cache --- Just (matchID, _) -> --- if --- matchID <= lowerBound then pure () : checkSlice j ownID lowerBound (Just lastSuccNode) cache --- else --- checkSlice j ownID lowerBound (Just lastSuccNode) cache - - --- Todo: DHT backend can learn potential initial bootstrapping points through the instances mentioned in the received AP-relay messages --- persist them on disk so they can be used for all following bootstraps - --- | configuration values used for initialising the FediChord DHT -data FediChordConf = FediChordConf - { confDomain :: String - , confIP :: HostAddress6 - , confDhtPort :: Int - } - deriving (Show, Eq) - -- | initialise data structures, compute own IDs and bind to listening socket -- ToDo: load persisted state, thus this function already operates in IO fediChordInit :: FediChordConf -> IO (Socket, LocalNodeState) @@ -475,16 +109,42 @@ nodeStateInit conf = do } pure initialState ---fediChordJoin :: LocalNodeState -- ^ the local 'NodeState' --- -> (String, PortNumber) -- ^ domain and port of a bootstrapping node --- -> Socket -- ^ socket used for sending and receiving the join message --- -> IO Either String NodeState -- ^ the joined 'NodeState' after a successful --- -- join, otherwise an error message ---fediChordJoin ns (joinHost, joinPort) sock = do --- -- 1. get routed to destination until FOUND --- -- 2. then send a join to the currently responsible node --- -- ToDo: implement cache management, as already all received replies should be stored in cache --- +fediChordJoin :: LocalNodeState -- ^ the local 'NodeState' + -> (String, PortNumber) -- ^ domain and port of a bootstrapping node + -> IO (Either String LocalNodeState) -- ^ the joined 'NodeState' after a + -- successful join, otherwise an error message +fediChordJoin ns (joinHost, joinPort) = do + -- can be invoked multiple times with all known bootstrapping nodes until successfully joined + sock <- mkSendSocket joinHost joinPort + -- 1. get routed to placement of own ID until FOUND: + -- Initialise an empty cache only with the responses from a bootstrapping node + bootstrapResponse <- sendQueryIdMessage (getNid ns) ns sock + if bootstrapResponse == Set.empty + then pure . Left $ "Bootstrapping node " <> show joinHost <> " gave no response." + else do + now <- getPOSIXTime + -- create new cache with all returned node responses + let bootstrapCache = + -- traverse response parts + foldr' (\resp cacheAcc -> case queryResult <$> payload resp of + Nothing -> cacheAcc + Just (FOUND result1) -> addCacheEntryPure now (RemoteCacheEntry result1 now) cacheAcc + Just (FORWARD resultset) -> foldr' (addCacheEntryPure now) cacheAcc resultset + ) + initCache bootstrapResponse + -- get routed to the currently responsible node, based on the response + -- from the bootstrapping node + currentlyResponsible <- queryIdLookupLoop bootstrapCache ns $ getNid ns + -- do actual join + joinResult <- requestJoin currentlyResponsible ns + case joinResult of + Nothing -> pure . Left $ "Error joining on " <> show currentlyResponsible + Just joinedNS -> pure . Right $ joinedNS + + + -- 2. then send a join to the currently responsible node + -- after successful join, finally add own node to the cache + -- | cache updater thread that waits for incoming NodeCache update instructions on -- the node's cacheWriteQueue and then modifies the NodeCache as the single writer. @@ -497,38 +157,3 @@ cacheWriter ns = do refModifier :: NodeCache -> (NodeCache, ()) refModifier nc = (f nc, ()) atomicModifyIORef' (nodeCacheRef ns) refModifier - --- ====== network socket operations ====== - --- | resolve a specified host and return the 'AddrInfo' for it. --- If no hostname or IP is specified, the 'AddrInfo' can be used to bind to all --- addresses; --- if no port is specified an arbitrary free port is selected. -resolve :: Maybe String -- ^ hostname or IP address to be resolved - -> Maybe PortNumber -- ^ port number of either local bind or remote - -> IO AddrInfo -resolve host port = let - hints = defaultHints { addrFamily = AF_INET6, addrSocketType = Datagram - , addrFlags = [AI_PASSIVE] } - in - head <$> getAddrInfo (Just hints) host (show <$> port) - --- | create an unconnected UDP Datagram 'Socket' bound to the specified address -mkServerSocket :: HostAddress6 -> PortNumber -> IO Socket -mkServerSocket ip port = do - sockAddr <- addrAddress <$> resolve (Just $ show . fromHostAddress6 $ ip) (Just port) - sock <- socket AF_INET6 Datagram defaultProtocol - setSocketOption sock IPv6Only 1 - bind sock sockAddr - pure sock - --- | create a UDP datagram socket, connected to a destination. --- The socket gets an arbitrary free local port assigned. -mkSendSocket :: String -- ^ destination hostname or IP - -> PortNumber -- ^ destination port - -> IO Socket -- ^ a socket with an arbitrary source port -mkSendSocket dest destPort = do - destAddr <- addrAddress <$> resolve (Just dest) (Just destPort) - sendSock <- socket AF_INET6 Datagram defaultProtocol - setSocketOption sendSock IPv6Only 1 - pure sendSock diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs new file mode 100644 index 0000000..7ad09a9 --- /dev/null +++ b/src/Hash2Pub/FediChordTypes.hs @@ -0,0 +1,428 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Hash2Pub.FediChordTypes ( + NodeID -- abstract, but newtype constructors cannot be hidden + , getNodeID + , toNodeID + , NodeState (..) + , LocalNodeState (..) + , RemoteNodeState (..) + , setSuccessors + , setPredecessors + , NodeCache + , CacheEntry(..) + , cacheGetNodeStateUnvalidated + , initCache + , cacheLookup + , cacheLookupSucc + , cacheLookupPred + , localCompare + , genNodeID + , genNodeIDBS + , genKeyID + , genKeyIDBS + , byteStringToUInteger + , ipAddrAsBS + , bsAsIpAddr + , FediChordConf(..) + ) where + +import Control.Exception +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, isJust, mapMaybe) +import qualified Data.Set as Set +import Data.Time.Clock.POSIX +import Network.Socket + +-- for hashing and ID conversion +import Control.Concurrent.STM +import Control.Concurrent.STM.TQueue +import Control.Monad (forever) +import Crypto.Hash +import qualified Data.ByteArray as BA +import qualified Data.ByteString as BS +import qualified Data.ByteString.UTF8 as BSU +import Data.IORef +import Data.IP (IPv6, fromHostAddress6, + toHostAddress6) +import Data.Typeable (Typeable (..), typeOf) +import Data.Word +import qualified Network.ByteOrder as NetworkBytes + +import Hash2Pub.Utils + + + +-- define protocol constants +-- | static definition of ID length in bits +idBits :: Integer +idBits = 256 + +-- |NodeIDs are Integers wrapped in a newtype, to be able to redefine +-- their instance behaviour +-- +-- for being able to check value bounds, the constructor should not be used directly +-- and new values are created via @toNodeID@ (newtype constructors cannot be hidden) +newtype NodeID = NodeID { getNodeID :: Integer } deriving stock (Show, Eq) deriving newtype Enum + +-- |smart data constructor for NodeID that throws a runtime exception for out-of-bounds values. +-- When needing a runtime-safe constructor with drawbacks, try @fromInteger@ +toNodeID :: Integer -> NodeID +toNodeID i = assert (i >= getNodeID minBound && i <= getNodeID maxBound) $ NodeID i + +-- |NodeIDs are bounded by the value range of an unsigned Integer of length 'idBits' +instance Bounded NodeID where + minBound = NodeID 0 + maxBound = NodeID (2^idBits - 1) + +-- |calculations with NodeIDs are modular arithmetic operations +instance Num NodeID where + a + b = NodeID $ (getNodeID a + getNodeID b) `mod` (getNodeID maxBound + 1) + a * b = NodeID $ (getNodeID a * getNodeID b) `mod` (getNodeID maxBound + 1) + a - b = NodeID $ (getNodeID a - getNodeID b) `mod` (getNodeID maxBound + 1) + -- |safe constructor for NodeID values with the drawback, that out-of-bound values are wrapped around + -- with modulo to fit in the allowed value space. For runtime checking, look at @toNodeID@. + fromInteger i = NodeID $ i `mod` (getNodeID maxBound + 1) + signum = NodeID . signum . getNodeID + abs = NodeID . abs . getNodeID -- ToDo: make sure that at creation time only IDs within the range are used + +-- | use normal strict monotonic ordering of integers, realising the ring structure +-- is done in the @NodeCache@ implementation +instance Ord NodeID where + a `compare` b = getNodeID a `compare` getNodeID b + +-- | local comparison of 2 node IDs, only relevant for determining a successor or predecessor on caches with just 2 nodes +localCompare :: NodeID -> NodeID -> Ordering +a `localCompare` b + | getNodeID a == getNodeID b = EQ + | wayForwards > wayBackwards = GT + | otherwise = LT + where + wayForwards = getNodeID (b - a) + wayBackwards = getNodeID (a - b) + + +-- | represents a node and all its important state +data RemoteNodeState = RemoteNodeState + { nid :: NodeID + , domain :: String + -- ^ full public domain name the node is reachable under + , ipAddr :: HostAddress6 + -- the node's public IPv6 address + , dhtPort :: PortNumber + -- ^ port of the DHT itself + , servicePort :: PortNumber + -- ^ port of the service provided on top of the DHT + , vServerID :: Integer + -- ^ ID of this vserver + } + deriving (Show, Eq) + +-- | represents a node and encapsulates all data and parameters that are not present for remote nodes +data LocalNodeState = LocalNodeState + { nodeState :: RemoteNodeState + -- ^ represents common data present both in remote and local node representations + , nodeCacheRef :: IORef NodeCache + -- ^ EpiChord node cache with expiry times for nodes + , cacheWriteQueue :: TQueue (NodeCache -> NodeCache) + -- ^ cache updates are not written directly to the 'nodeCache' but queued and + , successors :: [NodeID] -- could be a set instead as these are ordered as well + -- ^ successor nodes in ascending order by distance + , predecessors :: [NodeID] + -- ^ predecessor nodes in ascending order by distance + , kNeighbours :: Int + -- ^ desired length of predecessor and successor list + , lNumBestNodes :: Int + -- ^ number of best next hops to provide + , pNumParallelQueries :: Int + -- ^ number of parallel sent queries + , jEntriesPerSlice :: Int + -- ^ number of desired entries per cache slice + } + deriving (Show, Eq) + +-- | class for various NodeState representations, providing +-- getters and setters for common values +class NodeState a where + -- getters for common properties + getNid :: a -> NodeID + getDomain :: a -> String + getIpAddr :: a -> HostAddress6 + getDhtPort :: a -> PortNumber + getServicePort :: a -> PortNumber + getVServerID :: a -> Integer + -- setters for common properties + setNid :: NodeID -> a -> a + setDomain :: String -> a -> a + setIpAddr :: HostAddress6 -> a -> a + setDhtPort :: PortNumber -> a -> a + setServicePort :: PortNumber -> a -> a + setVServerID :: Integer -> a -> a + toRemoteNodeState :: a -> RemoteNodeState + +instance NodeState RemoteNodeState where + getNid = nid + getDomain = domain + getIpAddr = ipAddr + getDhtPort = dhtPort + getServicePort = servicePort + getVServerID = vServerID + setNid nid' ns = ns {nid = nid'} + setDomain domain' ns = ns {domain = domain'} + setIpAddr ipAddr' ns = ns {ipAddr = ipAddr'} + setDhtPort dhtPort' ns = ns {dhtPort = dhtPort'} + setServicePort servicePort' ns = ns {servicePort = servicePort'} + setVServerID vServerID' ns = ns {vServerID = vServerID'} + toRemoteNodeState = id + +-- | helper function for setting values on the 'RemoteNodeState' contained in the 'LocalNodeState' +propagateNodeStateSet_ :: (RemoteNodeState -> RemoteNodeState) -> LocalNodeState -> LocalNodeState +propagateNodeStateSet_ func ns = let + newNs = func $ nodeState ns + in + ns {nodeState = newNs} + + +instance NodeState LocalNodeState where + getNid = getNid . nodeState + getDomain = getDomain . nodeState + getIpAddr = getIpAddr . nodeState + getDhtPort = getDhtPort . nodeState + getServicePort = getServicePort . nodeState + getVServerID = getVServerID . nodeState + setNid nid' = propagateNodeStateSet_ $ setNid nid' + setDomain domain' = propagateNodeStateSet_ $ setDomain domain' + setIpAddr ipAddr' = propagateNodeStateSet_ $ setIpAddr ipAddr' + setDhtPort dhtPort' = propagateNodeStateSet_ $ setDhtPort dhtPort' + setServicePort servicePort' = propagateNodeStateSet_ $ setServicePort servicePort' + setVServerID vServerID' = propagateNodeStateSet_ $ setVServerID vServerID' + toRemoteNodeState = nodeState + +-- | defining Show instances to be able to print NodeState for debug purposes +instance Typeable a => Show (IORef a) where + show x = show (typeOf x) + +instance Typeable a => Show (TQueue a) where + show x = show (typeOf x) + +-- | convenience function that updates the successors of a 'LocalNodeState' +setSuccessors :: [NodeID] -> LocalNodeState -> LocalNodeState +setSuccessors succ' ns = ns {successors = succ'} + +-- | convenience function that updates the predecessors of a 'LocalNodeState' +setPredecessors :: [NodeID] -> LocalNodeState -> LocalNodeState +setPredecessors pred' ns = ns {predecessors = pred'} + +type NodeCache = Map.Map NodeID CacheEntry + +-- | An entry of the 'nodeCache' can hold 2 different kinds of data. +-- Type variable @a@ should be of type class 'NodeState', but I do not want to use GADTs here. +data CacheEntry = NodeEntry Bool RemoteNodeState POSIXTime + | ProxyEntry (NodeID, ProxyDirection) (Maybe CacheEntry) + deriving (Show, Eq) + +-- | as a compromise, only NodeEntry components are ordered by their NodeID +-- while ProxyEntry components should never be tried to be ordered. +instance Ord CacheEntry where + + a `compare` b = compare (extractID a) (extractID b) + where + extractID (NodeEntry _ eState _) = getNid eState + extractID (ProxyEntry _ _) = error "proxy entries should never appear outside of the NodeCache" + +data ProxyDirection = Backwards + | Forwards + deriving (Show, Eq) + +instance Enum ProxyDirection where + toEnum (-1) = Backwards + toEnum 1 = Forwards + toEnum _ = error "no such ProxyDirection" + fromEnum Backwards = - 1 + fromEnum Forwards = 1 + +--- useful function for getting entries for a full cache transfer +cacheEntries :: NodeCache -> [CacheEntry] +cacheEntries ncache = mapMaybe extractNodeEntries $ Map.elems ncache + where + extractNodeEntries (ProxyEntry _ possibleEntry) = possibleEntry + +-- | An empty @NodeCache@ needs to be initialised with 2 proxy entries, +-- linking the modular name space together by connecting @minBound@ and @maxBound@ +initCache :: NodeCache +initCache = Map.fromList $ proxyEntry <$> [(maxBound, (minBound, Forwards)), (minBound, (maxBound, Backwards))] + where + proxyEntry (from,to) = (from, ProxyEntry to Nothing) + +-- | Maybe returns the cache entry stored at given key +cacheLookup :: NodeID -- ^lookup key + -> NodeCache -- ^lookup cache + -> Maybe CacheEntry +cacheLookup key cache = case Map.lookup key cache of + Just (ProxyEntry _ result) -> result + res -> res + +-- | a wrapper around lookup functions, making the lookup redirectable by a @ProxyEntry@ +-- to simulate a modular ring +lookupWrapper :: (NodeID -> NodeCache -> Maybe (NodeID, CacheEntry)) -> (NodeID -> NodeCache -> Maybe (NodeID, CacheEntry)) -> ProxyDirection -> NodeID -> NodeCache -> Maybe CacheEntry +lookupWrapper f fRepeat direction key cache = + case f key cache of + -- the proxy entry found holds a + Just (_, ProxyEntry _ (Just entry@NodeEntry{})) -> Just entry + -- proxy entry holds another proxy entry, this should not happen + Just (_, ProxyEntry _ (Just (ProxyEntry _ _))) -> Nothing + -- proxy entry without own entry is a pointer on where to continue + -- if lookup direction is the same as pointer direction: follow pointer + Just (foundKey, ProxyEntry (pointerID, pointerDirection) Nothing) -> + let newKey = if pointerDirection == direction + then pointerID + else foundKey + (fromInteger . toInteger . fromEnum $ direction) + in if cacheNotEmpty cache + then lookupWrapper fRepeat fRepeat direction newKey cache + else Nothing + -- normal entries are returned + Just (_, entry@NodeEntry{}) -> Just entry + Nothing -> Nothing + where + cacheNotEmpty :: NodeCache -> Bool + cacheNotEmpty cache' = (Map.size cache' > 2) -- there are more than the 2 ProxyEntries + || isJust ( cacheLookup minBound cache') -- or one of the ProxyEntries holds a node + || isJust (cacheLookup maxBound cache') + +-- | find the successor node to a given key on a modular EpiChord ring cache. +-- Note: The EpiChord definition of "successor" includes the node at the key itself, +-- if existing. +cacheLookupSucc :: NodeID -- ^lookup key + -> NodeCache -- ^ring cache + -> Maybe CacheEntry +cacheLookupSucc = lookupWrapper Map.lookupGE Map.lookupGE Forwards + +-- | find the predecessor node to a given key on a modular EpiChord ring cache. +cacheLookupPred :: NodeID -- ^lookup key + -> NodeCache -- ^ring cache + -> Maybe CacheEntry +cacheLookupPred = lookupWrapper Map.lookupLT Map.lookupLE Backwards + +-- clean up cache entries: once now - entry > maxAge +-- transfer difference now - entry to other node + +-- | return the @NodeState@ data from a cache entry without checking its validation status +cacheGetNodeStateUnvalidated :: CacheEntry -> RemoteNodeState +cacheGetNodeStateUnvalidated (NodeEntry _ nState _) = nState +cacheGetNodeStateUnvalidated (ProxyEntry _ (Just entry)) = cacheGetNodeStateUnvalidated entry +cacheGetNodeStateUnvalidated _ = error "trying to pure empty node state, please report a bug" + +-- | converts a 'HostAddress6' IP address to a big-endian strict ByteString +ipAddrAsBS :: HostAddress6 -> BS.ByteString +ipAddrAsBS (a, b, c, d) = mconcat $ fmap NetworkBytes.bytestring32 [a, b, c, d] + +-- | converts a ByteString in big endian order to an IPv6 address 'HostAddress6' +bsAsIpAddr :: BS.ByteString -> HostAddress6 +bsAsIpAddr bytes = (a,b,c,d) + where + a:b:c:d:_ = fmap NetworkBytes.word32 . chunkBytes 4 $ bytes + + +-- | generates a 256 bit long NodeID using SHAKE128, represented as ByteString +genNodeIDBS :: HostAddress6 -- ^a node's IPv6 address + -> String -- ^a node's 1st and 2nd level domain name + -> Word8 -- ^the used vserver ID + -> BS.ByteString -- ^the NodeID as a 256bit ByteString big-endian unsigned integer +genNodeIDBS ip nodeDomain vserver = + hashIpaddrUpper `BS.append` hashID nodeDomain' `BS.append` hashIpaddLower + where + vsBS = BS.pack [vserver] -- attention: only works for vserver IDs up to 255 + ipaddrNet = BS.take 8 (ipAddrAsBS ip) `BS.append` vsBS + nodeDomain' = BSU.fromString nodeDomain `BS.append` vsBS + hashID bstr = BS.pack . BA.unpack $ (hash bstr :: Digest (SHAKE128 128)) + (hashIpaddrUpper, hashIpaddLower) = BS.splitAt 64 $ hashID ipaddrNet + + +-- | generates a 256 bit long @NodeID@ using SHAKE128 +genNodeID :: HostAddress6 -- ^a node's IPv6 address + -> String -- ^a node's 1st and 2nd level domain name + -> Word8 -- ^the used vserver ID + -> NodeID -- ^the generated @NodeID@ +genNodeID ip nodeDomain vs = NodeID . byteStringToUInteger $ genNodeIDBS ip nodeDomain vs + +-- | generates a 256 bit long key identifier, represented as ByteString, for looking up its data on the DHT +genKeyIDBS :: String -- ^the key string + -> BS.ByteString -- ^the key ID represented as a @ByteString@ +genKeyIDBS key = BS.pack . BA.unpack $ (hash (BSU.fromString key) :: Digest SHA3_256) + +-- | generates a 256 bit long key identifier for looking up its data on the DHT +genKeyID :: String -- ^the key string + -> NodeID -- ^the key ID +genKeyID = NodeID . byteStringToUInteger . genKeyIDBS + + +-- | parses the bit pattern of a ByteString as an unsigned Integer in Big Endian order +-- by iterating it byte-wise from the back and shifting the byte values according to their offset +byteStringToUInteger :: BS.ByteString -> Integer +byteStringToUInteger bs = sum $ parsedBytes 0 bs + where + parsedBytes :: Integer -> BS.ByteString -> [ Integer ] + parsedBytes offset uintBs = case BS.unsnoc uintBs of + Nothing -> [] + Just (bs', w) -> parseWithOffset offset w : parsedBytes (offset+1) bs' + + parseWithOffset :: Integer -> Word8 -> Integer + parseWithOffset 0 word = toInteger word -- a shift of 0 is always 0 + parseWithOffset offset word = toInteger word * 2^(8 * offset) + + + +-- TODO: complete rewrite +-- |checks wether the cache entries fulfill the logarithmic EpiChord invariant +-- of having j entries per slice, and creates a list of necessary lookup actions. +-- Should be invoked periodically. +--checkCacheSlices :: NodeState -> IO [()] +--checkCacheSlices state = case getNodeCache state of +-- -- don't do anything on nodes without a cache +-- Nothing -> pure [()] +-- Just cache' -> checkSlice jEntries (nid state) startBound lastSucc =<< readIORef cache' +-- -- TODO: do the same for predecessors +-- where +-- jEntries = fromMaybe 0 $ getInternals_ jEntriesPerSlice state +-- lastSucc = last <$> maybeEmpty (fromMaybe [] $ getSuccessors state) +-- startBound = NodeID 2^(255::Integer) + nid state +-- checkSlice :: Int -> NodeID -> NodeID -> Maybe NodeID -> NodeCache -> [IO ()] +-- checkSlice _ _ _ Nothing _ = [] +-- checkSlice j ownID upperBound (Just lastSuccNode) cache +-- | upperBound < lastSuccNode = [] +-- | otherwise = +-- -- continuously half the DHT namespace, take the upper part as a slice, +-- -- check for existing entries in that slice and create a lookup action +-- -- and recursively do this on the lower half. +-- -- recursion edge case: all successors/ predecessors need to be in the +-- -- first slice. +-- let +-- diff = getNodeID $ upperBound - ownID +-- lowerBound = ownID + NodeID (diff `div` 2) +-- in +-- -- TODO: replace empty IO actions with actual lookups to middle of slice +-- -- TODO: validate ID before adding to cache +-- case Map.lookupLT upperBound cache of +-- Nothing -> pure () : checkSlice j ownID lowerBound (Just lastSuccNode) cache +-- Just (matchID, _) -> +-- if +-- matchID <= lowerBound then pure () : checkSlice j ownID lowerBound (Just lastSuccNode) cache +-- else +-- checkSlice j ownID lowerBound (Just lastSuccNode) cache + + +-- Todo: DHT backend can learn potential initial bootstrapping points through the instances mentioned in the received AP-relay messages +-- persist them on disk so they can be used for all following bootstraps + +-- | configuration values used for initialising the FediChord DHT +data FediChordConf = FediChordConf + { confDomain :: String + , confIP :: HostAddress6 + , confDhtPort :: Int + } + deriving (Show, Eq) + + diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index 275d58f..9203bdd 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -1,9 +1,9 @@ module Hash2Pub.ProtocolTypes where -import qualified Data.Set as Set -import Data.Time.Clock.POSIX (POSIXTime) +import qualified Data.Set as Set +import Data.Time.Clock.POSIX (POSIXTime) -import Hash2Pub.FediChord +import Hash2Pub.FediChordTypes data QueryResponse = FORWARD (Set.Set RemoteCacheEntry) | FOUND RemoteNodeState @@ -37,6 +37,10 @@ data FediChordMessage = Request } deriving (Show, Eq) +instance Ord FediChordMessage where + compare a b | requestID a == requestID b = part a `compare` part b + | otherwise = requestID a `compare` requestID b + data ActionPayload = QueryIDRequestPayload { queryTargetID :: NodeID , queryLBestNodes :: Integer From ad1465c5fe50af1b9adf3db94b3f9a1c3725889d Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 26 May 2020 08:55:44 +0200 Subject: [PATCH 15/88] use global cache adding function --- src/Hash2Pub/DHTProtocol.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 7b07785..147fecc 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -203,14 +203,14 @@ queryIdLookupLoop cacheSnapshot ns targetID = do now <- getPOSIXTime newLCache <- foldM (\oldCache resp -> do let entriesToInsert = case queryResult <$> payload resp of - Just (FOUND result1) -> [addCacheEntryPure now (RemoteCacheEntry result1 now)] - Just (FORWARD resultset) -> addCacheEntryPure now <$> Set.elems resultset + Just (FOUND result1) -> [RemoteCacheEntry result1 now] + Just (FORWARD resultset) -> Set.elems resultset _ -> [] -- forward entries to global cache - forM_ entriesToInsert $ \entry -> atomically $ writeTQueue (cacheWriteQueue ns) entry + queueAddEntries entriesToInsert ns -- insert entries into local cache copy - pure $ foldl' ( - \oldLCache insertFunc -> insertFunc oldLCache + pure $ foldr' ( + addCacheEntryPure now ) oldCache entriesToInsert ) cacheSnapshot responses @@ -283,7 +283,7 @@ sendRequestTo timeoutMillis numAttempts msgIncomplete sock = do -- | enqueue a list of RemoteCacheEntries to be added to the global NodeCache -queueAddEntries :: [RemoteCacheEntry] +queueAddEntries :: Foldable c => c RemoteCacheEntry -> LocalNodeState -> IO () queueAddEntries entries ns = do From 43eb04dfea8a88f8764ee733234d403aff3c79c9 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 26 May 2020 09:38:38 +0200 Subject: [PATCH 16/88] preliminary passing of bootstrap nodes in Main to fediChordJoin --- src/Hash2Pub/DHTProtocol.hs | 1 + src/Hash2Pub/FediChord.hs | 1 + src/Hash2Pub/FediChordTypes.hs | 7 ++++--- src/Hash2Pub/Main.hs | 4 +++- 4 files changed, 9 insertions(+), 4 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 147fecc..588e846 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -334,4 +334,5 @@ mkSendSocket dest destPort = do destAddr <- addrAddress <$> resolve (Just dest) (Just destPort) sendSock <- socket AF_INET6 Datagram defaultProtocol setSocketOption sendSock IPv6Only 1 + connect sendSock destAddr pure sendSock diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 540267c..c52e9f9 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -37,6 +37,7 @@ module Hash2Pub.FediChord ( , bsAsIpAddr , FediChordConf(..) , fediChordInit + , fediChordJoin , nodeStateInit , mkServerSocket , mkSendSocket diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 7ad09a9..7e3565d 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -419,9 +419,10 @@ byteStringToUInteger bs = sum $ parsedBytes 0 bs -- | configuration values used for initialising the FediChord DHT data FediChordConf = FediChordConf - { confDomain :: String - , confIP :: HostAddress6 - , confDhtPort :: Int + { confDomain :: String + , confIP :: HostAddress6 + , confDhtPort :: Int + , confBootstrapNodes :: [(String, PortNumber)] } deriving (Show, Eq) diff --git a/src/Hash2Pub/Main.hs b/src/Hash2Pub/Main.hs index 1956f64..4435f73 100644 --- a/src/Hash2Pub/Main.hs +++ b/src/Hash2Pub/Main.hs @@ -18,15 +18,17 @@ main = do -- currently no masking is necessary, as there is nothing to clean up cacheWriterThread <- forkIO $ cacheWriter thisNode -- idea: list of bootstrapping nodes, try joining within a timeout + joinedState <- fediChordJoin thisNode $ head . confBootstrapNodes $ conf -- stop main thread from terminating during development getChar pure () readConfig :: IO FediChordConf readConfig = do - confDomainString : ipString : portString : _ <- getArgs + confDomainString : ipString : portString : bootstrapHost : bootstrapPortString : _ <- getArgs pure $ FediChordConf { confDomain = confDomainString , confIP = toHostAddress6 . read $ ipString , confDhtPort = read portString + , confBootstrapNodes = [(bootstrapHost, read bootstrapPortString)] } From 702684b1a955e1ae23ea59d4b3bc44fde9a8d8ee Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 26 May 2020 11:01:11 +0200 Subject: [PATCH 17/88] split fediChordJoin into general purpose and bootstrapping part --- src/Hash2Pub/FediChord.hs | 37 +++++++++++++++++++++++-------------- src/Hash2Pub/Main.hs | 2 +- 2 files changed, 24 insertions(+), 15 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index c52e9f9..9cce7eb 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -38,6 +38,7 @@ module Hash2Pub.FediChord ( , FediChordConf(..) , fediChordInit , fediChordJoin + , fediChordBootstrapJoin , nodeStateInit , mkServerSocket , mkSendSocket @@ -110,11 +111,13 @@ nodeStateInit conf = do } pure initialState -fediChordJoin :: LocalNodeState -- ^ the local 'NodeState' - -> (String, PortNumber) -- ^ domain and port of a bootstrapping node - -> IO (Either String LocalNodeState) -- ^ the joined 'NodeState' after a +-- | Join a new node into the DHT, using a provided bootstrap node as initial cache seed +-- for resolving the new node's position. +fediChordBootstrapJoin :: LocalNodeState -- ^ the local 'NodeState' + -> (String, PortNumber) -- ^ domain and port of a bootstrapping node + -> IO (Either String LocalNodeState) -- ^ the joined 'NodeState' after a -- successful join, otherwise an error message -fediChordJoin ns (joinHost, joinPort) = do +fediChordBootstrapJoin ns (joinHost, joinPort) = do -- can be invoked multiple times with all known bootstrapping nodes until successfully joined sock <- mkSendSocket joinHost joinPort -- 1. get routed to placement of own ID until FOUND: @@ -133,18 +136,24 @@ fediChordJoin ns (joinHost, joinPort) = do Just (FORWARD resultset) -> foldr' (addCacheEntryPure now) cacheAcc resultset ) initCache bootstrapResponse - -- get routed to the currently responsible node, based on the response - -- from the bootstrapping node - currentlyResponsible <- queryIdLookupLoop bootstrapCache ns $ getNid ns - -- do actual join - joinResult <- requestJoin currentlyResponsible ns - case joinResult of - Nothing -> pure . Left $ "Error joining on " <> show currentlyResponsible - Just joinedNS -> pure . Right $ joinedNS - + fediChordJoin bootstrapCache ns +-- | join a node to the DHT, using the provided cache snapshot for resolving the new +-- node's position. +fediChordJoin :: NodeCache -- ^ a snapshot of the NodeCache to + -- use for ID lookup + -> LocalNodeState -- ^ the local 'NodeState' + -> IO (Either String LocalNodeState) -- ^ the joined 'NodeState' after a + -- successful join, otherwise an error message +fediChordJoin cacheSnapshot ns = do + -- get routed to the currently responsible node, based on the response + -- from the bootstrapping node + currentlyResponsible <- queryIdLookupLoop cacheSnapshot ns $ getNid ns -- 2. then send a join to the currently responsible node - -- after successful join, finally add own node to the cache + joinResult <- requestJoin currentlyResponsible ns + case joinResult of + Nothing -> pure . Left $ "Error joining on " <> show currentlyResponsible + Just joinedNS -> pure . Right $ joinedNS -- | cache updater thread that waits for incoming NodeCache update instructions on diff --git a/src/Hash2Pub/Main.hs b/src/Hash2Pub/Main.hs index 4435f73..f1e6b29 100644 --- a/src/Hash2Pub/Main.hs +++ b/src/Hash2Pub/Main.hs @@ -18,7 +18,7 @@ main = do -- currently no masking is necessary, as there is nothing to clean up cacheWriterThread <- forkIO $ cacheWriter thisNode -- idea: list of bootstrapping nodes, try joining within a timeout - joinedState <- fediChordJoin thisNode $ head . confBootstrapNodes $ conf + joinedState <- fediChordBootstrapJoin thisNode $ head . confBootstrapNodes $ conf -- stop main thread from terminating during development getChar pure () From b1c5c5e5f4360801e667923347a19b9d5c7dac85 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 26 May 2020 20:54:02 +0200 Subject: [PATCH 18/88] try all bootstrap nodes until successfully joined --- src/Hash2Pub/Main.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/Hash2Pub/Main.hs b/src/Hash2Pub/Main.hs index f1e6b29..3fa5d47 100644 --- a/src/Hash2Pub/Main.hs +++ b/src/Hash2Pub/Main.hs @@ -17,12 +17,20 @@ main = do print serverSock -- currently no masking is necessary, as there is nothing to clean up cacheWriterThread <- forkIO $ cacheWriter thisNode - -- idea: list of bootstrapping nodes, try joining within a timeout - joinedState <- fediChordBootstrapJoin thisNode $ head . confBootstrapNodes $ conf + -- try joining the DHT using one of the provided bootstrapping nodes + let + tryJoining (bn:bns) = do + j <- fediChordBootstrapJoin thisNode bn + case j of + Left _ -> tryJoining bns + Right joined -> pure $ Right joined + tryJoining [] = pure $ Left "Exhausted all bootstrap points for joining." + joinedState <- tryJoining $ confBootstrapNodes conf -- stop main thread from terminating during development getChar pure () + readConfig :: IO FediChordConf readConfig = do confDomainString : ipString : portString : bootstrapHost : bootstrapPortString : _ <- getArgs From 27e5c5f9cecab676181018a5774cbba635ed0f7f Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 27 May 2020 17:48:01 +0200 Subject: [PATCH 19/88] bracket all socket-using operations to avoid resource leakage --- src/Hash2Pub/DHTProtocol.hs | 51 +++++++++++++++++++------------------ src/Hash2Pub/FediChord.hs | 39 ++++++++++++++-------------- src/Hash2Pub/Main.hs | 1 + 3 files changed, 47 insertions(+), 44 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 588e846..1adcdc1 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -23,6 +23,7 @@ module Hash2Pub.DHTProtocol where import Control.Concurrent.Async +import Control.Exception import Control.Concurrent.STM import Control.Concurrent.STM.TBQueue import Control.Concurrent.STM.TQueue @@ -146,28 +147,29 @@ markCacheEntryAsVerified timestamp = Map.adjust adjustFunc requestJoin :: NodeState a => a -- ^ currently responsible node to be contacted -> LocalNodeState -- ^ joining NodeState -> IO (Maybe LocalNodeState) -- ^ node after join with all its new information -requestJoin toJoinOn ownState = do - sock <- mkSendSocket (getDomain toJoinOn) (getDhtPort toJoinOn) - responses <- sendRequestTo 5000 3 (\rid -> Request rid (toRemoteNodeState ownState) 1 1 Join (Just JoinRequestPayload)) sock - joinedStateUnsorted <- foldM - (\nsAcc msg -> case payload msg of - Nothing -> pure nsAcc - Just msgPl -> do - -- add transfered cache entries to global NodeCache - queueAddEntries (joinCache msgPl) nsAcc - -- add received predecessors and successors - let - addPreds ns' = setPredecessors (foldr' (:) (predecessors ns') (joinPredecessors msgPl)) ns' - addSuccs ns' = setSuccessors (foldr' (:) (successors ns') (joinSuccessors msgPl)) ns' - pure $ addSuccs . addPreds $ nsAcc - ) - -- reset predecessors and successors - (setPredecessors [] . setSuccessors [] $ ownState) - responses - if responses == Set.empty - then pure Nothing - -- sort successors and predecessors - else pure . Just . setSuccessors (sortBy localCompare $ successors joinedStateUnsorted) . setPredecessors (sortBy localCompare $ predecessors joinedStateUnsorted) $ joinedStateUnsorted +requestJoin toJoinOn ownState = + bracket (mkSendSocket (getDomain toJoinOn) (getDhtPort toJoinOn)) close (\sock -> do + responses <- sendRequestTo 5000 3 (\rid -> Request rid (toRemoteNodeState ownState) 1 1 Join (Just JoinRequestPayload)) sock + joinedStateUnsorted <- foldM + (\nsAcc msg -> case payload msg of + Nothing -> pure nsAcc + Just msgPl -> do + -- add transfered cache entries to global NodeCache + queueAddEntries (joinCache msgPl) nsAcc + -- add received predecessors and successors + let + addPreds ns' = setPredecessors (foldr' (:) (predecessors ns') (joinPredecessors msgPl)) ns' + addSuccs ns' = setSuccessors (foldr' (:) (successors ns') (joinSuccessors msgPl)) ns' + pure $ addSuccs . addPreds $ nsAcc + ) + -- reset predecessors and successors + (setPredecessors [] . setSuccessors [] $ ownState) + responses + if responses == Set.empty + then pure Nothing + -- sort successors and predecessors + else pure . Just . setSuccessors (sortBy localCompare $ successors joinedStateUnsorted) . setPredecessors (sortBy localCompare $ predecessors joinedStateUnsorted) $ joinedStateUnsorted + ) -- | Send a 'QueryID' 'Request' for getting the node that handles a certain key ID. @@ -192,10 +194,9 @@ queryIdLookupLoop cacheSnapshot ns targetID = do case localResult of FOUND thisNode -> pure thisNode FORWARD nodeSet -> do - -- create connected sockets to all query targets - sockets <- mapM (\resultNode -> mkSendSocket (getDomain resultNode) (getDhtPort resultNode)) $ remoteNode <$> Set.toList nodeSet + -- create connected sockets to all query targets and use them for request handling -- ToDo: make attempts and timeout configurable - queryThreads <- mapM (async . sendQueryIdMessage targetID ns) sockets + queryThreads <- mapM (\resultNode -> async $ bracket (mkSendSocket (getDomain resultNode) (getDhtPort resultNode)) close (sendQueryIdMessage targetID ns)) $ remoteNode <$> Set.toList nodeSet -- ToDo: process results immediately instead of waiting for the last one to finish, see https://stackoverflow.com/a/38815224/9198613 -- ToDo: exception handling, maybe log them responses <- (mconcat . fmap Set.elems) . rights <$> mapM waitCatch queryThreads diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 9cce7eb..60d96ee 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -117,26 +117,27 @@ fediChordBootstrapJoin :: LocalNodeState -- ^ the local 'NodeState' -> (String, PortNumber) -- ^ domain and port of a bootstrapping node -> IO (Either String LocalNodeState) -- ^ the joined 'NodeState' after a -- successful join, otherwise an error message -fediChordBootstrapJoin ns (joinHost, joinPort) = do +fediChordBootstrapJoin ns (joinHost, joinPort) = -- can be invoked multiple times with all known bootstrapping nodes until successfully joined - sock <- mkSendSocket joinHost joinPort - -- 1. get routed to placement of own ID until FOUND: - -- Initialise an empty cache only with the responses from a bootstrapping node - bootstrapResponse <- sendQueryIdMessage (getNid ns) ns sock - if bootstrapResponse == Set.empty - then pure . Left $ "Bootstrapping node " <> show joinHost <> " gave no response." - else do - now <- getPOSIXTime - -- create new cache with all returned node responses - let bootstrapCache = - -- traverse response parts - foldr' (\resp cacheAcc -> case queryResult <$> payload resp of - Nothing -> cacheAcc - Just (FOUND result1) -> addCacheEntryPure now (RemoteCacheEntry result1 now) cacheAcc - Just (FORWARD resultset) -> foldr' (addCacheEntryPure now) cacheAcc resultset - ) - initCache bootstrapResponse - fediChordJoin bootstrapCache ns + bracket (mkSendSocket joinHost joinPort) close (\sock -> do + -- 1. get routed to placement of own ID until FOUND: + -- Initialise an empty cache only with the responses from a bootstrapping node + bootstrapResponse <- sendQueryIdMessage (getNid ns) ns sock + if bootstrapResponse == Set.empty + then pure . Left $ "Bootstrapping node " <> show joinHost <> " gave no response." + else do + now <- getPOSIXTime + -- create new cache with all returned node responses + let bootstrapCache = + -- traverse response parts + foldr' (\resp cacheAcc -> case queryResult <$> payload resp of + Nothing -> cacheAcc + Just (FOUND result1) -> addCacheEntryPure now (RemoteCacheEntry result1 now) cacheAcc + Just (FORWARD resultset) -> foldr' (addCacheEntryPure now) cacheAcc resultset + ) + initCache bootstrapResponse + fediChordJoin bootstrapCache ns + ) -- | join a node to the DHT, using the provided cache snapshot for resolving the new -- node's position. diff --git a/src/Hash2Pub/Main.hs b/src/Hash2Pub/Main.hs index 3fa5d47..4482012 100644 --- a/src/Hash2Pub/Main.hs +++ b/src/Hash2Pub/Main.hs @@ -1,6 +1,7 @@ module Main where import Control.Concurrent +import Control.Exception import Data.IP (IPv6, toHostAddress6) import System.Environment From 6ff765c63eb5420f739a1b36b0a4332120771e29 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 27 May 2020 18:59:38 +0200 Subject: [PATCH 20/88] catch and handle bootstrap join errors --- src/Hash2Pub/FediChord.hs | 1 + src/Hash2Pub/Main.hs | 14 +++++++++++++- 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 60d96ee..d159009 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -138,6 +138,7 @@ fediChordBootstrapJoin ns (joinHost, joinPort) = initCache bootstrapResponse fediChordJoin bootstrapCache ns ) + `catch` (\e -> pure . Left $ "Error at bootstrap joining: " <> displayException (e :: IOException)) -- | join a node to the DHT, using the provided cache snapshot for resolving the new -- node's position. diff --git a/src/Hash2Pub/Main.hs b/src/Hash2Pub/Main.hs index 4482012..fb58ad5 100644 --- a/src/Hash2Pub/Main.hs +++ b/src/Hash2Pub/Main.hs @@ -4,6 +4,7 @@ import Control.Concurrent import Control.Exception import Data.IP (IPv6, toHostAddress6) import System.Environment +import Data.Either import Hash2Pub.FediChord @@ -23,10 +24,21 @@ main = do tryJoining (bn:bns) = do j <- fediChordBootstrapJoin thisNode bn case j of - Left _ -> tryJoining bns + Left err -> putStrLn ("join error: " <> err) >> tryJoining bns Right joined -> pure $ Right joined tryJoining [] = pure $ Left "Exhausted all bootstrap points for joining." joinedState <- tryJoining $ confBootstrapNodes conf + either (\err -> + -- handle unsuccessful join + + putStrLn $ err <> " Error joining, start listening for incoming requests anyways" + -- TODO: periodic retry + ) + (\joinedNS -> + -- launch main eventloop with successfully joined state + putStrLn ("successful join at " <> (show . getNid $ joinedNS)) + ) + joinedState -- stop main thread from terminating during development getChar pure () From b4ecf8b0aab12f43eb6e886a6e927f36d6df39a0 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 27 May 2020 19:10:45 +0200 Subject: [PATCH 21/88] catch and handle more join errors --- src/Hash2Pub/DHTProtocol.hs | 9 +++++---- src/Hash2Pub/FediChord.hs | 4 ++-- src/Hash2Pub/Main.hs | 2 +- 3 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 1adcdc1..34423a4 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -23,10 +23,10 @@ module Hash2Pub.DHTProtocol where import Control.Concurrent.Async -import Control.Exception import Control.Concurrent.STM import Control.Concurrent.STM.TBQueue import Control.Concurrent.STM.TQueue +import Control.Exception import Control.Monad (foldM, forM, forM_) import qualified Data.ByteString as BS import Data.Either (rights) @@ -146,7 +146,7 @@ markCacheEntryAsVerified timestamp = Map.adjust adjustFunc -- | send a join request and return the joined 'LocalNodeState' including neighbours requestJoin :: NodeState a => a -- ^ currently responsible node to be contacted -> LocalNodeState -- ^ joining NodeState - -> IO (Maybe LocalNodeState) -- ^ node after join with all its new information + -> IO (Either String LocalNodeState) -- ^ node after join with all its new information requestJoin toJoinOn ownState = bracket (mkSendSocket (getDomain toJoinOn) (getDhtPort toJoinOn)) close (\sock -> do responses <- sendRequestTo 5000 3 (\rid -> Request rid (toRemoteNodeState ownState) 1 1 Join (Just JoinRequestPayload)) sock @@ -166,10 +166,11 @@ requestJoin toJoinOn ownState = (setPredecessors [] . setSuccessors [] $ ownState) responses if responses == Set.empty - then pure Nothing + then pure . Left $ "join error: got no response from " <> show (getNid toJoinOn) -- sort successors and predecessors - else pure . Just . setSuccessors (sortBy localCompare $ successors joinedStateUnsorted) . setPredecessors (sortBy localCompare $ predecessors joinedStateUnsorted) $ joinedStateUnsorted + else pure . Right . setSuccessors (sortBy localCompare $ successors joinedStateUnsorted) . setPredecessors (sortBy localCompare $ predecessors joinedStateUnsorted) $ joinedStateUnsorted ) + `catch` (\e -> pure . Left $ displayException (e :: IOException)) -- | Send a 'QueryID' 'Request' for getting the node that handles a certain key ID. diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index d159009..76ab1a2 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -154,8 +154,8 @@ fediChordJoin cacheSnapshot ns = do -- 2. then send a join to the currently responsible node joinResult <- requestJoin currentlyResponsible ns case joinResult of - Nothing -> pure . Left $ "Error joining on " <> show currentlyResponsible - Just joinedNS -> pure . Right $ joinedNS + Left err -> pure . Left $ "Error joining on " <> err + Right joinedNS -> pure . Right $ joinedNS -- | cache updater thread that waits for incoming NodeCache update instructions on diff --git a/src/Hash2Pub/Main.hs b/src/Hash2Pub/Main.hs index fb58ad5..4ab3a48 100644 --- a/src/Hash2Pub/Main.hs +++ b/src/Hash2Pub/Main.hs @@ -2,9 +2,9 @@ module Main where import Control.Concurrent import Control.Exception +import Data.Either import Data.IP (IPv6, toHostAddress6) import System.Environment -import Data.Either import Hash2Pub.FediChord From 61818c58a9429422538e3ae7786cc28595818017 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Fri, 29 May 2020 17:39:35 +0200 Subject: [PATCH 22/88] main server thread structure --- src/Hash2Pub/FediChord.hs | 55 ++++++++++++++++++++++++++++++++++++++- src/Hash2Pub/Main.hs | 7 +++-- 2 files changed, 59 insertions(+), 3 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 76ab1a2..fe6d0aa 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -39,6 +39,7 @@ module Hash2Pub.FediChord ( , fediChordInit , fediChordJoin , fediChordBootstrapJoin + , fediMainThreads , nodeStateInit , mkServerSocket , mkSendSocket @@ -52,9 +53,11 @@ import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, isJust, mapMaybe) import qualified Data.Set as Set import Data.Time.Clock.POSIX -import Network.Socket +import Network.Socket hiding (recv, recvFrom, send, sendTo) +import Network.Socket.ByteString -- for hashing and ID conversion +import Control.Concurrent.Async import Control.Concurrent.STM import Control.Concurrent.STM.TQueue import Control.Monad (forever) @@ -169,3 +172,53 @@ cacheWriter ns = do refModifier :: NodeCache -> (NodeCache, ()) refModifier nc = (f nc, ()) atomicModifyIORef' (nodeCacheRef ns) refModifier + +-- | Receives UDP packets and passes them to other threads via the given TQueue. +-- Shall be used as the single receiving thread on the server socket, as multiple +-- threads blocking on the same socket degrades performance. +recvThread :: Socket -- ^ server socket to receive packets from + -> TQueue (BS.ByteString, SockAddr) -- ^ receive queue + -> IO () +recvThread sock recvQ = forever $ do + packet <- recvFrom sock 65535 + atomically $ writeTQueue recvQ packet + +-- | Only thread to send data it gets from a TQueue through the server socket. +sendThread :: Socket -- ^ server socket used for sending + -> TQueue (BS.ByteString, SockAddr) -- ^ send queue + -> IO () +sendThread sock sendQ = forever $ do + (packet, addr) <- atomically $ readTQueue sendQ + sendAllTo sock packet addr + +-- | Sets up and manages the main server threads of FediChord +fediMainThreads :: Socket -> LocalNodeState -> IO () +fediMainThreads sock ns = do + sendQ <- newTQueueIO + recvQ <- newTQueueIO + -- concurrently launch all handler threads, if one of them throws an exception + -- all get cancelled + concurrently_ + (fediMessageHandler sendQ recvQ ns) $ + concurrently + (sendThread sock sendQ) + (recvThread sock recvQ) + + +-- | Wait for messages, deserialise them, manage parts and acknowledgement status, +-- and pass them to their specific handling function. +fediMessageHandler :: TQueue (BS.ByteString, SockAddr) -- ^ send queue + -> TQueue (BS.ByteString, SockAddr) -- ^ receive queue + -> LocalNodeState -- ^ acting NodeState + -> IO () +fediMessageHandler sendQ recvQ ns = forever $ do + -- wait for incoming messages +-- newMsg <- deserialiseMessage <$> recvFrom sock +-- either (\_ -> +-- -- ignore invalid messages +-- pure () +-- ) +-- (\aMsg -> +-- case aMsg of +-- aRequest@Request{} -> handleRequest + pure () diff --git a/src/Hash2Pub/Main.hs b/src/Hash2Pub/Main.hs index 4ab3a48..5b7fad6 100644 --- a/src/Hash2Pub/Main.hs +++ b/src/Hash2Pub/Main.hs @@ -1,6 +1,7 @@ module Main where import Control.Concurrent +import Control.Concurrent.Async import Control.Exception import Data.Either import Data.IP (IPv6, toHostAddress6) @@ -28,15 +29,17 @@ main = do Right joined -> pure $ Right joined tryJoining [] = pure $ Left "Exhausted all bootstrap points for joining." joinedState <- tryJoining $ confBootstrapNodes conf - either (\err -> + either (\err -> do -- handle unsuccessful join putStrLn $ err <> " Error joining, start listening for incoming requests anyways" + wait =<< async (fediMainThreads serverSock thisNode) -- TODO: periodic retry ) - (\joinedNS -> + (\joinedNS -> do -- launch main eventloop with successfully joined state putStrLn ("successful join at " <> (show . getNid $ joinedNS)) + wait =<< async (fediMainThreads serverSock thisNode) ) joinedState -- stop main thread from terminating during development From 96e61b726fddfe4b6da570aa911907d2ded3a97e Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Fri, 29 May 2020 21:30:18 +0200 Subject: [PATCH 23/88] adjust hlint hints to ignore lambda-case --- .hlint.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.hlint.yaml b/.hlint.yaml index 4fa15a6..dfe9a89 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -4,5 +4,5 @@ - error: { lhs: return, rhs: pure } -- ignore: {name: "Avoid lambda using `infix`"} +- ignore: {name: ["Avoid lambda using `infix`", "Use lambda-case"]} From fea9660f80084c4c6ec31ea8500d0592ab272507 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 30 May 2020 01:09:17 +0200 Subject: [PATCH 24/88] WIP: start implementing incoming request handling --- src/Hash2Pub/DHTProtocol.hs | 28 ++++++++++++++++++++++++++++ src/Hash2Pub/FediChord.hs | 30 +++++++++++++++++++++--------- src/Hash2Pub/Main.hs | 2 +- 3 files changed, 50 insertions(+), 10 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 34423a4..fba3f20 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -4,6 +4,7 @@ module Hash2Pub.DHTProtocol , addCacheEntry , addCacheEntryPure , deleteCacheEntry + , deserialiseMessage , markCacheEntryAsVerified , RemoteCacheEntry(..) , toRemoteCacheEntry @@ -19,6 +20,7 @@ module Hash2Pub.DHTProtocol , resolve , mkSendSocket , mkServerSocket + , handleIncomingRequest ) where @@ -31,6 +33,7 @@ import Control.Monad (foldM, forM, forM_) import qualified Data.ByteString as BS import Data.Either (rights) import Data.Foldable (foldl', foldr') +import Data.Functor.Identity import Data.IORef import Data.IP (IPv6, fromHostAddress6, toHostAddress6) @@ -141,8 +144,33 @@ markCacheEntryAsVerified timestamp = Map.adjust adjustFunc adjustFunc (ProxyEntry _ (Just entry)) = adjustFunc entry adjustFunc entry = entry + +-- | uses the successor and predecessor list of a node as an indicator for whether a +-- node has properly joined the DHT +isJoined_ :: LocalNodeState -> Bool +isJoined_ ns = not . all null $ [successors ns, predecessors ns] + -- ====== message send and receive operations ====== +handleIncomingRequest :: LocalNodeState -- ^ the handling node + -> TQueue (BS.ByteString, SockAddr) -- ^ send queue + -> FediChordMessage -- ^ request to handle + -> SockAddr -- ^ source address of the request + -> IO () +handleIncomingRequest ns sendQ msg sourceAddr = do + -- add nodestate to cache + now <- getPOSIXTime + queueAddEntries (Identity . RemoteCacheEntry (sender msg) $ now) ns + -- distinguish on whether and how to respond + -- create and enqueue ACK + -- Idea: only respond with payload on last part (part == parts), problem: need to know partnumber of response from first part on + -- PLACEHOLDER + pure () + +-- ....... response sending ....... + +-- ....... request sending ....... + -- | send a join request and return the joined 'LocalNodeState' including neighbours requestJoin :: NodeState a => a -- ^ currently responsible node to be contacted -> LocalNodeState -- ^ joining NodeState diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index fe6d0aa..8777cb8 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -53,10 +53,12 @@ import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, isJust, mapMaybe) import qualified Data.Set as Set import Data.Time.Clock.POSIX -import Network.Socket hiding (recv, recvFrom, send, sendTo) +import Network.Socket hiding (recv, recvFrom, send, + sendTo) import Network.Socket.ByteString -- for hashing and ID conversion +import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM import Control.Concurrent.STM.TQueue @@ -213,12 +215,22 @@ fediMessageHandler :: TQueue (BS.ByteString, SockAddr) -- ^ send queue -> IO () fediMessageHandler sendQ recvQ ns = forever $ do -- wait for incoming messages --- newMsg <- deserialiseMessage <$> recvFrom sock --- either (\_ -> --- -- ignore invalid messages --- pure () --- ) --- (\aMsg -> --- case aMsg of --- aRequest@Request{} -> handleRequest + (rawMsg, sourceAddr) <- atomically $ readTQueue recvQ + let aMsg = deserialiseMessage rawMsg + -- handling multipart messages: + -- So far I handle the effects of each message part immedeiately, before making sure that and whether all parts have been received, based on the idea that even incomplete information is beneficial and handled idempotent. + -- If this turns out not to be the case, request parts can be insert into a map (key: (sender IP against spoofing, request ID), value: timestamp + set of message parts, handle all of them when size of set == parts) before being handled. This map needs to be purged periodically by a separate thread and can be protected by an MVar for fairness. + either (\_ -> + -- drop invalid messages + pure () + ) + (\validMsg -> + case validMsg of + aRequest@Request{} -> forkIO (handleIncomingRequest ns sendQ aRequest sourceAddr) >> pure () + -- Responses should never arrive on the main server port, as they are always + -- responses to requests sent from dedicated sockets on another port + _ -> pure () + ) + aMsg + pure () diff --git a/src/Hash2Pub/Main.hs b/src/Hash2Pub/Main.hs index 5b7fad6..a837cc5 100644 --- a/src/Hash2Pub/Main.hs +++ b/src/Hash2Pub/Main.hs @@ -4,7 +4,7 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Exception import Data.Either -import Data.IP (IPv6, toHostAddress6) +import Data.IP (IPv6, toHostAddress6) import System.Environment import Hash2Pub.FediChord From f8d444d5b66956fdefbdad2c8ed485df8daa7693 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 30 May 2020 13:07:28 +0200 Subject: [PATCH 25/88] FediChordMessage: last part has falg instead of parts number in each msg Motivation: Including the number of parts in each message part requires the total number of parts to be known in advance, making dynamic responses based on the received data difficult --- FediChord.asn1 | 10 ++++++---- src/Hash2Pub/ASN1Coding.hs | 28 +++++++++++++++++----------- src/Hash2Pub/ProtocolTypes.hs | 4 ++-- 3 files changed, 25 insertions(+), 17 deletions(-) diff --git a/FediChord.asn1 b/FediChord.asn1 index 254fc95..a907bb1 100644 --- a/FediChord.asn1 +++ b/FediChord.asn1 @@ -4,14 +4,16 @@ NodeID ::= INTEGER (0..115792089237316195423570985008687907853269984665640564039 Domain ::= VisibleString +Partnum ::= INTEGER (0..150) + Action ::= ENUMERATED {queryID, join, leave, stabilise, ping} Request ::= SEQUENCE { action Action, requestID INTEGER (0..4294967295), -- arbitrarily restricting to an unsigned 32bit integer sender NodeState, - parts INTEGER (1..150), -- number of message parts - part INTEGER (1..150), -- part number of this message, starts at 1 + part Partnum, -- part number of this message, starts at 1 + finalPart BOOLEAN, -- flag indicating this `part` to be the last of this reuest actionPayload CHOICE { queryIDRequestPayload QueryIDRequestPayload, joinRequestPayload JoinRequestPayload, @@ -27,8 +29,8 @@ Request ::= SEQUENCE { Response ::= SEQUENCE { responseTo INTEGER (0..4294967295), -- arbitrarily restricting to an unsigned 32bit integer senderID NodeID, - parts INTEGER (0..150), - part INTEGER (0..150), + part Partnum, + finalPart BOOLEAN, -- flag indicating this `part` to be the last of this response action Action, actionPayload CHOICE { queryIDResponsePayload QueryIDResponsePayload, diff --git a/src/Hash2Pub/ASN1Coding.hs b/src/Hash2Pub/ASN1Coding.hs index abf749b..6bbb9df 100644 --- a/src/Hash2Pub/ASN1Coding.hs +++ b/src/Hash2Pub/ASN1Coding.hs @@ -103,7 +103,7 @@ serialiseMessage maxBytesLength msg = modifyMessage i (partNum, pl) pls = (partNum, msg { part = partNum , payload = Just pl - , parts = fromIntegral i + , isFinalPart = partNum == fromIntegral i }):pls -- part starts at 1 payloadParts :: Int -> Maybe [(Integer, ActionPayload)] @@ -216,23 +216,22 @@ encodeQueryResult FORWARD{} = Enumerated 1 encodeMessage :: FediChordMessage -- ^ the 'FediChordMessage to be encoded -> [ASN1] encodeMessage - (Request requestID sender parts part action requestPayload) = + (Request requestID sender part isFinalPart action requestPayload) = Start Sequence : (Enumerated . fromIntegral . fromEnum $ action) : IntVal requestID : encodeNodeState sender - <> [ - IntVal parts - , IntVal part ] + <> [IntVal part + , Boolean isFinalPart] <> maybe [] encodePayload requestPayload <> [End Sequence] encodeMessage - (Response responseTo senderID parts part action responsePayload) = [ + (Response responseTo senderID part isFinalPart action responsePayload) = [ Start Sequence , IntVal responseTo , IntVal . getNodeID $ senderID - , IntVal parts , IntVal part + , Boolean isFinalPart , Enumerated . fromIntegral . fromEnum $ action] <> maybe [] encodePayload responsePayload <> [End Sequence] @@ -265,8 +264,8 @@ parseRequest :: Action -> ParseASN1 FediChordMessage parseRequest action = do requestID <- parseInteger sender <- parseNodeState - parts <- parseInteger part <- parseInteger + isFinalPart <- parseBool hasPayload <- hasNext payload <- if not hasPayload then pure Nothing else Just <$> case action of QueryID -> parseQueryIDRequest @@ -275,13 +274,13 @@ parseRequest action = do Stabilise -> parseStabiliseRequest Ping -> parsePingRequest - pure $ Request requestID sender parts part action payload + pure $ Request requestID sender part isFinalPart action payload parseResponse :: Integer -> ParseASN1 FediChordMessage parseResponse responseTo = do senderID <- fromInteger <$> parseInteger :: ParseASN1 NodeID - parts <- parseInteger part <- parseInteger + isFinalPart <- parseBool action <- parseEnum :: ParseASN1 Action hasPayload <- hasNext payload <- if not hasPayload then pure Nothing else Just <$> case action of @@ -291,7 +290,14 @@ parseResponse responseTo = do Stabilise -> parseStabiliseResponse Ping -> parsePingResponse - pure $ Response responseTo senderID parts part action payload + pure $ Response responseTo senderID part isFinalPart action payload + +parseBool :: ParseASN1 Bool +parseBool = do + i <- getNext + case i of + Boolean parsed -> pure parsed + x -> throwParseError $ "Expected Boolean but got " <> show x parseInteger :: ParseASN1 Integer parseInteger = do diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index 9203bdd..bab3866 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -21,8 +21,8 @@ data Action = QueryID data FediChordMessage = Request { requestID :: Integer , sender :: RemoteNodeState - , parts :: Integer , part :: Integer + , isFinalPart :: Bool -- ^ part starts at 1 , action :: Action , payload :: Maybe ActionPayload @@ -30,8 +30,8 @@ data FediChordMessage = Request | Response { responseTo :: Integer , senderID :: NodeID - , parts :: Integer , part :: Integer + , isFinalPart :: Bool , action :: Action , payload :: Maybe ActionPayload } From 254209137999da5265e9f4d3ff46b5bb7d373545 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 30 May 2020 13:52:06 +0200 Subject: [PATCH 26/88] adjust rest of code to new message structure --- src/Hash2Pub/DHTProtocol.hs | 22 +++++++++++----------- test/FediChordSpec.hs | 4 ++-- 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index fba3f20..fb50c98 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -177,7 +177,7 @@ requestJoin :: NodeState a => a -- ^ currently responsible node to b -> IO (Either String LocalNodeState) -- ^ node after join with all its new information requestJoin toJoinOn ownState = bracket (mkSendSocket (getDomain toJoinOn) (getDhtPort toJoinOn)) close (\sock -> do - responses <- sendRequestTo 5000 3 (\rid -> Request rid (toRemoteNodeState ownState) 1 1 Join (Just JoinRequestPayload)) sock + responses <- sendRequestTo 5000 3 (\rid -> Request rid (toRemoteNodeState ownState) 1 True Join (Just JoinRequestPayload)) sock joinedStateUnsorted <- foldM (\nsAcc msg -> case payload msg of Nothing -> pure nsAcc @@ -259,7 +259,7 @@ sendQueryIdMessage :: NodeID -- ^ target key ID to look u -> IO (Set.Set FediChordMessage) -- ^ responses sendQueryIdMessage targetID ns = sendRequestTo 5000 3 (lookupMessage targetID ns) where - lookupMessage targetID ns rID = Request rID (toRemoteNodeState ns) 1 1 QueryID (Just $ pl ns targetID) + lookupMessage targetID ns rID = Request rID (toRemoteNodeState ns) 1 True QueryID (Just $ pl ns targetID) pl ns' targetID' = QueryIDRequestPayload { queryTargetID = targetID', queryLBestNodes = fromIntegral . lNumBestNodes $ ns } -- | Generic function for sending a request over a connected socket and collecting the response. @@ -281,7 +281,6 @@ sendRequestTo timeoutMillis numAttempts msgIncomplete sock = do recvdParts <- atomically $ flushTBQueue responseQ pure $ Set.fromList recvdParts where - -- state reingeben: state = noch nicht geackte messages, result = responses sendAndAck :: TBQueue FediChordMessage -- ^ the queue for putting in the received responses -> Socket -- ^ the socket used for sending and receiving for this particular remote node -> Map.Map Integer BS.ByteString -- ^ the remaining unacked request parts @@ -289,27 +288,28 @@ sendRequestTo timeoutMillis numAttempts msgIncomplete sock = do sendAndAck responseQueue sock remainingSends = do sendMany sock $ Map.elems remainingSends -- if all requests have been acked/ responded to, return prematurely - recvLoop responseQueue remainingSends Set.empty + recvLoop responseQueue remainingSends Set.empty Nothing recvLoop :: TBQueue FediChordMessage -- ^ the queue for putting in the received responses -> Map.Map Integer BS.ByteString -- ^ the remaining unacked request parts -> Set.Set Integer -- ^ already received response part numbers + -> Maybe Integer -- ^ total number of response parts if already known -> IO () - recvLoop responseQueue remainingSends' receivedPartNums = do + recvLoop responseQueue remainingSends' receivedPartNums totalParts = do -- 65535 is maximum length of UDP packets, as long as -- no IPv6 jumbograms are used response <- deserialiseMessage <$> recv sock 65535 case response of - -- drop errors - Left _ -> recvLoop responseQueue remainingSends' receivedPartNums - Right msg -> do + Right msg@Response{} -> do atomically $ writeTBQueue responseQueue msg let + newTotalParts = if isFinalPart msg then Just (part msg) else totalParts newRemaining = Map.delete (part msg) remainingSends' newReceivedParts = Set.insert (part msg) receivedPartNums - -- ToDo: handle responses with more parts than the request - if Map.null newRemaining && Set.size receivedPartNums == fromIntegral (parts msg) + if Map.null newRemaining && maybe False (\p -> Set.size receivedPartNums == fromIntegral p) newTotalParts then pure () - else recvLoop responseQueue newRemaining receivedPartNums + else recvLoop responseQueue newRemaining receivedPartNums newTotalParts + -- drop errors and invalid messages + Left _ -> recvLoop responseQueue remainingSends' receivedPartNums totalParts -- | enqueue a list of RemoteCacheEntries to be added to the global NodeCache diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index 784c14e..629c7c2 100644 --- a/test/FediChordSpec.hs +++ b/test/FediChordSpec.hs @@ -196,16 +196,16 @@ spec = do requestTemplate = Request { requestID = 2342 , sender = exampleNodeState - , parts = 1 , part = 1 + , isFinalPart = True , action = undefined , payload = undefined } responseTemplate = Response { responseTo = 2342 , senderID = nid exampleNodeState - , parts = 1 , part = 1 + , isFinalPart = True , action = undefined , payload = undefined } From bcd1c34c7cf100aa5634e6c910ae338b4146d324 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sun, 31 May 2020 01:13:34 +0200 Subject: [PATCH 27/88] manage incoming request parts before handling --- src/Hash2Pub/DHTProtocol.hs | 7 +-- src/Hash2Pub/FediChord.hs | 82 ++++++++++++++++++++++++++--------- src/Hash2Pub/ProtocolTypes.hs | 20 ++++----- 3 files changed, 76 insertions(+), 33 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index fb50c98..ed1e5d4 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -152,15 +152,16 @@ isJoined_ ns = not . all null $ [successors ns, predecessors ns] -- ====== message send and receive operations ====== + handleIncomingRequest :: LocalNodeState -- ^ the handling node -> TQueue (BS.ByteString, SockAddr) -- ^ send queue - -> FediChordMessage -- ^ request to handle + -> Set.Set FediChordMessage -- ^ all parts of the request to handle -> SockAddr -- ^ source address of the request -> IO () -handleIncomingRequest ns sendQ msg sourceAddr = do +handleIncomingRequest ns sendQ msgSet sourceAddr = do -- add nodestate to cache now <- getPOSIXTime - queueAddEntries (Identity . RemoteCacheEntry (sender msg) $ now) ns + queueAddEntries (Identity . RemoteCacheEntry (sender . head . Set.elems $ msgSet) $ now) ns -- distinguish on whether and how to respond -- create and enqueue ACK -- Idea: only respond with payload on last part (part == parts), problem: need to know partnumber of response from first part on diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 8777cb8..2a8e151 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -47,10 +47,12 @@ module Hash2Pub.FediChord ( , cacheWriter ) where +import Control.Applicative ((<|>)) import Control.Exception import Data.Foldable (foldr') import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.Maybe (fromJust, fromMaybe, isJust, + mapMaybe) import qualified Data.Set as Set import Data.Time.Clock.POSIX import Network.Socket hiding (recv, recvFrom, send, @@ -207,30 +209,70 @@ fediMainThreads sock ns = do (recvThread sock recvQ) +-- defining this here as, for now, the RequestMap is only used by fediMessageHandler. +-- Once that changes, move to FediChordTypes +type RequestMap = Map.Map (SockAddr, Integer) RequestMapEntry + +data RequestMapEntry = RequestMapEntry (Set.Set FediChordMessage) (Maybe Integer) + POSIXTime + +requestMapPurge :: MVar RequestMap -> IO () +-- PLACEHOLDER +requestMapPurge mapVar = pure () + -- | Wait for messages, deserialise them, manage parts and acknowledgement status, -- and pass them to their specific handling function. fediMessageHandler :: TQueue (BS.ByteString, SockAddr) -- ^ send queue -> TQueue (BS.ByteString, SockAddr) -- ^ receive queue -> LocalNodeState -- ^ acting NodeState -> IO () -fediMessageHandler sendQ recvQ ns = forever $ do - -- wait for incoming messages - (rawMsg, sourceAddr) <- atomically $ readTQueue recvQ - let aMsg = deserialiseMessage rawMsg +fediMessageHandler sendQ recvQ ns = do -- handling multipart messages: - -- So far I handle the effects of each message part immedeiately, before making sure that and whether all parts have been received, based on the idea that even incomplete information is beneficial and handled idempotent. - -- If this turns out not to be the case, request parts can be insert into a map (key: (sender IP against spoofing, request ID), value: timestamp + set of message parts, handle all of them when size of set == parts) before being handled. This map needs to be purged periodically by a separate thread and can be protected by an MVar for fairness. - either (\_ -> - -- drop invalid messages - pure () - ) - (\validMsg -> - case validMsg of - aRequest@Request{} -> forkIO (handleIncomingRequest ns sendQ aRequest sourceAddr) >> pure () - -- Responses should never arrive on the main server port, as they are always - -- responses to requests sent from dedicated sockets on another port - _ -> pure () - ) - aMsg + -- Request parts can be insert into a map (key: (sender IP against spoofing, request ID), value: timestamp + set of message parts, handle all of them when size of set == parts) before being handled. This map needs to be purged periodically by a separate thread and can be protected by an MVar for fairness. + requestMap <- newMVar (Map.empty :: RequestMap) + forever $ do + -- wait for incoming messages + (rawMsg, sourceAddr) <- atomically $ readTQueue recvQ + let aMsg = deserialiseMessage rawMsg + either (\_ -> + -- drop invalid messages + pure () + ) + (\validMsg -> + case validMsg of + aRequest@Request{} + -- if not a multipart message, handle immediately. Response is at the same time a confirmation + | part aRequest == 1 && isFinalPart aRequest -> + forkIO (handleIncomingRequest ns sendQ (Set.singleton aRequest) sourceAddr) >> pure () + -- otherwise collect all message parts first before handling the whole request + | otherwise -> do + now <- getPOSIXTime + -- critical locking section of requestMap + rMapState <- takeMVar requestMap + -- insert new message and get set + let + theseMaxParts = if isFinalPart aRequest then Just (part aRequest) else Nothing + thisKey = (sourceAddr, requestID aRequest) + newMapState = Map.insertWith (\ + (RequestMapEntry thisMsgSet p' ts) (RequestMapEntry oldMsgSet p'' _) -> + RequestMapEntry (thisMsgSet `Set.union` oldMsgSet) (p' <|> p'') ts + ) + thisKey + (RequestMapEntry (Set.singleton aRequest) theseMaxParts now) + rMapState + -- put map back into MVar, end of critical section + putMVar requestMap newMapState + -- if all parts received, then handle request. + let + (RequestMapEntry theseParts mayMaxParts _) = fromJust $ Map.lookup thisKey newMapState + numParts = Set.size theseParts + if maybe False (numParts ==) (fromIntegral <$> mayMaxParts) + then forkIO (handleIncomingRequest ns sendQ theseParts sourceAddr) >> pure() + else pure() + -- Responses should never arrive on the main server port, as they are always + -- responses to requests sent from dedicated sockets on another port + _ -> pure () + ) + aMsg - pure () + pure () diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index bab3866..5a594ca 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -19,21 +19,21 @@ data Action = QueryID deriving (Show, Eq, Enum) data FediChordMessage = Request - { requestID :: Integer - , sender :: RemoteNodeState - , part :: Integer + { requestID :: Integer + , sender :: RemoteNodeState + , part :: Integer , isFinalPart :: Bool -- ^ part starts at 1 - , action :: Action - , payload :: Maybe ActionPayload + , action :: Action + , payload :: Maybe ActionPayload } | Response - { responseTo :: Integer - , senderID :: NodeID - , part :: Integer + { responseTo :: Integer + , senderID :: NodeID + , part :: Integer , isFinalPart :: Bool - , action :: Action - , payload :: Maybe ActionPayload + , action :: Action + , payload :: Maybe ActionPayload } deriving (Show, Eq) From 88104de9bffca080bd3dcf987cc5015493fad478 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sun, 31 May 2020 21:07:40 +0200 Subject: [PATCH 28/88] periodically purge request parts --- src/Hash2Pub/FediChord.hs | 20 +++++++++++++++++--- src/Hash2Pub/Main.hs | 2 -- 2 files changed, 17 insertions(+), 5 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 2a8e151..8a367f2 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -216,9 +216,21 @@ type RequestMap = Map.Map (SockAddr, Integer) RequestMapEntry data RequestMapEntry = RequestMapEntry (Set.Set FediChordMessage) (Maybe Integer) POSIXTime +-- TODO: make purge age configurable +-- | periodically clean up old request parts +purgeAge :: POSIXTime +purgeAge = 60 -- seconds + requestMapPurge :: MVar RequestMap -> IO () --- PLACEHOLDER -requestMapPurge mapVar = pure () +requestMapPurge mapVar = forever $ do + rMapState <- takeMVar mapVar + now <- getPOSIXTime + putMVar mapVar $ Map.filter (\entry@(RequestMapEntry _ _ ts) -> + now - ts < purgeAge + ) rMapState + threadDelay $ fromEnum purgeAge * 2000 + + -- | Wait for messages, deserialise them, manage parts and acknowledgement status, -- and pass them to their specific handling function. @@ -230,7 +242,9 @@ fediMessageHandler sendQ recvQ ns = do -- handling multipart messages: -- Request parts can be insert into a map (key: (sender IP against spoofing, request ID), value: timestamp + set of message parts, handle all of them when size of set == parts) before being handled. This map needs to be purged periodically by a separate thread and can be protected by an MVar for fairness. requestMap <- newMVar (Map.empty :: RequestMap) - forever $ do + -- run receive loop and requestMapPurge concurrently, so that an exception makes + -- both of them fail + concurrently_ (requestMapPurge requestMap) $ forever $ do -- wait for incoming messages (rawMsg, sourceAddr) <- atomically $ readTQueue recvQ let aMsg = deserialiseMessage rawMsg diff --git a/src/Hash2Pub/Main.hs b/src/Hash2Pub/Main.hs index a837cc5..554585f 100644 --- a/src/Hash2Pub/Main.hs +++ b/src/Hash2Pub/Main.hs @@ -42,8 +42,6 @@ main = do wait =<< async (fediMainThreads serverSock thisNode) ) joinedState - -- stop main thread from terminating during development - getChar pure () From 0660bce29949b7237bbdf403a146a1910799c28a Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sun, 31 May 2020 23:21:27 +0200 Subject: [PATCH 29/88] acknowledge parts when receiving partial requests --- src/Hash2Pub/DHTProtocol.hs | 20 +++++++++++++++++++- src/Hash2Pub/FediChord.hs | 7 +++++-- 2 files changed, 24 insertions(+), 3 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index ed1e5d4..5ff87b0 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -21,6 +21,7 @@ module Hash2Pub.DHTProtocol , mkSendSocket , mkServerSocket , handleIncomingRequest + , ackRequest ) where @@ -150,8 +151,23 @@ markCacheEntryAsVerified timestamp = Map.adjust adjustFunc isJoined_ :: LocalNodeState -> Bool isJoined_ ns = not . all null $ [successors ns, predecessors ns] +-- | the size limit to be used when serialising messages for sending +sendMessageSize :: Num i => i +sendMessageSize = 1200 + -- ====== message send and receive operations ====== +-- encode the response to a request that just signals successful receipt +ackRequest :: NodeID -> FediChordMessage -> Map.Map Integer BS.ByteString +ackRequest ownID req@Request{} = serialiseMessage sendMessageSize $ Response { + responseTo = requestID req + , senderID = ownID + , part = part req + , isFinalPart = False + , action = action req + , payload = Nothing + } + handleIncomingRequest :: LocalNodeState -- ^ the handling node -> TQueue (BS.ByteString, SockAddr) -- ^ send queue @@ -165,6 +181,8 @@ handleIncomingRequest ns sendQ msgSet sourceAddr = do -- distinguish on whether and how to respond -- create and enqueue ACK -- Idea: only respond with payload on last part (part == parts), problem: need to know partnumber of response from first part on + -- TODO: determine request type only from first part, but catch RecSelError on each record access when folding, because otherwise different request type parts can make this crash + -- TODO: test case: mixed message types of parts -- PLACEHOLDER pure () @@ -273,7 +291,7 @@ sendRequestTo :: Int -- ^ timeout in seconds sendRequestTo timeoutMillis numAttempts msgIncomplete sock = do -- give the message a random request ID randomID <- randomRIO (0, 2^32-1) - let requests = serialiseMessage 1200 $ msgIncomplete randomID + let requests = serialiseMessage sendMessageSize $ msgIncomplete randomID -- create a queue for passing received response messages back, even after a timeout responseQ <- newTBQueueIO $ 2*maximumParts -- keep room for duplicate packets -- start sendAndAck with timeout diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 8a367f2..c8b2b2e 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -64,7 +64,7 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM import Control.Concurrent.STM.TQueue -import Control.Monad (forever) +import Control.Monad (forM_, forever) import Crypto.Hash import qualified Data.ByteArray as BA import qualified Data.ByteString as BS @@ -255,7 +255,7 @@ fediMessageHandler sendQ recvQ ns = do (\validMsg -> case validMsg of aRequest@Request{} - -- if not a multipart message, handle immediately. Response is at the same time a confirmation + -- if not a multipart message, handle immediately. Response is at the same time an ACK | part aRequest == 1 && isFinalPart aRequest -> forkIO (handleIncomingRequest ns sendQ (Set.singleton aRequest) sourceAddr) >> pure () -- otherwise collect all message parts first before handling the whole request @@ -276,6 +276,9 @@ fediMessageHandler sendQ recvQ ns = do rMapState -- put map back into MVar, end of critical section putMVar requestMap newMapState + -- ACK the received part + forM_ (ackRequest (getNid ns) aRequest) $ + \msg -> atomically $ writeTQueue sendQ (msg, sourceAddr) -- if all parts received, then handle request. let (RequestMapEntry theseParts mayMaxParts _) = fromJust $ Map.lookup thisKey newMapState From f42dfb2137c68d4a238b4904c269d16e29efbc82 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 3 Jun 2020 23:46:05 +0200 Subject: [PATCH 30/88] dispatch incoming requests to their response functions - contributes to #28 --- src/Hash2Pub/DHTProtocol.hs | 30 ++++++++++++++++++++++-------- 1 file changed, 22 insertions(+), 8 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 5ff87b0..9f1e4c7 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -177,14 +177,28 @@ handleIncomingRequest :: LocalNodeState -- ^ the handling no handleIncomingRequest ns sendQ msgSet sourceAddr = do -- add nodestate to cache now <- getPOSIXTime - queueAddEntries (Identity . RemoteCacheEntry (sender . head . Set.elems $ msgSet) $ now) ns - -- distinguish on whether and how to respond - -- create and enqueue ACK - -- Idea: only respond with payload on last part (part == parts), problem: need to know partnumber of response from first part on - -- TODO: determine request type only from first part, but catch RecSelError on each record access when folding, because otherwise different request type parts can make this crash - -- TODO: test case: mixed message types of parts - -- PLACEHOLDER - pure () + aPart <- headMay . Set.elems $ msgSet + case aPart of + Nothing -> pure () + Just aPart' -> + queueAddEntries (Identity . RemoteCacheEntry (sender aPart') $ now) ns + -- distinguish on whether and how to respond. If responding, pass message to response generating function and write responses to send queue + maybe (pure ()) (\respSet -> + forM_ (\resp -> atomically $ writeTQueue sendQ (resp, sourceAddr))) + (case action aPart' of + Ping -> Just respondPing ns msgSet + Join -> Just respondJoin ns msgSet + -- ToDo: figure out what happens if not joined + QueryID -> Just respondQueryID ns msgSet + -- only when joined + Leave -> if isJoined_ ns then Just respondLeave ns msgSet else Nothing + -- only when joined + Stabilise -> if isJoined_ ns then Just respondStabilise ns msgSet else Nothing + ) + -- for single part request, response starts with part number 1. For multipart requests, response starts with part number n+1. + + -- TODO: determine request type only from first part, but catch RecSelError on each record access when folding, because otherwise different request type parts can make this crash + -- TODO: test case: mixed message types of parts -- ....... response sending ....... From dc2e399d6480ccb323b72637d70e3055510a411c Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Thu, 4 Jun 2020 22:29:11 +0200 Subject: [PATCH 31/88] protect concurrent node state access with STM - for allowing concurrent access to predecessors and successors, the whole LocalNodeState is passed wrapped into an STM TVar - this allows keeping the tests for the mostly pure data type, compared to protecting only the successor and predecessor list contributes to #28 --- src/Hash2Pub/DHTProtocol.hs | 117 ++++++++++++++++++++------------- src/Hash2Pub/FediChord.hs | 46 +++++++------ src/Hash2Pub/FediChordTypes.hs | 4 ++ src/Hash2Pub/Main.hs | 8 ++- 4 files changed, 107 insertions(+), 68 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 9f1e4c7..8857597 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -53,7 +53,8 @@ import System.Timeout import Hash2Pub.ASN1Coding import Hash2Pub.FediChordTypes (CacheEntry (..), - LocalNodeState (..), NodeCache, + LocalNodeState (..), + LocalNodeStateSTM, NodeCache, NodeID, NodeState (..), RemoteNodeState (..), cacheGetNodeStateUnvalidated, @@ -169,67 +170,93 @@ ackRequest ownID req@Request{} = serialiseMessage sendMessageSize $ Response { } -handleIncomingRequest :: LocalNodeState -- ^ the handling node +handleIncomingRequest :: LocalNodeStateSTM -- ^ the handling node -> TQueue (BS.ByteString, SockAddr) -- ^ send queue -> Set.Set FediChordMessage -- ^ all parts of the request to handle -> SockAddr -- ^ source address of the request -> IO () -handleIncomingRequest ns sendQ msgSet sourceAddr = do +handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do + ns <- readTVarIO nsSTM -- add nodestate to cache now <- getPOSIXTime - aPart <- headMay . Set.elems $ msgSet - case aPart of + case headMay . Set.elems $ msgSet of Nothing -> pure () - Just aPart' -> - queueAddEntries (Identity . RemoteCacheEntry (sender aPart') $ now) ns + Just aPart -> do + queueAddEntries (Identity $ RemoteCacheEntry (sender aPart) now) ns -- distinguish on whether and how to respond. If responding, pass message to response generating function and write responses to send queue - maybe (pure ()) (\respSet -> - forM_ (\resp -> atomically $ writeTQueue sendQ (resp, sourceAddr))) - (case action aPart' of - Ping -> Just respondPing ns msgSet - Join -> Just respondJoin ns msgSet - -- ToDo: figure out what happens if not joined - QueryID -> Just respondQueryID ns msgSet - -- only when joined - Leave -> if isJoined_ ns then Just respondLeave ns msgSet else Nothing - -- only when joined - Stabilise -> if isJoined_ ns then Just respondStabilise ns msgSet else Nothing - ) - -- for single part request, response starts with part number 1. For multipart requests, response starts with part number n+1. - - -- TODO: determine request type only from first part, but catch RecSelError on each record access when folding, because otherwise different request type parts can make this crash - -- TODO: test case: mixed message types of parts - --- ....... response sending ....... + maybe (pure ()) ( + mapM_ (\resp -> atomically $ writeTQueue sendQ (resp, sourceAddr)) + ) + (case action aPart of + _ -> Just Map.empty) -- placeholder +-- Ping -> Just respondPing nsSTM msgSet +-- Join -> Just respondJoin nsSTM msgSet +-- -- ToDo: figure out what happens if not joined +-- QueryID -> Just respondQueryID nsSTM msgSet +-- -- only when joined +-- Leave -> if isJoined_ ns then Just respondLeave nsSTM msgSet else Nothing +-- -- only when joined +-- Stabilise -> if isJoined_ ns then Just respondStabilise nsSTM msgSet else Nothing +-- ) +-- -- for single part request, response starts with part number 1. For multipart requests, response starts with part number n+1. +-- +-- -- TODO: determine request type only from first part, but catch RecSelError on each record access when folding, because otherwise different request type parts can make this crash +-- -- TODO: test case: mixed message types of parts +-- +---- ....... response sending ....... +-- +---- this modifies node state, so locking and IO seems to be necessary. +---- Still try to keep as much code as possible pure +--respondJoin :: LocalNodeStateSTM -> Set.Set FediChordMessage -> Map Integer BS.ByteString +--respondJoin nsSTM msgSet = +-- -- check whether the joining node falls into our responsibility +-- -- if yes, adjust own predecessors/ successors and return those in a response +-- -- if no: empty response or send a QueryID forwards response? +-- -- TODO: notify service layer to copy over data now handled by the new joined node -- ....... request sending ....... -- | send a join request and return the joined 'LocalNodeState' including neighbours requestJoin :: NodeState a => a -- ^ currently responsible node to be contacted - -> LocalNodeState -- ^ joining NodeState - -> IO (Either String LocalNodeState) -- ^ node after join with all its new information -requestJoin toJoinOn ownState = + -> LocalNodeStateSTM -- ^ joining NodeState + -> IO (Either String LocalNodeStateSTM) -- ^ node after join with all its new information +requestJoin toJoinOn ownStateSTM = bracket (mkSendSocket (getDomain toJoinOn) (getDhtPort toJoinOn)) close (\sock -> do + -- extract own state for getting request information + ownState <- readTVarIO ownStateSTM responses <- sendRequestTo 5000 3 (\rid -> Request rid (toRemoteNodeState ownState) 1 True Join (Just JoinRequestPayload)) sock - joinedStateUnsorted <- foldM - (\nsAcc msg -> case payload msg of - Nothing -> pure nsAcc - Just msgPl -> do - -- add transfered cache entries to global NodeCache - queueAddEntries (joinCache msgPl) nsAcc - -- add received predecessors and successors - let - addPreds ns' = setPredecessors (foldr' (:) (predecessors ns') (joinPredecessors msgPl)) ns' - addSuccs ns' = setSuccessors (foldr' (:) (successors ns') (joinSuccessors msgPl)) ns' - pure $ addSuccs . addPreds $ nsAcc - ) - -- reset predecessors and successors - (setPredecessors [] . setSuccessors [] $ ownState) - responses + (cacheInsertQ, joinedState) <- atomically $ do + stateSnap <- readTVar ownStateSTM + let + (cacheInsertQ, joinedStateUnsorted) = foldl' + (\(insertQ, nsAcc) msg -> + let + insertQ' = maybe insertQ (\msgPl -> + -- collect list of insertion statements into global cache + queueAddEntries (joinCache msgPl) : insertQ + ) $ payload msg + -- add received predecessors and successors + addPreds ns' = maybe ns' (\msgPl -> + setPredecessors (foldr' (:) (predecessors ns') (joinPredecessors msgPl)) ns' + ) $ payload msg + addSuccs ns' = maybe ns' (\msgPl -> + setSuccessors (foldr' (:) (successors ns') (joinSuccessors msgPl)) ns' + ) $ payload msg + in + (insertQ', addSuccs . addPreds $ nsAcc) + ) + -- reset predecessors and successors + ([], setPredecessors [] . setSuccessors [] $ ownState) + responses + -- sort successors and predecessors + newState = setSuccessors (sortBy localCompare $ successors joinedStateUnsorted) . setPredecessors (sortBy localCompare $ predecessors joinedStateUnsorted) $ joinedStateUnsorted + writeTVar ownStateSTM newState + pure (cacheInsertQ, newState) + -- execute the cache insertions + mapM_ (\f -> f joinedState) cacheInsertQ if responses == Set.empty then pure . Left $ "join error: got no response from " <> show (getNid toJoinOn) - -- sort successors and predecessors - else pure . Right . setSuccessors (sortBy localCompare $ successors joinedStateUnsorted) . setPredecessors (sortBy localCompare $ predecessors joinedStateUnsorted) $ joinedStateUnsorted + else pure $ Right ownStateSTM ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index c8b2b2e..43de152 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -64,6 +64,7 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM import Control.Concurrent.STM.TQueue +import Control.Concurrent.STM.TVar import Control.Monad (forM_, forever) import Crypto.Hash import qualified Data.ByteArray as BA @@ -84,11 +85,12 @@ import Debug.Trace (trace) -- | initialise data structures, compute own IDs and bind to listening socket -- ToDo: load persisted state, thus this function already operates in IO -fediChordInit :: FediChordConf -> IO (Socket, LocalNodeState) +fediChordInit :: FediChordConf -> IO (Socket, LocalNodeStateSTM) fediChordInit conf = do initialState <- nodeStateInit conf + initialStateSTM <- newTVarIO initialState serverSock <- mkServerSocket (getIpAddr initialState) (getDhtPort initialState) - pure (serverSock, initialState) + pure (serverSock, initialStateSTM) -- | initialises the 'NodeState' for this local node. -- Separated from 'fediChordInit' to be usable in tests. @@ -120,15 +122,16 @@ nodeStateInit conf = do -- | Join a new node into the DHT, using a provided bootstrap node as initial cache seed -- for resolving the new node's position. -fediChordBootstrapJoin :: LocalNodeState -- ^ the local 'NodeState' +fediChordBootstrapJoin :: LocalNodeStateSTM -- ^ the local 'NodeState' -> (String, PortNumber) -- ^ domain and port of a bootstrapping node - -> IO (Either String LocalNodeState) -- ^ the joined 'NodeState' after a + -> IO (Either String LocalNodeStateSTM) -- ^ the joined 'NodeState' after a -- successful join, otherwise an error message -fediChordBootstrapJoin ns (joinHost, joinPort) = +fediChordBootstrapJoin nsSTM (joinHost, joinPort) = -- can be invoked multiple times with all known bootstrapping nodes until successfully joined bracket (mkSendSocket joinHost joinPort) close (\sock -> do -- 1. get routed to placement of own ID until FOUND: -- Initialise an empty cache only with the responses from a bootstrapping node + ns <- readTVarIO nsSTM bootstrapResponse <- sendQueryIdMessage (getNid ns) ns sock if bootstrapResponse == Set.empty then pure . Left $ "Bootstrapping node " <> show joinHost <> " gave no response." @@ -143,7 +146,7 @@ fediChordBootstrapJoin ns (joinHost, joinPort) = Just (FORWARD resultset) -> foldr' (addCacheEntryPure now) cacheAcc resultset ) initCache bootstrapResponse - fediChordJoin bootstrapCache ns + fediChordJoin bootstrapCache nsSTM ) `catch` (\e -> pure . Left $ "Error at bootstrap joining: " <> displayException (e :: IOException)) @@ -151,15 +154,16 @@ fediChordBootstrapJoin ns (joinHost, joinPort) = -- node's position. fediChordJoin :: NodeCache -- ^ a snapshot of the NodeCache to -- use for ID lookup - -> LocalNodeState -- ^ the local 'NodeState' - -> IO (Either String LocalNodeState) -- ^ the joined 'NodeState' after a + -> LocalNodeStateSTM -- ^ the local 'NodeState' + -> IO (Either String LocalNodeStateSTM) -- ^ the joined 'NodeState' after a -- successful join, otherwise an error message -fediChordJoin cacheSnapshot ns = do +fediChordJoin cacheSnapshot nsSTM = do + ns <- readTVarIO nsSTM -- get routed to the currently responsible node, based on the response -- from the bootstrapping node currentlyResponsible <- queryIdLookupLoop cacheSnapshot ns $ getNid ns -- 2. then send a join to the currently responsible node - joinResult <- requestJoin currentlyResponsible ns + joinResult <- requestJoin currentlyResponsible nsSTM case joinResult of Left err -> pure . Left $ "Error joining on " <> err Right joinedNS -> pure . Right $ joinedNS @@ -167,8 +171,9 @@ fediChordJoin cacheSnapshot ns = do -- | cache updater thread that waits for incoming NodeCache update instructions on -- the node's cacheWriteQueue and then modifies the NodeCache as the single writer. -cacheWriter :: LocalNodeState -> IO () -cacheWriter ns = do +cacheWriter :: LocalNodeStateSTM -> IO () +cacheWriter nsSTM = do + ns <- readTVarIO nsSTM let writeQueue' = cacheWriteQueue ns forever $ do f <- atomically $ readTQueue writeQueue' @@ -196,14 +201,14 @@ sendThread sock sendQ = forever $ do sendAllTo sock packet addr -- | Sets up and manages the main server threads of FediChord -fediMainThreads :: Socket -> LocalNodeState -> IO () -fediMainThreads sock ns = do +fediMainThreads :: Socket -> LocalNodeStateSTM -> IO () +fediMainThreads sock nsSTM = do sendQ <- newTQueueIO recvQ <- newTQueueIO -- concurrently launch all handler threads, if one of them throws an exception -- all get cancelled concurrently_ - (fediMessageHandler sendQ recvQ ns) $ + (fediMessageHandler sendQ recvQ nsSTM) $ concurrently (sendThread sock sendQ) (recvThread sock recvQ) @@ -236,9 +241,10 @@ requestMapPurge mapVar = forever $ do -- and pass them to their specific handling function. fediMessageHandler :: TQueue (BS.ByteString, SockAddr) -- ^ send queue -> TQueue (BS.ByteString, SockAddr) -- ^ receive queue - -> LocalNodeState -- ^ acting NodeState + -> LocalNodeStateSTM -- ^ acting NodeState -> IO () -fediMessageHandler sendQ recvQ ns = do +fediMessageHandler sendQ recvQ nsSTM = do + nsSnap <- readTVarIO nsSTM -- handling multipart messages: -- Request parts can be insert into a map (key: (sender IP against spoofing, request ID), value: timestamp + set of message parts, handle all of them when size of set == parts) before being handled. This map needs to be purged periodically by a separate thread and can be protected by an MVar for fairness. requestMap <- newMVar (Map.empty :: RequestMap) @@ -257,7 +263,7 @@ fediMessageHandler sendQ recvQ ns = do aRequest@Request{} -- if not a multipart message, handle immediately. Response is at the same time an ACK | part aRequest == 1 && isFinalPart aRequest -> - forkIO (handleIncomingRequest ns sendQ (Set.singleton aRequest) sourceAddr) >> pure () + forkIO (handleIncomingRequest nsSTM sendQ (Set.singleton aRequest) sourceAddr) >> pure () -- otherwise collect all message parts first before handling the whole request | otherwise -> do now <- getPOSIXTime @@ -277,14 +283,14 @@ fediMessageHandler sendQ recvQ ns = do -- put map back into MVar, end of critical section putMVar requestMap newMapState -- ACK the received part - forM_ (ackRequest (getNid ns) aRequest) $ + forM_ (ackRequest (getNid nsSnap) aRequest) $ \msg -> atomically $ writeTQueue sendQ (msg, sourceAddr) -- if all parts received, then handle request. let (RequestMapEntry theseParts mayMaxParts _) = fromJust $ Map.lookup thisKey newMapState numParts = Set.size theseParts if maybe False (numParts ==) (fromIntegral <$> mayMaxParts) - then forkIO (handleIncomingRequest ns sendQ theseParts sourceAddr) >> pure() + then forkIO (handleIncomingRequest nsSTM sendQ theseParts sourceAddr) >> pure() else pure() -- Responses should never arrive on the main server port, as they are always -- responses to requests sent from dedicated sockets on another port diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 7e3565d..2feea08 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -9,6 +9,7 @@ module Hash2Pub.FediChordTypes ( , toNodeID , NodeState (..) , LocalNodeState (..) + , LocalNodeStateSTM , RemoteNodeState (..) , setSuccessors , setPredecessors @@ -40,6 +41,7 @@ import Network.Socket -- for hashing and ID conversion import Control.Concurrent.STM import Control.Concurrent.STM.TQueue +import Control.Concurrent.STM.TVar import Control.Monad (forever) import Crypto.Hash import qualified Data.ByteArray as BA @@ -144,6 +146,8 @@ data LocalNodeState = LocalNodeState } deriving (Show, Eq) +type LocalNodeStateSTM = TVar LocalNodeState + -- | class for various NodeState representations, providing -- getters and setters for common values class NodeState a where diff --git a/src/Hash2Pub/Main.hs b/src/Hash2Pub/Main.hs index 554585f..fc9299d 100644 --- a/src/Hash2Pub/Main.hs +++ b/src/Hash2Pub/Main.hs @@ -2,9 +2,11 @@ module Main where import Control.Concurrent import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Concurrent.STM.TVar import Control.Exception import Data.Either -import Data.IP (IPv6, toHostAddress6) +import Data.IP (IPv6, toHostAddress6) import System.Environment import Hash2Pub.FediChord @@ -16,7 +18,7 @@ main = do conf <- readConfig -- ToDo: load persisted caches, bootstrapping nodes … (serverSock, thisNode) <- fediChordInit conf - print thisNode + print =<< readTVarIO thisNode print serverSock -- currently no masking is necessary, as there is nothing to clean up cacheWriterThread <- forkIO $ cacheWriter thisNode @@ -38,7 +40,7 @@ main = do ) (\joinedNS -> do -- launch main eventloop with successfully joined state - putStrLn ("successful join at " <> (show . getNid $ joinedNS)) + putStrLn "successful join" wait =<< async (fediMainThreads serverSock thisNode) ) joinedState From 914e07a412a3105651188064eba64644173e1750 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Fri, 5 Jun 2020 22:07:47 +0200 Subject: [PATCH 32/88] change NodeCache protection to STM - putting the NodeCache behind an IORef had been chose because those could've been read non-blocking - the same is true for TVars. The performance characteristics are likely worse, but at the advantage of composability within STM monads --- src/Hash2Pub/DHTProtocol.hs | 4 ++-- src/Hash2Pub/FediChord.hs | 19 +++++++------------ src/Hash2Pub/FediChordTypes.hs | 5 ++--- test/FediChordSpec.hs | 1 - 4 files changed, 11 insertions(+), 18 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 8857597..e30fe26 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -27,6 +27,7 @@ module Hash2Pub.DHTProtocol import Control.Concurrent.Async import Control.Concurrent.STM +import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TBQueue import Control.Concurrent.STM.TQueue import Control.Exception @@ -35,7 +36,6 @@ import qualified Data.ByteString as BS import Data.Either (rights) import Data.Foldable (foldl', foldr') import Data.Functor.Identity -import Data.IORef import Data.IP (IPv6, fromHostAddress6, toHostAddress6) import Data.List (sortBy) @@ -272,7 +272,7 @@ requestQueryID :: LocalNodeState -- ^ NodeState of the querying node -- 5. repeat until FOUND (problem: new entries not necessarily already in cache, explicitly compare with closer results) -- TODO: deal with lookup failures requestQueryID ns targetID = do - firstCacheSnapshot <- readIORef . nodeCacheRef $ ns + firstCacheSnapshot <- readTVarIO . nodeCacheSTM $ ns queryIdLookupLoop firstCacheSnapshot ns targetID -- | like 'requestQueryID, but allows passing of a custom cache, e.g. for joining diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 43de152..795772b 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -70,7 +70,6 @@ import Crypto.Hash import qualified Data.ByteArray as BA import qualified Data.ByteString as BS import qualified Data.ByteString.UTF8 as BSU -import Data.IORef import Data.IP (IPv6, fromHostAddress6, toHostAddress6) import Data.Typeable (Typeable (..), typeOf) @@ -96,7 +95,7 @@ fediChordInit conf = do -- Separated from 'fediChordInit' to be usable in tests. nodeStateInit :: FediChordConf -> IO LocalNodeState nodeStateInit conf = do - cacheRef <- newIORef initCache + cacheSTM <- newTVarIO initCache q <- atomically newTQueue let containedState = RemoteNodeState { @@ -109,7 +108,7 @@ nodeStateInit conf = do } initialState = LocalNodeState { nodeState = containedState - , nodeCacheRef = cacheRef + , nodeCacheSTM = cacheSTM , cacheWriteQueue = q , successors = [] , predecessors = [] @@ -172,15 +171,11 @@ fediChordJoin cacheSnapshot nsSTM = do -- | cache updater thread that waits for incoming NodeCache update instructions on -- the node's cacheWriteQueue and then modifies the NodeCache as the single writer. cacheWriter :: LocalNodeStateSTM -> IO () -cacheWriter nsSTM = do - ns <- readTVarIO nsSTM - let writeQueue' = cacheWriteQueue ns - forever $ do - f <- atomically $ readTQueue writeQueue' - let - refModifier :: NodeCache -> (NodeCache, ()) - refModifier nc = (f nc, ()) - atomicModifyIORef' (nodeCacheRef ns) refModifier +cacheWriter nsSTM = + forever $ atomically $ do + ns <- readTVar nsSTM + cacheModifier <- readTQueue $ cacheWriteQueue ns + modifyTVar' (nodeCacheSTM ns) cacheModifier -- | Receives UDP packets and passes them to other threads via the given TQueue. -- Shall be used as the single receiving thread on the server socket, as multiple diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 2feea08..1f28aea 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -47,7 +47,6 @@ import Crypto.Hash import qualified Data.ByteArray as BA import qualified Data.ByteString as BS import qualified Data.ByteString.UTF8 as BSU -import Data.IORef import Data.IP (IPv6, fromHostAddress6, toHostAddress6) import Data.Typeable (Typeable (..), typeOf) @@ -127,7 +126,7 @@ data RemoteNodeState = RemoteNodeState data LocalNodeState = LocalNodeState { nodeState :: RemoteNodeState -- ^ represents common data present both in remote and local node representations - , nodeCacheRef :: IORef NodeCache + , nodeCacheSTM :: TVar NodeCache -- ^ EpiChord node cache with expiry times for nodes , cacheWriteQueue :: TQueue (NodeCache -> NodeCache) -- ^ cache updates are not written directly to the 'nodeCache' but queued and @@ -206,7 +205,7 @@ instance NodeState LocalNodeState where toRemoteNodeState = nodeState -- | defining Show instances to be able to print NodeState for debug purposes -instance Typeable a => Show (IORef a) where +instance Typeable a => Show (TVar a) where show x = show (typeOf x) instance Typeable a => Show (TQueue a) where diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index 629c7c2..36ae2de 100644 --- a/test/FediChordSpec.hs +++ b/test/FediChordSpec.hs @@ -4,7 +4,6 @@ module FediChordSpec where import Control.Exception import Data.ASN1.Parse (runParseASN1) import qualified Data.ByteString as BS -import Data.IORef import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) import qualified Data.Set as Set From e32f0c91462cf891afdb288c4fc68c9aeb5097d8 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Fri, 5 Jun 2020 21:37:20 +0200 Subject: [PATCH 33/88] process and respond to join requests - serialiseMessage now starts numbering parts from the first number it gets, to be able to continue responding after having ACKed previous parts contributes to #28 --- src/Hash2Pub/ASN1Coding.hs | 2 +- src/Hash2Pub/DHTProtocol.hs | 97 ++++++++++++++++++++++++++--------- src/Hash2Pub/ProtocolTypes.hs | 7 +++ 3 files changed, 80 insertions(+), 26 deletions(-) diff --git a/src/Hash2Pub/ASN1Coding.hs b/src/Hash2Pub/ASN1Coding.hs index 6bbb9df..25e435b 100644 --- a/src/Hash2Pub/ASN1Coding.hs +++ b/src/Hash2Pub/ASN1Coding.hs @@ -107,7 +107,7 @@ serialiseMessage maxBytesLength msg = }):pls -- part starts at 1 payloadParts :: Int -> Maybe [(Integer, ActionPayload)] - payloadParts i = zip [1..] . splitPayload i <$> actionPayload + payloadParts i = zip [(part msg)..] . splitPayload i <$> actionPayload actionPayload = payload msg encodedMsgs i = Map.map encodeMsg $ messageParts i maxMsgLength = maximum . fmap BS.length . Map.elems diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index e30fe26..b759093 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -27,9 +27,9 @@ module Hash2Pub.DHTProtocol import Control.Concurrent.Async import Control.Concurrent.STM -import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TBQueue import Control.Concurrent.STM.TQueue +import Control.Concurrent.STM.TVar import Control.Exception import Control.Monad (foldM, forM, forM_) import qualified Data.ByteString as BS @@ -170,6 +170,8 @@ ackRequest ownID req@Request{} = serialiseMessage sendMessageSize $ Response { } +-- | Dispatch incoming requests to the dedicated handling and response function, and enqueue +-- the response to be sent. handleIncomingRequest :: LocalNodeStateSTM -- ^ the handling node -> TQueue (BS.ByteString, SockAddr) -- ^ send queue -> Set.Set FediChordMessage -- ^ all parts of the request to handle @@ -187,32 +189,74 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do maybe (pure ()) ( mapM_ (\resp -> atomically $ writeTQueue sendQ (resp, sourceAddr)) ) - (case action aPart of - _ -> Just Map.empty) -- placeholder --- Ping -> Just respondPing nsSTM msgSet --- Join -> Just respondJoin nsSTM msgSet + =<< (case action aPart of +-- Ping -> Just <$> respondPing nsSTM msgSet + Join -> Just <$> respondJoin nsSTM msgSet -- -- ToDo: figure out what happens if not joined --- QueryID -> Just respondQueryID nsSTM msgSet +-- QueryID -> Just <$> respondQueryID nsSTM msgSet -- -- only when joined --- Leave -> if isJoined_ ns then Just respondLeave nsSTM msgSet else Nothing +-- Leave -> if isJoined_ ns then Just <$> respondLeave nsSTM msgSet else Nothing -- -- only when joined --- Stabilise -> if isJoined_ ns then Just respondStabilise nsSTM msgSet else Nothing +-- Stabilise -> if isJoined_ ns then Just <$> respondStabilise nsSTM msgSet else Nothing -- ) --- -- for single part request, response starts with part number 1. For multipart requests, response starts with part number n+1. --- --- -- TODO: determine request type only from first part, but catch RecSelError on each record access when folding, because otherwise different request type parts can make this crash --- -- TODO: test case: mixed message types of parts --- ----- ....... response sending ....... --- ----- this modifies node state, so locking and IO seems to be necessary. ----- Still try to keep as much code as possible pure ---respondJoin :: LocalNodeStateSTM -> Set.Set FediChordMessage -> Map Integer BS.ByteString ---respondJoin nsSTM msgSet = --- -- check whether the joining node falls into our responsibility --- -- if yes, adjust own predecessors/ successors and return those in a response --- -- if no: empty response or send a QueryID forwards response? --- -- TODO: notify service layer to copy over data now handled by the new joined node + -- for single part request, response starts with part number 1. For multipart requests, response starts with part number n+1. + + -- TODO: determine request type only from first part, but catch RecSelError on each record access when folding, because otherwise different request type parts can make this crash + -- TODO: test case: mixed message types of parts + + ) -- placeholder + + +-- ....... response sending ....... + +-- this modifies node state, so locking and IO seems to be necessary. +-- Still try to keep as much code as possible pure +respondJoin :: LocalNodeStateSTM -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString) +respondJoin nsSTM msgSet = do + -- atomically read and modify the node state according to the parsed request + responseMsg <- atomically $ do + nsSnap <- readTVar nsSTM + cache <- readTVar $ nodeCacheSTM nsSnap + let + aRequestPart = Set.elemAt 0 msgSet + senderNS = sender aRequestPart + responsibilityLookup = queryLocalCache nsSnap cache 1 (getNid senderNS) + thisNodeResponsible (FOUND _) = True + thisNodeResponsible (FORWARD _) = False + -- check whether the joining node falls into our responsibility + if thisNodeResponsible responsibilityLookup + then do + -- if yes, adjust own predecessors/ successors and return those in a response + let + newPreds = take (kNeighbours nsSnap) . sortBy (flip localCompare) $ getNid senderNS:predecessors nsSnap + joinedNS = setPredecessors newPreds nsSnap + responsePayload = JoinResponsePayload { + joinSuccessors = successors joinedNS + , joinPredecessors = predecessors joinedNS + , joinCache = toRemoteCache cache + } + joinResponse = Response { + responseTo = requestID aRequestPart + , senderID = getNid joinedNS + , part = if Set.size msgSet == 1 then 1 else fromIntegral $ Set.size msgSet + 1 + , isFinalPart = False + , action = Join + , payload = Just responsePayload + } + writeTVar nsSTM joinedNS + pure joinResponse + -- otherwise respond with empty payload + else pure Response { + responseTo = requestID aRequestPart + , senderID = getNid nsSnap + , part = if Set.size msgSet == 1 then 1 else fromIntegral $ Set.size msgSet + 1 + , isFinalPart = False + , action = Join + , payload = Nothing + } + + pure $ serialiseMessage sendMessageSize responseMsg + -- TODO: notify service layer to copy over data now handled by the new joined node -- ....... request sending ....... @@ -249,14 +293,17 @@ requestJoin toJoinOn ownStateSTM = ([], setPredecessors [] . setSuccessors [] $ ownState) responses -- sort successors and predecessors - newState = setSuccessors (sortBy localCompare $ successors joinedStateUnsorted) . setPredecessors (sortBy localCompare $ predecessors joinedStateUnsorted) $ joinedStateUnsorted + newState = setSuccessors (take (kNeighbours joinedStateUnsorted) . sortBy localCompare $ successors joinedStateUnsorted) . setPredecessors (take (kNeighbours joinedStateUnsorted) . sortBy (flip localCompare) $ predecessors joinedStateUnsorted) $ joinedStateUnsorted writeTVar ownStateSTM newState pure (cacheInsertQ, newState) -- execute the cache insertions mapM_ (\f -> f joinedState) cacheInsertQ if responses == Set.empty then pure . Left $ "join error: got no response from " <> show (getNid toJoinOn) - else pure $ Right ownStateSTM + else if null (predecessors joinedState) && null (successors joinedState) + then pure $ Left "join error: no predecessors or successors" + -- successful join + else pure $ Right ownStateSTM ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index 5a594ca..c6348b3 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -1,5 +1,7 @@ module Hash2Pub.ProtocolTypes where +import qualified Data.Map as Map +import Data.Maybe (mapMaybe) import qualified Data.Set as Set import Data.Time.Clock.POSIX (POSIXTime) @@ -83,11 +85,16 @@ data RemoteCacheEntry = RemoteCacheEntry RemoteNodeState POSIXTime instance Ord RemoteCacheEntry where (RemoteCacheEntry ns1 _) `compare` (RemoteCacheEntry ns2 _) = nid ns1 `compare` nid ns2 +-- | Extracts a 'RemoteCacheEntry' from the indirections of a 'CacheEntry', if it holds one toRemoteCacheEntry :: CacheEntry -> Maybe RemoteCacheEntry toRemoteCacheEntry (NodeEntry _ ns ts) = Just $ RemoteCacheEntry ns ts toRemoteCacheEntry (ProxyEntry _ (Just entry@NodeEntry{})) = toRemoteCacheEntry entry toRemoteCacheEntry _ = Nothing +-- | a list of all entries of a 'NodeCache' as 'RemoteCacheEntry', useful for cache transfers +toRemoteCache :: NodeCache -> [RemoteCacheEntry] +toRemoteCache cache = mapMaybe toRemoteCacheEntry $ Map.elems cache + -- | extract the 'NodeState' from a 'RemoteCacheEntry' remoteNode :: RemoteCacheEntry -> RemoteNodeState remoteNode (RemoteCacheEntry ns _) = ns From cb769e088fc9bdef7c85a0ff81c0a1372051e666 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 6 Jun 2020 13:29:48 +0200 Subject: [PATCH 34/88] add test for serialiseMessage part numbering --- test/FediChordSpec.hs | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index 36ae2de..b6f08ad 100644 --- a/test/FediChordSpec.hs +++ b/test/FediChordSpec.hs @@ -5,7 +5,7 @@ import Control.Exception import Data.ASN1.Parse (runParseASN1) import qualified Data.ByteString as BS import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, isJust) import qualified Data.Set as Set import Data.Time.Clock.POSIX import Network.Socket @@ -212,6 +212,12 @@ spec = do responseWith a pa = responseTemplate {action = a, payload = Just pa} encodeDecodeAndCheck msg = runParseASN1 parseMessage (encodeMessage msg) `shouldBe` pure msg + largeMessage = responseWith Join $ JoinResponsePayload { + joinSuccessors = fromInteger <$> [-20..150] + , joinPredecessors = fromInteger <$> [5..11] + , joinCache = [ RemoteCacheEntry (exampleNodeState {nid = node}) 290001 | node <- [50602,506011..60000]] + } + it "messages are encoded and decoded correctly from and to ASN1" $ do encodeDecodeAndCheck $ requestWith QueryID qidReqPayload encodeDecodeAndCheck $ requestWith Join jReqPayload @@ -227,14 +233,14 @@ spec = do it "messages are encoded and decoded to ASN.1 DER properly" $ deserialiseMessage (fromJust $ Map.lookup 1 (serialiseMessage 652 $ responseWith Ping pingResPayload)) `shouldBe` Right (responseWith Ping pingResPayload) it "messages too large for a single packet can (often) be split into multiple parts" $ do - let largeMessage = responseWith Join $ JoinResponsePayload { - joinSuccessors = fromInteger <$> [-20..150] - , joinPredecessors = fromInteger <$> [5..11] - , joinCache = [ RemoteCacheEntry (exampleNodeState {nid = node}) 290001 | node <- [50602,506011..60000]] - } -- TODO: once splitting works more efficient, test for exact number or payload, see #18 length (serialiseMessage 600 largeMessage) > 1 `shouldBe` True length (serialiseMessage 6000 largeMessage) `shouldBe` 1 + it "message part numbering starts at the submitted part number" $ do + isJust (Map.lookup 1 (serialiseMessage 600 largeMessage)) `shouldBe` True + let startAt5 = serialiseMessage 600 (largeMessage {part = 5}) + Map.lookup 1 startAt5 `shouldBe` Nothing + part <$> (deserialiseMessage . fromJust) (Map.lookup 5 startAt5) `shouldBe` Right 5 -- some example data From 43d72128d20217ecd505dee5cd067c2d45815b37 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 6 Jun 2020 17:05:54 +0200 Subject: [PATCH 35/88] respond to Ping requests --- src/Hash2Pub/DHTProtocol.hs | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index b759093..983fdc2 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -190,7 +190,7 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do mapM_ (\resp -> atomically $ writeTQueue sendQ (resp, sourceAddr)) ) =<< (case action aPart of --- Ping -> Just <$> respondPing nsSTM msgSet + Ping -> Just <$> respondPing nsSTM msgSet Join -> Just <$> respondJoin nsSTM msgSet -- -- ToDo: figure out what happens if not joined -- QueryID -> Just <$> respondQueryID nsSTM msgSet @@ -209,6 +209,25 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do -- ....... response sending ....... +-- TODO: could all these respond* functions be in STM instead of IO? + +respondPing :: LocalNodeStateSTM -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString) +respondPing nsSTM msgSet = do + -- TODO: respond with all active VS when implementing k-choices + nsSnap <- readTVarIO nsSTM + let + aRequestPart = Set.elemAt 0 msgSet + responsePayload = PingResponsePayload { pingNodeStates = [ toRemoteNodeState nsSnap ] } + pingResponse = Response { + responseTo = requestID aRequestPart + , senderID = getNid nsSnap + , part = if Set.size msgSet == 1 then 1 else fromIntegral $ Set.size msgSet + 1 + , isFinalPart = False + , action = Ping + , payload = Just responsePayload + } + pure $ serialiseMessage sendMessageSize pingResponse + -- this modifies node state, so locking and IO seems to be necessary. -- Still try to keep as much code as possible pure respondJoin :: LocalNodeStateSTM -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString) From 53308080db63fb4e30dcc35e672b1e2a40c1cf41 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 6 Jun 2020 17:31:20 +0200 Subject: [PATCH 36/88] respond to Stabilise requests --- src/Hash2Pub/DHTProtocol.hs | 32 +++++++++++++++++++++++++++----- 1 file changed, 27 insertions(+), 5 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 983fdc2..2df852b 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -195,22 +195,44 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do -- -- ToDo: figure out what happens if not joined -- QueryID -> Just <$> respondQueryID nsSTM msgSet -- -- only when joined --- Leave -> if isJoined_ ns then Just <$> respondLeave nsSTM msgSet else Nothing +-- Leave -> if isJoined_ ns then Just <$> respondLeave nsSTM msgSet else pure Nothing -- -- only when joined --- Stabilise -> if isJoined_ ns then Just <$> respondStabilise nsSTM msgSet else Nothing --- ) + Stabilise -> if isJoined_ ns then Just <$> respondStabilise nsSTM msgSet else pure Nothing + ) -- for single part request, response starts with part number 1. For multipart requests, response starts with part number n+1. -- TODO: determine request type only from first part, but catch RecSelError on each record access when folding, because otherwise different request type parts can make this crash -- TODO: test case: mixed message types of parts - ) -- placeholder - -- ....... response sending ....... -- TODO: could all these respond* functions be in STM instead of IO? + +-- | respond to stabilise requests by returning successor and predecessor list +respondStabilise :: LocalNodeStateSTM -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString) +respondStabilise nsSTM msgSet = do + nsSnap <- readTVarIO nsSTM + let + aRequestPart = Set.elemAt 0 msgSet + responsePayload = StabiliseResponsePayload { + stabiliseSuccessors = successors nsSnap + , stabilisePredecessors = predecessors nsSnap + } + stabiliseResponse = Response { + responseTo = requestID aRequestPart + , senderID = getNid nsSnap + , part = if Set.size msgSet == 1 then 1 else fromIntegral $ Set.size msgSet + 1 + , isFinalPart = False + , action = Stabilise + , payload = Just responsePayload + } + -- TODO: return service endpoint for copying over key data + pure $ serialiseMessage sendMessageSize stabiliseResponse + + +-- | respond to Ping request by returning all active vserver NodeStates respondPing :: LocalNodeStateSTM -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString) respondPing nsSTM msgSet = do -- TODO: respond with all active VS when implementing k-choices From e00da9b84fbc81f84c48fd48cfff15b64efc3802 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 6 Jun 2020 18:02:40 +0200 Subject: [PATCH 37/88] respond to and handle Leave requests contributes to #28 --- src/Hash2Pub/DHTProtocol.hs | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 2df852b..5cbba56 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -38,7 +38,7 @@ import Data.Foldable (foldl', foldr') import Data.Functor.Identity import Data.IP (IPv6, fromHostAddress6, toHostAddress6) -import Data.List (sortBy) +import Data.List (delete, sortBy) import qualified Data.Map as Map import Data.Maybe (fromJust, fromMaybe, mapMaybe, maybe) @@ -209,6 +209,32 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do -- TODO: could all these respond* functions be in STM instead of IO? +-- | Respond to a Leave request by removing the leaving node from local data structures +-- and confirming with response. +-- TODO: copy over key data from leaver and confirm +respondLeave :: LocalNodeStateSTM -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString) +respondLeave nsSTM msgSet = do + responseMsg <- atomically $ do + nsSnap <- readTVar nsSTM + let + aRequestPart = Set.elemAt 0 msgSet + senderID = getNid . sender $ aRequestPart + -- remove leaving node from successors, predecessors and NodeCache + writeTQueue (cacheWriteQueue nsSnap) $ deleteCacheEntry senderID + writeTVar nsSTM $ + setPredecessors (delete senderID $ predecessors nsSnap) + . setSuccessors (delete senderID $ successors nsSnap) $ nsSnap + -- TODO: handle handover of key data + let leaveResponse = Response { + responseTo = requestID aRequestPart + , senderID = getNid nsSnap + , part = if Set.size msgSet == 1 then 1 else fromIntegral $ Set.size msgSet + 1 + , isFinalPart = False + , action = Leave + , payload = Just LeaveResponsePayload + } + pure leaveResponse + pure $ serialiseMessage sendMessageSize responseMsg -- | respond to stabilise requests by returning successor and predecessor list respondStabilise :: LocalNodeStateSTM -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString) From 0a9b0547c67da0840ad3463e04a14794b6464198 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sun, 7 Jun 2020 00:21:03 +0200 Subject: [PATCH 38/88] forgot handling the successors and predecessors of the leaving node contributes to #28 --- src/Hash2Pub/DHTProtocol.hs | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 5cbba56..313471c 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -38,7 +38,7 @@ import Data.Foldable (foldl', foldr') import Data.Functor.Identity import Data.IP (IPv6, fromHostAddress6, toHostAddress6) -import Data.List (delete, sortBy) +import Data.List (delete, nub, sortBy) import qualified Data.Map as Map import Data.Maybe (fromJust, fromMaybe, mapMaybe, maybe) @@ -214,16 +214,22 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do -- TODO: copy over key data from leaver and confirm respondLeave :: LocalNodeStateSTM -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString) respondLeave nsSTM msgSet = do + -- combine payload of all parts + let (requestSuccs, requestPreds) = foldr' (\msg (succAcc, predAcc) -> + (maybe succAcc (++ succAcc) (leaveSuccessors <$> payload msg) + ,maybe predAcc (++ predAcc) (leavePredecessors <$> payload msg)) + ) + ([],[]) msgSet + aRequestPart = Set.elemAt 0 msgSet + senderID = getNid . sender $ aRequestPart responseMsg <- atomically $ do nsSnap <- readTVar nsSTM - let - aRequestPart = Set.elemAt 0 msgSet - senderID = getNid . sender $ aRequestPart -- remove leaving node from successors, predecessors and NodeCache writeTQueue (cacheWriteQueue nsSnap) $ deleteCacheEntry senderID writeTVar nsSTM $ - setPredecessors (delete senderID $ predecessors nsSnap) - . setSuccessors (delete senderID $ successors nsSnap) $ nsSnap + -- add predecessors and successors of leaving node to own lists + setPredecessors (take (kNeighbours nsSnap) . delete senderID . nub . sortBy (flip localCompare) $ requestPreds <> predecessors nsSnap) + . setSuccessors (take (kNeighbours nsSnap) . delete senderID . nub . sortBy localCompare $ requestSuccs <> successors nsSnap) $ nsSnap -- TODO: handle handover of key data let leaveResponse = Response { responseTo = requestID aRequestPart @@ -295,7 +301,7 @@ respondJoin nsSTM msgSet = do then do -- if yes, adjust own predecessors/ successors and return those in a response let - newPreds = take (kNeighbours nsSnap) . sortBy (flip localCompare) $ getNid senderNS:predecessors nsSnap + newPreds = take (kNeighbours nsSnap) . nub . sortBy (flip localCompare) $ getNid senderNS:predecessors nsSnap joinedNS = setPredecessors newPreds nsSnap responsePayload = JoinResponsePayload { joinSuccessors = successors joinedNS From eec751584c2ba9876a6f15a19b765fde4a871ba8 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sun, 7 Jun 2020 23:45:09 +0200 Subject: [PATCH 39/88] make setPredecessors and setSuccessors enforce the ordering + size limit closes #47 --- src/Hash2Pub/DHTProtocol.hs | 6 +++--- src/Hash2Pub/FediChordTypes.hs | 5 +++-- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 313471c..b70550f 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -228,8 +228,8 @@ respondLeave nsSTM msgSet = do writeTQueue (cacheWriteQueue nsSnap) $ deleteCacheEntry senderID writeTVar nsSTM $ -- add predecessors and successors of leaving node to own lists - setPredecessors (take (kNeighbours nsSnap) . delete senderID . nub . sortBy (flip localCompare) $ requestPreds <> predecessors nsSnap) - . setSuccessors (take (kNeighbours nsSnap) . delete senderID . nub . sortBy localCompare $ requestSuccs <> successors nsSnap) $ nsSnap + setPredecessors (delete senderID $ requestPreds <> predecessors nsSnap) + . setSuccessors (delete senderID $ requestSuccs <> successors nsSnap) $ nsSnap -- TODO: handle handover of key data let leaveResponse = Response { responseTo = requestID aRequestPart @@ -301,7 +301,7 @@ respondJoin nsSTM msgSet = do then do -- if yes, adjust own predecessors/ successors and return those in a response let - newPreds = take (kNeighbours nsSnap) . nub . sortBy (flip localCompare) $ getNid senderNS:predecessors nsSnap + newPreds = getNid senderNS:predecessors nsSnap joinedNS = setPredecessors newPreds nsSnap responsePayload = JoinResponsePayload { joinSuccessors = successors joinedNS diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 1f28aea..d5ea900 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -32,6 +32,7 @@ module Hash2Pub.FediChordTypes ( ) where import Control.Exception +import Data.List (delete, nub, sortBy) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, isJust, mapMaybe) import qualified Data.Set as Set @@ -213,11 +214,11 @@ instance Typeable a => Show (TQueue a) where -- | convenience function that updates the successors of a 'LocalNodeState' setSuccessors :: [NodeID] -> LocalNodeState -> LocalNodeState -setSuccessors succ' ns = ns {successors = succ'} +setSuccessors succ' ns = ns {successors = take (kNeighbours ns) . nub . sortBy localCompare $ succ'} -- | convenience function that updates the predecessors of a 'LocalNodeState' setPredecessors :: [NodeID] -> LocalNodeState -> LocalNodeState -setPredecessors pred' ns = ns {predecessors = pred'} +setPredecessors pred' ns = ns {predecessors = take (kNeighbours ns) . nub . sortBy (flip localCompare) $ pred'} type NodeCache = Map.Map NodeID CacheEntry From 6699237243744f070d1670457f3a696d4a001f8b Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 8 Jun 2020 00:36:48 +0200 Subject: [PATCH 40/88] respond to and handle QueryID requests closes #28 --- src/Hash2Pub/DHTProtocol.hs | 48 +++++++++++++++++++++++++++++++------ 1 file changed, 41 insertions(+), 7 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index b70550f..89a429b 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -40,8 +40,8 @@ import Data.IP (IPv6, fromHostAddress6, toHostAddress6) import Data.List (delete, nub, sortBy) import qualified Data.Map as Map -import Data.Maybe (fromJust, fromMaybe, mapMaybe, - maybe) +import Data.Maybe (fromJust, fromMaybe, isJust, + isNothing, mapMaybe, maybe) import qualified Data.Set as Set import Data.Time.Clock.POSIX import Network.Socket hiding (recv, recvFrom, send, @@ -192,11 +192,10 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do =<< (case action aPart of Ping -> Just <$> respondPing nsSTM msgSet Join -> Just <$> respondJoin nsSTM msgSet --- -- ToDo: figure out what happens if not joined --- QueryID -> Just <$> respondQueryID nsSTM msgSet --- -- only when joined --- Leave -> if isJoined_ ns then Just <$> respondLeave nsSTM msgSet else pure Nothing --- -- only when joined + -- ToDo: figure out what happens if not joined + QueryID -> Just <$> respondQueryID nsSTM msgSet + -- only when joined + Leave -> if isJoined_ ns then Just <$> respondLeave nsSTM msgSet else pure Nothing Stabilise -> if isJoined_ ns then Just <$> respondStabilise nsSTM msgSet else pure Nothing ) -- for single part request, response starts with part number 1. For multipart requests, response starts with part number n+1. @@ -209,6 +208,41 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do -- TODO: could all these respond* functions be in STM instead of IO? + +-- | execute a key ID lookup on local cache and respond with the result +respondQueryID :: LocalNodeStateSTM -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString) +respondQueryID nsSTM msgSet = do + -- this message cannot be split reasonably, so just + -- consider the first payload + let + aRequestPart = Set.elemAt 0 msgSet + senderID = getNid . sender $ aRequestPart + senderPayload = foldr' (\msg plAcc -> + if isNothing plAcc && isJust (payload msg) + then payload msg + else plAcc + ) Nothing msgSet + -- return only empty message serialisation if no payload was included in parts + maybe (pure Map.empty) (\senderPayload' -> do + responseMsg <- atomically $ do + nsSnap <- readTVar nsSTM + cache <- readTVar $ nodeCacheSTM nsSnap + let + responsePayload = QueryIDResponsePayload { + queryResult = queryLocalCache nsSnap cache (fromIntegral $ queryLBestNodes senderPayload') (queryTargetID senderPayload') + } + queryResponseMsg = Response { + responseTo = requestID aRequestPart + , senderID = getNid nsSnap + , part = if Set.size msgSet == 1 then 1 else fromIntegral $ Set.size msgSet + 1 + , isFinalPart = False + , action = QueryID + , payload = Just responsePayload + } + pure queryResponseMsg + pure $ serialiseMessage sendMessageSize responseMsg + ) senderPayload + -- | Respond to a Leave request by removing the leaving node from local data structures -- and confirming with response. -- TODO: copy over key data from leaver and confirm From 2c827ea326ca1abd504c08d5a2f1a67ef4f1eddd Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 8 Jun 2020 20:31:18 +0200 Subject: [PATCH 41/88] rename responseTo -> requestID to avoid partial record accessors --- FediChord.asn1 | 3 ++- src/Hash2Pub/ASN1Coding.hs | 8 ++++---- src/Hash2Pub/DHTProtocol.hs | 15 ++++++++------- src/Hash2Pub/ProtocolTypes.hs | 8 ++++++-- test/FediChordSpec.hs | 2 +- 5 files changed, 21 insertions(+), 15 deletions(-) diff --git a/FediChord.asn1 b/FediChord.asn1 index a907bb1..41f9650 100644 --- a/FediChord.asn1 +++ b/FediChord.asn1 @@ -27,7 +27,8 @@ Request ::= SEQUENCE { -- request and response instead of explicit flag Response ::= SEQUENCE { - responseTo INTEGER (0..4294967295), -- arbitrarily restricting to an unsigned 32bit integer + -- requestID of the request responding to + requestID INTEGER (0..4294967295), -- arbitrarily restricting to an unsigned 32bit integer senderID NodeID, part Partnum, finalPart BOOLEAN, -- flag indicating this `part` to be the last of this response diff --git a/src/Hash2Pub/ASN1Coding.hs b/src/Hash2Pub/ASN1Coding.hs index 25e435b..d476809 100644 --- a/src/Hash2Pub/ASN1Coding.hs +++ b/src/Hash2Pub/ASN1Coding.hs @@ -226,9 +226,9 @@ encodeMessage <> maybe [] encodePayload requestPayload <> [End Sequence] encodeMessage - (Response responseTo senderID part isFinalPart action responsePayload) = [ + (Response requestID senderID part isFinalPart action responsePayload) = [ Start Sequence - , IntVal responseTo + , IntVal requestID , IntVal . getNodeID $ senderID , IntVal part , Boolean isFinalPart @@ -277,7 +277,7 @@ parseRequest action = do pure $ Request requestID sender part isFinalPart action payload parseResponse :: Integer -> ParseASN1 FediChordMessage -parseResponse responseTo = do +parseResponse requestID = do senderID <- fromInteger <$> parseInteger :: ParseASN1 NodeID part <- parseInteger isFinalPart <- parseBool @@ -290,7 +290,7 @@ parseResponse responseTo = do Stabilise -> parseStabiliseResponse Ping -> parsePingResponse - pure $ Response responseTo senderID part isFinalPart action payload + pure $ Response requestID senderID part isFinalPart action payload parseBool :: ParseASN1 Bool parseBool = do diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 89a429b..626cd2b 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -161,13 +161,14 @@ sendMessageSize = 1200 -- encode the response to a request that just signals successful receipt ackRequest :: NodeID -> FediChordMessage -> Map.Map Integer BS.ByteString ackRequest ownID req@Request{} = serialiseMessage sendMessageSize $ Response { - responseTo = requestID req + requestID = requestID req , senderID = ownID , part = part req , isFinalPart = False , action = action req , payload = Nothing } +ackRequest _ _ = Map.empty -- | Dispatch incoming requests to the dedicated handling and response function, and enqueue @@ -232,7 +233,7 @@ respondQueryID nsSTM msgSet = do queryResult = queryLocalCache nsSnap cache (fromIntegral $ queryLBestNodes senderPayload') (queryTargetID senderPayload') } queryResponseMsg = Response { - responseTo = requestID aRequestPart + requestID = requestID aRequestPart , senderID = getNid nsSnap , part = if Set.size msgSet == 1 then 1 else fromIntegral $ Set.size msgSet + 1 , isFinalPart = False @@ -266,7 +267,7 @@ respondLeave nsSTM msgSet = do . setSuccessors (delete senderID $ requestSuccs <> successors nsSnap) $ nsSnap -- TODO: handle handover of key data let leaveResponse = Response { - responseTo = requestID aRequestPart + requestID = requestID aRequestPart , senderID = getNid nsSnap , part = if Set.size msgSet == 1 then 1 else fromIntegral $ Set.size msgSet + 1 , isFinalPart = False @@ -287,7 +288,7 @@ respondStabilise nsSTM msgSet = do , stabilisePredecessors = predecessors nsSnap } stabiliseResponse = Response { - responseTo = requestID aRequestPart + requestID = requestID aRequestPart , senderID = getNid nsSnap , part = if Set.size msgSet == 1 then 1 else fromIntegral $ Set.size msgSet + 1 , isFinalPart = False @@ -307,7 +308,7 @@ respondPing nsSTM msgSet = do aRequestPart = Set.elemAt 0 msgSet responsePayload = PingResponsePayload { pingNodeStates = [ toRemoteNodeState nsSnap ] } pingResponse = Response { - responseTo = requestID aRequestPart + requestID = requestID aRequestPart , senderID = getNid nsSnap , part = if Set.size msgSet == 1 then 1 else fromIntegral $ Set.size msgSet + 1 , isFinalPart = False @@ -343,7 +344,7 @@ respondJoin nsSTM msgSet = do , joinCache = toRemoteCache cache } joinResponse = Response { - responseTo = requestID aRequestPart + requestID = requestID aRequestPart , senderID = getNid joinedNS , part = if Set.size msgSet == 1 then 1 else fromIntegral $ Set.size msgSet + 1 , isFinalPart = False @@ -354,7 +355,7 @@ respondJoin nsSTM msgSet = do pure joinResponse -- otherwise respond with empty payload else pure Response { - responseTo = requestID aRequestPart + requestID = requestID aRequestPart , senderID = getNid nsSnap , part = if Set.size msgSet == 1 then 1 else fromIntegral $ Set.size msgSet + 1 , isFinalPart = False diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index c6348b3..d56a257 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -30,7 +30,7 @@ data FediChordMessage = Request , payload :: Maybe ActionPayload } | Response - { responseTo :: Integer + { requestID :: Integer , senderID :: NodeID , part :: Integer , isFinalPart :: Bool @@ -40,8 +40,12 @@ data FediChordMessage = Request deriving (Show, Eq) instance Ord FediChordMessage where - compare a b | requestID a == requestID b = part a `compare` part b + compare a@Request{} b@Request{} | requestID a == requestID b = part a `compare` part b | otherwise = requestID a `compare` requestID b + compare a@Response{} b@Response{} | requestID a == requestID b = part a `compare` part b + | otherwise = requestID a `compare` requestID b + -- comparing different constructor types always yields "not equal" + compare _ _ = LT data ActionPayload = QueryIDRequestPayload { queryTargetID :: NodeID diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index b6f08ad..146afcd 100644 --- a/test/FediChordSpec.hs +++ b/test/FediChordSpec.hs @@ -201,7 +201,7 @@ spec = do , payload = undefined } responseTemplate = Response { - responseTo = 2342 + requestID = 2342 , senderID = nid exampleNodeState , part = 1 , isFinalPart = True From 4e359775ec3d42e43e7640cc8bd8de3305590559 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 8 Jun 2020 20:31:22 +0200 Subject: [PATCH 42/88] add some debug output prints --- src/Hash2Pub/DHTProtocol.hs | 6 +++++- src/Hash2Pub/FediChord.hs | 2 ++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 626cd2b..64e4602 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -213,6 +213,7 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do -- | execute a key ID lookup on local cache and respond with the result respondQueryID :: LocalNodeStateSTM -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString) respondQueryID nsSTM msgSet = do + putStrLn "responding to a QueryID request" -- this message cannot be split reasonably, so just -- consider the first payload let @@ -487,7 +488,10 @@ sendRequestTo :: Int -- ^ timeout in seconds sendRequestTo timeoutMillis numAttempts msgIncomplete sock = do -- give the message a random request ID randomID <- randomRIO (0, 2^32-1) - let requests = serialiseMessage sendMessageSize $ msgIncomplete randomID + let + msgComplete = msgIncomplete randomID + requests = serialiseMessage sendMessageSize msgComplete + putStrLn $ "sending request message " <> show msgComplete -- create a queue for passing received response messages back, even after a timeout responseQ <- newTBQueueIO $ 2*maximumParts -- keep room for duplicate packets -- start sendAndAck with timeout diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 795772b..f66cafc 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -128,6 +128,7 @@ fediChordBootstrapJoin :: LocalNodeStateSTM -- ^ the local 'NodeSta fediChordBootstrapJoin nsSTM (joinHost, joinPort) = -- can be invoked multiple times with all known bootstrapping nodes until successfully joined bracket (mkSendSocket joinHost joinPort) close (\sock -> do + putStrLn "BootstrapJoin" -- 1. get routed to placement of own ID until FOUND: -- Initialise an empty cache only with the responses from a bootstrapping node ns <- readTVarIO nsSTM @@ -145,6 +146,7 @@ fediChordBootstrapJoin nsSTM (joinHost, joinPort) = Just (FORWARD resultset) -> foldr' (addCacheEntryPure now) cacheAcc resultset ) initCache bootstrapResponse + putStrLn "initialised bootstrap cache" fediChordJoin bootstrapCache nsSTM ) `catch` (\e -> pure . Left $ "Error at bootstrap joining: " <> displayException (e :: IOException)) From 67cba1b69bfb53b27f45f3b3e5ffd34cd4f87db0 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 8 Jun 2020 23:18:12 +0200 Subject: [PATCH 43/88] fixup! rename responseTo -> requestID to avoid partial record accessors --- src/Hash2Pub/ProtocolTypes.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index d56a257..25cf2d4 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -30,7 +30,7 @@ data FediChordMessage = Request , payload :: Maybe ActionPayload } | Response - { requestID :: Integer + { requestID :: Integer , senderID :: NodeID , part :: Integer , isFinalPart :: Bool From f15d83baffe2870d432553c625b42a890d17cbce Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 9 Jun 2020 15:21:22 +0200 Subject: [PATCH 44/88] Refactor predecessors and successors to hold RemoteNodeStates - neighbour nodes need to be contacted reliably - Only holding NodeIDs requires a cache lookup for getting hostname and port. This is brittle as the entry could've been purged from cache. - refactored ASN.1 scheme, types and add/ sort/ remove implementations closes #46 --- FediChord.asn1 | 12 ++++++------ src/Hash2Pub/ASN1Coding.hs | 24 ++++++++++++------------ src/Hash2Pub/DHTProtocol.hs | 34 +++++++++++++++++----------------- src/Hash2Pub/FediChordTypes.hs | 16 ++++++++++------ src/Hash2Pub/ProtocolTypes.hs | 12 ++++++------ test/FediChordSpec.hs | 20 ++++++++++---------- 6 files changed, 61 insertions(+), 57 deletions(-) diff --git a/FediChord.asn1 b/FediChord.asn1 index 41f9650..f278f8f 100644 --- a/FediChord.asn1 +++ b/FediChord.asn1 @@ -62,8 +62,8 @@ NodeCache ::= SEQUENCE OF CacheEntry JoinRequestPayload ::= NULL JoinResponsePayload ::= SEQUENCE { - successors SEQUENCE OF NodeID, - predecessors SEQUENCE OF NodeID, + successors SEQUENCE OF NodeState, + predecessors SEQUENCE OF NodeState, cache NodeCache } @@ -82,14 +82,14 @@ QueryIDResponsePayload ::= SEQUENCE { StabiliseRequestPayload ::= NULL StabiliseResponsePayload ::= SEQUENCE { - successors SEQUENCE OF NodeID, - predecessors SEQUENCE OF NodeID + successors SEQUENCE OF NodeState, + predecessors SEQUENCE OF NodeState -- ToDo: transfer of handled key data, if newly responsible for it } LeaveRequestPayload ::= SEQUENCE { - successors SEQUENCE OF NodeID, - predecessors SEQUENCE OF NodeID + successors SEQUENCE OF NodeState, + predecessors SEQUENCE OF NodeState -- ToDo: transfer of own data to newly responsible node } diff --git a/src/Hash2Pub/ASN1Coding.hs b/src/Hash2Pub/ASN1Coding.hs index d476809..456dac6 100644 --- a/src/Hash2Pub/ASN1Coding.hs +++ b/src/Hash2Pub/ASN1Coding.hs @@ -130,20 +130,20 @@ encodePayload LeaveResponsePayload = [Null] encodePayload payload'@LeaveRequestPayload{} = Start Sequence : Start Sequence - : fmap (IntVal . getNodeID) (leaveSuccessors payload') + : concatMap encodeNodeState (leaveSuccessors payload') <> [End Sequence , Start Sequence] - <> fmap (IntVal . getNodeID) (leavePredecessors payload') + <> concatMap encodeNodeState (leavePredecessors payload') <> [End Sequence , End Sequence] -- currently StabiliseResponsePayload and LeaveRequestPayload are equal encodePayload payload'@StabiliseResponsePayload{} = Start Sequence : Start Sequence - : fmap (IntVal . getNodeID) (stabiliseSuccessors payload') + : concatMap encodeNodeState (stabiliseSuccessors payload') <> [End Sequence , Start Sequence] - <> fmap (IntVal . getNodeID) (stabilisePredecessors payload') + <> concatMap encodeNodeState (stabilisePredecessors payload') <> [End Sequence , End Sequence] encodePayload payload'@StabiliseRequestPayload = [Null] @@ -170,10 +170,10 @@ encodePayload payload'@QueryIDRequestPayload{} = [ encodePayload payload'@JoinResponsePayload{} = Start Sequence : Start Sequence - : fmap (IntVal . getNodeID) (joinSuccessors payload') + : concatMap encodeNodeState (joinSuccessors payload') <> [End Sequence , Start Sequence] - <> fmap (IntVal . getNodeID) (joinPredecessors payload') + <> concatMap encodeNodeState (joinPredecessors payload') <> [End Sequence , Start Sequence] <> concatMap encodeCacheEntry (joinCache payload') @@ -368,8 +368,8 @@ parseJoinRequest = do parseJoinResponse :: ParseASN1 ActionPayload parseJoinResponse = onNextContainer Sequence $ do - succ' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger) - pred' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger) + succ' <- onNextContainer Sequence (getMany parseNodeState) + pred' <- onNextContainer Sequence (getMany parseNodeState) cache <- parseNodeCache pure $ JoinResponsePayload { joinSuccessors = succ' @@ -404,8 +404,8 @@ parseStabiliseRequest = do parseStabiliseResponse :: ParseASN1 ActionPayload parseStabiliseResponse = onNextContainer Sequence $ do - succ' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger) - pred' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger) + succ' <- onNextContainer Sequence (getMany parseNodeState) + pred' <- onNextContainer Sequence (getMany parseNodeState) pure $ StabiliseResponsePayload { stabiliseSuccessors = succ' , stabilisePredecessors = pred' @@ -413,8 +413,8 @@ parseStabiliseResponse = onNextContainer Sequence $ do parseLeaveRequest :: ParseASN1 ActionPayload parseLeaveRequest = onNextContainer Sequence $ do - succ' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger) - pred' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger) + succ' <- onNextContainer Sequence (getMany parseNodeState) + pred' <- onNextContainer Sequence (getMany parseNodeState) pure $ LeaveRequestPayload { leaveSuccessors = succ' , leavePredecessors = pred' diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 64e4602..f1eda71 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -73,7 +73,7 @@ import Debug.Trace (trace) queryLocalCache :: LocalNodeState -> NodeCache -> Int -> NodeID -> QueryResponse queryLocalCache ownState nCache lBestNodes targetID -- as target ID falls between own ID and first predecessor, it is handled by this node - | (targetID `localCompare` ownID) `elem` [LT, EQ] && maybe False (\p -> targetID `localCompare` p == GT) (headMay preds) = FOUND . toRemoteNodeState $ ownState + | (targetID `localCompare` ownID) `elem` [LT, EQ] && maybe False (\p -> targetID `localCompare` p == GT) (getNid <$> headMay preds) = FOUND . toRemoteNodeState $ ownState -- my interpretation: the "l best next hops" are the l-1 closest preceding nodes and -- the closest succeeding node (like with the p initiated parallel queries | otherwise = FORWARD $ closestSuccessor `Set.union` closestPredecessors @@ -264,8 +264,8 @@ respondLeave nsSTM msgSet = do writeTQueue (cacheWriteQueue nsSnap) $ deleteCacheEntry senderID writeTVar nsSTM $ -- add predecessors and successors of leaving node to own lists - setPredecessors (delete senderID $ requestPreds <> predecessors nsSnap) - . setSuccessors (delete senderID $ requestSuccs <> successors nsSnap) $ nsSnap + setPredecessors (filter ((/=) senderID . getNid) $ requestPreds <> predecessors nsSnap) + . setSuccessors (filter ((/=) senderID . getNid) $ requestSuccs <> successors nsSnap) $ nsSnap -- TODO: handle handover of key data let leaveResponse = Response { requestID = requestID aRequestPart @@ -337,7 +337,7 @@ respondJoin nsSTM msgSet = do then do -- if yes, adjust own predecessors/ successors and return those in a response let - newPreds = getNid senderNS:predecessors nsSnap + newPreds = senderNS:predecessors nsSnap joinedNS = setPredecessors newPreds nsSnap responsePayload = JoinResponsePayload { joinSuccessors = successors joinedNS @@ -381,28 +381,28 @@ requestJoin toJoinOn ownStateSTM = (cacheInsertQ, joinedState) <- atomically $ do stateSnap <- readTVar ownStateSTM let - (cacheInsertQ, joinedStateUnsorted) = foldl' - (\(insertQ, nsAcc) msg -> + (cacheInsertQ, predAccSet, succAccSet) = foldl' + (\(insertQ, predAccSet', succAccSet') msg -> let insertQ' = maybe insertQ (\msgPl -> -- collect list of insertion statements into global cache queueAddEntries (joinCache msgPl) : insertQ ) $ payload msg - -- add received predecessors and successors - addPreds ns' = maybe ns' (\msgPl -> - setPredecessors (foldr' (:) (predecessors ns') (joinPredecessors msgPl)) ns' - ) $ payload msg - addSuccs ns' = maybe ns' (\msgPl -> - setSuccessors (foldr' (:) (successors ns') (joinSuccessors msgPl)) ns' - ) $ payload msg + -- collect received predecessors and successors + predAccSet'' = maybe predAccSet' ( + foldr' Set.insert predAccSet' . joinPredecessors + ) $ payload msg + succAccSet'' = maybe succAccSet' ( + foldr' Set.insert succAccSet' . joinSuccessors + ) $ payload msg in - (insertQ', addSuccs . addPreds $ nsAcc) + (insertQ', predAccSet'', succAccSet'') ) -- reset predecessors and successors - ([], setPredecessors [] . setSuccessors [] $ ownState) + ([], Set.empty, Set.empty) responses - -- sort successors and predecessors - newState = setSuccessors (take (kNeighbours joinedStateUnsorted) . sortBy localCompare $ successors joinedStateUnsorted) . setPredecessors (take (kNeighbours joinedStateUnsorted) . sortBy (flip localCompare) $ predecessors joinedStateUnsorted) $ joinedStateUnsorted + -- sort, slice and set the accumulated successors and predecessors + newState = setSuccessors (Set.elems succAccSet) . setPredecessors (Set.elems predAccSet) $ stateSnap writeTVar ownStateSTM newState pure (cacheInsertQ, newState) -- execute the cache insertions diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index d5ea900..410cbe9 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -32,6 +32,7 @@ module Hash2Pub.FediChordTypes ( ) where import Control.Exception +import Data.Function (on) import Data.List (delete, nub, sortBy) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, isJust, mapMaybe) @@ -123,6 +124,9 @@ data RemoteNodeState = RemoteNodeState } deriving (Show, Eq) +instance Ord RemoteNodeState where + a `compare` b = nid a `compare` nid b + -- | represents a node and encapsulates all data and parameters that are not present for remote nodes data LocalNodeState = LocalNodeState { nodeState :: RemoteNodeState @@ -131,9 +135,9 @@ data LocalNodeState = LocalNodeState -- ^ EpiChord node cache with expiry times for nodes , cacheWriteQueue :: TQueue (NodeCache -> NodeCache) -- ^ cache updates are not written directly to the 'nodeCache' but queued and - , successors :: [NodeID] -- could be a set instead as these are ordered as well + , successors :: [RemoteNodeState] -- could be a set instead as these are ordered as well -- ^ successor nodes in ascending order by distance - , predecessors :: [NodeID] + , predecessors :: [RemoteNodeState] -- ^ predecessor nodes in ascending order by distance , kNeighbours :: Int -- ^ desired length of predecessor and successor list @@ -213,12 +217,12 @@ instance Typeable a => Show (TQueue a) where show x = show (typeOf x) -- | convenience function that updates the successors of a 'LocalNodeState' -setSuccessors :: [NodeID] -> LocalNodeState -> LocalNodeState -setSuccessors succ' ns = ns {successors = take (kNeighbours ns) . nub . sortBy localCompare $ succ'} +setSuccessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState +setSuccessors succ' ns = ns {successors = take (kNeighbours ns) . nub . sortBy (localCompare `on` getNid) $ succ'} -- | convenience function that updates the predecessors of a 'LocalNodeState' -setPredecessors :: [NodeID] -> LocalNodeState -> LocalNodeState -setPredecessors pred' ns = ns {predecessors = take (kNeighbours ns) . nub . sortBy (flip localCompare) $ pred'} +setPredecessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState +setPredecessors pred' ns = ns {predecessors = take (kNeighbours ns) . nub . sortBy (flip (localCompare `on` getNid)) $ pred'} type NodeCache = Map.Map NodeID CacheEntry diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index 25cf2d4..afb72d2 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -53,8 +53,8 @@ data ActionPayload = QueryIDRequestPayload } | JoinRequestPayload | LeaveRequestPayload - { leaveSuccessors :: [NodeID] - , leavePredecessors :: [NodeID] + { leaveSuccessors :: [RemoteNodeState] + , leavePredecessors :: [RemoteNodeState] } | StabiliseRequestPayload | PingRequestPayload @@ -62,14 +62,14 @@ data ActionPayload = QueryIDRequestPayload { queryResult :: QueryResponse } | JoinResponsePayload - { joinSuccessors :: [NodeID] - , joinPredecessors :: [NodeID] + { joinSuccessors :: [RemoteNodeState] + , joinPredecessors :: [RemoteNodeState] , joinCache :: [RemoteCacheEntry] } | LeaveResponsePayload | StabiliseResponsePayload - { stabiliseSuccessors :: [NodeID] - , stabilisePredecessors :: [NodeID] + { stabiliseSuccessors :: [RemoteNodeState] + , stabilisePredecessors :: [RemoteNodeState] } | PingResponsePayload { pingNodeStates :: [RemoteNodeState] diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index 146afcd..b289c33 100644 --- a/test/FediChordSpec.hs +++ b/test/FediChordSpec.hs @@ -119,7 +119,7 @@ spec = do let emptyCache = initCache nid1 = toNodeID 2^(23::Integer)+1 - node1 = setPredecessors [nid4] . setNid nid1 <$> exampleLocalNode + node1 = setPredecessors [node4] . setNid nid1 <$> exampleLocalNode nid2 = toNodeID 2^(230::Integer)+12 node2 = exampleNodeState { nid = nid2} nid3 = toNodeID 2^(25::Integer)+10 @@ -152,15 +152,15 @@ spec = do describe "Messages can be encoded to and decoded from ASN.1" $ do -- define test messages let - someNodeIDs = fmap fromInteger [3..12] + someNodes = fmap (flip setNid exampleNodeState . fromInteger) [3..12] qidReqPayload = QueryIDRequestPayload { queryTargetID = nid exampleNodeState , queryLBestNodes = 3 } jReqPayload = JoinRequestPayload lReqPayload = LeaveRequestPayload { - leaveSuccessors = someNodeIDs - , leavePredecessors = someNodeIDs + leaveSuccessors = someNodes + , leavePredecessors = someNodes } stabReqPayload = StabiliseRequestPayload pingReqPayload = PingRequestPayload @@ -174,8 +174,8 @@ spec = do ] } jResPayload = JoinResponsePayload { - joinSuccessors = someNodeIDs - , joinPredecessors = someNodeIDs + joinSuccessors = someNodes + , joinPredecessors = someNodes , joinCache = [ RemoteCacheEntry exampleNodeState (toEnum 23420001) , RemoteCacheEntry (exampleNodeState {nid = fromInteger (-5)}) (toEnum 0) @@ -183,7 +183,7 @@ spec = do } lResPayload = LeaveResponsePayload stabResPayload = StabiliseResponsePayload { - stabiliseSuccessors = someNodeIDs + stabiliseSuccessors = someNodes , stabilisePredecessors = [] } pingResPayload = PingResponsePayload { @@ -213,8 +213,8 @@ spec = do encodeDecodeAndCheck msg = runParseASN1 parseMessage (encodeMessage msg) `shouldBe` pure msg largeMessage = responseWith Join $ JoinResponsePayload { - joinSuccessors = fromInteger <$> [-20..150] - , joinPredecessors = fromInteger <$> [5..11] + joinSuccessors = flip setNid exampleNodeState . fromInteger <$> [-20..150] + , joinPredecessors = flip setNid exampleNodeState . fromInteger <$> [5..11] , joinCache = [ RemoteCacheEntry (exampleNodeState {nid = node}) 290001 | node <- [50602,506011..60000]] } @@ -235,7 +235,7 @@ spec = do it "messages too large for a single packet can (often) be split into multiple parts" $ do -- TODO: once splitting works more efficient, test for exact number or payload, see #18 length (serialiseMessage 600 largeMessage) > 1 `shouldBe` True - length (serialiseMessage 6000 largeMessage) `shouldBe` 1 + length (serialiseMessage 60000 largeMessage) `shouldBe` 1 it "message part numbering starts at the submitted part number" $ do isJust (Map.lookup 1 (serialiseMessage 600 largeMessage)) `shouldBe` True let startAt5 = serialiseMessage 600 (largeMessage {part = 5}) From 2c98d8507da7d53a76ba7adaa782c8a7a58f5a49 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 9 Jun 2020 22:11:38 +0200 Subject: [PATCH 45/88] implement stabilise request sending and parsing contributes to #44 --- src/Hash2Pub/DHTProtocol.hs | 52 +++++++++++++++++++++++++++++++------ 1 file changed, 44 insertions(+), 8 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index f1eda71..73e564f 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -251,9 +251,9 @@ respondQueryID nsSTM msgSet = do respondLeave :: LocalNodeStateSTM -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString) respondLeave nsSTM msgSet = do -- combine payload of all parts - let (requestSuccs, requestPreds) = foldr' (\msg (succAcc, predAcc) -> - (maybe succAcc (++ succAcc) (leaveSuccessors <$> payload msg) - ,maybe predAcc (++ predAcc) (leavePredecessors <$> payload msg)) + let (requestPreds, requestSuccs) = foldr' (\msg (predAcc, succAcc) -> + (maybe predAcc (++ predAcc) (leavePredecessors <$> payload msg) + ,maybe succAcc (++ succAcc) (leaveSuccessors <$> payload msg)) ) ([],[]) msgSet aRequestPart = Set.elemAt 0 msgSet @@ -407,13 +407,13 @@ requestJoin toJoinOn ownStateSTM = pure (cacheInsertQ, newState) -- execute the cache insertions mapM_ (\f -> f joinedState) cacheInsertQ - if responses == Set.empty - then pure . Left $ "join error: got no response from " <> show (getNid toJoinOn) + pure $ if responses == Set.empty + then Left $ "join error: got no response from " <> show (getNid toJoinOn) else if null (predecessors joinedState) && null (successors joinedState) - then pure $ Left "join error: no predecessors or successors" + then Left "join error: no predecessors or successors" -- successful join - else pure $ Right ownStateSTM - ) + else Right ownStateSTM + ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) @@ -478,6 +478,42 @@ sendQueryIdMessage targetID ns = sendRequestTo 5000 3 (lookupMessage targetID ns lookupMessage targetID ns rID = Request rID (toRemoteNodeState ns) 1 True QueryID (Just $ pl ns targetID) pl ns' targetID' = QueryIDRequestPayload { queryTargetID = targetID', queryLBestNodes = fromIntegral . lNumBestNodes $ ns } + +-- | Send a stabilise request to provided 'RemoteNode' and, if successful, +-- return parsed neighbour lists +requestStabilise :: LocalNodeState -- ^ sending node + -> RemoteNodeState -- ^ neighbour node to send to + -> IO (Either String ([RemoteNodeState], [RemoteNodeState])) -- ^ (predecessors, successors) of responding node +requestStabilise ns neighbour = do + responses <- bracket (mkSendSocket (getDomain neighbour) (getDhtPort neighbour)) close (sendRequestTo 5000 3 (\rid -> + Request { + requestID = rid + , sender = toRemoteNodeState ns + , part = 1 + , isFinalPart = False + , action = Stabilise + , payload = Just StabiliseRequestPaylod + } + ) + ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) + either + -- forward IO error messages + (pure . Left) + (\respSet -> do + -- fold all reply parts together + let (responsePreds, responseSuccs) = foldr' (\msg (predAcc, succAcc) -> + (maybe predAcc (++ predAcc) (stabilisePredecessors <$> payload msg) + ,maybe succAcc (++ succAcc) (stabiliseSuccessors <$> payload msg)) + ) + ([],[]) respSet + pure $ if null responsePreds && null responseSuccs + then Left "no neighbours returned" + else Right (responsePreds, responseSuccs) + ) responses + + + + -- | Generic function for sending a request over a connected socket and collecting the response. -- Serialises the message and tries to deliver its parts for a number of attempts within a specified timeout. sendRequestTo :: Int -- ^ timeout in seconds From 1204457a2adc32bf28fd00925cea5658466b20a2 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 10 Jun 2020 16:53:17 +0200 Subject: [PATCH 46/88] make sure that predecessors are smaller and successors are larger than node ID --- src/Hash2Pub/FediChordTypes.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 410cbe9..a599739 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -218,11 +218,11 @@ instance Typeable a => Show (TQueue a) where -- | convenience function that updates the successors of a 'LocalNodeState' setSuccessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState -setSuccessors succ' ns = ns {successors = take (kNeighbours ns) . nub . sortBy (localCompare `on` getNid) $ succ'} +setSuccessors succ' ns = ns {successors = take (kNeighbours ns) . nub . sortBy (localCompare `on` getNid) . filter ((== LT) . (localCompare `on` getNid) (toRemoteNodeState ns)) $ succ'} -- | convenience function that updates the predecessors of a 'LocalNodeState' setPredecessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState -setPredecessors pred' ns = ns {predecessors = take (kNeighbours ns) . nub . sortBy (flip (localCompare `on` getNid)) $ pred'} +setPredecessors pred' ns = ns {predecessors = take (kNeighbours ns) . nub . sortBy (flip localCompare `on` getNid) . filter ((== GT) . (localCompare `on` getNid) (toRemoteNodeState ns)) $ pred'} type NodeCache = Map.Map NodeID CacheEntry From 2739b4716277a487365e915e0a43e5dc56fcb2cf Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Fri, 12 Jun 2020 15:48:56 +0200 Subject: [PATCH 47/88] send stabilise to certain successor or predecessor --- src/Hash2Pub/DHTProtocol.hs | 7 +++-- src/Hash2Pub/FediChord.hs | 63 +++++++++++++++++++++++++++++-------- 2 files changed, 54 insertions(+), 16 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 73e564f..6469e1c 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -16,6 +16,7 @@ module Hash2Pub.DHTProtocol , sendQueryIdMessage , requestQueryID , requestJoin + , requestStabilise , queryIdLookupLoop , resolve , mkSendSocket @@ -485,14 +486,14 @@ requestStabilise :: LocalNodeState -- ^ sending node -> RemoteNodeState -- ^ neighbour node to send to -> IO (Either String ([RemoteNodeState], [RemoteNodeState])) -- ^ (predecessors, successors) of responding node requestStabilise ns neighbour = do - responses <- bracket (mkSendSocket (getDomain neighbour) (getDhtPort neighbour)) close (sendRequestTo 5000 3 (\rid -> + responses <- bracket (mkSendSocket (getDomain neighbour) (getDhtPort neighbour)) close (fmap Right . sendRequestTo 5000 3 (\rid -> Request { requestID = rid , sender = toRemoteNodeState ns , part = 1 , isFinalPart = False , action = Stabilise - , payload = Just StabiliseRequestPaylod + , payload = Just StabiliseRequestPayload } ) ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) @@ -510,7 +511,7 @@ requestStabilise ns neighbour = do then Left "no neighbours returned" else Right (responsePreds, responseSuccs) ) responses - + diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index f66cafc..6a66220 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : FediChord @@ -48,33 +49,33 @@ module Hash2Pub.FediChord ( ) where import Control.Applicative ((<|>)) -import Control.Exception -import Data.Foldable (foldr') -import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust, fromMaybe, isJust, - mapMaybe) -import qualified Data.Set as Set -import Data.Time.Clock.POSIX -import Network.Socket hiding (recv, recvFrom, send, - sendTo) -import Network.Socket.ByteString - --- for hashing and ID conversion import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM import Control.Concurrent.STM.TQueue import Control.Concurrent.STM.TVar +import Control.Exception import Control.Monad (forM_, forever) +import Control.Monad.Except import Crypto.Hash import qualified Data.ByteArray as BA import qualified Data.ByteString as BS import qualified Data.ByteString.UTF8 as BSU +import Data.Foldable (foldr') import Data.IP (IPv6, fromHostAddress6, toHostAddress6) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust, fromMaybe, isJust, + mapMaybe) +import qualified Data.Set as Set +import Data.Time.Clock.POSIX import Data.Typeable (Typeable (..), typeOf) import Data.Word import qualified Network.ByteOrder as NetworkBytes +import Network.Socket hiding (recv, recvFrom, send, + sendTo) +import Network.Socket.ByteString +import Safe import Hash2Pub.DHTProtocol import Hash2Pub.FediChordTypes @@ -179,6 +180,43 @@ cacheWriter nsSTM = cacheModifier <- readTQueue $ cacheWriteQueue ns modifyTVar' (nodeCacheSTM ns) cacheModifier +stabiliseThread :: LocalNodeStateSTM -> IO () +stabiliseThread nsSTM = do + -- TODO: update successfully stabilised nodes in cache + -- placeholder + stabiliseNeighbour nsSTM successors setSuccessors 1 + pure () + where + stabiliseNeighbour :: LocalNodeStateSTM + -> (LocalNodeState -> [RemoteNodeState]) + -> ([RemoteNodeState] -> LocalNodeState -> LocalNodeState) + -> Int + -> IO (Either String ()) + stabiliseNeighbour nsSTM neighbourGetter neighbourSetter neighbourNum = do + nsSnap <- readTVarIO nsSTM + let chosenNode = maybe (Left "no such neighbour entry") Right $ atMay (neighbourGetter nsSnap) neighbourNum + -- returning @Left@ signifies the need to try again with next from list + runExceptT $ requestToNeighbour nsSnap chosenNode >>= parseNeighbourResponse + requestToNeighbour :: (MonadError String m, MonadIO m) + => LocalNodeState + -> Either String RemoteNodeState + -> m (Either String ([RemoteNodeState],[RemoteNodeState])) + requestToNeighbour _ (Left err) = throwError err + requestToNeighbour ns (Right n) = liftIO $ requestStabilise ns n + parseNeighbourResponse :: (MonadError String m, MonadIO m) + => Either String ([RemoteNodeState], [RemoteNodeState]) + -> m () + parseNeighbourResponse (Left err) = throwError err + parseNeighbourResponse (Right (succs, preds)) = liftIO $ do + atomically $ do + newerNsSnap <- readTVar nsSTM + writeTVar nsSTM $ setPredecessors (predecessors newerNsSnap <> preds) . setSuccessors (successors newerNsSnap <> succs) $ newerNsSnap + pure () + +-- periodically contact immediate successor and predecessor +-- If they respond, see whether there is a closer neighbour in between +-- If they don't respond, drop them and try the next one + -- | Receives UDP packets and passes them to other threads via the given TQueue. -- Shall be used as the single receiving thread on the server socket, as multiple -- threads blocking on the same socket degrades performance. @@ -233,7 +271,6 @@ requestMapPurge mapVar = forever $ do threadDelay $ fromEnum purgeAge * 2000 - -- | Wait for messages, deserialise them, manage parts and acknowledgement status, -- and pass them to their specific handling function. fediMessageHandler :: TQueue (BS.ByteString, SockAddr) -- ^ send queue From 7612f5532ac4a04be2c54d8c8b7f7559a685184c Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 13 Jun 2020 14:47:40 +0200 Subject: [PATCH 48/88] create a test for parts of #48 --- test/FediChordSpec.hs | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index b289c33..ab9f1b2 100644 --- a/test/FediChordSpec.hs +++ b/test/FediChordSpec.hs @@ -148,6 +148,27 @@ spec = do it "does not fail on nodes without neighbours (initial state)" $ do (FORWARD nodeset) <- queryLocalCache <$> exampleLocalNode <*> cacheWith4Entries <*> pure 3 <*> pure (toNodeID 11) Set.map (nid . remoteNode ) nodeset `shouldBe` Set.fromList [nid4, nid2, nid3] + describe "successors and predecessors do not disturb the ring characteristics of EpiChord operations (see #48)" $ do + let + emptyCache = initCache + -- implicitly relies on kNieghbours to be <= 3 + thisNid = toNodeID 1000 + thisNode = setNid thisNid <$> exampleLocalNode + nid2 = toNodeID 1003 + node2 = exampleNodeState { nid = nid2} + nid3 = toNodeID 1010 + node3 = exampleNodeState { nid = nid3} + nid4 = toNodeID 1020 + node4 = exampleNodeState { nid = nid4} + nid5 = toNodeID 1025 + node5 = exampleNodeState { nid = nid5} + allRemoteNodes = [node2, node3, node4, node5] + it "lookups also work for slices larger than 1/2 key space" $ do + node <- setSuccessors allRemoteNodes . setPredecessors allRemoteNodes <$> thisNode + -- do lookup on empty cache but with successors for a key > 1/2 key space + -- succeeding the node + queryLocalCache node emptyCache 1 (nid5 + 10) `shouldBe` FOUND (toRemoteNodeState node) + describe "Messages can be encoded to and decoded from ASN.1" $ do -- define test messages From b179357ab0f3de877543e6f95de101c758af56ba Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 13 Jun 2020 21:41:23 +0200 Subject: [PATCH 49/88] generalise NodeCache implementation to make it usable for neighbour nodes as well contributes to #48 --- src/Hash2Pub/FediChordTypes.hs | 112 +++++++++++++++++++++++---------- 1 file changed, 79 insertions(+), 33 deletions(-) diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index a599739..d775f9f 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -150,6 +150,7 @@ data LocalNodeState = LocalNodeState } deriving (Show, Eq) +-- | for concurrent access, LocalNodeState is wrapped in a TVar type LocalNodeStateSTM = TVar LocalNodeState -- | class for various NodeState representations, providing @@ -224,22 +225,39 @@ setSuccessors succ' ns = ns {successors = take (kNeighbours ns) . nub . sortBy ( setPredecessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState setPredecessors pred' ns = ns {predecessors = take (kNeighbours ns) . nub . sortBy (flip localCompare `on` getNid) . filter ((== GT) . (localCompare `on` getNid) (toRemoteNodeState ns)) $ pred'} -type NodeCache = Map.Map NodeID CacheEntry +-- | Class for all types that can be identified via an EpiChord key. +-- Used for restricting the types a 'RingMap' can store +class HasKeyID a where + getKeyID :: a -> NodeID + +instance HasKeyID RemoteNodeState where + getKeyID = getNid + +instance HasKeyID CacheEntry where + getKeyID (CacheEntry _ ns _) = getNid ns + +type NodeCache = RingMap CacheEntry + +-- | generic data structure for holding elements with a key and modular lookup +newtype RingMap a = RingMap { getRingMap :: HasKeyID a => Map.Map NodeID (RingEntry a) } deriving (Show, Eq) -- | An entry of the 'nodeCache' can hold 2 different kinds of data. -- Type variable @a@ should be of type class 'NodeState', but I do not want to use GADTs here. -data CacheEntry = NodeEntry Bool RemoteNodeState POSIXTime - | ProxyEntry (NodeID, ProxyDirection) (Maybe CacheEntry) +data RingEntry a = KeyEntry a + | ProxyEntry (NodeID, ProxyDirection) (Maybe (RingEntry a)) deriving (Show, Eq) --- | as a compromise, only NodeEntry components are ordered by their NodeID --- while ProxyEntry components should never be tried to be ordered. -instance Ord CacheEntry where +-- | 'RingEntry' type for usage as a node cache +data CacheEntry = CacheEntry Bool RemoteNodeState POSIXTime + +-- | as a compromise, only KeyEntry components are ordered by their NodeID +-- while ProxyEntry components should never be tried to be ordered. +instance Ord RingEntry where a `compare` b = compare (extractID a) (extractID b) where - extractID (NodeEntry _ eState _) = getNid eState - extractID (ProxyEntry _ _) = error "proxy entries should never appear outside of the NodeCache" + extractID (KeyEntry e) = getKeyID e + extractID ProxyEntry{} = error "proxy entries should never appear outside of the RingMap" data ProxyDirection = Backwards | Forwards @@ -254,32 +272,48 @@ instance Enum ProxyDirection where --- useful function for getting entries for a full cache transfer cacheEntries :: NodeCache -> [CacheEntry] -cacheEntries ncache = mapMaybe extractNodeEntries $ Map.elems ncache +cacheEntries = mapMaybe extractNodeEntries . Map.elems . getRingMap where extractNodeEntries (ProxyEntry _ possibleEntry) = possibleEntry + extractNodeEntries (KeyEntry entry) = Just entry -- | An empty @NodeCache@ needs to be initialised with 2 proxy entries, -- linking the modular name space together by connecting @minBound@ and @maxBound@ -initCache :: NodeCache -initCache = Map.fromList $ proxyEntry <$> [(maxBound, (minBound, Forwards)), (minBound, (maxBound, Backwards))] +initRMap :: HasKeyID a => RingMap a +initRMap = RingMap . Map.fromList . proxyEntry <$> [(maxBound, (minBound, Forwards)), (minBound, (maxBound, Backwards))] where proxyEntry (from,to) = (from, ProxyEntry to Nothing) --- | Maybe returns the cache entry stored at given key -cacheLookup :: NodeID -- ^lookup key - -> NodeCache -- ^lookup cache - -> Maybe CacheEntry -cacheLookup key cache = case Map.lookup key cache of +initCache :: NodeCache +initCache = initRingMap + +-- | Maybe returns the entry stored at given key +rMapLookup :: HasKeyID a + => NodeID -- ^lookup key + -> RingMap a -- ^lookup cache + -> Maybe a +rMapLookup key rmap = case Map.lookup key $ getRingMap rmap of Just (ProxyEntry _ result) -> result res -> res +cacheLookup :: NodeID -- ^lookup key + -> NodeCache -- ^lookup cache + -> Maybe CacheEntry +cacheLookup = rMapLookup + -- | a wrapper around lookup functions, making the lookup redirectable by a @ProxyEntry@ -- to simulate a modular ring -lookupWrapper :: (NodeID -> NodeCache -> Maybe (NodeID, CacheEntry)) -> (NodeID -> NodeCache -> Maybe (NodeID, CacheEntry)) -> ProxyDirection -> NodeID -> NodeCache -> Maybe CacheEntry -lookupWrapper f fRepeat direction key cache = - case f key cache of +lookupWrapper :: HasKeyID a + => (NodeID -> Map.Map NodeID a -> Maybe (NodeID, a)) + -> (NodeID -> Map.Map NodeID a -> Maybe (NodeID, a)) + -> ProxyDirection + -> NodeID + -> RingMap a + -> Maybe a +lookupWrapper f fRepeat direction key rmap = + case f key $ getRingMap rmap of -- the proxy entry found holds a - Just (_, ProxyEntry _ (Just entry@NodeEntry{})) -> Just entry + Just (_, ProxyEntry _ (Just entry@KeyEntry{})) -> Just entry -- proxy entry holds another proxy entry, this should not happen Just (_, ProxyEntry _ (Just (ProxyEntry _ _))) -> Nothing -- proxy entry without own entry is a pointer on where to continue @@ -288,38 +322,50 @@ lookupWrapper f fRepeat direction key cache = let newKey = if pointerDirection == direction then pointerID else foundKey + (fromInteger . toInteger . fromEnum $ direction) - in if cacheNotEmpty cache - then lookupWrapper fRepeat fRepeat direction newKey cache + in if rMapNotEmpty rmap + then lookupWrapper fRepeat fRepeat direction newKey rmap else Nothing -- normal entries are returned - Just (_, entry@NodeEntry{}) -> Just entry + Just (_, entry@KeyEntry{}) -> Just entry Nothing -> Nothing where - cacheNotEmpty :: NodeCache -> Bool - cacheNotEmpty cache' = (Map.size cache' > 2) -- there are more than the 2 ProxyEntries - || isJust ( cacheLookup minBound cache') -- or one of the ProxyEntries holds a node - || isJust (cacheLookup maxBound cache') + rMapNotEmpty :: RingMap a -> Bool + rMapNotEmpty rmap' = (Map.size (getRingMap rmap') > 2) -- there are more than the 2 ProxyEntries + || isJust (rMapLookup minBound rmap') -- or one of the ProxyEntries holds a node + || isJust (rMapLookup maxBound rmap') --- | find the successor node to a given key on a modular EpiChord ring cache. +-- | find the successor node to a given key on a modular EpiChord ring. -- Note: The EpiChord definition of "successor" includes the node at the key itself, -- if existing. +rMapLookupSucc :: HasKeyID a + => NodeID -- ^lookup key + -> RingMap a -- ^ring cache + -> Maybe a +rMapLookupSucc = lookupWrapper Map.lookupGE Map.lookupGE Forwards + cacheLookupSucc :: NodeID -- ^lookup key -> NodeCache -- ^ring cache -> Maybe CacheEntry -cacheLookupSucc = lookupWrapper Map.lookupGE Map.lookupGE Forwards +cacheLookupSucc = rMapLookupSucc + +-- | find the predecessor node to a given key on a modular EpiChord ring. +rMapLookupPred :: HasKeyID a + => NodeID -- ^lookup key + -> RingMap a -- ^ring cache + -> Maybe a +rMapLookupPred = lookupWrapper Map.lookupLT Map.lookupLE Backwards --- | find the predecessor node to a given key on a modular EpiChord ring cache. cacheLookupPred :: NodeID -- ^lookup key -> NodeCache -- ^ring cache -> Maybe CacheEntry -cacheLookupPred = lookupWrapper Map.lookupLT Map.lookupLE Backwards +cacheLookupPred = rMapLookupPred -- clean up cache entries: once now - entry > maxAge -- transfer difference now - entry to other node -- | return the @NodeState@ data from a cache entry without checking its validation status -cacheGetNodeStateUnvalidated :: CacheEntry -> RemoteNodeState -cacheGetNodeStateUnvalidated (NodeEntry _ nState _) = nState +cacheGetNodeStateUnvalidated :: RingEntry CacheEntry -> RemoteNodeState +cacheGetNodeStateUnvalidated (KeyEntry (CacheEntry _ nState _)) = nState cacheGetNodeStateUnvalidated (ProxyEntry _ (Just entry)) = cacheGetNodeStateUnvalidated entry cacheGetNodeStateUnvalidated _ = error "trying to pure empty node state, please report a bug" From 6a98b5c6daa2284c65acd6fb00f9e9d550afaefe Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 15 Jun 2020 13:52:52 +0200 Subject: [PATCH 50/88] fix RingMap function types --- src/Hash2Pub/FediChordTypes.hs | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index d775f9f..f887095 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} module Hash2Pub.FediChordTypes ( NodeID -- abstract, but newtype constructors cannot be hidden @@ -239,7 +240,7 @@ instance HasKeyID CacheEntry where type NodeCache = RingMap CacheEntry -- | generic data structure for holding elements with a key and modular lookup -newtype RingMap a = RingMap { getRingMap :: HasKeyID a => Map.Map NodeID (RingEntry a) } deriving (Show, Eq) +newtype RingMap a = RingMap { getRingMap :: HasKeyID a => Map.Map NodeID (RingEntry a) } -- | An entry of the 'nodeCache' can hold 2 different kinds of data. -- Type variable @a@ should be of type class 'NodeState', but I do not want to use GADTs here. @@ -253,7 +254,7 @@ data CacheEntry = CacheEntry Bool RemoteNodeState POSIXTime -- | as a compromise, only KeyEntry components are ordered by their NodeID -- while ProxyEntry components should never be tried to be ordered. -instance Ord RingEntry where +instance (HasKeyID a, Eq a) => Ord (RingEntry a) where a `compare` b = compare (extractID a) (extractID b) where extractID (KeyEntry e) = getKeyID e @@ -274,18 +275,20 @@ instance Enum ProxyDirection where cacheEntries :: NodeCache -> [CacheEntry] cacheEntries = mapMaybe extractNodeEntries . Map.elems . getRingMap where - extractNodeEntries (ProxyEntry _ possibleEntry) = possibleEntry - extractNodeEntries (KeyEntry entry) = Just entry + extractNodeEntries :: RingEntry CacheEntry -> Maybe CacheEntry + extractNodeEntries (ProxyEntry _ (Just (KeyEntry entry))) = Just entry + extractNodeEntries (KeyEntry entry) = Just entry + extractNodeEntries _ = Nothing -- | An empty @NodeCache@ needs to be initialised with 2 proxy entries, -- linking the modular name space together by connecting @minBound@ and @maxBound@ initRMap :: HasKeyID a => RingMap a -initRMap = RingMap . Map.fromList . proxyEntry <$> [(maxBound, (minBound, Forwards)), (minBound, (maxBound, Backwards))] +initRMap = RingMap . Map.fromList $ proxyEntry <$> [(maxBound, (minBound, Forwards)), (minBound, (maxBound, Backwards))] where proxyEntry (from,to) = (from, ProxyEntry to Nothing) initCache :: NodeCache -initCache = initRingMap +initCache = initRMap -- | Maybe returns the entry stored at given key rMapLookup :: HasKeyID a @@ -293,8 +296,9 @@ rMapLookup :: HasKeyID a -> RingMap a -- ^lookup cache -> Maybe a rMapLookup key rmap = case Map.lookup key $ getRingMap rmap of - Just (ProxyEntry _ result) -> result - res -> res + Just (ProxyEntry _ (Just (KeyEntry result))) -> Just result + Just (KeyEntry res) -> Just res + _ -> Nothing cacheLookup :: NodeID -- ^lookup key -> NodeCache -- ^lookup cache @@ -304,8 +308,8 @@ cacheLookup = rMapLookup -- | a wrapper around lookup functions, making the lookup redirectable by a @ProxyEntry@ -- to simulate a modular ring lookupWrapper :: HasKeyID a - => (NodeID -> Map.Map NodeID a -> Maybe (NodeID, a)) - -> (NodeID -> Map.Map NodeID a -> Maybe (NodeID, a)) + => (NodeID -> Map.Map NodeID (RingEntry a) -> Maybe (NodeID, RingEntry a)) + -> (NodeID -> Map.Map NodeID (RingEntry a) -> Maybe (NodeID, RingEntry a)) -> ProxyDirection -> NodeID -> RingMap a @@ -313,7 +317,7 @@ lookupWrapper :: HasKeyID a lookupWrapper f fRepeat direction key rmap = case f key $ getRingMap rmap of -- the proxy entry found holds a - Just (_, ProxyEntry _ (Just entry@KeyEntry{})) -> Just entry + Just (_, ProxyEntry _ (Just (KeyEntry entry))) -> Just entry -- proxy entry holds another proxy entry, this should not happen Just (_, ProxyEntry _ (Just (ProxyEntry _ _))) -> Nothing -- proxy entry without own entry is a pointer on where to continue @@ -326,10 +330,10 @@ lookupWrapper f fRepeat direction key rmap = then lookupWrapper fRepeat fRepeat direction newKey rmap else Nothing -- normal entries are returned - Just (_, entry@KeyEntry{}) -> Just entry + Just (_, (KeyEntry entry)) -> Just entry Nothing -> Nothing where - rMapNotEmpty :: RingMap a -> Bool + rMapNotEmpty :: (HasKeyID a) => RingMap a -> Bool rMapNotEmpty rmap' = (Map.size (getRingMap rmap') > 2) -- there are more than the 2 ProxyEntries || isJust (rMapLookup minBound rmap') -- or one of the ProxyEntries holds a node || isJust (rMapLookup maxBound rmap') From 061bce2b08370feff699893526ec146ecaa6f26b Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 15 Jun 2020 15:14:00 +0200 Subject: [PATCH 51/88] adjust types to refactored RingMap NodeCache --- src/Hash2Pub/DHTProtocol.hs | 23 +++++++++++++---------- src/Hash2Pub/FediChordTypes.hs | 3 +++ src/Hash2Pub/ProtocolTypes.hs | 9 +++------ 3 files changed, 19 insertions(+), 16 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 6469e1c..48f1a19 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -54,10 +54,12 @@ import System.Timeout import Hash2Pub.ASN1Coding import Hash2Pub.FediChordTypes (CacheEntry (..), + CacheEntry (..), LocalNodeState (..), LocalNodeStateSTM, NodeCache, NodeID, NodeState (..), RemoteNodeState (..), + RingEntry (..), RingMap (..), cacheGetNodeStateUnvalidated, cacheLookup, cacheLookupPred, cacheLookupSucc, localCompare, @@ -83,7 +85,7 @@ queryLocalCache ownState nCache lBestNodes targetID preds = predecessors ownState closestSuccessor :: Set.Set RemoteCacheEntry - closestSuccessor = maybe Set.empty Set.singleton $ toRemoteCacheEntry =<< cacheLookupSucc targetID nCache + closestSuccessor = maybe Set.empty (Set.singleton . toRemoteCacheEntry) $ cacheLookupSucc targetID nCache closestPredecessors :: Set.Set RemoteCacheEntry closestPredecessors = closestPredecessor (lBestNodes-1) $ getNid ownState @@ -94,10 +96,11 @@ queryLocalCache ownState nCache lBestNodes targetID | otherwise = let result = cacheLookupPred lastID nCache in - case toRemoteCacheEntry =<< result of + case toRemoteCacheEntry <$> result of Nothing -> Set.empty Just nPred@(RemoteCacheEntry ns ts) -> Set.insert nPred $ closestPredecessor (remainingLookups-1) (nid ns) + -- cache operations -- | update or insert a 'RemoteCacheEntry' into the cache, @@ -118,22 +121,22 @@ addCacheEntryPure now (RemoteCacheEntry ns ts) cache = let -- TODO: limit diffSeconds to some maximum value to prevent malicious nodes from inserting entries valid nearly until eternity timestamp' = if ts <= now then ts else now - newCache = Map.insertWith insertCombineFunction (nid ns) (NodeEntry False ns timestamp') cache - insertCombineFunction newVal@(NodeEntry newValidationState newNode newTimestamp) oldVal = + newCache = Map.insertWith insertCombineFunction (nid ns) (KeyEntry (CacheEntry False ns timestamp')) $ getRingMap cache + insertCombineFunction newVal@(KeyEntry (CacheEntry newValidationState newNode newTimestamp)) oldVal = case oldVal of ProxyEntry n _ -> ProxyEntry n (Just newVal) - NodeEntry oldValidationState _ oldTimestamp -> NodeEntry oldValidationState newNode (max oldTimestamp newTimestamp) + KeyEntry (CacheEntry oldValidationState _ oldTimestamp) -> KeyEntry (CacheEntry oldValidationState newNode (max oldTimestamp newTimestamp)) in - newCache + RingMap newCache -- | delete the node with given ID from cache deleteCacheEntry :: NodeID -- ^ID of the node to be deleted -> NodeCache -- ^cache to delete from -> NodeCache -- ^cache without the specified element -deleteCacheEntry = Map.update modifier +deleteCacheEntry nid = RingMap . Map.update modifier nid . getRingMap where modifier (ProxyEntry idPointer _) = Just (ProxyEntry idPointer Nothing) - modifier NodeEntry {} = Nothing + modifier KeyEntry {} = Nothing -- | Mark a cache entry as verified after pinging it, possibly bumping its timestamp. markCacheEntryAsVerified :: Maybe POSIXTime -- ^ the (current) timestamp to be @@ -141,9 +144,9 @@ markCacheEntryAsVerified :: Maybe POSIXTime -- ^ the (current) timestamp to -> NodeID -- ^ which node to mark -> NodeCache -- ^ current node cache -> NodeCache -- ^ new NodeCache with the updated entry -markCacheEntryAsVerified timestamp = Map.adjust adjustFunc +markCacheEntryAsVerified timestamp nid = RingMap . Map.adjust adjustFunc nid . getRingMap where - adjustFunc (NodeEntry _ ns ts) = NodeEntry True ns $ fromMaybe ts timestamp + adjustFunc (KeyEntry (CacheEntry _ ns ts)) = KeyEntry (CacheEntry True ns $ fromMaybe ts timestamp) adjustFunc (ProxyEntry _ (Just entry)) = adjustFunc entry adjustFunc entry = entry diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index f887095..c09c02b 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -16,8 +16,11 @@ module Hash2Pub.FediChordTypes ( , setPredecessors , NodeCache , CacheEntry(..) + , RingEntry(..) + , RingMap(..) , cacheGetNodeStateUnvalidated , initCache + , cacheEntries , cacheLookup , cacheLookupSucc , cacheLookupPred diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index afb72d2..15cb863 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -89,15 +89,12 @@ data RemoteCacheEntry = RemoteCacheEntry RemoteNodeState POSIXTime instance Ord RemoteCacheEntry where (RemoteCacheEntry ns1 _) `compare` (RemoteCacheEntry ns2 _) = nid ns1 `compare` nid ns2 --- | Extracts a 'RemoteCacheEntry' from the indirections of a 'CacheEntry', if it holds one -toRemoteCacheEntry :: CacheEntry -> Maybe RemoteCacheEntry -toRemoteCacheEntry (NodeEntry _ ns ts) = Just $ RemoteCacheEntry ns ts -toRemoteCacheEntry (ProxyEntry _ (Just entry@NodeEntry{})) = toRemoteCacheEntry entry -toRemoteCacheEntry _ = Nothing +toRemoteCacheEntry :: CacheEntry -> RemoteCacheEntry +toRemoteCacheEntry (CacheEntry _ ns ts) = RemoteCacheEntry ns ts -- | a list of all entries of a 'NodeCache' as 'RemoteCacheEntry', useful for cache transfers toRemoteCache :: NodeCache -> [RemoteCacheEntry] -toRemoteCache cache = mapMaybe toRemoteCacheEntry $ Map.elems cache +toRemoteCache cache = toRemoteCacheEntry <$> cacheEntries cache -- | extract the 'NodeState' from a 'RemoteCacheEntry' remoteNode :: RemoteCacheEntry -> RemoteNodeState From 22a6becf6bcac9601c0561b60d39c240bbf1c2b1 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 15 Jun 2020 16:41:03 +0200 Subject: [PATCH 52/88] fix all previously working tests --- src/Hash2Pub/FediChordTypes.hs | 23 ++++++++++++++++++----- test/FediChordSpec.hs | 15 ++++++++------- 2 files changed, 26 insertions(+), 12 deletions(-) diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index c09c02b..bd5db0e 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -18,6 +18,7 @@ module Hash2Pub.FediChordTypes ( , CacheEntry(..) , RingEntry(..) , RingMap(..) + , rMapSize , cacheGetNodeStateUnvalidated , initCache , cacheEntries @@ -39,7 +40,8 @@ import Control.Exception import Data.Function (on) import Data.List (delete, nub, sortBy) import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.Maybe (fromMaybe, isJust, isNothing, + mapMaybe) import qualified Data.Set as Set import Data.Time.Clock.POSIX import Network.Socket @@ -253,6 +255,7 @@ data RingEntry a = KeyEntry a -- | 'RingEntry' type for usage as a node cache data CacheEntry = CacheEntry Bool RemoteNodeState POSIXTime + deriving (Show, Eq) -- | as a compromise, only KeyEntry components are ordered by their NodeID @@ -308,6 +311,18 @@ cacheLookup :: NodeID -- ^lookup key -> Maybe CacheEntry cacheLookup = rMapLookup +-- | returns number of present 'KeyEntry' in a properly initialised 'RingMap' +rMapSize :: (HasKeyID a, Integral i) + => RingMap a + -> i +rMapSize rmap = fromIntegral $ Map.size innerMap - oneIfEntry minBound - oneIfEntry maxBound + where + innerMap = getRingMap rmap + oneIfEntry :: Integral i => NodeID -> i + oneIfEntry nid + | isNothing (rMapLookup nid rmap) = 1 + | otherwise = 0 + -- | a wrapper around lookup functions, making the lookup redirectable by a @ProxyEntry@ -- to simulate a modular ring lookupWrapper :: HasKeyID a @@ -371,10 +386,8 @@ cacheLookupPred = rMapLookupPred -- transfer difference now - entry to other node -- | return the @NodeState@ data from a cache entry without checking its validation status -cacheGetNodeStateUnvalidated :: RingEntry CacheEntry -> RemoteNodeState -cacheGetNodeStateUnvalidated (KeyEntry (CacheEntry _ nState _)) = nState -cacheGetNodeStateUnvalidated (ProxyEntry _ (Just entry)) = cacheGetNodeStateUnvalidated entry -cacheGetNodeStateUnvalidated _ = error "trying to pure empty node state, please report a bug" +cacheGetNodeStateUnvalidated :: CacheEntry -> RemoteNodeState +cacheGetNodeStateUnvalidated (CacheEntry _ nState _) = nState -- | converts a 'HostAddress6' IP address to a big-endian strict ByteString ipAddrAsBS :: HostAddress6 -> BS.ByteString diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index ab9f1b2..0ac0ea9 100644 --- a/test/FediChordSpec.hs +++ b/test/FediChordSpec.hs @@ -2,11 +2,11 @@ module FediChordSpec where import Control.Exception -import Data.ASN1.Parse (runParseASN1) -import qualified Data.ByteString as BS -import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust, isJust) -import qualified Data.Set as Set +import Data.ASN1.Parse (runParseASN1) +import qualified Data.ByteString as BS +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust, isJust) +import qualified Data.Set as Set import Data.Time.Clock.POSIX import Network.Socket import Test.Hspec @@ -14,6 +14,7 @@ import Test.Hspec import Hash2Pub.ASN1Coding import Hash2Pub.DHTProtocol import Hash2Pub.FediChord +import Hash2Pub.FediChordTypes spec :: Spec spec = do @@ -79,8 +80,8 @@ spec = do newCache = addCacheEntryPure 10 (RemoteCacheEntry exampleNodeState 10) (addCacheEntryPure 10 (RemoteCacheEntry anotherNode 10) emptyCache) exampleID = nid exampleNodeState it "entries can be added to a node cache and looked up again" $ do - -- the cache includes 2 additional proxy elements right from the start - Map.size newCache - Map.size emptyCache `shouldBe` 2 + rMapSize emptyCache `shouldBe` 0 + rMapSize newCache `shouldBe` 2 -- normal entry lookup nid . cacheGetNodeStateUnvalidated <$> cacheLookup anotherID newCache `shouldBe` Just anotherID nid . cacheGetNodeStateUnvalidated <$> cacheLookup (anotherID+1) newCache `shouldBe` Nothing From 6142ee61d724717e6c08b2ca47ddf8d804972caf Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 16 Jun 2020 23:15:05 +0200 Subject: [PATCH 53/88] WIP: implement adding, setting and taking RingMap entries. contributes to #48 --- src/Hash2Pub/DHTProtocol.hs | 4 +- src/Hash2Pub/FediChordTypes.hs | 104 +++++++++++++++++++++++++++++---- 2 files changed, 95 insertions(+), 13 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 48f1a19..2fe41eb 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -121,13 +121,13 @@ addCacheEntryPure now (RemoteCacheEntry ns ts) cache = let -- TODO: limit diffSeconds to some maximum value to prevent malicious nodes from inserting entries valid nearly until eternity timestamp' = if ts <= now then ts else now - newCache = Map.insertWith insertCombineFunction (nid ns) (KeyEntry (CacheEntry False ns timestamp')) $ getRingMap cache + newCache = addRMapEntryWith insertCombineFunction (KeyEntry (CacheEntry False ns timestamp')) cache insertCombineFunction newVal@(KeyEntry (CacheEntry newValidationState newNode newTimestamp)) oldVal = case oldVal of ProxyEntry n _ -> ProxyEntry n (Just newVal) KeyEntry (CacheEntry oldValidationState _ oldTimestamp) -> KeyEntry (CacheEntry oldValidationState newNode (max oldTimestamp newTimestamp)) in - RingMap newCache + newCache -- | delete the node with given ID from cache deleteCacheEntry :: NodeID -- ^ID of the node to be deleted diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index bd5db0e..ca7e3d5 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -19,6 +19,10 @@ module Hash2Pub.FediChordTypes ( , RingEntry(..) , RingMap(..) , rMapSize + , addRMapEntry + , addRMapEntryWith + , takeRMapPredecessors + , takeRMapSuccessors , cacheGetNodeStateUnvalidated , initCache , cacheEntries @@ -37,11 +41,12 @@ module Hash2Pub.FediChordTypes ( ) where import Control.Exception +import Data.Foldable (foldr') import Data.Function (on) import Data.List (delete, nub, sortBy) import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, isJust, isNothing, - mapMaybe) +import Data.Maybe (fromJust, fromMaybe, isJust, + isNothing, mapMaybe) import qualified Data.Set as Set import Data.Time.Clock.POSIX import Network.Socket @@ -141,9 +146,9 @@ data LocalNodeState = LocalNodeState -- ^ EpiChord node cache with expiry times for nodes , cacheWriteQueue :: TQueue (NodeCache -> NodeCache) -- ^ cache updates are not written directly to the 'nodeCache' but queued and - , successors :: [RemoteNodeState] -- could be a set instead as these are ordered as well + , successors :: RingMap RemoteNodeState -- could be a set instead as these are ordered as well -- ^ successor nodes in ascending order by distance - , predecessors :: [RemoteNodeState] + , predecessors :: RingMap RemoteNodeState -- ^ predecessor nodes in ascending order by distance , kNeighbours :: Int -- ^ desired length of predecessor and successor list @@ -233,7 +238,7 @@ setPredecessors pred' ns = ns {predecessors = take (kNeighbours ns) . nub . sort -- | Class for all types that can be identified via an EpiChord key. -- Used for restricting the types a 'RingMap' can store -class HasKeyID a where +class (Eq a, Show a) => HasKeyID a where getKeyID :: a -> NodeID instance HasKeyID RemoteNodeState where @@ -247,8 +252,14 @@ type NodeCache = RingMap CacheEntry -- | generic data structure for holding elements with a key and modular lookup newtype RingMap a = RingMap { getRingMap :: HasKeyID a => Map.Map NodeID (RingEntry a) } --- | An entry of the 'nodeCache' can hold 2 different kinds of data. --- Type variable @a@ should be of type class 'NodeState', but I do not want to use GADTs here. +instance Eq (RingMap a) where + a == b = getRingMap a == getRingMap b + +instance Show (RingMap a) where + show rmap = shows (getRingMap rmap) "RingMap " + +-- | entry of a 'RingMap' that holds a value and can also +-- wrap around the lookup direction at the edges of the name space. data RingEntry a = KeyEntry a | ProxyEntry (NodeID, ProxyDirection) (Maybe (RingEntry a)) deriving (Show, Eq) @@ -286,15 +297,15 @@ cacheEntries = mapMaybe extractNodeEntries . Map.elems . getRingMap extractNodeEntries (KeyEntry entry) = Just entry extractNodeEntries _ = Nothing --- | An empty @NodeCache@ needs to be initialised with 2 proxy entries, +-- | An empty 'RingMap' needs to be initialised with 2 proxy entries, -- linking the modular name space together by connecting @minBound@ and @maxBound@ -initRMap :: HasKeyID a => RingMap a -initRMap = RingMap . Map.fromList $ proxyEntry <$> [(maxBound, (minBound, Forwards)), (minBound, (maxBound, Backwards))] +emptyRMap :: HasKeyID a => RingMap a +emptyRMap = RingMap . Map.fromList $ proxyEntry <$> [(maxBound, (minBound, Forwards)), (minBound, (maxBound, Backwards))] where proxyEntry (from,to) = (from, ProxyEntry to Nothing) initCache :: NodeCache -initCache = initRMap +initCache = emptyRMap -- | Maybe returns the entry stored at given key rMapLookup :: HasKeyID a @@ -382,6 +393,77 @@ cacheLookupPred :: NodeID -- ^lookup key -> Maybe CacheEntry cacheLookupPred = rMapLookupPred +addRMapEntryWith :: HasKeyID a + => (RingEntry a -> RingEntry a -> RingEntry a) + -> a + -> RingMap a + -> RingMap a +addRMapEntryWith combineFunc entry = RingMap + . Map.insertWith combineFunc (getKeyID entry) (KeyEntry entry) + . getRingMap + +addRMapEntry :: HasKeyID a + => a + -> RingMap a + -> RingMap a +addRMapEntry = addRMapEntryWith insertCombineFunction + where + insertCombineFunction newVal oldVal = + case oldVal of + ProxyEntry n _ -> ProxyEntry n (Just newVal) + KeyEntry _ -> newVal + + +addRMapEntries :: (Foldable t, HasKeyID a) + => t a + -> RingMap a + -> RingMap a +addRMapEntries entries rmap = foldr' addRMapEntry rmap entries + +setRMapEntries :: (Foldable t, HasKeyID a) + => t a + -> RingMap a +setRMapEntries entries = addRMapEntries entries emptyRMap + +-- | takes up to i entries from a 'RingMap' by calling a getter function on a +-- *startAt* value and after that on the previously returned value. +-- Stops once i entries have been taken or an entry has been encountered twice +-- (meaning the ring has been traversed completely). +-- Forms the basis for 'takeRMapSuccessors' and 'takeRMapPredecessors'. +takeRMapEntries_ :: (HasKeyID a, Integral i) + => (NodeID -> RingMap a -> Maybe a) + -> NodeID + -> i + -> RingMap a + -> [a] +-- TODO: might be more efficient with dlists +takeRMapEntries_ getterFunc startAt num rmap = reverse $ + case getterFunc startAt rmap of + Nothing -> [] + Just anEntry -> takeEntriesUntil (getKeyID anEntry) (getKeyID anEntry) (num-1) [anEntry] + where + -- TODO: figure out correct type signature once it compiles + --takeEntriesUntil :: (HasKeyID b, Integral i) => NodeID -> NodeID -> i -> [b] -> [b] + takeEntriesUntil havingReached previousEntry remaining takeAcc + | remaining <= 0 = takeAcc + | getKeyID (fromJust $ getterFunc previousEntry rmap) == havingReached = takeAcc + | otherwise = let (Just gotEntry) = getterFunc (getKeyID previousEntry) rmap + in takeEntriesUntil (getKeyID havingReached) (getKeyID gotEntry) (remaining-1) (gotEntry:takeAcc) + +takeRMapPredecessors :: (HasKeyID a, Integral i) + => NodeID + -> i + -> RingMap a + -> [a] +takeRMapPredecessors = takeRMapEntries_ rMapLookupPred + +takeRMapSuccessors :: (HasKeyID a, Integral i) + => NodeID + -> i + -> RingMap a + -> [a] +takeRMapSuccessors = takeRMapEntries_ rMapLookupSucc + -- clean up cache entries: once now - entry > maxAge -- transfer difference now - entry to other node From 2269357ed043393a03fd053e39951729e7e5c9ce Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 17 Jun 2020 02:21:27 +0200 Subject: [PATCH 54/88] deleting RingMap entries, list conversion --- src/Hash2Pub/FediChordTypes.hs | 36 ++++++++++++++++++++++++---------- 1 file changed, 26 insertions(+), 10 deletions(-) diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index ca7e3d5..b41e3dd 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -23,6 +23,9 @@ module Hash2Pub.FediChordTypes ( , addRMapEntryWith , takeRMapPredecessors , takeRMapSuccessors + , deleteRMapEntry + , rMapFromList + , rMapToList , cacheGetNodeStateUnvalidated , initCache , cacheEntries @@ -288,14 +291,15 @@ instance Enum ProxyDirection where fromEnum Backwards = - 1 fromEnum Forwards = 1 +-- | helper function for getting the a from a RingEntry a +extractRingEntry :: HasKeyID a => RingEntry a -> Maybe a +extractRingEntry (KeyEntry entry) = Just entry +extractRingEntry (ProxyEntry _ (Just (KeyEntry entry))) = Just entry +extractRingEntry _ = Nothing + --- useful function for getting entries for a full cache transfer cacheEntries :: NodeCache -> [CacheEntry] -cacheEntries = mapMaybe extractNodeEntries . Map.elems . getRingMap - where - extractNodeEntries :: RingEntry CacheEntry -> Maybe CacheEntry - extractNodeEntries (ProxyEntry _ (Just (KeyEntry entry))) = Just entry - extractNodeEntries (KeyEntry entry) = Just entry - extractNodeEntries _ = Nothing +cacheEntries = mapMaybe extractRingEntry . Map.elems . getRingMap -- | An empty 'RingMap' needs to be initialised with 2 proxy entries, -- linking the modular name space together by connecting @minBound@ and @maxBound@ @@ -312,10 +316,7 @@ rMapLookup :: HasKeyID a => NodeID -- ^lookup key -> RingMap a -- ^lookup cache -> Maybe a -rMapLookup key rmap = case Map.lookup key $ getRingMap rmap of - Just (ProxyEntry _ (Just (KeyEntry result))) -> Just result - Just (KeyEntry res) -> Just res - _ -> Nothing +rMapLookup key rmap = extractRingEntry =<< Map.lookup key (getRingMap rmap) cacheLookup :: NodeID -- ^lookup key -> NodeCache -- ^lookup cache @@ -425,6 +426,21 @@ setRMapEntries :: (Foldable t, HasKeyID a) -> RingMap a setRMapEntries entries = addRMapEntries entries emptyRMap +deleteRMapEntry :: (HasKeyID a) + => NodeID + -> RingMap a + -> RingMap a +deleteRMapEntry nid = RingMap . Map.update modifier nid . getRingMap + where + modifier (ProxyEntry idPointer _) = Just (ProxyEntry idPointer Nothing) + modifier KeyEntry {} = Nothing + +rMapToList :: (HasKeyID a) => RingMap a -> [a] +rMapToList = mapMaybe extractRingEntry . Map.elems . getRingMap + +rMapFromList :: (HasKeyID a) => [a] -> RingMap a +rMapFromList = setRMapEntries + -- | takes up to i entries from a 'RingMap' by calling a getter function on a -- *startAt* value and after that on the previously returned value. -- Stops once i entries have been taken or an entry has been encountered twice From 7e08250f8c0775061087fff82731cb6f430ffeb4 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 17 Jun 2020 14:29:19 +0200 Subject: [PATCH 55/88] refactor setting successors and predecessors --- src/Hash2Pub/FediChordTypes.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index b41e3dd..47b2004 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -149,9 +149,9 @@ data LocalNodeState = LocalNodeState -- ^ EpiChord node cache with expiry times for nodes , cacheWriteQueue :: TQueue (NodeCache -> NodeCache) -- ^ cache updates are not written directly to the 'nodeCache' but queued and - , successors :: RingMap RemoteNodeState -- could be a set instead as these are ordered as well + , successors :: [RemoteNodeState] -- could be a set instead as these are ordered as well -- ^ successor nodes in ascending order by distance - , predecessors :: RingMap RemoteNodeState + , predecessors :: [RemoteNodeState] -- ^ predecessor nodes in ascending order by distance , kNeighbours :: Int -- ^ desired length of predecessor and successor list @@ -231,13 +231,14 @@ instance Typeable a => Show (TVar a) where instance Typeable a => Show (TQueue a) where show x = show (typeOf x) + -- | convenience function that updates the successors of a 'LocalNodeState' setSuccessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState -setSuccessors succ' ns = ns {successors = take (kNeighbours ns) . nub . sortBy (localCompare `on` getNid) . filter ((== LT) . (localCompare `on` getNid) (toRemoteNodeState ns)) $ succ'} +setSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeighbours ns) . rMapFromList $ succs} -- | convenience function that updates the predecessors of a 'LocalNodeState' setPredecessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState -setPredecessors pred' ns = ns {predecessors = take (kNeighbours ns) . nub . sortBy (flip localCompare `on` getNid) . filter ((== GT) . (localCompare `on` getNid) (toRemoteNodeState ns)) $ pred'} +setPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (kNeighbours ns) . rMapFromList $ preds} -- | Class for all types that can be identified via an EpiChord key. -- Used for restricting the types a 'RingMap' can store @@ -463,8 +464,8 @@ takeRMapEntries_ getterFunc startAt num rmap = reverse $ takeEntriesUntil havingReached previousEntry remaining takeAcc | remaining <= 0 = takeAcc | getKeyID (fromJust $ getterFunc previousEntry rmap) == havingReached = takeAcc - | otherwise = let (Just gotEntry) = getterFunc (getKeyID previousEntry) rmap - in takeEntriesUntil (getKeyID havingReached) (getKeyID gotEntry) (remaining-1) (gotEntry:takeAcc) + | otherwise = let (Just gotEntry) = getterFunc previousEntry rmap + in takeEntriesUntil havingReached (getKeyID gotEntry) (remaining-1) (gotEntry:takeAcc) takeRMapPredecessors :: (HasKeyID a, Integral i) => NodeID From fb164dea0a6e407444ff5b713c7b52ce1c266b2e Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 17 Jun 2020 14:32:26 +0200 Subject: [PATCH 56/88] fix instance declaration of RingMap --- src/Hash2Pub/FediChordTypes.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 47b2004..27d5f32 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -256,10 +256,10 @@ type NodeCache = RingMap CacheEntry -- | generic data structure for holding elements with a key and modular lookup newtype RingMap a = RingMap { getRingMap :: HasKeyID a => Map.Map NodeID (RingEntry a) } -instance Eq (RingMap a) where +instance (HasKeyID a) => Eq (RingMap a) where a == b = getRingMap a == getRingMap b -instance Show (RingMap a) where +instance (HasKeyID a) => Show (RingMap a) where show rmap = shows (getRingMap rmap) "RingMap " -- | entry of a 'RingMap' that holds a value and can also From 43e4ab184e51a4632e92860b628155ceb3b6a4f7 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 17 Jun 2020 14:53:36 +0200 Subject: [PATCH 57/88] adjust cache entry insertion to usage of RingMap #48 --- src/Hash2Pub/DHTProtocol.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 2fe41eb..3c6cd6c 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -60,6 +60,7 @@ import Hash2Pub.FediChordTypes (CacheEntry (..), NodeID, NodeState (..), RemoteNodeState (..), RingEntry (..), RingMap (..), + addRMapEntryWith, cacheGetNodeStateUnvalidated, cacheLookup, cacheLookupPred, cacheLookupSucc, localCompare, @@ -114,14 +115,14 @@ addCacheEntry entry cache = do -- | pure version of 'addCacheEntry' with current time explicitly specified as argument addCacheEntryPure :: POSIXTime -- ^ current time - -> RemoteCacheEntry -- ^ a remote cache entry received from network - -> NodeCache -- ^ node cache to insert to - -> NodeCache -- ^ new node cache with the element inserted + -> RemoteCacheEntry -- ^ a remote cache entry received from network + -> NodeCache -- ^ node cache to insert to + -> NodeCache -- ^ new node cache with the element inserted addCacheEntryPure now (RemoteCacheEntry ns ts) cache = let -- TODO: limit diffSeconds to some maximum value to prevent malicious nodes from inserting entries valid nearly until eternity timestamp' = if ts <= now then ts else now - newCache = addRMapEntryWith insertCombineFunction (KeyEntry (CacheEntry False ns timestamp')) cache + newCache = addRMapEntryWith insertCombineFunction (CacheEntry False ns timestamp') cache insertCombineFunction newVal@(KeyEntry (CacheEntry newValidationState newNode newTimestamp)) oldVal = case oldVal of ProxyEntry n _ -> ProxyEntry n (Just newVal) From f27812bcf31170edca4af31a9d5d9ce577ec5c29 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 17 Jun 2020 15:13:49 +0200 Subject: [PATCH 58/88] give up on providing type signature for takeEntriesUntil --- src/Hash2Pub/FediChordTypes.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 27d5f32..06f0fc5 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -459,8 +459,6 @@ takeRMapEntries_ getterFunc startAt num rmap = reverse $ Nothing -> [] Just anEntry -> takeEntriesUntil (getKeyID anEntry) (getKeyID anEntry) (num-1) [anEntry] where - -- TODO: figure out correct type signature once it compiles - --takeEntriesUntil :: (HasKeyID b, Integral i) => NodeID -> NodeID -> i -> [b] -> [b] takeEntriesUntil havingReached previousEntry remaining takeAcc | remaining <= 0 = takeAcc | getKeyID (fromJust $ getterFunc previousEntry rmap) == havingReached = takeAcc From da0b8626cbb9b0a92289383bb8a1b938ce4ad2d8 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Thu, 18 Jun 2020 23:06:43 +0200 Subject: [PATCH 59/88] critical bug fix: use target ID for predecessor query lookup --- src/Hash2Pub/DHTProtocol.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 3c6cd6c..3a019e7 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -89,7 +89,7 @@ queryLocalCache ownState nCache lBestNodes targetID closestSuccessor = maybe Set.empty (Set.singleton . toRemoteCacheEntry) $ cacheLookupSucc targetID nCache closestPredecessors :: Set.Set RemoteCacheEntry - closestPredecessors = closestPredecessor (lBestNodes-1) $ getNid ownState + closestPredecessors = closestPredecessor (lBestNodes-1) targetID closestPredecessor :: (Integral n, Show n) => n -> NodeID -> Set.Set RemoteCacheEntry closestPredecessor 0 _ = Set.empty closestPredecessor remainingLookups lastID From 3f42f984438bb49d97bc2d91ab34bb65ba8ba097 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Thu, 18 Jun 2020 23:08:20 +0200 Subject: [PATCH 60/88] adjust lookup to RingMap, fix #48 - change default lookup result when not joined to FOUND - fix determining own responsibility #48 - adjust tests --- src/Hash2Pub/DHTProtocol.hs | 20 +++++++++++++++++++- src/Hash2Pub/FediChordTypes.hs | 11 ++++++++++- test/FediChordSpec.hs | 34 ++++++++++++++++++---------------- 3 files changed, 47 insertions(+), 18 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 3a019e7..5daa1c8 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -60,11 +60,16 @@ import Hash2Pub.FediChordTypes (CacheEntry (..), NodeID, NodeState (..), RemoteNodeState (..), RingEntry (..), RingMap (..), + HasKeyID(..), addRMapEntryWith, + addRMapEntry, cacheGetNodeStateUnvalidated, cacheLookup, cacheLookupPred, cacheLookupSucc, localCompare, localCompare, setPredecessors, + getKeyID, rMapFromList, + rMapLookupPred, + rMapLookupSucc, setSuccessors) import Hash2Pub.ProtocolTypes @@ -77,7 +82,7 @@ import Debug.Trace (trace) queryLocalCache :: LocalNodeState -> NodeCache -> Int -> NodeID -> QueryResponse queryLocalCache ownState nCache lBestNodes targetID -- as target ID falls between own ID and first predecessor, it is handled by this node - | (targetID `localCompare` ownID) `elem` [LT, EQ] && maybe False (\p -> targetID `localCompare` p == GT) (getNid <$> headMay preds) = FOUND . toRemoteNodeState $ ownState + | isInOwnResponsibilitySlice ownState targetID = FOUND . toRemoteNodeState $ ownState -- my interpretation: the "l best next hops" are the l-1 closest preceding nodes and -- the closest succeeding node (like with the p initiated parallel queries | otherwise = FORWARD $ closestSuccessor `Set.union` closestPredecessors @@ -101,6 +106,19 @@ queryLocalCache ownState nCache lBestNodes targetID Nothing -> Set.empty Just nPred@(RemoteCacheEntry ns ts) -> Set.insert nPred $ closestPredecessor (remainingLookups-1) (nid ns) +-- | Determines whether a lookup key is within the responsibility slice of a node, +-- as it falls between its first predecessor and the node itself. +-- Looks up the successor of the lookup key on a 'RingMap' representation of the +-- predecessor list with the node itself added. If the result is the same as the node +-- itself then it falls into the responsibility interval. +isInOwnResponsibilitySlice :: HasKeyID a => LocalNodeState -> a -> Bool +isInOwnResponsibilitySlice ownNs lookupTarget = (getKeyID <$> rMapLookupSucc (getKeyID lookupTarget) predecessorRMap) == pure (getNid ownNs) + where + predecessorList = predecessors ownNs + -- add node itself to RingMap representation, to distinguish between + -- responsibility of own node and predecessor + predecessorRMap = addRMapEntry (toRemoteNodeState ownNs) $ rMapFromList predecessorList + closestPredecessor = headMay predecessorList -- cache operations diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 06f0fc5..601ca63 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -18,12 +18,18 @@ module Hash2Pub.FediChordTypes ( , CacheEntry(..) , RingEntry(..) , RingMap(..) + , HasKeyID + , getKeyID , rMapSize + , rMapLookup + , rMapLookupPred + , rMapLookupSucc , addRMapEntry , addRMapEntryWith , takeRMapPredecessors , takeRMapSuccessors , deleteRMapEntry + , setRMapEntries , rMapFromList , rMapToList , cacheGetNodeStateUnvalidated @@ -251,6 +257,9 @@ instance HasKeyID RemoteNodeState where instance HasKeyID CacheEntry where getKeyID (CacheEntry _ ns _) = getNid ns +instance HasKeyID NodeID where + getKeyID = id + type NodeCache = RingMap CacheEntry -- | generic data structure for holding elements with a key and modular lookup @@ -260,7 +269,7 @@ instance (HasKeyID a) => Eq (RingMap a) where a == b = getRingMap a == getRingMap b instance (HasKeyID a) => Show (RingMap a) where - show rmap = shows (getRingMap rmap) "RingMap " + show rmap = shows "RingMap " (show $ getRingMap rmap) -- | entry of a 'RingMap' that holds a value and can also -- wrap around the lookup direction at the edges of the name space. diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index 0ac0ea9..dbb8e8b 100644 --- a/test/FediChordSpec.hs +++ b/test/FediChordSpec.hs @@ -127,28 +127,30 @@ spec = do node3 = exampleNodeState { nid = nid3} nid4 = toNodeID 2^(9::Integer)+100 node4 = exampleNodeState { nid = nid4} - cacheWith2Entries :: IO NodeCache - cacheWith2Entries = addCacheEntryPure 10 <$> (RemoteCacheEntry <$> (toRemoteNodeState <$> node1) <*> pure 10) <*> pure (addCacheEntryPure 10 (RemoteCacheEntry node2 10) emptyCache) - cacheWith4Entries = addCacheEntryPure 10 (RemoteCacheEntry node3 10) <$> (addCacheEntryPure 10 (RemoteCacheEntry node4 10) <$> cacheWith2Entries) - it "works on an empty cache" $ do - queryLocalCache <$> exampleLocalNode <*> pure emptyCache <*> pure 3 <*> pure (toNodeID 2^(9::Integer)+5) `shouldReturn` FORWARD Set.empty - queryLocalCache <$> exampleLocalNode <*> pure emptyCache <*> pure 1 <*> pure (toNodeID 2342) `shouldReturn` FORWARD Set.empty + nid5 = toNodeID 2^(25::Integer)+100 + node5 = exampleNodeState { nid = nid5} + cacheWith2Entries :: NodeCache + cacheWith2Entries = addCacheEntryPure 10 (RemoteCacheEntry node5 10) (addCacheEntryPure 10 (RemoteCacheEntry node2 10) emptyCache) + cacheWith4Entries = addCacheEntryPure 10 (RemoteCacheEntry node3 10) (addCacheEntryPure 10 (RemoteCacheEntry node4 10) cacheWith2Entries) + it "nodes not joined provide the default answer FOUND" $ do + exampleLocalNodeAsRemote <- toRemoteNodeState <$> exampleLocalNode + queryLocalCache <$> exampleLocalNode <*> pure emptyCache <*> pure 3 <*> pure (toNodeID 2^(9::Integer)+5) `shouldReturn` FOUND exampleLocalNodeAsRemote + queryLocalCache <$> exampleLocalNode <*> pure cacheWith4Entries <*> pure 1 <*> pure (toNodeID 2342) `shouldReturn` FOUND exampleLocalNodeAsRemote + it "joined nodes do not fall back to the default" $ + queryLocalCache <$> node1 <*> pure emptyCache <*> pure 1 <*> pure (toNodeID 3) `shouldReturn` FORWARD Set.empty it "works on a cache with less entries than needed" $ do - (FORWARD nodeset) <- queryLocalCache <$> exampleLocalNode <*> cacheWith2Entries <*> pure 4 <*> pure (toNodeID 2^(9::Integer)+5) - Set.map (nid . remoteNode) nodeset `shouldBe` Set.fromList [ nid1, nid2 ] + (FORWARD nodeset) <- queryLocalCache <$> node1 <*> pure cacheWith2Entries <*> pure 4 <*> pure (toNodeID 2^(9::Integer)+5) + Set.map (nid . remoteNode) nodeset `shouldBe` Set.fromList [ nid5, nid2 ] it "works on a cache with sufficient entries" $ do - (FORWARD nodeset1) <- queryLocalCache <$> exampleLocalNode <*> cacheWith4Entries <*> pure 3 <*> pure (toNodeID 2^(9::Integer)+5) - (FORWARD nodeset2) <- queryLocalCache <$> exampleLocalNode <*> cacheWith4Entries <*> pure 1 <*> pure (toNodeID 2^(9::Integer)+5) - Set.map (nid . remoteNode) nodeset1 `shouldBe` Set.fromList [nid4, nid2, nid3] + (FORWARD nodeset1) <- queryLocalCache <$> node1 <*> pure cacheWith4Entries <*> pure 3 <*> pure (toNodeID 2^(9::Integer)+5) + (FORWARD nodeset2) <- queryLocalCache <$> node1 <*> pure cacheWith4Entries <*> pure 1 <*> pure (toNodeID 2^(9::Integer)+5) + Set.map (nid . remoteNode) nodeset1 `shouldBe` Set.fromList [nid4, nid2, nid5] Set.map (nid . remoteNode) nodeset2 `shouldBe` Set.fromList [nid4] it "recognises the node's own responsibility" $ do - FOUND selfQueryRes <- queryLocalCache <$> node1 <*> cacheWith4Entries <*> pure 3 <*> pure nid1 + FOUND selfQueryRes <- queryLocalCache <$> node1 <*> pure cacheWith4Entries <*> pure 3 <*> pure nid1 getNid <$> node1 `shouldReturn` getNid selfQueryRes - FOUND responsibilityResult <- queryLocalCache <$> node1 <*> cacheWith4Entries <*> pure 3 <*> pure (toNodeID 2^(22::Integer)) + FOUND responsibilityResult <- queryLocalCache <$> node1 <*> pure cacheWith4Entries <*> pure 3 <*> pure (toNodeID 2^(22::Integer)) getNid <$> node1 `shouldReturn` getNid responsibilityResult - it "does not fail on nodes without neighbours (initial state)" $ do - (FORWARD nodeset) <- queryLocalCache <$> exampleLocalNode <*> cacheWith4Entries <*> pure 3 <*> pure (toNodeID 11) - Set.map (nid . remoteNode ) nodeset `shouldBe` Set.fromList [nid4, nid2, nid3] describe "successors and predecessors do not disturb the ring characteristics of EpiChord operations (see #48)" $ do let emptyCache = initCache From 00ff2bf071d4883516f7b00c2fc828ab13b01cfe Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Fri, 19 Jun 2020 19:14:25 +0200 Subject: [PATCH 61/88] refactor adding neighbours --- src/Hash2Pub/DHTProtocol.hs | 5 ++--- src/Hash2Pub/FediChord.hs | 7 +++---- src/Hash2Pub/FediChordTypes.hs | 24 +++++++++++++++++------- 3 files changed, 22 insertions(+), 14 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 6838137..68b6b9d 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -64,9 +64,8 @@ import Hash2Pub.FediChordTypes (CacheEntry (..), cacheGetNodeStateUnvalidated, cacheLookup, cacheLookupPred, cacheLookupSucc, getKeyID, - localCompare, localCompare, - rMapFromList, rMapLookupPred, - rMapLookupSucc, + localCompare, rMapFromList, + rMapLookupPred, rMapLookupSucc, setPredecessors, setSuccessors) import Hash2Pub.ProtocolTypes diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 6a66220..7a184f4 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -184,15 +184,14 @@ stabiliseThread :: LocalNodeStateSTM -> IO () stabiliseThread nsSTM = do -- TODO: update successfully stabilised nodes in cache -- placeholder - stabiliseNeighbour nsSTM successors setSuccessors 1 + stabiliseNeighbour nsSTM successors 1 pure () where stabiliseNeighbour :: LocalNodeStateSTM -> (LocalNodeState -> [RemoteNodeState]) - -> ([RemoteNodeState] -> LocalNodeState -> LocalNodeState) -> Int -> IO (Either String ()) - stabiliseNeighbour nsSTM neighbourGetter neighbourSetter neighbourNum = do + stabiliseNeighbour nsSTM neighbourGetter neighbourNum = do nsSnap <- readTVarIO nsSTM let chosenNode = maybe (Left "no such neighbour entry") Right $ atMay (neighbourGetter nsSnap) neighbourNum -- returning @Left@ signifies the need to try again with next from list @@ -210,7 +209,7 @@ stabiliseThread nsSTM = do parseNeighbourResponse (Right (succs, preds)) = liftIO $ do atomically $ do newerNsSnap <- readTVar nsSTM - writeTVar nsSTM $ setPredecessors (predecessors newerNsSnap <> preds) . setSuccessors (successors newerNsSnap <> succs) $ newerNsSnap + writeTVar nsSTM $ addPredecessors preds . addSuccessors succs $ newerNsSnap pure () -- periodically contact immediate successor and predecessor diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 601ca63..363e300 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -19,19 +19,21 @@ module Hash2Pub.FediChordTypes ( , RingEntry(..) , RingMap(..) , HasKeyID - , getKeyID + , getKeyID , rMapSize , rMapLookup , rMapLookupPred , rMapLookupSucc , addRMapEntry , addRMapEntryWith + , addPredecessors + , addSuccessors , takeRMapPredecessors , takeRMapSuccessors , deleteRMapEntry , setRMapEntries - , rMapFromList - , rMapToList + , rMapFromList + , rMapToList , cacheGetNodeStateUnvalidated , initCache , cacheEntries @@ -238,13 +240,21 @@ instance Typeable a => Show (TQueue a) where show x = show (typeOf x) --- | convenience function that updates the successors of a 'LocalNodeState' +-- | convenience function that replaces the predecessors of a 'LocalNodeState' with the k closest nodes from the provided list +setPredecessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState +setPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (kNeighbours ns) . rMapFromList $ preds} + +-- | convenience function that replaces the successors of a 'LocalNodeState' with the k closest nodes from the provided list setSuccessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState setSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeighbours ns) . rMapFromList $ succs} --- | convenience function that updates the predecessors of a 'LocalNodeState' -setPredecessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState -setPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (kNeighbours ns) . rMapFromList $ preds} +-- | sets the predecessors of a 'LocalNodeState' to the closest k nodes of the current predecessors and the provided list, combined +addPredecessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState +addPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (kNeighbours ns) . addRMapEntries preds . rMapFromList $ predecessors ns} + +-- | sets the successors of a 'LocalNodeState' to the closest k nodes of the current successors and the provided list, combined +addSuccessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState +addSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeighbours ns) . addRMapEntries succs . rMapFromList $ successors ns} -- | Class for all types that can be identified via an EpiChord key. -- Used for restricting the types a 'RingMap' can store From 3482876d9be497afb8ac977d1fabf9e4365746f4 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Fri, 19 Jun 2020 23:03:27 +0200 Subject: [PATCH 62/88] send and parse Ping requests contributes to #29 #44 --- src/Hash2Pub/DHTProtocol.hs | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 68b6b9d..165ec39 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -16,6 +16,7 @@ module Hash2Pub.DHTProtocol , sendQueryIdMessage , requestQueryID , requestJoin + , requestPing , requestStabilise , queryIdLookupLoop , resolve @@ -531,6 +532,35 @@ requestStabilise ns neighbour = do ) responses +requestPing :: LocalNodeState -- ^ sending node + -> RemoteNodeState -- ^ node to be PINGed + -> IO (Either String [RemoteNodeState]) -- ^ all active vServers of the pinged node +requestPing ns target = do + responses <- bracket (mkSendSocket (getDomain target) (getDhtPort target)) close (fmap Right . sendRequestTo 5000 3 (\rid -> + Request { + requestID = rid + , sender = toRemoteNodeState ns + , part = 1 + , isFinalPart = False + , action = Ping + , payload = Just PingRequestPayload + } + ) + ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) + either + -- forward IO error messages + (pure . Left) + (\respSet -> do + -- fold all reply parts together + let responseVss = foldr' (\msg acc -> + maybe acc (foldr' (:) acc) (pingNodeStates <$> payload msg) + ) + [] respSet + pure $ if null responseVss + then Left "no active vServer IDs returned, ignoring node" + else Right responseVss + ) responses + -- | Generic function for sending a request over a connected socket and collecting the response. From 0494ddd696de5086ee46b6d4a1a006ea60847f95 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 20 Jun 2020 21:20:32 +0200 Subject: [PATCH 63/88] stabilise periodically contributes to #44 --- app/Main.hs | 1 + src/Hash2Pub/FediChord.hs | 13 +++++++++---- src/Hash2Pub/FediChordTypes.hs | 1 + test/FediChordSpec.hs | 2 +- 4 files changed, 12 insertions(+), 5 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index fc9299d..c712f55 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -55,4 +55,5 @@ readConfig = do , confIP = toHostAddress6 . read $ ipString , confDhtPort = read portString , confBootstrapNodes = [(bootstrapHost, read bootstrapPortString)] + --, confStabiliseInterval = 60 } diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 7a184f4..9767aa2 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -181,11 +181,16 @@ cacheWriter nsSTM = modifyTVar' (nodeCacheSTM ns) cacheModifier stabiliseThread :: LocalNodeStateSTM -> IO () -stabiliseThread nsSTM = do +stabiliseThread nsSTM = forever $ do + ns <- readTVarIO nsSTM -- TODO: update successfully stabilised nodes in cache - -- placeholder - stabiliseNeighbour nsSTM successors 1 - pure () + -- first stabilise immediate neihbours, then the next ones + forM_ [1..(kNeighbours ns)] (\num -> do + stabiliseNeighbour nsSTM predecessors num + stabiliseNeighbour nsSTM successors num + ) + -- TODO: make delay configurable + threadDelay (60 * 1000) where stabiliseNeighbour :: LocalNodeStateSTM -> (LocalNodeState -> [RemoteNodeState]) diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 363e300..26a13f8 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -613,6 +613,7 @@ data FediChordConf = FediChordConf , confIP :: HostAddress6 , confDhtPort :: Int , confBootstrapNodes :: [(String, PortNumber)] + --, confStabiliseInterval :: Int } deriving (Show, Eq) diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index dbb8e8b..4f05e72 100644 --- a/test/FediChordSpec.hs +++ b/test/FediChordSpec.hs @@ -154,7 +154,7 @@ spec = do describe "successors and predecessors do not disturb the ring characteristics of EpiChord operations (see #48)" $ do let emptyCache = initCache - -- implicitly relies on kNieghbours to be <= 3 + -- implicitly relies on kNeighbours to be <= 3 thisNid = toNodeID 1000 thisNode = setNid thisNid <$> exampleLocalNode nid2 = toNodeID 1003 From d5f502c05c25ea2c4cba712df340bb9f25dacf8c Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 20 Jun 2020 22:28:01 +0200 Subject: [PATCH 64/88] ping potential neighbours before adding to list for #44 --- src/Hash2Pub/FediChord.hs | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 9767aa2..e1ec96b 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -61,12 +61,13 @@ import Crypto.Hash import qualified Data.ByteArray as BA import qualified Data.ByteString as BS import qualified Data.ByteString.UTF8 as BSU +import Data.Either (rights) import Data.Foldable (foldr') import Data.IP (IPv6, fromHostAddress6, toHostAddress6) import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust, fromMaybe, isJust, - mapMaybe) +import Data.Maybe (catMaybes, fromJust, fromMaybe, + isJust, mapMaybe) import qualified Data.Set as Set import Data.Time.Clock.POSIX import Data.Typeable (Typeable (..), typeOf) @@ -212,10 +213,25 @@ stabiliseThread nsSTM = forever $ do -> m () parseNeighbourResponse (Left err) = throwError err parseNeighbourResponse (Right (succs, preds)) = liftIO $ do + -- ping each returned node before actually inserting them + -- send pings in parallel, check whether ID is part of the returned IDs + nsSnap <- readTVarIO nsSTM + pingThreads <- mapM (async . checkReachability nsSnap) $ preds <> succs + -- ToDo: exception handling, maybe log them + -- filter out own node + checkedNeighbours <- filter (/= toRemoteNodeState nsSnap) . catMaybes . rights <$> mapM waitCatch pingThreads + atomically $ do newerNsSnap <- readTVar nsSTM - writeTVar nsSTM $ addPredecessors preds . addSuccessors succs $ newerNsSnap + writeTVar nsSTM $ addPredecessors checkedNeighbours . addSuccessors checkedNeighbours $ newerNsSnap pure () + checkReachability :: LocalNodeState -> RemoteNodeState -> IO (Maybe RemoteNodeState) + checkReachability ns toCheck = do + resp <- requestPing ns toCheck + pure $ either (const Nothing) (\vss -> + if toCheck `elem` vss then Just toCheck else Nothing + ) resp + -- periodically contact immediate successor and predecessor -- If they respond, see whether there is a closer neighbour in between From 111c1a299d646991a49320315442f353464cb856 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 23 Jun 2020 19:33:54 +0200 Subject: [PATCH 65/88] refactored stabilise: use first responding neighbour contributes to #44 --- src/Hash2Pub/FediChord.hs | 91 ++++++++++++++++++++++++--------------- 1 file changed, 56 insertions(+), 35 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index e1ec96b..a5967ad 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -65,9 +65,10 @@ import Data.Either (rights) import Data.Foldable (foldr') import Data.IP (IPv6, fromHostAddress6, toHostAddress6) +import Data.List ((\\)) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromJust, fromMaybe, - isJust, mapMaybe) + isJust, isNothing, mapMaybe) import qualified Data.Set as Set import Data.Time.Clock.POSIX import Data.Typeable (Typeable (..), typeOf) @@ -184,47 +185,67 @@ cacheWriter nsSTM = stabiliseThread :: LocalNodeStateSTM -> IO () stabiliseThread nsSTM = forever $ do ns <- readTVarIO nsSTM + + -- iterate through the same snapshot, collect potential new neighbours + -- and nodes to be deleted, and modify these changes only at the end of + -- each stabilise run. + -- This decision makes iterating through a potentially changing list easier. + + -- don't contact all neighbours unless the previous one failed/ Left ed + + predStabilise <- stabiliseClosestResponder ns predecessors 1 [] + succStabilise <- stabiliseClosestResponder ns predecessors 1 [] + + let + (predDeletes, predNeighbours) = either (const ([], [])) id predStabilise + (succDeletes, succNeighbours) = either (const ([], [])) id succStabilise + allDeletes = predDeletes <> succDeletes + allNeighbours = predNeighbours <> succNeighbours + + -- now actually modify the node state's neighbours + updatedNs <- atomically $ do + newerNsSnap <- readTVar nsSTM + let + -- sorting and taking only k neighbours is taken care of by the + -- setSuccessors/ setPredecessors functions + newPreds = (predecessors newerNsSnap \\ allDeletes) <> allNeighbours + newSuccs = (successors newerNsSnap \\ allDeletes) <> allNeighbours + newNs = setPredecessors newPreds . setSuccessors newSuccs $ newerNsSnap + writeTVar nsSTM newNs + pure newNs + -- TODO: update successfully stabilised nodes in cache - -- first stabilise immediate neihbours, then the next ones - forM_ [1..(kNeighbours ns)] (\num -> do - stabiliseNeighbour nsSTM predecessors num - stabiliseNeighbour nsSTM successors num - ) + + -- try looking up additional neighbours if list too short + -- TODO: make delay configurable threadDelay (60 * 1000) where - stabiliseNeighbour :: LocalNodeStateSTM + stabiliseClosestResponder :: LocalNodeState -> (LocalNodeState -> [RemoteNodeState]) -> Int - -> IO (Either String ()) - stabiliseNeighbour nsSTM neighbourGetter neighbourNum = do - nsSnap <- readTVarIO nsSTM - let chosenNode = maybe (Left "no such neighbour entry") Right $ atMay (neighbourGetter nsSnap) neighbourNum - -- returning @Left@ signifies the need to try again with next from list - runExceptT $ requestToNeighbour nsSnap chosenNode >>= parseNeighbourResponse - requestToNeighbour :: (MonadError String m, MonadIO m) - => LocalNodeState - -> Either String RemoteNodeState - -> m (Either String ([RemoteNodeState],[RemoteNodeState])) - requestToNeighbour _ (Left err) = throwError err - requestToNeighbour ns (Right n) = liftIO $ requestStabilise ns n - parseNeighbourResponse :: (MonadError String m, MonadIO m) - => Either String ([RemoteNodeState], [RemoteNodeState]) - -> m () - parseNeighbourResponse (Left err) = throwError err - parseNeighbourResponse (Right (succs, preds)) = liftIO $ do - -- ping each returned node before actually inserting them - -- send pings in parallel, check whether ID is part of the returned IDs - nsSnap <- readTVarIO nsSTM - pingThreads <- mapM (async . checkReachability nsSnap) $ preds <> succs - -- ToDo: exception handling, maybe log them - -- filter out own node - checkedNeighbours <- filter (/= toRemoteNodeState nsSnap) . catMaybes . rights <$> mapM waitCatch pingThreads + -> [RemoteNodeState] -- ^ delete accumulator + -> IO (Either String ([RemoteNodeState], [RemoteNodeState])) -- ^ (nodes to be deleted, successfully pinged potential neighbours) + stabiliseClosestResponder ns neighbourGetter neighbourNum deleteAcc + | isNothing (currentNeighbour ns neighbourGetter neighbourNum) = pure $ Left "exhausted all neigbours" + | otherwise = do + let node = fromJust $ currentNeighbour ns neighbourGetter neighbourNum + stabResponse <- requestStabilise ns node + case stabResponse of + -- returning @Left@ signifies the need to try again with next from list + Left err -> stabiliseClosestResponder ns neighbourGetter (neighbourNum+1) (node:deleteAcc) + Right (succs, preds) -> do + -- ping each returned node before actually inserting them + -- send pings in parallel, check whether ID is part of the returned IDs + pingThreads <- mapM (async . checkReachability ns) $ preds <> succs + -- ToDo: exception handling, maybe log them + -- filter out own node + checkedNeighbours <- filter (/= toRemoteNodeState ns) . catMaybes . rights <$> mapM waitCatch pingThreads + pure $ Right (deleteAcc, checkedNeighbours) + + + currentNeighbour ns neighbourGetter = atMay $ neighbourGetter ns - atomically $ do - newerNsSnap <- readTVar nsSTM - writeTVar nsSTM $ addPredecessors checkedNeighbours . addSuccessors checkedNeighbours $ newerNsSnap - pure () checkReachability :: LocalNodeState -> RemoteNodeState -> IO (Maybe RemoteNodeState) checkReachability ns toCheck = do resp <- requestPing ns toCheck From 25f44f3a4572e2f7cbc6f4d9e5193989d6d21fd1 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 24 Jun 2020 01:19:53 +0200 Subject: [PATCH 66/88] look up additional neighbours if necessary for #44 --- src/Hash2Pub/FediChord.hs | 23 +++++++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index a5967ad..db4ac61 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -217,15 +217,30 @@ stabiliseThread nsSTM = forever $ do -- TODO: update successfully stabilised nodes in cache -- try looking up additional neighbours if list too short + forM_ [(length $ predecessors updatedNs)..(kNeighbours updatedNs)] (\_ -> do + ns' <- readTVarIO nsSTM + nextEntry <- requestQueryID ns' $ pred . getNid $ atDef (toRemoteNodeState ns') (predecessors ns') (-1) + atomically $ do + latestNs <- readTVar nsSTM + writeTVar nsSTM $ addPredecessors [nextEntry] latestNs + ) +-- + forM_ [(length $ successors updatedNs)..(kNeighbours updatedNs)] (\_ -> do + ns' <- readTVarIO nsSTM + nextEntry <- requestQueryID ns' $ succ . getNid $ atDef (toRemoteNodeState ns') (successors ns') (-1) + atomically $ do + latestNs <- readTVar nsSTM + writeTVar nsSTM $ addSuccessors [nextEntry] latestNs + ) -- TODO: make delay configurable threadDelay (60 * 1000) where stabiliseClosestResponder :: LocalNodeState - -> (LocalNodeState -> [RemoteNodeState]) - -> Int - -> [RemoteNodeState] -- ^ delete accumulator - -> IO (Either String ([RemoteNodeState], [RemoteNodeState])) -- ^ (nodes to be deleted, successfully pinged potential neighbours) + -> (LocalNodeState -> [RemoteNodeState]) + -> Int + -> [RemoteNodeState] -- ^ delete accumulator + -> IO (Either String ([RemoteNodeState], [RemoteNodeState])) -- ^ (nodes to be deleted, successfully pinged potential neighbours) stabiliseClosestResponder ns neighbourGetter neighbourNum deleteAcc | isNothing (currentNeighbour ns neighbourGetter neighbourNum) = pure $ Left "exhausted all neigbours" | otherwise = do From 16b46a8b0b74ef4c6190a91cef7593fda706e899 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 24 Jun 2020 02:12:21 +0200 Subject: [PATCH 67/88] add some comments on stabilise --- src/Hash2Pub/DHTProtocol.hs | 1 + src/Hash2Pub/FediChord.hs | 25 ++++++++++++++++--------- 2 files changed, 17 insertions(+), 9 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 165ec39..459a4c1 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -486,6 +486,7 @@ queryIdLookupLoop cacheSnapshot ns targetID = do _ -> Nothing ) $ responses -- if no FOUND, recursively call lookup again + -- TODO: this could lead to infinite recursion on an empty cache. Consider returning the node itself as default value maybe (queryIdLookupLoop newLCache ns targetID) pure foundResp diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index db4ac61..1b1f808 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -182,6 +182,10 @@ cacheWriter nsSTM = cacheModifier <- readTQueue $ cacheWriteQueue ns modifyTVar' (nodeCacheSTM ns) cacheModifier + +-- | Periodically send @StabiliseRequest' s to the closest neighbour nodes, until +-- one responds, and get their neighbours for maintaining the own neighbour lists. +-- If necessary, request new neighbours. stabiliseThread :: LocalNodeStateSTM -> IO () stabiliseThread nsSTM = forever $ do ns <- readTVarIO nsSTM @@ -224,7 +228,7 @@ stabiliseThread nsSTM = forever $ do latestNs <- readTVar nsSTM writeTVar nsSTM $ addPredecessors [nextEntry] latestNs ) --- + forM_ [(length $ successors updatedNs)..(kNeighbours updatedNs)] (\_ -> do ns' <- readTVarIO nsSTM nextEntry <- requestQueryID ns' $ succ . getNid $ atDef (toRemoteNodeState ns') (successors ns') (-1) @@ -236,9 +240,14 @@ stabiliseThread nsSTM = forever $ do -- TODO: make delay configurable threadDelay (60 * 1000) where - stabiliseClosestResponder :: LocalNodeState - -> (LocalNodeState -> [RemoteNodeState]) - -> Int + -- | send a stabilise request to the n-th neighbour + -- (specified by the provided getter function) and on failure retr + -- with the n+1-th neighbour. + -- On success, return 2 lists: The failed nodes and the potential neighbours + -- returned by the queried node. + stabiliseClosestResponder :: LocalNodeState -- ^ own node + -> (LocalNodeState -> [RemoteNodeState]) -- ^ getter function for either predecessors or successors + -> Int -- ^ index of neighbour to query -> [RemoteNodeState] -- ^ delete accumulator -> IO (Either String ([RemoteNodeState], [RemoteNodeState])) -- ^ (nodes to be deleted, successfully pinged potential neighbours) stabiliseClosestResponder ns neighbourGetter neighbourNum deleteAcc @@ -261,7 +270,9 @@ stabiliseThread nsSTM = forever $ do currentNeighbour ns neighbourGetter = atMay $ neighbourGetter ns - checkReachability :: LocalNodeState -> RemoteNodeState -> IO (Maybe RemoteNodeState) + checkReachability :: LocalNodeState -- ^ this node + -> RemoteNodeState -- ^ node to Ping for reachability + -> IO (Maybe RemoteNodeState) -- ^ if the Pinged node handles the requested node state then that one checkReachability ns toCheck = do resp <- requestPing ns toCheck pure $ either (const Nothing) (\vss -> @@ -269,10 +280,6 @@ stabiliseThread nsSTM = forever $ do ) resp --- periodically contact immediate successor and predecessor --- If they respond, see whether there is a closer neighbour in between --- If they don't respond, drop them and try the next one - -- | Receives UDP packets and passes them to other threads via the given TQueue. -- Shall be used as the single receiving thread on the server socket, as multiple -- threads blocking on the same socket degrades performance. From 81e346db4ed2ba979c5fe5b112d081ee0da0421b Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 24 Jun 2020 02:48:41 +0200 Subject: [PATCH 68/88] update responding neighbours and delete unresponding ones from cache contributes to #44 --- src/Hash2Pub/DHTProtocol.hs | 3 +++ src/Hash2Pub/FediChord.hs | 4 ++-- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 459a4c1..bfcdf9e 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -527,6 +527,9 @@ requestStabilise ns neighbour = do ,maybe succAcc (++ succAcc) (stabiliseSuccessors <$> payload msg)) ) ([],[]) respSet + -- update successfully responded neighbour in cache + now <- getPOSIXTime + maybe (pure ()) (\p -> queueAddEntries (Identity $ RemoteCacheEntry (sender p) now) ns) $ headMay (Set.elems respSet) pure $ if null responsePreds && null responseSuccs then Left "no neighbours returned" else Right (responsePreds, responseSuccs) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 1b1f808..b013bdc 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -217,8 +217,8 @@ stabiliseThread nsSTM = forever $ do newNs = setPredecessors newPreds . setSuccessors newSuccs $ newerNsSnap writeTVar nsSTM newNs pure newNs - - -- TODO: update successfully stabilised nodes in cache + -- delete unresponding nodes from cache as well + mapM_ (atomically . writeTQueue (cacheWriteQueue updatedNs) . deleteCacheEntry . getNid) allDeletes -- try looking up additional neighbours if list too short forM_ [(length $ predecessors updatedNs)..(kNeighbours updatedNs)] (\_ -> do From c9783a10cf1a3df42dab5691d55e1644bfc5593c Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 24 Jun 2020 02:51:28 +0200 Subject: [PATCH 69/88] launch stabilise thread closes #44 although stabilise functionality is still untested --- src/Hash2Pub/FediChord.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index b013bdc..c425683 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -307,9 +307,10 @@ fediMainThreads sock nsSTM = do -- all get cancelled concurrently_ (fediMessageHandler sendQ recvQ nsSTM) $ - concurrently - (sendThread sock sendQ) - (recvThread sock recvQ) + concurrently_ (stabiliseThread nsSTM) $ + concurrently_ + (sendThread sock sendQ) + (recvThread sock recvQ) -- defining this here as, for now, the RequestMap is only used by fediMessageHandler. From 5e8cfb0ccde77a6c9a77b356961cc3e3b6f1e562 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 24 Jun 2020 22:27:35 +0200 Subject: [PATCH 70/88] mark successfully Pinged nodes as verified for #29 --- src/Hash2Pub/DHTProtocol.hs | 66 ++++++++++++++++++++++++++++--------- 1 file changed, 50 insertions(+), 16 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index bfcdf9e..f02bd59 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -3,9 +3,10 @@ module Hash2Pub.DHTProtocol , queryLocalCache , addCacheEntry , addCacheEntryPure + , addNodeAsVerified + , addNodeAsVerifiedPure , deleteCacheEntry , deserialiseMessage - , markCacheEntryAsVerified , RemoteCacheEntry(..) , toRemoteCacheEntry , remoteNode @@ -64,9 +65,10 @@ import Hash2Pub.FediChordTypes (CacheEntry (..), addRMapEntry, addRMapEntryWith, cacheGetNodeStateUnvalidated, cacheLookup, cacheLookupPred, - cacheLookupSucc, getKeyID, - localCompare, rMapFromList, - rMapLookupPred, rMapLookupSucc, + cacheLookupSucc, genNodeID, + getKeyID, localCompare, + rMapFromList, rMapLookupPred, + rMapLookupSucc, setPredecessors, setSuccessors) import Hash2Pub.ProtocolTypes @@ -154,6 +156,26 @@ deleteCacheEntry nid = RingMap . Map.update modifier nid . getRingMap modifier (ProxyEntry idPointer _) = Just (ProxyEntry idPointer Nothing) modifier KeyEntry {} = Nothing + +-- | Add a 'RemoteNodeState' to the node cache marked as verified. +-- If an entry already exists, it is replaced by the new verified one. +addNodeAsVerified :: RemoteNodeState + -> NodeCache + -> IO NodeCache +addNodeAsVerified node cache = do + now <- getPOSIXTime + pure $ addNodeAsVerifiedPure now node cache + + +-- | Pure variant of 'addNodeAsVerified' with current time explicitly specified as an argument +addNodeAsVerifiedPure :: POSIXTime + -> RemoteNodeState + -> NodeCache + -> NodeCache +addNodeAsVerifiedPure now node = addRMapEntry (CacheEntry True node now) + + + -- | Mark a cache entry as verified after pinging it, possibly bumping its timestamp. markCacheEntryAsVerified :: Maybe POSIXTime -- ^ the (current) timestamp to be -- given to the entry, or Nothing @@ -540,26 +562,38 @@ requestPing :: LocalNodeState -- ^ sending node -> RemoteNodeState -- ^ node to be PINGed -> IO (Either String [RemoteNodeState]) -- ^ all active vServers of the pinged node requestPing ns target = do - responses <- bracket (mkSendSocket (getDomain target) (getDhtPort target)) close (fmap Right . sendRequestTo 5000 3 (\rid -> - Request { - requestID = rid - , sender = toRemoteNodeState ns - , part = 1 - , isFinalPart = False - , action = Ping - , payload = Just PingRequestPayload - } - ) - ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) + responses <- bracket (mkSendSocket (getDomain target) (getDhtPort target)) close + (\sock -> do + resp <- sendRequestTo 5000 3 (\rid -> + Request { + requestID = rid + , sender = toRemoteNodeState ns + , part = 1 + , isFinalPart = False + , action = Ping + , payload = Just PingRequestPayload + } + ) sock + (SockAddrInet6 _ _ peerAddr _) <- getPeerName sock + pure $ Right (peerAddr, resp) + ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) either -- forward IO error messages (pure . Left) - (\respSet -> do + (\(peerAddr, respSet) -> do -- fold all reply parts together let responseVss = foldr' (\msg acc -> maybe acc (foldr' (:) acc) (pingNodeStates <$> payload msg) ) [] respSet + -- recompute ID for each received node and mark as verified in cache + now <- getPOSIXTime + forM_ responseVss (\vs -> + let recomputedID = genNodeID peerAddr (getDomain vs) (fromInteger $ getVServerID vs) + in if recomputedID == getNid vs + then atomically $ writeTQueue (cacheWriteQueue ns) $ addNodeAsVerifiedPure now vs + else pure () + ) pure $ if null responseVss then Left "no active vServer IDs returned, ignoring node" else Right responseVss From 7f5dac55ea5418ddf21d24eb3b5770627ee11456 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Thu, 25 Jun 2020 01:24:25 +0200 Subject: [PATCH 71/88] close #29: periodic cache maintenance periodically delete expired cache entries, check unverified ones and potentially use them as neighbour --- src/Hash2Pub/DHTProtocol.hs | 36 ++++++++++++++++++-- src/Hash2Pub/FediChord.hs | 68 +++++++++++++++++++++++++++++++++---- 2 files changed, 94 insertions(+), 10 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index f02bd59..7af7699 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -20,11 +20,16 @@ module Hash2Pub.DHTProtocol , requestPing , requestStabilise , queryIdLookupLoop + , queueAddEntries + , queueDeleteEntries + , queueDeleteEntry , resolve , mkSendSocket , mkServerSocket , handleIncomingRequest , ackRequest + , isPossibleSuccessor + , isPossiblePredecessor ) where @@ -81,7 +86,7 @@ import Debug.Trace (trace) queryLocalCache :: LocalNodeState -> NodeCache -> Int -> NodeID -> QueryResponse queryLocalCache ownState nCache lBestNodes targetID -- as target ID falls between own ID and first predecessor, it is handled by this node - | isInOwnResponsibilitySlice ownState targetID = FOUND . toRemoteNodeState $ ownState + | targetID `isInOwnResponsibilitySlice` ownState = FOUND . toRemoteNodeState $ ownState -- my interpretation: the "l best next hops" are the l-1 closest preceding nodes and -- the closest succeeding node (like with the p initiated parallel queries | otherwise = FORWARD $ closestSuccessor `Set.union` closestPredecessors @@ -110,8 +115,8 @@ queryLocalCache ownState nCache lBestNodes targetID -- Looks up the successor of the lookup key on a 'RingMap' representation of the -- predecessor list with the node itself added. If the result is the same as the node -- itself then it falls into the responsibility interval. -isInOwnResponsibilitySlice :: HasKeyID a => LocalNodeState -> a -> Bool -isInOwnResponsibilitySlice ownNs lookupTarget = (getKeyID <$> rMapLookupSucc (getKeyID lookupTarget) predecessorRMap) == pure (getNid ownNs) +isInOwnResponsibilitySlice :: HasKeyID a => a -> LocalNodeState -> Bool +isInOwnResponsibilitySlice lookupTarget ownNs = (getKeyID <$> rMapLookupSucc (getKeyID lookupTarget) predecessorRMap) == pure (getNid ownNs) where predecessorList = predecessors ownNs -- add node itself to RingMap representation, to distinguish between @@ -119,6 +124,16 @@ isInOwnResponsibilitySlice ownNs lookupTarget = (getKeyID <$> rMapLookupSucc (ge predecessorRMap = addRMapEntry (toRemoteNodeState ownNs) $ rMapFromList predecessorList closestPredecessor = headMay predecessorList +isPossiblePredecessor :: HasKeyID a => a -> LocalNodeState -> Bool +isPossiblePredecessor = isInOwnResponsibilitySlice + +isPossibleSuccessor :: HasKeyID a => a -> LocalNodeState -> Bool +isPossibleSuccessor lookupTarget ownNs = (getKeyID <$> rMapLookupPred (getKeyID lookupTarget) successorRMap) == pure (getNid ownNs) + where + successorList = successors ownNs + successorRMap = addRMapEntry (toRemoteNodeState ownNs) $ rMapFromList successorList + closestSuccessor = headMay successorList + -- cache operations -- | update or insert a 'RemoteCacheEntry' into the cache, @@ -662,6 +677,21 @@ queueAddEntries entries ns = do now <- getPOSIXTime forM_ entries $ \entry -> atomically $ writeTQueue (cacheWriteQueue ns) $ addCacheEntryPure now entry + +-- | enque a list of node IDs to be deleted from the global NodeCache +queueDeleteEntries :: Foldable c + => c NodeID + -> LocalNodeState + -> IO () +queueDeleteEntries ids ns = forM_ ids $ atomically . writeTQueue (cacheWriteQueue ns) . deleteCacheEntry + + +-- | enque a single node ID to be deleted from the global NodeCache +queueDeleteEntry :: NodeID + -> LocalNodeState + -> IO () +queueDeleteEntry toDelete = queueDeleteEntries $ Identity toDelete + -- | retry an IO action at most *i* times until it delivers a result attempts :: Int -- ^ number of retries *i* -> IO (Maybe a) -- ^ action to retry diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index c425683..fe7fa83 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -63,6 +63,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.UTF8 as BSU import Data.Either (rights) import Data.Foldable (foldr') +import Data.Functor.Identity import Data.IP (IPv6, fromHostAddress6, toHostAddress6) import Data.List ((\\)) @@ -183,6 +184,58 @@ cacheWriter nsSTM = modifyTVar' (nodeCacheSTM ns) cacheModifier +-- TODO: make max entry age configurable +maxEntryAge :: POSIXTime +maxEntryAge = 600 + + +-- | Periodically iterate through cache, clean up expired entries and verify unverified ones +cacheVerifyThread :: LocalNodeStateSTM -> IO () +cacheVerifyThread nsSTM = forever $ do + -- get cache + (ns, cache) <- atomically $ do + ns <- readTVar nsSTM + cache <- readTVar $ nodeCacheSTM ns + pure (ns, cache) + -- iterate entries: + -- for avoiding too many time syscalls, get current time before iterating. + now <- getPOSIXTime + forM_ (cacheEntries cache) (\(CacheEntry validated node ts) -> + -- case too old: delete (future work: decide whether pinging and resetting timestamp is better) + if (now - ts) > maxEntryAge + then + queueDeleteEntry (getNid node) ns + -- case unverified: try verifying, otherwise delete + else if not validated + then do + -- marking as verified is done by 'requestPing' as well + pong <- requestPing ns node + either (\_-> + queueDeleteEntry (getNid node) ns + ) + (\vss -> + if node `notElem` vss + then queueDeleteEntry (getNid node) ns + -- after verifying a node, check whether it can be a closer neighbour + else do + if node `isPossiblePredecessor` ns + then atomically $ do + ns' <- readTVar nsSTM + writeTVar nsSTM $ addPredecessors [node] ns' + else pure () + if node `isPossibleSuccessor` ns + then atomically $ do + ns' <- readTVar nsSTM + writeTVar nsSTM $ addSuccessors [node] ns' + else pure () + ) pong + else pure () + ) + + threadDelay $ toEnum (fromEnum maxEntryAge `div` 20) + + + -- | Periodically send @StabiliseRequest' s to the closest neighbour nodes, until -- one responds, and get their neighbours for maintaining the own neighbour lists. -- If necessary, request new neighbours. @@ -308,9 +361,10 @@ fediMainThreads sock nsSTM = do concurrently_ (fediMessageHandler sendQ recvQ nsSTM) $ concurrently_ (stabiliseThread nsSTM) $ - concurrently_ - (sendThread sock sendQ) - (recvThread sock recvQ) + concurrently_ (cacheVerifyThread nsSTM) $ + concurrently_ + (sendThread sock sendQ) + (recvThread sock recvQ) -- defining this here as, for now, the RequestMap is only used by fediMessageHandler. @@ -322,17 +376,17 @@ data RequestMapEntry = RequestMapEntry (Set.Set FediChordMessage) (Maybe Integer -- TODO: make purge age configurable -- | periodically clean up old request parts -purgeAge :: POSIXTime -purgeAge = 60 -- seconds +responsePurgeAge :: POSIXTime +responsePurgeAge = 60 -- seconds requestMapPurge :: MVar RequestMap -> IO () requestMapPurge mapVar = forever $ do rMapState <- takeMVar mapVar now <- getPOSIXTime putMVar mapVar $ Map.filter (\entry@(RequestMapEntry _ _ ts) -> - now - ts < purgeAge + now - ts < responsePurgeAge ) rMapState - threadDelay $ fromEnum purgeAge * 2000 + threadDelay $ fromEnum responsePurgeAge * 2000 -- | Wait for messages, deserialise them, manage parts and acknowledgement status, From 280d928ad7c40d4949a7173f7229b18f6a5893a0 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 27 Jun 2020 15:57:54 +0200 Subject: [PATCH 72/88] Refactor requestQueryID to be able to send a single request in preparation for #30 --- src/Hash2Pub/DHTProtocol.hs | 115 ++++++++++++++++++++------------- src/Hash2Pub/FediChord.hs | 2 +- src/Hash2Pub/FediChordTypes.hs | 3 +- 3 files changed, 74 insertions(+), 46 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 7af7699..83e32d4 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -14,11 +14,13 @@ module Hash2Pub.DHTProtocol , ActionPayload(..) , FediChordMessage(..) , maximumParts - , sendQueryIdMessage + , sendQueryIdMessages , requestQueryID , requestJoin , requestPing , requestStabilise + , lookupMessage + , sendRequestTo , queryIdLookupLoop , queueAddEntries , queueDeleteEntries @@ -30,6 +32,7 @@ module Hash2Pub.DHTProtocol , ackRequest , isPossibleSuccessor , isPossiblePredecessor + , closestCachePredecessors ) where @@ -89,7 +92,7 @@ queryLocalCache ownState nCache lBestNodes targetID | targetID `isInOwnResponsibilitySlice` ownState = FOUND . toRemoteNodeState $ ownState -- my interpretation: the "l best next hops" are the l-1 closest preceding nodes and -- the closest succeeding node (like with the p initiated parallel queries - | otherwise = FORWARD $ closestSuccessor `Set.union` closestPredecessors + | otherwise = FORWARD $ closestSuccessor `Set.union` closestCachePredecessors (lBestNodes-1) targetID nCache where ownID = getNid ownState preds = predecessors ownState @@ -97,18 +100,22 @@ queryLocalCache ownState nCache lBestNodes targetID closestSuccessor :: Set.Set RemoteCacheEntry closestSuccessor = maybe Set.empty (Set.singleton . toRemoteCacheEntry) $ cacheLookupSucc targetID nCache - closestPredecessors :: Set.Set RemoteCacheEntry - closestPredecessors = closestPredecessor (lBestNodes-1) targetID - closestPredecessor :: (Integral n, Show n) => n -> NodeID -> Set.Set RemoteCacheEntry - closestPredecessor 0 _ = Set.empty - closestPredecessor remainingLookups lastID - | remainingLookups < 0 = Set.empty - | otherwise = - let result = cacheLookupPred lastID nCache - in - case toRemoteCacheEntry <$> result of - Nothing -> Set.empty - Just nPred@(RemoteCacheEntry ns ts) -> Set.insert nPred $ closestPredecessor (remainingLookups-1) (nid ns) + +-- | look up the 3 direct predecessor cache entries of a given ID +closestCachePredecessors :: (Integral n) + => n -- ^ number of entries to look up + -> NodeID -- ^ target ID to get the predecessors of + -> NodeCache -- ^ cache to use for lookup + -> Set.Set RemoteCacheEntry +closestCachePredecessors 0 _ _ = Set.empty +closestCachePredecessors remainingLookups lastID nCache + | remainingLookups < 0 = Set.empty + | otherwise = + let result = cacheLookupPred lastID nCache + in + case toRemoteCacheEntry <$> result of + Nothing -> Set.empty + Just nPred@(RemoteCacheEntry ns ts) -> Set.insert nPred $ closestCachePredecessors (remainingLookups-1) (nid ns) nCache -- | Determines whether a lookup key is within the responsibility slice of a node, -- as it falls between its first predecessor and the node itself. @@ -496,45 +503,65 @@ queryIdLookupLoop cacheSnapshot ns targetID = do case localResult of FOUND thisNode -> pure thisNode FORWARD nodeSet -> do + responseEntries <- sendQueryIdMessages targetID ns Nothing (remoteNode <$> Set.elems nodeSet) + now <- getPOSIXTime + -- check for a FOUND and return it + case responseEntries of + FOUND foundNode -> pure foundNode + -- if not FOUND, insert entries into local cache copy and recurse + FORWARD entrySet -> + let newLCache = foldr' ( + addCacheEntryPure now + ) cacheSnapshot entrySet + in + -- TODO: this could lead to infinite recursion on an empty cache. Consider returning the node itself as default value + queryIdLookupLoop newLCache ns targetID + + +sendQueryIdMessages :: (Integral i) + => NodeID -- ^ target key ID to look up + -> LocalNodeState -- ^ node state of the node doing the query + -> Maybe i -- ^ optionally provide an explicit @l@ parameter of number of nodes to be returned + -> [RemoteNodeState] -- ^ nodes to query + -> IO QueryResponse -- ^ accumulated response +sendQueryIdMessages targetID ns lParam targets = do + -- create connected sockets to all query targets and use them for request handling -- ToDo: make attempts and timeout configurable - queryThreads <- mapM (\resultNode -> async $ bracket (mkSendSocket (getDomain resultNode) (getDhtPort resultNode)) close (sendQueryIdMessage targetID ns)) $ remoteNode <$> Set.toList nodeSet + queryThreads <- mapM (\resultNode -> async $ bracket (mkSendSocket (getDomain resultNode) (getDhtPort resultNode)) close ( + sendRequestTo 5000 3 (lookupMessage targetID ns Nothing) + )) targets -- ToDo: process results immediately instead of waiting for the last one to finish, see https://stackoverflow.com/a/38815224/9198613 -- ToDo: exception handling, maybe log them responses <- (mconcat . fmap Set.elems) . rights <$> mapM waitCatch queryThreads - -- insert new cache entries both into global cache as well as in local copy, to make sure it is already up to date at next lookup + -- insert new cache entries both into global cache as well as return accumulated QueryResponses for further processing now <- getPOSIXTime - newLCache <- foldM (\oldCache resp -> do - let entriesToInsert = case queryResult <$> payload resp of - Just (FOUND result1) -> [RemoteCacheEntry result1 now] - Just (FORWARD resultset) -> Set.elems resultset - _ -> [] + -- collect cache entries from all responses + foldM (\acc resp -> do + let entrySet = case queryResult <$> payload resp of + Just (FOUND result1) -> Set.singleton (RemoteCacheEntry result1 now) + Just (FORWARD resultset) -> resultset + _ -> Set.empty + -- forward entries to global cache - queueAddEntries entriesToInsert ns - -- insert entries into local cache copy - pure $ foldr' ( - addCacheEntryPure now - ) oldCache entriesToInsert - ) cacheSnapshot responses + queueAddEntries entrySet ns + -- return accumulated QueryResult + pure $ case acc of + -- once a FOUND as been encountered, return this as a result + isFound@FOUND{} -> isFound + FORWARD accSet -> FORWARD $ entrySet `Set.union` accSet - -- check for a FOUND and return it - let foundResp = headMay . mapMaybe (\resp -> case queryResult <$> payload resp of - Just (FOUND ns') -> Just ns' - _ -> Nothing - ) $ responses - -- if no FOUND, recursively call lookup again - -- TODO: this could lead to infinite recursion on an empty cache. Consider returning the node itself as default value - maybe (queryIdLookupLoop newLCache ns targetID) pure foundResp + ) (FORWARD Set.empty) responses - -sendQueryIdMessage :: NodeID -- ^ target key ID to look up - -> LocalNodeState -- ^ node state of the node doing the query - -> Socket -- ^ connected socket to use for sending - -> IO (Set.Set FediChordMessage) -- ^ responses -sendQueryIdMessage targetID ns = sendRequestTo 5000 3 (lookupMessage targetID ns) - where - lookupMessage targetID ns rID = Request rID (toRemoteNodeState ns) 1 True QueryID (Just $ pl ns targetID) - pl ns' targetID' = QueryIDRequestPayload { queryTargetID = targetID', queryLBestNodes = fromIntegral . lNumBestNodes $ ns } +-- | Create a QueryID message to be supplied to 'sendRequestTo' +lookupMessage :: Integral i + => NodeID -- ^ target ID + -> LocalNodeState -- ^ sender node state + -> Maybe i -- ^ optionally provide a different l parameter + -> (Integer -> FediChordMessage) +lookupMessage targetID ns lParam = \rID -> Request rID (toRemoteNodeState ns) 1 True QueryID (Just $ pl ns targetID) + where + pl ns' targetID' = QueryIDRequestPayload { queryTargetID = targetID', queryLBestNodes = maybe (fromIntegral $ lNumBestNodes ns) fromIntegral lParam } -- | Send a stabilise request to provided 'RemoteNode' and, if successful, diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index fe7fa83..021b94d 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -136,7 +136,7 @@ fediChordBootstrapJoin nsSTM (joinHost, joinPort) = -- 1. get routed to placement of own ID until FOUND: -- Initialise an empty cache only with the responses from a bootstrapping node ns <- readTVarIO nsSTM - bootstrapResponse <- sendQueryIdMessage (getNid ns) ns sock + bootstrapResponse <- sendRequestTo 5000 3 (lookupMessage (getNid ns) ns Nothing) sock if bootstrapResponse == Set.empty then pure . Left $ "Bootstrapping node " <> show joinHost <> " gave no response." else do diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 26a13f8..7153aec 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -6,6 +6,7 @@ module Hash2Pub.FediChordTypes ( NodeID -- abstract, but newtype constructors cannot be hidden + , idBits , getNodeID , toNodeID , NodeState (..) @@ -380,7 +381,7 @@ lookupWrapper f fRepeat direction key rmap = then lookupWrapper fRepeat fRepeat direction newKey rmap else Nothing -- normal entries are returned - Just (_, (KeyEntry entry)) -> Just entry + Just (_, KeyEntry entry) -> Just entry Nothing -> Nothing where rMapNotEmpty :: (HasKeyID a) => RingMap a -> Bool From 2c3ef440641ab5382daa3e6f2c00d6c0b6f59f54 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 27 Jun 2020 16:06:43 +0200 Subject: [PATCH 73/88] check cache invariant for successors and lookup missing IDs first half of #30 --- src/Hash2Pub/FediChord.hs | 47 +++++++++++++++++++++++++++++++++- src/Hash2Pub/FediChordTypes.hs | 41 ----------------------------- 2 files changed, 46 insertions(+), 42 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 021b94d..59f5bfb 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -231,10 +231,55 @@ cacheVerifyThread nsSTM = forever $ do ) pong else pure () ) - + + -- check the cache invariant per slice and, if necessary, do a single lookup to the + -- middle of each slice not verifying the invariant + latestNs <- readTVarIO nsSTM + latestCache <- readTVarIO $ nodeCacheSTM latestNs + let nodesToQuery targetID = case queryLocalCache latestNs latestCache (lNumBestNodes latestNs) targetID of + FOUND node -> [node] + FORWARD nodeSet -> remoteNode <$> Set.elems nodeSet + forM_ (checkCacheSliceInvariants latestNs latestCache) (\targetID -> + forkIO $ sendQueryIdMessages targetID latestNs (Just (1 + jEntriesPerSlice latestNs)) (nodesToQuery targetID) >> pure () -- ask for 1 entry more than j because of querying the middle + ) + threadDelay $ toEnum (fromEnum maxEntryAge `div` 20) +-- | Checks the invariant of at least @jEntries@ per cache slice. +-- If this invariant does not hold, the middle of the slice is returned for +-- making lookups to that ID +checkCacheSliceInvariants :: LocalNodeState + -> NodeCache + -> [NodeID] -- ^ list of middle IDs of slices not + -- ^ fulfilling the invariant +checkCacheSliceInvariants ns = checkSuccessorSlice jEntries (getNid ns) startBound lastSucc + where + jEntries = jEntriesPerSlice ns + lastSucc = getNid <$> lastMay (successors ns) + -- start slice boundary: 1/2 key space + startBound = getNid ns + 2^(idBits - 1) + + checkSuccessorSlice :: Integral i => i -> NodeID -> NodeID -> Maybe NodeID -> NodeCache -> [NodeID] + checkSuccessorSlice _ _ _ Nothing _ = [] + checkSuccessorSlice j ownID upperBound (Just lastSuccID) cache + | (upperBound `localCompare` lastSuccID) == LT = [] + | otherwise = + let + diff = getNodeID $ upperBound - ownID + lowerBound = ownID + fromInteger (diff `div` 2) + middleID = lowerBound + fromInteger (diff `div` 4) + lookupResult = Set.map (getNid . remoteNode) $ closestCachePredecessors jEntries upperBound cache + in + -- check whether j entries are in the slice + if length lookupResult == jEntries + && all (\r -> (r `localCompare` lowerBound) == GT) lookupResult + && all (\r -> (r `localCompare` upperBound) == LT) lookupResult + then checkSuccessorSlice j ownID (lowerBound - 1) (Just lastSuccID) cache + -- if not enough entries, add the middle of the slice to list + else middleID : checkSuccessorSlice j ownID (lowerBound - 1) (Just lastSuccID) cache + + -- | Periodically send @StabiliseRequest' s to the closest neighbour nodes, until -- one responds, and get their neighbours for maintaining the own neighbour lists. diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 7153aec..459837f 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -564,47 +564,6 @@ byteStringToUInteger bs = sum $ parsedBytes 0 bs parseWithOffset 0 word = toInteger word -- a shift of 0 is always 0 parseWithOffset offset word = toInteger word * 2^(8 * offset) - - --- TODO: complete rewrite --- |checks wether the cache entries fulfill the logarithmic EpiChord invariant --- of having j entries per slice, and creates a list of necessary lookup actions. --- Should be invoked periodically. ---checkCacheSlices :: NodeState -> IO [()] ---checkCacheSlices state = case getNodeCache state of --- -- don't do anything on nodes without a cache --- Nothing -> pure [()] --- Just cache' -> checkSlice jEntries (nid state) startBound lastSucc =<< readIORef cache' --- -- TODO: do the same for predecessors --- where --- jEntries = fromMaybe 0 $ getInternals_ jEntriesPerSlice state --- lastSucc = last <$> maybeEmpty (fromMaybe [] $ getSuccessors state) --- startBound = NodeID 2^(255::Integer) + nid state --- checkSlice :: Int -> NodeID -> NodeID -> Maybe NodeID -> NodeCache -> [IO ()] --- checkSlice _ _ _ Nothing _ = [] --- checkSlice j ownID upperBound (Just lastSuccNode) cache --- | upperBound < lastSuccNode = [] --- | otherwise = --- -- continuously half the DHT namespace, take the upper part as a slice, --- -- check for existing entries in that slice and create a lookup action --- -- and recursively do this on the lower half. --- -- recursion edge case: all successors/ predecessors need to be in the --- -- first slice. --- let --- diff = getNodeID $ upperBound - ownID --- lowerBound = ownID + NodeID (diff `div` 2) --- in --- -- TODO: replace empty IO actions with actual lookups to middle of slice --- -- TODO: validate ID before adding to cache --- case Map.lookupLT upperBound cache of --- Nothing -> pure () : checkSlice j ownID lowerBound (Just lastSuccNode) cache --- Just (matchID, _) -> --- if --- matchID <= lowerBound then pure () : checkSlice j ownID lowerBound (Just lastSuccNode) cache --- else --- checkSlice j ownID lowerBound (Just lastSuccNode) cache - - -- Todo: DHT backend can learn potential initial bootstrapping points through the instances mentioned in the received AP-relay messages -- persist them on disk so they can be used for all following bootstraps From f7ed0ee8d8996e64b963dab997f7e153195321dd Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 27 Jun 2020 16:23:16 +0200 Subject: [PATCH 74/88] check cache slice invariant for predecessor slices as well closes #30 \0/ --- src/Hash2Pub/FediChord.hs | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 59f5bfb..ce8b5b9 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -253,9 +253,10 @@ checkCacheSliceInvariants :: LocalNodeState -> NodeCache -> [NodeID] -- ^ list of middle IDs of slices not -- ^ fulfilling the invariant -checkCacheSliceInvariants ns = checkSuccessorSlice jEntries (getNid ns) startBound lastSucc +checkCacheSliceInvariants ns = checkPredecessorSlice jEntries (getNid ns) startBound lastPred <> checkSuccessorSlice jEntries (getNid ns) startBound lastSucc where jEntries = jEntriesPerSlice ns + lastPred = getNid <$> lastMay (predecessors ns) lastSucc = getNid <$> lastMay (successors ns) -- start slice boundary: 1/2 key space startBound = getNid ns + 2^(idBits - 1) @@ -279,6 +280,24 @@ checkCacheSliceInvariants ns = checkSuccessorSlice jEntries (getNid ns) startBou -- if not enough entries, add the middle of the slice to list else middleID : checkSuccessorSlice j ownID (lowerBound - 1) (Just lastSuccID) cache + checkPredecessorSlice :: Integral i => i -> NodeID -> NodeID -> Maybe NodeID -> NodeCache -> [NodeID] + checkPredecessorSlice _ _ _ Nothing _ = [] + checkPredecessorSlice j ownID lowerBound (Just lastPredID) cache + | (lowerBound `localCompare` lastPredID) == GT = [] + | otherwise = + let + diff = getNodeID $ ownID - lowerBound + upperBound = ownID - fromInteger (diff `div` 2) + middleID = lowerBound + fromInteger (diff `div` 4) + lookupResult = Set.map (getNid . remoteNode) $ closestCachePredecessors jEntries upperBound cache + in + -- check whether j entries are in the slice + if length lookupResult == jEntries + && all (\r -> (r `localCompare` lowerBound) == GT) lookupResult + && all (\r -> (r `localCompare` upperBound) == LT) lookupResult + then checkPredecessorSlice j ownID (upperBound + 1) (Just lastPredID) cache + -- if not enough entries, add the middle of the slice to list + else middleID : checkPredecessorSlice j ownID (upperBound + 1) (Just lastPredID) cache -- | Periodically send @StabiliseRequest' s to the closest neighbour nodes, until From 6313a06a837df4c6f8098aa6fa840a4f3adf8f19 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 29 Jun 2020 13:41:11 +0200 Subject: [PATCH 75/88] fix time conversion for threadDelay --- src/Hash2Pub/FediChord.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index ce8b5b9..95617fc 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -243,7 +243,7 @@ cacheVerifyThread nsSTM = forever $ do forkIO $ sendQueryIdMessages targetID latestNs (Just (1 + jEntriesPerSlice latestNs)) (nodesToQuery targetID) >> pure () -- ask for 1 entry more than j because of querying the middle ) - threadDelay $ toEnum (fromEnum maxEntryAge `div` 20) + threadDelay $ 10^6 * round maxEntryAge `div` 20 -- | Checks the invariant of at least @jEntries@ per cache slice. @@ -355,7 +355,7 @@ stabiliseThread nsSTM = forever $ do ) -- TODO: make delay configurable - threadDelay (60 * 1000) + threadDelay (60 * 10^6) where -- | send a stabilise request to the n-th neighbour -- (specified by the provided getter function) and on failure retr @@ -450,7 +450,7 @@ requestMapPurge mapVar = forever $ do putMVar mapVar $ Map.filter (\entry@(RequestMapEntry _ _ ts) -> now - ts < responsePurgeAge ) rMapState - threadDelay $ fromEnum responsePurgeAge * 2000 + threadDelay $ round responsePurgeAge * 2 * 10^6 -- | Wait for messages, deserialise them, manage parts and acknowledgement status, From eab5a73ead1f0d30f0c52dfc8751f50534578ea8 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 29 Jun 2020 13:42:39 +0200 Subject: [PATCH 76/88] make sure that own node isn't added as neighbour --- src/Hash2Pub/FediChordTypes.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 459837f..6c5d357 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -243,19 +243,19 @@ instance Typeable a => Show (TQueue a) where -- | convenience function that replaces the predecessors of a 'LocalNodeState' with the k closest nodes from the provided list setPredecessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState -setPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (kNeighbours ns) . rMapFromList $ preds} +setPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (kNeighbours ns) . rMapFromList . filter ((/=) (getNid ns) . getNid) $ preds} -- | convenience function that replaces the successors of a 'LocalNodeState' with the k closest nodes from the provided list setSuccessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState -setSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeighbours ns) . rMapFromList $ succs} +setSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeighbours ns) . rMapFromList . filter ((/=) (getNid ns) . getNid) $ succs} -- | sets the predecessors of a 'LocalNodeState' to the closest k nodes of the current predecessors and the provided list, combined addPredecessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState -addPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (kNeighbours ns) . addRMapEntries preds . rMapFromList $ predecessors ns} +addPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (kNeighbours ns) . addRMapEntries preds . rMapFromList . filter ((/=) (getNid ns) . getNid) $ predecessors ns} -- | sets the successors of a 'LocalNodeState' to the closest k nodes of the current successors and the provided list, combined addSuccessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState -addSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeighbours ns) . addRMapEntries succs . rMapFromList $ successors ns} +addSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeighbours ns) . addRMapEntries succs . rMapFromList . filter ((/=) (getNid ns) . getNid) $ successors ns} -- | Class for all types that can be identified via an EpiChord key. -- Used for restricting the types a 'RingMap' can store From abbe664ca14debfe571f1e32d4d8d015d2f8d5b4 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 30 Jun 2020 00:26:26 +0200 Subject: [PATCH 77/88] fixup! make sure that own node isn't added as neighbour --- src/Hash2Pub/FediChordTypes.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 6c5d357..fbd3295 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -251,11 +251,11 @@ setSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeigh -- | sets the predecessors of a 'LocalNodeState' to the closest k nodes of the current predecessors and the provided list, combined addPredecessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState -addPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (kNeighbours ns) . addRMapEntries preds . rMapFromList . filter ((/=) (getNid ns) . getNid) $ predecessors ns} +addPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (kNeighbours ns) . addRMapEntries (filter ((/=) (getNid ns) . getNid) preds) . rMapFromList $ predecessors ns} -- | sets the successors of a 'LocalNodeState' to the closest k nodes of the current successors and the provided list, combined addSuccessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState -addSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeighbours ns) . addRMapEntries succs . rMapFromList . filter ((/=) (getNid ns) . getNid) $ successors ns} +addSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeighbours ns) . addRMapEntries (filter ((/=) (getNid ns) . getNid) succs) . rMapFromList $ successors ns} -- | Class for all types that can be identified via an EpiChord key. -- Used for restricting the types a 'RingMap' can store From 8d349212b4cb84a62ed657ac014af7a7de3470b2 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 1 Jul 2020 18:22:28 +0200 Subject: [PATCH 78/88] prevent cache invariant querying when not joined --- src/Hash2Pub/DHTProtocol.hs | 9 +++++---- src/Hash2Pub/FediChord.hs | 11 ++++++++--- 2 files changed, 13 insertions(+), 7 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 83e32d4..230f7df 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -32,6 +32,7 @@ module Hash2Pub.DHTProtocol , ackRequest , isPossibleSuccessor , isPossiblePredecessor + , isJoined , closestCachePredecessors ) where @@ -213,8 +214,8 @@ markCacheEntryAsVerified timestamp nid = RingMap . Map.adjust adjustFunc nid . g -- | uses the successor and predecessor list of a node as an indicator for whether a -- node has properly joined the DHT -isJoined_ :: LocalNodeState -> Bool -isJoined_ ns = not . all null $ [successors ns, predecessors ns] +isJoined :: LocalNodeState -> Bool +isJoined ns = not . all null $ [successors ns, predecessors ns] -- | the size limit to be used when serialising messages for sending sendMessageSize :: Num i => i @@ -260,8 +261,8 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do -- ToDo: figure out what happens if not joined QueryID -> Just <$> respondQueryID nsSTM msgSet -- only when joined - Leave -> if isJoined_ ns then Just <$> respondLeave nsSTM msgSet else pure Nothing - Stabilise -> if isJoined_ ns then Just <$> respondStabilise nsSTM msgSet else pure Nothing + Leave -> if isJoined ns then Just <$> respondLeave nsSTM msgSet else pure Nothing + Stabilise -> if isJoined ns then Just <$> respondStabilise nsSTM msgSet else pure Nothing ) -- for single part request, response starts with part number 1. For multipart requests, response starts with part number n+1. diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 95617fc..061a74f 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -253,7 +253,9 @@ checkCacheSliceInvariants :: LocalNodeState -> NodeCache -> [NodeID] -- ^ list of middle IDs of slices not -- ^ fulfilling the invariant -checkCacheSliceInvariants ns = checkPredecessorSlice jEntries (getNid ns) startBound lastPred <> checkSuccessorSlice jEntries (getNid ns) startBound lastSucc +checkCacheSliceInvariants ns + | isJoined ns = checkPredecessorSlice jEntries (getNid ns) startBound lastPred <> checkSuccessorSlice jEntries (getNid ns) startBound lastSucc + | otherwise = const [] where jEntries = jEntriesPerSlice ns lastPred = getNid <$> lastMay (predecessors ns) @@ -340,7 +342,7 @@ stabiliseThread nsSTM = forever $ do -- try looking up additional neighbours if list too short forM_ [(length $ predecessors updatedNs)..(kNeighbours updatedNs)] (\_ -> do ns' <- readTVarIO nsSTM - nextEntry <- requestQueryID ns' $ pred . getNid $ atDef (toRemoteNodeState ns') (predecessors ns') (-1) + nextEntry <- requestQueryID ns' $ pred . getNid $ lastDef (toRemoteNodeState ns') (predecessors ns') atomically $ do latestNs <- readTVar nsSTM writeTVar nsSTM $ addPredecessors [nextEntry] latestNs @@ -348,7 +350,7 @@ stabiliseThread nsSTM = forever $ do forM_ [(length $ successors updatedNs)..(kNeighbours updatedNs)] (\_ -> do ns' <- readTVarIO nsSTM - nextEntry <- requestQueryID ns' $ succ . getNid $ atDef (toRemoteNodeState ns') (successors ns') (-1) + nextEntry <- requestQueryID ns' $ succ . getNid $ lastDef (toRemoteNodeState ns') (successors ns') atomically $ do latestNs <- readTVar nsSTM writeTVar nsSTM $ addSuccessors [nextEntry] latestNs @@ -460,6 +462,9 @@ fediMessageHandler :: TQueue (BS.ByteString, SockAddr) -- ^ send queue -> LocalNodeStateSTM -- ^ acting NodeState -> IO () fediMessageHandler sendQ recvQ nsSTM = do + -- Read node state just once, assuming that all relevant data for this function does + -- not change. + -- Other functions are passed the nsSTM reference and thus can get the latest state. nsSnap <- readTVarIO nsSTM -- handling multipart messages: -- Request parts can be insert into a map (key: (sender IP against spoofing, request ID), value: timestamp + set of message parts, handle all of them when size of set == parts) before being handled. This map needs to be purged periodically by a separate thread and can be protected by an MVar for fairness. From f6481996d777a33c95d2a43dcdc7e54a4e9486f0 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Thu, 2 Jul 2020 00:54:14 +0200 Subject: [PATCH 79/88] Change default response to QueryID for unjoined nodes reason: allow unjoined nodes to find bootstrap node in local cache, while always advertising itself to incoming requests for bootstrapping. --- src/Hash2Pub/DHTProtocol.hs | 10 ++++++++-- test/FediChordSpec.hs | 18 +++++++++++++++--- 2 files changed, 23 insertions(+), 5 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 230f7df..e562b98 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -90,7 +90,9 @@ import Debug.Trace (trace) queryLocalCache :: LocalNodeState -> NodeCache -> Int -> NodeID -> QueryResponse queryLocalCache ownState nCache lBestNodes targetID -- as target ID falls between own ID and first predecessor, it is handled by this node - | targetID `isInOwnResponsibilitySlice` ownState = FOUND . toRemoteNodeState $ ownState + -- This only makes sense if the node is part of the DHT by having joined. + -- A default answer to nodes querying an unjoined node is provided by 'respondQueryID'. + | isJoined ownState && targetID `isInOwnResponsibilitySlice` ownState = FOUND . toRemoteNodeState $ ownState -- my interpretation: the "l best next hops" are the l-1 closest preceding nodes and -- the closest succeeding node (like with the p initiated parallel queries | otherwise = FORWARD $ closestSuccessor `Set.union` closestCachePredecessors (lBestNodes-1) targetID nCache @@ -296,7 +298,11 @@ respondQueryID nsSTM msgSet = do cache <- readTVar $ nodeCacheSTM nsSnap let responsePayload = QueryIDResponsePayload { - queryResult = queryLocalCache nsSnap cache (fromIntegral $ queryLBestNodes senderPayload') (queryTargetID senderPayload') + queryResult = if isJoined nsSnap + then queryLocalCache nsSnap cache (fromIntegral $ queryLBestNodes senderPayload') (queryTargetID senderPayload') + -- if not joined yet, attract responsibility for + -- all keys to make bootstrapping possible + else FOUND (toRemoteNodeState nsSnap) } queryResponseMsg = Response { requestID = requestID aRequestPart diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index 4f05e72..545c3dd 100644 --- a/test/FediChordSpec.hs +++ b/test/FediChordSpec.hs @@ -132,10 +132,11 @@ spec = do cacheWith2Entries :: NodeCache cacheWith2Entries = addCacheEntryPure 10 (RemoteCacheEntry node5 10) (addCacheEntryPure 10 (RemoteCacheEntry node2 10) emptyCache) cacheWith4Entries = addCacheEntryPure 10 (RemoteCacheEntry node3 10) (addCacheEntryPure 10 (RemoteCacheEntry node4 10) cacheWith2Entries) - it "nodes not joined provide the default answer FOUND" $ do + it "unjoined nodes should never return themselfs" $ do exampleLocalNodeAsRemote <- toRemoteNodeState <$> exampleLocalNode - queryLocalCache <$> exampleLocalNode <*> pure emptyCache <*> pure 3 <*> pure (toNodeID 2^(9::Integer)+5) `shouldReturn` FOUND exampleLocalNodeAsRemote - queryLocalCache <$> exampleLocalNode <*> pure cacheWith4Entries <*> pure 1 <*> pure (toNodeID 2342) `shouldReturn` FOUND exampleLocalNodeAsRemote + queryLocalCache <$> exampleLocalNode <*> pure emptyCache <*> pure 3 <*> pure (toNodeID 2^(9::Integer)+5) `shouldReturn` FORWARD Set.empty + (FORWARD fwSet) <- queryLocalCache <$> exampleLocalNode <*> pure cacheWith4Entries <*> pure 1 <*> (getNid <$> exampleLocalNode) + remoteNode (head $ Set.elems fwSet) `shouldBe` node4 it "joined nodes do not fall back to the default" $ queryLocalCache <$> node1 <*> pure emptyCache <*> pure 1 <*> pure (toNodeID 3) `shouldReturn` FORWARD Set.empty it "works on a cache with less entries than needed" $ do @@ -265,6 +266,17 @@ spec = do let startAt5 = serialiseMessage 600 (largeMessage {part = 5}) Map.lookup 1 startAt5 `shouldBe` Nothing part <$> (deserialiseMessage . fromJust) (Map.lookup 5 startAt5) `shouldBe` Right 5 + describe "join cache lookup" $ + it "A bootstrap cache initialised with just one node returns that one." $ do + let + bootstrapNid = toNodeID 34804191837661041451755206127000721433747285589603756490902196113256157045194 + bootstrapNode = setNid bootstrapNid exampleNodeState + bootstrapCache = addCacheEntryPure 10 (RemoteCacheEntry bootstrapNode 19) initCache + ownId = toNodeID 34804191837661041451755206127000721433707928516052624394829818586723613390165 + ownNode <- setNid ownId <$> exampleLocalNode + let (FORWARD qResult) = queryLocalCache ownNode bootstrapCache 2 ownId + remoteNode (head $ Set.elems qResult) `shouldBe` bootstrapNode + -- some example data From edf66e1b517354c22282b0c9d18461545ae6b875 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Thu, 2 Jul 2020 01:36:31 +0200 Subject: [PATCH 80/88] add som debug prints --- app/Main.hs | 1 + src/Hash2Pub/DHTProtocol.hs | 1 + src/Hash2Pub/FediChord.hs | 8 +++++++- src/Hash2Pub/FediChordTypes.hs | 2 ++ 4 files changed, 11 insertions(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index c712f55..36e79c5 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -35,6 +35,7 @@ main = do -- handle unsuccessful join putStrLn $ err <> " Error joining, start listening for incoming requests anyways" + print =<< readTVarIO thisNode wait =<< async (fediMainThreads serverSock thisNode) -- TODO: periodic retry ) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index e562b98..f431da9 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -246,6 +246,7 @@ handleIncomingRequest :: LocalNodeStateSTM -- ^ the handling -> SockAddr -- ^ source address of the request -> IO () handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do + putStrLn $ "handling incoming request: " <> show msgSet ns <- readTVarIO nsSTM -- add nodestate to cache now <- getPOSIXTime diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 061a74f..6667a3e 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -150,7 +150,6 @@ fediChordBootstrapJoin nsSTM (joinHost, joinPort) = Just (FORWARD resultset) -> foldr' (addCacheEntryPure now) cacheAcc resultset ) initCache bootstrapResponse - putStrLn "initialised bootstrap cache" fediChordJoin bootstrapCache nsSTM ) `catch` (\e -> pure . Left $ "Error at bootstrap joining: " <> displayException (e :: IOException)) @@ -192,6 +191,7 @@ maxEntryAge = 600 -- | Periodically iterate through cache, clean up expired entries and verify unverified ones cacheVerifyThread :: LocalNodeStateSTM -> IO () cacheVerifyThread nsSTM = forever $ do + putStrLn "cache verify run: begin" -- get cache (ns, cache) <- atomically $ do ns <- readTVar nsSTM @@ -239,10 +239,12 @@ cacheVerifyThread nsSTM = forever $ do let nodesToQuery targetID = case queryLocalCache latestNs latestCache (lNumBestNodes latestNs) targetID of FOUND node -> [node] FORWARD nodeSet -> remoteNode <$> Set.elems nodeSet + print $ checkCacheSliceInvariants latestNs latestCache forM_ (checkCacheSliceInvariants latestNs latestCache) (\targetID -> forkIO $ sendQueryIdMessages targetID latestNs (Just (1 + jEntriesPerSlice latestNs)) (nodesToQuery targetID) >> pure () -- ask for 1 entry more than j because of querying the middle ) + putStrLn "cache verify run: end" threadDelay $ 10^6 * round maxEntryAge `div` 20 @@ -309,6 +311,8 @@ stabiliseThread :: LocalNodeStateSTM -> IO () stabiliseThread nsSTM = forever $ do ns <- readTVarIO nsSTM + putStrLn "stabilise run: begin" + -- iterate through the same snapshot, collect potential new neighbours -- and nodes to be deleted, and modify these changes only at the end of -- each stabilise run. @@ -356,6 +360,7 @@ stabiliseThread nsSTM = forever $ do writeTVar nsSTM $ addSuccessors [nextEntry] latestNs ) + putStrLn "stabilise run: end" -- TODO: make delay configurable threadDelay (60 * 10^6) where @@ -420,6 +425,7 @@ sendThread sock sendQ = forever $ do -- | Sets up and manages the main server threads of FediChord fediMainThreads :: Socket -> LocalNodeStateSTM -> IO () fediMainThreads sock nsSTM = do + (\x -> putStrLn $ "launching threads, ns: " <> show x) =<< readTVarIO nsSTM sendQ <- newTQueueIO recvQ <- newTQueueIO -- concurrently launch all handler threads, if one of them throws an exception diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index fbd3295..660eb49 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -80,6 +80,8 @@ import qualified Network.ByteOrder as NetworkBytes import Hash2Pub.Utils +import Debug.Trace (trace) + -- define protocol constants From e06c53ff7cd334f94c8ee097ff20f4996f6b0900 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Thu, 2 Jul 2020 01:38:51 +0200 Subject: [PATCH 81/88] stylish fixes --- src/Hash2Pub/FediChord.hs | 6 +++--- test/FediChordSpec.hs | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 6667a3e..152abd9 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -231,7 +231,7 @@ cacheVerifyThread nsSTM = forever $ do ) pong else pure () ) - + -- check the cache invariant per slice and, if necessary, do a single lookup to the -- middle of each slice not verifying the invariant latestNs <- readTVarIO nsSTM @@ -243,7 +243,7 @@ cacheVerifyThread nsSTM = forever $ do forM_ (checkCacheSliceInvariants latestNs latestCache) (\targetID -> forkIO $ sendQueryIdMessages targetID latestNs (Just (1 + jEntriesPerSlice latestNs)) (nodesToQuery targetID) >> pure () -- ask for 1 entry more than j because of querying the middle ) - + putStrLn "cache verify run: end" threadDelay $ 10^6 * round maxEntryAge `div` 20 @@ -255,7 +255,7 @@ checkCacheSliceInvariants :: LocalNodeState -> NodeCache -> [NodeID] -- ^ list of middle IDs of slices not -- ^ fulfilling the invariant -checkCacheSliceInvariants ns +checkCacheSliceInvariants ns | isJoined ns = checkPredecessorSlice jEntries (getNid ns) startBound lastPred <> checkSuccessorSlice jEntries (getNid ns) startBound lastSucc | otherwise = const [] where diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index 545c3dd..1e94628 100644 --- a/test/FediChordSpec.hs +++ b/test/FediChordSpec.hs @@ -276,7 +276,7 @@ spec = do ownNode <- setNid ownId <$> exampleLocalNode let (FORWARD qResult) = queryLocalCache ownNode bootstrapCache 2 ownId remoteNode (head $ Set.elems qResult) `shouldBe` bootstrapNode - + -- some example data From bdb92411c61b71d188dfe002680abdefbe902b5b Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Thu, 2 Jul 2020 03:34:34 +0200 Subject: [PATCH 82/88] iteration limit for QueryID lookups - closes #52 --- src/Hash2Pub/DHTProtocol.hs | 13 ++++++++----- src/Hash2Pub/FediChord.hs | 2 +- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index f431da9..a2dd676 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -501,11 +501,15 @@ requestQueryID :: LocalNodeState -- ^ NodeState of the querying node -- TODO: deal with lookup failures requestQueryID ns targetID = do firstCacheSnapshot <- readTVarIO . nodeCacheSTM $ ns - queryIdLookupLoop firstCacheSnapshot ns targetID + -- TODO: make maxAttempts configurable + queryIdLookupLoop firstCacheSnapshot ns 50 targetID -- | like 'requestQueryID, but allows passing of a custom cache, e.g. for joining -queryIdLookupLoop :: NodeCache -> LocalNodeState -> NodeID -> IO RemoteNodeState -queryIdLookupLoop cacheSnapshot ns targetID = do +queryIdLookupLoop :: NodeCache -> LocalNodeState -> Int -> NodeID -> IO RemoteNodeState +-- return node itself as default fallback value against infinite recursion. +-- TODO: consider using an Either instead of a default value +queryIdLookupLoop _ ns 0 _ = pure $ toRemoteNodeState ns +queryIdLookupLoop cacheSnapshot ns maxAttempts targetID = do let localResult = queryLocalCache ns cacheSnapshot (lNumBestNodes ns) targetID -- FOUND can only be returned if targetID is owned by local node case localResult of @@ -522,8 +526,7 @@ queryIdLookupLoop cacheSnapshot ns targetID = do addCacheEntryPure now ) cacheSnapshot entrySet in - -- TODO: this could lead to infinite recursion on an empty cache. Consider returning the node itself as default value - queryIdLookupLoop newLCache ns targetID + queryIdLookupLoop newLCache ns (maxAttempts - 1) targetID sendQueryIdMessages :: (Integral i) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 152abd9..8337b06 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -165,7 +165,7 @@ fediChordJoin cacheSnapshot nsSTM = do ns <- readTVarIO nsSTM -- get routed to the currently responsible node, based on the response -- from the bootstrapping node - currentlyResponsible <- queryIdLookupLoop cacheSnapshot ns $ getNid ns + currentlyResponsible <- queryIdLookupLoop cacheSnapshot ns 50 $ getNid ns -- 2. then send a join to the currently responsible node joinResult <- requestJoin currentlyResponsible nsSTM case joinResult of From 7c17e3a44dff3a73314ea290c2b48a494a7c6b4d Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 4 Jul 2020 15:03:28 +0200 Subject: [PATCH 83/88] implement join-retry on new cache entries closes #42 --- app/Main.hs | 3 ++- src/Hash2Pub/FediChord.hs | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 34 insertions(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index 36e79c5..d06ae26 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -36,8 +36,9 @@ main = do putStrLn $ err <> " Error joining, start listening for incoming requests anyways" print =<< readTVarIO thisNode + -- launch thread attempting to join on new cache entries + _ <- forkIO $ joinOnNewEntriesThread thisNode wait =<< async (fediMainThreads serverSock thisNode) - -- TODO: periodic retry ) (\joinedNS -> do -- launch main eventloop with successfully joined state diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 8337b06..100ae5f 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -46,6 +46,7 @@ module Hash2Pub.FediChord ( , mkSendSocket , resolve , cacheWriter + , joinOnNewEntriesThread ) where import Control.Applicative ((<|>)) @@ -166,6 +167,7 @@ fediChordJoin cacheSnapshot nsSTM = do -- get routed to the currently responsible node, based on the response -- from the bootstrapping node currentlyResponsible <- queryIdLookupLoop cacheSnapshot ns 50 $ getNid ns + putStrLn $ "Trying to join on " <> show (getNid currentlyResponsible) -- 2. then send a join to the currently responsible node joinResult <- requestJoin currentlyResponsible nsSTM case joinResult of @@ -173,6 +175,36 @@ fediChordJoin cacheSnapshot nsSTM = do Right joinedNS -> pure . Right $ joinedNS +-- | Wait for new cache entries to appear and then try joining on them. +-- Exits after successful joining. +joinOnNewEntriesThread :: LocalNodeStateSTM -> IO () +joinOnNewEntriesThread nsSTM = loop + where + loop = do + nsSnap <- readTVarIO nsSTM + (lookupResult, cache) <- atomically $ do + cache <- readTVar $ nodeCacheSTM nsSnap + case queryLocalCache nsSnap cache 1 (getNid nsSnap) of + -- empty cache, block until cache changes and then retry + (FORWARD s) | Set.null s -> retry + result -> pure (result, cache) + case lookupResult of + -- already joined + FOUND _ -> do + print =<< readTVarIO nsSTM + pure () + -- otherwise try joining + FORWARD _ -> do + joinResult <- fediChordJoin cache nsSTM + either + -- on join failure, sleep and retry + -- TODO: make delay configurable + (const $ threadDelay (30 * 10^6) >> loop) + (const $ pure ()) + joinResult + emptyset = Set.empty -- because pattern matches don't accept qualified names + + -- | cache updater thread that waits for incoming NodeCache update instructions on -- the node's cacheWriteQueue and then modifies the NodeCache as the single writer. cacheWriter :: LocalNodeStateSTM -> IO () From e91f317a8e3346b381f85ad8380e14b4b374ddce Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sun, 5 Jul 2020 16:52:09 +0200 Subject: [PATCH 84/88] decrease logging verbosity --- app/Main.hs | 2 -- src/Hash2Pub/FediChord.hs | 2 +- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index d06ae26..eb54359 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -18,8 +18,6 @@ main = do conf <- readConfig -- ToDo: load persisted caches, bootstrapping nodes … (serverSock, thisNode) <- fediChordInit conf - print =<< readTVarIO thisNode - print serverSock -- currently no masking is necessary, as there is nothing to clean up cacheWriterThread <- forkIO $ cacheWriter thisNode -- try joining the DHT using one of the provided bootstrapping nodes diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 100ae5f..5470731 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -271,7 +271,6 @@ cacheVerifyThread nsSTM = forever $ do let nodesToQuery targetID = case queryLocalCache latestNs latestCache (lNumBestNodes latestNs) targetID of FOUND node -> [node] FORWARD nodeSet -> remoteNode <$> Set.elems nodeSet - print $ checkCacheSliceInvariants latestNs latestCache forM_ (checkCacheSliceInvariants latestNs latestCache) (\targetID -> forkIO $ sendQueryIdMessages targetID latestNs (Just (1 + jEntriesPerSlice latestNs)) (nodesToQuery targetID) >> pure () -- ask for 1 entry more than j because of querying the middle ) @@ -344,6 +343,7 @@ stabiliseThread nsSTM = forever $ do ns <- readTVarIO nsSTM putStrLn "stabilise run: begin" + print ns -- iterate through the same snapshot, collect potential new neighbours -- and nodes to be deleted, and modify these changes only at the end of From df7423ce2ea1d16f5a09c21ece5fccbdce2a6510 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sun, 5 Jul 2020 18:18:51 +0200 Subject: [PATCH 85/88] fixup! iteration limit for QueryID lookups --- src/Hash2Pub/FediChord.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 5470731..1e992bc 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -187,7 +187,7 @@ joinOnNewEntriesThread nsSTM = loop case queryLocalCache nsSnap cache 1 (getNid nsSnap) of -- empty cache, block until cache changes and then retry (FORWARD s) | Set.null s -> retry - result -> pure (result, cache) + result -> pure (result, cache) case lookupResult of -- already joined FOUND _ -> do @@ -200,7 +200,7 @@ joinOnNewEntriesThread nsSTM = loop -- on join failure, sleep and retry -- TODO: make delay configurable (const $ threadDelay (30 * 10^6) >> loop) - (const $ pure ()) + (const $ pure ()) joinResult emptyset = Set.empty -- because pattern matches don't accept qualified names From d293cc05d148ebe7b9019afffcfdab5ff44719d5 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 7 Jul 2020 17:34:42 +0200 Subject: [PATCH 86/88] data structure for RealNode holds common config and management data contributes to #56, #34, #2 --- app/Main.hs | 5 ++++- src/Hash2Pub/FediChord.hs | 25 ++++++++++++++++++------- src/Hash2Pub/FediChordTypes.hs | 17 +++++++++++++++++ test/FediChordSpec.hs | 22 ++++++++++++++++------ 4 files changed, 55 insertions(+), 14 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index eb54359..03f72f1 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -16,10 +16,13 @@ main = do -- ToDo: parse and pass config -- probably use `tomland` for that conf <- readConfig + -- TODO: first initialise 'RealNode', then the vservers -- ToDo: load persisted caches, bootstrapping nodes … (serverSock, thisNode) <- fediChordInit conf -- currently no masking is necessary, as there is nothing to clean up cacheWriterThread <- forkIO $ cacheWriter thisNode + thisNodeSnap <- readTVarIO thisNode + realNode <- readTVarIO $ parentRealNode thisNodeSnap -- try joining the DHT using one of the provided bootstrapping nodes let tryJoining (bn:bns) = do @@ -28,7 +31,7 @@ main = do Left err -> putStrLn ("join error: " <> err) >> tryJoining bns Right joined -> pure $ Right joined tryJoining [] = pure $ Left "Exhausted all bootstrap points for joining." - joinedState <- tryJoining $ confBootstrapNodes conf + joinedState <- tryJoining $ bootstrapNodes realNode either (\err -> do -- handle unsuccessful join diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 1e992bc..ba7edb4 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -41,6 +41,7 @@ module Hash2Pub.FediChord ( , fediChordJoin , fediChordBootstrapJoin , fediMainThreads + , RealNode (..) , nodeStateInit , mkServerSocket , mkSendSocket @@ -90,27 +91,36 @@ import Debug.Trace (trace) -- | initialise data structures, compute own IDs and bind to listening socket -- ToDo: load persisted state, thus this function already operates in IO fediChordInit :: FediChordConf -> IO (Socket, LocalNodeStateSTM) -fediChordInit conf = do - initialState <- nodeStateInit conf +fediChordInit initConf = do + let realNode = RealNode { + vservers = [] + , nodeConfig = initConf + , bootstrapNodes = confBootstrapNodes initConf + } + realNodeSTM <- newTVarIO realNode + initialState <- nodeStateInit realNodeSTM initialStateSTM <- newTVarIO initialState serverSock <- mkServerSocket (getIpAddr initialState) (getDhtPort initialState) pure (serverSock, initialStateSTM) -- | initialises the 'NodeState' for this local node. -- Separated from 'fediChordInit' to be usable in tests. -nodeStateInit :: FediChordConf -> IO LocalNodeState -nodeStateInit conf = do +nodeStateInit :: RealNodeSTM -> IO LocalNodeState +nodeStateInit realNodeSTM = do + realNode <- readTVarIO realNodeSTM cacheSTM <- newTVarIO initCache q <- atomically newTQueue let + conf = nodeConfig realNode + vsID = 0 containedState = RemoteNodeState { domain = confDomain conf , ipAddr = confIP conf - , nid = genNodeID (confIP conf) (confDomain conf) 0 + , nid = genNodeID (confIP conf) (confDomain conf) $ fromInteger vsID , dhtPort = toEnum $ confDhtPort conf , servicePort = 0 - , vServerID = 0 - } + , vServerID = vsID + } initialState = LocalNodeState { nodeState = containedState , nodeCacheSTM = cacheSTM @@ -121,6 +131,7 @@ nodeStateInit conf = do , lNumBestNodes = 3 , pNumParallelQueries = 2 , jEntriesPerSlice = 2 + , parentRealNode = realNodeSTM } pure initialState diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 660eb49..8351eba 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -13,6 +13,8 @@ module Hash2Pub.FediChordTypes ( , LocalNodeState (..) , LocalNodeStateSTM , RemoteNodeState (..) + , RealNode (..) + , RealNodeSTM , setSuccessors , setPredecessors , NodeCache @@ -132,6 +134,19 @@ a `localCompare` b wayForwards = getNodeID (b - a) wayBackwards = getNodeID (a - b) +-- | Data for managing the virtual server nodes of this real node. +-- Also contains shared data and config values. +-- TODO: more data structures for k-choices bookkeeping +data RealNode = RealNode + { vservers :: [LocalNodeStateSTM] + -- ^ references to all active versers + , nodeConfig :: FediChordConf + -- ^ holds the initial configuration read at program start + , bootstrapNodes :: [(String, PortNumber)] + -- ^ nodes to be used as bootstrapping points, new ones learned during operation + } + +type RealNodeSTM = TVar RealNode -- | represents a node and all its important state data RemoteNodeState = RemoteNodeState @@ -172,6 +187,8 @@ data LocalNodeState = LocalNodeState -- ^ number of parallel sent queries , jEntriesPerSlice :: Int -- ^ number of desired entries per cache slice + , parentRealNode :: RealNodeSTM + -- ^ the parent node managing this vserver instance } deriving (Show, Eq) diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index 1e94628..1cace7a 100644 --- a/test/FediChordSpec.hs +++ b/test/FediChordSpec.hs @@ -1,12 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} module FediChordSpec where +import Control.Concurrent.STM.TVar import Control.Exception -import Data.ASN1.Parse (runParseASN1) -import qualified Data.ByteString as BS -import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust, isJust) -import qualified Data.Set as Set +import Data.ASN1.Parse (runParseASN1) +import qualified Data.ByteString as BS +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust, isJust) +import qualified Data.Set as Set import Data.Time.Clock.POSIX import Network.Socket import Test.Hspec @@ -292,11 +293,20 @@ exampleNodeState = RemoteNodeState { } exampleLocalNode :: IO LocalNodeState -exampleLocalNode = nodeStateInit $ FediChordConf { +exampleLocalNode = nodeStateInit =<< (newTVarIO $ RealNode { + vservers = [] + , nodeConfig = exampleFediConf + , bootstrapNodes = confBootstrapNodes exampleFediConf + }) + + +exampleFediConf :: FediChordConf +exampleFediConf = FediChordConf { confDomain = "example.social" , confIP = exampleIp , confDhtPort = 2342 } + exampleNodeDomain :: String exampleNodeDomain = "example.social" exampleVs :: (Integral i) => i From 56ca2b53ccb723497b682b40b3e36988370f05d0 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 7 Jul 2020 18:07:01 +0200 Subject: [PATCH 87/88] refactor trying to join on any bootstrap node into own function contributes to #56 --- app/Main.hs | 11 +---------- src/Hash2Pub/FediChord.hs | 20 ++++++++++++++++++++ 2 files changed, 21 insertions(+), 10 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 03f72f1..cc93c26 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -21,17 +21,8 @@ main = do (serverSock, thisNode) <- fediChordInit conf -- currently no masking is necessary, as there is nothing to clean up cacheWriterThread <- forkIO $ cacheWriter thisNode - thisNodeSnap <- readTVarIO thisNode - realNode <- readTVarIO $ parentRealNode thisNodeSnap -- try joining the DHT using one of the provided bootstrapping nodes - let - tryJoining (bn:bns) = do - j <- fediChordBootstrapJoin thisNode bn - case j of - Left err -> putStrLn ("join error: " <> err) >> tryJoining bns - Right joined -> pure $ Right joined - tryJoining [] = pure $ Left "Exhausted all bootstrap points for joining." - joinedState <- tryJoining $ bootstrapNodes realNode + joinedState <- tryBootstrapJoining thisNode either (\err -> do -- handle unsuccessful join diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index ba7edb4..de9a462 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -40,6 +40,7 @@ module Hash2Pub.FediChord ( , fediChordInit , fediChordJoin , fediChordBootstrapJoin + , tryBootstrapJoining , fediMainThreads , RealNode (..) , nodeStateInit @@ -166,6 +167,25 @@ fediChordBootstrapJoin nsSTM (joinHost, joinPort) = ) `catch` (\e -> pure . Left $ "Error at bootstrap joining: " <> displayException (e :: IOException)) + +-- | Try joining the DHT through any of the bootstrapping nodes until it succeeds. +tryBootstrapJoining :: LocalNodeStateSTM -> IO (Either String LocalNodeStateSTM) +tryBootstrapJoining nsSTM = do + bss <- atomically $ do + nsSnap <- readTVar nsSTM + realNodeSnap <- readTVar $ parentRealNode nsSnap + pure $ bootstrapNodes realNodeSnap + tryJoining bss + where + tryJoining (bn:bns) = do + j <- fediChordBootstrapJoin nsSTM bn + case j of + Left err -> putStrLn ("join error: " <> err) >> tryJoining bns + Right joined -> pure $ Right joined + tryJoining [] = pure $ Left "Exhausted all bootstrap points for joining." + + + -- | join a node to the DHT, using the provided cache snapshot for resolving the new -- node's position. fediChordJoin :: NodeCache -- ^ a snapshot of the NodeCache to From 61ea6ed3ff90266fda46428518e4cf4de0809048 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 8 Jul 2020 01:18:44 +0200 Subject: [PATCH 88/88] Periodically contact bootstrap nodes for convergence sampling or joining closes #56 --- app/Main.hs | 1 + src/Hash2Pub/FediChord.hs | 115 +++++++++++++++++++++++---------- src/Hash2Pub/FediChordTypes.hs | 15 +++-- 3 files changed, 91 insertions(+), 40 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index cc93c26..cdfc2b3 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -50,4 +50,5 @@ readConfig = do , confDhtPort = read portString , confBootstrapNodes = [(bootstrapHost, read bootstrapPortString)] --, confStabiliseInterval = 60 + , confBootstrapSamplingInterval = 180 } diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index de9a462..2b9a2ef 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -82,6 +82,7 @@ import Network.Socket hiding (recv, recvFrom, send, sendTo) import Network.Socket.ByteString import Safe +import System.Random (randomRIO) import Hash2Pub.DHTProtocol import Hash2Pub.FediChordTypes @@ -142,30 +143,48 @@ fediChordBootstrapJoin :: LocalNodeStateSTM -- ^ the local 'NodeSta -> (String, PortNumber) -- ^ domain and port of a bootstrapping node -> IO (Either String LocalNodeStateSTM) -- ^ the joined 'NodeState' after a -- successful join, otherwise an error message -fediChordBootstrapJoin nsSTM (joinHost, joinPort) = +fediChordBootstrapJoin nsSTM bootstrapNode = do -- can be invoked multiple times with all known bootstrapping nodes until successfully joined - bracket (mkSendSocket joinHost joinPort) close (\sock -> do - putStrLn "BootstrapJoin" - -- 1. get routed to placement of own ID until FOUND: - -- Initialise an empty cache only with the responses from a bootstrapping node - ns <- readTVarIO nsSTM - bootstrapResponse <- sendRequestTo 5000 3 (lookupMessage (getNid ns) ns Nothing) sock - if bootstrapResponse == Set.empty - then pure . Left $ "Bootstrapping node " <> show joinHost <> " gave no response." - else do - now <- getPOSIXTime - -- create new cache with all returned node responses - let bootstrapCache = - -- traverse response parts - foldr' (\resp cacheAcc -> case queryResult <$> payload resp of - Nothing -> cacheAcc - Just (FOUND result1) -> addCacheEntryPure now (RemoteCacheEntry result1 now) cacheAcc - Just (FORWARD resultset) -> foldr' (addCacheEntryPure now) cacheAcc resultset - ) - initCache bootstrapResponse - fediChordJoin bootstrapCache nsSTM - ) - `catch` (\e -> pure . Left $ "Error at bootstrap joining: " <> displayException (e :: IOException)) + ns <- readTVarIO nsSTM + runExceptT $ do + -- 1. get routed to the currently responsible node + lookupResp <- liftIO $ bootstrapQueryId nsSTM bootstrapNode $ getNid ns + currentlyResponsible <- liftEither lookupResp + liftIO . putStrLn $ "Trying to join on " <> show (getNid currentlyResponsible) + -- 2. then send a join to the currently responsible node + joinResult <- liftIO $ requestJoin currentlyResponsible nsSTM + liftEither joinResult + +-- Periodically lookup own ID through a random bootstrapping node to discover and merge separated DHT clusters. +-- Unjoined try joining instead. +convergenceSampleThread :: LocalNodeStateSTM -> IO () +convergenceSampleThread nsSTM = forever $ do + nsSnap <- readTVarIO nsSTM + parentNode <- readTVarIO $ parentRealNode nsSnap + if isJoined nsSnap + then + runExceptT (do + -- joined node: choose random node, do queryIDLoop, compare result with own responsibility + let bss = bootstrapNodes parentNode + randIndex <- liftIO $ randomRIO (0, length bss - 1) + chosenNode <- maybe (throwError "invalid bootstrapping node index") pure $ atMay bss randIndex + lookupResult <- liftIO $ bootstrapQueryId nsSTM chosenNode (getNid nsSnap) + currentlyResponsible <- liftEither lookupResult + if getNid currentlyResponsible /= getNid nsSnap + -- if mismatch, stabilise on the result, else do nothing + then do + stabResult <- liftIO $ requestStabilise nsSnap currentlyResponsible + (preds, succs) <- liftEither stabResult + -- TODO: verify neighbours before adding, see #55 + liftIO . atomically $ do + ns <- readTVar nsSTM + writeTVar nsSTM $ addPredecessors preds ns + else pure () + ) >> pure () + -- unjoined node: try joining through all bootstrapping nodes + else tryBootstrapJoining nsSTM >> pure () + let delaySecs = confBootstrapSamplingInterval . nodeConfig $ parentNode + threadDelay $ delaySecs * 10^6 -- | Try joining the DHT through any of the bootstrapping nodes until it succeeds. @@ -185,19 +204,44 @@ tryBootstrapJoining nsSTM = do tryJoining [] = pure $ Left "Exhausted all bootstrap points for joining." +-- | Look up a key just based on the responses of a single bootstrapping node. +bootstrapQueryId :: LocalNodeStateSTM -> (String, PortNumber) -> NodeID -> IO (Either String RemoteNodeState) +bootstrapQueryId nsSTM (bootstrapHost, bootstrapPort) targetID = do + ns <- readTVarIO nsSTM + bootstrapResponse <- bracket (mkSendSocket bootstrapHost bootstrapPort) close ( + -- Initialise an empty cache only with the responses from a bootstrapping node + fmap Right . sendRequestTo 5000 3 (lookupMessage targetID ns Nothing) + ) + `catch` (\e -> pure . Left $ "Error at bootstrap QueryId: " <> displayException (e :: IOException)) --- | join a node to the DHT, using the provided cache snapshot for resolving the new + case bootstrapResponse of + Left err -> pure $ Left err + Right resp + | resp == Set.empty -> pure . Left $ "Bootstrapping node " <> show bootstrapHost <> " gave no response." + | otherwise -> do + now <- getPOSIXTime + -- create new cache with all returned node responses + let bootstrapCache = + -- traverse response parts + foldr' (\resp cacheAcc -> case queryResult <$> payload resp of + Nothing -> cacheAcc + Just (FOUND result1) -> addCacheEntryPure now (RemoteCacheEntry result1 now) cacheAcc + Just (FORWARD resultset) -> foldr' (addCacheEntryPure now) cacheAcc resultset + ) + initCache resp + currentlyResponsible <- queryIdLookupLoop bootstrapCache ns 50 $ getNid ns + pure $ Right currentlyResponsible + + +-- | join a node to the DHT using the global node cache -- node's position. -fediChordJoin :: NodeCache -- ^ a snapshot of the NodeCache to - -- use for ID lookup - -> LocalNodeStateSTM -- ^ the local 'NodeState' +fediChordJoin :: LocalNodeStateSTM -- ^ the local 'NodeState' -> IO (Either String LocalNodeStateSTM) -- ^ the joined 'NodeState' after a -- successful join, otherwise an error message -fediChordJoin cacheSnapshot nsSTM = do +fediChordJoin nsSTM = do ns <- readTVarIO nsSTM - -- get routed to the currently responsible node, based on the response - -- from the bootstrapping node - currentlyResponsible <- queryIdLookupLoop cacheSnapshot ns 50 $ getNid ns + -- 1. get routed to the currently responsible node + currentlyResponsible <- requestQueryID ns $ getNid ns putStrLn $ "Trying to join on " <> show (getNid currentlyResponsible) -- 2. then send a join to the currently responsible node joinResult <- requestJoin currentlyResponsible nsSTM @@ -226,7 +270,7 @@ joinOnNewEntriesThread nsSTM = loop pure () -- otherwise try joining FORWARD _ -> do - joinResult <- fediChordJoin cache nsSTM + joinResult <- fediChordJoin nsSTM either -- on join failure, sleep and retry -- TODO: make delay configurable @@ -497,9 +541,10 @@ fediMainThreads sock nsSTM = do (fediMessageHandler sendQ recvQ nsSTM) $ concurrently_ (stabiliseThread nsSTM) $ concurrently_ (cacheVerifyThread nsSTM) $ - concurrently_ - (sendThread sock sendQ) - (recvThread sock recvQ) + concurrently_ (convergenceSampleThread nsSTM) $ + concurrently_ + (sendThread sock sendQ) + (recvThread sock recvQ) -- defining this here as, for now, the RequestMap is only used by fediMessageHandler. diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 8351eba..296ebfa 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -588,11 +588,16 @@ byteStringToUInteger bs = sum $ parsedBytes 0 bs -- | configuration values used for initialising the FediChord DHT data FediChordConf = FediChordConf - { confDomain :: String - , confIP :: HostAddress6 - , confDhtPort :: Int - , confBootstrapNodes :: [(String, PortNumber)] - --, confStabiliseInterval :: Int + { confDomain :: String + -- ^ the domain/ hostname the node is reachable under + , confIP :: HostAddress6 + -- ^ IP address of outgoing packets + , confDhtPort :: Int + -- ^ listening port for the FediChord DHT + , confBootstrapNodes :: [(String, PortNumber)] + -- ^ list of potential bootstrapping nodes + , confBootstrapSamplingInterval :: Int + -- ^ pause between sampling the own ID through bootstrap nodes, in seconds } deriving (Show, Eq)