server endpoint for tag subscription

Hash2Pub.cabal

@@ -46,7 +46,7 @@ category:            Network
 extra-source-files:  CHANGELOG.md
 
 common deps
-  build-depends:       base ^>=4.12.0.0, containers ^>=0.6.0.1, bytestring, utf8-string ^>=1.0.1.1, network ^>=2.8.0.1, time ^>=1.8.0.2, cmdargs ^>= 0.10, cryptonite ^>= 0.25, memory, async, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms
+  build-depends:       base ^>=4.12.0.0, containers ^>=0.6.0.1, bytestring, utf8-string ^>=1.0.1.1, network ^>=2.8.0.1, time ^>=1.8.0.2, cmdargs ^>= 0.10, cryptonite ^>= 0.25, memory, async, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client
   ghc-options:         -Wall
 
 

app/Main.hs

@@ -57,7 +57,7 @@ readConfig = do
       , confMaxLookupCacheAge = 300
                            }
         sConf = ServiceConf {
-        confSubscriptionExpiryTime = 2*3600 `div` read speedup
+        confSubscriptionExpiryTime = fromIntegral $ 2*3600 `div` (read speedup :: Integer)
                             , confServicePort = read servicePortString
                             , confServiceHost = confDomainString
                             }

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