src/Hash2Pub/PostService.hs

@@ -272,13 +272,8 @@ tagDelivery serv hashtag posts = do
             pure ()
     pure $ "Received a postID for tag " <> hashtag
 
-tagSubscribe :: DHT d => PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Integer
+tagSubscribe :: PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Integer
 tagSubscribe serv hashtag origin = do
-    responsible <- liftIO $ isResponsibleFor (baseDHT serv) (genKeyID . Txt.unpack $ hashtag)
-    if not responsible
-       -- GONE if not responsible
-       then throwError err410 { errBody = "not responsible for this tag" }
-       else pure ()
     originURL <- maybe
         (throwError $ err400 { errBody = "Missing Origin header" })
         pure
@@ -291,13 +286,8 @@ tagSubscribe serv hashtag origin = do
     pure $ round leaseTime
 
 
-tagUnsubscribe :: DHT d => PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Txt.Text
+tagUnsubscribe :: PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Txt.Text
 tagUnsubscribe serv hashtag origin = do
-    responsible <- liftIO $ isResponsibleFor (baseDHT serv) (genKeyID . Txt.unpack $ hashtag)
-    if not responsible
-       -- GONE if not responsible
-       then throwError err410 { errBody = "not responsible for this tag" }
-       else pure ()
     originURL <- maybe
         (throwError $ err400 { errBody = "Missing Origin header" })
         pure
@@ -369,45 +359,15 @@ clientDeliverSubscriptions serv fromTag toTag (toHost, toPort) = do
 clientSubscribeTo :: DHT d => PostService d -> Hashtag -> IO (Either String Integer)
 clientSubscribeTo serv tag = do
     lookupRes <- lookupKey (baseDHT serv) (Txt.unpack tag)
-    doSubscribe lookupRes True
-  where
-      doSubscribe lookupResponse allowRetry = maybe
-          (pure . Left $ "No node found")
-          (\(foundHost, foundPort) -> do
-              let origin = "http://" <> Txt.pack (confServiceHost $ serviceConf serv) <> ":" <> Txt.pack (show (getListeningPortFromService serv :: Integer))
-              resp <- runClientM (tagSubscribeClient tag (Just origin)) (mkClientEnv (httpMan serv) (BaseUrl Http foundHost (fromIntegral foundPort) ""))
-              case resp of
-                Left (FailureResponse _ fresp)
-                  |(HTTPT.statusCode . responseStatusCode $ fresp) == 410 && allowRetry -> do  -- responsibility gone, force new lookup
-                      newRes <- forceLookupKey (baseDHT serv) (Txt.unpack tag)
-                      doSubscribe newRes False
-                Left err    -> pure . Left . show $ err
-                Right lease -> pure . Right $ lease
-          )
-          lookupResponse
-
-
--- | Unsubscribe the client from the given hashtag.
-clientUnsubscribeFrom :: DHT d => PostService d -> Hashtag -> IO (Either String ())
-clientUnsubscribeFrom serv tag = do
-    lookupRes <- lookupKey (baseDHT serv) (Txt.unpack tag)
-    doUnsubscribe lookupRes True
-  where
-      doUnsubscribe lookupResponse allowRetry = maybe
-          (pure . Left $ "No node found")
-          (\(foundHost, foundPort) -> do
-              let origin = "http://" <> Txt.pack (confServiceHost $ serviceConf serv) <> ":" <> Txt.pack (show (getListeningPortFromService serv :: Integer))
-              resp <- runClientM (tagUnsubscribeClient tag (Just origin)) (mkClientEnv (httpMan serv) (BaseUrl Http foundHost (fromIntegral foundPort) ""))
-              case resp of
-                Left (FailureResponse _ fresp)
-                  |(HTTPT.statusCode . responseStatusCode $ fresp) == 410 && allowRetry -> do  -- responsibility gone, force new lookup
-                      newRes <- forceLookupKey (baseDHT serv) (Txt.unpack tag)
-                      doUnsubscribe newRes False
-                Left err    -> pure . Left . show $ err
-                Right _ -> pure . Right $ ()
-          )
-          lookupResponse
-
+    maybe
+        (pure . Left $ "No node found")
+        (\(foundHost, foundPort) -> do
+            resp <- runClientM (tagSubscribeClient tag (Just . fromString . confServiceHost . serviceConf $ serv)) (mkClientEnv (httpMan serv) (BaseUrl Http foundHost (fromIntegral foundPort) ""))
+            case resp of
+              Left err    -> pure . Left . show $ err
+              Right lease -> pure . Right $ lease
+        )
+        lookupRes
 
 -- currently this is unused code
 getClients :: String -> Int -> HTTP.Manager -> Client IO PostServiceAPI