diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal index 8a12e02..624cb9b 100644 --- a/Hash2Pub.cabal +++ b/Hash2Pub.cabal @@ -55,7 +55,7 @@ library import: deps -- Modules exported by the library. - exposed-modules: Hash2Pub.FediChord, Hash2Pub.FediChordTypes, Hash2Pub.DHTProtocol, Hash2Pub.ASN1Coding, Hash2Pub.ProtocolTypes, Hash2Pub.PostService + exposed-modules: Hash2Pub.FediChord, Hash2Pub.FediChordTypes, Hash2Pub.DHTProtocol, Hash2Pub.ASN1Coding, Hash2Pub.ProtocolTypes, Hash2Pub.PostService, Hash2Pub.ServiceTypes -- Modules included in this library but not exported. other-modules: Hash2Pub.Utils diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 3ff4d8e..26a373c 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} {- | Module : FediChord Description : An opinionated implementation of the EpiChord DHT by Leong et al. @@ -49,6 +51,7 @@ module Hash2Pub.FediChord ( , resolve , nodeCacheWriter , joinOnNewEntriesThread + , DHT(..) ) where import Control.Applicative ((<|>)) @@ -643,6 +646,9 @@ fediMessageHandler sendQ recvQ nsSTM = do -- ==== interface to service layer ==== +instance DHT RealNodeSTM where + lookupKey nodeSTM keystring = getKeyResponsibility nodeSTM $ genKeyID keystring + forceLookupKey nodeSTM keystring = updateLookupCache nodeSTM $ genKeyID keystring -- | Returns the hostname and port of the host responsible for a key. -- Information is provided from a cache, only on a cache miss a new DHT lookup @@ -656,15 +662,15 @@ getKeyResponsibility nodeSTM lookupKey = do case cacheResult of Just (CacheEntry _ connInfo ts) | now - ts < confMaxLookupCacheAge (nodeConfig node) -> pure (Just connInfo) - | otherwise -> updateLookupCache_ nodeSTM lookupKey - Nothing -> updateLookupCache_ nodeSTM lookupKey + | otherwise -> updateLookupCache nodeSTM lookupKey + Nothing -> updateLookupCache nodeSTM lookupKey -- | Triggers a new DHT lookup for a key, updates the lookup cache and returns the -- new entry. -- If no vserver is active in the DHT, 'Nothing' is returned. -updateLookupCache_ :: RealNodeSTM -> NodeID -> IO (Maybe (String, PortNumber)) -updateLookupCache_ nodeSTM lookupKey = do +updateLookupCache :: RealNodeSTM -> NodeID -> IO (Maybe (String, PortNumber)) +updateLookupCache nodeSTM lookupKey = do (node, lookupSource) <- atomically $ do node <- readTVar nodeSTM let firstVs = headMay (vservers node) diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index a91c369..6511db6 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -55,6 +55,7 @@ module Hash2Pub.FediChordTypes ( , ipAddrAsBS , bsAsIpAddr , FediChordConf(..) + , DHT(..) ) where import Control.Exception @@ -612,4 +613,11 @@ data FediChordConf = FediChordConf } deriving (Show, Eq) - +class DHT d where + -- | lookup the responsible host handling a given key string, + -- 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. + -- Also invalidates old cache entries. + forceLookupKey :: d -> String -> IO (Maybe (String, PortNumber)) diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs index 652be25..e654868 100644 --- a/src/Hash2Pub/PostService.hs +++ b/src/Hash2Pub/PostService.hs @@ -2,18 +2,64 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE InstanceSigs #-} + module Hash2Pub.PostService where +import Control.Concurrent 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 Servant import Web.HttpApiData (showTextData) +import Hash2Pub.FediChord +import Hash2Pub.ServiceTypes + + +data PostService d = PostService + { psPort :: Warp.Port + , psHost :: String + -- queues, other data structures + , baseDHT :: (DHT d) => d + , serviceThread :: ThreadId + } + +instance DHT d => Service PostService d where + runService dht host port = do + let + port' = fromIntegral port + warpSettings = Warp.setPort port' . Warp.setHost (fromString host) $ Warp.defaultSettings + 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 :: Application +postServiceApplication = serve exposedPostServiceAPI postServer + +servicePort = 8081 + +-- | needed for guiding type inference +exposedPostServiceAPI :: Proxy PostServiceAPI +exposedPostServiceAPI = Proxy + + + +-- ========= HTTP API and handlers ============= + 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 @@ -43,19 +89,6 @@ postServer = relayInbox :<|> tagUnsubscribe --- | needed for guiding type inference -exposedPostServiceAPI :: Proxy PostServiceAPI -exposedPostServiceAPI = Proxy - --- | return a WAI application -postServiceApplication :: Application -postServiceApplication = serve exposedPostServiceAPI postServer - -servicePort = 8081 - -runService :: IO () -runService = Warp.run servicePort postServiceApplication - relayInbox :: Txt.Text -> Handler Txt.Text relayInbox post = pure $ "Here be InboxDragons with " <> post @@ -79,7 +112,7 @@ 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 al showable types to PlainText +-- | define how to convert all showable types to PlainText -- No idea what I'm doing with these overlappable instances though ¯\_(ツ)_/¯ -- TODO: figure out how this overlapping stuff actually works https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#instance-overlap instance {-# OVERLAPPABLE #-} Show a => MimeRender PlainText a where diff --git a/src/Hash2Pub/ServiceTypes.hs b/src/Hash2Pub/ServiceTypes.hs new file mode 100644 index 0000000..ab06052 --- /dev/null +++ b/src/Hash2Pub/ServiceTypes.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +module Hash2Pub.ServiceTypes where + +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