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

Compare commits

base: schmittlauch:bf277c5a730f92f669929f2f015aa6b471758b59
Branches Tags
schmittlauch:mainline
schmittlauch:k-choices
schmittlauch:measurement_logging
schmittlauch:instrumentation
schmittlauch:fix_networking
schmittlauch:data_migration
schmittlauch:refactorRingMap
schmittlauch:instrumentation_prototype
..
compare: schmittlauch:e9ae258ddeec73b424528639c379c18d7c3d3e2c
Branches Tags
schmittlauch:mainline
schmittlauch:k-choices
schmittlauch:measurement_logging
schmittlauch:instrumentation
schmittlauch:fix_networking
schmittlauch:data_migration
schmittlauch:refactorRingMap
schmittlauch:instrumentation_prototype

No commits in common. "bf277c5a730f92f669929f2f015aa6b471758b59" and "e9ae258ddeec73b424528639c379c18d7c3d3e2c" have entirely different histories.
bf277c5a73 ... e9ae258dde

1 changed files with 11 additions and 51 deletions
Download patch file Download diff file Expand all files Collapse all files

50
src/Hash2Pub/PostService.hs
View file

@ -272,13 +272,8 @@ tagDelivery serv hashtag posts = do
pure () pure ()
pure $ "Received a postID for tag " <> hashtag 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 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 originURL <- maybe
(throwError $ err400 { errBody = "Missing Origin header" }) (throwError $ err400 { errBody = "Missing Origin header" })
pure pure
@ -291,13 +286,8 @@ tagSubscribe serv hashtag origin = do
pure $ round leaseTime 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 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
@ -369,45 +359,15 @@ clientDeliverSubscriptions serv fromTag toTag (toHost, toPort) = do
clientSubscribeTo :: DHT d => PostService d -> Hashtag -> IO (Either String Integer) clientSubscribeTo :: DHT d => PostService d -> Hashtag -> IO (Either String Integer)
clientSubscribeTo serv tag = do clientSubscribeTo serv tag = do
lookupRes <- lookupKey (baseDHT serv) (Txt.unpack tag) lookupRes <- lookupKey (baseDHT serv) (Txt.unpack tag)
doSubscribe lookupRes True maybe
where
doSubscribe lookupResponse allowRetry = maybe
(pure . Left $ "No node found") (pure . Left $ "No node found")
(\(foundHost, foundPort) -> do (\(foundHost, foundPort) -> do
let origin = "http://" <> Txt.pack (confServiceHost $ serviceConf serv) <> ":" <> Txt.pack (show (getListeningPortFromService serv :: Integer)) resp <- runClientM (tagSubscribeClient tag (Just . fromString . confServiceHost . serviceConf $ serv)) (mkClientEnv (httpMan serv) (BaseUrl Http foundHost (fromIntegral foundPort) ""))
resp <- runClientM (tagSubscribeClient tag (Just origin)) (mkClientEnv (httpMan serv) (BaseUrl Http foundHost (fromIntegral foundPort) ""))
case resp of 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 Left err -> pure . Left . show $ err
Right lease -> pure . Right $ lease Right lease -> pure . Right $ lease
) )
lookupResponse lookupRes
-- | 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