schmittlauch/Hash2Pub
1
0
Fork 1
Code Issues 47 Pull requests Releases Wiki Activity

adjust code to refactored and parameterisable RingMap

Browse source 
is a bit ugly due to FlexibleContexts being neede at several places
This commit is contained in:
Trolli Schmittlauch 2020-07-25 23:34:58 +02:00
parent 9a20a60222
commit 0d1551261b
4 changed files with 43 additions and 39 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
src/Hash2Pub/DHTProtocol.hs
View file

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

10
src/Hash2Pub/FediChordTypes.hs
View file

@ -1,6 +1,8 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
@ -283,17 +285,17 @@ 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}
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

1
src/Hash2Pub/PostService.hs
View file

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

57
src/Hash2Pub/RingMap.hs
View file

@ -1,3 +1,4 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
module Hash2Pub.RingMap where
@ -7,19 +8,19 @@ import qualified Data.Map.Strict as Map
import Data.Maybe (fromJust, isJust, isNothing, mapMaybe)
-- | Class for all types that can be identified via an EpiChord key.
-- | 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) => HasKeyID a where
getKeyID :: (Bounded k, Ord k) => a -> k
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, Bounded k, Ord k) => Map.Map k (RingEntry a k) }
newtype RingMap a k = RingMap { getRingMap :: (HasKeyID a k, Bounded k, Ord k) => Map.Map k (RingEntry a k) }
instance (HasKeyID a, Bounded k, Ord k) => Eq (RingMap a k) where
instance (HasKeyID a k, Bounded k, Ord k) => Eq (RingMap a k) where
a == b = getRingMap a == getRingMap b
instance (HasKeyID a, Bounded k, Ord k, Show k) => Show (RingMap a k) where
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
@ -30,10 +31,10 @@ data RingEntry a k = KeyEntry a
-- | as a compromise, only KeyEntry components are ordered by their key
-- while ProxyEntry components should never be tried to be ordered.
instance (HasKeyID a, Eq k, Ord a, Bounded k, Ord k) => Ord (RingEntry a k) where
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, Ord a, Bounded k, Ord k) => RingEntry a k -> k
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"
@ -49,40 +50,40 @@ instance Enum ProxyDirection where
fromEnum Forwards = 1
-- | helper function for getting the a from a RingEntry a k
extractRingEntry :: (HasKeyID a, Bounded k, Ord k) => RingEntry a k -> Maybe a
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, Bounded k, Ord k) => RingMap a k
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, Bounded k, Ord k)
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, Integral i, Bounded k, Ord k)
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, Integral i, Bounded k, Ord k) => RingMap a k -> k -> i
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, Bounded k, Ord k, Num k)
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
@ -108,7 +109,7 @@ lookupWrapper f fRepeat direction key rmap =
Just (_, KeyEntry entry) -> Just entry
Nothing -> Nothing
where
rMapNotEmpty :: (HasKeyID a, Bounded k, Ord k) => RingMap a k -> Bool
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')
@ -116,20 +117,20 @@ lookupWrapper f fRepeat direction key 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, Bounded k, Ord k, Num k)
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, Bounded k, Ord k, Num k)
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, Bounded k, Ord k)
addRMapEntryWith :: (HasKeyID a k, Bounded k, Ord k)
=> (RingEntry a k -> RingEntry a k -> RingEntry a k)
-> a
-> RingMap a k
@ -138,7 +139,7 @@ addRMapEntryWith combineFunc entry = RingMap
. Map.insertWith combineFunc (getKeyID entry) (KeyEntry entry)
. getRingMap
addRMapEntry :: (HasKeyID a, Bounded k, Ord k)
addRMapEntry :: (HasKeyID a k, Bounded k, Ord k)
=> a
-> RingMap a k
-> RingMap a k
@ -150,18 +151,18 @@ addRMapEntry = addRMapEntryWith insertCombineFunction
KeyEntry _ -> newVal
addRMapEntries :: (Foldable t, HasKeyID a, Bounded k, Ord k)
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, Bounded k, Ord k)
setRMapEntries :: (Foldable t, HasKeyID a k, Bounded k, Ord k)
=> t a
-> RingMap a k
setRMapEntries entries = addRMapEntries entries emptyRMap
deleteRMapEntry :: (HasKeyID a, Bounded k, Ord k)
deleteRMapEntry :: (HasKeyID a k, Bounded k, Ord k)
=> k
-> RingMap a k
-> RingMap a k
@ -170,10 +171,10 @@ deleteRMapEntry nid = RingMap . Map.update modifier nid . getRingMap
modifier (ProxyEntry idPointer _) = Just (ProxyEntry idPointer Nothing)
modifier KeyEntry {} = Nothing
rMapToList :: (HasKeyID a, Bounded k, Ord k) => RingMap a k -> [a]
rMapToList :: (HasKeyID a k, Bounded k, Ord k) => RingMap a k -> [a]
rMapToList = mapMaybe extractRingEntry . Map.elems . getRingMap
rMapFromList :: (HasKeyID a, Bounded k, Ord k) => [a] -> RingMap a k
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
@ -181,7 +182,7 @@ rMapFromList = setRMapEntries
-- 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, Bounded k, Ord k)
takeRMapEntries_ :: (HasKeyID a k, Integral i, Bounded k, Ord k)
=> (k -> RingMap a k -> Maybe a)
-> k
-> i
@ -195,7 +196,7 @@ takeRMapEntries_ getterFunc startAt num rmap = reverse $
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, Integral i, Bounded k, Ord k)
takeEntriesUntil :: (HasKeyID a k, Integral i, Bounded k, Ord k)
=> RingMap a k
-> (k -> RingMap a k -> Maybe a) -- getter function
-> k
@ -209,14 +210,14 @@ takeRMapEntries_ getterFunc startAt num rmap = reverse $
| otherwise = let (Just gotEntry) = getterFunc' previousEntry rmap'
in takeEntriesUntil rmap' getterFunc' havingReached (getKeyID gotEntry) (remaining-1) (gotEntry:takeAcc)
takeRMapPredecessors :: (HasKeyID a, Integral i, Bounded k, Ord k, Num k)
takeRMapPredecessors :: (HasKeyID a k, Integral i, Bounded k, Ord k, Num k)
=> k
-> i
-> RingMap a k
-> [a]
takeRMapPredecessors = takeRMapEntries_ rMapLookupPred
takeRMapSuccessors :: (HasKeyID a, Integral i, Bounded k, Ord k, Num k)
takeRMapSuccessors :: (HasKeyID a k, Integral i, Bounded k, Ord k, Num k)
=> k
-> i
-> RingMap a k