diff options
| -rw-r--r-- | Assistant/ThreadedMonad.hs | 11 | ||||
| -rw-r--r-- | Assistant/Threads/Transferrer.hs | 54 | ||||
| -rw-r--r-- | Assistant/TransferSlots.hs | 8 | ||||
| -rw-r--r-- | Assistant/WebApp/DashBoard.hs | 34 |
4 files changed, 44 insertions, 63 deletions
diff --git a/Assistant/ThreadedMonad.hs b/Assistant/ThreadedMonad.hs index 1decd8e91..7b915e12c 100644 --- a/Assistant/ThreadedMonad.hs +++ b/Assistant/ThreadedMonad.hs @@ -36,14 +36,3 @@ withThreadState a = do - time. -} runThreadState :: ThreadState -> Annex a -> IO a runThreadState mvar a = modifyMVar mvar $ \state -> swap <$> Annex.run state a - -{- Runs an Annex action, using a copy of the state from the MVar. - - - - It's up to the action to perform any necessary shutdown tasks in order - - for state to not be lost. And it's up to the caller to resynchronise - - with any changes the action makes to eg, the git-annex branch. - -} -unsafeRunThreadState :: ThreadState -> Annex a -> IO () -unsafeRunThreadState mvar a = do - state <- readMVar mvar - void $ Annex.eval state a diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index 67fdcd2a7..6391d7189 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -14,7 +14,6 @@ import Assistant.TransferQueue import Assistant.TransferSlots import Assistant.Alert import Logs.Transfer -import Logs.Presence import Logs.Location import Annex.Content import qualified Remote @@ -41,7 +40,7 @@ transfererThread st dstatus transferqueue slots = go ( do debug thisThread [ "Transferring:" , show t ] notifyTransfer dstatus - transferThread st dstatus slots t info + transferThread dstatus slots t info , do debug thisThread [ "Skipping unnecessary transfer:" , show t ] -- getNextTransfer added t to the @@ -71,22 +70,22 @@ shouldTransfer t info where key = transferKey t -{- A transfer is run in a separate thread, with a *copy* of the Annex - - state. This is necessary to avoid blocking the rest of the assistant - - on the transfer completing, and also to allow multiple transfers to run - - at once. This requires GHC's threaded runtime to work! +{- A sepeate git-annex process is forked off to run a transfer. + - This allows killing the process if the user decides to cancel the + - transfer. - - - The copy of state means that the transfer processes are responsible - - for doing any necessary shutdown cleanups, and that the parent - - thread's cache must be invalidated once a transfer completes, as - - changes may have been made to the git-annex branch. - -} -transferThread :: ThreadState -> DaemonStatusHandle -> TransferSlots -> Transfer -> TransferInfo -> IO () -transferThread st dstatus slots t info = case (transferRemote info, associatedFile info) of + - A thread is forked off to run the process, and the thread + - occupys one of the transfer slots. If all slots are in use, this will + - block until one becomes available. The thread's id is also recorded in + - the transfer info; the thread will also be killed when a transfer is + - stopped, to avoid it displaying any alert about the transfer having + - failed. -} +transferThread :: DaemonStatusHandle -> TransferSlots -> Transfer -> TransferInfo -> IO () +transferThread dstatus slots t info = case (transferRemote info, associatedFile info) of (Nothing, _) -> noop (_, Nothing) -> noop (Just remote, Just file) -> do - tid <- inTransferSlot slots st $ + tid <- inTransferSlot slots $ transferprocess remote file now <- getCurrentTime adjustTransfers dstatus $ @@ -97,24 +96,15 @@ transferThread st dstatus slots t info = case (transferRemote info, associatedFi where direction = transferDirection t isdownload = direction == Download - tofrom - | isdownload = "from" - | otherwise = "to" - key = transferKey t - transferprocess remote file = do - showStart "copy" file - showAction $ tofrom ++ " " ++ Remote.name remote - ok <- runTransfer t (Just file) $ - if isdownload - then getViaTmp key $ - Remote.retrieveKeyFile remote key (Just file) - else do - ok <- Remote.storeKey remote key $ Just file - when ok $ - Remote.logStatus remote key InfoPresent - return ok - showEndResult ok - liftIO $ addAlert dstatus $ + transferprocess remote file = void $ do + ok <- boolSystem "git-annex" + [ Param "copy" + , Param "--fast" + , Param $ if isdownload then "--from" else "--to" + , Param $ Remote.name remote + , File file + ] + addAlert dstatus $ makeAlertFiller ok $ transferFileAlert direction file diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index 9556232a4..c394dc30d 100644 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -11,7 +11,6 @@ import Control.Exception import Control.Concurrent import Common.Annex -import Assistant.ThreadedMonad type TransferSlots = QSemN @@ -29,13 +28,12 @@ newTransferSlots = newQSemN numSlots {- Waits until a transfer slot becomes available, and runs a transfer - 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 +inTransferSlot :: TransferSlots -> IO () -> IO ThreadId +inTransferSlot s a = do waitQSemN s 1 - forkIO $ bracket_ noop done run + forkIO $ bracket_ noop done a where done = transferComplete s - run = unsafeRunThreadState st a {- Call when a transfer is complete. -} transferComplete :: TransferSlots -> IO () diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs index 08aeb78c5..a04861ed6 100644 --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -164,19 +164,23 @@ startTransfer t = liftIO $ putStrLn "start" cancelTransfer :: Transfer -> Handler () cancelTransfer t = do webapp <- getYesod - {- Remove if queued. -} + {- remove queued transfer -} 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 + {- stop running transfer -} + maybe noop (void . liftIO . stop webapp) =<< running webapp + where + running webapp = liftIO $ M.lookup t . currentTransfers + <$> getDaemonStatus (daemonStatus webapp) + stop webapp info = do + putStrLn $ "stopping transfer " ++ show info + {- When there's a thread associated with the + - transfer, it's killed first, to avoid it + - displaying any alert about the transfer having + - failed when the transfer process is killed. -} + maybe noop killThread $ transferTid info + maybe noop killproc $ transferPid info + removeTransfer (daemonStatus webapp) t + killproc pid = do + void $ tryIO $ signalProcess sigTERM pid + threadDelay 100000 -- 0.1 second grace period + void $ tryIO $ signalProcess sigKILL pid |