define typeclasses for interfacing between PostService and DHT

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

src/Hash2Pub/FediChord.hs

@@ -1,7 +1,9 @@
 {-# 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
+        | 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
 -- new entry.
 -- 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 <- readTVar nodeSTM
         let firstVs = headMay (vservers node)

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

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

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