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

refactor relay processing to STM-retry instead of busy-wait

Browse source
This commit is contained in:
Trolli Schmittlauch 2020-09-09 14:23:36 +02:00
parent 2b39648a77
commit 0ffe9effc0
2 changed files with 34 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Hash2Pub.cabal
View file

@ -46,7 +46,7 @@ category: Network
extra-source-files: CHANGELOG.md extra-source-files: CHANGELOG.md
common deps common deps
build-depends: base ^>=4.12.0.0, containers ^>=0.6.0.1, bytestring, utf8-string ^>=1.0.1.1, network ^>=2.8.0.1, time ^>=1.8.0.2, cmdargs ^>= 0.10, cryptonite ^>= 0.25, memory, async, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client, http-types, unbounded-delays build-depends: base ^>=4.12.0.0, containers ^>=0.6.0.1, bytestring, utf8-string ^>=1.0.1.1, network ^>=2.8.0.1, time ^>=1.8.0.2, cmdargs ^>= 0.10, cryptonite ^>= 0.25, memory, async, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client, http-types, unbounded-delays, dlist
ghc-options: -Wall -Wpartial-fields -O2 ghc-options: -Wall -Wpartial-fields -O2

48
src/Hash2Pub/PostService.hs
View file

@ -17,6 +17,7 @@ import Control.Monad.IO.Class (liftIO)
import Data.Bifunctor import Data.Bifunctor
import qualified Data.ByteString.Lazy.UTF8 as BSUL import qualified Data.ByteString.Lazy.UTF8 as BSUL
import qualified Data.ByteString.UTF8 as BSU import qualified Data.ByteString.UTF8 as BSU
import qualified Data.DList as D
import Data.Either (rights) import Data.Either (rights)
import qualified Data.HashMap.Strict as HMap import qualified Data.HashMap.Strict as HMap
import qualified Data.HashSet as HSet import qualified Data.HashSet as HSet
@ -39,6 +40,7 @@ import Servant.Client
import Hash2Pub.FediChordTypes import Hash2Pub.FediChordTypes
import Hash2Pub.PostService.API import Hash2Pub.PostService.API
import Hash2Pub.RingMap import Hash2Pub.RingMap
import Hash2Pub.Utils
data PostService d = PostService data PostService d = PostService
@ -612,27 +614,43 @@ fetchTagPosts serv = forever $ do
pure () pure ()
-- TODO: make configurable
numParallelDeliveries = 10
-- TODO: paralellelisation -- TODO: paralellelisation
-- TODO: make sure it doesn't busy-wait
relayWorker :: PostService d -> IO () relayWorker :: PostService d -> IO ()
relayWorker serv = forever $ do relayWorker serv = forever $ do
subscriptionMap <- readTVarIO $ subscribers serv -- atomically (to be able to retry) fold a list of due delivery actions
-- for each tag, try to deliver some posts to subscriber jobsToProcess <- atomically $ do
forM_ subscriptionMap (\(subscriberMapSTM, _, tag) -> do subscriptionMap <- readTVar $ subscribers serv
subscriberMap <- readTVarIO subscriberMapSTM jobList <- D.toList <$> foldM (\jobAcc (subscriberMapSTM, _, tag) -> do
forM_ (HMap.toList subscriberMap) (\((subHost, subPort), (postChan, _)) -> do subscriberMap <- readTVar subscriberMapSTM
postsToDeliver <- readUpTo 500 postChan foldM (\jobAcc' ((subHost, subPort), (postChan, _)) -> do
response <- runClientM (tagDeliveryClient tag (Txt.unlines postsToDeliver)) (mkClientEnv (httpMan serv) (BaseUrl Http subHost (fromIntegral subPort) "")) postsToDeliver <- readUpTo 500 postChan
-- so far just dropping failed attempts, TODO: retry mechanism -- append fetch job to job list
-- TODO: stats pure $ if not (null postsToDeliver)
pure () then jobAcc' `D.snoc` runClientM (tagDeliveryClient tag (Txt.unlines postsToDeliver)) (mkClientEnv (httpMan serv) (BaseUrl Http subHost (fromIntegral subPort) ""))
) else jobAcc'
) ) jobAcc $ HMap.toList subscriberMap
) D.empty subscriptionMap
-- if no relay jobs, then retry
if null jobList
then retry
else pure jobList
-- when processing the list, send several deliveries in parallel
forM_ (chunksOf numParallelDeliveries jobsToProcess) $ \jobset -> do
runningJobs <- mapM async jobset
-- so far just dropping failed attempts, TODO: retry mechanism
successfulResults <- rights <$> mapM waitCatch runningJobs
-- TODO: stats
pure ()
where where
readUpTo :: Int -> TChan a -> IO [a] readUpTo :: Int -> TChan a -> STM [a]
readUpTo 0 _ = pure [] readUpTo 0 _ = pure []
readUpTo n chan = do readUpTo n chan = do
readFromChan <- atomically (tryReadTChan chan) readFromChan <- tryReadTChan chan
case readFromChan of case readFromChan of
Nothing -> pure [] Nothing -> pure []
Just val -> do Just val -> do