move TransferrerPool from assistant
This old code will now be useful for git-annex beyond the assistant. git-annex won't use the CheckTransferrer part, and won't run transferkeys as a batch process, and will want withTransferrer to not shut down transferkeys processes. Still, the rest of this is a good fit for what I need now. Also removed some dead code, and simplified a little bit. This commit was sponsored by Mark Reidenbach on Patreon.
This commit is contained in:
parent
438d5be1f7
commit
72e5764a87
6 changed files with 103 additions and 76 deletions
56
Types/TransferrerPool.hs
Normal file
56
Types/TransferrerPool.hs
Normal file
|
@ -0,0 +1,56 @@
|
|||
{- A pool of "git-annex transferkeys" processes available for use
|
||||
-
|
||||
- Copyright 2013-2020 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Types.TransferrerPool where
|
||||
|
||||
import Annex.Common
|
||||
|
||||
import Control.Concurrent.STM hiding (check)
|
||||
|
||||
type TransferrerPool = TVar (MkCheckTransferrer, [TransferrerPoolItem])
|
||||
|
||||
type CheckTransferrer = IO Bool
|
||||
type MkCheckTransferrer = IO (IO Bool)
|
||||
|
||||
{- Each item in the pool may have a transferrer running, and has an
|
||||
- IO action that can be used to check if it's still ok to use the
|
||||
- transferrer. -}
|
||||
data TransferrerPoolItem = TransferrerPoolItem (Maybe Transferrer) CheckTransferrer
|
||||
|
||||
data Transferrer = Transferrer
|
||||
{ transferrerRead :: Handle
|
||||
, transferrerWrite :: Handle
|
||||
, transferrerHandle :: ProcessHandle
|
||||
}
|
||||
|
||||
newTransferrerPool :: MkCheckTransferrer -> IO TransferrerPool
|
||||
newTransferrerPool c = newTVarIO (c, [])
|
||||
|
||||
popTransferrerPool :: TransferrerPool -> STM (Maybe TransferrerPoolItem, Int)
|
||||
popTransferrerPool p = do
|
||||
(c, l) <- readTVar p
|
||||
case l of
|
||||
[] -> return (Nothing, 0)
|
||||
(i:is) -> do
|
||||
writeTVar p (c, is)
|
||||
return $ (Just i, length is)
|
||||
|
||||
pushTransferrerPool :: TransferrerPool -> TransferrerPoolItem -> STM ()
|
||||
pushTransferrerPool p i = do
|
||||
(c, l) <- readTVar p
|
||||
let l' = i:l
|
||||
writeTVar p (c, l')
|
||||
|
||||
{- Note that making a CheckTransferrer may allocate resources,
|
||||
- such as a NotificationHandle, so it's important that the returned
|
||||
- TransferrerPoolItem is pushed into the pool, and not left to be
|
||||
- garbage collected. -}
|
||||
mkTransferrerPoolItem :: TransferrerPool -> Transferrer -> IO TransferrerPoolItem
|
||||
mkTransferrerPoolItem p t = do
|
||||
mkcheck <- atomically $ fst <$> readTVar p
|
||||
check <- mkcheck
|
||||
return $ TransferrerPoolItem (Just t) check
|
Loading…
Add table
Add a link
Reference in a new issue