Merge branch 'refactorSuccessorsPredecessors' into dhtNetworking
This commit is contained in:
commit
e898b80762
|
|
@ -54,15 +54,20 @@ import System.Timeout
|
|||
|
||||
import Hash2Pub.ASN1Coding
|
||||
import Hash2Pub.FediChordTypes (CacheEntry (..),
|
||||
CacheEntry (..), HasKeyID (..),
|
||||
LocalNodeState (..),
|
||||
LocalNodeStateSTM, NodeCache,
|
||||
NodeID, NodeState (..),
|
||||
RemoteNodeState (..),
|
||||
RingEntry (..), RingMap (..),
|
||||
addRMapEntry, addRMapEntryWith,
|
||||
cacheGetNodeStateUnvalidated,
|
||||
cacheLookup, cacheLookupPred,
|
||||
cacheLookupSucc, localCompare,
|
||||
localCompare, setPredecessors,
|
||||
setSuccessors)
|
||||
cacheLookupSucc, getKeyID,
|
||||
localCompare, localCompare,
|
||||
rMapFromList, rMapLookupPred,
|
||||
rMapLookupSucc,
|
||||
setPredecessors, setSuccessors)
|
||||
import Hash2Pub.ProtocolTypes
|
||||
|
||||
import Debug.Trace (trace)
|
||||
|
|
@ -74,7 +79,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
|
||||
|
|
@ -83,10 +88,10 @@ 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
|
||||
closestPredecessors = closestPredecessor (lBestNodes-1) targetID
|
||||
closestPredecessor :: (Integral n, Show n) => n -> NodeID -> Set.Set RemoteCacheEntry
|
||||
closestPredecessor 0 _ = Set.empty
|
||||
closestPredecessor remainingLookups lastID
|
||||
|
|
@ -94,10 +99,24 @@ 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)
|
||||
|
||||
-- | 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
|
||||
|
||||
-- | update or insert a 'RemoteCacheEntry' into the cache,
|
||||
|
|
@ -111,18 +130,18 @@ 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 = Map.insertWith insertCombineFunction (nid ns) (NodeEntry False ns timestamp') cache
|
||||
insertCombineFunction newVal@(NodeEntry newValidationState newNode newTimestamp) oldVal =
|
||||
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)
|
||||
NodeEntry oldValidationState _ oldTimestamp -> NodeEntry oldValidationState newNode (max oldTimestamp newTimestamp)
|
||||
KeyEntry (CacheEntry oldValidationState _ oldTimestamp) -> KeyEntry (CacheEntry oldValidationState newNode (max oldTimestamp newTimestamp))
|
||||
in
|
||||
newCache
|
||||
|
||||
|
|
@ -130,10 +149,10 @@ addCacheEntryPure now (RemoteCacheEntry ns ts) 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 +160,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
|
||||
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module Hash2Pub.FediChordTypes (
|
||||
NodeID -- abstract, but newtype constructors cannot be hidden
|
||||
|
|
@ -15,8 +16,25 @@ module Hash2Pub.FediChordTypes (
|
|||
, setPredecessors
|
||||
, NodeCache
|
||||
, CacheEntry(..)
|
||||
, RingEntry(..)
|
||||
, RingMap(..)
|
||||
, HasKeyID
|
||||
, getKeyID
|
||||
, rMapSize
|
||||
, rMapLookup
|
||||
, rMapLookupPred
|
||||
, rMapLookupSucc
|
||||
, addRMapEntry
|
||||
, addRMapEntryWith
|
||||
, takeRMapPredecessors
|
||||
, takeRMapSuccessors
|
||||
, deleteRMapEntry
|
||||
, setRMapEntries
|
||||
, rMapFromList
|
||||
, rMapToList
|
||||
, cacheGetNodeStateUnvalidated
|
||||
, initCache
|
||||
, cacheEntries
|
||||
, cacheLookup
|
||||
, cacheLookupSucc
|
||||
, cacheLookupPred
|
||||
|
|
@ -32,10 +50,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, mapMaybe)
|
||||
import Data.Maybe (fromJust, fromMaybe, isJust,
|
||||
isNothing, mapMaybe)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Time.Clock.POSIX
|
||||
import Network.Socket
|
||||
|
|
@ -150,6 +170,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
|
||||
|
|
@ -216,30 +237,58 @@ 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}
|
||||
|
||||
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 (Eq a, Show a) => HasKeyID a where
|
||||
getKeyID :: a -> NodeID
|
||||
|
||||
-- | 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)
|
||||
instance HasKeyID RemoteNodeState where
|
||||
getKeyID = getNid
|
||||
|
||||
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
|
||||
newtype RingMap a = RingMap { getRingMap :: HasKeyID a => Map.Map NodeID (RingEntry a) }
|
||||
|
||||
instance (HasKeyID a) => Eq (RingMap a) where
|
||||
a == b = getRingMap a == getRingMap b
|
||||
|
||||
instance (HasKeyID a) => Show (RingMap a) where
|
||||
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.
|
||||
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
|
||||
deriving (Show, Eq)
|
||||
|
||||
|
||||
-- | as a compromise, only KeyEntry components are ordered by their NodeID
|
||||
-- while ProxyEntry components should never be tried to be ordered.
|
||||
instance (HasKeyID a, Eq a) => Ord (RingEntry a) 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
|
||||
|
|
@ -252,34 +301,63 @@ 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 ncache = mapMaybe extractNodeEntries $ Map.elems ncache
|
||||
where
|
||||
extractNodeEntries (ProxyEntry _ possibleEntry) = possibleEntry
|
||||
cacheEntries = mapMaybe extractRingEntry . Map.elems . getRingMap
|
||||
|
||||
-- | 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@
|
||||
initCache :: NodeCache
|
||||
initCache = 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)
|
||||
|
||||
-- | Maybe returns the cache entry stored at given key
|
||||
initCache :: NodeCache
|
||||
initCache = emptyRMap
|
||||
|
||||
-- | Maybe returns the entry stored at given key
|
||||
rMapLookup :: HasKeyID a
|
||||
=> NodeID -- ^lookup key
|
||||
-> RingMap a -- ^lookup cache
|
||||
-> Maybe a
|
||||
rMapLookup key rmap = extractRingEntry =<< Map.lookup key (getRingMap rmap)
|
||||
|
||||
cacheLookup :: NodeID -- ^lookup key
|
||||
-> NodeCache -- ^lookup cache
|
||||
-> Maybe CacheEntry
|
||||
cacheLookup key cache = case Map.lookup key cache of
|
||||
Just (ProxyEntry _ result) -> result
|
||||
res -> res
|
||||
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 :: (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 (RingEntry a) -> Maybe (NodeID, RingEntry a))
|
||||
-> (NodeID -> Map.Map NodeID (RingEntry a) -> Maybe (NodeID, RingEntry 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 (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
|
||||
|
|
@ -288,40 +366,134 @@ 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 (_, (KeyEntry entry)) -> 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 :: (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')
|
||||
|
||||
-- | 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
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
-- (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
|
||||
takeEntriesUntil havingReached previousEntry remaining takeAcc
|
||||
| remaining <= 0 = takeAcc
|
||||
| getKeyID (fromJust $ getterFunc previousEntry rmap) == havingReached = takeAcc
|
||||
| otherwise = let (Just gotEntry) = getterFunc previousEntry rmap
|
||||
in takeEntriesUntil 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
|
||||
|
||||
-- | 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"
|
||||
cacheGetNodeStateUnvalidated (CacheEntry _ nState _) = nState
|
||||
|
||||
-- | converts a 'HostAddress6' IP address to a big-endian strict ByteString
|
||||
ipAddrAsBS :: HostAddress6 -> BS.ByteString
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -126,28 +127,51 @@ 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
|
||||
-- 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
|
||||
|
|
|
|||
Loading…
Reference in a new issue