d3f78da0edDone on unix, could not implement it on windows quite. The signal library gets part of the way needed for windows. But I had to open https://github.com/pmlodawski/signal/issues/1 because it lacks raiseSignal. Also, I don't know what the equivilant of getProcessGroupIDOf is on windows. And System.Process does not provide a way to send any signal to a process group except for SIGINT. This commit was sponsored by Boyd Stephen Smith Jr. on Patreon.
59 lines
1.8 KiB
Haskell
59 lines
1.8 KiB
Haskell
{- A pool of "git-annex transfer" 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 Common
|
|
|
|
import Control.Concurrent.STM hiding (check)
|
|
|
|
type TransferrerPool = TVar [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
|
|
, transferrerShutdown :: IO ()
|
|
-- ^ Closes the FDs and waits for the process to exit.
|
|
-- Should be used when the transferrer is in between transfers,
|
|
-- as otherwise it may not shutdown promptly.
|
|
}
|
|
|
|
newTransferrerPool :: IO TransferrerPool
|
|
newTransferrerPool = newTVarIO []
|
|
|
|
popTransferrerPool :: TransferrerPool -> STM (Maybe TransferrerPoolItem, Int)
|
|
popTransferrerPool p = do
|
|
l <- readTVar p
|
|
case l of
|
|
[] -> return (Nothing, 0)
|
|
(i:is) -> do
|
|
writeTVar p is
|
|
return $ (Just i, length is)
|
|
|
|
pushTransferrerPool :: TransferrerPool -> TransferrerPoolItem -> STM ()
|
|
pushTransferrerPool p i = do
|
|
l <- readTVar p
|
|
let l' = i:l
|
|
writeTVar p 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 :: MkCheckTransferrer -> Transferrer -> IO TransferrerPoolItem
|
|
mkTransferrerPoolItem mkcheck t = do
|
|
check <- mkcheck
|
|
return $ TransferrerPoolItem (Just t) check
|