diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal index 56441ad..ebc9c7e 100644 --- a/Hash2Pub.cabal +++ b/Hash2Pub.cabal @@ -46,7 +46,7 @@ category: Network extra-source-files: CHANGELOG.md 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, unordered-containers, hashable, unicode-transforms + 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 diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 546c10f..d69d94c 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -130,25 +130,23 @@ 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 NodeID a => a -> LocalNodeState -> Bool -isInOwnResponsibilitySlice lookupTarget ownNs = (fst <$> rMapLookupSucc (getKeyID lookupTarget :: NodeID) 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 -- responsibility of own node and predecessor - predecessorRMap = addRMapEntry (getKeyID ownRemote) ownRemote $ rMapFromList (keyValuePair <$> predecessorList) :: RingMap NodeID RemoteNodeState - ownRemote = toRemoteNodeState ownNs + predecessorRMap = addRMapEntry (toRemoteNodeState ownNs) $ rMapFromList predecessorList closestPredecessor = headMay predecessorList -isPossiblePredecessor :: HasKeyID NodeID a => a -> LocalNodeState -> Bool +isPossiblePredecessor :: HasKeyID a NodeID => a -> LocalNodeState -> Bool isPossiblePredecessor = isInOwnResponsibilitySlice -isPossibleSuccessor :: HasKeyID NodeID a => a -> LocalNodeState -> Bool -isPossibleSuccessor lookupTarget ownNs = (fst <$> rMapLookupPred (getKeyID lookupTarget :: NodeID) 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 (getKeyID ownRemote) ownRemote $ rMapFromList (keyValuePair <$> successorList) - ownRemote = toRemoteNodeState ownNs + successorRMap = addRMapEntry (toRemoteNodeState ownNs) $ rMapFromList successorList closestSuccessor = headMay successorList -- cache operations @@ -171,8 +169,7 @@ addCacheEntryPure now (RemoteCacheEntry ns ts) cache = let -- TODO: limit diffSeconds to some maximum value to prevent malicious nodes from inserting entries valid nearly until eternity timestamp' = if ts <= now then ts else now - newEntry = CacheEntry False ns timestamp' - newCache = addRMapEntryWith insertCombineFunction (getKeyID newEntry) newEntry cache + newCache = addRMapEntryWith insertCombineFunction (CacheEntry False ns timestamp') cache insertCombineFunction newVal@(KeyEntry (CacheEntry newValidationState newNode newTimestamp)) oldVal = case oldVal of ProxyEntry n _ -> ProxyEntry n (Just newVal) @@ -205,7 +202,7 @@ addNodeAsVerifiedPure :: POSIXTime -> RemoteNodeState -> NodeCache -> NodeCache -addNodeAsVerifiedPure now node = addRMapEntry (getKeyID node) (CacheEntry True node now) +addNodeAsVerifiedPure now node = addRMapEntry (CacheEntry True node now) diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index d764b71..7652f4f 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -27,7 +26,8 @@ module Hash2Pub.FediChordTypes ( , CacheEntry(..) , RingEntry(..) , RingMap(..) - , HasKeyID(..) + , HasKeyID + , getKeyID , rMapSize , rMapLookup , rMapLookupPred @@ -271,31 +271,31 @@ instance Typeable a => Show (TQueue a) where -- | convenience function that replaces the predecessors of a 'LocalNodeState' with the k closest nodes from the provided list setPredecessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState -setPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (kNeighbours ns) . rMapFromList . fmap keyValuePair . filter ((/=) (getNid ns) . getNid) $ preds} +setPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (kNeighbours ns) . rMapFromList . filter ((/=) (getNid ns) . getNid) $ preds} -- | convenience function that replaces the successors of a 'LocalNodeState' with the k closest nodes from the provided list setSuccessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState -setSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeighbours ns) . rMapFromList . fmap keyValuePair . filter ((/=) (getNid ns) . getNid) $ succs} +setSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeighbours ns) . rMapFromList . filter ((/=) (getNid ns) . getNid) $ succs} -- | sets the predecessors of a 'LocalNodeState' to the closest k nodes of the current predecessors and the provided list, combined addPredecessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState -addPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (kNeighbours ns) . addRMapEntries (keyValuePair <$> filter ((/=) (getNid ns) . getNid) preds) . rMapFromList . fmap keyValuePair $ predecessors ns} +addPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (kNeighbours ns) . addRMapEntries (filter ((/=) (getNid ns) . getNid) preds) . rMapFromList $ predecessors ns} -- | sets the successors of a 'LocalNodeState' to the closest k nodes of the current successors and the provided list, combined addSuccessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState -addSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeighbours ns) . addRMapEntries (keyValuePair <$> filter ((/=) (getNid ns) . getNid) succs) . rMapFromList . fmap keyValuePair $ successors ns} +addSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeighbours ns) . addRMapEntries (filter ((/=) (getNid ns) . getNid) succs) . rMapFromList $ successors ns} -instance HasKeyID NodeID RemoteNodeState where +instance HasKeyID RemoteNodeState NodeID where getKeyID = getNid -instance HasKeyID k a => HasKeyID k (CacheEntry a) where +instance HasKeyID a k => HasKeyID (CacheEntry a) k where getKeyID (CacheEntry _ obj _) = getKeyID obj instance HasKeyID NodeID NodeID where getKeyID = id type NodeCacheEntry = CacheEntry RemoteNodeState -type NodeCache = RingMap NodeID NodeCacheEntry +type NodeCache = RingMap NodeCacheEntry NodeID type LookupCacheEntry = CacheEntry (String, PortNumber) type LookupCache = Map.Map NodeID LookupCacheEntry @@ -319,15 +319,12 @@ cacheLookup = rMapLookup cacheLookupSucc :: NodeID -- ^lookup key -> NodeCache -- ^ring cache -> Maybe NodeCacheEntry -cacheLookupSucc key cache = snd <$> rMapLookupSucc key cache +cacheLookupSucc = rMapLookupSucc cacheLookupPred :: NodeID -- ^lookup key -> NodeCache -- ^ring cache -> Maybe NodeCacheEntry -cacheLookupPred key cache = snd <$> rMapLookupPred key cache - --- clean up cache entries: once now - entry > maxAge --- transfer difference now - entry to other node +cacheLookupPred = rMapLookupPred -- | return the @NodeState@ data from a cache entry without checking its validation status cacheGetNodeStateUnvalidated :: CacheEntry RemoteNodeState -> RemoteNodeState @@ -413,7 +410,7 @@ data FediChordConf = FediChordConf class DHT d where -- | lookup the responsible host handling a given key string, - -- possiblggy from a lookup cache + -- possibly from a lookup cache lookupKey :: d -> String -> IO (Maybe (String, PortNumber)) -- | lookup the responsible host handling a given key string, -- but force the DHT to do a fresh lookup instead of returning a cached result. diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs index e44c8c6..e8b325b 100644 --- a/src/Hash2Pub/PostService.hs +++ b/src/Hash2Pub/PostService.hs @@ -1,100 +1,54 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE InstanceSigs #-} module Hash2Pub.PostService where import Control.Concurrent -import Control.Concurrent.STM -import Control.Concurrent.STM.TChan -import Control.Concurrent.STM.TQueue -import Control.Concurrent.STM.TVar -import Control.Monad (forM_, forever) -import Control.Monad.IO.Class (liftIO) -import qualified Data.ByteString.Lazy.UTF8 as BSU -import qualified Data.HashMap.Strict as HMap -import qualified Data.HashSet as HSet -import Data.Maybe (fromMaybe) -import Data.String (fromString) -import qualified Data.Text.Lazy as Txt -import Data.Text.Normalize (NormalizationMode (NFC), - normalize) -import Data.Time.Clock.POSIX -import System.Random +import qualified Data.ByteString.Lazy.UTF8 as BSU +import Data.Maybe (fromMaybe) +import Data.String (fromString) +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 Hash2Pub.FediChordTypes -import Hash2Pub.RingMap +import Hash2Pub.FediChord import Hash2Pub.ServiceTypes data PostService d = PostService - { psPort :: Warp.Port - , psHost :: String + { psPort :: Warp.Port + , psHost :: String -- queues, other data structures - , baseDHT :: (DHT d) => d - , serviceThread :: TVar ThreadId - , subscribers :: TVar (RingMap NodeID TagSubscribers) - -- ^ for each tag store the subscribers + their queue - , ownSubscriptions :: TVar (HMap.HashMap NodeID POSIXTime) - -- ^ tags subscribed by the own node have an assigned lease time - , ownPosts :: TVar (HSet.HashSet Txt.Text) - -- ^ just store the existence of posts for saving memory, - , relayInQueue :: TQueue (Hashtag, PostID, PostContent) - -- ^ Queue for processing incoming posts of own instance asynchronously + , baseDHT :: (DHT d) => d + , serviceThread :: ThreadId } -type Hashtag = Txt.Text -type PostID = Txt.Text -type PostContent = Txt.Text --- | For each handled tag, store its subscribers and provide a --- broadcast 'TChan' for enqueuing posts -type RelayTags = RingMap NodeID (TagSubscribers, TChan PostContent) --- | each subscriber is identified by its contact data "hostname" "port" --- and holds a TChan duplicated from the broadcast TChan of the tag -type TagSubscribers = HMap.HashMap (String, Int) (TChan PostContent) - - instance DHT d => Service PostService d where - -- | initialise 'PostService' data structures and run server runService dht host port = do - -- create necessary TVars - threadVar <- newTVarIO =<< myThreadId -- own thread ID as placeholder - subscriberVar <- newTVarIO emptyRMap - ownSubsVar <- newTVarIO HMap.empty - ownPostVar <- newTVarIO HSet.empty - relayInQueue' <- newTQueueIO let - thisService = PostService { - psPort = port' - , psHost = host - , baseDHT = dht - , serviceThread = threadVar - , subscribers = subscriberVar - , ownSubscriptions = ownSubsVar - , ownPosts = ownPostVar - , relayInQueue = relayInQueue' - } port' = fromIntegral port warpSettings = Warp.setPort port' . Warp.setHost (fromString host) $ Warp.defaultSettings - servThreadID <- forkIO $ Warp.runSettings warpSettings $ postServiceApplication thisService - -- update thread ID after fork - atomically $ writeTVar threadVar servThreadID - pure thisService - + servThread <- forkIO $ Warp.runSettings warpSettings postServiceApplication + pure $ PostService { + psPort = port' + , psHost = host + , baseDHT = dht + , serviceThread = servThread + } getServicePort s = fromIntegral $ psPort s -- | return a WAI application -postServiceApplication :: PostService d -> Application -postServiceApplication serv = serve exposedPostServiceAPI $ postServer serv +postServiceApplication :: Application +postServiceApplication = serve exposedPostServiceAPI postServer +servicePort = 8081 -- | needed for guiding type inference exposedPostServiceAPI :: Proxy PostServiceAPI @@ -104,7 +58,7 @@ exposedPostServiceAPI = Proxy -- ========= HTTP API and handlers ============= -type PostServiceAPI = "relay" :> "inbox" :> ReqBody '[PlainText] Txt.Text :> PutCreated '[PlainText] NoContent +type PostServiceAPI = "relay" :> "inbox" :> ReqBody '[PlainText] Txt.Text :> PostCreated '[PlainText] Txt.Text -- ^ delivery endpoint of newly published posts of the relay's instance :<|> "relay" :> "subscribers" :> ReqBody '[PlainText] Txt.Text :> Post '[PlainText] Txt.Text -- ^ endpoint for delivering the subscriptions and outstanding queue @@ -123,51 +77,37 @@ type PostServiceAPI = "relay" :> "inbox" :> ReqBody '[PlainText] Txt.Text :> Put -- the Origin header to $hashtag -postServer :: PostService d -> Server PostServiceAPI -postServer service = relayInbox service - :<|> subscriptionDelivery service - :<|> postFetch service - :<|> postMultiFetch service - :<|> tagDelivery service - :<|> tagSubscribe service - :<|> tagUnsubscribe service +postServer :: Server PostServiceAPI +postServer = relayInbox + :<|> subscriptionDelivery + :<|> postFetch + :<|> postMultiFetch + :<|> tagDelivery + :<|> tagSubscribe + :<|> tagUnsubscribe -relayInbox :: PostService d -> Txt.Text -> Handler NoContent -relayInbox serv post = do - -- extract contained hashtags - let - containedTags = fmap (Txt.fromStrict . normalize NFC . Txt.toStrict . Txt.tail) . filter ((==) '#' . Txt.head) . Txt.words $ post - -- generate post ID - postId <- liftIO $ Txt.pack . show <$> (randomRIO (0, 2^128-1) :: IO Integer) - -- add ID to own posts - liftIO . atomically $ modifyTVar' (ownPosts serv) (HSet.insert postId) - -- enqueue a relay job for each tag - liftIO $ forM_ (containedTags :: [Txt.Text]) (\tag -> - atomically $ writeTQueue (relayInQueue serv) (tag, postId, post) - ) - pure NoContent +relayInbox :: Txt.Text -> Handler Txt.Text +relayInbox post = pure $ "Here be InboxDragons with " <> post +subscriptionDelivery :: Txt.Text -> Handler Txt.Text +subscriptionDelivery subList = pure $ "Here be Subscription List dragons: " <> subList +postFetch :: Txt.Text -> Handler Txt.Text +postFetch postID = pure $ "Here be a post with dragon ID " <> postID -subscriptionDelivery :: PostService d -> Txt.Text -> Handler Txt.Text -subscriptionDelivery serv subList = pure $ "Here be Subscription List dragons: " <> subList - -postFetch :: PostService d -> Txt.Text -> Handler Txt.Text -postFetch serv postID = pure $ "Here be a post with dragon ID " <> postID - -postMultiFetch :: PostService d -> Txt.Text -> Handler Txt.Text -postMultiFetch serv postIDs = pure $ "Here be multiple post dragons: " +postMultiFetch :: Txt.Text -> Handler Txt.Text +postMultiFetch postIDs = pure $ "Here be multiple post dragons: " <> (Txt.unwords . Txt.lines $ postIDs) -tagDelivery :: PostService d -> Txt.Text -> Txt.Text -> Handler Txt.Text -tagDelivery serv hashtag posts = pure $ "Here be #" <> hashtag <> " dragons with " <> posts +tagDelivery :: Txt.Text -> Txt.Text -> Handler Txt.Text +tagDelivery hashtag posts = pure $ "Here be #" <> hashtag <> " dragons with " <> posts -tagSubscribe :: PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Integer -tagSubscribe serv hashtag origin = pure 42 +tagSubscribe :: Txt.Text -> Maybe Txt.Text -> Handler Integer +tagSubscribe hashtag origin = pure 42 -tagUnsubscribe :: PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Txt.Text -tagUnsubscribe serv hashtag origin = pure $ "Here be a dragon unsubscription from " <> fromMaybe "Nothing" origin <> " to " <> hashtag +tagUnsubscribe :: Txt.Text -> Maybe Txt.Text -> Handler Txt.Text +tagUnsubscribe hashtag origin = pure $ "Here be a dragon unsubscription from " <> fromMaybe "Nothing" origin <> " to " <> hashtag -- | define how to convert all showable types to PlainText diff --git a/src/Hash2Pub/RingMap.hs b/src/Hash2Pub/RingMap.hs index 016f9f1..529a68b 100644 --- a/src/Hash2Pub/RingMap.hs +++ b/src/Hash2Pub/RingMap.hs @@ -5,38 +5,36 @@ module Hash2Pub.RingMap where import Data.Foldable (foldr') import qualified Data.Map.Strict as Map -import Data.Maybe (isJust, isNothing, mapMaybe) +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 k a where +class (Eq a, Show a, Bounded k, Ord k) => HasKeyID a k 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) } +newtype RingMap a k = RingMap { getRingMap :: (HasKeyID a k, Bounded k, Ord k) => Map.Map k (RingEntry a k) } -instance (Bounded k, Ord k, Eq a) => Eq (RingMap k a) where +instance (HasKeyID a k, Bounded k, Ord k) => Eq (RingMap a k) where a == b = getRingMap a == getRingMap b -instance (Bounded k, Ord k, Show k, Show a) => Show (RingMap k a) 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 -- 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)) +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 k a, Eq k, Ord a, Bounded k, Ord k) => Ord (RingEntry k a) 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 k a, Ord a, Bounded k, Ord k) => RingEntry k a -> 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" @@ -51,51 +49,51 @@ instance Enum ProxyDirection where 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 +-- | 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 :: (Bounded k, Ord k) => RingMap k a +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 :: (Bounded k, Ord k) +rMapLookup :: (HasKeyID a k, Bounded k, Ord k) => k -- ^lookup key - -> RingMap k a -- ^lookup cache + -> 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 :: (Integral i, Bounded k, Ord k) - => RingMap k a +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 :: (Integral i, Bounded k, Ord k) => RingMap k a -> 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 :: (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)) +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 k a - -> Maybe (k, a) + -> RingMap a k + -> Maybe 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) + 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 @@ -108,10 +106,10 @@ lookupWrapper f fRepeat direction key rmap = then lookupWrapper fRepeat fRepeat direction newKey rmap else Nothing -- normal entries are returned - Just (foundKey, KeyEntry entry) -> Just (foundKey, entry) + Just (_, KeyEntry entry) -> Just entry Nothing -> Nothing where - rMapNotEmpty :: (Bounded k, Ord k) => RingMap k a -> 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') @@ -119,34 +117,32 @@ 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 :: (Bounded k, Ord k, Num k) +rMapLookupSucc :: (HasKeyID a k, Bounded k, Ord k, Num k) => k -- ^lookup key - -> RingMap k a -- ^ring cache - -> Maybe (k, a) + -> 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 :: (Bounded k, Ord k, Num k) +rMapLookupPred :: (HasKeyID a k, Bounded k, Ord k, Num k) => k -- ^lookup key - -> RingMap k a -- ^ring cache - -> Maybe (k, a) + -> RingMap a k -- ^ring cache + -> Maybe a rMapLookupPred = lookupWrapper Map.lookupLT Map.lookupLE Backwards -addRMapEntryWith :: (Bounded k, Ord k) - => (RingEntry k a -> RingEntry k a -> RingEntry k a) - -> k -- ^ key - -> a -- ^ value - -> RingMap k a - -> RingMap k a -addRMapEntryWith combineFunc key entry = RingMap - . Map.insertWith combineFunc key (KeyEntry entry) +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 :: (Bounded k, Ord k) - => k -- ^ key - -> a -- ^ value - -> RingMap k a - -> RingMap k a +addRMapEntry :: (HasKeyID a k, Bounded k, Ord k) + => a + -> RingMap a k + -> RingMap a k addRMapEntry = addRMapEntryWith insertCombineFunction where insertCombineFunction newVal oldVal = @@ -155,30 +151,30 @@ addRMapEntry = addRMapEntryWith insertCombineFunction 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 +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, Bounded k, Ord k) - => t (k, a) - -> RingMap k a +setRMapEntries :: (Foldable t, HasKeyID a k, Bounded k, Ord k) + => t a + -> RingMap a k setRMapEntries entries = addRMapEntries entries emptyRMap -deleteRMapEntry :: (Bounded k, Ord k) +deleteRMapEntry :: (HasKeyID a k, Bounded k, Ord k) => k - -> RingMap k a - -> RingMap k a + -> 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 :: (Bounded k, Ord k) => RingMap k a -> [a] +rMapToList :: (HasKeyID a k, Bounded k, Ord k) => RingMap a k -> [a] rMapToList = mapMaybe extractRingEntry . Map.elems . getRingMap -rMapFromList :: (Bounded k, Ord k) => [(k, a)] -> RingMap k a +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 @@ -186,52 +182,49 @@ 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_ :: (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 +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 (foundKey, anEntry) -> takeEntriesUntil rmap getterFunc foundKey foundKey (num-1) [anEntry] + 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 :: (Integral i, Bounded k, Ord k) - => RingMap k a - -> (k -> RingMap k a -> Maybe (k, a)) -- getter function + 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 - -- length limit reached | remaining <= 0 = takeAcc - -- - | otherwise = case nextEntry of - Just (fKey, gotEntry) - | fKey == havingReached -> takeAcc - | otherwise -> takeEntriesUntil rmap' getterFunc' havingReached fKey (remaining - 1) (gotEntry:takeAcc) - Nothing -> takeAcc - where - nextEntry = getterFunc' previousEntry rmap' + | 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 :: (Integral i, Bounded k, Ord k, Num k) +takeRMapPredecessors :: (HasKeyID a k, Integral i, Bounded k, Ord k, Num k) => k -> i - -> RingMap k a + -> RingMap a k -> [a] takeRMapPredecessors = takeRMapEntries_ rMapLookupPred -takeRMapSuccessors :: (Integral i, Bounded k, Ord k, Num k) +takeRMapSuccessors :: (HasKeyID a k, Integral i, Bounded k, Ord k, Num k) => k -> i - -> RingMap k a + -> RingMap a k -> [a] takeRMapSuccessors = takeRMapEntries_ rMapLookupSucc +-- clean up cache entries: once now - entry > maxAge +-- transfer difference now - entry to other node + + diff --git a/src/Hash2Pub/ServiceTypes.hs b/src/Hash2Pub/ServiceTypes.hs index 5e2b37c..ab06052 100644 --- a/src/Hash2Pub/ServiceTypes.hs +++ b/src/Hash2Pub/ServiceTypes.hs @@ -1,15 +1,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Hash2Pub.ServiceTypes where -import Data.Hashable (Hashable (..)) - -import Hash2Pub.FediChord (DHT (..), NodeID (..)) +import Hash2Pub.FediChord (DHT (..)) class Service s d where -- | run the service runService :: (Integral i) => d -> String -> i -> IO (s d) getServicePort :: (Integral i) => s d -> i - -instance Hashable NodeID where - hashWithSalt salt = hashWithSalt salt . getNodeID - hash = hash . getNodeID