refactorRingMap #63

Merged
schmittlauch merged 3 commits from refactorRingMap into mainline 2020-07-26 00:07:54 +02:00
3 changed files with 216 additions and 210 deletions
Showing only changes of commit 1ff540fd68 - Show all commits

View file

@ -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

View file

@ -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

213
src/Hash2Pub/RingMap.hs Normal file
View file

@ -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