From 0d1551261b949e42d64297aa9462b93e334cd662 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 25 Jul 2020 23:34:58 +0200 Subject: [PATCH] adjust code to refactored and parameterisable RingMap is a bit ugly due to FlexibleContexts being neede at several places --- src/Hash2Pub/DHTProtocol.hs | 12 ++++--- src/Hash2Pub/FediChordTypes.hs | 10 +++--- src/Hash2Pub/PostService.hs | 1 - src/Hash2Pub/RingMap.hs | 59 +++++++++++++++++----------------- 4 files changed, 43 insertions(+), 39 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 9305f06..d69d94c 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -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 diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index a135e80..7652f4f 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -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 diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs index 53a840d..e8b325b 100644 --- a/src/Hash2Pub/PostService.hs +++ b/src/Hash2Pub/PostService.hs @@ -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 diff --git a/src/Hash2Pub/RingMap.hs b/src/Hash2Pub/RingMap.hs index 46aec5f..529a68b 100644 --- a/src/Hash2Pub/RingMap.hs +++ b/src/Hash2Pub/RingMap.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE RankNTypes #-} +{-# 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