fix build with old stm
Old stm lacks isFullTMQueue. To avoid needing to update stm on the Android autobuilder, I switched to a TBMQueue. It never needs to be closed, but the overhead is minimal.
This commit is contained in:
parent
d44694cdd1
commit
effd50d918
1 changed files with 10 additions and 7 deletions
|
@ -31,6 +31,7 @@ import System.PosixCompat.User
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import System.Log.Logger (debugM)
|
import System.Log.Logger (debugM)
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
|
import Control.Concurrent.STM.TBMQueue
|
||||||
import Control.Concurrent.Async
|
import Control.Concurrent.Async
|
||||||
import qualified Network.Socket as S
|
import qualified Network.Socket as S
|
||||||
|
|
||||||
|
@ -39,7 +40,7 @@ server :: TransportHandle -> IO ()
|
||||||
server th@(TransportHandle (LocalRepo r) _) = do
|
server th@(TransportHandle (LocalRepo r) _) = do
|
||||||
u <- liftAnnex th getUUID
|
u <- liftAnnex th getUUID
|
||||||
|
|
||||||
q <- newTBQueueIO maxConnections
|
q <- newTBMQueueIO maxConnections
|
||||||
replicateM_ maxConnections $
|
replicateM_ maxConnections $
|
||||||
forkIO $ forever $ serveClient th u r q
|
forkIO $ forever $ serveClient th u r q
|
||||||
|
|
||||||
|
@ -59,10 +60,10 @@ server th@(TransportHandle (LocalRepo r) _) = do
|
||||||
forever $ do
|
forever $ do
|
||||||
(conn, _) <- S.accept soc
|
(conn, _) <- S.accept soc
|
||||||
h <- setupHandle conn
|
h <- setupHandle conn
|
||||||
ok <- atomically $ ifM (isFullTBQueue q)
|
ok <- atomically $ ifM (isFullTBMQueue q)
|
||||||
( return False
|
( return False
|
||||||
, do
|
, do
|
||||||
writeTBQueue q h
|
writeTBMQueue q h
|
||||||
return True
|
return True
|
||||||
)
|
)
|
||||||
unless ok $ do
|
unless ok $ do
|
||||||
|
@ -73,19 +74,21 @@ server th@(TransportHandle (LocalRepo r) _) = do
|
||||||
maxConnections :: Int
|
maxConnections :: Int
|
||||||
maxConnections = 100
|
maxConnections = 100
|
||||||
|
|
||||||
serveClient :: TransportHandle -> UUID -> Repo -> TBQueue Handle -> IO ()
|
serveClient :: TransportHandle -> UUID -> Repo -> TBMQueue Handle -> IO ()
|
||||||
serveClient th u r q = bracket setup cleanup start
|
serveClient th u r q = bracket setup cleanup start
|
||||||
where
|
where
|
||||||
setup = do
|
setup = do
|
||||||
h <- atomically $ readTBQueue q
|
h <- atomically $ readTBMQueue q
|
||||||
debugM "remotedaemon" "serving a Tor connection"
|
debugM "remotedaemon" "serving a Tor connection"
|
||||||
return h
|
return h
|
||||||
|
|
||||||
cleanup h = do
|
cleanup Nothing = return ()
|
||||||
|
cleanup (Just h) = do
|
||||||
debugM "remotedaemon" "done with Tor connection"
|
debugM "remotedaemon" "done with Tor connection"
|
||||||
hClose h
|
hClose h
|
||||||
|
|
||||||
start h = do
|
start Nothing = return ()
|
||||||
|
start (Just h) = do
|
||||||
-- Avoid doing any work in the liftAnnex, since only one
|
-- Avoid doing any work in the liftAnnex, since only one
|
||||||
-- can run at a time.
|
-- can run at a time.
|
||||||
st <- liftAnnex th dupState
|
st <- liftAnnex th dupState
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue