schmittlauch/Hash2Pub
1
0
Fork 1
Code Issues 47 Pull requests Releases Wiki Activity

unsubsribe from tag

Browse source
This commit is contained in:
Trolli Schmittlauch 2020-08-13 23:50:33 +02:00
parent 402378a78b
commit bf277c5a73
1 changed files with 28 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

29
src/Hash2Pub/PostService.hs
View file

@ -291,8 +291,13 @@ tagSubscribe serv hashtag origin = do
pure $ round leaseTime pure $ round leaseTime
tagUnsubscribe :: PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Txt.Text tagUnsubscribe :: DHT d => PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Txt.Text
tagUnsubscribe serv hashtag origin = do 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 originURL <- maybe
(throwError $ err400 { errBody = "Missing Origin header" }) (throwError $ err400 { errBody = "Missing Origin header" })
pure pure
@ -382,6 +387,28 @@ clientSubscribeTo serv tag = do
lookupResponse 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
-- currently this is unused code -- currently this is unused code
getClients :: String -> Int -> HTTP.Manager -> Client IO PostServiceAPI getClients :: String -> Int -> HTTP.Manager -> Client IO PostServiceAPI
getClients hostname' port' httpMan = hoistClient clientAPI getClients hostname' port' httpMan = hoistClient clientAPI