From 6142ee61d724717e6c08b2ca47ddf8d804972caf Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 16 Jun 2020 23:15:05 +0200 Subject: [PATCH] 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