server endpoint for tag subscription

src/Hash2Pub/FediChordTypes.hs

@@ -430,7 +430,7 @@ instance Hashable.Hashable NodeID where
     hash = Hashable.hash . getNodeID
 
 data ServiceConf = ServiceConf
-    { confSubscriptionExpiryTime :: Integer
+    { confSubscriptionExpiryTime :: POSIXTime
     -- ^ subscription lease expiration in seconds
     , confServicePort            :: Int
     -- ^ listening port for service

src/Hash2Pub/PostService.hs

@@ -16,7 +16,8 @@ import           Control.Concurrent.STM.TQueue
 import           Control.Concurrent.STM.TVar
 import           Control.Monad                 (foldM, forM_, forever)
 import           Control.Monad.IO.Class        (liftIO)
-import qualified Data.ByteString.Lazy.UTF8     as BSU
+import qualified Data.ByteString.Lazy.UTF8     as BSUL
+import qualified Data.ByteString.UTF8          as BSU
 import qualified Data.HashMap.Strict           as HMap
 import qualified Data.HashSet                  as HSet
 import           Data.Maybe                    (fromMaybe, isJust)
@@ -26,6 +27,7 @@ import           Data.Text.Normalize           (NormalizationMode (NFC),
                                                 normalize)
 import           Data.Time.Clock.POSIX
 import           Data.Typeable                 (Typeable)
+import qualified Network.HTTP.Client           as HTTP
 import           System.Random
 
 import qualified Network.Wai.Handler.Warp      as Warp
@@ -235,7 +237,18 @@ tagDelivery serv hashtag posts = do
     pure $ "Received a postID for tag " <> hashtag
 
 tagSubscribe :: PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Integer
-tagSubscribe serv hashtag origin = pure 42
+tagSubscribe serv hashtag origin = do
+    originURL <- maybe
+        (throwError $ err400 { errBody = "Missing Origin header" })
+        pure
+        origin
+    req <- HTTP.parseUrlThrow (Txt.unpack originURL)
+    now <- liftIO getPOSIXTime
+    let leaseTime = now + confSubscriptionExpiryTime (serviceConf serv)
+    -- setup subscription entry
+    _ <- liftIO . atomically $ setupSubscriberChannel (subscribers serv) hashtag (BSU.toString $ HTTP.host req, HTTP.port req) leaseTime
+    pure $ round leaseTime
+
 
 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
@@ -310,7 +323,7 @@ normaliseTag = Txt.fromStrict . normalize NFC . Txt.toStrict
 -- 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
-    mimeRender _ = BSU.fromString . show
+    mimeRender _ = BSUL.fromString . show
 
 
 -- ====== worker threads ======