define typeclasses for interfacing between PostService and DHT

This commit is contained in:
Trolli Schmittlauch 2020-07-24 22:29:43 +02:00
parent c05544aa5b
commit 1a085f2fe0
5 changed files with 80 additions and 24 deletions

View file

@ -55,7 +55,7 @@ library
import: deps import: deps
-- Modules exported by the library. -- 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. -- Modules included in this library but not exported.
other-modules: Hash2Pub.Utils other-modules: Hash2Pub.Utils

View file

@ -1,7 +1,9 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
{- | {- |
Module : FediChord Module : FediChord
Description : An opinionated implementation of the EpiChord DHT by Leong et al. Description : An opinionated implementation of the EpiChord DHT by Leong et al.
@ -49,6 +51,7 @@ module Hash2Pub.FediChord (
, resolve , resolve
, nodeCacheWriter , nodeCacheWriter
, joinOnNewEntriesThread , joinOnNewEntriesThread
, DHT(..)
) where ) where
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
@ -643,6 +646,9 @@ fediMessageHandler sendQ recvQ nsSTM = do
-- ==== interface to service layer ==== -- ==== 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. -- | 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 -- 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 case cacheResult of
Just (CacheEntry _ connInfo ts) Just (CacheEntry _ connInfo ts)
| now - ts < confMaxLookupCacheAge (nodeConfig node) -> pure (Just connInfo) | now - ts < confMaxLookupCacheAge (nodeConfig node) -> pure (Just connInfo)
| otherwise -> updateLookupCache_ nodeSTM lookupKey | otherwise -> updateLookupCache nodeSTM lookupKey
Nothing -> updateLookupCache_ nodeSTM lookupKey Nothing -> updateLookupCache nodeSTM lookupKey
-- | Triggers a new DHT lookup for a key, updates the lookup cache and returns the -- | Triggers a new DHT lookup for a key, updates the lookup cache and returns the
-- new entry. -- new entry.
-- If no vserver is active in the DHT, 'Nothing' is returned. -- If no vserver is active in the DHT, 'Nothing' is returned.
updateLookupCache_ :: RealNodeSTM -> NodeID -> IO (Maybe (String, PortNumber)) updateLookupCache :: RealNodeSTM -> NodeID -> IO (Maybe (String, PortNumber))
updateLookupCache_ nodeSTM lookupKey = do updateLookupCache nodeSTM lookupKey = do
(node, lookupSource) <- atomically $ do (node, lookupSource) <- atomically $ do
node <- readTVar nodeSTM node <- readTVar nodeSTM
let firstVs = headMay (vservers node) let firstVs = headMay (vservers node)

View file

@ -55,6 +55,7 @@ module Hash2Pub.FediChordTypes (
, ipAddrAsBS , ipAddrAsBS
, bsAsIpAddr , bsAsIpAddr
, FediChordConf(..) , FediChordConf(..)
, DHT(..)
) where ) where
import Control.Exception import Control.Exception
@ -612,4 +613,11 @@ data FediChordConf = FediChordConf
} }
deriving (Show, Eq) 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))

View file

@ -2,18 +2,64 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE InstanceSigs #-}
module Hash2Pub.PostService where module Hash2Pub.PostService where
import Control.Concurrent
import qualified Data.ByteString.Lazy.UTF8 as BSU import qualified Data.ByteString.Lazy.UTF8 as BSU
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.String (fromString)
import qualified Data.Text as Txt 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 Servant
import Web.HttpApiData (showTextData) 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 type PostServiceAPI = "relay" :> "inbox" :> ReqBody '[PlainText] Txt.Text :> PostCreated '[PlainText] Txt.Text
-- ^ delivery endpoint of newly published posts of the relay's instance -- ^ delivery endpoint of newly published posts of the relay's instance
:<|> "relay" :> "subscribers" :> ReqBody '[PlainText] Txt.Text :> Post '[PlainText] Txt.Text :<|> "relay" :> "subscribers" :> ReqBody '[PlainText] Txt.Text :> Post '[PlainText] Txt.Text
@ -43,19 +89,6 @@ postServer = relayInbox
:<|> tagUnsubscribe :<|> 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 :: Txt.Text -> Handler Txt.Text
relayInbox post = pure $ "Here be InboxDragons with " <> post 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 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 ¯\_(ツ)_/¯ -- 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 -- 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 instance {-# OVERLAPPABLE #-} Show a => MimeRender PlainText a where

View file

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