313 lines
13 KiB
Haskell
313 lines
13 KiB
Haskell
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
|
|
module Hash2Pub.RingMap where
|
|
|
|
import Data.Foldable (foldr')
|
|
import qualified Data.Map.Strict as Map
|
|
import Data.Maybe (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 k a where
|
|
getKeyID :: a -> k
|
|
keyValuePair :: a -> (k, a)
|
|
keyValuePair val = (getKeyID val, val)
|
|
|
|
|
|
-- | generic data structure for holding elements with a key and modular lookup
|
|
newtype RingMap k a = RingMap { getRingMap :: (Bounded k, Ord k) => Map.Map k (RingEntry k a) }
|
|
|
|
instance (Bounded k, Ord k, Eq a) => Eq (RingMap k a) where
|
|
a == b = getRingMap a == getRingMap b
|
|
|
|
instance (Bounded k, Ord k, Show k, Show a) => Show (RingMap k a) where
|
|
show rmap = shows ("RingMap " :: String) (show $ getRingMap rmap)
|
|
|
|
|
|
instance (Bounded k, Ord k) => Functor (RingMap k) where
|
|
-- | map a function over all payload values of a 'RingMap'
|
|
fmap f = RingMap . Map.map traversingF . getRingMap
|
|
where
|
|
traversingF (KeyEntry a) = KeyEntry (f a)
|
|
traversingF (ProxyEntry pointer (Just entry)) = ProxyEntry pointer (Just $ traversingF entry)
|
|
traversingF (ProxyEntry pointer Nothing) = ProxyEntry pointer Nothing
|
|
|
|
|
|
instance (Bounded k, Ord k) => Foldable (RingMap k) where
|
|
foldr f initVal = Map.foldr traversingFR initVal . getRingMap
|
|
where
|
|
traversingFR (KeyEntry a) acc = f a acc
|
|
traversingFR (ProxyEntry _ Nothing) acc = acc
|
|
traversingFR (ProxyEntry _ (Just entry)) acc = traversingFR entry acc
|
|
foldl f initVal = Map.foldl traversingFL initVal . getRingMap
|
|
where
|
|
traversingFL acc (KeyEntry a) = f acc a
|
|
traversingFL acc (ProxyEntry _ Nothing) = acc
|
|
traversingFL acc (ProxyEntry _ (Just entry)) = traversingFL acc entry
|
|
|
|
instance (Bounded k, Ord k) => Traversable (RingMap k) where
|
|
traverse f = fmap RingMap . traverse traversingF . getRingMap
|
|
where
|
|
traversingF (KeyEntry entry) = KeyEntry <$> f entry
|
|
traversingF (ProxyEntry to Nothing) = pure $ ProxyEntry to Nothing
|
|
traversingF (ProxyEntry to (Just entry)) = ProxyEntry to . Just <$> traversingF entry
|
|
|
|
|
|
-- | 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 k a = KeyEntry a
|
|
| ProxyEntry (k, ProxyDirection) (Maybe (RingEntry k a))
|
|
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 k a, Eq k, Ord a, Bounded k, Ord k) => Ord (RingEntry k a) where
|
|
a `compare` b = compare (extractID a) (extractID b)
|
|
where
|
|
extractID :: (HasKeyID k a, Ord a, Bounded k, Ord k) => RingEntry k a -> 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 k a
|
|
extractRingEntry :: (Bounded k, Ord k) => RingEntry k a -> Maybe a
|
|
extractRingEntry (KeyEntry entry) = Just entry
|
|
extractRingEntry (ProxyEntry _ (Just (KeyEntry entry))) = Just entry
|
|
extractRingEntry _ = Nothing
|
|
|
|
-- | An empty 'RingMap' needs to be initialised with 2 proxy entries,
|
|
-- linking the modular name space together by connecting @minBound@ and @maxBound@
|
|
emptyRMap :: (Bounded k, Ord k) => RingMap k a
|
|
emptyRMap = RingMap . Map.fromList $ proxyEntry <$> [(maxBound, (minBound, Forwards)), (minBound, (maxBound, Backwards))]
|
|
where
|
|
proxyEntry (from,to) = (from, ProxyEntry to Nothing)
|
|
|
|
-- | Maybe returns the entry stored at given key
|
|
rMapLookup :: (Bounded k, Ord k)
|
|
=> k -- ^lookup key
|
|
-> RingMap k a -- ^lookup cache
|
|
-> Maybe a
|
|
rMapLookup key rmap = extractRingEntry =<< Map.lookup key (getRingMap rmap)
|
|
|
|
-- | returns number of present 'KeyEntry' in a properly initialised 'RingMap'
|
|
rMapSize :: (Integral i, Bounded k, Ord k)
|
|
=> RingMap k a
|
|
-> i
|
|
rMapSize rmap = fromIntegral $ Map.size innerMap - oneIfEntry rmap minBound - oneIfEntry rmap maxBound
|
|
where
|
|
innerMap = getRingMap rmap
|
|
oneIfEntry :: (Integral i, Bounded k, Ord k) => RingMap k a -> k -> i
|
|
oneIfEntry rmap' nid
|
|
| isNothing (rMapLookup nid rmap') = 1
|
|
| otherwise = 0
|
|
|
|
|
|
-- | whether the RingMap is empty (except for empty proxy entries)
|
|
nullRMap :: (Num k, Bounded k, Ord k)
|
|
=> RingMap k a
|
|
-> Bool
|
|
-- basic idea: look for a predecessor starting from the upper Map bound,
|
|
-- Nothing indicates no entry being found
|
|
nullRMap = isNothing . rMapLookupPred maxBound
|
|
|
|
|
|
-- | O(logn( Is the key a member of the RingMap?
|
|
memberRMap :: (Bounded k, Ord k)
|
|
=> k
|
|
-> RingMap k a
|
|
-> Bool
|
|
memberRMap key = isJust . rMapLookup key
|
|
|
|
-- | a wrapper around lookup functions, making the lookup redirectable by a @ProxyEntry@
|
|
-- to simulate a modular ring
|
|
lookupWrapper :: (Bounded k, Ord k, Num k)
|
|
=> (k -> Map.Map k (RingEntry k a) -> Maybe (k, RingEntry k a))
|
|
-> (k -> Map.Map k (RingEntry k a) -> Maybe (k, RingEntry k a))
|
|
-> ProxyDirection
|
|
-> k
|
|
-> RingMap k a
|
|
-> Maybe (k, a)
|
|
lookupWrapper f fRepeat direction key rmap =
|
|
case f key $ getRingMap rmap of
|
|
-- the proxy entry found holds a
|
|
Just (foundKey, ProxyEntry _ (Just (KeyEntry entry))) -> Just (foundKey, 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 (foundKey, KeyEntry entry) -> Just (foundKey, entry)
|
|
Nothing -> Nothing
|
|
where
|
|
rMapNotEmpty :: (Bounded k, Ord k) => RingMap k 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 :: (Bounded k, Ord k, Num k)
|
|
=> k -- ^lookup key
|
|
-> RingMap k a -- ^ring cache
|
|
-> Maybe (k, a)
|
|
rMapLookupSucc = lookupWrapper Map.lookupGE Map.lookupGE Forwards
|
|
|
|
-- | find the predecessor node to a given key on a modular EpiChord ring.
|
|
rMapLookupPred :: (Bounded k, Ord k, Num k)
|
|
=> k -- ^lookup key
|
|
-> RingMap k a -- ^ring cache
|
|
-> Maybe (k, a)
|
|
rMapLookupPred = lookupWrapper Map.lookupLT Map.lookupLE Backwards
|
|
|
|
addRMapEntryWith :: (Bounded k, Ord k)
|
|
=> (RingEntry k a -> RingEntry k a -> RingEntry k a) -- ^ f new_value mold_value
|
|
-> k -- ^ key
|
|
-> a -- ^ value
|
|
-> RingMap k a
|
|
-> RingMap k a
|
|
addRMapEntryWith combineFunc key entry = RingMap
|
|
. Map.insertWith combineFunc key (KeyEntry entry)
|
|
. getRingMap
|
|
|
|
addRMapEntry :: (Bounded k, Ord k)
|
|
=> k -- ^ key
|
|
-> a -- ^ value
|
|
-> RingMap k a
|
|
-> RingMap k a
|
|
addRMapEntry = addRMapEntryWith insertCombineFunction
|
|
where
|
|
insertCombineFunction newVal oldVal =
|
|
case oldVal of
|
|
ProxyEntry n _ -> ProxyEntry n (Just newVal)
|
|
KeyEntry _ -> newVal
|
|
|
|
|
|
addRMapEntries :: (Foldable t, Bounded k, Ord k)
|
|
=> t (k, a)
|
|
-> RingMap k a
|
|
-> RingMap k a
|
|
addRMapEntries entries rmap = foldr' (\(k, v) rmap' -> addRMapEntry k v rmap') rmap entries
|
|
|
|
setRMapEntries :: (Foldable t, Bounded k, Ord k)
|
|
=> t (k, a)
|
|
-> RingMap k a
|
|
setRMapEntries entries = addRMapEntries entries emptyRMap
|
|
|
|
deleteRMapEntry :: (Bounded k, Ord k)
|
|
=> k
|
|
-> RingMap k a
|
|
-> RingMap k a
|
|
deleteRMapEntry nid = RingMap . Map.update modifier nid . getRingMap
|
|
where
|
|
modifier (ProxyEntry idPointer _) = Just (ProxyEntry idPointer Nothing)
|
|
modifier KeyEntry {} = Nothing
|
|
|
|
-- TODO: rename this to elems
|
|
rMapToList :: (Bounded k, Ord k) => RingMap k a -> [a]
|
|
rMapToList = mapMaybe extractRingEntry . Map.elems . getRingMap
|
|
|
|
-- TODO: rename this to toList
|
|
rMapToListWithKeys :: (Bounded k, Ord k) => RingMap k a -> [(k, a)]
|
|
rMapToListWithKeys = Map.foldrWithKey (\k v acc ->
|
|
maybe acc (\val -> (k, val):acc) $ extractRingEntry v
|
|
)
|
|
[]
|
|
. getRingMap
|
|
|
|
rMapFromList :: (Bounded k, Ord k) => [(k, a)] -> RingMap k a
|
|
rMapFromList = setRMapEntries
|
|
|
|
|
|
-- | this just merges the underlying 'Map.Map' s and does not check whether the
|
|
-- ProxyEntry pointers are consistent, so better only create unions of
|
|
-- equal-pointered RingMaps
|
|
unionRMap :: (Bounded k, Ord k) => RingMap k a -> RingMap k a -> RingMap k a
|
|
unionRMap a b = RingMap $ Map.union (getRingMap a) (getRingMap b)
|
|
|
|
-- | 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_ :: (Integral i, Bounded k, Ord k)
|
|
=> (k -> RingMap k a -> Maybe (k, a)) -- ^ parameterisable getter function to determine lookup direction
|
|
-> k -- ^ starting key
|
|
-> i -- ^ number of maximum values to take
|
|
-> RingMap k a
|
|
-> [a] -- ^ values taken
|
|
-- TODO: might be more efficient with dlists
|
|
takeRMapEntries_ getterFunc startAt num rmap = reverse $
|
|
case getterFunc startAt rmap of
|
|
Nothing -> []
|
|
Just (foundKey, anEntry) -> takeEntriesUntil_ rmap getterFunc foundKey foundKey (Just $ num-1) [anEntry]
|
|
|
|
|
|
takeEntriesUntil_ :: (Integral i, Bounded k, Ord k)
|
|
=> RingMap k a
|
|
-> (k -> RingMap k a -> Maybe (k, a)) -- getter function
|
|
-> k -- limit value
|
|
-> k -- start value
|
|
-> Maybe i -- possible number limit
|
|
-> [a]
|
|
-> [a]
|
|
takeEntriesUntil_ _rmap' _getterFunc' _havingReached _previousEntry (Just remaining) takeAcc
|
|
-- length limit reached
|
|
| remaining <= 0 = takeAcc
|
|
takeEntriesUntil_ rmap' getterFunc' havingReached previousEntry numLimit takeAcc =
|
|
case nextEntry of
|
|
Just (fKey, gotEntry)
|
|
| fKey == havingReached -> takeAcc
|
|
| otherwise -> takeEntriesUntil_ rmap' getterFunc' havingReached fKey (fmap pred numLimit) (gotEntry:takeAcc)
|
|
Nothing -> takeAcc
|
|
where
|
|
nextEntry = getterFunc' previousEntry rmap'
|
|
|
|
|
|
takeRMapPredecessors :: (Integral i, Bounded k, Ord k, Num k)
|
|
=> k
|
|
-> i
|
|
-> RingMap k a
|
|
-> [a]
|
|
takeRMapPredecessors = takeRMapEntries_ rMapLookupPred
|
|
|
|
takeRMapSuccessors :: (Integral i, Bounded k, Ord k, Num k)
|
|
=> k
|
|
-> i
|
|
-> RingMap k a
|
|
-> [a]
|
|
takeRMapSuccessors = takeRMapEntries_ rMapLookupSucc
|
|
|
|
takeRMapPredecessorsFromTo :: (Bounded k, Ord k, Num k)
|
|
=> k -- start value for taking
|
|
-> k -- stop value for taking
|
|
-> RingMap k a
|
|
-> [a]
|
|
takeRMapPredecessorsFromTo fromVal toVal rmap = takeEntriesUntil_ rmap rMapLookupPred toVal fromVal Nothing []
|
|
|
|
takeRMapSuccessorsFromTo :: (Bounded k, Ord k, Num k)
|
|
=> k -- start value for taking
|
|
-> k -- stop value for taking
|
|
-> RingMap k a
|
|
-> [a]
|
|
takeRMapSuccessorsFromTo fromVal toVal rmap = takeEntriesUntil_ rmap rMapLookupSucc toVal fromVal Nothing []
|