refactorRingMap #63
|
@ -46,7 +46,7 @@ category: Network
|
||||||
extra-source-files: CHANGELOG.md
|
extra-source-files: CHANGELOG.md
|
||||||
|
|
||||||
common deps
|
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
|
ghc-options: -Wall
|
||||||
|
|
||||||
|
|
||||||
|
@ -55,7 +55,7 @@ library
|
||||||
import: deps
|
import: deps
|
||||||
|
|
||||||
-- Modules exported by the library.
|
-- 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.
|
-- Modules included in this library but not exported.
|
||||||
other-modules: Hash2Pub.Utils
|
other-modules: Hash2Pub.Utils
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
|
||||||
module Hash2Pub.DHTProtocol
|
module Hash2Pub.DHTProtocol
|
||||||
( QueryResponse (..)
|
( QueryResponse (..)
|
||||||
, queryLocalCache
|
, queryLocalCache
|
||||||
|
@ -128,8 +130,8 @@ closestCachePredecessors remainingLookups lastID nCache
|
||||||
-- Looks up the successor of the lookup key on a 'RingMap' representation of the
|
-- 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
|
-- predecessor list with the node itself added. If the result is the same as the node
|
||||||
-- itself then it falls into the responsibility interval.
|
-- itself then it falls into the responsibility interval.
|
||||||
isInOwnResponsibilitySlice :: HasKeyID a => a -> LocalNodeState -> Bool
|
isInOwnResponsibilitySlice :: HasKeyID a NodeID => a -> LocalNodeState -> Bool
|
||||||
isInOwnResponsibilitySlice lookupTarget ownNs = (getKeyID <$> rMapLookupSucc (getKeyID lookupTarget) predecessorRMap) == pure (getNid ownNs)
|
isInOwnResponsibilitySlice lookupTarget ownNs = (getKeyID <$> rMapLookupSucc (getKeyID lookupTarget :: NodeID) predecessorRMap) == pure (getNid ownNs)
|
||||||
where
|
where
|
||||||
predecessorList = predecessors ownNs
|
predecessorList = predecessors ownNs
|
||||||
-- add node itself to RingMap representation, to distinguish between
|
-- 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
|
predecessorRMap = addRMapEntry (toRemoteNodeState ownNs) $ rMapFromList predecessorList
|
||||||
closestPredecessor = headMay predecessorList
|
closestPredecessor = headMay predecessorList
|
||||||
|
|
||||||
isPossiblePredecessor :: HasKeyID a => a -> LocalNodeState -> Bool
|
isPossiblePredecessor :: HasKeyID a NodeID => a -> LocalNodeState -> Bool
|
||||||
isPossiblePredecessor = isInOwnResponsibilitySlice
|
isPossiblePredecessor = isInOwnResponsibilitySlice
|
||||||
|
|
||||||
isPossibleSuccessor :: HasKeyID a => a -> LocalNodeState -> Bool
|
isPossibleSuccessor :: HasKeyID a NodeID => a -> LocalNodeState -> Bool
|
||||||
isPossibleSuccessor lookupTarget ownNs = (getKeyID <$> rMapLookupPred (getKeyID lookupTarget) successorRMap) == pure (getNid ownNs)
|
isPossibleSuccessor lookupTarget ownNs = (getKeyID <$> rMapLookupPred (getKeyID lookupTarget :: NodeID) successorRMap) == pure (getNid ownNs)
|
||||||
where
|
where
|
||||||
successorList = successors ownNs
|
successorList = successors ownNs
|
||||||
successorRMap = addRMapEntry (toRemoteNodeState ownNs) $ rMapFromList successorList
|
successorRMap = addRMapEntry (toRemoteNodeState ownNs) $ rMapFromList successorList
|
||||||
|
|
|
@ -1,6 +1,8 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE DerivingStrategies #-}
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
|
||||||
|
@ -84,6 +86,7 @@ import Data.Typeable (Typeable (..), typeOf)
|
||||||
import Data.Word
|
import Data.Word
|
||||||
import qualified Network.ByteOrder as NetworkBytes
|
import qualified Network.ByteOrder as NetworkBytes
|
||||||
|
|
||||||
|
import Hash2Pub.RingMap
|
||||||
import Hash2Pub.Utils
|
import Hash2Pub.Utils
|
||||||
|
|
||||||
import Debug.Trace (trace)
|
import Debug.Trace (trace)
|
||||||
|
@ -282,255 +285,47 @@ addPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (
|
||||||
addSuccessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState
|
addSuccessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState
|
||||||
addSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeighbours ns) . addRMapEntries (filter ((/=) (getNid ns) . getNid) succs) . rMapFromList $ successors ns}
|
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.
|
instance HasKeyID RemoteNodeState NodeID where
|
||||||
-- 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
|
getKeyID = getNid
|
||||||
|
|
||||||
instance HasKeyID a => HasKeyID (CacheEntry a) where
|
instance HasKeyID a k => HasKeyID (CacheEntry a) k where
|
||||||
getKeyID (CacheEntry _ obj _) = getKeyID obj
|
getKeyID (CacheEntry _ obj _) = getKeyID obj
|
||||||
|
|
||||||
instance HasKeyID NodeID where
|
instance HasKeyID NodeID NodeID where
|
||||||
getKeyID = id
|
getKeyID = id
|
||||||
|
|
||||||
type NodeCacheEntry = CacheEntry RemoteNodeState
|
type NodeCacheEntry = CacheEntry RemoteNodeState
|
||||||
type NodeCache = RingMap NodeCacheEntry
|
type NodeCache = RingMap NodeCacheEntry NodeID
|
||||||
|
|
||||||
type LookupCacheEntry = CacheEntry (String, PortNumber)
|
type LookupCacheEntry = CacheEntry (String, PortNumber)
|
||||||
type LookupCache = Map.Map NodeID LookupCacheEntry
|
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
|
-- | 'RingEntry' type for usage as a node cache
|
||||||
data CacheEntry a = CacheEntry Bool a POSIXTime
|
data CacheEntry a = CacheEntry Bool a POSIXTime
|
||||||
deriving (Show, Eq)
|
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
|
--- useful function for getting entries for a full cache transfer
|
||||||
nodeCacheEntries :: NodeCache -> [NodeCacheEntry]
|
nodeCacheEntries :: NodeCache -> [NodeCacheEntry]
|
||||||
nodeCacheEntries = mapMaybe extractRingEntry . Map.elems . getRingMap
|
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 :: NodeCache
|
||||||
initCache = emptyRMap
|
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
|
cacheLookup :: NodeID -- ^lookup key
|
||||||
-> NodeCache -- ^lookup cache
|
-> NodeCache -- ^lookup cache
|
||||||
-> Maybe NodeCacheEntry
|
-> Maybe NodeCacheEntry
|
||||||
cacheLookup = rMapLookup
|
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
|
cacheLookupSucc :: NodeID -- ^lookup key
|
||||||
-> NodeCache -- ^ring cache
|
-> NodeCache -- ^ring cache
|
||||||
-> Maybe NodeCacheEntry
|
-> Maybe NodeCacheEntry
|
||||||
cacheLookupSucc = rMapLookupSucc
|
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
|
cacheLookupPred :: NodeID -- ^lookup key
|
||||||
-> NodeCache -- ^ring cache
|
-> NodeCache -- ^ring cache
|
||||||
-> Maybe NodeCacheEntry
|
-> Maybe NodeCacheEntry
|
||||||
cacheLookupPred = rMapLookupPred
|
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
|
-- | return the @NodeState@ data from a cache entry without checking its validation status
|
||||||
cacheGetNodeStateUnvalidated :: CacheEntry RemoteNodeState -> RemoteNodeState
|
cacheGetNodeStateUnvalidated :: CacheEntry RemoteNodeState -> RemoteNodeState
|
||||||
cacheGetNodeStateUnvalidated (CacheEntry _ nState _) = nState
|
cacheGetNodeStateUnvalidated (CacheEntry _ nState _) = nState
|
||||||
|
|
|
@ -16,7 +16,6 @@ import qualified Data.Text as Txt
|
||||||
|
|
||||||
import qualified Network.Wai.Handler.Warp as Warp
|
import qualified Network.Wai.Handler.Warp as Warp
|
||||||
import Servant
|
import Servant
|
||||||
import Web.HttpApiData (showTextData)
|
|
||||||
|
|
||||||
import Hash2Pub.FediChord
|
import Hash2Pub.FediChord
|
||||||
import Hash2Pub.ServiceTypes
|
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