set up subscription data structures and transfer subscription endpoint

This commit is contained in:
Trolli Schmittlauch 2020-07-28 21:39:15 +02:00
parent 3b65757406
commit 970c94ff0d

View file

@ -41,7 +41,7 @@ data PostService d = PostService
-- queues, other data structures
, baseDHT :: (DHT d) => d
, serviceThread :: TVar ThreadId
, subscribers :: TVar (RingMap NodeID TagSubscribers)
, subscribers :: TVar RelayTags
-- ^ for each tag store the subscribers + their queue
, ownSubscriptions :: TVar (HMap.HashMap NodeID POSIXTime)
-- ^ tags subscribed by the own node have an assigned lease time
@ -56,10 +56,10 @@ type PostID = Txt.Text
type PostContent = Txt.Text
-- | For each handled tag, store its subscribers and provide a
-- broadcast 'TChan' for enqueuing posts
type RelayTags = RingMap NodeID (TagSubscribers, TChan PostContent)
type RelayTags = RingMap NodeID (TagSubscribers, TChan PostID, Hashtag)
-- | each subscriber is identified by its contact data "hostname" "port"
-- and holds a TChan duplicated from the broadcast TChan of the tag
type TagSubscribers = HMap.HashMap (String, Int) (TChan PostContent)
type TagSubscribers = TVar (HMap.HashMap (String, Int) (TChan PostID))
instance DHT d => Service PostService d where
@ -114,7 +114,7 @@ exposedPostServiceAPI = Proxy
type PostServiceAPI = "relay" :> "inbox" :> ReqBody '[PlainText] Txt.Text :> PutCreated '[PlainText] NoContent
-- ^ delivery endpoint of newly published posts of the relay's instance
:<|> "relay" :> "subscribers" :> ReqBody '[PlainText] Txt.Text :> Post '[PlainText] Txt.Text
:<|> "relay" :> "subscribers" :> ReqBody '[PlainText] Txt.Text :> PostNoContent '[PlainText] NoContent
-- ^ endpoint for delivering the subscriptions and outstanding queue
:<|> "post" :> Capture "postid" Txt.Text :> Get '[PlainText] Txt.Text
-- ^ fetch endpoint for posts, full post ID is http://$domain/post/$postid
@ -145,7 +145,7 @@ relayInbox :: PostService d -> Txt.Text -> Handler NoContent
relayInbox serv post = do
-- extract contained hashtags
let
containedTags = fmap (Txt.fromStrict . normalize NFC . Txt.toStrict . Txt.tail) . filter ((==) '#' . Txt.head) . Txt.words $ post
containedTags = fmap (normaliseTag . Txt.tail) . filter ((==) '#' . Txt.head) . Txt.words $ post
-- generate post ID
postId <- liftIO $ Txt.pack . show <$> (randomRIO (0, 2^128-1) :: IO Integer)
-- add ID to own posts
@ -158,8 +158,25 @@ relayInbox serv post = do
subscriptionDelivery :: PostService d -> Txt.Text -> Handler Txt.Text
subscriptionDelivery serv subList = pure $ "Here be Subscription List dragons: " <> subList
subscriptionDelivery :: PostService d -> Txt.Text -> Handler NoContent
subscriptionDelivery serv subList = do
let
tagSubs = Txt.lines subList
liftIO $ forM_ tagSubs $ processTag (subscribers serv)
pure NoContent
-- TODO: check and only accept tags in own (future?) responsibility
where
processTag :: TVar RelayTags -> Txt.Text -> IO ()
processTag subscriberSTM tagData = do
let
tag:subText:posts:_ = Txt.splitOn "," tagData
sub = read . Txt.unpack $ subText :: (String, Int)
postList = Txt.words posts
enqueueSubscriptions subscriberSTM (normaliseTag tag) sub postList
postFetch :: PostService d -> Txt.Text -> Handler Txt.Text
postFetch serv postID = pure $ "Here be a post with dragon ID " <> postID
@ -178,6 +195,49 @@ tagUnsubscribe :: PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Txt.Tex
tagUnsubscribe serv hashtag origin = pure $ "Here be a dragon unsubscription from " <> fromMaybe "Nothing" origin <> " to " <> hashtag
-- ======= data structure manipulations =========
-- | Write all pending posts of a subscriber-tag-combination to its queue.
-- Sets up all necessary data structures if they are still missing.
enqueueSubscriptions :: TVar RelayTags -- tag-subscriber map
-> Hashtag -- hashtag of pending posts
-> (String, Int) -- subscriber's connection information
-> [PostID] -- pending posts
-> IO ()
enqueueSubscriptions tagMapSTM tag subscriber posts = do
-- get the tag output queue and, if necessary, create it
subChan <- atomically setupSubscriberChannel
forM_ posts (atomically . writeTChan subChan)
where
setupSubscriberChannel :: STM (TChan PostID)
setupSubscriberChannel = do
tagMap <- readTVar tagMapSTM
case rMapLookup (genKeyID . Txt.unpack $ tag) tagMap of
Nothing -> do
-- if no collision/ tag doesn't exist yet, just initialize a
-- new subscriber map
broadcastChan <- newBroadcastTChan
tagOutChan <- dupTChan broadcastChan
newSubMapSTM <- newTVar $ HMap.singleton subscriber tagOutChan
writeTVar tagMapSTM $ addRMapEntry (genKeyID . Txt.unpack $ tag) (newSubMapSTM, broadcastChan, tag) tagMap
pure tagOutChan
Just (foundSubMapSTM, broadcastChan, _) -> do
-- otherwise use the existing subscriber map
foundSubMap <- readTVar foundSubMapSTM
case HMap.lookup subscriber foundSubMap of
Nothing -> do
-- for new subscribers, create new output channel
tagOutChan <- dupTChan broadcastChan
writeTVar foundSubMapSTM $ HMap.insert subscriber tagOutChan foundSubMap
pure tagOutChan
-- existing subscriber's channels are just returned
Just tagOutChan -> pure tagOutChan
-- normalise the unicode representation of a string to NFC
normaliseTag :: Txt.Text -> Txt.Text
normaliseTag = Txt.fromStrict . normalize NFC . Txt.toStrict
-- | define how to convert all showable types to PlainText
-- No idea what I'm doing with these overlappable instances though ¯\_(ツ)_/¯
-- TODO: figure out how this overlapping stuff actually works https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#instance-overlap