From 1ff540fd6891cd9c9b879dbc7763ceabb8a7354b Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 25 Jul 2020 01:57:38 +0200 Subject: [PATCH] refactor RingMap into own module --- Hash2Pub.cabal | 4 +- src/Hash2Pub/FediChordTypes.hs | 209 +------------------------------- src/Hash2Pub/RingMap.hs | 213 +++++++++++++++++++++++++++++++++ 3 files changed, 216 insertions(+), 210 deletions(-) create mode 100644 src/Hash2Pub/RingMap.hs diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal index 624cb9b..ebc9c7e 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, random, servant, servant-server, servant-client, warp, text, http-api-data + 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, servant, servant-server, servant-client, warp, text, unordered-containers ghc-options: -Wall @@ -55,7 +55,7 @@ library import: deps -- Modules exported by the library. - exposed-modules: Hash2Pub.FediChord, Hash2Pub.FediChordTypes, Hash2Pub.DHTProtocol, Hash2Pub.ASN1Coding, Hash2Pub.ProtocolTypes, Hash2Pub.PostService, Hash2Pub.ServiceTypes + exposed-modules: Hash2Pub.FediChord, Hash2Pub.FediChordTypes, Hash2Pub.DHTProtocol, Hash2Pub.ASN1Coding, Hash2Pub.ProtocolTypes, Hash2Pub.PostService, Hash2Pub.ServiceTypes, Hash2Pub.RingMap -- Modules included in this library but not exported. other-modules: Hash2Pub.Utils diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 6511db6..a135e80 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -84,6 +84,7 @@ import Data.Typeable (Typeable (..), typeOf) import Data.Word import qualified Network.ByteOrder as NetworkBytes +import Hash2Pub.RingMap import Hash2Pub.Utils import Debug.Trace (trace) @@ -282,11 +283,6 @@ addPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) ( addSuccessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState 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 -class (Eq a, Show a) => HasKeyID a where - getKeyID :: a -> NodeID - instance HasKeyID RemoteNodeState where getKeyID = getNid @@ -302,235 +298,32 @@ type NodeCache = RingMap NodeCacheEntry type LookupCacheEntry = CacheEntry (String, PortNumber) type LookupCache = Map.Map NodeID LookupCacheEntry --- | 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) - -- | 'RingEntry' type for usage as a node cache data CacheEntry a = CacheEntry Bool a 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 (KeyEntry e) = getKeyID e - extractID ProxyEntry{} = error "proxy entries should never appear outside of the RingMap" - -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 - --- | 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 nodeCacheEntries :: NodeCache -> [NodeCacheEntry] nodeCacheEntries = 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@ -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 = 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 NodeCacheEntry 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 - => (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 (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 - -- 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 rMapNotEmpty rmap - then lookupWrapper fRepeat fRepeat direction newKey rmap - else Nothing - -- normal entries are returned - Just (_, KeyEntry entry) -> Just entry - Nothing -> Nothing - where - 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. --- 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 NodeCacheEntry 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 - cacheLookupPred :: NodeID -- ^lookup key -> NodeCache -- ^ring cache -> Maybe NodeCacheEntry 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 -> RemoteNodeState cacheGetNodeStateUnvalidated (CacheEntry _ nState _) = nState diff --git a/src/Hash2Pub/RingMap.hs b/src/Hash2Pub/RingMap.hs new file mode 100644 index 0000000..75698d6 --- /dev/null +++ b/src/Hash2Pub/RingMap.hs @@ -0,0 +1,213 @@ +module Hash2Pub.RingMap where + + +-- | 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 + + +-- | 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 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 (KeyEntry e) = getKeyID e + extractID ProxyEntry{} = error "proxy entries should never appear outside of the RingMap" + +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 + +-- | 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 + +-- | An empty 'RingMap' needs to be initialised with 2 proxy entries, +-- linking the modular name space together by connecting @minBound@ and @maxBound@ +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 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) + +-- | 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 + => (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 (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 + -- 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 rMapNotEmpty rmap + then lookupWrapper fRepeat fRepeat direction newKey rmap + else Nothing + -- normal entries are returned + Just (_, KeyEntry entry) -> Just entry + Nothing -> Nothing + where + 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. +-- 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 + +-- | 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 + +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 + +