620 lines
29 KiB
Haskell
620 lines
29 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE InstanceSigs #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
module Hash2Pub.PostService where
|
|
|
|
import Control.Concurrent
|
|
import Control.Concurrent.Async
|
|
import Control.Concurrent.MVar
|
|
import Control.Concurrent.STM
|
|
import Control.Concurrent.STM.TChan
|
|
import Control.Concurrent.STM.TChan
|
|
import Control.Concurrent.STM.TQueue
|
|
import Control.Concurrent.STM.TVar
|
|
import Control.Exception (Exception (..), try)
|
|
import Control.Monad (foldM, forM, forM_, forever, when, void)
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import Control.Monad.STM
|
|
import Data.Bifunctor
|
|
import qualified Data.ByteString.Lazy.UTF8 as BSUL
|
|
import qualified Data.ByteString.UTF8 as BSU
|
|
import qualified Data.HashMap.Strict as HMap
|
|
import qualified Data.HashSet as HSet
|
|
import Data.Maybe (fromMaybe, isJust)
|
|
import Data.String (fromString)
|
|
import qualified Data.Text.Lazy as Txt
|
|
import Data.Text.Normalize (NormalizationMode (NFC),
|
|
normalize)
|
|
import Data.Time.Clock.POSIX
|
|
import Data.Typeable (Typeable)
|
|
import qualified Network.HTTP.Client as HTTP
|
|
import qualified Network.HTTP.Types as HTTPT
|
|
import System.Random
|
|
import Text.Read (readEither)
|
|
|
|
import qualified Network.Wai.Handler.Warp as Warp
|
|
import Servant
|
|
import Servant.Client
|
|
import Servant.Server
|
|
|
|
import Hash2Pub.FediChordTypes
|
|
import Hash2Pub.RingMap
|
|
|
|
|
|
data PostService d = PostService
|
|
{ serviceConf :: ServiceConf
|
|
-- queues, other data structures
|
|
, baseDHT :: (DHT d) => d
|
|
, serviceThread :: TVar ThreadId
|
|
, 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
|
|
, ownPosts :: TVar (HSet.HashSet Txt.Text)
|
|
-- ^ just store the existence of posts for saving memory,
|
|
, relayInQueue :: TQueue (Hashtag, PostID, PostContent)
|
|
-- ^ Queue for processing incoming posts of own instance asynchronously
|
|
, postFetchQueue :: TQueue PostID
|
|
, migrationsInProgress :: TVar (HMap.HashMap NodeID (MVar ()))
|
|
, httpMan :: HTTP.Manager
|
|
}
|
|
deriving (Typeable)
|
|
|
|
type Hashtag = Txt.Text
|
|
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 (TagSubscribersSTM, TChan PostID, Hashtag)
|
|
type TagSubscribersSTM = TVar TagSubscribers
|
|
-- | each subscriber is identified by its contact data "hostname" "port"
|
|
-- and holds a TChan duplicated from the broadcast TChan of the tag
|
|
-- + an expiration timestamp
|
|
type TagSubscribers = (HMap.HashMap (String, Int) (TChan PostID, POSIXTime))
|
|
|
|
|
|
instance DHT d => Service PostService d where
|
|
-- | initialise 'PostService' data structures and run server
|
|
runService conf dht = do
|
|
-- create necessary TVars
|
|
threadVar <- newTVarIO =<< myThreadId -- own thread ID as placeholder
|
|
subscriberVar <- newTVarIO emptyRMap
|
|
ownSubsVar <- newTVarIO HMap.empty
|
|
ownPostVar <- newTVarIO HSet.empty
|
|
relayInQueue' <- newTQueueIO
|
|
postFetchQueue' <- newTQueueIO
|
|
migrationsInProgress' <- newTVarIO HMap.empty
|
|
httpMan' <- HTTP.newManager HTTP.defaultManagerSettings
|
|
let
|
|
thisService = PostService {
|
|
serviceConf = conf
|
|
, baseDHT = dht
|
|
, serviceThread = threadVar
|
|
, subscribers = subscriberVar
|
|
, ownSubscriptions = ownSubsVar
|
|
, ownPosts = ownPostVar
|
|
, relayInQueue = relayInQueue'
|
|
, postFetchQueue = postFetchQueue'
|
|
, migrationsInProgress = migrationsInProgress'
|
|
, httpMan = httpMan'
|
|
}
|
|
port' = fromIntegral (confServicePort conf)
|
|
warpSettings = Warp.setPort port' . Warp.setHost (fromString . confServiceHost $ conf) $ Warp.defaultSettings
|
|
-- Run 'concurrently_' from another thread to be able to return the
|
|
-- 'PostService'.
|
|
-- Terminating that parent thread will make all child threads terminate as well.
|
|
servThreadID <- forkIO $
|
|
concurrently_
|
|
-- web server
|
|
(Warp.runSettings warpSettings $ postServiceApplication thisService)
|
|
(processIncomingPosts thisService)
|
|
-- update thread ID after fork
|
|
atomically $ writeTVar threadVar servThreadID
|
|
pure thisService
|
|
|
|
getListeningPortFromService = fromIntegral . confServicePort . serviceConf
|
|
|
|
migrateData = clientDeliverSubscriptions
|
|
|
|
waitForMigrationFrom serv fromID = do
|
|
migrationSynchroniser <- atomically $ do
|
|
syncPoint <- HMap.lookup fromID <$> readTVar (migrationsInProgress serv)
|
|
maybe
|
|
-- decision: this function blocks until it gets an incoming migration from given ID
|
|
retry
|
|
pure
|
|
syncPoint
|
|
-- block until migration finished
|
|
takeMVar migrationSynchroniser
|
|
|
|
|
|
-- | return a WAI application
|
|
postServiceApplication :: DHT d => PostService d -> Application
|
|
postServiceApplication serv = serve exposedPostServiceAPI $ postServer serv
|
|
|
|
|
|
-- | needed for guiding type inference
|
|
exposedPostServiceAPI :: Proxy PostServiceAPI
|
|
exposedPostServiceAPI = Proxy
|
|
|
|
-- ========= constants ===========
|
|
|
|
placeholderPost :: Txt.Text
|
|
placeholderPost = Txt.take 5120 . Txt.repeat $ 'O' -- size 5KiB
|
|
|
|
-- ========= HTTP API and handlers =============
|
|
|
|
type PostServiceAPI = "relay" :> "inbox" :> Capture "hashtag" Txt.Text :> ReqBody '[PlainText] Txt.Text :> PutCreated '[PlainText] NoContent
|
|
-- delivery endpoint at responsible relay for delivering posts of $tag for distribution
|
|
:<|> "relay" :> "subscribers" :> Capture "senderID" Integer :> ReqBody '[PlainText] Txt.Text :> PostNoContent '[PlainText] Txt.Text
|
|
-- 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
|
|
:<|> "posts" :> ReqBody '[PlainText] Txt.Text :> Post '[PlainText] Txt.Text
|
|
-- endpoint for fetching multiple posts at once
|
|
:<|> "posts" :> "inbox" :> ReqBody '[PlainText] Txt.Text :> PutCreated '[PlainText] NoContent
|
|
-- delivery endpoint of newly published posts of the relay's instance
|
|
:<|> "tags" :> Capture "hashtag" Txt.Text :> ReqBody '[PlainText] Txt.Text :> PostCreated '[PlainText] Txt.Text
|
|
-- delivery endpoint for posts of $tag at subscribing instance
|
|
:<|> "tags" :> Capture "hashtag" Txt.Text :> "subscribe" :> Header "Origin" Txt.Text :> Get '[PlainText] Integer
|
|
-- endpoint for subscribing the instance specified in
|
|
-- the Origin header to $hashtag.
|
|
-- Returns subscription lease time in seconds.
|
|
:<|> "tags" :> Capture "hashtag" Txt.Text :> "unsubscribe" :> Header "Origin" Txt.Text :> Get '[PlainText] Txt.Text
|
|
-- endpoint for unsubscribing the instance specified in
|
|
-- the Origin header to $hashtag
|
|
|
|
|
|
postServer :: DHT d => PostService d -> Server PostServiceAPI
|
|
postServer service = relayInbox service
|
|
:<|> subscriptionDelivery service
|
|
:<|> postFetch service
|
|
:<|> postMultiFetch service
|
|
:<|> postInbox service
|
|
:<|> tagDelivery service
|
|
:<|> tagSubscribe service
|
|
:<|> tagUnsubscribe service
|
|
|
|
|
|
relayInbox :: DHT d => PostService d -> Hashtag -> Txt.Text -> Handler NoContent
|
|
relayInbox serv tag posts = do
|
|
let
|
|
-- skip checking whether the post actually contains the tag, just drop full post
|
|
postIDs = head . Txt.splitOn "," <$> Txt.lines posts
|
|
-- if tag is not in own responsibility, return a 410 Gone
|
|
responsible <- liftIO $ isResponsibleFor (baseDHT serv) (genKeyID . Txt.unpack $ tag)
|
|
if responsible
|
|
then pure ()
|
|
else
|
|
throwError $ err410 { errBody = "Relay is not responsible for this tag"}
|
|
broadcastChan <- liftIO $ atomically $ getTagBroadcastChannel serv tag
|
|
maybe
|
|
-- if noone subscribed to the tag, nothing needs to be done
|
|
(pure ())
|
|
-- otherwise enqueue posts into broadcast queue of the tag
|
|
(\queue ->
|
|
liftIO $ forM_ postIDs (atomically . writeTChan queue)
|
|
)
|
|
broadcastChan
|
|
pure NoContent
|
|
|
|
-- exception to be thrown when a tag is not in the responsibility of a relay
|
|
newtype UnhandledTagException = UnhandledTagException String
|
|
deriving (Show, Typeable)
|
|
|
|
instance Exception UnhandledTagException
|
|
|
|
subscriptionDelivery :: DHT d => PostService d -> Integer -> Txt.Text -> Handler Txt.Text
|
|
subscriptionDelivery serv senderID subList = do
|
|
let
|
|
tagSubs = Txt.lines subList
|
|
-- signal that the migration is in progress
|
|
syncMVar <- liftIO newEmptyMVar
|
|
liftIO . atomically $ modifyTVar' (migrationsInProgress serv) $
|
|
HMap.insert (fromInteger senderID) syncMVar
|
|
-- In favor of having the convenience of rolling back the transaction once a
|
|
-- not-handled tag occurs, this results in a single large transaction.
|
|
-- Hopefully the performance isn't too bad.
|
|
res <- liftIO . atomically $ (foldM (\_ tag' -> do
|
|
responsible <- isResponsibleForSTM (baseDHT serv) (genKeyID . Txt.unpack $ tag')
|
|
if responsible
|
|
then processTag (subscribers serv) tag'
|
|
else throwSTM $ UnhandledTagException (Txt.unpack tag' <> " not handled by this relay")
|
|
pure $ Right ()
|
|
) (pure ()) tagSubs
|
|
`catchSTM` (\e -> pure . Left $ show (e :: UnhandledTagException))
|
|
-- TODO: potentially log this
|
|
:: STM (Either String ()))
|
|
-- TODO: should this always signal migration finished to avoid deadlocksP
|
|
liftIO $ putMVar syncMVar () -- wakes up waiting thread
|
|
-- allow response to be completed independently from waiting thread
|
|
_ <- liftIO . forkIO $ do
|
|
putMVar syncMVar () -- blocks until waiting thread has resumed
|
|
-- delete this migration from ongoing ones
|
|
liftIO . atomically $ modifyTVar' (migrationsInProgress serv) $
|
|
HMap.delete (fromInteger senderID)
|
|
case res of
|
|
Left err -> throwError err410 {errBody = BSUL.fromString err}
|
|
Right _ -> pure ""
|
|
-- TODO: check and only accept tags in own (future?) responsibility
|
|
where
|
|
processTag :: TVar RelayTags -> Txt.Text -> STM ()
|
|
processTag subscriberSTM tagData = do
|
|
let
|
|
tag:subText:lease:posts:_ = Txt.splitOn "," tagData
|
|
-- ignore checking of lease time
|
|
leaseTime = fromIntegral (read . Txt.unpack $ lease :: Integer)
|
|
sub = read . Txt.unpack $ subText :: (String, Int)
|
|
postList = Txt.words posts
|
|
enqueueSubscription subscriberSTM (normaliseTag tag) sub postList leaseTime
|
|
|
|
|
|
postFetch :: PostService d -> Txt.Text -> Handler Txt.Text
|
|
postFetch serv postID = do
|
|
postSet <- liftIO . readTVarIO . ownPosts $ serv
|
|
if HSet.member postID postSet
|
|
-- decision: always return the same placeholder post
|
|
then pure placeholderPost
|
|
else throwError $ err404 { errBody = "No post found with this ID" }
|
|
|
|
|
|
postMultiFetch :: PostService d -> Txt.Text -> Handler Txt.Text
|
|
postMultiFetch serv postIDs = do
|
|
let idList = Txt.lines postIDs
|
|
postSet <- liftIO . readTVarIO . ownPosts $ serv
|
|
-- look up existence of all given post IDs, fail if even one is missing
|
|
foldM (\response postID ->
|
|
if HSet.member postID postSet
|
|
then pure $ placeholderPost <> "\n" <> response
|
|
else throwError $ err404 { errBody = "No post found with this ID" }
|
|
) "" idList
|
|
|
|
|
|
postInbox :: PostService d -> Txt.Text -> Handler NoContent
|
|
postInbox serv post = do
|
|
-- extract contained hashtags
|
|
let
|
|
containedTags = fmap (normaliseTag . Txt.tail) . filter ((==) '#' . Txt.head) . Txt.words $ post
|
|
-- generate post ID
|
|
postId <- liftIO $ Txt.pack . show <$> (randomRIO (0, 2^(128::Integer)-1) :: IO Integer)
|
|
-- add ID to own posts
|
|
liftIO . atomically $ modifyTVar' (ownPosts serv) (HSet.insert postId)
|
|
-- enqueue a relay job for each tag
|
|
liftIO $ forM_ (containedTags :: [Txt.Text]) (\tag ->
|
|
atomically $ writeTQueue (relayInQueue serv) (tag, postId, post)
|
|
)
|
|
pure NoContent
|
|
|
|
|
|
tagDelivery :: PostService d -> Txt.Text -> Txt.Text -> Handler Txt.Text
|
|
tagDelivery serv hashtag posts = do
|
|
let postIDs = Txt.lines posts
|
|
subscriptions <- liftIO . readTVarIO . ownSubscriptions $ serv
|
|
if isJust (HMap.lookup (genKeyID . Txt.unpack $ hashtag) subscriptions)
|
|
then -- TODO: increase a counter/ statistics for received posts of this tag
|
|
liftIO $ forM_ postIDs $ atomically . writeTQueue (postFetchQueue serv)
|
|
else -- silently drop posts from unsubscribed tags
|
|
pure ()
|
|
pure $ "Received a postID for tag " <> hashtag
|
|
|
|
tagSubscribe :: DHT d => 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
|
|
origin
|
|
req <- HTTP.parseUrlThrow (Txt.unpack originURL)
|
|
now <- liftIO getPOSIXTime
|
|
let leaseTime = now + confSubscriptionExpiryTime (serviceConf serv)
|
|
-- setup subscription entry
|
|
_ <- liftIO . atomically $ setupSubscriberChannel (subscribers serv) hashtag (BSU.toString $ HTTP.host req, HTTP.port req) leaseTime
|
|
pure $ round leaseTime
|
|
|
|
|
|
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
|
|
origin
|
|
req <- HTTP.parseUrlThrow (Txt.unpack originURL)
|
|
liftIO . atomically $ deleteSubscription (subscribers serv) hashtag (BSU.toString $ HTTP.host req, HTTP.port req)
|
|
pure "bye bye"
|
|
|
|
-- client/ request functions
|
|
|
|
clientAPI :: Proxy PostServiceAPI
|
|
clientAPI = Proxy
|
|
|
|
|
|
relayInboxClient :<|> subscriptionDeliveryClient :<|> postFetchClient :<|> postMultiFetchClient :<|> postInboxClient :<|> tagDeliveryClient :<|> tagSubscribeClient :<|> tagUnsubscribeClient = client clientAPI
|
|
|
|
|
|
-- | Deliver the subscriber list of all hashtags in the interval [fromTag, toTag]
|
|
-- and their outstanding delivery queue to another instance.
|
|
-- If the transfer succeeds, the transfered subscribers are removed from the local list.
|
|
clientDeliverSubscriptions :: PostService d
|
|
-> NodeID -- ^ sender node ID
|
|
-> NodeID -- ^ fromTag
|
|
-> NodeID -- ^ toTag
|
|
-> (String, Int) -- ^ hostname and port of instance to deliver to
|
|
-> IO (Either String ()) -- Either signals success or failure
|
|
clientDeliverSubscriptions serv fromNode fromKey toKey (toHost, toPort) = do
|
|
-- collect tag intearval
|
|
intervalTags <- takeRMapSuccessorsFromTo fromKey toKey <$> readTVarIO (subscribers serv)
|
|
-- returns a [ (TagSubscribersSTM, TChan PostID, Hashtag) ]
|
|
-- extract subscribers and posts
|
|
-- no need for extracting as a single atomic operation, as newly incoming posts are supposed to be rejected because of already having re-positioned on the DHT
|
|
subscriberData <- foldM (\response (subSTM, _, tag) -> do
|
|
subMap <- readTVarIO subSTM
|
|
thisTagsData <- foldM (\tagResponse (subscriber, (subChan, lease)) -> do
|
|
-- duplicate the pending queue to work on a copy, in case of a delivery error
|
|
pending <- atomically $ do
|
|
queueCopy <- cloneTChan subChan
|
|
channelGetAll queueCopy
|
|
if null pending
|
|
then pure tagResponse
|
|
else pure $ tag <> "," <> Txt.pack (show subscriber) <> "," <> Txt.pack (show lease) <> "," <> Txt.unwords pending <> "\n"
|
|
)
|
|
""
|
|
(HMap.toList subMap)
|
|
pure $ thisTagsData <> response
|
|
)
|
|
""
|
|
intervalTags
|
|
-- send subscribers
|
|
resp <- runClientM (subscriptionDeliveryClient (getNodeID fromNode) subscriberData) (mkClientEnv (httpMan serv) (BaseUrl Http toHost (fromIntegral toPort) ""))
|
|
-- on failure return a Left, otherwise delete subscription entry
|
|
case resp of
|
|
Left err -> pure . Left . show $ err
|
|
Right _ -> do
|
|
atomically $
|
|
modifyTVar' (subscribers serv) $ \tagMap ->
|
|
foldr deleteRMapEntry tagMap ((\(_, _, t) -> genKeyID . Txt.unpack $ t) <$> intervalTags)
|
|
pure . Right $ ()
|
|
where
|
|
channelGetAll :: TChan a -> STM [a]
|
|
channelGetAll chan = channelGetAll' chan []
|
|
channelGetAll' :: TChan a -> [a] -> STM [a]
|
|
channelGetAll' chan acc = do
|
|
haveRead <- tryReadTChan chan
|
|
maybe (pure acc) (\x -> channelGetAll' chan (x:acc)) haveRead
|
|
|
|
|
|
-- | Subscribe the client to the given hashtag. On success it returns the given lease time,
|
|
-- but also records the subscription in its own data structure.
|
|
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 -> do
|
|
atomically . modifyTVar' (ownSubscriptions serv) $ HMap.insert (genKeyID . Txt.unpack $ tag) (fromInteger 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 _ -> do
|
|
atomically . modifyTVar' (ownSubscriptions serv) $ HMap.delete (genKeyID . Txt.unpack $ tag)
|
|
pure . Right $ ()
|
|
)
|
|
lookupResponse
|
|
|
|
|
|
-- | publish a new post to the inbox of a specified relay instance. This
|
|
-- instance will then be the originating instance of the post and will forward
|
|
-- the post to the responsible relays.
|
|
-- As the initial publishing isn't done by a specific relay (but *to* a specific relay
|
|
-- instead), the function does *not* take a PostService as argument.
|
|
clientPublishPost :: HTTP.Manager -- for better performance, a shared HTTP manager has to be provided
|
|
-> String -- hostname
|
|
-> Int -- port
|
|
-> PostContent -- post content
|
|
-> IO (Either String ()) -- error or success
|
|
clientPublishPost httpman hostname port postC = do
|
|
resp <- runClientM (postInboxClient postC) (mkClientEnv httpman (BaseUrl Http hostname port ""))
|
|
pure . bimap show (const ()) $ resp
|
|
|
|
-- currently this is unused code
|
|
getClients :: String -> Int -> HTTP.Manager -> Client IO PostServiceAPI
|
|
getClients hostname' port' httpMan = hoistClient clientAPI
|
|
(fmap (either (error . show) id)
|
|
. flip runClientM clientEnv
|
|
)
|
|
(client clientAPI)
|
|
where
|
|
clientEnv = mkClientEnv httpMan (BaseUrl Http hostname' port' "")
|
|
|
|
-- ======= 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.
|
|
enqueueSubscription :: TVar RelayTags -- tag-subscriber map
|
|
-> Hashtag -- hashtag of pending posts
|
|
-> (String, Int) -- subscriber's connection information
|
|
-> [PostID] -- pending posts
|
|
-> POSIXTime -- lease expiry time
|
|
-> STM ()
|
|
enqueueSubscription tagMapSTM tag subscriber posts leaseTime = do
|
|
-- get the tag output queue and, if necessary, create it
|
|
subChan <- setupSubscriberChannel tagMapSTM tag subscriber leaseTime
|
|
forM_ posts (writeTChan subChan)
|
|
|
|
|
|
-- | STM operation to return the outgoing post queue of a tag to a specified subscriber.
|
|
-- If the queue doesn't exist yet, all necessary data structures are set up accordingly.
|
|
setupSubscriberChannel :: TVar RelayTags -> Hashtag -> (String, Int) -> POSIXTime -> STM (TChan PostID)
|
|
setupSubscriberChannel tagMapSTM tag subscriber leaseTime = do
|
|
tagMap <- readTVar tagMapSTM
|
|
case lookupTagSubscriptions 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, leaseTime)
|
|
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, leaseTime) foundSubMap
|
|
pure tagOutChan
|
|
-- existing subscriber's channels are just returned
|
|
Just (tagOutChan, _) -> pure tagOutChan
|
|
|
|
|
|
-- | deletes a subscription from the passed subscriber map
|
|
deleteSubscription :: TVar RelayTags -> Hashtag -> (String, Int) -> STM ()
|
|
deleteSubscription tagMapSTM tag subscriber = do
|
|
tagMap <- readTVar tagMapSTM
|
|
case lookupTagSubscriptions tag tagMap of
|
|
-- no subscribers to that tag, just return
|
|
Nothing -> pure ()
|
|
Just (foundSubMapSTM, _, _) -> do
|
|
foundSubMap <- readTVar foundSubMapSTM
|
|
let newSubMap = HMap.delete subscriber foundSubMap
|
|
-- if there are no subscriptions for the tag anymore, remove its
|
|
-- data sttructure altogether
|
|
if HMap.null newSubMap
|
|
then writeTVar tagMapSTM $ deleteRMapEntry (genKeyID . Txt.unpack $ tag) tagMap
|
|
-- otherwise just remove the subscription of that node
|
|
else writeTVar foundSubMapSTM newSubMap
|
|
|
|
|
|
|
|
-- | returns the broadcast channel of a hashtag if there are any subscribers to it
|
|
getTagBroadcastChannel :: PostService d -> Hashtag -> STM (Maybe (TChan PostID))
|
|
getTagBroadcastChannel serv tag = do
|
|
tagMap <- readTVar $ subscribers serv
|
|
case lookupTagSubscriptions tag tagMap of
|
|
Nothing -> pure Nothing
|
|
Just (subscriberSTM, broadcastChan, _) -> do
|
|
subscriberMap <- readTVar subscriberSTM
|
|
if HMap.null subscriberMap
|
|
then pure Nothing
|
|
else pure (Just broadcastChan)
|
|
|
|
|
|
-- | look up the subscription data of a tag
|
|
lookupTagSubscriptions :: Hashtag -> RingMap NodeID a -> Maybe a
|
|
lookupTagSubscriptions tag = rMapLookup (genKeyID . Txt.unpack $ tag)
|
|
|
|
|
|
-- 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
|
|
instance {-# OVERLAPPABLE #-} Show a => MimeRender PlainText a where
|
|
mimeRender _ = BSUL.fromString . show
|
|
|
|
instance {-# OVERLAPPABLE #-} Read a => MimeUnrender PlainText a where
|
|
mimeUnrender _ = readEither . BSUL.toString
|
|
|
|
-- ====== worker threads ======
|
|
|
|
-- | process the pending relay inbox of incoming posts from the internal queue:
|
|
-- Look up responsible relay node for given hashtag and forward post to it
|
|
processIncomingPosts :: DHT d => PostService d -> IO ()
|
|
processIncomingPosts serv = forever $ do
|
|
-- blocks until available
|
|
-- TODO: process multiple in parallel
|
|
(tag, pID, pContent) <- atomically . readTQueue $ relayInQueue serv
|
|
lookupRes <- lookupKey (baseDHT serv) (Txt.unpack tag)
|
|
case lookupRes of
|
|
-- no vserver active => wait and retry
|
|
Nothing -> threadDelay $ 10 * 10^6
|
|
Just (responsibleHost, responsiblePort) -> do
|
|
resp <- runClientM (relayInboxClient tag $ pID <> "," <> pContent) (mkClientEnv (httpMan serv) (BaseUrl Http responsibleHost (fromIntegral responsiblePort) ""))
|
|
case resp of
|
|
Left err -> do
|
|
putStrLn $ "Error: " <> show err
|
|
-- 410 error indicates outdated responsibility mapping
|
|
-- Simplification: just invalidate the mapping entry on all errors, force a re-lookup and re-queue the post
|
|
-- TODO: keep track of maximum retries
|
|
_ <- forceLookupKey (baseDHT serv) (Txt.unpack tag)
|
|
atomically . writeTQueue (relayInQueue serv) $ (tag, pID, pContent)
|
|
Right yay -> do
|
|
putStrLn $ "Yay! " <> show yay
|
|
-- idea for the experiment: each post publication makes the initial posting instance subscribe to all contained tags
|
|
now <- getPOSIXTime
|
|
subscriptionStatus <- HMap.lookup (genKeyID . Txt.unpack $ tag) <$> readTVarIO (ownSubscriptions serv)
|
|
-- if not yet subscribed or subscription expires within 2 minutes, (re)subscribe to tag
|
|
when (maybe False (\subLease -> now - subLease < 120) subscriptionStatus) $
|
|
void $ clientSubscribeTo serv tag
|
|
|
|
|
|
-- | process the pending fetch jobs of delivered post IDs: Delivered posts are tried to be fetched from their URI-ID
|
|
fetchTagPosts :: DHT d => PostService d -> IO ()
|
|
fetchTagPosts serv = forever $ do
|
|
-- blocks until available
|
|
-- TODO: batching, retry
|
|
-- TODO: process multiple in parallel
|
|
pIdUri <- atomically . readTQueue $ postFetchQueue serv
|
|
fetchReq <- HTTP.parseRequest . Txt.unpack $pIdUri
|
|
resp <- try $ HTTP.httpLbs fetchReq (httpMan serv) :: IO (Either HTTP.HttpException (HTTP.Response BSUL.ByteString))
|
|
case resp of
|
|
Right response ->
|
|
if HTTPT.statusCode (HTTP.responseStatus response) == 200
|
|
then
|
|
-- success, TODO: statistics
|
|
putStrLn "post fetch success"
|
|
else
|
|
-- TODO error handling, retry
|
|
pure ()
|
|
Left _ ->
|
|
-- TODO error handling, retry
|
|
pure ()
|
|
|