refactorRingMap #63
					 5 changed files with 246 additions and 220 deletions
				
			
		|  | @ -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…
	
	Add table
		Add a link
		
	
		Reference in a new issue