40ecf58d4b
This does not change the overall license of the git-annex program, which was already AGPL due to a number of sources files being AGPL already. Legally speaking, I'm adding a new license under which these files are now available; I already released their current contents under the GPL license. Now they're dual licensed GPL and AGPL. However, I intend for all my future changes to these files to only be released under the AGPL license, and I won't be tracking the dual licensing status, so I'm simply changing the license statement to say it's AGPL. (In some cases, others wrote parts of the code of a file and released it under the GPL; but in all cases I have contributed a significant portion of the code in each file and it's that code that is getting the AGPL license; the GPL license of other contributors allows combining with AGPL code.)
110 lines
3.2 KiB
Haskell
110 lines
3.2 KiB
Haskell
{- git-annex assistant git merge thread
|
|
-
|
|
- Copyright 2012-2017 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Assistant.Threads.Merger where
|
|
|
|
import Assistant.Common
|
|
import Assistant.TransferQueue
|
|
import Assistant.BranchChange
|
|
import Assistant.Sync
|
|
import Utility.DirWatcher
|
|
import Utility.DirWatcher.Types
|
|
import Annex.CurrentBranch
|
|
import qualified Annex.Branch
|
|
import qualified Git
|
|
import qualified Git.Branch
|
|
import qualified Git.Ref
|
|
import qualified Command.Sync
|
|
|
|
{- This thread watches for changes to .git/refs/, and handles incoming
|
|
- pushes. -}
|
|
mergeThread :: NamedThread
|
|
mergeThread = namedThread "Merger" $ do
|
|
g <- liftAnnex gitRepo
|
|
let dir = Git.localGitDir g </> "refs"
|
|
liftIO $ createDirectoryIfMissing True dir
|
|
let hook a = Just <$> asIO2 (runHandler a)
|
|
changehook <- hook onChange
|
|
errhook <- hook onErr
|
|
let hooks = mkWatchHooks
|
|
{ addHook = changehook
|
|
, modifyHook = changehook
|
|
, errHook = errhook
|
|
}
|
|
void $ liftIO $ watchDir dir (const False) True hooks id
|
|
debug ["watching", dir]
|
|
|
|
type Handler = FilePath -> Assistant ()
|
|
|
|
{- Runs an action handler.
|
|
-
|
|
- Exceptions are ignored, otherwise a whole thread could be crashed.
|
|
-}
|
|
runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
|
|
runHandler handler file _filestatus =
|
|
either (liftIO . print) (const noop) =<< tryIO <~> handler file
|
|
|
|
{- Called when there's an error with inotify. -}
|
|
onErr :: Handler
|
|
onErr = error
|
|
|
|
{- Called when a new branch ref is written, or a branch ref is modified.
|
|
-
|
|
- 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.
|
|
-}
|
|
onChange :: Handler
|
|
onChange file
|
|
| ".lock" `isSuffixOf` file = noop
|
|
| isAnnexBranch file = do
|
|
branchChanged
|
|
diverged <- liftAnnex Annex.Branch.forceUpdate
|
|
when diverged $ do
|
|
updateExportTreeFromLogAll
|
|
queueDeferredDownloads "retrying deferred download" Later
|
|
| otherwise = mergecurrent
|
|
where
|
|
changedbranch = fileToBranch file
|
|
|
|
mergecurrent =
|
|
mergecurrent' =<< liftAnnex getCurrentBranch
|
|
mergecurrent' currbranch@(Just b, _)
|
|
| changedbranch `isRelatedTo` b =
|
|
whenM (liftAnnex $ inRepo $ Git.Branch.changed b changedbranch) $ do
|
|
debug
|
|
[ "merging", Git.fromRef changedbranch
|
|
, "into", Git.fromRef b
|
|
]
|
|
void $ liftAnnex $ Command.Sync.merge
|
|
currbranch Command.Sync.mergeConfig
|
|
def
|
|
Git.Branch.AutomaticCommit
|
|
changedbranch
|
|
mergecurrent' _ = noop
|
|
|
|
{- Is the first branch a synced branch or remote tracking branch related
|
|
- to the second branch, which should be merged into it? -}
|
|
isRelatedTo :: Git.Ref -> Git.Ref -> Bool
|
|
isRelatedTo x y
|
|
| basex /= takeDirectory basex ++ "/" ++ basey = False
|
|
| "/synced/" `isInfixOf` Git.fromRef x = True
|
|
| "refs/remotes/" `isPrefixOf` Git.fromRef x = True
|
|
| otherwise = False
|
|
where
|
|
basex = Git.fromRef $ Git.Ref.base x
|
|
basey = Git.fromRef $ Git.Ref.base y
|
|
|
|
isAnnexBranch :: FilePath -> Bool
|
|
isAnnexBranch f = n `isSuffixOf` f
|
|
where
|
|
n = '/' : Git.fromRef Annex.Branch.name
|
|
|
|
fileToBranch :: FilePath -> Git.Ref
|
|
fileToBranch f = Git.Ref $ "refs" </> base
|
|
where
|
|
base = Prelude.last $ split "/refs/" f
|