summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2013-10-29 13:41:44 -0400
committerGravatar Joey Hess <joey@kitenet.net>2013-10-29 13:41:44 -0400
commit2db78797ee58e53f06bd2d104fb203c45247e7c0 (patch)
tree3b8b7ab10eeb2cb8c787a6d57c1a03bb623ece6a
parent255354acc20f2680126b22cc02a0893d1d72d804 (diff)
move code around and rename thread; no functional changes
-rw-r--r--Assistant.hs4
-rw-r--r--Assistant/Monad.hs6
-rw-r--r--Assistant/RemoteProblem.hs23
-rw-r--r--Assistant/RepoProblem.hs23
-rw-r--r--Assistant/Sync.hs4
-rw-r--r--Assistant/Threads/ProblemChecker.hs53
-rw-r--r--Assistant/Threads/RemoteChecker.hs46
-rw-r--r--Assistant/Threads/SanityChecker.hs43
-rw-r--r--Assistant/Types/RepoProblem.hs (renamed from Assistant/Types/RemoteProblem.hs)8
9 files changed, 88 insertions, 122 deletions
diff --git a/Assistant.hs b/Assistant.hs
index 8ae779714..aa1399c03 100644
--- a/Assistant.hs
+++ b/Assistant.hs
@@ -23,7 +23,7 @@ import Assistant.Threads.TransferWatcher
import Assistant.Threads.Transferrer
import Assistant.Threads.SanityChecker
import Assistant.Threads.Cronner
-import Assistant.Threads.RemoteChecker
+import Assistant.Threads.ProblemChecker
#ifdef WITH_CLIBS
import Assistant.Threads.MountWatcher
#endif
@@ -130,7 +130,7 @@ startDaemon assistant foreground startdelay listenhost startbrowser = do
, assist $ daemonStatusThread
, assist $ sanityCheckerDailyThread
, assist $ sanityCheckerHourlyThread
- , assist $ remoteCheckerThread urlrenderer
+ , assist $ problemCheckerThread urlrenderer
#ifdef WITH_CLIBS
, assist $ mountWatcherThread
#endif
diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs
index 154813785..6b843ea88 100644
--- a/Assistant/Monad.hs
+++ b/Assistant/Monad.hs
@@ -39,7 +39,7 @@ import Assistant.Types.Pushes
import Assistant.Types.BranchChange
import Assistant.Types.Commits
import Assistant.Types.Changes
-import Assistant.Types.RemoteProblem
+import Assistant.Types.RepoProblem
import Assistant.Types.Buddies
import Assistant.Types.NetMessager
import Assistant.Types.ThreadName
@@ -64,7 +64,7 @@ data AssistantData = AssistantData
, failedPushMap :: FailedPushMap
, commitChan :: CommitChan
, changePool :: ChangePool
- , remoteProblemChan :: RemoteProblemChan
+ , repoProblemChan :: RepoProblemChan
, branchChangeHandle :: BranchChangeHandle
, buddyList :: BuddyList
, netMessager :: NetMessager
@@ -82,7 +82,7 @@ newAssistantData st dstatus = AssistantData
<*> newFailedPushMap
<*> newCommitChan
<*> newChangePool
- <*> newRemoteProblemChan
+ <*> newRepoProblemChan
<*> newBranchChangeHandle
<*> newBuddyList
<*> newNetMessager
diff --git a/Assistant/RemoteProblem.hs b/Assistant/RemoteProblem.hs
deleted file mode 100644
index c064a9475..000000000
--- a/Assistant/RemoteProblem.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{- git-annex assistant remote problem handling
- -
- - Copyright 2013 Joey Hess <joey@kitenet.net>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-module Assistant.RemoteProblem where
-
-import Assistant.Common
-import Utility.TList
-
-import Control.Concurrent.STM
-
-{- Gets all remotes that have problems.
- - Blocks until there is at least one. -}
-getRemoteProblems :: Assistant [Remote]
-getRemoteProblems = (atomically . getTList) <<~ remoteProblemChan
-
-{- Indicates that there was a problem accessing a remote, and the problem
- - appears to not be a transient (eg network connection) problem. -}
-remoteHasProblem :: Remote -> Assistant ()
-remoteHasProblem r = (atomically . flip consTList r) <<~ remoteProblemChan
diff --git a/Assistant/RepoProblem.hs b/Assistant/RepoProblem.hs
new file mode 100644
index 000000000..d2e5a5cf1
--- /dev/null
+++ b/Assistant/RepoProblem.hs
@@ -0,0 +1,23 @@
+{- git-annex assistant remote problem handling
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.RepoProblem where
+
+import Assistant.Common
+import Utility.TList
+
+import Control.Concurrent.STM
+
+{- Gets all repositories that have problems.
+ - Blocks until there is at least one. -}
+getRepoProblems :: Assistant [UUID]
+getRepoProblems = (atomically . getTList) <<~ repoProblemChan
+
+{- Indicates that there was a problem accessing a repo, and the problem
+ - appears to not be a transient (eg network connection) problem. -}
+repoHasProblem :: UUID -> Assistant ()
+repoHasProblem r = (atomically . flip consTList r) <<~ repoProblemChan
diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs
index 5715901d6..4a021df2e 100644
--- a/Assistant/Sync.hs
+++ b/Assistant/Sync.hs
@@ -33,7 +33,7 @@ import Assistant.NamedThread
import Assistant.Threads.Watcher (watchThread, WatcherControl(..))
import Assistant.TransferSlots
import Assistant.TransferQueue
-import Assistant.RemoteProblem
+import Assistant.RepoProblem
import Logs.Transfer
import Data.Time.Clock
@@ -67,7 +67,7 @@ reconnectRemotes notifypushes rs = void $ do
failedrs <- syncAction rs' (const go)
forM_ failedrs $ \r ->
whenM (liftIO $ Remote.checkAvailable False r) $
- remoteHasProblem r
+ repoHasProblem (Remote.uuid r)
mapM_ signal $ filter (`notElem` failedrs) rs'
where
gitremotes = filter (notspecialremote . Remote.repo) rs
diff --git a/Assistant/Threads/ProblemChecker.hs b/Assistant/Threads/ProblemChecker.hs
new file mode 100644
index 000000000..1a30a337e
--- /dev/null
+++ b/Assistant/Threads/ProblemChecker.hs
@@ -0,0 +1,53 @@
+{- git-annex assistant thread to handle reported problems with repositories
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Threads.ProblemChecker (
+ problemCheckerThread
+) where
+
+import Assistant.Common
+import Utility.ThreadScheduler
+import Assistant.Types.UrlRenderer
+import Assistant.Alert
+import Remote
+import qualified Types.Remote as Remote
+import qualified Git.Fsck
+import Assistant.Repair
+import qualified Git
+import Assistant.RepoProblem
+import Assistant.Sync
+import Annex.UUID
+
+{- Waits for problems with a repo, and tries to fsck the repo and repair
+ - the problem. -}
+problemCheckerThread :: UrlRenderer -> NamedThread
+problemCheckerThread urlrenderer = namedThread "ProblemChecker" $ forever $ do
+ mapM_ (handleProblem urlrenderer)
+ =<< nub <$> getRepoProblems
+ liftIO $ threadDelaySeconds (Seconds 60)
+
+handleProblem :: UrlRenderer -> UUID -> Assistant ()
+handleProblem urlrenderer u = ifM ((==) u <$> liftAnnex getUUID)
+ ( handleLocalRepoProblem urlrenderer
+ , maybe noop (handleRemoteProblem urlrenderer)
+ =<< liftAnnex (remoteFromUUID u)
+ )
+
+handleRemoteProblem :: UrlRenderer -> Remote -> Assistant ()
+handleRemoteProblem urlrenderer rmt
+ | Git.repoIsLocal r && not (Git.repoIsLocalUnknown r) =
+ whenM (liftIO $ checkAvailable True rmt) $ do
+ fsckresults <- showFscking urlrenderer (Just $ Remote.name rmt) $ tryNonAsync $
+ Git.Fsck.findBroken True r
+ whenM (repairWhenNecessary urlrenderer (Remote.uuid rmt) (Just rmt) fsckresults) $
+ syncRemote rmt
+ | otherwise = noop
+ where
+ r = Remote.repo rmt
+
+handleLocalRepoProblem :: UrlRenderer -> Assistant ()
+handleLocalRepoProblem urlrenderer = error "TODO"
diff --git a/Assistant/Threads/RemoteChecker.hs b/Assistant/Threads/RemoteChecker.hs
deleted file mode 100644
index ea0b578d2..000000000
--- a/Assistant/Threads/RemoteChecker.hs
+++ /dev/null
@@ -1,46 +0,0 @@
-{- git-annex assistant remote checker thread
- -
- - Copyright 2013 Joey Hess <joey@kitenet.net>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-module Assistant.Threads.RemoteChecker (
- remoteCheckerThread
-) where
-
-import Assistant.Common
-import Utility.ThreadScheduler
-import Assistant.Types.UrlRenderer
-import Assistant.Alert
-import Remote
-import qualified Types.Remote as Remote
-import qualified Git.Fsck
-import Assistant.Repair
-import qualified Git
-import Assistant.RemoteProblem
-import Assistant.Sync
-
-import Data.Function
-
-{- Waits for problems with remotes, and tries to fsck the remote and repair
- - the problem. -}
-remoteCheckerThread :: UrlRenderer -> NamedThread
-remoteCheckerThread urlrenderer = namedThread "RemoteChecker" $ forever $ do
- mapM_ (handleProblem urlrenderer)
- =<< liftIO . filterM (checkAvailable True)
- =<< nubremotes <$> getRemoteProblems
- liftIO $ threadDelaySeconds (Seconds 60)
- where
- nubremotes = nubBy ((==) `on` Remote.uuid)
-
-handleProblem :: UrlRenderer -> Remote -> Assistant ()
-handleProblem urlrenderer rmt
- | Git.repoIsLocal r && not (Git.repoIsLocalUnknown r) = do
- fsckresults <- showFscking urlrenderer (Just $ Remote.name rmt) $ tryNonAsync $
- Git.Fsck.findBroken True r
- whenM (repairWhenNecessary urlrenderer (Remote.uuid rmt) (Just rmt) fsckresults) $
- syncRemote rmt
- | otherwise = noop
- where
- r = Remote.repo rmt
diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs
index d8ffa41f4..916cf52c4 100644
--- a/Assistant/Threads/SanityChecker.hs
+++ b/Assistant/Threads/SanityChecker.hs
@@ -14,6 +14,7 @@ module Assistant.Threads.SanityChecker (
import Assistant.Common
import Assistant.DaemonStatus
import Assistant.Alert
+import Assistant.Repair
import qualified Git.LsFiles
import qualified Git.Command
import qualified Git.Config
@@ -23,8 +24,6 @@ import Utility.LogFile
import Utility.Batch
import Utility.NotificationBroadcaster
import Config
-import qualified Git
-import qualified Utility.Lsof as Lsof
import Utility.HumanTime
import Data.Time.Clock.POSIX
@@ -146,46 +145,6 @@ checkLogSize n = do
where
filesize f = fromIntegral . fileSize <$> liftIO (getFileStatus f)
-{- Detect when a git lock file exists and has no git process currently
- - writing to it. This strongly suggests it is a stale lock file.
- -
- - However, this could be on a network filesystem. Which is not very safe
- - anyway (the assistant relies on being able to check when files have
- - no writers to know when to commit them). Just in case, when the lock
- - file appears stale, we delay for one minute, and check its size. If
- - the size changed, delay for another minute, and so on. This will at
- - least work to detect is another machine is writing out a new index
- - file, since git does so by writing the new content to index.lock.
- -}
-checkStaleGitLocks :: Assistant ()
-checkStaleGitLocks = do
- lockfiles <- filter (not . isInfixOf "gc.pid")
- . filter (".lock" `isSuffixOf`)
- <$> (liftIO . dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir)
- =<< liftAnnex (fromRepo Git.localGitDir))
- checkStaleLocks lockfiles
-checkStaleLocks :: [FilePath] -> Assistant ()
-checkStaleLocks lockfiles = go =<< getsizes
- where
- getsize lf = catchMaybeIO $
- (\s -> (lf, fileSize s)) <$> getFileStatus lf
- getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles
- go [] = return ()
- go l = ifM (liftIO $ null <$> Lsof.query ("--" : map fst l))
- ( do
- waitforit "to check stale git lock file"
- l' <- getsizes
- if l' == l
- then liftIO $ mapM_ nukeFile (map fst l)
- else go l'
- , do
- waitforit "for git lock file writer"
- go =<< getsizes
- )
- waitforit why = do
- notice ["Waiting for 60 seconds", why]
- liftIO $ threadDelaySeconds $ Seconds 60
-
oneMegabyte :: Int
oneMegabyte = 1000000
diff --git a/Assistant/Types/RemoteProblem.hs b/Assistant/Types/RepoProblem.hs
index 539da3db9..40397c708 100644
--- a/Assistant/Types/RemoteProblem.hs
+++ b/Assistant/Types/RepoProblem.hs
@@ -5,14 +5,14 @@
- Licensed under the GNU GPL version 3 or higher.
-}
-module Assistant.Types.RemoteProblem where
+module Assistant.Types.RepoProblem where
import Types
import Utility.TList
import Control.Concurrent.STM
-type RemoteProblemChan = TList Remote
+type RepoProblemChan = TList UUID
-newRemoteProblemChan :: IO RemoteProblemChan
-newRemoteProblemChan = atomically newTList
+newRepoProblemChan :: IO RepoProblemChan
+newRepoProblemChan = atomically newTList