diff options
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/TransferQueue.hs | 16 | ||||
| -rw-r--r-- | Assistant/TransferSlots.hs | 3 | ||||
| -rw-r--r-- | Assistant/WebApp/DashBoard.hs | 20 |
3 files changed, 34 insertions, 5 deletions
diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs index 40adc3520..865a82915 100644 --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -13,7 +13,8 @@ module Assistant.TransferQueue ( queueTransfers, queueTransfer, queueTransferAt, - getNextTransfer + getNextTransfer, + dequeueTransfer, ) where import Common.Annex @@ -30,7 +31,7 @@ import qualified Data.Map as M - in parallel to allow for reading. -} data TransferQueue = TransferQueue { queue :: TChan (Transfer, TransferInfo) - , queuesize :: TVar Integer + , queuesize :: TVar Int , queuelist :: TVar [(Transfer, TransferInfo)] } @@ -104,7 +105,7 @@ queueTransfer schedule q dstatus f t remote = {- Blocks until the queue is no larger than a given size, and then adds a - transfer to the queue. -} -queueTransferAt :: Integer -> Schedule -> TransferQueue -> DaemonStatusHandle -> AssociatedFile -> Transfer -> Remote -> IO () +queueTransferAt :: Int -> Schedule -> TransferQueue -> DaemonStatusHandle -> AssociatedFile -> Transfer -> Remote -> IO () queueTransferAt wantsz schedule q dstatus f t remote = do atomically $ do sz <- readTVar (queuesize q) @@ -132,3 +133,12 @@ getNextTransfer q dstatus acceptable = atomically $ do M.insertWith' const t info return $ Just r else return Nothing + +{- Removes a transfer from the queue, if present, and returns True if it + - was present. -} +dequeueTransfer :: TransferQueue -> Transfer -> IO Bool +dequeueTransfer q t = atomically $ do + (l, removed) <- partition (\i -> fst i /= t) <$> readTVar (queuelist q) + void $ writeTVar (queuesize q) (length l) + void $ writeTVar (queuelist q) l + return $ not $ null removed diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index 710a18884..9556232a4 100644 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -27,7 +27,8 @@ newTransferSlots :: IO TransferSlots newTransferSlots = newQSemN numSlots {- Waits until a transfer slot becomes available, and runs a transfer - - action in the slot, in its own thread. -} + - action in the slot, in its own thread. Note that this thread is + - subject to being killed when the transfer is canceled. -} inTransferSlot :: TransferSlots -> ThreadState -> Annex a -> IO ThreadId inTransferSlot s st a = do waitQSemN s 1 diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs index 57d789831..08aeb78c5 100644 --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -29,6 +29,7 @@ import Yesod import Text.Hamlet import qualified Data.Map as M import Control.Concurrent +import System.Posix.Signals (signalProcess, sigTERM, sigKILL) {- A display of currently running and queued transfers. - @@ -161,4 +162,21 @@ startTransfer :: Transfer -> Handler () startTransfer t = liftIO $ putStrLn "start" cancelTransfer :: Transfer -> Handler () -cancelTransfer t = liftIO $ putStrLn "cancel" +cancelTransfer t = do + webapp <- getYesod + {- Remove if queued. -} + void $ liftIO $ dequeueTransfer (transferQueue webapp) t + {- When the transfer is running, don't directly remove it from the + - map, instead signal to end the transfer, and rely on the + - TransferWatcher to notice it's done and update the map. -} + mi <- liftIO $ M.lookup t . currentTransfers + <$> getDaemonStatus (daemonStatus webapp) + case mi of + Just (TransferInfo { transferTid = Just tid } ) -> do + -- TODO + error "TODO" + Just (TransferInfo { transferPid = Just pid } ) -> liftIO $ do + signalProcess sigTERM pid + threadDelay 500000 -- half a second grace period + signalProcess sigKILL pid + _ -> noop |