diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs index 99a9efb..15901e0 100644 --- a/src/Hash2Pub/PostService.hs +++ b/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