adf5195082
I was seeing some interesting crashes after the previous commit, when making file changes slightly faster than the assistant could keep up. error: Ref refs/heads/master is at 7074f8e0a11110c532d06746e334f2fec6af6ab4 but expected 95ea86008d72a40d97a81cfc8fb47a0da92166bd fatal: cannot lock HEAD ref Committer crashed: git commit [Param "--allow-empty-message",Param "-m",Param "",Param "--allow-empty",Param "--quiet"] failed Pusher crashed: thread blocked indefinitely in an STM transaction Clearly the the merger ended up running at the same time as the committer, and with both modifying HEAD the committer crashed. I fixed that by making the Merger run its merge inside the annex monad, which avoids it running concurrently with other git operations. Also by making the committer not crash if git fails. What I don't understand is why the pusher then crashed with a STM deadlock. That must be in either the DaemonStatusHandle or the FailedPushMap, and the latter is only used by the pusher. Did the committer's crash somehow break STM? The BlockedIndefinitelyOnSTM exception is described as: -- |The thread is waiting to retry an STM transaction, but there are no -- other references to any @TVar@s involved, so it can't ever continue. If the Committer had a reference to a TVar and crashed, I can sort of see this leading to that exception.. The crash was quite easy to reproduce after the previous commit, but after making the above change, I have yet to see it again. Here's hoping.
104 lines
3.2 KiB
Haskell
104 lines
3.2 KiB
Haskell
{- git-annex assistant git merge thread
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Assistant.Threads.Merger where
|
|
|
|
import Assistant.Common
|
|
import Assistant.ThreadedMonad
|
|
import Assistant.DaemonStatus
|
|
import Assistant.TransferQueue
|
|
import Utility.DirWatcher
|
|
import Utility.Types.DirWatcher
|
|
import qualified Annex.Branch
|
|
import qualified Git
|
|
import qualified Git.Merge
|
|
import qualified Git.Branch
|
|
|
|
thisThread :: ThreadName
|
|
thisThread = "Merger"
|
|
|
|
{- This thread watches for changes to .git/refs/, and handles incoming
|
|
- pushes. -}
|
|
mergeThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> NamedThread
|
|
mergeThread st dstatus transferqueue = thread $ do
|
|
g <- runThreadState st $ fromRepo id
|
|
let dir = Git.localGitDir g </> "refs"
|
|
createDirectoryIfMissing True dir
|
|
let hook a = Just $ runHandler st dstatus transferqueue a
|
|
let hooks = mkWatchHooks
|
|
{ addHook = hook onAdd
|
|
, errHook = hook onErr
|
|
}
|
|
void $ watchDir dir (const False) hooks id
|
|
debug thisThread ["watching", dir]
|
|
where
|
|
thread = NamedThread thisThread
|
|
|
|
type Handler = ThreadState -> DaemonStatusHandle -> TransferQueue -> FilePath -> Maybe FileStatus -> IO ()
|
|
|
|
{- Runs an action handler.
|
|
-
|
|
- Exceptions are ignored, otherwise a whole thread could be crashed.
|
|
-}
|
|
runHandler :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Handler -> FilePath -> Maybe FileStatus -> IO ()
|
|
runHandler st dstatus transferqueue handler file filestatus = void $
|
|
either print (const noop) =<< tryIO go
|
|
where
|
|
go = handler st dstatus transferqueue file filestatus
|
|
|
|
{- Called when there's an error with inotify. -}
|
|
onErr :: Handler
|
|
onErr _ _ _ msg _ = error msg
|
|
|
|
{- Called when a new branch ref is written.
|
|
-
|
|
- This relies on git's atomic method of updating branch ref files,
|
|
- which is to first write the new file to .lock, and then rename it
|
|
- over the old file. So, ignore .lock files, and the rename ensures
|
|
- the watcher sees a new file being added on each update.
|
|
-
|
|
- At startup, synthetic add events fire, causing this to run, but that's
|
|
- ok; it ensures that any changes pushed since the last time the assistant
|
|
- ran are merged in.
|
|
-}
|
|
onAdd :: Handler
|
|
onAdd st dstatus transferqueue file _
|
|
| ".lock" `isSuffixOf` file = noop
|
|
| isAnnexBranch file = runThreadState st $
|
|
whenM Annex.Branch.forceUpdate $
|
|
queueDeferredDownloads Later transferqueue dstatus
|
|
| "/synced/" `isInfixOf` file = runThreadState st $ do
|
|
mergecurrent =<< inRepo Git.Branch.current
|
|
| otherwise = noop
|
|
where
|
|
changedbranch = fileToBranch file
|
|
mergecurrent (Just current)
|
|
| equivBranches changedbranch current = do
|
|
liftIO $ debug thisThread
|
|
[ "merging"
|
|
, show changedbranch
|
|
, "into"
|
|
, show current
|
|
]
|
|
void $ inRepo $
|
|
Git.Merge.mergeNonInteractive changedbranch
|
|
mergecurrent _ = noop
|
|
|
|
equivBranches :: Git.Ref -> Git.Ref -> Bool
|
|
equivBranches x y = base x == base y
|
|
where
|
|
base = takeFileName . show
|
|
|
|
isAnnexBranch :: FilePath -> Bool
|
|
isAnnexBranch f = n `isSuffixOf` f
|
|
where
|
|
n = "/" ++ show Annex.Branch.name
|
|
|
|
fileToBranch :: FilePath -> Git.Ref
|
|
fileToBranch f = Git.Ref $ "refs" </> base
|
|
where
|
|
base = Prelude.last $ split "/refs/" f
|