From bf277c5a730f92f669929f2f015aa6b471758b59 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 13 Aug 2020 23:50:33 +0200
Subject: [PATCH] unsubsribe from tag

---
 src/Hash2Pub/PostService.hs | 29 ++++++++++++++++++++++++++++-
 1 file changed, 28 insertions(+), 1 deletion(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 26c473b..99a9efb 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -291,8 +291,13 @@ tagSubscribe serv hashtag origin = do
     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
+    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
@@ -382,6 +387,28 @@ clientSubscribeTo serv tag = do
           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
 getClients :: String -> Int -> HTTP.Manager -> Client IO PostServiceAPI
 getClients hostname' port' httpMan = hoistClient clientAPI