diff --git a/Assistant/Repair.hs b/Assistant/Repair.hs new file mode 100644 index 0000000000..282864d1b7 --- /dev/null +++ b/Assistant/Repair.hs @@ -0,0 +1,59 @@ +{- git-annex assistant repository repair + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-} + +module Assistant.Repair where + +import Assistant.Common +import Command.Repair (repairAnnexBranch) +import Git.Repair (runRepairOf) +import Logs.FsckResults +import Annex.UUID +import Utility.Batch +import Config.Files +import Assistant.Sync + +import Control.Concurrent.Async + +runRepair :: UUID -> Assistant () +runRepair u = do + -- Stop the watcher from running while running repairs. + changeSyncable Nothing False + + fsckresults <- liftAnnex $ readFsckResults u + myu <- liftAnnex getUUID + if u == myu + then localrepair fsckresults + else remoterepair fsckresults + liftAnnex $ writeFsckResults u Nothing + + -- Start the watcher running again. This also triggers it to do a + -- startup scan, which is especially important if the git repo + -- repair removed files from the index file. Those files will be + -- seen as new, and re-added to the repository. + changeSyncable Nothing True + where + localrepair fsckresults = do + -- This intentionally runs the repair inside the Annex + -- monad, which is not strictly necessary, but keeps + -- other threads that might be trying to use the Annex + -- from running until it completes. + needfsck <- liftAnnex $ do + (ok, stillmissing, modifiedbranches) <- inRepo $ + runRepairOf fsckresults True + repairAnnexBranch stillmissing modifiedbranches + return (not ok) + when needfsck $ + backgroundfsck [ Param "--fast" ] + + remoterepair _fsckresults = do + error "TODO: remote repair" + + backgroundfsck params = liftIO $ void $ async $ do + program <- readProgramFile + batchCommand program (Param "fsck" : params) diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index 43f0309fe1..6a66802d51 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -23,9 +23,17 @@ import qualified Git.Command import qualified Git.Ref import qualified Remote import qualified Types.Remote as Remote +import qualified Remote.List as Remote import qualified Annex.Branch import Annex.UUID import Annex.TaggedPush +import qualified Config +import Git.Config +import Assistant.NamedThread +import Assistant.Threads.Watcher (watchThread, WatcherControl(..)) +import Assistant.TransferSlots +import Assistant.TransferQueue +import Logs.Transfer import Data.Time.Clock import qualified Data.Map as M @@ -233,3 +241,36 @@ syncRemote remote = do reconnectRemotes False [remote] addScanRemotes True [remote] void $ liftIO $ forkIO $ thread + +{- Use Nothing to change autocommit setting; or a remote to change + - its sync setting. -} +changeSyncable :: Maybe Remote -> Bool -> Assistant () +changeSyncable Nothing enable = do + liftAnnex $ Config.setConfig key (boolConfig enable) + liftIO . maybe noop (`throwTo` signal) + =<< namedThreadId watchThread + where + key = Config.annexConfig "autocommit" + signal + | enable = ResumeWatcher + | otherwise = PauseWatcher +changeSyncable (Just r) True = do + liftAnnex $ changeSyncFlag r True + syncRemote r +changeSyncable (Just r) False = do + liftAnnex $ changeSyncFlag r False + updateSyncRemotes + {- Stop all transfers to or from this remote. + - XXX Can't stop any ongoing scan, or git syncs. -} + void $ dequeueTransfers tofrom + mapM_ (cancelTransfer False) =<< + filter tofrom . M.keys . currentTransfers <$> getDaemonStatus + where + tofrom t = transferUUID t == Remote.uuid r + +changeSyncFlag :: Remote -> Bool -> Annex () +changeSyncFlag r enabled = do + Config.setConfig key (boolConfig enabled) + void Remote.remoteListRefresh + where + key = Config.remoteConfig (Remote.repo r) "sync" diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs index 9bc851d4e7..fc09373e79 100644 --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -9,9 +9,7 @@ module Assistant.Threads.TransferWatcher where import Assistant.Common import Assistant.DaemonStatus -import Assistant.TransferQueue -import Assistant.Drop -import Annex.Content +import Assistant.TransferSlots import Logs.Transfer import Utility.DirWatcher import Utility.DirWatcher.Types @@ -98,28 +96,3 @@ onDel file = case parseTransferFile file of - runs. -} threadDelay 10000000 -- 10 seconds finished t minfo - -{- Queue uploads of files downloaded to us, spreading them - - out to other reachable remotes. - - - - Downloading a file may have caused a remote to not want it; - - so check for drops from remotes. - - - - Uploading a file may cause the local repo, or some other remote to not - - want it; handle that too. - -} -finishedTransfer :: Transfer -> Maybe TransferInfo -> Assistant () -finishedTransfer t (Just info) - | transferDirection t == Download = - whenM (liftAnnex $ inAnnex $ transferKey t) $ do - dodrops False - queueTransfersMatching (/= transferUUID t) - "newly received object" - Later (transferKey t) (associatedFile info) Upload - | otherwise = dodrops True - where - dodrops fromhere = handleDrops - ("drop wanted after " ++ describeTransfer t info) - fromhere (transferKey t) (associatedFile info) Nothing -finishedTransfer _ _ = noop - diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index 98f8b6ad75..82f3f3e105 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -36,105 +36,3 @@ transfererThread = namedThread "Transferrer" $ do where {- Skip transfers that are already running. -} notrunning = isNothing . startedTime - -{- By the time this is called, the daemonstatus's currentTransfers map should - - already have been updated to include the transfer. -} -genTransfer :: Transfer -> TransferInfo -> TransferGenerator -genTransfer t info = case (transferRemote info, associatedFile info) of - (Just remote, Just file) - | Git.repoIsLocalUnknown (Remote.repo remote) -> do - -- optimisation for removable drives not plugged in - liftAnnex $ recordFailedTransfer t info - void $ removeTransfer t - return Nothing - | otherwise -> ifM (liftAnnex $ shouldTransfer t info) - ( do - debug [ "Transferring:" , describeTransfer t info ] - notifyTransfer - return $ Just (t, info, go remote file) - , do - debug [ "Skipping unnecessary transfer:", - describeTransfer t info ] - void $ removeTransfer t - finishedTransfer t (Just info) - return Nothing - ) - _ -> return Nothing - where - direction = transferDirection t - isdownload = direction == Download - - {- Alerts are only shown for successful transfers. - - Transfers can temporarily fail for many reasons, - - so there's no point in bothering the user about - - those. The assistant should recover. - - - - After a successful upload, handle dropping it from - - here, if desired. In this case, the remote it was - - uploaded to is known to have it. - - - - Also, after a successful transfer, the location - - log has changed. Indicate that a commit has been - - made, in order to queue a push of the git-annex - - branch out to remotes that did not participate - - in the transfer. - - - - If the process failed, it could have crashed, - - so remove the transfer from the list of current - - transfers, just in case it didn't stop - - in a way that lets the TransferWatcher do its - - usual cleanup. However, first check if something else is - - running the transfer, to avoid removing active transfers. - -} - go remote file transferrer = ifM (liftIO $ performTransfer transferrer t $ associatedFile info) - ( do - void $ addAlert $ makeAlertFiller True $ - transferFileAlert direction True file - unless isdownload $ - handleDrops - ("object uploaded to " ++ show remote) - True (transferKey t) - (associatedFile info) - (Just remote) - void recordCommit - , whenM (liftAnnex $ isNothing <$> checkTransfer t) $ - void $ removeTransfer t - ) - -{- Called right before a transfer begins, this is a last chance to avoid - - unnecessary transfers. - - - - For downloads, we obviously don't need to download if the already - - have the object. - - - - Smilarly, for uploads, check if the remote is known to already have - - the object. - - - - Also, uploads get queued to all remotes, in order of cost. - - This may mean, for example, that an object is uploaded over the LAN - - to a locally paired client, and once that upload is done, a more - - expensive transfer remote no longer wants the object. (Since - - all the clients have it already.) So do one last check if this is still - - preferred content. - - - - We'll also do one last preferred content check for downloads. An - - example of a case where this could be needed is if a download is queued - - for a file that gets moved out of an archive directory -- but before - - that download can happen, the file is put back in the archive. - -} -shouldTransfer :: Transfer -> TransferInfo -> Annex Bool -shouldTransfer t info - | transferDirection t == Download = - (not <$> inAnnex key) <&&> wantGet True file - | transferDirection t == Upload = case transferRemote info of - Nothing -> return False - Just r -> notinremote r - <&&> wantSend True file (Remote.uuid r) - | otherwise = return False - where - key = transferKey t - file = associatedFile info - - {- Trust the location log to check if the remote already has - - the key. This avoids a roundtrip to the remote. -} - notinremote r = notElem (Remote.uuid r) <$> loggedLocations key diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index a446646391..3eedbe145d 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -9,7 +9,7 @@ module Assistant.Threads.Watcher ( watchThread, - WatcherException(..), + WatcherControl(..), checkCanWatch, needLsof, onAddSymlink, @@ -64,10 +64,10 @@ needLsof = error $ unlines ] {- A special exception that can be thrown to pause or resume the watcher. -} -data WatcherException = PauseWatcher | ResumeWatcher +data WatcherControl = PauseWatcher | ResumeWatcher deriving (Show, Eq, Typeable) -instance E.Exception WatcherException +instance E.Exception WatcherControl watchThread :: NamedThread watchThread = namedThread "Watcher" $ @@ -107,7 +107,7 @@ runWatcher = do where hook a = Just <$> asIO2 (runHandler a) -waitFor :: WatcherException -> Assistant () -> Assistant () +waitFor :: WatcherControl -> Assistant () -> Assistant () waitFor sig next = do r <- liftIO (E.try pause :: IO (Either E.SomeException ())) case r of diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index 81a778a0ac..36d557c3d7 100644 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -13,11 +13,27 @@ import Assistant.Types.TransferSlots import Assistant.DaemonStatus import Assistant.TransferrerPool import Assistant.Types.TransferrerPool +import Assistant.Types.TransferQueue +import Assistant.TransferQueue +import Assistant.Alert +import Assistant.Alert.Utility +import Assistant.Commits +import Assistant.Drop import Logs.Transfer +import Logs.Location +import qualified Git +import qualified Remote +import qualified Types.Remote as Remote +import Annex.Content +import Annex.Wanted +import Config.Files +import qualified Data.Map as M import qualified Control.Exception as E import Control.Concurrent import qualified Control.Concurrent.MSemN as MSemN +import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL) +import System.Posix.Process (getProcessGroupIDOf) type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, Transferrer -> Assistant ())) @@ -76,3 +92,186 @@ runTransferThread' program d run = go _ -> done done = runAssistant d $ flip MSemN.signal 1 <<~ transferSlots + +{- By the time this is called, the daemonstatus's currentTransfers map should + - already have been updated to include the transfer. -} +genTransfer :: Transfer -> TransferInfo -> TransferGenerator +genTransfer t info = case (transferRemote info, associatedFile info) of + (Just remote, Just file) + | Git.repoIsLocalUnknown (Remote.repo remote) -> do + -- optimisation for removable drives not plugged in + liftAnnex $ recordFailedTransfer t info + void $ removeTransfer t + return Nothing + | otherwise -> ifM (liftAnnex $ shouldTransfer t info) + ( do + debug [ "Transferring:" , describeTransfer t info ] + notifyTransfer + return $ Just (t, info, go remote file) + , do + debug [ "Skipping unnecessary transfer:", + describeTransfer t info ] + void $ removeTransfer t + finishedTransfer t (Just info) + return Nothing + ) + _ -> return Nothing + where + direction = transferDirection t + isdownload = direction == Download + + {- Alerts are only shown for successful transfers. + - Transfers can temporarily fail for many reasons, + - so there's no point in bothering the user about + - those. The assistant should recover. + - + - After a successful upload, handle dropping it from + - here, if desired. In this case, the remote it was + - uploaded to is known to have it. + - + - Also, after a successful transfer, the location + - log has changed. Indicate that a commit has been + - made, in order to queue a push of the git-annex + - branch out to remotes that did not participate + - in the transfer. + - + - If the process failed, it could have crashed, + - so remove the transfer from the list of current + - transfers, just in case it didn't stop + - in a way that lets the TransferWatcher do its + - usual cleanup. However, first check if something else is + - running the transfer, to avoid removing active transfers. + -} + go remote file transferrer = ifM (liftIO $ performTransfer transferrer t $ associatedFile info) + ( do + void $ addAlert $ makeAlertFiller True $ + transferFileAlert direction True file + unless isdownload $ + handleDrops + ("object uploaded to " ++ show remote) + True (transferKey t) + (associatedFile info) + (Just remote) + void recordCommit + , whenM (liftAnnex $ isNothing <$> checkTransfer t) $ + void $ removeTransfer t + ) + +{- Called right before a transfer begins, this is a last chance to avoid + - unnecessary transfers. + - + - For downloads, we obviously don't need to download if the already + - have the object. + - + - Smilarly, for uploads, check if the remote is known to already have + - the object. + - + - Also, uploads get queued to all remotes, in order of cost. + - This may mean, for example, that an object is uploaded over the LAN + - to a locally paired client, and once that upload is done, a more + - expensive transfer remote no longer wants the object. (Since + - all the clients have it already.) So do one last check if this is still + - preferred content. + - + - We'll also do one last preferred content check for downloads. An + - example of a case where this could be needed is if a download is queued + - for a file that gets moved out of an archive directory -- but before + - that download can happen, the file is put back in the archive. + -} +shouldTransfer :: Transfer -> TransferInfo -> Annex Bool +shouldTransfer t info + | transferDirection t == Download = + (not <$> inAnnex key) <&&> wantGet True file + | transferDirection t == Upload = case transferRemote info of + Nothing -> return False + Just r -> notinremote r + <&&> wantSend True file (Remote.uuid r) + | otherwise = return False + where + key = transferKey t + file = associatedFile info + + {- Trust the location log to check if the remote already has + - the key. This avoids a roundtrip to the remote. -} + notinremote r = notElem (Remote.uuid r) <$> loggedLocations key + +{- Queue uploads of files downloaded to us, spreading them + - out to other reachable remotes. + - + - Downloading a file may have caused a remote to not want it; + - so check for drops from remotes. + - + - Uploading a file may cause the local repo, or some other remote to not + - want it; handle that too. + -} +finishedTransfer :: Transfer -> Maybe TransferInfo -> Assistant () +finishedTransfer t (Just info) + | transferDirection t == Download = + whenM (liftAnnex $ inAnnex $ transferKey t) $ do + dodrops False + queueTransfersMatching (/= transferUUID t) + "newly received object" + Later (transferKey t) (associatedFile info) Upload + | otherwise = dodrops True + where + dodrops fromhere = handleDrops + ("drop wanted after " ++ describeTransfer t info) + fromhere (transferKey t) (associatedFile info) Nothing +finishedTransfer _ _ = noop + +{- Pause a running transfer. -} +pauseTransfer :: Transfer -> Assistant () +pauseTransfer = cancelTransfer True + +{- Cancel a running transfer. -} +cancelTransfer :: Bool -> Transfer -> Assistant () +cancelTransfer pause t = do + m <- getCurrentTransfers + unless pause $ + {- remove queued transfer -} + void $ dequeueTransfers $ equivilantTransfer t + {- stop running transfer -} + maybe noop stop (M.lookup t m) + where + stop info = do + {- When there's a thread associated with the + - transfer, it's signaled first, to avoid it + - displaying any alert about the transfer having + - failed when the transfer process is killed. -} + liftIO $ maybe noop signalthread $ transferTid info + liftIO $ maybe noop killproc $ transferPid info + if pause + then void $ alterTransferInfo t $ + \i -> i { transferPaused = True } + else void $ removeTransfer t + signalthread tid + | pause = throwTo tid PauseTransfer + | otherwise = killThread tid + {- In order to stop helper processes like rsync, + - kill the whole process group of the process running the transfer. -} + killproc pid = void $ tryIO $ do + g <- getProcessGroupIDOf pid + void $ tryIO $ signalProcessGroup sigTERM g + threadDelay 50000 -- 0.05 second grace period + void $ tryIO $ signalProcessGroup sigKILL g + +{- Start or resume a transfer. -} +startTransfer :: Transfer -> Assistant () +startTransfer t = do + m <- getCurrentTransfers + maybe startqueued go (M.lookup t m) + where + go info = maybe (start info) resume $ transferTid info + startqueued = do + is <- map snd <$> getMatchingTransfers (== t) + maybe noop start $ headMaybe is + resume tid = do + alterTransferInfo t $ \i -> i { transferPaused = False } + liftIO $ throwTo tid ResumeTransfer + start info = do + program <- liftIO readProgramFile + inImmediateTransferSlot program $ + genTransfer t info + +getCurrentTransfers :: Assistant TransferMap +getCurrentTransfers = currentTransfers <$> getDaemonStatus diff --git a/Assistant/WebApp/Configurators/Delete.hs b/Assistant/WebApp/Configurators/Delete.hs index 2eb5404465..074f20f6b7 100644 --- a/Assistant/WebApp/Configurators/Delete.hs +++ b/Assistant/WebApp/Configurators/Delete.hs @@ -14,6 +14,7 @@ import Assistant.DeleteRemote import Assistant.WebApp.Utility import Assistant.DaemonStatus import Assistant.ScanRemotes +import Assistant.Sync import qualified Remote import qualified Git import Config.Files @@ -91,9 +92,10 @@ deleteCurrentRepository = dangerPage $ do {- Disable syncing to this repository, and all - remotes. This stops all transfers, and all - file watching. -} - changeSyncable Nothing False - rs <- liftAssistant $ syncRemotes <$> getDaemonStatus - mapM_ (\r -> changeSyncable (Just r) False) rs + liftAssistant $ do + changeSyncable Nothing False + rs <- syncRemotes <$> getDaemonStatus + mapM_ (\r -> changeSyncable (Just r) False) rs {- Make all directories writable, so all annexed - content can be deleted. -} diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs index 9200cd2459..f24ebca60e 100644 --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -10,12 +10,12 @@ module Assistant.WebApp.Configurators.Edit where import Assistant.WebApp.Common -import Assistant.WebApp.Utility import Assistant.WebApp.Gpg import Assistant.DaemonStatus import Assistant.MakeRemote (uniqueRemoteName) import Assistant.WebApp.Configurators.XMPP (xmppNeeded) import Assistant.ScanRemotes +import Assistant.Sync import qualified Assistant.WebApp.Configurators.AWS as AWS import qualified Assistant.WebApp.Configurators.IA as IA #ifdef WITH_S3 @@ -124,7 +124,7 @@ setRepoConfig uuid mremote oldc newc = do Nothing -> addScanRemotes True =<< syncDataRemotes <$> getDaemonStatus when syncableChanged $ - changeSyncable mremote (repoSyncable newc) + liftAssistant $ changeSyncable mremote (repoSyncable newc) where syncableChanged = repoSyncable oldc /= repoSyncable newc associatedDirectoryChanged = repoAssociatedDirectory oldc /= repoAssociatedDirectory newc diff --git a/Assistant/WebApp/Control.hs b/Assistant/WebApp/Control.hs index 7521c1e75b..b7684531ad 100644 --- a/Assistant/WebApp/Control.hs +++ b/Assistant/WebApp/Control.hs @@ -13,8 +13,8 @@ import Assistant.WebApp.Common import Config.Files import Utility.LogFile import Assistant.DaemonStatus -import Assistant.WebApp.Utility import Assistant.Alert +import Assistant.TransferSlots import Control.Concurrent import System.Posix (getProcessID, signalProcess, sigTERM) @@ -26,16 +26,16 @@ getShutdownR = page "Shutdown" Nothing $ getShutdownConfirmedR :: Handler Html getShutdownConfirmedR = do - {- Remove all alerts for currently running activities. -} liftAssistant $ do + {- Remove all alerts for currently running activities. -} updateAlertMap $ M.filter $ \a -> alertClass a /= Activity void $ addAlert shutdownAlert - {- Stop transfers the assistant is running, - - otherwise they would continue past shutdown. - - Pausing transfers prevents more being started up (and stops - - the transfer processes). -} - ts <- liftAssistant $ M.keys . currentTransfers <$> getDaemonStatus - mapM_ pauseTransfer ts + {- Stop transfers the assistant is running, + - otherwise they would continue past shutdown. + - Pausing transfers prevents more being started up (and stops + - the transfer processes). -} + ts <- M.keys . currentTransfers <$> getDaemonStatus + mapM_ pauseTransfer ts page "Shutdown" Nothing $ do {- Wait 2 seconds before shutting down, to give the web - page time to load in the browser. -} diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs index 86460461fe..0458997674 100644 --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -10,10 +10,10 @@ module Assistant.WebApp.DashBoard where import Assistant.WebApp.Common -import Assistant.WebApp.Utility import Assistant.WebApp.RepoList import Assistant.WebApp.Notifications import Assistant.TransferQueue +import Assistant.TransferSlots import Assistant.DaemonStatus import Utility.NotificationBroadcaster import Logs.Transfer @@ -31,7 +31,7 @@ import Control.Concurrent transfersDisplay :: Bool -> Widget transfersDisplay warnNoScript = do webapp <- liftH getYesod - current <- liftH $ M.toList <$> getCurrentTransfers + current <- liftAssistant $ M.toList <$> getCurrentTransfers queued <- take 10 <$> liftAssistant getTransferQueue autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int) let transfers = simplifyTransfers $ current ++ queued @@ -139,15 +139,15 @@ openFileBrowser = do getPauseTransferR :: Transfer -> Handler () getPauseTransferR = noscript postPauseTransferR postPauseTransferR :: Transfer -> Handler () -postPauseTransferR = pauseTransfer +postPauseTransferR = liftAssistant . pauseTransfer getStartTransferR :: Transfer -> Handler () getStartTransferR = noscript postStartTransferR postStartTransferR :: Transfer -> Handler () -postStartTransferR = startTransfer +postStartTransferR = liftAssistant . startTransfer getCancelTransferR :: Transfer -> Handler () getCancelTransferR = noscript postCancelTransferR postCancelTransferR :: Transfer -> Handler () -postCancelTransferR = cancelTransfer False +postCancelTransferR = liftAssistant . cancelTransfer False noscript :: (Transfer -> Handler ()) -> Transfer -> Handler () noscript a t = a t >> redirectBack diff --git a/Assistant/WebApp/Repair.hs b/Assistant/WebApp/Repair.hs index 653fc8d42d..5f022ee2e9 100644 --- a/Assistant/WebApp/Repair.hs +++ b/Assistant/WebApp/Repair.hs @@ -10,17 +10,9 @@ module Assistant.WebApp.Repair where import Assistant.WebApp.Common -import Assistant.WebApp.Utility import Assistant.WebApp.RepoList import Remote (prettyUUID) -import Command.Repair (repairAnnexBranch) -import Git.Repair (runRepairOf) -import Logs.FsckResults -import Annex.UUID -import Utility.Batch -import Config.Files - -import Control.Concurrent.Async +import Assistant.Repair getRepairRepositoryR :: UUID -> Handler Html getRepairRepositoryR = postRepairRepositoryR @@ -33,48 +25,8 @@ getRepairRepositoryRunR :: UUID -> Handler Html getRepairRepositoryRunR = postRepairRepositoryRunR postRepairRepositoryRunR :: UUID -> Handler Html postRepairRepositoryRunR u = do - -- Stop the watcher from running while running repairs. - changeSyncable Nothing False - - fsckthread <- liftAssistant $ runRepair u - - -- Start the watcher running again. This also triggers it to do a - -- startup scan, which is especially important if the git repo - -- repair removed files from the index file. Those files will be - -- seen as new, and re-added to the repository. - changeSyncable Nothing True - - liftAnnex $ writeFsckResults u Nothing - + liftAssistant $ runRepair u page "Repair repository" Nothing $ do let repolist = repoListDisplay $ mainRepoSelector { nudgeAddMore = True } $(widgetFile "control/repairrepository/done") - -runRepair :: UUID -> Assistant () -runRepair u = do - fsckresults <- liftAnnex (readFsckResults u) - myu <- liftAnnex getUUID - if u == myu - then localrepair fsckresults - else remoterepair fsckresults - where - localrepair fsckresults = do - -- This intentionally runs the repair inside the Annex - -- monad, which is not stricktly necessary, but keeps - -- other threads that might be trying to use the Annex - -- from running until it completes. - needfsck <- liftAnnex $ do - (ok, stillmissing, modifiedbranches) <- inRepo $ - runRepairOf fsckresults True - repairAnnexBranch stillmissing modifiedbranches - return (not ok) - when needfsck $ - backgroundfsck [ Param "--fast" ] - - remoterepair _fsckresults = do - error "TODO: remote repair" - - backgroundfsck params = liftIO $ void $ async $ do - program <- readProgramFile - batchCommand program (Param "fsck" : params) diff --git a/Assistant/WebApp/RepoList.hs b/Assistant/WebApp/RepoList.hs index 88169d0ba3..af8d5104d8 100644 --- a/Assistant/WebApp/RepoList.hs +++ b/Assistant/WebApp/RepoList.hs @@ -12,7 +12,6 @@ module Assistant.WebApp.RepoList where import Assistant.WebApp.Common import Assistant.DaemonStatus import Assistant.WebApp.Notifications -import Assistant.WebApp.Utility import Assistant.Ssh import qualified Annex import qualified Remote @@ -208,7 +207,7 @@ getDisableSyncR = flipSync False flipSync :: Bool -> UUID -> Handler () flipSync enable uuid = do mremote <- liftAnnex $ Remote.remoteFromUUID uuid - changeSyncable mremote enable + liftAssistant $ changeSyncable mremote enable redirectBack getRepositoriesReorderR :: Handler () diff --git a/Assistant/WebApp/Utility.hs b/Assistant/WebApp/Utility.hs index fa83631a07..3574831ed7 100644 --- a/Assistant/WebApp/Utility.hs +++ b/Assistant/WebApp/Utility.hs @@ -9,122 +9,17 @@ module Assistant.WebApp.Utility where import Assistant.Common import Assistant.WebApp.Types -import Assistant.DaemonStatus -import Assistant.TransferQueue -import Assistant.Types.TransferSlots -import Assistant.TransferSlots import Assistant.Sync import qualified Remote -import qualified Types.Remote as Remote -import qualified Remote.List as Remote -import qualified Assistant.Threads.Transferrer as Transferrer -import Logs.Transfer import qualified Config import Config.Cost -import Config.Files -import Git.Config -import Assistant.Threads.Watcher -import Assistant.NamedThread import Types.StandardGroups import Git.Remote import Logs.PreferredContent import Assistant.MakeRemote -import qualified Data.Map as M -import Control.Concurrent -import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL) -import System.Posix.Process (getProcessGroupIDOf) import Utility.Yesod -{- Use Nothing to change autocommit setting; or a remote to change - - its sync setting. -} -changeSyncable :: Maybe Remote -> Bool -> Handler () -changeSyncable Nothing enable = do - liftAnnex $ Config.setConfig key (boolConfig enable) - liftIO . maybe noop (`throwTo` signal) - =<< liftAssistant (namedThreadId watchThread) - where - key = Config.annexConfig "autocommit" - signal - | enable = ResumeWatcher - | otherwise = PauseWatcher -changeSyncable (Just r) True = do - changeSyncFlag r True - liftAssistant $ syncRemote r -changeSyncable (Just r) False = do - changeSyncFlag r False - liftAssistant updateSyncRemotes - {- Stop all transfers to or from this remote. - - XXX Can't stop any ongoing scan, or git syncs. -} - void $ liftAssistant $ dequeueTransfers tofrom - mapM_ (cancelTransfer False) =<< - filter tofrom . M.keys <$> - liftAssistant (currentTransfers <$> getDaemonStatus) - where - tofrom t = transferUUID t == Remote.uuid r - -changeSyncFlag :: Remote -> Bool -> Handler () -changeSyncFlag r enabled = liftAnnex $ do - Config.setConfig key (boolConfig enabled) - void Remote.remoteListRefresh - where - key = Config.remoteConfig (Remote.repo r) "sync" - -pauseTransfer :: Transfer -> Handler () -pauseTransfer = cancelTransfer True - -cancelTransfer :: Bool -> Transfer -> Handler () -cancelTransfer pause t = do - m <- getCurrentTransfers - unless pause $ - {- remove queued transfer -} - void $ liftAssistant $ dequeueTransfers $ equivilantTransfer t - {- stop running transfer -} - maybe noop stop (M.lookup t m) - where - stop info = liftAssistant $ do - {- When there's a thread associated with the - - transfer, it's signaled first, to avoid it - - displaying any alert about the transfer having - - failed when the transfer process is killed. -} - liftIO $ maybe noop signalthread $ transferTid info - liftIO $ maybe noop killproc $ transferPid info - if pause - then void $ alterTransferInfo t $ - \i -> i { transferPaused = True } - else void $ removeTransfer t - signalthread tid - | pause = throwTo tid PauseTransfer - | otherwise = killThread tid - {- In order to stop helper processes like rsync, - - kill the whole process group of the process running the transfer. -} - killproc pid = void $ tryIO $ do - g <- getProcessGroupIDOf pid - void $ tryIO $ signalProcessGroup sigTERM g - threadDelay 50000 -- 0.05 second grace period - void $ tryIO $ signalProcessGroup sigKILL g - -startTransfer :: Transfer -> Handler () -startTransfer t = do - m <- getCurrentTransfers - maybe startqueued go (M.lookup t m) - where - go info = maybe (start info) resume $ transferTid info - startqueued = do - is <- liftAssistant $ map snd <$> getMatchingTransfers (== t) - maybe noop start $ headMaybe is - resume tid = do - liftAssistant $ alterTransferInfo t $ - \i -> i { transferPaused = False } - liftIO $ throwTo tid ResumeTransfer - start info = liftAssistant $ do - program <- liftIO readProgramFile - inImmediateTransferSlot program $ - Transferrer.genTransfer t info - -getCurrentTransfers :: Handler TransferMap -getCurrentTransfers = currentTransfers <$> liftAssistant getDaemonStatus - {- Runs an action that creates or enables a cloud remote, - and finishes setting it up, then starts syncing with it, - and finishes by displaying the page to edit it. -}