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:
Joey Hess 2016-12-10 11:32:05 -04:00
parent d44694cdd1
commit effd50d918
No known key found for this signature in database
GPG key ID: C910D9222512E3C7

View file

@ -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