Merge pull request 'refactorRingMap' (#63) from refactorRingMap into mainline
This PR likely enables too many LanguageExtensions and could possibly be simplified, see 63. Merging this for now though as tests run through fine.
This commit is contained in:
commit
91ac4ca7e1
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module Hash2Pub.DHTProtocol
|
||||
( QueryResponse (..)
|
||||
, queryLocalCache
|
||||
|
|
@ -128,8 +130,8 @@ closestCachePredecessors remainingLookups lastID nCache
|
|||
-- 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 => a -> LocalNodeState -> Bool
|
||||
isInOwnResponsibilitySlice lookupTarget ownNs = (getKeyID <$> rMapLookupSucc (getKeyID lookupTarget) predecessorRMap) == pure (getNid ownNs)
|
||||
isInOwnResponsibilitySlice :: HasKeyID a NodeID => a -> LocalNodeState -> Bool
|
||||
isInOwnResponsibilitySlice lookupTarget ownNs = (getKeyID <$> rMapLookupSucc (getKeyID lookupTarget :: NodeID) predecessorRMap) == pure (getNid ownNs)
|
||||
where
|
||||
predecessorList = predecessors ownNs
|
||||
-- add node itself to RingMap representation, to distinguish between
|
||||
|
|
@ -137,11 +139,11 @@ isInOwnResponsibilitySlice lookupTarget ownNs = (getKeyID <$> rMapLookupSucc (ge
|
|||
predecessorRMap = addRMapEntry (toRemoteNodeState ownNs) $ rMapFromList predecessorList
|
||||
closestPredecessor = headMay predecessorList
|
||||
|
||||
isPossiblePredecessor :: HasKeyID a => a -> LocalNodeState -> Bool
|
||||
isPossiblePredecessor :: HasKeyID a NodeID => a -> LocalNodeState -> Bool
|
||||
isPossiblePredecessor = isInOwnResponsibilitySlice
|
||||
|
||||
isPossibleSuccessor :: HasKeyID a => a -> LocalNodeState -> Bool
|
||||
isPossibleSuccessor lookupTarget ownNs = (getKeyID <$> rMapLookupPred (getKeyID lookupTarget) successorRMap) == pure (getNid ownNs)
|
||||
isPossibleSuccessor :: HasKeyID a NodeID => a -> LocalNodeState -> Bool
|
||||
isPossibleSuccessor lookupTarget ownNs = (getKeyID <$> rMapLookupPred (getKeyID lookupTarget :: NodeID) successorRMap) == pure (getNid ownNs)
|
||||
where
|
||||
successorList = successors ownNs
|
||||
successorRMap = addRMapEntry (toRemoteNodeState ownNs) $ rMapFromList successorList
|
||||
|
|
|
|||
|
|
@ -1,6 +1,8 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
|
|
@ -84,6 +86,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,255 +285,47 @@ 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
|
||||
instance HasKeyID RemoteNodeState NodeID where
|
||||
getKeyID = getNid
|
||||
|
||||
instance HasKeyID a => HasKeyID (CacheEntry a) where
|
||||
instance HasKeyID a k => HasKeyID (CacheEntry a) k where
|
||||
getKeyID (CacheEntry _ obj _) = getKeyID obj
|
||||
|
||||
instance HasKeyID NodeID where
|
||||
instance HasKeyID NodeID NodeID where
|
||||
getKeyID = id
|
||||
|
||||
type NodeCacheEntry = CacheEntry RemoteNodeState
|
||||
type NodeCache = RingMap NodeCacheEntry
|
||||
type NodeCache = RingMap NodeCacheEntry NodeID
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -16,7 +16,6 @@ import qualified Data.Text as Txt
|
|||
|
||||
import qualified Network.Wai.Handler.Warp as Warp
|
||||
import Servant
|
||||
import Web.HttpApiData (showTextData)
|
||||
|
||||
import Hash2Pub.FediChord
|
||||
import Hash2Pub.ServiceTypes
|
||||
|
|
|
|||
230
src/Hash2Pub/RingMap.hs
Normal file
230
src/Hash2Pub/RingMap.hs
Normal file
|
|
@ -0,0 +1,230 @@
|
|||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module Hash2Pub.RingMap where
|
||||
|
||||
import Data.Foldable (foldr')
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe (fromJust, isJust, isNothing, mapMaybe)
|
||||
|
||||
|
||||
-- | Class for all types that can be identified via a EpiChord key.
|
||||
-- Used for restricting the types a 'RingMap' can store
|
||||
class (Eq a, Show a, Bounded k, Ord k) => HasKeyID a k where
|
||||
getKeyID :: a -> k
|
||||
|
||||
|
||||
-- | generic data structure for holding elements with a key and modular lookup
|
||||
newtype RingMap a k = RingMap { getRingMap :: (HasKeyID a k, Bounded k, Ord k) => Map.Map k (RingEntry a k) }
|
||||
|
||||
instance (HasKeyID a k, Bounded k, Ord k) => Eq (RingMap a k) where
|
||||
a == b = getRingMap a == getRingMap b
|
||||
|
||||
instance (HasKeyID a k, Bounded k, Ord k, Show k) => Show (RingMap a k) 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 k = KeyEntry a
|
||||
| ProxyEntry (k, ProxyDirection) (Maybe (RingEntry a k))
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | as a compromise, only KeyEntry components are ordered by their key
|
||||
-- while ProxyEntry components should never be tried to be ordered.
|
||||
instance (HasKeyID a k, Eq k, Ord a, Bounded k, Ord k) => Ord (RingEntry a k) where
|
||||
a `compare` b = compare (extractID a) (extractID b)
|
||||
where
|
||||
extractID :: (HasKeyID a k, Ord a, Bounded k, Ord k) => RingEntry a k -> k
|
||||
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 k
|
||||
extractRingEntry :: (HasKeyID a k, Bounded k, Ord k) => RingEntry a k -> 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 k, Bounded k, Ord k) => RingMap a k
|
||||
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 k, Bounded k, Ord k)
|
||||
=> k -- ^lookup key
|
||||
-> RingMap a k -- ^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 k, Integral i, Bounded k, Ord k)
|
||||
=> RingMap a k
|
||||
-> i
|
||||
rMapSize rmap = fromIntegral $ Map.size innerMap - oneIfEntry rmap minBound - oneIfEntry rmap maxBound
|
||||
where
|
||||
innerMap = getRingMap rmap
|
||||
oneIfEntry :: (HasKeyID a k, Integral i, Bounded k, Ord k) => RingMap a k -> k -> i
|
||||
oneIfEntry rmap' 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 k, Bounded k, Ord k, Num k)
|
||||
=> (k -> Map.Map k (RingEntry a k) -> Maybe (k, RingEntry a k))
|
||||
-> (k -> Map.Map k (RingEntry a k) -> Maybe (k, RingEntry a k))
|
||||
-> ProxyDirection
|
||||
-> k
|
||||
-> RingMap a k
|
||||
-> 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 k, Bounded k, Ord k) => RingMap a k -> 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 k, Bounded k, Ord k, Num k)
|
||||
=> k -- ^lookup key
|
||||
-> RingMap a k -- ^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 k, Bounded k, Ord k, Num k)
|
||||
=> k -- ^lookup key
|
||||
-> RingMap a k -- ^ring cache
|
||||
-> Maybe a
|
||||
rMapLookupPred = lookupWrapper Map.lookupLT Map.lookupLE Backwards
|
||||
|
||||
addRMapEntryWith :: (HasKeyID a k, Bounded k, Ord k)
|
||||
=> (RingEntry a k -> RingEntry a k -> RingEntry a k)
|
||||
-> a
|
||||
-> RingMap a k
|
||||
-> RingMap a k
|
||||
addRMapEntryWith combineFunc entry = RingMap
|
||||
. Map.insertWith combineFunc (getKeyID entry) (KeyEntry entry)
|
||||
. getRingMap
|
||||
|
||||
addRMapEntry :: (HasKeyID a k, Bounded k, Ord k)
|
||||
=> a
|
||||
-> RingMap a k
|
||||
-> RingMap a k
|
||||
addRMapEntry = addRMapEntryWith insertCombineFunction
|
||||
where
|
||||
insertCombineFunction newVal oldVal =
|
||||
case oldVal of
|
||||
ProxyEntry n _ -> ProxyEntry n (Just newVal)
|
||||
KeyEntry _ -> newVal
|
||||
|
||||
|
||||
addRMapEntries :: (Foldable t, HasKeyID a k, Bounded k, Ord k)
|
||||
=> t a
|
||||
-> RingMap a k
|
||||
-> RingMap a k
|
||||
addRMapEntries entries rmap = foldr' addRMapEntry rmap entries
|
||||
|
||||
setRMapEntries :: (Foldable t, HasKeyID a k, Bounded k, Ord k)
|
||||
=> t a
|
||||
-> RingMap a k
|
||||
setRMapEntries entries = addRMapEntries entries emptyRMap
|
||||
|
||||
deleteRMapEntry :: (HasKeyID a k, Bounded k, Ord k)
|
||||
=> k
|
||||
-> RingMap a k
|
||||
-> RingMap a k
|
||||
deleteRMapEntry nid = RingMap . Map.update modifier nid . getRingMap
|
||||
where
|
||||
modifier (ProxyEntry idPointer _) = Just (ProxyEntry idPointer Nothing)
|
||||
modifier KeyEntry {} = Nothing
|
||||
|
||||
rMapToList :: (HasKeyID a k, Bounded k, Ord k) => RingMap a k -> [a]
|
||||
rMapToList = mapMaybe extractRingEntry . Map.elems . getRingMap
|
||||
|
||||
rMapFromList :: (HasKeyID a k, Bounded k, Ord k) => [a] -> RingMap a k
|
||||
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 k, Integral i, Bounded k, Ord k)
|
||||
=> (k -> RingMap a k -> Maybe a)
|
||||
-> k
|
||||
-> i
|
||||
-> RingMap a k
|
||||
-> [a]
|
||||
-- TODO: might be more efficient with dlists
|
||||
takeRMapEntries_ getterFunc startAt num rmap = reverse $
|
||||
case getterFunc startAt rmap of
|
||||
Nothing -> []
|
||||
Just anEntry -> takeEntriesUntil rmap getterFunc (getKeyID anEntry) (getKeyID anEntry) (num-1) [anEntry]
|
||||
where
|
||||
-- for some reason, just reusing the already-bound @rmap@ and @getterFunc@
|
||||
-- variables leads to a type error, these need to be passed explicitly
|
||||
takeEntriesUntil :: (HasKeyID a k, Integral i, Bounded k, Ord k)
|
||||
=> RingMap a k
|
||||
-> (k -> RingMap a k -> Maybe a) -- getter function
|
||||
-> k
|
||||
-> k
|
||||
-> i
|
||||
-> [a]
|
||||
-> [a]
|
||||
takeEntriesUntil rmap' getterFunc' havingReached previousEntry remaining takeAcc
|
||||
| remaining <= 0 = takeAcc
|
||||
| getKeyID (fromJust $ getterFunc' previousEntry rmap') == havingReached = takeAcc
|
||||
| otherwise = let (Just gotEntry) = getterFunc' previousEntry rmap'
|
||||
in takeEntriesUntil rmap' getterFunc' havingReached (getKeyID gotEntry) (remaining-1) (gotEntry:takeAcc)
|
||||
|
||||
takeRMapPredecessors :: (HasKeyID a k, Integral i, Bounded k, Ord k, Num k)
|
||||
=> k
|
||||
-> i
|
||||
-> RingMap a k
|
||||
-> [a]
|
||||
takeRMapPredecessors = takeRMapEntries_ rMapLookupPred
|
||||
|
||||
takeRMapSuccessors :: (HasKeyID a k, Integral i, Bounded k, Ord k, Num k)
|
||||
=> k
|
||||
-> i
|
||||
-> RingMap a k
|
||||
-> [a]
|
||||
takeRMapSuccessors = takeRMapEntries_ rMapLookupSucc
|
||||
|
||||
-- clean up cache entries: once now - entry > maxAge
|
||||
-- transfer difference now - entry to other node
|
||||
|
||||
|
||||
Loading…
Reference in a new issue