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

View file

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

View file

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

View file

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

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