.forgejo/patches/ghc-9.8.patch

@@ -1,18 +0,0 @@
-Support ghc-9.8 by widening a lot of constraints.
-
-This patch can be removed once upstream supports ghc 9.8 offically.
-
-diff -uprN git-annex-10.20240227.orig/cabal.project git-annex-10.20240227/cabal.project
---- git-annex-10.20240227.orig/cabal.project	1970-01-01 01:00:00.000000000 +0100
-+++ git-annex-10.20240227/cabal.project	2024-04-28 13:30:14.061706299 +0200
-@@ -0,0 +1,10 @@
-+packages: *.cabal
-+
-+allow-newer: dav
-+allow-newer: haskeline:filepath
-+allow-newer: haskeline:directory
-+allow-newer: xml-hamlet
-+allow-newer: aws:filepath
-+allow-newer: dbus:network
-+allow-newer: dbus:filepath
-+allow-newer: microstache:filepath

.forgejo/workflows/generate-lockfile.yml

@@ -1,85 +0,0 @@
-on:
-  workflow_dispatch:
-    inputs:
-      ref_name:
-        description: 'Tag or commit'
-        required: true
-        type: string
-
-  push:
-    tags:
-      - '*'
-
-jobs:
-  cabal-config-edge:
-    name: Generate cabal config for edge
-    runs-on: x86_64
-    container:
-      image: alpine:edge
-    env:
-      CI_ALPINE_TARGET_RELEASE: edge
-    steps:
-      - name: Environment setup
-        run: apk add nodejs git cabal patch
-      - name: Repo pull
-        uses: actions/checkout@v4
-        with:
-          fetch-depth: 1
-          ref: ${{ inputs.ref_name }}
-      - name: Config generation
-        run: |
-          patch -p1 -i .forgejo/patches/ghc-9.8.patch
-          HOME="${{ github.workspace}}"/cabal_cache cabal update
-          HOME="${{ github.workspace}}"/cabal_cache cabal v2-freeze --shadow-installed-packages --strong-flags --flags="+assistant +webapp +pairing +production +torrentparser +magicmime +benchmark -debuglocks +dbus +networkbsd +gitlfs +httpclientrestricted"
-          mv cabal.project.freeze git-annex.config
-      - name: Package upload
-        uses: forgejo/upload-artifact@v3
-        with:
-          name: cabalconfigedge
-          path: git-annex*.config
-  cabal-config-v321:
-    name: Generate cabal config for v3.21
-    runs-on: x86_64
-    container:
-      image: alpine:3.21
-    env:
-      CI_ALPINE_TARGET_RELEASE: v3.21
-    steps:
-      - name: Environment setup
-        run: apk add nodejs git cabal patch
-      - name: Repo pull
-        uses: actions/checkout@v4
-        with:
-          fetch-depth: 1
-          ref: ${{ inputs.ref_name }}
-      - name: Config generation
-        run: |
-          patch -p1 -i .forgejo/patches/ghc-9.8.patch
-          HOME="${{ github.workspace }}"/cabal_cache cabal update
-          HOME="${{ github.workspace }}"/cabal_cache cabal v2-freeze --shadow-installed-packages --strong-flags --flags="+assistant +webapp +pairing +production +torrentparser +magicmime +benchmark -debuglocks +dbus +networkbsd +gitlfs +httpclientrestricted"
-          mv cabal.project.freeze git-annex.config
-      - name: Package upload
-        uses: forgejo/upload-artifact@v3
-        with:
-          name: cabalconfig321
-          path: git-annex*.config
-  upload-tarball:
-    name: Upload to generic repo
-    runs-on: x86_64
-    needs: [cabal-config-edge,cabal-config-v321]
-    container:
-      image: alpine:latest
-    steps:
-      - name: Environment setup
-        run: apk add nodejs curl findutils
-      - name: Package download
-        uses: forgejo/download-artifact@v3
-      - name: Package deployment 
-        run: |
-          if test $GITHUB_REF_NAME == "ci" ; then
-            CI_REF_NAME=${{ inputs.ref_name }}
-          else
-            CI_REF_NAME=$GITHUB_REF_NAME
-          fi
-          curl --user ${{ vars.CODE_FORGEJO_USER }}:${{ secrets.CODE_FORGEJO_TOKEN }} --upload-file ./cabalconfigedge/git-annex.config ${{ github.server_url }}/api/packages/mirrors/generic/git-annex/$CI_REF_NAME/git-annex-$CI_REF_NAME-edge.cabal
-          curl --user ${{ vars.CODE_FORGEJO_USER }}:${{ secrets.CODE_FORGEJO_TOKEN }} --upload-file ./cabalconfig321/git-annex.config ${{ github.server_url }}/api/packages/mirrors/generic/git-annex/$CI_REF_NAME/git-annex-$CI_REF_NAME-v321.cabal

.forgejo/workflows/mirror-repository.yml

@@ -1,50 +0,0 @@
-on:
-  workflow_dispatch:
-
-  schedule:
-    - cron: '@hourly'
-
-jobs:
-  mirror:
-    name: Pull from upstream
-    runs-on: x86_64
-    container:
-      image: alpine:latest
-    env:
-      upstream: https://git.joeyh.name/git/git-annex.git 
-      tags: '10.2025*'
-    steps:
-      - name: Environment setup
-        run: apk add grep git sed coreutils bash nodejs
-      - name: Fetch destination
-        uses: actions/checkout@v4
-        with:
-          fetch_depth: 1
-          ref: ci
-          token: ${{ secrets.CODE_FORGEJO_TOKEN }}
-      - name: Missing tag detecting
-        run: |
-          git ls-remote $upstream "refs/tags/$tags" | grep -v '{' | sed 's|.*/||' | sort > upstream_tags
-          git ls-remote ${{ github.server_url}}/${{ github.repository }} "refs/tags/$tags" | grep -v '{' | sed 's|.*/||' | sort > destination_tags
-          comm -23 upstream_tags destination_tags > missing_tags
-          echo "Missing tags:"
-          cat missing_tags
-      - name: Missing tag fetch
-        run: |
-          git remote add upstream $upstream
-          while read tag; do
-            git fetch upstream tag $tag --no-tags
-          done < missing_tags
-      - name: Packaging workflow injection
-        run: |
-          while read tag; do
-            git checkout $tag
-            git tag -d $tag
-            git checkout ci -- ./.forgejo
-            git config user.name "forgejo-actions[bot]"
-            git config user.email "dev@ayakael.net"
-            git commit -m 'Inject custom workflow'
-            git tag -a $tag -m $tag
-          done < missing_tags
-      - name: Push to destination
-        run: git push --force origin refs/tags/*:refs/tags/* --tags   

.ghci

@@ -0,0 +1 @@
+:load Common

.gitattributes

@@ -0,0 +1 @@
+CHANGELOG merge=dpkg-mergechangelogs

.gitignore

@@ -0,0 +1,36 @@
+tags
+Setup
+*.hi
+*.o
+tmp
+test
+Build/SysConfig
+Build/Version
+Build/InstallDesktopFile
+Build/EvilSplicer
+Build/Standalone
+Build/OSXMkLibs
+Build/LinuxMkLibs
+Build/BuildVersion
+Build/MakeMans
+git-annex
+git-annex-shell
+man
+git-union-merge
+git-union-merge.1
+doc/.ikiwiki
+html
+*.tix
+.hpc
+dist
+# Sandboxed builds
+cabal-dev
+.cabal-sandbox
+cabal.sandbox.config
+.stack-work
+# Project-local emacs configuration
+.dir-locals.el
+# OSX related
+.DS_Store
+.virthualenv
+.tasty-rerun-log

.mailmap

@@ -0,0 +1,29 @@
+Antoine Beaupré <anarcat@koumbit.org> anarcat <anarcat@web>
+Antoine Beaupré <anarcat@koumbit.org> https://id.koumbit.net/anarcat <https://id.koumbit.net/anarcat@web>
+Greg Grossmeier <greg@grossmeier.net> http://grossmeier.net/ <greg@web>
+Jimmy Tang <jtang@tchpc.tcd.ie> jtang <jtang@web>
+Joachim Breitner <mail@joachim-breitner.de> http://www.joachim-breitner.de/ <nomeata@web>
+Joey Hess <id@joeyh.name> Joey Hess <joey@gnu.kitenet.net>
+Joey Hess <id@joeyh.name> Joey Hess <joey@kitenet.net>
+Joey Hess <id@joeyh.name> Joey Hess <joeyh@debian.org>
+Joey Hess <id@joeyh.name> Joey Hess <joeyh@fischer.debian.org>
+Joey Hess <id@joeyh.name> Joey Hess <joeyh@joeyh.name>
+Joey Hess <id@joeyh.name> Joey Hess <joeyh@oberon.tam-lin.net>
+Joey Hess <id@joeyh.name> Joey Hess <joeyh@oberon.underhill.private>
+Joey Hess <id@joeyh.name> http://joey.kitenet.net/ <joey@web>
+Joey Hess <id@joeyh.name> http://joeyh.name/ <http://joeyh.name/@web>
+Joey Hess <id@joeyh.name> http://joeyh.name/ <joey@web>
+Joey Hess <id@joeyh.name> https://www.google.com/accounts/o8/id?id=AItOawmJfIszzreLNvCqzqzvTayA9_9L6gb9RtY <Joey@web>
+Johan Kiviniemi <devel@johan.kiviniemi.name> http://johan.kiviniemi.name/ <Johan@web>
+Johan Kiviniemi <devel@johan.kiviniemi.name> http://johan.kiviniemi.name/ <http://johan.kiviniemi.name/@web>
+Nicolas Pouillard <nicolas.pouillard@gmail.com> http://ertai.myopenid.com/ <npouillard@web>
+Peter Simons <simons@cryp.to> Peter Simons <simons@ubuntu-12.04>
+Peter Simons <simons@cryp.to> http://peter-simons.myopenid.com/ <http://peter-simons.myopenid.com/@web>
+Philipp Kern <pkern@debian.org> http://phil.0x539.de/ <Philipp_Kern@web>
+Richard Hartmann <richih@debian.org> https://www.google.com/accounts/o8/id?id=AItOawl9sYlePmv1xK-VvjBdN-5doOa_Xw-jH4U <Richard@web>
+Yaroslav Halchenko <debian@onerussian.com>
+Yaroslav Halchenko <debian@onerussian.com> http://yarikoptic.myopenid.com/ <site-myopenid@web>
+Yaroslav Halchenko <debian@onerussian.com> https://www.google.com/accounts/o8/id?id=AItOawnx8kHW66N3BqmkVpgtXDlYMvr8TJ5VvfY <Yaroslav@web>
+Yaroslav Halchenko <debian@onerussian.com> https://me.yahoo.com/a/EbvxpTI_xP9Aod7Mg4cwGhgjrCrdM5s-#7c0f4 <https://me.yahoo.com/a/EbvxpTI_xP9Aod7Mg4cwGhgjrCrdM5s-#7c0f4@web>
+Øyvind A. Holm <sunny@sunbase.org> http://sunny256.sunbase.org/ <sunny256@web>
+Øyvind A. Holm <sunny@sunbase.org> https://sunny256.wordpress.com/ <sunny256@web>

Annex.hs

@@ -0,0 +1,376 @@
+{- git-annex monad
+ -
+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE GeneralizedNewtypeDeriving, PackageImports, BangPatterns #-}
+
+module Annex (
+	Annex,
+	AnnexState(..),
+	new,
+	run,
+	eval,
+	makeRunner,
+	getState,
+	changeState,
+	withState,
+	setFlag,
+	setField,
+	setOutput,
+	getFlag,
+	getField,
+	addCleanup,
+	gitRepo,
+	inRepo,
+	fromRepo,
+	calcRepo,
+	getGitConfig,
+	changeGitConfig,
+	changeGitRepo,
+	adjustGitRepo,
+	getRemoteGitConfig,
+	withCurrentState,
+	changeDirectory,
+	getGitRemotes,
+	incError,
+) where
+
+import Common
+import qualified Git
+import qualified Git.Config
+import qualified Git.Construct
+import Annex.Fixup
+import Git.CatFile
+import Git.HashObject
+import Git.CheckAttr
+import Git.CheckIgnore
+import qualified Git.Hook
+import qualified Git.Queue
+import Types.Key
+import Types.Backend
+import Types.GitConfig
+import qualified Types.Remote
+import Types.Crypto
+import Types.BranchState
+import Types.TrustLevel
+import Types.Group
+import Types.Messages
+import Types.Concurrency
+import Types.UUID
+import Types.FileMatcher
+import Types.NumCopies
+import Types.LockCache
+import Types.DesktopNotify
+import Types.CleanupActions
+import qualified Database.Keys.Handle as Keys
+import Utility.InodeCache
+import Utility.Url
+
+import "mtl" Control.Monad.Reader
+import Control.Concurrent
+import Control.Concurrent.Async
+import Control.Concurrent.STM
+import qualified Data.Map.Strict as M
+import qualified Data.Set as S
+
+{- git-annex's monad is a ReaderT around an AnnexState stored in a MVar.
+ - The MVar is not exposed outside this module.
+ -
+ - Note that when an Annex action fails and the exception is caught,
+ - any changes the action has made to the AnnexState are retained,
+ - due to the use of the MVar to store the state.
+ -}
+newtype Annex a = Annex { runAnnex :: ReaderT (MVar AnnexState) IO a }
+	deriving (
+		Monad,
+		MonadIO,
+		MonadReader (MVar AnnexState),
+		MonadCatch,
+		MonadThrow,
+		MonadMask,
+		Functor,
+		Applicative
+	)
+
+-- internal state storage
+data AnnexState = AnnexState
+	{ repo :: Git.Repo
+	, repoadjustment :: (Git.Repo -> IO Git.Repo)
+	, gitconfig :: GitConfig
+	, gitremotes :: Maybe [Git.Repo]
+	, backend :: Maybe (BackendA Annex)
+	, remotes :: [Types.Remote.RemoteA Annex]
+	, remoteannexstate :: M.Map UUID AnnexState
+	, output :: MessageState
+	, concurrency :: Concurrency
+	, force :: Bool
+	, fast :: Bool
+	, daemon :: Bool
+	, branchstate :: BranchState
+	, repoqueue :: Maybe Git.Queue.Queue
+	, catfilehandles :: M.Map FilePath CatFileHandle
+	, hashobjecthandle :: Maybe HashObjectHandle
+	, checkattrhandle :: Maybe CheckAttrHandle
+	, checkignorehandle :: Maybe (Maybe CheckIgnoreHandle)
+	, forcebackend :: Maybe String
+	, globalnumcopies :: Maybe NumCopies
+	, forcenumcopies :: Maybe NumCopies
+	, limit :: ExpandableMatcher Annex
+	, uuidmap :: Maybe UUIDMap
+	, preferredcontentmap :: Maybe (FileMatcherMap Annex)
+	, requiredcontentmap :: Maybe (FileMatcherMap Annex)
+	, forcetrust :: TrustMap
+	, trustmap :: Maybe TrustMap
+	, groupmap :: Maybe GroupMap
+	, ciphers :: M.Map StorableCipher Cipher
+	, lockcache :: LockCache
+	, sshstalecleaned :: TMVar Bool
+	, flags :: M.Map String Bool
+	, fields :: M.Map String String
+	, cleanup :: M.Map CleanupAction (Annex ())
+	, sentinalstatus :: Maybe SentinalStatus
+	, useragent :: Maybe String
+	, errcounter :: Integer
+	, unusedkeys :: Maybe (S.Set Key)
+	, tempurls :: M.Map Key URLString
+	, existinghooks :: M.Map Git.Hook.Hook Bool
+	, desktopnotify :: DesktopNotify
+	, workers :: [Either AnnexState (Async AnnexState)]
+	, activekeys :: TVar (M.Map Key ThreadId)
+	, activeremotes :: MVar (M.Map (Types.Remote.RemoteA Annex) Integer)
+	, keysdbhandle :: Maybe Keys.DbHandle
+	, cachedcurrentbranch :: Maybe Git.Branch
+	, cachedgitenv :: Maybe [(String, String)]
+	, urloptions :: Maybe UrlOptions
+	}
+
+newState :: GitConfig -> Git.Repo -> IO AnnexState
+newState c r = do
+	emptyactiveremotes <- newMVar M.empty
+	emptyactivekeys <- newTVarIO M.empty
+	o <- newMessageState
+	sc <- newTMVarIO False
+	return $ AnnexState
+		{ repo = r
+		, repoadjustment = return
+		, gitconfig = c
+		, gitremotes = Nothing
+		, backend = Nothing
+		, remotes = []
+		, remoteannexstate = M.empty
+		, output = o
+		, concurrency = NonConcurrent
+		, force = False
+		, fast = False
+		, daemon = False
+		, branchstate = startBranchState
+		, repoqueue = Nothing
+		, catfilehandles = M.empty
+		, hashobjecthandle = Nothing
+		, checkattrhandle = Nothing
+		, checkignorehandle = Nothing
+		, forcebackend = Nothing
+		, globalnumcopies = Nothing
+		, forcenumcopies = Nothing
+		, limit = BuildingMatcher []
+		, uuidmap = Nothing
+		, preferredcontentmap = Nothing
+		, requiredcontentmap = Nothing
+		, forcetrust = M.empty
+		, trustmap = Nothing
+		, groupmap = Nothing
+		, ciphers = M.empty
+		, lockcache = M.empty
+		, sshstalecleaned = sc
+		, flags = M.empty
+		, fields = M.empty
+		, cleanup = M.empty
+		, sentinalstatus = Nothing
+		, useragent = Nothing
+		, errcounter = 0
+		, unusedkeys = Nothing
+		, tempurls = M.empty
+		, existinghooks = M.empty
+		, desktopnotify = mempty
+		, workers = []
+		, activekeys = emptyactivekeys
+		, activeremotes = emptyactiveremotes
+		, keysdbhandle = Nothing
+		, cachedcurrentbranch = Nothing
+		, cachedgitenv = Nothing
+		, urloptions = Nothing
+		}
+
+{- Makes an Annex state object for the specified git repo.
+ - Ensures the config is read, if it was not already, and performs
+ - any necessary git repo fixups. -}
+new :: Git.Repo -> IO AnnexState
+new r = do
+	r' <- Git.Config.read =<< Git.relPath r
+	let c = extractGitConfig r'
+	newState c =<< fixupRepo r' c
+
+{- Performs an action in the Annex monad from a starting state,
+ - returning a new state. -}
+run :: AnnexState -> Annex a -> IO (a, AnnexState)
+run s a = flip run' a =<< newMVar s
+
+run' :: MVar AnnexState -> Annex a -> IO (a, AnnexState)
+run' mvar a = do
+	r <- runReaderT (runAnnex a) mvar
+		`onException` (flush =<< readMVar mvar)
+	s' <- takeMVar mvar
+	flush s'
+	return (r, s')
+  where
+	flush = maybe noop Keys.flushDbQueue . keysdbhandle
+
+{- Performs an action in the Annex monad from a starting state, 
+ - and throws away the new state. -}
+eval :: AnnexState -> Annex a -> IO a
+eval s a = fst <$> run s a
+
+{- Makes a runner action, that allows diving into IO and from inside
+ - the IO action, running an Annex action. -}
+makeRunner :: Annex (Annex a -> IO a)
+makeRunner = do
+	mvar <- ask
+	return $ \a -> do
+		(r, s) <- run' mvar a
+		putMVar mvar s
+		return r
+
+getState :: (AnnexState -> v) -> Annex v
+getState selector = do
+	mvar <- ask
+	s <- liftIO $ readMVar mvar
+	return $ selector s
+
+changeState :: (AnnexState -> AnnexState) -> Annex ()
+changeState modifier = do
+	mvar <- ask
+	liftIO $ modifyMVar_ mvar $ return . modifier
+
+withState :: (AnnexState -> IO (AnnexState, b)) -> Annex b
+withState modifier = do
+	mvar <- ask
+	liftIO $ modifyMVar mvar modifier
+
+{- Sets a flag to True -}
+setFlag :: String -> Annex ()
+setFlag flag = changeState $ \s ->
+	s { flags = M.insert flag True $ flags s }
+
+{- Sets a field to a value -}
+setField :: String -> String -> Annex ()
+setField field value = changeState $ \s ->
+	s { fields = M.insert field value $ fields s }
+
+{- Adds a cleanup action to perform. -}
+addCleanup :: CleanupAction -> Annex () -> Annex ()
+addCleanup k a = changeState $ \s ->
+	s { cleanup = M.insert k a $ cleanup s }
+
+{- Sets the type of output to emit. -}
+setOutput :: OutputType -> Annex ()
+setOutput o = changeState $ \s ->
+	let m = output s
+	in s { output = m { outputType = adjustOutputType (outputType m) o } }
+
+{- Checks if a flag was set. -}
+getFlag :: String -> Annex Bool
+getFlag flag = fromMaybe False . M.lookup flag <$> getState flags
+
+{- Gets the value of a field. -}
+getField :: String -> Annex (Maybe String)
+getField field = M.lookup field <$> getState fields
+
+{- Returns the annex's git repository. -}
+gitRepo :: Annex Git.Repo
+gitRepo = getState repo
+
+{- Runs an IO action in the annex's git repository. -}
+inRepo :: (Git.Repo -> IO a) -> Annex a
+inRepo a = liftIO . a =<< gitRepo
+
+{- Extracts a value from the annex's git repisitory. -}
+fromRepo :: (Git.Repo -> a) -> Annex a
+fromRepo a = a <$> gitRepo
+
+{- Calculates a value from an annex's git repository and its GitConfig. -}
+calcRepo :: (Git.Repo -> GitConfig -> IO a) -> Annex a
+calcRepo a = do
+	s <- getState id
+	liftIO $ a (repo s) (gitconfig s)
+
+{- Gets the GitConfig settings. -}
+getGitConfig :: Annex GitConfig
+getGitConfig = getState gitconfig
+
+{- Modifies a GitConfig setting. -}
+changeGitConfig :: (GitConfig -> GitConfig) -> Annex ()
+changeGitConfig a = changeState $ \s -> s { gitconfig = a (gitconfig s) }
+
+{- Changing the git Repo data also involves re-extracting its GitConfig. -}
+changeGitRepo :: Git.Repo -> Annex ()
+changeGitRepo r = do
+	adjuster <- getState repoadjustment
+	r' <- liftIO $ adjuster r
+	changeState $ \s -> s
+		{ repo = r'
+		, gitconfig = extractGitConfig r'
+		}
+
+{- Adds an adjustment to the Repo data. Adjustments persist across reloads
+ - of the repo's config. -}
+adjustGitRepo :: (Git.Repo -> IO Git.Repo) -> Annex ()
+adjustGitRepo a = do
+	changeState $ \s -> s { repoadjustment = \r -> repoadjustment s r >>= a }
+	changeGitRepo =<< gitRepo
+
+{- Gets the RemoteGitConfig from a remote, given the Git.Repo for that
+ - remote. -}
+getRemoteGitConfig :: Git.Repo -> Annex RemoteGitConfig
+getRemoteGitConfig r = do
+	g <- gitRepo
+	liftIO $ atomically $ extractRemoteGitConfig g (Git.repoDescribe r)
+
+{- Converts an Annex action into an IO action, that runs with a copy
+ - of the current Annex state. 
+ -
+ - Use with caution; the action should not rely on changing the
+ - state, as it will be thrown away. -}
+withCurrentState :: Annex a -> Annex (IO a)
+withCurrentState a = do
+	s <- getState id
+	return $ eval s a
+
+{- It's not safe to use setCurrentDirectory in the Annex monad,
+ - because the git repo paths are stored relative.
+ - Instead, use this.
+ -}
+changeDirectory :: FilePath -> Annex ()
+changeDirectory d = do
+	r <- liftIO . Git.adjustPath absPath =<< gitRepo
+	liftIO $ setCurrentDirectory d
+	r' <- liftIO $ Git.relPath r
+	changeState $ \s -> s { repo = r' }
+
+incError :: Annex ()
+incError = changeState $ \s -> 
+	let ! c = errcounter s + 1 
+	    ! s' = s { errcounter = c }
+	in s'
+
+getGitRemotes :: Annex [Git.Repo]
+getGitRemotes = do
+	s <- getState id
+	case gitremotes s of
+		Just rs -> return rs
+		Nothing -> do
+			rs <- liftIO $ Git.Construct.fromRemotes (repo s)
+			changeState $ \s' -> s' { gitremotes = Just rs }
+			return rs

Annex/Action.hs

@@ -0,0 +1,66 @@
+{- git-annex actions
+ -
+ - Copyright 2010-2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Action where
+
+import qualified Data.Map as M
+#ifndef mingw32_HOST_OS
+import System.Posix.Signals
+import System.Posix.Process (getAnyProcessStatus)
+import Utility.Exception
+#endif
+
+import Annex.Common
+import qualified Annex
+import Annex.Content
+import Annex.CatFile
+import Annex.CheckAttr
+import Annex.HashObject
+import Annex.CheckIgnore
+
+{- Actions to perform each time ran. -}
+startup :: Annex ()
+startup =
+#ifndef mingw32_HOST_OS
+	liftIO $ void $ installHandler sigINT Default Nothing
+#else
+	return ()
+#endif
+
+{- Cleanup actions. -}
+shutdown :: Bool -> Annex ()
+shutdown nocommit = do
+	saveState nocommit
+	sequence_ =<< M.elems <$> Annex.getState Annex.cleanup
+	stopCoProcesses
+	liftIO reapZombies -- zombies from long-running git processes
+
+{- Stops all long-running git query processes. -}
+stopCoProcesses :: Annex ()
+stopCoProcesses = do
+	catFileStop
+	checkAttrStop
+	hashObjectStop
+	checkIgnoreStop
+
+{- Reaps any zombie processes that may be hanging around.
+ -
+ - Warning: Not thread safe. Anything that was expecting to wait
+ - on a process and get back an exit status is going to be confused
+ - if this reap gets there first. -}
+reapZombies :: IO ()
+#ifndef mingw32_HOST_OS
+reapZombies =
+	-- throws an exception when there are no child processes
+	catchDefaultIO Nothing (getAnyProcessStatus False True)
+		>>= maybe (return ()) (const reapZombies)
+
+#else
+reapZombies = return ()
+#endif

Annex/AdjustedBranch.hs

@@ -0,0 +1,616 @@
+{- adjusted branch
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns #-}
+
+module Annex.AdjustedBranch (
+	Adjustment(..),
+	OrigBranch,
+	AdjBranch(..),
+	originalToAdjusted,
+	adjustedToOriginal,
+	fromAdjustedBranch,
+	getAdjustment,
+	enterAdjustedBranch,
+	adjustBranch,
+	adjustToCrippledFileSystem,
+	updateAdjustedBranch,
+	propigateAdjustedCommits,
+	AdjustedClone(..),
+	checkAdjustedClone,
+	isGitVersionSupported,
+	checkVersionSupported,
+) where
+
+import Annex.Common
+import qualified Annex
+import Git
+import Git.Types
+import qualified Git.Branch
+import qualified Git.Ref
+import qualified Git.Command
+import qualified Git.Tree
+import qualified Git.DiffTree
+import qualified Git.Merge
+import Git.Tree (TreeItem(..))
+import Git.Sha
+import Git.Env
+import Git.Index
+import Git.FilePath
+import qualified Git.LockFile
+import qualified Git.Version
+import Annex.Version
+import Annex.CatFile
+import Annex.Link
+import Annex.AutoMerge
+import Annex.Content
+import Annex.Perms
+import Annex.GitOverlay
+import Utility.Tmp.Dir
+import Utility.CopyFile
+import qualified Database.Keys
+import Config
+
+import qualified Data.Map as M
+
+data Adjustment
+	= UnlockAdjustment
+	| LockAdjustment
+	| FixAdjustment
+	| UnFixAdjustment
+	| HideMissingAdjustment
+	| ShowMissingAdjustment
+	deriving (Show, Eq)
+
+reverseAdjustment :: Adjustment -> Adjustment
+reverseAdjustment UnlockAdjustment = LockAdjustment
+reverseAdjustment LockAdjustment = UnlockAdjustment
+reverseAdjustment HideMissingAdjustment = ShowMissingAdjustment
+reverseAdjustment ShowMissingAdjustment = HideMissingAdjustment
+reverseAdjustment FixAdjustment = UnFixAdjustment
+reverseAdjustment UnFixAdjustment = FixAdjustment
+
+{- How to perform various adjustments to a TreeItem. -}
+adjustTreeItem :: Adjustment -> TreeItem -> Annex (Maybe TreeItem)
+adjustTreeItem UnlockAdjustment = ifSymlink adjustToPointer noAdjust
+adjustTreeItem LockAdjustment = ifSymlink noAdjust adjustToSymlink
+adjustTreeItem FixAdjustment = ifSymlink adjustToSymlink noAdjust
+adjustTreeItem UnFixAdjustment = ifSymlink (adjustToSymlink' gitAnnexLinkCanonical) noAdjust
+adjustTreeItem HideMissingAdjustment = \ti@(TreeItem _ _ s) ->
+	catKey s >>= \case
+		Just k -> ifM (inAnnex k)
+			( return (Just ti)
+			, return Nothing
+			)
+		Nothing -> return (Just ti)
+adjustTreeItem ShowMissingAdjustment = noAdjust
+
+ifSymlink :: (TreeItem -> Annex a) -> (TreeItem -> Annex a) -> TreeItem -> Annex a
+ifSymlink issymlink notsymlink ti@(TreeItem _f m _s)
+	| toTreeItemType m == Just TreeSymlink = issymlink ti
+	| otherwise = notsymlink ti
+
+noAdjust :: TreeItem -> Annex (Maybe TreeItem)
+noAdjust = return . Just
+
+adjustToPointer :: TreeItem -> Annex (Maybe TreeItem)
+adjustToPointer ti@(TreeItem f _m s) = catKey s >>= \case
+	Just k -> do
+		Database.Keys.addAssociatedFile k f
+		Just . TreeItem f (fromTreeItemType TreeFile)
+			<$> hashPointerFile k
+	Nothing -> return (Just ti)
+
+adjustToSymlink :: TreeItem -> Annex (Maybe TreeItem)
+adjustToSymlink = adjustToSymlink' gitAnnexLink
+
+adjustToSymlink' :: (FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath) -> TreeItem -> Annex (Maybe TreeItem)
+adjustToSymlink' gitannexlink ti@(TreeItem f _m s) = catKey s >>= \case
+	Just k -> do
+		absf <- inRepo $ \r -> absPath $
+			fromTopFilePath f r
+		linktarget <- calcRepo $ gitannexlink absf k
+		Just . TreeItem f (fromTreeItemType TreeSymlink)
+			<$> hashSymlink linktarget
+	Nothing -> return (Just ti)
+
+type OrigBranch = Branch
+newtype AdjBranch = AdjBranch { adjBranch :: Branch }
+
+-- This is a hidden branch ref, that's used as the basis for the AdjBranch,
+-- since pushes can overwrite the OrigBranch at any time. So, changes
+-- are propigated from the AdjBranch to the head of the BasisBranch.
+newtype BasisBranch = BasisBranch Ref
+
+-- The basis for refs/heads/adjusted/master(unlocked) is
+-- refs/basis/adjusted/master(unlocked).
+basisBranch :: AdjBranch -> BasisBranch
+basisBranch (AdjBranch adjbranch) = BasisBranch $
+	Ref ("refs/basis/" ++ fromRef (Git.Ref.base adjbranch))
+
+adjustedBranchPrefix :: String
+adjustedBranchPrefix = "refs/heads/adjusted/"
+
+serialize :: Adjustment -> String
+serialize UnlockAdjustment = "unlocked"
+serialize LockAdjustment = "locked"
+serialize HideMissingAdjustment = "present"
+serialize ShowMissingAdjustment = "showmissing"
+serialize FixAdjustment = "fixed"
+serialize UnFixAdjustment = "unfixed"
+
+deserialize :: String -> Maybe Adjustment
+deserialize "unlocked" = Just UnlockAdjustment
+deserialize "locked" = Just UnlockAdjustment
+deserialize "present" = Just HideMissingAdjustment
+deserialize "fixed" = Just FixAdjustment
+deserialize "unfixed" = Just UnFixAdjustment
+deserialize _ = Nothing
+
+originalToAdjusted :: OrigBranch -> Adjustment -> AdjBranch
+originalToAdjusted orig adj = AdjBranch $ Ref $
+	adjustedBranchPrefix ++ base ++ '(' : serialize adj ++ ")"
+  where
+	base = fromRef (Git.Ref.base orig)
+
+adjustedToOriginal :: Branch -> Maybe (Adjustment, OrigBranch)
+adjustedToOriginal b
+	| adjustedBranchPrefix `isPrefixOf` bs = do
+		let (base, as) = separate (== '(') (drop prefixlen bs)
+		adj <- deserialize (takeWhile (/= ')') as)
+		Just (adj, Git.Ref.branchRef (Ref base))
+	| otherwise = Nothing
+  where
+	bs = fromRef b
+	prefixlen = length adjustedBranchPrefix
+
+getAdjustment :: Branch -> Maybe Adjustment
+getAdjustment = fmap fst . adjustedToOriginal
+
+fromAdjustedBranch :: Branch -> OrigBranch
+fromAdjustedBranch b = maybe b snd (adjustedToOriginal b)
+
+originalBranch :: Annex (Maybe OrigBranch)
+originalBranch = fmap fromAdjustedBranch <$> inRepo Git.Branch.current
+
+{- Enter an adjusted version of current branch (or, if already in an
+ - adjusted version of a branch, changes the adjustment of the original
+ - branch).
+ -
+ - Can fail, if no branch is checked out, or if the adjusted branch already
+ - exists, or perhaps if staged changes conflict with the adjusted branch.
+ -}
+enterAdjustedBranch :: Adjustment -> Annex Bool
+enterAdjustedBranch adj = go =<< originalBranch
+  where
+	go (Just origbranch) = do
+		let adjbranch = adjBranch $ originalToAdjusted origbranch adj
+		ifM (inRepo (Git.Ref.exists adjbranch) <&&> (not <$> Annex.getState Annex.force))
+			( do
+				mapM_ (warning . unwords)
+					[ [ "adjusted branch"
+					  , Git.Ref.describe adjbranch
+					  , "already exists."
+					  ]
+					, [ "Aborting because that branch may have changes that have not yet reached"
+					  , Git.Ref.describe origbranch
+					  ]
+					, [ "You can check out the adjusted branch manually to enter it,"
+					  , "or delete the adjusted branch and re-run this command."
+					  ]
+					]
+				return False
+			, do
+				AdjBranch b <- preventCommits $ const $ 
+					adjustBranch adj origbranch
+				showOutput -- checkout can have output in large repos
+				inRepo $ Git.Command.runBool
+					[ Param "checkout"
+					, Param $ fromRef $ Git.Ref.base b
+					]
+			)
+	go Nothing = do
+		warning "not on any branch!"
+		return False
+
+adjustToCrippledFileSystem :: Annex ()
+adjustToCrippledFileSystem = do
+	warning "Entering an adjusted branch where files are unlocked as this filesystem does not support locked files."
+	whenM (isNothing <$> originalBranch) $
+		void $ inRepo $ Git.Branch.commitCommand Git.Branch.AutomaticCommit
+			[ Param "--quiet"
+			, Param "--allow-empty"
+			, Param "-m"
+			, Param "commit before entering adjusted unlocked branch"
+			]
+	unlessM (enterAdjustedBranch UnlockAdjustment) $
+		warning "Failed to enter adjusted branch!"
+
+setBasisBranch :: BasisBranch -> Ref -> Annex ()
+setBasisBranch (BasisBranch basis) new = 
+	inRepo $ Git.Branch.update' basis new
+
+setAdjustedBranch :: String -> AdjBranch -> Ref -> Annex ()
+setAdjustedBranch msg (AdjBranch b) r = inRepo $ Git.Branch.update msg b r
+
+adjustBranch :: Adjustment -> OrigBranch -> Annex AdjBranch
+adjustBranch adj origbranch = do
+	-- Start basis off with the current value of the origbranch.
+	setBasisBranch basis origbranch
+	sha <- adjustCommit adj basis
+	setAdjustedBranch "entering adjusted branch" adjbranch sha
+	return adjbranch
+  where
+	adjbranch = originalToAdjusted origbranch adj
+	basis = basisBranch adjbranch
+
+adjustCommit :: Adjustment -> BasisBranch -> Annex Sha
+adjustCommit adj basis = do
+	treesha <- adjustTree adj basis
+	commitAdjustedTree treesha basis
+
+adjustTree :: Adjustment -> BasisBranch -> Annex Sha
+adjustTree adj (BasisBranch basis) = do
+	let toadj = adjustTreeItem adj
+	treesha <- Git.Tree.adjustTree toadj [] [] basis =<< Annex.gitRepo
+	return treesha
+
+type CommitsPrevented = Git.LockFile.LockHandle
+
+{- Locks git's index file, preventing git from making a commit, merge, 
+ - or otherwise changing the HEAD ref while the action is run.
+ -
+ - Throws an IO exception if the index file is already locked.
+ -}
+preventCommits :: (CommitsPrevented -> Annex a) -> Annex a
+preventCommits = bracket setup cleanup
+  where
+	setup = do
+		lck <- fromRepo indexFileLock
+		liftIO $ Git.LockFile.openLock lck
+	cleanup = liftIO . Git.LockFile.closeLock
+
+{- Commits a given adjusted tree, with the provided parent ref.
+ -
+ - This should always yield the same value, even if performed in different 
+ - clones of a repo, at different times. The commit message and other
+ - metadata is based on the parent.
+ -}
+commitAdjustedTree :: Sha -> BasisBranch -> Annex Sha
+commitAdjustedTree treesha parent@(BasisBranch b) =
+	commitAdjustedTree' treesha parent [b]
+
+commitAdjustedTree' :: Sha -> BasisBranch -> [Ref] -> Annex Sha
+commitAdjustedTree' treesha (BasisBranch basis) parents =
+	go =<< catCommit basis
+  where
+	go Nothing = inRepo mkcommit
+	go (Just basiscommit) = inRepo $ commitWithMetaData
+		(commitAuthorMetaData basiscommit)
+		(commitCommitterMetaData basiscommit)
+		mkcommit
+	mkcommit = Git.Branch.commitTree Git.Branch.AutomaticCommit
+		adjustedBranchCommitMessage parents treesha
+
+{- This message should never be changed. -}
+adjustedBranchCommitMessage :: String
+adjustedBranchCommitMessage = "git-annex adjusted branch"
+
+findAdjustingCommit :: AdjBranch -> Annex (Maybe Commit)
+findAdjustingCommit (AdjBranch b) = go =<< catCommit b
+  where
+	go Nothing = return Nothing
+	go (Just c)
+		| commitMessage c == adjustedBranchCommitMessage = return (Just c)
+		| otherwise = case commitParent c of
+			[p] -> go =<< catCommit p
+			_ -> return Nothing
+
+{- Update the currently checked out adjusted branch, merging the provided
+ - branch into it. Note that the provided branch should be a non-adjusted
+ - branch. -}
+updateAdjustedBranch :: Branch -> (OrigBranch, Adjustment) -> [Git.Merge.MergeConfig] -> Annex Bool -> Git.Branch.CommitMode -> Annex Bool
+updateAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge commitmode = catchBoolIO $
+	join $ preventCommits go
+  where
+	adjbranch@(AdjBranch currbranch) = originalToAdjusted origbranch adj
+	basis = basisBranch adjbranch
+
+	go commitsprevented =
+		ifM (inRepo $ Git.Branch.changed currbranch tomerge)
+			( do
+				(updatedorig, _) <- propigateAdjustedCommits'
+					origbranch adj commitsprevented
+				changestomerge updatedorig
+			, nochangestomerge
+			)
+
+	nochangestomerge = return $ return True
+
+	{- Since the adjusted branch changes files, merging tomerge
+	 - directly into it would likely result in unncessary merge
+	 - conflicts. To avoid those conflicts, instead merge tomerge into
+	 - updatedorig. The result of the merge can the be
+	 - adjusted to yield the final adjusted branch.
+	 -
+	 - In order to do a merge into a ref that is not checked out,
+	 - set the work tree to a temp directory, and set GIT_DIR
+	 - to another temp directory, in which HEAD contains the
+	 - updatedorig sha. GIT_COMMON_DIR is set to point to the real
+	 - git directory, and so git can read and write objects from there,
+	 - but will use GIT_DIR for HEAD and index.
+	 -
+	 - (Doing the merge this way also lets it run even though the main
+	 - index file is currently locked.)
+	 -}
+	changestomerge (Just updatedorig) = do
+		misctmpdir <- fromRepo gitAnnexTmpMiscDir
+		void $ createAnnexDirectory misctmpdir
+		tmpwt <- fromRepo gitAnnexMergeDir
+		git_dir <- fromRepo Git.localGitDir
+		withTmpDirIn misctmpdir "git" $ \tmpgit -> withWorkTreeRelated tmpgit $
+			withemptydir tmpwt $ withWorkTree tmpwt $ do
+				liftIO $ writeFile (tmpgit </> "HEAD") (fromRef updatedorig)
+				-- Copy in refs and packed-refs, to work
+				-- around bug in git 2.13.0, which
+				-- causes it not to look in GIT_DIR for refs.
+				refs <- liftIO $ dirContentsRecursive $
+					git_dir </> "refs"
+				let refs' = (git_dir </> "packed-refs") : refs
+				liftIO $ forM_ refs' $ \src ->
+					whenM (doesFileExist src) $ do
+						dest <- relPathDirToFile git_dir src
+						let dest' = tmpgit </> dest
+						createDirectoryIfMissing True (takeDirectory dest')
+						void $ createLinkOrCopy src dest'
+				-- This reset makes git merge not care
+				-- that the work tree is empty; otherwise
+				-- it will think that all the files have
+				-- been staged for deletion, and sometimes
+				-- the merge includes these deletions
+				-- (for an unknown reason).
+				-- http://thread.gmane.org/gmane.comp.version-control.git/297237
+				inRepo $ Git.Command.run [Param "reset", Param "HEAD", Param "--quiet"]
+				showAction $ "Merging into " ++ fromRef (Git.Ref.base origbranch)
+				merged <- inRepo (Git.Merge.merge' [] tomerge mergeconfig commitmode)
+					<||> (resolveMerge (Just updatedorig) tomerge True <&&> commitResolvedMerge commitmode)
+				if merged
+					then do
+						!mergecommit <- liftIO $ extractSha <$> readFile (tmpgit </> "HEAD")
+						-- This is run after the commit lock is dropped.
+						return $ postmerge mergecommit
+					else return $ return False
+	changestomerge Nothing = return $ return False
+	
+	withemptydir d a = bracketIO setup cleanup (const a)
+	  where
+		setup = do
+			whenM (doesDirectoryExist d) $
+				removeDirectoryRecursive d
+			createDirectoryIfMissing True d
+		cleanup _ = removeDirectoryRecursive d
+
+	{- A merge commit has been made between the basisbranch and 
+	 - tomerge. Update the basisbranch and origbranch to point
+	 - to that commit, adjust it to get the new adjusted branch,
+	 - and check it out.
+	 -
+	 - But, there may be unstaged work tree changes that conflict, 
+	 - so the check out is done by making a normal merge of
+	 - the new adjusted branch.
+	 -}
+	postmerge (Just mergecommit) = do
+		setBasisBranch basis mergecommit
+		inRepo $ Git.Branch.update' origbranch mergecommit
+		adjtree <- adjustTree adj (BasisBranch mergecommit)
+		adjmergecommit <- commitAdjustedTree adjtree (BasisBranch mergecommit)
+		-- Make currbranch be the parent, so that merging
+		-- this commit will be a fast-forward.
+		adjmergecommitff <- commitAdjustedTree' adjtree (BasisBranch mergecommit) [currbranch]
+		showAction "Merging into adjusted branch"
+		ifM (autoMergeFrom adjmergecommitff (Just currbranch) mergeconfig canresolvemerge commitmode)
+			( reparent adjtree adjmergecommit =<< getcurrentcommit
+			, return False
+			)
+	postmerge Nothing = return False
+
+	-- Now that the merge into the adjusted branch is complete,
+	-- take the tree from that merge, and attach it on top of the
+	-- adjmergecommit, if it's different.
+	reparent adjtree adjmergecommit (Just currentcommit) = do
+		if (commitTree currentcommit /= adjtree)
+			then do
+				c <- inRepo $ Git.Branch.commitTree Git.Branch.AutomaticCommit
+					("Merged " ++ fromRef tomerge) [adjmergecommit]
+					(commitTree currentcommit)
+				inRepo $ Git.Branch.update "updating adjusted branch" currbranch c
+				propigateAdjustedCommits origbranch adj
+			else inRepo $ Git.Branch.update "updating adjusted branch" currbranch adjmergecommit
+		return True
+	reparent _ _ Nothing = return False
+
+	getcurrentcommit = inRepo Git.Branch.currentUnsafe >>= \case
+		Nothing -> return Nothing
+		Just c -> catCommit c
+
+{- Check for any commits present on the adjusted branch that have not yet
+ - been propigated to the basis branch, and propigate them to the basis
+ - branch and from there on to the orig branch.
+ -
+ - After propigating the commits back to the basis banch,
+ - rebase the adjusted branch on top of the updated basis branch.
+ -}
+propigateAdjustedCommits :: OrigBranch -> Adjustment -> Annex ()
+propigateAdjustedCommits origbranch adj = 
+	preventCommits $ \commitsprevented ->
+		join $ snd <$> propigateAdjustedCommits' origbranch adj commitsprevented
+		
+{- Returns sha of updated basis branch, and action which will rebase
+ - the adjusted branch on top of the updated basis branch. -}
+propigateAdjustedCommits'
+	:: OrigBranch
+	-> Adjustment
+	-> CommitsPrevented
+	-> Annex (Maybe Sha, Annex ())
+propigateAdjustedCommits' origbranch adj _commitsprevented =
+	inRepo (Git.Ref.sha basis) >>= \case
+		Just origsha -> catCommit currbranch >>= \case
+			Just currcommit ->
+				newcommits >>= go origsha False >>= \case
+					Left e -> do
+						warning e
+						return (Nothing, return ())
+					Right newparent -> return
+						( Just newparent
+						, rebase currcommit newparent
+						)
+			Nothing -> return (Nothing, return ())
+		Nothing -> return (Nothing, return ())
+  where
+	(BasisBranch basis) = basisBranch adjbranch
+	adjbranch@(AdjBranch currbranch) = originalToAdjusted origbranch adj
+	newcommits = inRepo $ Git.Branch.changedCommits basis currbranch
+		-- Get commits oldest first, so they can be processed
+		-- in order made.
+		[Param "--reverse"]
+	go parent _ [] = do
+		setBasisBranch (BasisBranch basis) parent
+		inRepo $ Git.Branch.update' origbranch parent
+		return (Right parent)
+	go parent pastadjcommit (sha:l) = catCommit sha >>= \case
+		Just c
+			| commitMessage c == adjustedBranchCommitMessage ->
+				go parent True l
+			| pastadjcommit ->
+				reverseAdjustedCommit parent adj (sha, c) origbranch
+					>>= \case
+						Left e -> return (Left e)
+						Right commit -> go commit pastadjcommit l
+		_ -> go parent pastadjcommit l
+	rebase currcommit newparent = do
+		-- Reuse the current adjusted tree, and reparent it
+		-- on top of the newparent.
+		commitAdjustedTree (commitTree currcommit) (BasisBranch newparent)
+			>>= inRepo . Git.Branch.update rebaseOnTopMsg currbranch
+
+rebaseOnTopMsg :: String
+rebaseOnTopMsg = "rebasing adjusted branch on top of updated original branch"
+
+{- Reverses an adjusted commit, and commit with provided commitparent,
+ - yielding a commit sha.
+ -
+ - Adjusts the tree of the commitparent, changing only the files that the
+ - commit changed, and reverse adjusting those changes.
+ -
+ - The commit message, and the author and committer metadata are
+ - copied over from the basiscommit. However, any gpg signature
+ - will be lost, and any other headers are not copied either. -}
+reverseAdjustedCommit :: Sha -> Adjustment -> (Sha, Commit) -> OrigBranch -> Annex (Either String Sha)
+reverseAdjustedCommit commitparent adj (csha, basiscommit) origbranch
+	| length (commitParent basiscommit) > 1 = return $
+		Left $ "unable to propigate merge commit " ++ show csha ++ " back to " ++ show origbranch
+	| otherwise = do
+		treesha <- reverseAdjustedTree commitparent adj csha
+		revadjcommit <- inRepo $ commitWithMetaData
+			(commitAuthorMetaData basiscommit)
+			(commitCommitterMetaData basiscommit) $
+				Git.Branch.commitTree Git.Branch.AutomaticCommit
+					(commitMessage basiscommit) [commitparent] treesha
+		return (Right revadjcommit)
+
+{- Adjusts the tree of the basis, changing only the files that the
+ - commit changed, and reverse adjusting those changes.
+ -
+ - commitDiff does not support merge commits, so the csha must not be a
+ - merge commit. -}
+reverseAdjustedTree :: Sha -> Adjustment -> Sha -> Annex Sha
+reverseAdjustedTree basis adj csha = do
+	(diff, cleanup) <- inRepo (Git.DiffTree.commitDiff csha)
+	let (adds, others) = partition (\dti -> Git.DiffTree.srcsha dti == nullSha) diff
+	let (removes, changes) = partition (\dti -> Git.DiffTree.dstsha dti == nullSha) others
+	adds' <- catMaybes <$>
+		mapM (adjustTreeItem reverseadj) (map diffTreeToTreeItem adds)
+	treesha <- Git.Tree.adjustTree
+		(propchanges changes)
+		adds'
+		(map Git.DiffTree.file removes)
+		basis
+		=<< Annex.gitRepo
+	void $ liftIO cleanup
+	return treesha
+  where
+	reverseadj = reverseAdjustment adj
+	propchanges changes ti@(TreeItem f _ _) =
+		case M.lookup (norm f) m of
+			Nothing -> return (Just ti) -- not changed
+			Just change -> adjustTreeItem reverseadj change
+	  where
+		m = M.fromList $ map (\i@(TreeItem f' _ _) -> (norm f', i)) $
+			map diffTreeToTreeItem changes
+		norm = normalise . getTopFilePath
+
+diffTreeToTreeItem :: Git.DiffTree.DiffTreeItem -> TreeItem
+diffTreeToTreeItem dti = TreeItem
+	(Git.DiffTree.file dti)
+	(Git.DiffTree.dstmode dti)
+	(Git.DiffTree.dstsha dti)
+
+data AdjustedClone = InAdjustedClone | NotInAdjustedClone | NeedUpgradeForAdjustedClone
+
+{- Cloning a repository that has an adjusted branch checked out will
+ - result in the clone having the same adjusted branch checked out -- but
+ - the origbranch won't exist in the clone, nor will the basis. So
+ - to properly set up the adjusted branch, the origbranch and basis need
+ - to be set.
+ - 
+ - We can't trust that the origin's origbranch matches up with the currently
+ - checked out adjusted branch; the origin could have the two branches
+ - out of sync (eg, due to another branch having been pushed to the origin's
+ - origbranch), or due to a commit on its adjusted branch not having been
+ - propigated back to origbranch.
+ -
+ - So, find the adjusting commit on the currently checked out adjusted
+ - branch, and use the parent of that commit as the basis, and set the
+ - origbranch to it.
+ -
+ - The repository may also need to be upgraded to a new version, if the
+ - current version is too old to support adjusted branches. -}
+checkAdjustedClone :: Annex AdjustedClone
+checkAdjustedClone = ifM isBareRepo
+	( return NotInAdjustedClone
+	, go =<< inRepo Git.Branch.current
+	)
+  where
+	go Nothing = return NotInAdjustedClone
+	go (Just currbranch) = case adjustedToOriginal currbranch of
+		Nothing -> return NotInAdjustedClone
+		Just (adj, origbranch) -> do
+			let basis@(BasisBranch bb) = basisBranch (originalToAdjusted origbranch adj)
+			unlessM (inRepo $ Git.Ref.exists bb) $ do
+				unlessM (inRepo $ Git.Ref.exists origbranch) $ do
+					let remotebranch = Git.Ref.underBase "refs/remotes/origin" origbranch
+					inRepo $ Git.Branch.update' origbranch remotebranch
+				aps <- fmap commitParent <$> findAdjustingCommit (AdjBranch currbranch)
+				case aps of
+					Just [p] -> setBasisBranch basis p
+					_ -> giveup $ "Unable to clean up from clone of adjusted branch; perhaps you should check out " ++ Git.Ref.describe origbranch
+			ifM versionSupportsUnlockedPointers
+				( return InAdjustedClone
+				, return NeedUpgradeForAdjustedClone
+				)
+
+-- git 2.2.0 needed for GIT_COMMON_DIR which is needed
+-- by updateAdjustedBranch to use withWorkTreeRelated.
+isGitVersionSupported :: IO Bool
+isGitVersionSupported = not <$> Git.Version.older "2.2.0"
+
+checkVersionSupported :: Annex ()
+checkVersionSupported = do
+	unlessM versionSupportsAdjustedBranch $
+		giveup "Adjusted branches are only supported in v6 or newer repositories."
+	unlessM (liftIO isGitVersionSupported) $
+		giveup "Your version of git is too old; upgrade it to 2.2.0 or newer to use adjusted branches."

Annex/AutoMerge.hs

@@ -0,0 +1,354 @@
+{- git-annex automatic merge conflict resolution
+ -
+ - Copyright 2012-2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.AutoMerge
+	( autoMergeFrom
+	, resolveMerge
+	, commitResolvedMerge
+	) where
+
+import Annex.Common
+import qualified Annex.Queue
+import Annex.Direct
+import Annex.CatFile
+import Annex.Link
+import Annex.Content
+import qualified Git.LsFiles as LsFiles
+import qualified Git.UpdateIndex as UpdateIndex
+import qualified Git.Merge
+import qualified Git.Ref
+import qualified Git
+import qualified Git.Branch
+import Git.Types (TreeItemType(..), fromTreeItemType)
+import Git.FilePath
+import Config
+import Annex.ReplaceFile
+import Annex.VariantFile
+import qualified Database.Keys
+import Annex.InodeSentinal
+import Utility.InodeCache
+import Utility.FileMode
+
+import qualified Data.Set as S
+import qualified Data.Map as M
+import qualified Data.ByteString.Lazy as L
+
+{- Merges from a branch into the current branch (which may not exist yet),
+ - with automatic merge conflict resolution.
+ -
+ - Callers should use Git.Branch.changed first, to make sure that
+ - there are changes from the current branch to the branch being merged in.
+ -}
+autoMergeFrom :: Git.Ref -> Maybe Git.Ref -> [Git.Merge.MergeConfig] -> Annex Bool -> Git.Branch.CommitMode -> Annex Bool
+autoMergeFrom branch currbranch mergeconfig canresolvemerge commitmode = do
+	showOutput
+	case currbranch of
+		Nothing -> go Nothing
+		Just b -> go =<< inRepo (Git.Ref.sha b)
+  where
+	go old = ifM isDirect
+		( mergeDirect currbranch old branch resolvemerge mergeconfig commitmode
+		, do
+			r <- inRepo (Git.Merge.merge branch mergeconfig commitmode)
+				<||> (resolvemerge <&&> commitResolvedMerge commitmode)
+			-- Merging can cause new associated files to appear
+			-- and the smudge filter will add them to the database.
+			-- To ensure that this process sees those changes,
+			-- close the database if it was open.
+			Database.Keys.closeDb
+			return r
+		)
+	  where
+		resolvemerge = ifM canresolvemerge
+			( resolveMerge old branch False
+			, return False 
+			)
+
+{- Resolves a conflicted merge. It's important that any conflicts be
+ - resolved in a way that itself avoids later merge conflicts, since
+ - multiple repositories may be doing this concurrently.
+ -
+ - Only merge conflicts where at least one side is an annexed file
+ - is resolved.
+ -
+ - This uses the Keys pointed to by the files to construct new
+ - filenames. So when both sides modified annexed file foo, 
+ - it will be deleted, and replaced with files foo.variant-A and
+ - foo.variant-B.
+ -
+ - On the other hand, when one side deleted foo, and the other modified it,
+ - it will be deleted, and the modified version stored as file
+ - foo.variant-A (or B).
+ -
+ - It's also possible that one side has foo as an annexed file, and
+ - the other as a directory or non-annexed file. The annexed file
+ - is renamed to resolve the merge, and the other object is preserved as-is.
+ -
+ - In indirect mode, the merge is resolved in the work tree and files
+ - staged, to clean up from a conflicted merge that was run in the work
+ - tree. 
+ -
+ - In direct mode, the work tree is not touched here; files are staged to
+ - the index, and written to the gitAnnexMergeDir, for later handling by
+ - the direct mode merge code.
+ - 
+ - This is complicated by needing to support merges run in an overlay
+ - work tree, in which case the CWD won't be within the work tree.
+ - In this mode, there is no need to update the work tree at all,
+ - as the overlay work tree will get deleted.
+ -
+ - Unlocked files remain unlocked after merging, and locked files
+ - remain locked. When the merge conflict is between a locked and unlocked
+ - file, that otherwise point to the same content, the unlocked mode wins.
+ - This is done because only unlocked files work in filesystems that don't
+ - support symlinks.
+ -
+ - Returns false when there are no merge conflicts to resolve.
+ - A git merge can fail for other reasons, and this allows detecting
+ - such failures.
+ -}
+resolveMerge :: Maybe Git.Ref -> Git.Ref -> Bool -> Annex Bool
+resolveMerge us them inoverlay = do
+	top <- if inoverlay
+		then pure "."
+		else fromRepo Git.repoPath
+	(fs, cleanup) <- inRepo (LsFiles.unmerged [top])
+	srcmap <- if inoverlay
+		then pure M.empty
+		else inodeMap $ pure (map LsFiles.unmergedFile fs, return True)
+	(mergedks, mergedfs) <- unzip <$> mapM (resolveMerge' srcmap us them inoverlay) fs
+	let mergedks' = concat mergedks
+	let mergedfs' = catMaybes mergedfs
+	let merged = not (null mergedfs')
+	void $ liftIO cleanup
+
+	unlessM (pure inoverlay <||> isDirect) $ do
+		(deleted, cleanup2) <- inRepo (LsFiles.deleted [top])
+		unless (null deleted) $
+			Annex.Queue.addCommand "rm"
+				[Param "--quiet", Param "-f", Param "--"]
+				deleted
+		void $ liftIO cleanup2
+
+	when merged $ do
+		Annex.Queue.flush
+		unlessM (pure inoverlay <||> isDirect) $ do
+			unstagedmap <- inodeMap $ inRepo $ LsFiles.notInRepo False [top]
+			cleanConflictCruft mergedks' mergedfs' unstagedmap
+		showLongNote "Merge conflict was automatically resolved; you may want to examine the result."
+	return merged
+
+resolveMerge' :: InodeMap -> Maybe Git.Ref -> Git.Ref -> Bool -> LsFiles.Unmerged -> Annex ([Key], Maybe FilePath)
+resolveMerge' _ Nothing _ _ _ = return ([], Nothing)
+resolveMerge' unstagedmap (Just us) them inoverlay u = do
+	kus <- getkey LsFiles.valUs
+	kthem <- getkey LsFiles.valThem
+	case (kus, kthem) of
+		-- Both sides of conflict are annexed files
+		(Just keyUs, Just keyThem)
+			| keyUs /= keyThem -> resolveby [keyUs, keyThem] $ do
+				makeannexlink keyUs LsFiles.valUs
+				makeannexlink keyThem LsFiles.valThem
+				-- cleanConflictCruft can't handle unlocked
+				-- files, so delete here.
+				unless inoverlay $
+					unless (islocked LsFiles.valUs) $
+						liftIO $ nukeFile file
+			| otherwise -> do
+				-- Only resolve using symlink when both
+				-- were locked, otherwise use unlocked
+				-- pointer.
+				-- In either case, keep original filename.
+				if islocked LsFiles.valUs && islocked LsFiles.valThem
+					then makesymlink keyUs file
+					else makepointer keyUs file (combinedmodes)
+				return ([keyUs, keyThem], Just file)
+		-- Our side is annexed file, other side is not.
+		(Just keyUs, Nothing) -> resolveby [keyUs] $ do
+			graftin them file LsFiles.valThem LsFiles.valThem LsFiles.valUs
+			makeannexlink keyUs LsFiles.valUs 
+		-- Our side is not annexed file, other side is.
+		(Nothing, Just keyThem) -> resolveby [keyThem] $ do
+			graftin us file LsFiles.valUs LsFiles.valUs LsFiles.valThem
+			makeannexlink keyThem LsFiles.valThem
+		-- Neither side is annexed file; cannot resolve.
+		(Nothing, Nothing) -> return ([], Nothing)
+  where
+	file = LsFiles.unmergedFile u
+
+	getkey select = 
+		case select (LsFiles.unmergedSha u) of
+			Just sha -> catKey sha
+			Nothing -> return Nothing
+	
+	islocked select = select (LsFiles.unmergedTreeItemType u) == Just TreeSymlink
+
+	combinedmodes = case catMaybes [ourmode, theirmode] of
+		[] -> Nothing
+		l -> Just (combineModes l)
+	  where
+		ourmode = fromTreeItemType
+			<$> LsFiles.valUs (LsFiles.unmergedTreeItemType u)
+		theirmode = fromTreeItemType
+			<$> LsFiles.valThem (LsFiles.unmergedTreeItemType u)
+
+	makeannexlink key select
+		| islocked select = makesymlink key dest
+		| otherwise = makepointer key dest destmode
+	  where
+		dest = variantFile file key
+		destmode = fromTreeItemType <$> select (LsFiles.unmergedTreeItemType u)
+
+	stagefile :: FilePath -> Annex FilePath
+	stagefile f
+		| inoverlay = (</> f) <$> fromRepo Git.repoPath
+		| otherwise = pure f
+
+	makesymlink key dest = do
+		l <- calcRepo $ gitAnnexLink dest key
+		unless inoverlay $ replacewithsymlink dest l
+		dest' <- stagefile dest
+		stageSymlink dest' =<< hashSymlink l
+
+	replacewithsymlink dest link = withworktree dest $ \f ->
+		replaceFile f $ makeGitLink link
+
+	makepointer key dest destmode = do
+		unless inoverlay $ 
+			unlessM (reuseOldFile unstagedmap key file dest) $
+				linkFromAnnex key dest destmode >>= \case
+					LinkAnnexFailed -> liftIO $
+						writePointerFile dest key destmode
+					_ -> noop
+		dest' <- stagefile dest
+		stagePointerFile dest' destmode =<< hashPointerFile key
+		unless inoverlay $
+			Database.Keys.addAssociatedFile key
+				=<< inRepo (toTopFilePath dest)
+
+	withworktree f a = ifM isDirect
+		( do
+			d <- fromRepo gitAnnexMergeDir
+			a (d </> f)
+		, a f
+		)
+
+	{- Stage a graft of a directory or file from a branch
+	 - and update the work tree. -}
+	graftin b item selectwant selectwant' selectunwant = do
+		Annex.Queue.addUpdateIndex
+			=<< fromRepo (UpdateIndex.lsSubTree b item)
+
+		-- Update the work tree to reflect the graft.
+		unless inoverlay $ case (selectwant (LsFiles.unmergedTreeItemType u), selectunwant (LsFiles.unmergedTreeItemType u)) of
+			-- Symlinks are never left in work tree when
+			-- there's a conflict with anything else.
+			-- So, when grafting in a symlink, we must create it:
+			(Just TreeSymlink, _) -> do
+				case selectwant' (LsFiles.unmergedSha u) of
+					Nothing -> noop
+					Just sha -> do
+						link <- catSymLinkTarget sha
+						replacewithsymlink item link
+			-- And when grafting in anything else vs a symlink,
+			-- the work tree already contains what we want.
+			(_, Just TreeSymlink) -> noop
+			_ -> ifM (withworktree item (liftIO . doesDirectoryExist))
+				-- a conflict between a file and a directory
+				-- leaves the directory, so since a directory
+				-- is there, it must be what was wanted
+				( noop
+				-- probably a file with conflict markers is
+				-- in the work tree; replace with grafted
+				-- file content
+				, case selectwant' (LsFiles.unmergedSha u) of
+					Nothing -> noop
+					Just sha -> withworktree item $ \f -> 
+						replaceFile f $ \tmp -> do
+							c <- catObject sha
+							liftIO $ L.writeFile tmp c
+				)
+	
+	resolveby ks a = do
+		{- Remove conflicted file from index so merge can be resolved. -}
+		Annex.Queue.addCommand "rm"
+			[Param "--quiet", Param "-f", Param "--cached", Param "--"] [file]
+		void a
+		return (ks, Just file)
+
+{- git-merge moves conflicting files away to files
+ - named something like f~HEAD or f~branch or just f, but the
+ - exact name chosen can vary. Once the conflict is resolved,
+ - this cruft can be deleted. To avoid deleting legitimate
+ - files that look like this, only delete files that are
+ - A) not staged in git and
+ - B) have a name related to the merged files and
+ - C) are pointers to or have the content of keys that were involved
+ - in the merge.
+ -}
+cleanConflictCruft :: [Key] -> [FilePath] -> InodeMap -> Annex ()
+cleanConflictCruft resolvedks resolvedfs unstagedmap = do
+	is <- S.fromList . map (inodeCacheToKey Strongly) . concat 
+		<$> mapM Database.Keys.getInodeCaches resolvedks
+	forM_ (M.toList unstagedmap) $ \(i, f) ->
+		whenM (matchesresolved is i f) $
+			liftIO $ nukeFile f
+  where
+	fs = S.fromList resolvedfs
+	ks = S.fromList resolvedks
+	inks = maybe False (flip S.member ks)
+	matchesresolved is i f
+		| S.member f fs || S.member (conflictCruftBase f) fs = anyM id
+			[ pure (S.member i is)
+			, inks <$> isAnnexLink f
+			, inks <$> liftIO (isPointerFile f)
+			]
+		| otherwise = return False
+
+conflictCruftBase :: FilePath -> FilePath
+conflictCruftBase f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f
+
+{- When possible, reuse an existing file from the srcmap as the
+ - content of a worktree file in the resolved merge. It must have the
+ - same name as the origfile, or a name that git would use for conflict
+ - cruft. And, its inode cache must be a known one for the key. -}
+reuseOldFile :: InodeMap -> Key -> FilePath -> FilePath -> Annex Bool
+reuseOldFile srcmap key origfile destfile = do
+	is <- map (inodeCacheToKey Strongly)
+		<$> Database.Keys.getInodeCaches key
+	liftIO $ go $ mapMaybe (\i -> M.lookup i srcmap) is
+  where
+	go [] = return False
+	go (f:fs)
+		| f == origfile || conflictCruftBase f == origfile = 
+			ifM (doesFileExist f)
+				( do
+					renameFile f destfile
+					return True
+				, go fs
+				)
+		| otherwise = go fs
+	
+commitResolvedMerge :: Git.Branch.CommitMode -> Annex Bool
+commitResolvedMerge commitmode = inRepo $ Git.Branch.commitCommand commitmode
+	[ Param "--no-verify"
+	, Param "-m"
+	, Param "git-annex automatic merge conflict fix"
+	]
+
+type InodeMap = M.Map InodeCacheKey FilePath
+
+inodeMap :: Annex ([FilePath], IO Bool) -> Annex InodeMap
+inodeMap getfiles = do
+	(fs, cleanup) <- getfiles
+	fsis <- forM fs $ \f -> do
+		mi <- withTSDelta (liftIO . genInodeCache f)
+		return $ case mi of
+			Nothing -> Nothing
+			Just i -> Just (inodeCacheToKey Strongly i, f)
+	void $ liftIO cleanup
+	return $ M.fromList $ catMaybes fsis

Annex/BloomFilter.hs

@@ -0,0 +1,53 @@
+{- git-annex bloom filter
+ -
+ - Copyright 2010-2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.BloomFilter where
+
+import Annex.Common
+import qualified Annex
+import Utility.Bloom
+
+import Control.Monad.ST
+
+{- A bloom filter capable of holding half a million keys with a
+ - false positive rate of 1 in 10000000 uses around 16 mb of memory,
+ - so will easily fit on even my lowest memory systems.
+ -}
+bloomCapacity :: Annex Int
+bloomCapacity = fromMaybe 500000 . annexBloomCapacity <$> Annex.getGitConfig
+bloomAccuracy :: Annex Int
+bloomAccuracy = fromMaybe 10000000 . annexBloomAccuracy <$> Annex.getGitConfig
+bloomBitsHashes :: Annex (Int, Int)
+bloomBitsHashes = do
+	capacity <- bloomCapacity
+	accuracy <- bloomAccuracy
+	case safeSuggestSizing capacity (1 / fromIntegral accuracy) of
+		Left e -> do
+			warning $ "bloomfilter " ++ e ++ "; falling back to sane value"
+			-- precaulculated value for 500000 (1/10000000)
+			return (16777216,23)
+		Right v -> return v
+
+{- Creates a bloom filter, and runs an action to populate it.
+ -
+ - The action is passed a callback that it can use to feed values into the
+ - bloom filter. 
+ -
+ - Once the action completes, the mutable filter is frozen
+ - for later use.
+ -}
+genBloomFilter :: Hashable v => ((v -> Annex ()) -> Annex ()) -> Annex (Bloom v)
+genBloomFilter populate = do
+	(numbits, numhashes) <- bloomBitsHashes
+	bloom <- lift $ newMB (cheapHashes numhashes) numbits
+	populate $ \v -> lift $ insertMB bloom v
+	lift $ unsafeFreezeMB bloom
+  where
+	lift = liftIO . stToIO
+
+bloomFilter :: [v] -> Bloom v -> [v]
+bloomFilter l bloom = filter (\v -> v `notElemB` bloom) l

Annex/Branch.hs

@@ -0,0 +1,662 @@
+{- management of the git-annex branch
+ -
+ - Copyright 2011-2018 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Branch (
+	fullname,
+	name,
+	hasOrigin,
+	hasSibling,
+	siblingBranches,
+	create,
+	update,
+	forceUpdate,
+	updateTo,
+	get,
+	getHistorical,
+	change,
+	maybeChange,
+	commitMessage,
+	commit,
+	forceCommit,
+	getBranch,
+	files,
+	graftTreeish,
+	performTransitions,
+	withIndex,
+) where
+
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Set as S
+import qualified Data.Map as M
+import Data.Function
+import Data.Char
+import Control.Concurrent (threadDelay)
+
+import Annex.Common
+import Annex.BranchState
+import Annex.Journal
+import Annex.GitOverlay
+import qualified Git
+import qualified Git.Command
+import qualified Git.Ref
+import qualified Git.RefLog
+import qualified Git.Sha
+import qualified Git.Branch
+import qualified Git.UnionMerge
+import qualified Git.UpdateIndex
+import qualified Git.Tree
+import Git.LsTree (lsTreeParams)
+import qualified Git.HashObject
+import Annex.HashObject
+import Git.Types (Ref(..), fromRef, RefDate, TreeItemType(..))
+import Git.FilePath
+import Annex.CatFile
+import Annex.Perms
+import Logs
+import Logs.Transitions
+import Logs.File
+import Logs.Trust.Pure
+import Logs.Difference.Pure
+import qualified Annex.Queue
+import Annex.Branch.Transitions
+import qualified Annex
+import Annex.Hook
+import Utility.FileSystemEncoding
+import Utility.Directory.Stream
+
+{- Name of the branch that is used to store git-annex's information. -}
+name :: Git.Ref
+name = Git.Ref "git-annex"
+
+{- Fully qualified name of the branch. -}
+fullname :: Git.Ref
+fullname = Git.Ref $ "refs/heads/" ++ fromRef name
+
+{- Branch's name in origin. -}
+originname :: Git.Ref
+originname = Git.Ref $ "origin/" ++ fromRef name
+
+{- Does origin/git-annex exist? -}
+hasOrigin :: Annex Bool
+hasOrigin = inRepo $ Git.Ref.exists originname
+
+{- Does the git-annex branch or a sibling foo/git-annex branch exist? -}
+hasSibling :: Annex Bool
+hasSibling = not . null <$> siblingBranches
+
+{- List of git-annex (shas, branches), including the main one and any
+ - from remotes. Duplicates are filtered out. -}
+siblingBranches :: Annex [(Git.Sha, Git.Branch)]
+siblingBranches = inRepo $ Git.Ref.matchingUniq [name]
+
+{- Creates the branch, if it does not already exist. -}
+create :: Annex ()
+create = void getBranch
+
+{- Returns the ref of the branch, creating it first if necessary. -}
+getBranch :: Annex Git.Ref
+getBranch = maybe (hasOrigin >>= go >>= use) return =<< branchsha
+  where
+	go True = do
+		inRepo $ Git.Command.run
+			[Param "branch", Param $ fromRef name, Param $ fromRef originname]
+		fromMaybe (error $ "failed to create " ++ fromRef name)
+			<$> branchsha
+	go False = withIndex' True $
+		inRepo $ Git.Branch.commitAlways Git.Branch.AutomaticCommit "branch created" fullname []
+	use sha = do
+		setIndexSha sha
+		return sha
+	branchsha = inRepo $ Git.Ref.sha fullname
+
+{- Ensures that the branch and index are up-to-date; should be
+ - called before data is read from it. Runs only once per git-annex run. -}
+update :: Annex ()
+update = runUpdateOnce $ void $ updateTo =<< siblingBranches
+
+{- Forces an update even if one has already been run. -}
+forceUpdate :: Annex Bool
+forceUpdate = updateTo =<< siblingBranches
+
+{- Merges the specified Refs into the index, if they have any changes not
+ - already in it. The Branch names are only used in the commit message;
+ - it's even possible that the provided Branches have not been updated to
+ - point to the Refs yet.
+ - 
+ - The branch is fast-forwarded if possible, otherwise a merge commit is
+ - made.
+ -
+ - Before Refs are merged into the index, it's important to first stage the
+ - journal into the index. Otherwise, any changes in the journal would
+ - later get staged, and might overwrite changes made during the merge.
+ - This is only done if some of the Refs do need to be merged.
+ -
+ - Also handles performing any Transitions that have not yet been
+ - performed, in either the local branch, or the Refs.
+ -
+ - Returns True if any refs were merged in, False otherwise.
+ -}
+updateTo :: [(Git.Sha, Git.Branch)] -> Annex Bool
+updateTo pairs = ifM (annexMergeAnnexBranches <$> Annex.getGitConfig)
+	( updateTo' pairs
+	, return False
+	)
+
+updateTo' :: [(Git.Sha, Git.Branch)] -> Annex Bool
+updateTo' pairs = do
+	-- ensure branch exists, and get its current ref
+	branchref <- getBranch
+	dirty <- journalDirty
+	ignoredrefs <- getIgnoredRefs
+	let unignoredrefs = excludeset ignoredrefs pairs
+	tomerge <- if null unignoredrefs
+		then return []
+		else do
+			mergedrefs <- getMergedRefs
+			filterM isnewer (excludeset mergedrefs unignoredrefs)
+	if null tomerge
+		{- Even when no refs need to be merged, the index
+		 - may still be updated if the branch has gotten ahead 
+		 - of the index. -}
+		then do
+			whenM (needUpdateIndex branchref) $ lockJournal $ \jl -> do
+				forceUpdateIndex jl branchref
+				{- When there are journalled changes
+				 - as well as the branch being updated,
+				 - a commit needs to be done. -}
+				when dirty $
+					go branchref True [] jl
+		else lockJournal $ go branchref dirty tomerge
+	return $ not $ null tomerge
+  where
+	excludeset s = filter (\(r, _) -> S.notMember r s)
+	isnewer (r, _) = inRepo $ Git.Branch.changed fullname r
+	go branchref dirty tomerge jl = withIndex $ do
+		let (refs, branches) = unzip tomerge
+		cleanjournal <- if dirty then stageJournal jl else return noop
+		merge_desc <- if null tomerge
+			then commitMessage
+			else return $ "merging " ++
+				unwords (map Git.Ref.describe branches) ++ 
+				" into " ++ fromRef name
+		localtransitions <- parseTransitionsStrictly "local"
+			<$> getLocal transitionsLog
+		unless (null tomerge) $ do
+			showSideAction merge_desc
+			mapM_ checkBranchDifferences refs
+			mergeIndex jl refs
+		let commitrefs = nub $ fullname:refs
+		ifM (handleTransitions jl localtransitions commitrefs)
+			( runAnnexHook postUpdateAnnexHook
+			, do
+				ff <- if dirty
+					then return False
+					else inRepo $ Git.Branch.fastForward fullname refs
+				if ff
+					then updateIndex jl branchref
+					else commitIndex jl branchref merge_desc commitrefs
+			)
+		addMergedRefs tomerge
+		liftIO cleanjournal
+
+{- Gets the content of a file, which may be in the journal, or in the index
+ - (and committed to the branch).
+ - 
+ - Updates the branch if necessary, to ensure the most up-to-date available
+ - content is returned.
+ -
+ - Returns an empty string if the file doesn't exist yet. -}
+get :: FilePath -> Annex String
+get file = do
+	update
+	getLocal file
+
+{- Like get, but does not merge the branch, so the info returned may not
+ - reflect changes in remotes.
+ - (Changing the value this returns, and then merging is always the
+ - same as using get, and then changing its value.) -}
+getLocal :: FilePath -> Annex String
+getLocal file = go =<< getJournalFileStale file
+  where
+	go (Just journalcontent) = return journalcontent
+	go Nothing = getRef fullname file
+
+{- Gets the content of a file as staged in the branch's index. -}
+getStaged :: FilePath -> Annex String
+getStaged = getRef indexref
+  where
+	-- This makes git cat-file be run with ":file",
+	-- so it looks at the index.
+	indexref = Ref ""
+
+getHistorical :: RefDate -> FilePath -> Annex String
+getHistorical date file =
+	-- This check avoids some ugly error messages when the reflog
+	-- is empty.
+	ifM (null <$> inRepo (Git.RefLog.get' [Param (fromRef fullname), Param "-n1"]))
+		( giveup ("No reflog for " ++ fromRef fullname)
+		, getRef (Git.Ref.dateRef fullname date) file
+		)
+
+getRef :: Ref -> FilePath -> Annex String
+getRef ref file = withIndex $ decodeBS <$> catFile ref file
+
+{- Applies a function to modify the content of a file.
+ -
+ - Note that this does not cause the branch to be merged, it only
+ - modifes the current content of the file on the branch.
+ -}
+change :: FilePath -> (String -> String) -> Annex ()
+change file f = lockJournal $ \jl -> f <$> getLocal file >>= set jl file
+
+{- Applies a function which can modify the content of a file, or not. -}
+maybeChange :: FilePath -> (String -> Maybe String) -> Annex ()
+maybeChange file f = lockJournal $ \jl -> do
+	v <- getLocal file
+	case f v of
+		Just v' | v' /= v -> set jl file v'
+		_ -> noop
+
+{- Records new content of a file into the journal -}
+set :: JournalLocked -> FilePath -> String -> Annex ()
+set = setJournalFile
+
+{- Commit message used when making a commit of whatever data has changed
+ - to the git-annex brach. -}
+commitMessage :: Annex String
+commitMessage = fromMaybe "update" . annexCommitMessage <$> Annex.getGitConfig
+
+{- Stages the journal, and commits staged changes to the branch. -}
+commit :: String -> Annex ()
+commit = whenM journalDirty . forceCommit
+
+{- Commits the current index to the branch even without any journalled
+ - changes. -}
+forceCommit :: String -> Annex ()
+forceCommit message = lockJournal $ \jl -> do
+	cleanjournal <- stageJournal jl
+	ref <- getBranch
+	withIndex $ commitIndex jl ref message [fullname]
+	liftIO cleanjournal
+
+{- Commits the staged changes in the index to the branch.
+ - 
+ - Ensures that the branch's index file is first updated to merge the state
+ - of the branch at branchref, before running the commit action. This
+ - is needed because the branch may have had changes pushed to it, that
+ - are not yet reflected in the index.
+ - 
+ - The branchref value can have been obtained using getBranch at any
+ - previous point, though getting it a long time ago makes the race
+ - more likely to occur.
+ -
+ - Note that changes may be pushed to the branch at any point in time!
+ - So, there's a race. If the commit is made using the newly pushed tip of
+ - the branch as its parent, and that ref has not yet been merged into the
+ - index, then the result is that the commit will revert the pushed
+ - changes, since they have not been merged into the index. This race
+ - is detected and another commit made to fix it.
+ -
+ - (It's also possible for the branch to be overwritten,
+ - losing the commit made here. But that's ok; the data is still in the
+ - index and will get committed again later.)
+ -}
+commitIndex :: JournalLocked -> Git.Ref -> String -> [Git.Ref] -> Annex ()
+commitIndex jl branchref message parents = do
+	showStoringStateAction
+	commitIndex' jl branchref message message 0 parents
+commitIndex' :: JournalLocked -> Git.Ref -> String -> String -> Integer -> [Git.Ref] -> Annex ()
+commitIndex' jl branchref message basemessage retrynum parents = do
+	updateIndex jl branchref
+	committedref <- inRepo $ Git.Branch.commitAlways Git.Branch.AutomaticCommit message fullname parents
+	setIndexSha committedref
+	parentrefs <- commitparents <$> catObject committedref
+	when (racedetected branchref parentrefs) $
+		fixrace committedref parentrefs
+  where
+	-- look for "parent ref" lines and return the refs
+	commitparents = map (Git.Ref . snd) . filter isparent .
+		map (toassoc . decodeBS) . L.split newline
+	newline = fromIntegral (ord '\n')
+	toassoc = separate (== ' ')
+	isparent (k,_) = k == "parent"
+		
+	{- The race can be detected by checking the commit's
+	 - parent, which will be the newly pushed branch,
+	 - instead of the expected ref that the index was updated to. -}
+	racedetected expectedref parentrefs
+		| expectedref `elem` parentrefs = False -- good parent
+		| otherwise = True -- race!
+		
+	{- To recover from the race, union merge the lost refs
+	 - into the index. -}
+	fixrace committedref lostrefs = do
+		showSideAction "recovering from race"
+		let retrynum' = retrynum+1
+		-- small sleep to let any activity that caused
+		-- the race settle down
+		liftIO $ threadDelay (100000 + fromInteger retrynum')
+		mergeIndex jl lostrefs
+		let racemessage = basemessage ++ " (recovery from race #" ++ show retrynum' ++ "; expected commit parent " ++ show branchref ++ " but found " ++ show lostrefs ++ " )"
+		commitIndex' jl committedref racemessage basemessage retrynum' [committedref]
+
+{- Lists all files on the branch. including ones in the journal
+ - that have not been committed yet. There may be duplicates in the list. -}
+files :: Annex [FilePath]
+files = do
+	update
+	-- ++ forces the content of the first list to be buffered in memory,
+	-- so use getJournalledFilesStale which should be much smaller most
+	-- of the time. branchFiles will stream as the list is consumed.
+	(++)
+		<$> getJournalledFilesStale
+		<*> branchFiles
+
+{- Files in the branch, not including any from journalled changes,
+ - and without updating the branch. -}
+branchFiles :: Annex [FilePath]
+branchFiles = withIndex $ inRepo branchFiles'
+
+branchFiles' :: Git.Repo -> IO [FilePath]
+branchFiles' = Git.Command.pipeNullSplitZombie
+	(lsTreeParams fullname [Param "--name-only"])
+
+{- Populates the branch's index file with the current branch contents.
+ - 
+ - This is only done when the index doesn't yet exist, and the index 
+ - is used to build up changes to be commited to the branch, and merge
+ - in changes from other branches.
+ -}
+genIndex :: Git.Repo -> IO ()
+genIndex g = Git.UpdateIndex.streamUpdateIndex g
+	[Git.UpdateIndex.lsTree fullname g]
+
+{- Merges the specified refs into the index.
+ - Any changes staged in the index will be preserved. -}
+mergeIndex :: JournalLocked -> [Git.Ref] -> Annex ()
+mergeIndex jl branches = do
+	prepareModifyIndex jl
+	hashhandle <- hashObjectHandle
+	ch <- catFileHandle
+	inRepo $ \g -> Git.UnionMerge.mergeIndex hashhandle ch g branches
+
+{- Removes any stale git lock file, to avoid git falling over when
+ - updating the index.
+ -
+ - Since all modifications of the index are performed inside this module,
+ - and only when the journal is locked, the fact that the journal has to be
+ - locked when this is called ensures that no other process is currently
+ - modifying the index. So any index.lock file must be stale, caused
+ - by git running when the system crashed, or the repository's disk was
+ - removed, etc.
+ -}
+prepareModifyIndex :: JournalLocked -> Annex ()
+prepareModifyIndex _jl = do
+	index <- fromRepo gitAnnexIndex
+	void $ liftIO $ tryIO $ removeFile $ index ++ ".lock"
+
+{- Runs an action using the branch's index file. -}
+withIndex :: Annex a -> Annex a
+withIndex = withIndex' False
+withIndex' :: Bool -> Annex a -> Annex a
+withIndex' bootstrapping a = do
+	f <- fromRepo gitAnnexIndex
+	withIndexFile f $ do
+		checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do
+			unless bootstrapping create
+			createAnnexDirectory $ takeDirectory f
+			unless bootstrapping $ inRepo genIndex
+		a
+
+{- Updates the branch's index to reflect the current contents of the branch.
+ - Any changes staged in the index will be preserved.
+ -
+ - Compares the ref stored in the lock file with the current
+ - ref of the branch to see if an update is needed.
+ -}
+updateIndex :: JournalLocked -> Git.Ref -> Annex ()
+updateIndex jl branchref = whenM (needUpdateIndex branchref) $
+	forceUpdateIndex jl branchref
+
+forceUpdateIndex :: JournalLocked -> Git.Ref -> Annex ()
+forceUpdateIndex jl branchref = do
+	withIndex $ mergeIndex jl [fullname]
+	setIndexSha branchref
+
+{- Checks if the index needs to be updated. -}
+needUpdateIndex :: Git.Ref -> Annex Bool
+needUpdateIndex branchref = do
+	f <- fromRepo gitAnnexIndexStatus
+	committedref <- Git.Ref . firstLine <$>
+		liftIO (catchDefaultIO "" $ readFileStrict f)
+	return (committedref /= branchref)
+
+{- Record that the branch's index has been updated to correspond to a
+ - given ref of the branch. -}
+setIndexSha :: Git.Ref -> Annex ()
+setIndexSha ref = do
+	f <- fromRepo gitAnnexIndexStatus
+	writeLogFile f $ fromRef ref ++ "\n"
+	runAnnexHook postUpdateAnnexHook
+
+{- Stages the journal into the index and returns an action that will
+ - clean up the staged journal files, which should only be run once
+ - the index has been committed to the branch.
+ -
+ - Before staging, this removes any existing git index file lock.
+ - This is safe to do because stageJournal is the only thing that
+ - modifies this index file, and only one can run at a time, because
+ - the journal is locked. So any existing git index file lock must be
+ - stale, and the journal must contain any data that was in the process
+ - of being written to the index file when it crashed.
+ -}
+stageJournal :: JournalLocked -> Annex (IO ())
+stageJournal jl = withIndex $ do
+	prepareModifyIndex jl
+	g <- gitRepo
+	let dir = gitAnnexJournalDir g
+	(jlogf, jlogh) <- openjlog
+	h <- hashObjectHandle
+	withJournalHandle $ \jh ->
+		Git.UpdateIndex.streamUpdateIndex g
+			[genstream dir h jh jlogh]
+	return $ cleanup dir jlogh jlogf
+  where
+	genstream dir h jh jlogh streamer = readDirectory jh >>= \case
+		Nothing -> return ()
+		Just file -> do
+			unless (dirCruft file) $ do
+				let path = dir </> file
+				sha <- Git.HashObject.hashFile h path
+				hPutStrLn jlogh file
+				streamer $ Git.UpdateIndex.updateIndexLine
+					sha TreeFile (asTopFilePath $ fileJournal file)
+			genstream dir h jh jlogh streamer
+	-- Clean up the staged files, as listed in the temp log file.
+	-- The temp file is used to avoid needing to buffer all the
+	-- filenames in memory.
+	cleanup dir jlogh jlogf = do
+		hFlush jlogh
+		hSeek jlogh AbsoluteSeek 0
+		stagedfs <- lines <$> hGetContents jlogh
+		mapM_ (removeFile . (dir </>)) stagedfs
+		hClose jlogh
+		nukeFile jlogf
+	openjlog = do
+		tmpdir <- fromRepo gitAnnexTmpMiscDir
+		createAnnexDirectory tmpdir
+		liftIO $ openTempFile tmpdir "jlog"
+
+{- This is run after the refs have been merged into the index,
+ - but before the result is committed to the branch.
+ - (Which is why it's passed the contents of the local branches's
+ - transition log before that merge took place.)
+ -
+ - When the refs contain transitions that have not yet been done locally,
+ - the transitions are performed on the index, and a new branch
+ - is created from the result.
+ -
+ - When there are transitions recorded locally that have not been done
+ - to the remote refs, the transitions are performed in the index,
+ - and committed to the existing branch. In this case, the untransitioned
+ - remote refs cannot be merged into the branch (since transitions
+ - throw away history), so they are added to the list of refs to ignore,
+ - to avoid re-merging content from them again.
+ -}
+handleTransitions :: JournalLocked -> Transitions -> [Git.Ref] -> Annex Bool
+handleTransitions jl localts refs = do
+	m <- M.fromList <$> mapM getreftransition refs
+	let remotets = M.elems m
+	if all (localts ==) remotets
+		then return False
+		else do
+			let allts = combineTransitions (localts:remotets)
+			let (transitionedrefs, untransitionedrefs) =
+				partition (\r -> M.lookup r m == Just allts) refs
+			performTransitionsLocked jl allts (localts /= allts) transitionedrefs
+			ignoreRefs untransitionedrefs
+			return True
+  where
+	getreftransition ref = do
+		ts <- parseTransitionsStrictly "remote" . decodeBS
+			<$> catFile ref transitionsLog
+		return (ref, ts)
+
+{- Performs the specified transitions on the contents of the index file,
+ - commits it to the branch, or creates a new branch.
+ -}
+performTransitions :: Transitions -> Bool -> [Ref] -> Annex ()
+performTransitions ts neednewlocalbranch transitionedrefs = lockJournal $ \jl ->
+	performTransitionsLocked jl ts neednewlocalbranch transitionedrefs
+performTransitionsLocked :: JournalLocked -> Transitions -> Bool -> [Ref] -> Annex ()
+performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do
+	-- For simplicity & speed, we're going to use the Annex.Queue to
+	-- update the git-annex branch, while it usually holds changes
+	-- for the head branch. Flush any such changes.
+	Annex.Queue.flush
+	-- Stop any running git cat-files, to ensure that the
+	-- getStaged calls below use the current index, and not some older
+	-- one.
+	catFileStop
+	withIndex $ do
+		prepareModifyIndex jl
+		run $ mapMaybe getTransitionCalculator tlist
+		Annex.Queue.flush
+		if neednewlocalbranch
+			then do
+				committedref <- inRepo $ Git.Branch.commitAlways Git.Branch.AutomaticCommit message fullname transitionedrefs
+				setIndexSha committedref
+			else do
+				ref <- getBranch
+				commitIndex jl ref message (nub $ fullname:transitionedrefs)
+  where
+	message
+		| neednewlocalbranch && null transitionedrefs = "new branch for transition " ++ tdesc
+		| otherwise = "continuing transition " ++ tdesc
+	tdesc = show $ map describeTransition tlist
+	tlist = transitionList ts
+
+	{- The changes to make to the branch are calculated and applied to
+	 - the branch directly, rather than going through the journal,
+	 - which would be innefficient. (And the journal is not designed
+	 - to hold changes to every file in the branch at once.)
+	 -
+	 - When a file in the branch is changed by transition code,
+	 - its new content is remembered and fed into the code for subsequent
+	 - transitions.
+	 -}
+	run [] = noop
+	run changers = do
+		trustmap <- calcTrustMap <$> getStaged trustLog
+		fs <- branchFiles
+		forM_ fs $ \f -> do
+			content <- getStaged f
+			apply changers f content trustmap
+	apply [] _ _ _ = return ()
+	apply (changer:rest) file content trustmap =
+		case changer file content trustmap of
+			RemoveFile -> do
+				Annex.Queue.addUpdateIndex
+					=<< inRepo (Git.UpdateIndex.unstageFile file)
+				-- File is deleted; can't run any other
+				-- transitions on it.
+				return ()
+			ChangeFile content' -> do
+				sha <- hashBlob content'
+				Annex.Queue.addUpdateIndex $ Git.UpdateIndex.pureStreamer $
+					Git.UpdateIndex.updateIndexLine sha TreeFile (asTopFilePath file)
+				apply rest file content' trustmap
+			PreserveFile ->
+				apply rest file content trustmap
+
+checkBranchDifferences :: Git.Ref -> Annex ()
+checkBranchDifferences ref = do
+	theirdiffs <- allDifferences . parseDifferencesLog . decodeBS
+		<$> catFile ref differenceLog
+	mydiffs <- annexDifferences <$> Annex.getGitConfig
+	when (theirdiffs /= mydiffs) $
+		giveup "Remote repository is tuned in incompatible way; cannot be merged with local repository."
+
+ignoreRefs :: [Git.Sha] -> Annex ()
+ignoreRefs rs = do
+	old <- getIgnoredRefs
+	let s = S.unions [old, S.fromList rs]
+	f <- fromRepo gitAnnexIgnoredRefs
+	writeLogFile f $
+		unlines $ map fromRef $ S.elems s
+
+getIgnoredRefs :: Annex (S.Set Git.Sha)
+getIgnoredRefs = S.fromList . mapMaybe Git.Sha.extractSha . lines <$> content
+  where
+	content = do
+		f <- fromRepo gitAnnexIgnoredRefs
+		liftIO $ catchDefaultIO "" $ readFile f
+
+addMergedRefs :: [(Git.Sha, Git.Branch)] -> Annex ()
+addMergedRefs [] = return ()
+addMergedRefs new = do
+	old <- getMergedRefs'
+	-- Keep only the newest sha for each branch.
+	let l = nubBy ((==) `on` snd) (new ++ old)
+	f <- fromRepo gitAnnexMergedRefs
+	writeLogFile f $
+		unlines $ map (\(s, b) -> fromRef s ++ '\t' : fromRef b) l
+
+getMergedRefs :: Annex (S.Set Git.Sha)
+getMergedRefs = S.fromList . map fst <$> getMergedRefs'
+
+getMergedRefs' :: Annex [(Git.Sha, Git.Branch)]
+getMergedRefs' = do
+	f <- fromRepo gitAnnexMergedRefs
+	s <- liftIO $ catchDefaultIO "" $ readFile f
+	return $ map parse $ lines s
+  where
+	parse l = 
+		let (s, b) = separate (== '\t') l
+		in (Ref s, Ref b)
+
+{- Grafts a treeish into the branch at the specified location,
+ - and then removes it. This ensures that the treeish won't get garbage
+ - collected, and will always be available as long as the git-annex branch
+ - is available. -}
+graftTreeish :: Git.Ref -> TopFilePath -> Annex ()
+graftTreeish treeish graftpoint = lockJournal $ \jl -> do
+	branchref <- getBranch
+	updateIndex jl branchref
+	Git.Tree.Tree t <- inRepo $ Git.Tree.getTree branchref
+	t' <- inRepo $ Git.Tree.recordTree $ Git.Tree.Tree $
+		Git.Tree.RecordedSubTree graftpoint treeish [] : t
+	c <- inRepo $ Git.Branch.commitTree Git.Branch.AutomaticCommit
+		"graft" [branchref] t'
+	origtree <- inRepo $ Git.Tree.recordTree (Git.Tree.Tree t)
+	c' <- inRepo $ Git.Branch.commitTree Git.Branch.AutomaticCommit
+		"graft cleanup" [c] origtree
+	inRepo $ Git.Branch.update' fullname c'
+	-- The tree in c' is the same as the tree in branchref,
+	-- and the index was updated to that above, so it's safe to
+	-- say that the index contains c'.
+	setIndexSha c'

Annex/Branch/Transitions.hs

@@ -0,0 +1,64 @@
+{- git-annex branch transitions
+ -
+ - Copyright 2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Branch.Transitions (
+	FileTransition(..),
+	getTransitionCalculator
+) where
+
+import Logs
+import Logs.Transitions
+import qualified Logs.UUIDBased as UUIDBased
+import qualified Logs.Presence.Pure as Presence
+import qualified Logs.Chunk.Pure as Chunk
+import Types.TrustLevel
+import Types.UUID
+
+import qualified Data.Map as M
+import Data.Default
+
+data FileTransition
+	= ChangeFile String
+	| RemoveFile
+	| PreserveFile
+
+type TransitionCalculator = FilePath -> String -> TrustMap -> FileTransition
+
+getTransitionCalculator :: Transition -> Maybe TransitionCalculator
+getTransitionCalculator ForgetGitHistory = Nothing
+getTransitionCalculator ForgetDeadRemotes = Just dropDead
+
+dropDead :: FilePath -> String -> TrustMap -> FileTransition
+dropDead f content trustmap = case getLogVariety f of
+	Just UUIDBasedLog
+		-- Don't remove the dead repo from the trust log,
+		-- because git remotes may still exist, and they need
+		-- to still know it's dead.
+		| f == trustLog -> PreserveFile
+		| otherwise -> ChangeFile $ UUIDBased.showLog id $ dropDeadFromMapLog trustmap id $ UUIDBased.parseLog Just content
+	Just NewUUIDBasedLog -> ChangeFile $
+		UUIDBased.showLogNew id $ dropDeadFromMapLog trustmap id $ UUIDBased.parseLogNew Just content
+	Just (ChunkLog _) -> ChangeFile $
+		Chunk.showLog $ dropDeadFromMapLog trustmap fst $ Chunk.parseLog content
+	Just (PresenceLog _) ->
+		let newlog = Presence.compactLog $ dropDeadFromPresenceLog trustmap $ Presence.parseLog content
+		in if null newlog
+			then RemoveFile
+			else ChangeFile $ Presence.showLog newlog
+	Just OtherLog -> PreserveFile
+	Nothing -> PreserveFile
+
+dropDeadFromMapLog :: TrustMap -> (k -> UUID) -> M.Map k v -> M.Map k v
+dropDeadFromMapLog trustmap getuuid = M.filterWithKey $ \k _v -> notDead trustmap getuuid k
+
+{- Presence logs can contain UUIDs or other values. Any line that matches
+ - a dead uuid is dropped; any other values are passed through. -}
+dropDeadFromPresenceLog :: TrustMap -> [Presence.LogLine] -> [Presence.LogLine]
+dropDeadFromPresenceLog trustmap = filter $ notDead trustmap (toUUID . Presence.info)
+
+notDead :: TrustMap -> (v -> UUID) -> v -> Bool
+notDead trustmap a v = M.findWithDefault def (a v) trustmap /= DeadTrusted

Annex/BranchState.hs

@@ -0,0 +1,41 @@
+{- git-annex branch state management
+ -
+ - Runtime state about the git-annex branch.
+ -
+ - Copyright 2011-2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.BranchState where
+
+import Annex.Common
+import Types.BranchState
+import qualified Annex
+
+getState :: Annex BranchState
+getState = Annex.getState Annex.branchstate
+
+changeState :: (BranchState -> BranchState) -> Annex ()
+changeState changer = Annex.changeState $ \s -> 
+	s { Annex.branchstate = changer (Annex.branchstate s) }
+
+{- Runs an action to check that the index file exists, if it's not been
+ - checked before in this run of git-annex. -}
+checkIndexOnce :: Annex () -> Annex ()
+checkIndexOnce a = unlessM (indexChecked <$> getState) $ do
+	a
+	changeState $ \s -> s { indexChecked = True }
+
+{- Runs an action to update the branch, if it's not been updated before
+ - in this run of git-annex. -}
+runUpdateOnce :: Annex () -> Annex ()
+runUpdateOnce a = unlessM (branchUpdated <$> getState) $ do
+	a
+	disableUpdate
+
+{- Avoids updating the branch. A useful optimisation when the branch
+ - is known to have not changed, or git-annex won't be relying on info
+ - from it. -}
+disableUpdate :: Annex ()
+disableUpdate = changeState $ \s -> s { branchUpdated = True }

Annex/CatFile.hs

@@ -0,0 +1,143 @@
+{- git cat-file interface, with handle automatically stored in the Annex monad
+ -
+ - Copyright 2011-2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.CatFile (
+	catFile,
+	catFileDetails,
+	catObject,
+	catTree,
+	catCommit,
+	catObjectDetails,
+	catFileHandle,
+	catFileStop,
+	catKey,
+	catKeyFile,
+	catKeyFileHEAD,
+	catSymLinkTarget,
+) where
+
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Map as M
+import System.PosixCompat.Types
+
+import Annex.Common
+import qualified Git
+import qualified Git.CatFile
+import qualified Annex
+import Git.Types
+import Git.FilePath
+import Git.Index
+import qualified Git.Ref
+import Annex.Link
+import Utility.FileSystemEncoding
+
+catFile :: Git.Branch -> FilePath -> Annex L.ByteString
+catFile branch file = do
+	h <- catFileHandle
+	liftIO $ Git.CatFile.catFile h branch file
+
+catFileDetails :: Git.Branch -> FilePath -> Annex (Maybe (L.ByteString, Sha, ObjectType))
+catFileDetails branch file = do
+	h <- catFileHandle
+	liftIO $ Git.CatFile.catFileDetails h branch file
+
+catObject :: Git.Ref -> Annex L.ByteString
+catObject ref = do
+	h <- catFileHandle
+	liftIO $ Git.CatFile.catObject h ref
+
+catObjectMetaData :: Git.Ref -> Annex (Maybe (Integer, ObjectType))
+catObjectMetaData ref = do
+	h <- catFileHandle
+	liftIO $ Git.CatFile.catObjectMetaData h ref
+
+catTree :: Git.Ref -> Annex [(FilePath, FileMode)]
+catTree ref = do
+	h <- catFileHandle
+	liftIO $ Git.CatFile.catTree h ref
+
+catCommit :: Git.Ref -> Annex (Maybe Commit)
+catCommit ref = do
+	h <- catFileHandle
+	liftIO $ Git.CatFile.catCommit h ref
+
+catObjectDetails :: Git.Ref -> Annex (Maybe (L.ByteString, Sha, ObjectType))
+catObjectDetails ref = do
+	h <- catFileHandle
+	liftIO $ Git.CatFile.catObjectDetails h ref
+
+{- There can be multiple index files, and a different cat-file is needed
+ - for each. This is selected by setting GIT_INDEX_FILE in the gitEnv. -}
+catFileHandle :: Annex Git.CatFile.CatFileHandle
+catFileHandle = do
+	m <- Annex.getState Annex.catfilehandles
+	indexfile <- fromMaybe "" . maybe Nothing (lookup indexEnv)
+		<$> fromRepo gitEnv
+	case M.lookup indexfile m of
+		Just h -> return h
+		Nothing -> do
+			h <- inRepo Git.CatFile.catFileStart
+			let m' = M.insert indexfile h m
+			Annex.changeState $ \s -> s { Annex.catfilehandles = m' }
+			return h
+
+{- Stops all running cat-files. Should only be run when it's known that
+ - nothing is using the handles, eg at shutdown. -}
+catFileStop :: Annex ()
+catFileStop = do
+	m <- Annex.withState $ pure . \s ->
+		(s { Annex.catfilehandles = M.empty }, Annex.catfilehandles s)
+	liftIO $ mapM_ Git.CatFile.catFileStop (M.elems m)
+
+{- From ref to a symlink or a pointer file, get the key. -}
+catKey :: Ref -> Annex (Maybe Key)
+catKey ref = go =<< catObjectMetaData ref
+  where
+	go (Just (sz, _))
+		-- Avoid catting large files, that cannot be symlinks or
+		-- pointer files, which would require buffering their
+		-- content in memory, as well as a lot of IO.
+		| sz <= maxPointerSz = parseLinkOrPointer <$> catObject ref
+	go _ = return Nothing
+
+{- Gets a symlink target. -}
+catSymLinkTarget :: Sha -> Annex String
+catSymLinkTarget sha = fromInternalGitPath . decodeBS <$> get
+  where
+	-- Avoid buffering the whole file content, which might be large.
+	-- 8192 is enough if it really is a symlink.
+	get = L.take 8192 <$> catObject sha
+
+{- From a file in the repository back to the key.
+ -
+ - Ideally, this should reflect the key that's staged in the index,
+ - not the key that's committed to HEAD. Unfortunately, git cat-file
+ - does not refresh the index file after it's started up, so things
+ - newly staged in the index won't show up. It does, however, notice
+ - when branches change.
+ -
+ - For command-line git-annex use, that doesn't matter. It's perfectly
+ - reasonable for things staged in the index after the currently running
+ - git-annex process to not be noticed by it. However, we do want to see
+ - what's in the index, since it may have uncommitted changes not in HEAD
+ -
+ - For the assistant, this is much more of a problem, since it commits
+ - files and then needs to be able to immediately look up their keys.
+ - OTOH, the assistant doesn't keep changes staged in the index for very
+ - long at all before committing them -- and it won't look at the keys
+ - of files until after committing them.
+ -
+ - So, this gets info from the index, unless running as a daemon.
+ -}
+catKeyFile :: FilePath -> Annex (Maybe Key)
+catKeyFile f = ifM (Annex.getState Annex.daemon)
+	( catKeyFileHEAD f
+	, catKey $ Git.Ref.fileRef f
+	)
+
+catKeyFileHEAD :: FilePath -> Annex (Maybe Key)
+catKeyFileHEAD f = catKey $ Git.Ref.fileFromRef Git.Ref.headRef f

Annex/ChangedRefs.hs

@@ -0,0 +1,103 @@
+{- Waiting for changed git refs
+ -
+ - Copyright 2014-216 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.ChangedRefs
+	( ChangedRefs(..)
+	, ChangedRefsHandle
+	, waitChangedRefs
+	, drainChangedRefs
+	, stopWatchingChangedRefs
+	, watchChangedRefs
+	) where
+
+import Annex.Common
+import Utility.DirWatcher
+import Utility.DirWatcher.Types
+import qualified Git
+import Git.Sha
+import qualified Utility.SimpleProtocol as Proto
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TBMChan
+
+newtype ChangedRefs = ChangedRefs [Git.Ref]
+	deriving (Show)
+
+instance Proto.Serializable ChangedRefs where
+	serialize (ChangedRefs l) = unwords $ map Git.fromRef l
+	deserialize = Just . ChangedRefs . map Git.Ref . words
+
+data ChangedRefsHandle = ChangedRefsHandle DirWatcherHandle (TBMChan Git.Sha)
+
+-- | Wait for one or more git refs to change.
+--
+-- When possible, coalesce ref writes that occur closely together
+-- in time. Delay up to 0.05 seconds to get more ref writes.
+waitChangedRefs :: ChangedRefsHandle -> IO ChangedRefs
+waitChangedRefs (ChangedRefsHandle _ chan) =
+	atomically (readTBMChan chan) >>= \case
+		Nothing -> return $ ChangedRefs []
+		Just r -> do
+			threadDelay 50000
+			rs <- atomically $ loop []
+			return $ ChangedRefs (r:rs)
+  where
+	loop rs = tryReadTBMChan chan >>= \case
+		Just (Just r) -> loop (r:rs)
+		_ -> return rs
+
+-- | Remove any changes that might be buffered in the channel,
+-- without waiting for any new changes.
+drainChangedRefs :: ChangedRefsHandle -> IO ()
+drainChangedRefs (ChangedRefsHandle _ chan) = atomically go
+  where
+	go = tryReadTBMChan chan >>= \case
+		Just (Just _) -> go
+		_ -> return ()
+
+stopWatchingChangedRefs :: ChangedRefsHandle -> IO ()
+stopWatchingChangedRefs h@(ChangedRefsHandle wh chan) = do
+	stopWatchDir wh
+	atomically $ closeTBMChan chan
+	drainChangedRefs h
+
+watchChangedRefs :: Annex (Maybe ChangedRefsHandle)
+watchChangedRefs = do
+	-- This channel is used to accumulate notifications,
+	-- because the DirWatcher might have multiple threads that find
+	-- changes at the same time. It is bounded to allow a watcher
+	-- to be started once and reused, without too many changes being
+	-- buffered in memory.
+	chan <- liftIO $ newTBMChanIO 100
+	
+	g <- gitRepo
+	let refdir = Git.localGitDir g </> "refs"
+	liftIO $ createDirectoryIfMissing True refdir
+
+	let notifyhook = Just $ notifyHook chan
+	let hooks = mkWatchHooks
+		{ addHook = notifyhook
+		, modifyHook = notifyhook
+		}
+
+	if canWatch
+		then do
+			h <- liftIO $ watchDir refdir (const False) True hooks id
+			return $ Just $ ChangedRefsHandle h chan
+		else return Nothing
+
+notifyHook :: TBMChan Git.Sha -> FilePath -> Maybe FileStatus -> IO ()
+notifyHook chan reffile _
+	| ".lock" `isSuffixOf` reffile = noop
+	| otherwise = void $ do
+		sha <- catchDefaultIO Nothing $
+			extractSha <$> readFile reffile
+		-- When the channel is full, there is probably no reader
+		-- running, or ref changes have been occuring very fast,
+		-- so it's ok to not write the change to it.
+		maybe noop (void . atomically . tryWriteTBMChan chan) sha

Annex/CheckAttr.hs

@@ -0,0 +1,44 @@
+{- git check-attr interface, with handle automatically stored in the Annex monad
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.CheckAttr (
+	checkAttr,
+	checkAttrHandle,
+	checkAttrStop,
+) where
+
+import Annex.Common
+import qualified Git.CheckAttr as Git
+import qualified Annex
+
+{- All gitattributes used by git-annex. -}
+annexAttrs :: [Git.Attr]
+annexAttrs =
+	[ "annex.backend"
+	, "annex.numcopies"
+	, "annex.largefiles"
+	]
+
+checkAttr :: Git.Attr -> FilePath -> Annex String
+checkAttr attr file = do
+	h <- checkAttrHandle
+	liftIO $ Git.checkAttr h attr file
+
+checkAttrHandle :: Annex Git.CheckAttrHandle
+checkAttrHandle = maybe startup return =<< Annex.getState Annex.checkattrhandle
+  where
+	startup = do
+		h <- inRepo $ Git.checkAttrStart annexAttrs
+		Annex.changeState $ \s -> s { Annex.checkattrhandle = Just h }
+		return h
+
+checkAttrStop :: Annex ()
+checkAttrStop = maybe noop stop =<< Annex.getState Annex.checkattrhandle
+  where
+	stop h = do
+		liftIO $ Git.checkAttrStop h
+		Annex.changeState $ \s -> s { Annex.checkattrhandle = Nothing }

Annex/CheckIgnore.hs

@@ -0,0 +1,41 @@
+{- git check-ignore interface, with handle automatically stored in
+ - the Annex monad
+ -
+ - Copyright 2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.CheckIgnore (
+	checkIgnored,
+	checkIgnoreHandle,
+	checkIgnoreStop
+) where
+
+import Annex.Common
+import qualified Git.CheckIgnore as Git
+import qualified Annex
+
+checkIgnored :: FilePath -> Annex Bool
+checkIgnored file = go =<< checkIgnoreHandle
+  where
+	go Nothing = return False
+	go (Just h) = liftIO $ Git.checkIgnored h file
+
+checkIgnoreHandle :: Annex (Maybe Git.CheckIgnoreHandle)
+checkIgnoreHandle = maybe startup return =<< Annex.getState Annex.checkignorehandle
+  where
+	startup = do
+		v <- inRepo Git.checkIgnoreStart
+		when (isNothing v) $
+			warning "The installed version of git is too old for .gitignores to be honored by git-annex."
+		Annex.changeState $ \s -> s { Annex.checkignorehandle = Just v }
+		return v
+
+checkIgnoreStop :: Annex ()
+checkIgnoreStop = maybe noop stop =<< Annex.getState Annex.checkignorehandle
+  where
+	stop (Just h) = do
+		liftIO $ Git.checkIgnoreStop h
+		Annex.changeState $ \s -> s { Annex.checkignorehandle = Nothing }
+	stop Nothing = noop

Annex/Common.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE CPP #-}
+
+module Annex.Common (module X) where
+
+import Common as X
+import Types as X
+import Key as X
+import Types.UUID as X
+import Annex as X (gitRepo, inRepo, fromRepo, calcRepo)
+import Annex.Locations as X
+import Messages as X
+#ifndef mingw32_HOST_OS
+import System.Posix.IO as X hiding (createPipe)
+#endif

Annex/Concurrent.hs

@@ -0,0 +1,60 @@
+{- git-annex concurrent state
+ -
+ - Copyright 2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Concurrent where
+
+import Annex
+import Annex.Common
+import Annex.Action
+import qualified Annex.Queue
+
+import qualified Data.Map as M
+
+{- Allows forking off a thread that uses a copy of the current AnnexState
+ - to run an Annex action.
+ -
+ - The returned IO action can be used to start the thread.
+ - It returns an Annex action that must be run in the original 
+ - calling context to merge the forked AnnexState back into the
+ - current AnnexState.
+ -}
+forkState :: Annex a -> Annex (IO (Annex a))
+forkState a = do
+	st <- dupState
+	return $ do
+		(ret, newst) <- run st a
+		return $ do
+			mergeState newst
+			return ret
+
+{- Returns a copy of the current AnnexState that is safe to be
+ - used when forking off a thread. 
+ -
+ - After an Annex action is run using this AnnexState, it
+ - should be merged back into the current Annex's state,
+ - by calling mergeState.
+ -}
+dupState :: Annex AnnexState
+dupState = do
+	st <- Annex.getState id
+	-- avoid sharing eg, open file handles
+	return $ st
+		{ Annex.workers = []
+		, Annex.catfilehandles = M.empty
+		, Annex.checkattrhandle = Nothing
+		, Annex.checkignorehandle = Nothing
+		}
+
+{- Merges the passed AnnexState into the current Annex state.
+ - Also closes various handles in it. -}
+mergeState :: AnnexState -> Annex ()
+mergeState st = do
+	st' <- liftIO $ snd <$> run st stopCoProcesses
+	forM_ (M.toList $ Annex.cleanup st') $
+		uncurry addCleanup
+	Annex.Queue.mergeFrom st'
+	changeState $ \s -> s { errcounter = errcounter s + errcounter st' }

Annex/Content/Direct.hs

@@ -0,0 +1,181 @@
+{- git-annex file content managing for direct mode
+ -
+ - This is deprecated, and will be removed when direct mode gets removed
+ - from git-annex.
+ -
+ - Copyright 2012-2014 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Content.Direct (
+	associatedFiles,
+	associatedFilesRelative,
+	removeAssociatedFile,
+	removeAssociatedFileUnchecked,
+	removeAssociatedFiles,
+	addAssociatedFile,
+	goodContent,
+	recordedInodeCache,
+	updateInodeCache,
+	addInodeCache,
+	writeInodeCache,
+	compareInodeCaches,
+	sameInodeCache,
+	elemInodeCaches,
+	sameFileStatus,
+	removeInodeCache,
+	toInodeCache,
+	addContentWhenNotPresent,
+) where
+
+import Annex.Common
+import Annex.Perms
+import qualified Git
+import Logs.Location
+import Logs.File
+import Utility.InodeCache
+import Utility.CopyFile
+import Annex.ReplaceFile
+import Annex.Link
+import Annex.InodeSentinal
+
+{- Absolute FilePaths of Files in the tree that are associated with a key. -}
+associatedFiles :: Key -> Annex [FilePath]
+associatedFiles key = do
+	files <- associatedFilesRelative key
+	top <- fromRepo Git.repoPath
+	return $ map (top </>) files
+
+{- List of files in the tree that are associated with a key, relative to
+ - the top of the repo. -}
+associatedFilesRelative :: Key -> Annex [FilePath] 
+associatedFilesRelative key = do
+	mapping <- calcRepo $ gitAnnexMapping key
+	liftIO $ catchDefaultIO [] $ withFile mapping ReadMode $ \h ->
+		-- Read strictly to ensure the file is closed
+		-- before changeAssociatedFiles tries to write to it.
+		-- (Especially needed on Windows.)
+		lines <$> hGetContentsStrict h
+
+{- Changes the associated files information for a key, applying a
+ - transformation to the list. Returns new associatedFiles value. -}
+changeAssociatedFiles :: Key -> ([FilePath] -> [FilePath]) -> Annex [FilePath]
+changeAssociatedFiles key transform = do
+	mapping <- calcRepo $ gitAnnexMapping key
+	files <- associatedFilesRelative key
+	let files' = transform files
+	when (files /= files') $
+		modifyContent mapping $
+			writeLogFile mapping $ unlines files'
+	top <- fromRepo Git.repoPath
+	return $ map (top </>) files'
+
+{- Removes the list of associated files. -}
+removeAssociatedFiles :: Key -> Annex ()
+removeAssociatedFiles key = do
+	mapping <- calcRepo $ gitAnnexMapping key
+	modifyContent mapping $
+		liftIO $ nukeFile mapping
+
+{- Removes an associated file. Returns new associatedFiles value.
+ - Checks if this was the last copy of the object, and updates location
+ - log. -}
+removeAssociatedFile :: Key -> FilePath -> Annex [FilePath]
+removeAssociatedFile key file = do
+	fs <- removeAssociatedFileUnchecked key file
+	when (null fs) $
+		logStatus key InfoMissing
+	return fs
+
+{- Removes an associated file. Returns new associatedFiles value. -}
+removeAssociatedFileUnchecked :: Key -> FilePath -> Annex [FilePath]
+removeAssociatedFileUnchecked key file = do
+	file' <- normaliseAssociatedFile file
+	changeAssociatedFiles key $ filter (/= file')
+
+{- Adds an associated file. Returns new associatedFiles value. -}
+addAssociatedFile :: Key -> FilePath -> Annex [FilePath]
+addAssociatedFile key file = do
+	file' <- normaliseAssociatedFile file
+	changeAssociatedFiles key $ \files ->
+		if file' `elem` files
+			then files
+			else file':files
+
+{- Associated files are always stored relative to the top of the repository.
+ - The input FilePath is relative to the CWD, or is absolute. -}
+normaliseAssociatedFile :: FilePath -> Annex FilePath
+normaliseAssociatedFile file = do
+	top <- fromRepo Git.repoPath
+	liftIO $ relPathDirToFile top file
+
+{- Checks if a file in the tree, associated with a key, has not been modified.
+ -
+ - To avoid needing to fsck the file's content, which can involve an
+ - expensive checksum, this relies on a cache that contains the file's
+ - expected mtime and inode.
+ -}
+goodContent :: Key -> FilePath -> Annex Bool
+goodContent key file = sameInodeCache file =<< recordedInodeCache key
+
+{- Gets the recorded inode cache for a key. 
+ -
+ - A key can be associated with multiple files, so may return more than
+ - one. -}
+recordedInodeCache :: Key -> Annex [InodeCache]
+recordedInodeCache key = withInodeCacheFile key $ \f ->
+	liftIO $ catchDefaultIO [] $
+		mapMaybe readInodeCache . lines <$> readFileStrict f
+
+{- Caches an inode for a file.
+ -
+ - Anything else already cached is preserved.
+ -}
+updateInodeCache :: Key -> FilePath -> Annex ()
+updateInodeCache key file = maybe noop (addInodeCache key)
+	=<< withTSDelta (liftIO . genInodeCache file)
+
+{- Adds another inode to the cache for a key. -}
+addInodeCache :: Key -> InodeCache -> Annex ()
+addInodeCache key cache = do
+	oldcaches <- recordedInodeCache key
+	unlessM (elemInodeCaches cache oldcaches) $
+		writeInodeCache key (cache:oldcaches)
+
+{- Writes inode cache for a key. -}
+writeInodeCache :: Key -> [InodeCache] -> Annex ()
+writeInodeCache key caches = withInodeCacheFile key $ \f -> 
+	modifyContent f $
+		liftIO $ writeFile f $
+			unlines $ map showInodeCache caches
+
+{- Removes an inode cache. -}
+removeInodeCache :: Key -> Annex ()
+removeInodeCache key = withInodeCacheFile key $ \f ->
+	modifyContent f $
+		liftIO $ nukeFile f
+
+withInodeCacheFile :: Key -> (FilePath -> Annex a) -> Annex a
+withInodeCacheFile key a = a =<< calcRepo (gitAnnexInodeCache key)
+
+{- Checks if a FileStatus matches the recorded InodeCache of a file. -}
+sameFileStatus :: Key -> FilePath -> FileStatus -> Annex Bool
+sameFileStatus key f status = do
+	old <- recordedInodeCache key
+	curr <- withTSDelta $ \delta -> liftIO $ toInodeCache delta f status
+	case (old, curr) of
+		(_, Just c) -> elemInodeCaches c old
+		([], Nothing) -> return True
+		_ -> return False
+
+{- Copies the contentfile to the associated file, if the associated
+ - file has no content. If the associated file does have content,
+ - even if the content differs, it's left unchanged. -}
+addContentWhenNotPresent :: Key -> FilePath -> FilePath -> Annex ()
+addContentWhenNotPresent key contentfile associatedfile = do
+	v <- isAnnexLink associatedfile
+	when (Just key == v) $
+		replaceFile associatedfile $
+			liftIO . void . copyFileExternal CopyAllMetaData contentfile
+	updateInodeCache key associatedfile	

Annex/Difference.hs

@@ -0,0 +1,58 @@
+{- git-annex repository differences
+ -
+ - Copyright 2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Difference (
+	module Types.Difference,
+	setDifferences,
+) where
+
+import Annex.Common
+import Types.Difference
+import Logs.Difference
+import Config
+import Annex.UUID
+import Logs.UUID
+import Annex.Version
+import qualified Annex
+
+import qualified Data.Map as M
+
+-- Differences are only allowed to be tweaked when initializing a
+-- repository for the first time, and then only if there is not another
+-- known uuid. If the repository was cloned from elsewhere, it inherits
+-- the existing settings.
+--
+-- Must be called before setVersion, so it can check if this is the first
+-- time the repository is being initialized.
+setDifferences :: Annex ()
+setDifferences = do
+	u <- getUUID
+	otherds <- allDifferences <$> recordedDifferences
+	ds <- mappend otherds . annexDifferences <$> Annex.getGitConfig
+	when (ds /= mempty) $ do
+		ds' <- ifM (isJust <$> getVersion)
+			( do
+				oldds <- recordedDifferencesFor u
+				when (ds /= oldds) $
+					warning "Cannot change tunable parameters in already initialized repository."
+				return oldds
+			, if otherds == mempty
+				then ifM (any (/= u) . M.keys <$> uuidMap)
+					( do
+						warning "Cannot change tunable parameters in a clone of an existing repository."
+						return mempty
+					, return ds
+					)
+				else if otherds /= ds
+					then do
+						warning "The specified tunable parameters differ from values being used in other clones of this repository."
+						return otherds
+					else return ds
+			)
+		forM_ (listDifferences ds') $ \d ->
+			setConfig (ConfigKey $ differenceConfigKey d) (differenceConfigVal d)
+		recordDifferences ds' u

Annex/DirHashes.hs

@@ -0,0 +1,98 @@
+{- git-annex file locations
+ -
+ - Copyright 2010-2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.DirHashes (
+	Hasher,
+	HashLevels(..),
+	objectHashLevels,
+	branchHashLevels,
+	branchHashDir,
+	dirHashes,
+	hashDirMixed,
+	hashDirLower,
+	display_32bits_as_dir
+) where
+
+import Data.Bits
+import Data.Word
+import Data.Default
+import qualified Data.ByteArray
+
+import Common
+import Key
+import Types.GitConfig
+import Types.Difference
+import Utility.FileSystemEncoding
+import Utility.Hash
+
+type Hasher = Key -> FilePath
+
+-- Number of hash levels to use. 2 is the default.
+newtype HashLevels = HashLevels Int
+
+instance Default HashLevels where
+	def = HashLevels 2
+
+objectHashLevels :: GitConfig -> HashLevels
+objectHashLevels = configHashLevels OneLevelObjectHash
+
+branchHashLevels :: GitConfig -> HashLevels
+branchHashLevels = configHashLevels OneLevelBranchHash
+
+configHashLevels :: Difference -> GitConfig -> HashLevels
+configHashLevels d config
+	| hasDifference d (annexDifferences config) = HashLevels 1
+	| otherwise = def
+
+branchHashDir :: GitConfig -> Key -> String
+branchHashDir = hashDirLower . branchHashLevels
+
+{- Two different directory hashes may be used. The mixed case hash
+ - came first, and is fine, except for the problem of case-strict
+ - filesystems such as Linux VFAT (mounted with shortname=mixed),
+ - which do not allow using a directory "XX" when "xx" already exists.
+ - To support that, most repositories use the lower case hash for new data. -}
+dirHashes :: [HashLevels -> Hasher]
+dirHashes = [hashDirLower, hashDirMixed]
+
+hashDirs :: HashLevels -> Int -> String -> FilePath
+hashDirs (HashLevels 1) sz s = addTrailingPathSeparator $ take sz s
+hashDirs _ sz s = addTrailingPathSeparator $ take sz s </> drop sz s
+
+hashDirLower :: HashLevels -> Hasher
+hashDirLower n k = hashDirs n 3 $ take 6 $ show $ md5 $
+	encodeBS $ key2file $ nonChunkKey k
+
+{- This was originally using Data.Hash.MD5 from MissingH. This new version
+- is faster, but ugly as it has to replicate the 4 Word32's that produced. -}
+hashDirMixed :: HashLevels -> Hasher
+hashDirMixed n k = hashDirs n 2 $ take 4 $ concatMap display_32bits_as_dir $
+	encodeWord32 $ map fromIntegral $ Data.ByteArray.unpack $
+		Utility.Hash.md5 $ encodeBS $ key2file $ nonChunkKey k
+  where
+	encodeWord32 (b1:b2:b3:b4:rest) =
+		(shiftL b4 24 .|. shiftL b3 16 .|. shiftL b2 8 .|. b1)
+		: encodeWord32 rest
+	encodeWord32 _ = []
+
+{- modified version of display_32bits_as_hex from Data.Hash.MD5
+ - in MissingH
+ -   Copyright (C) 2001 Ian Lynagh 
+ -   License: Either BSD or GPL
+ -}
+display_32bits_as_dir :: Word32 -> String
+display_32bits_as_dir w = trim $ swap_pairs cs
+  where
+	-- Need 32 characters to use. To avoid inaverdently making
+	-- a real word, use letters that appear less frequently.
+	chars = ['0'..'9'] ++ "zqjxkmvwgpfZQJXKMVWGPF"
+	cs = map (\x -> getc $ (shiftR w (6*x)) .&. 31) [0..7]
+	getc n = chars !! fromIntegral n
+	swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs
+	swap_pairs _ = []
+	-- Last 2 will always be 00, so omit.
+	trim = take 6

Annex/Direct.hs

@@ -0,0 +1,480 @@
+{- git-annex direct mode
+ -
+ - This is deprecated, and will be removed when direct mode gets removed
+ - from git-annex.
+ -
+ - Copyright 2012-2014 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Direct where
+
+import Annex.Common
+import qualified Annex
+import qualified Git
+import qualified Git.LsFiles
+import qualified Git.Merge
+import qualified Git.DiffTree as DiffTree
+import qualified Git.Config
+import qualified Git.Ref
+import qualified Git.Branch
+import Git.Sha
+import Git.FilePath
+import Git.Types
+import Config
+import Annex.CatFile
+import qualified Annex.Queue
+import Logs.Location
+import Backend
+import Types.KeySource
+import Annex.Content
+import Annex.Content.Direct
+import Annex.Link
+import Utility.InodeCache
+import Utility.CopyFile
+import Annex.Perms
+import Annex.ReplaceFile
+import Annex.VariantFile
+import Git.Index
+import Annex.GitOverlay
+import Annex.LockFile
+import Annex.InodeSentinal
+
+{- Uses git ls-files to find files that need to be committed, and stages
+ - them into the index. Returns True if some changes were staged. -}
+stageDirect :: Annex Bool
+stageDirect = do
+	Annex.Queue.flush
+	top <- fromRepo Git.repoPath
+	(l, cleanup) <- inRepo $ Git.LsFiles.stagedOthersDetails [top]
+	forM_ l go
+	void $ liftIO cleanup
+	staged <- Annex.Queue.size
+	Annex.Queue.flush
+	return $ staged /= 0
+  where
+	{- Determine what kind of modified or deleted file this is, as
+	 - efficiently as we can, by getting any key that's associated
+	 - with it in git, as well as its stat info. -}
+	go (file, Just sha, Just _mode) = withTSDelta $ \delta -> do
+		shakey <- catKey sha
+		mstat <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file
+		mcache <- liftIO $ maybe (pure Nothing) (toInodeCache delta file) mstat
+		filekey <- isAnnexLink file
+		case (shakey, filekey, mstat, mcache) of
+			(_, Just key, _, _)
+				| shakey == filekey -> noop
+				{- A changed symlink. -}
+				| otherwise -> stageannexlink file key
+			(Just key, _, _, Just cache) -> do
+				{- All direct mode files will show as
+				 - modified, so compare the cache to see if
+				 - it really was. -}
+				oldcache <- recordedInodeCache key
+				case oldcache of
+					[] -> modifiedannexed file key cache
+					_ -> unlessM (elemInodeCaches cache oldcache) $
+						modifiedannexed file key cache
+			(Just key, _, Nothing, _) -> deletedannexed file key
+			(Nothing, _, Nothing, _) -> deletegit file
+			(_, _, Just _, _) -> addgit file
+	go _ = noop
+
+	modifiedannexed file oldkey cache = do
+		void $ removeAssociatedFile oldkey file
+		void $ addDirect file cache
+	
+	deletedannexed file key = do
+		void $ removeAssociatedFile key file
+		deletegit file
+	
+	stageannexlink file key = do
+		l <- calcRepo $ gitAnnexLink file key
+		stageSymlink file =<< hashSymlink l
+		void $ addAssociatedFile key file
+
+	addgit file = Annex.Queue.addCommand "add" [Param "-f"] [file]
+
+	deletegit file = Annex.Queue.addCommand "rm" [Param "-qf"] [file]
+
+{- Run before a commit to update direct mode bookeeping to reflect the
+ - staged changes being committed. -}
+preCommitDirect :: Annex Bool
+preCommitDirect = do
+	(diffs, clean) <- inRepo $ DiffTree.diffIndex Git.Ref.headRef
+	makeabs <- flip fromTopFilePath <$> gitRepo
+	forM_ diffs (go makeabs)
+	liftIO clean
+  where
+	go makeabs diff = do
+		withkey (DiffTree.srcsha diff) (DiffTree.srcmode diff) removeAssociatedFile
+		withkey (DiffTree.dstsha diff) (DiffTree.dstmode diff) addAssociatedFile
+	  where
+		withkey sha _mode a = when (sha /= nullSha) $
+			catKey sha >>= \case
+				Nothing -> noop
+				Just key -> void $ a key $
+					makeabs $ DiffTree.file diff
+
+{- Adds a file to the annex in direct mode. Can fail, if the file is
+ - modified or deleted while it's being added. -}
+addDirect :: FilePath -> InodeCache -> Annex Bool
+addDirect file cache = do
+	showStart "add" file
+	let source = KeySource
+		{ keyFilename = file
+		, contentLocation = file
+		, inodeCache = Just cache
+		}
+	got =<< genKey source =<< chooseBackend file
+  where
+	got Nothing = do
+		showEndFail
+		return False
+	got (Just (key, _)) = ifM (sameInodeCache file [cache])
+		( do
+			l <- calcRepo $ gitAnnexLink file key
+			stageSymlink file =<< hashSymlink l
+			addInodeCache key cache
+			void $ addAssociatedFile key file
+			logStatus key InfoPresent
+			showEndOk
+			return True
+		, do
+			showEndFail
+			return False
+		)
+
+{- In direct mode, git merge would usually refuse to do anything, since it
+ - sees present direct mode files as type changed files.
+ -
+ - So, to handle a merge, it's run with the work tree set to a temp
+ - directory, and the merge is staged into a copy of the index.
+ - Then the work tree is updated to reflect the merge, and
+ - finally, the merge is committed and the real index updated.
+ -
+ - A lock file is used to avoid races with any other caller of mergeDirect.
+ - 
+ - To avoid other git processes from making changes to the index while our
+ - merge is in progress, the index lock file is used as the temp index
+ - file. This is the same as what git does when updating the index
+ - normally.
+ -}
+mergeDirect :: Maybe Git.Ref -> Maybe Git.Ref -> Git.Branch -> Annex Bool -> [Git.Merge.MergeConfig] -> Git.Branch.CommitMode -> Annex Bool
+mergeDirect startbranch oldref branch resolvemerge mergeconfig commitmode = exclusively $ do
+	reali <- liftIO . absPath =<< fromRepo indexFile
+	tmpi <- liftIO . absPath =<< fromRepo indexFileLock
+	liftIO $ whenM (doesFileExist reali) $
+		copyFile reali tmpi
+
+	d <- fromRepo gitAnnexMergeDir
+	liftIO $ do
+		whenM (doesDirectoryExist d) $
+			removeDirectoryRecursive d
+		createDirectoryIfMissing True d
+
+	withIndexFile tmpi $ do
+		merged <- stageMerge d branch mergeconfig commitmode
+		ok <- if merged
+			then return True
+			else resolvemerge
+		if ok
+			then do
+				mergeDirectCleanup d (fromMaybe Git.Sha.emptyTree oldref)
+				mergeDirectCommit merged startbranch branch commitmode
+				liftIO $ whenM (doesFileExist tmpi) $
+					rename tmpi reali
+			else do
+				liftIO $ nukeFile tmpi
+		liftIO $ removeDirectoryRecursive d
+		return ok
+  where
+	exclusively = withExclusiveLock gitAnnexMergeLock
+
+{- Stage a merge into the index, avoiding changing HEAD or the current
+ - branch. -}
+stageMerge :: FilePath -> Git.Branch -> [Git.Merge.MergeConfig] -> Git.Branch.CommitMode -> Annex Bool
+stageMerge d branch mergeconfig commitmode = do
+	-- XXX A bug in git makes stageMerge unsafe to use if the git repo
+	-- is configured with core.symlinks=false
+	-- Using merge is not ideal though, since it will
+	-- update the current branch immediately, before the work tree
+	-- has been updated, which would leave things in an inconsistent
+	-- state if mergeDirectCleanup is interrupted.
+	-- <http://marc.info/?l=git&m=140262402204212&w=2>
+	merger <- ifM (coreSymlinks <$> Annex.getGitConfig)
+		( return $ \ref -> Git.Merge.stageMerge ref mergeconfig
+		, return $ \ref -> Git.Merge.merge ref mergeconfig commitmode
+		)
+	inRepo $ \g -> do
+		wd <- liftIO $ absPath d
+		gd <- liftIO $ absPath $ Git.localGitDir g
+		merger branch $ 
+			g { location = Local { gitdir = gd, worktree = Just (addTrailingPathSeparator wd) } }
+
+{- Commits after a direct mode merge is complete, and after the work
+ - tree has been updated by mergeDirectCleanup.
+ -}
+mergeDirectCommit :: Bool -> Maybe Git.Ref -> Git.Branch -> Git.Branch.CommitMode -> Annex ()
+mergeDirectCommit allowff old branch commitmode = do
+	void preCommitDirect
+	d <- fromRepo Git.localGitDir
+	let merge_head = d </> "MERGE_HEAD"
+	let merge_msg = d </> "MERGE_MSG"
+	let merge_mode = d </> "MERGE_MODE"
+	ifM (pure allowff <&&> canff)
+		( inRepo $ Git.Branch.update "merge" Git.Ref.headRef branch -- fast forward
+		, do
+			msg <- liftIO $
+				catchDefaultIO ("merge " ++ fromRef branch) $
+					readFile merge_msg
+			void $ inRepo $ Git.Branch.commit commitmode False msg
+				Git.Ref.headRef [Git.Ref.headRef, branch]
+		)
+	liftIO $ mapM_ nukeFile [merge_head, merge_msg, merge_mode]
+  where
+	canff = maybe (return False) (\o -> inRepo $ Git.Branch.fastForwardable o branch) old
+
+mergeDirectCleanup :: FilePath -> Git.Ref -> Annex ()
+mergeDirectCleanup d oldref = updateWorkTree d oldref False
+
+{- Updates the direct mode work tree to reflect the changes staged in the
+ - index by a git command, that was run in a temporary work tree.
+ -
+ - Uses diff-index to compare the staged changes with provided ref
+ - which should be the tree before the merge, and applies those
+ - changes to the work tree.
+ -
+ - There are really only two types of changes: An old item can be deleted,
+ - or a new item added. Two passes are made, first deleting and then
+ - adding. This is to handle cases where eg, a file is deleted and a
+ - directory is added. (The diff-tree output may list these in the opposite
+ - order, but we cannot add the directory until the file with the
+ - same name is removed.)
+ -}
+updateWorkTree :: FilePath -> Git.Ref -> Bool -> Annex ()
+updateWorkTree d oldref force = do
+	(items, cleanup) <- inRepo $ DiffTree.diffIndex oldref
+	makeabs <- flip fromTopFilePath <$> gitRepo
+	let fsitems = zip (map (makeabs . DiffTree.file) items) items
+	forM_ fsitems $
+		go makeabs DiffTree.srcsha moveout moveout_raw
+	forM_ fsitems $
+		go makeabs DiffTree.dstsha movein movein_raw
+	void $ liftIO cleanup
+  where
+	go makeabs getsha a araw (f, item)
+		| getsha item == nullSha = noop
+		| otherwise = void $
+			tryNonAsync . maybe (araw item makeabs f) (\k -> void $ a item makeabs k f)
+				=<< catKey (getsha item)
+
+	moveout _ _ = removeDirect
+
+	{- Files deleted by the merge are removed from the work tree.
+	 - Empty work tree directories are removed, per git behavior. -}
+	moveout_raw _ _ f = liftIO $ do
+		nukeFile f
+		void $ tryIO $ removeDirectory $ parentDir f
+	
+	{- If the file is already present, with the right content for the
+	 - key, it's left alone. 
+	 -
+	 - If the file is already present, and does not exist in the
+	 - oldref, preserve this local file.
+	 -
+	 - Otherwise, create the symlink and then if possible, replace it
+	 - with the content. -}
+	movein item makeabs k f = unlessM (goodContent k f) $ do
+		unless force $ preserveUnannexed item makeabs f oldref
+		l <- calcRepo $ gitAnnexLink f k
+		replaceFile f $ makeAnnexLink l
+		toDirect k f
+	
+	{- Any new, modified, or renamed files were written to the temp
+	 - directory by the merge, and are moved to the real work tree. -}
+	movein_raw item makeabs f = do
+		unless force $ preserveUnannexed item makeabs f oldref
+		liftIO $ do
+			createDirectoryIfMissing True $ parentDir f
+			void $ tryIO $ rename (d </> getTopFilePath (DiffTree.file item)) f
+
+{- If the file that's being moved in is already present in the work
+ - tree, but did not exist in the oldref, preserve this
+ - local, unannexed file (or directory), as "variant-local".
+ -
+ - It's also possible that the file that's being moved in
+ - is in a directory that collides with an exsting, non-annexed
+ - file (not a directory), which should be preserved.
+ -}
+preserveUnannexed :: DiffTree.DiffTreeItem -> (TopFilePath -> FilePath) -> FilePath -> Ref -> Annex ()
+preserveUnannexed item makeabs absf oldref = do
+	whenM (liftIO (collidingitem absf) <&&> unannexed absf) $
+		liftIO $ findnewname absf 0
+	checkdirs (DiffTree.file item)
+  where
+	checkdirs from = case upFrom (getTopFilePath from) of
+		Nothing -> noop
+		Just p -> do
+			let d = asTopFilePath p
+			let absd = makeabs d
+			whenM (liftIO (colliding_nondir absd) <&&> unannexed absd) $
+				liftIO $ findnewname absd 0
+			checkdirs d
+			
+	collidingitem f = isJust
+		<$> catchMaybeIO (getSymbolicLinkStatus f)
+	colliding_nondir f = maybe False (not . isDirectory)
+		<$> catchMaybeIO (getSymbolicLinkStatus f)
+
+	unannexed f = (isNothing <$> isAnnexLink f)
+		<&&> (isNothing <$> catFileDetails oldref f)
+
+	findnewname :: FilePath -> Int -> IO ()
+	findnewname f n = do
+		let localf = mkVariant f 
+			("local" ++ if n > 0 then show n else "")
+		ifM (collidingitem localf)
+			( findnewname f (n+1)
+			, rename f localf
+				`catchIO` const (findnewname f (n+1))
+			)
+
+{- If possible, converts a symlink in the working tree into a direct
+ - mode file. If the content is not available, leaves the symlink
+ - unchanged. -}
+toDirect :: Key -> FilePath -> Annex ()
+toDirect k f = fromMaybe noop =<< toDirectGen k f
+
+toDirectGen :: Key -> FilePath -> Annex (Maybe (Annex ()))
+toDirectGen k f = do
+	loc <- calcRepo $ gitAnnexLocation k
+	ifM (liftIO $ doesFileExist loc)
+		( return $ Just $ fromindirect loc
+		, do
+			{- Copy content from another direct file. -}
+			absf <- liftIO $ absPath f
+			dlocs <- filterM (goodContent k) =<<
+				filterM (\l -> isNothing <$> getAnnexLinkTarget l) =<<
+				(filter (/= absf) <$> addAssociatedFile k f)
+			case dlocs of
+				[] -> return Nothing
+				(dloc:_) -> return $ Just $ fromdirect dloc
+		)
+  where
+	fromindirect loc = do
+		{- Move content from annex to direct file. -}
+		updateInodeCache k loc
+		void $ addAssociatedFile k f
+		modifyContent loc $ do
+			thawContent loc
+			liftIO (replaceFileFrom loc f)
+				`catchIO` (\_ -> freezeContent loc)
+	fromdirect loc = do
+		replaceFile f $
+			liftIO . void . copyFileExternal CopyAllMetaData loc
+		updateInodeCache k f
+
+{- Removes a direct mode file, while retaining its content in the annex
+ - (unless its content has already been changed). -}
+removeDirect :: Key -> FilePath -> Annex ()
+removeDirect k f = do
+	void $ removeAssociatedFileUnchecked k f
+	unlessM (inAnnex k) $
+		-- If moveAnnex rejects the content of the key,
+		-- treat that the same as its content having changed.
+		ifM (goodContent k f)
+			( unlessM (moveAnnex k f) $
+				logStatus k InfoMissing
+			, logStatus k InfoMissing
+			)
+	liftIO $ do
+		nukeFile f
+		void $ tryIO $ removeDirectory $ parentDir f
+
+{- Called when a direct mode file has been changed. Its old content may be
+ - lost. -}
+changedDirect :: Key -> FilePath -> Annex ()
+changedDirect oldk f = do
+	locs <- removeAssociatedFile oldk f
+	whenM (pure (null locs) <&&> not <$> inAnnex oldk) $
+		logStatus oldk InfoMissing
+
+{- Git config settings to enable/disable direct mode. -}
+setDirect :: Bool -> Annex ()
+setDirect wantdirect = do
+	if wantdirect
+		then do
+			switchHEAD
+			setbare
+		else do
+			setbare
+			switchHEADBack
+	setConfig (annexConfig "direct") val
+	Annex.changeGitConfig $ \c -> c { annexDirect = wantdirect }
+  where
+	val = Git.Config.boolConfig wantdirect
+	coreworktree = ConfigKey "core.worktree"
+	indirectworktree = ConfigKey "core.indirect-worktree"
+	setbare = do
+		-- core.worktree is not compatable with
+		-- core.bare; git does not allow both to be set, so
+		-- unset it when enabling direct mode, caching in
+		-- core.indirect-worktree
+		if wantdirect
+			then moveconfig coreworktree indirectworktree
+			else moveconfig indirectworktree coreworktree
+		setConfig (ConfigKey Git.Config.coreBare) val
+	moveconfig src dest = getConfigMaybe src >>= \case
+		Nothing -> noop
+		Just wt -> do
+			unsetConfig src
+			setConfig dest wt
+			reloadConfig
+
+{- Since direct mode sets core.bare=true, incoming pushes could change
+ - the currently checked out branch. To avoid this problem, HEAD
+ - is changed to a internal ref that nothing is going to push to.
+ -
+ - For refs/heads/master, use refs/heads/annex/direct/master;
+ - this way things that show HEAD (eg shell prompts) will
+ - hopefully show just "master". -}
+directBranch :: Ref -> Ref
+directBranch orighead = case splitc '/' $ fromRef orighead of
+	("refs":"heads":"annex":"direct":_) -> orighead
+	("refs":"heads":rest) ->
+		Ref $ "refs/heads/annex/direct/" ++ intercalate "/" rest
+	_ -> Ref $ "refs/heads/" ++ fromRef (Git.Ref.base orighead)
+
+{- Converts a directBranch back to the original branch.
+ -
+ - Any other ref is left unchanged.
+ -}
+fromDirectBranch :: Ref -> Ref
+fromDirectBranch directhead = case splitc '/' $ fromRef directhead of
+	("refs":"heads":"annex":"direct":rest) -> 
+		Ref $ "refs/heads/" ++ intercalate "/" rest
+	_ -> directhead
+
+switchHEAD :: Annex ()
+switchHEAD = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
+  where
+	switch orighead = do
+		let newhead = directBranch orighead
+		maybe noop (inRepo . Git.Branch.update "entering direct mode" newhead)
+			=<< inRepo (Git.Ref.sha orighead)
+		inRepo $ Git.Branch.checkout newhead
+
+switchHEADBack :: Annex ()
+switchHEADBack = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
+  where
+	switch currhead = do
+		let orighead = fromDirectBranch currhead
+		inRepo (Git.Ref.sha currhead) >>= \case
+			Just headsha
+				| orighead /= currhead -> do
+					inRepo $ Git.Branch.update "leaving direct mode" orighead headsha
+					inRepo $ Git.Branch.checkout orighead
+					inRepo $ Git.Branch.delete currhead
+			_ -> inRepo $ Git.Branch.checkout orighead

Annex/Drop.hs

@@ -0,0 +1,130 @@
+{- dropping of unwanted content
+ -
+ - Copyright 2012-2014 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Drop where
+
+import Annex.Common
+import qualified Annex
+import Logs.Trust
+import Annex.NumCopies
+import Types.Remote (uuid)
+import qualified Remote
+import qualified Command.Drop
+import Command
+import Annex.Wanted
+import Config
+import Annex.Content.Direct
+import qualified Database.Keys
+import Git.FilePath
+
+import qualified Data.Set as S
+import System.Log.Logger (debugM)
+
+type Reason = String
+
+{- Drop a key from local and/or remote when allowed by the preferred content
+ - and numcopies settings.
+ -
+ - The UUIDs are ones where the content is believed to be present.
+ - The Remote list can include other remotes that do not have the content;
+ - only ones that match the UUIDs will be dropped from.
+ -
+ - If allowed to drop fromhere, that drop will be done last. This is done
+ - because local drops do not need any LockedCopy evidence, and so dropping
+ - from local last allows the content to be removed from more remotes.
+ -
+ - A VerifiedCopy can be provided as an optimisation when eg, a key
+ - has just been uploaded to a remote.
+ -
+ - In direct mode, all associated files are checked, and only if all
+ - of them are unwanted are they dropped.
+ -
+ - The runner is used to run commands, and so can be either callCommand
+ - or commandAction.
+ -}
+handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> [VerifiedCopy] -> (CommandStart -> CommandCleanup) -> Annex ()
+handleDropsFrom locs rs reason fromhere key afile preverified runner = do
+	l <- ifM isDirect
+		( associatedFilesRelative key
+		, do
+			g <- Annex.gitRepo
+			map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key
+		)
+	let fs = case afile of
+		AssociatedFile (Just f) -> nub (f : l)
+		AssociatedFile Nothing -> l
+	n <- getcopies fs
+	void $ if fromhere && checkcopies n Nothing
+		then go fs rs n >>= dropl fs
+		else go fs rs n
+  where
+	getcopies fs = do
+		(untrusted, have) <- trustPartition UnTrusted locs
+		numcopies <- if null fs
+			then getNumCopies
+			else maximum <$> mapM getFileNumCopies fs
+		return (NumCopies (length have), numcopies, S.fromList untrusted)
+
+	{- Check that we have enough copies still to drop the content.
+	 - When the remote being dropped from is untrusted, it was not
+	 - counted as a copy, so having only numcopies suffices. Otherwise,
+	 - we need more than numcopies to safely drop. -}
+	checkcopies (have, numcopies, _untrusted) Nothing = have > numcopies
+	checkcopies (have, numcopies, untrusted) (Just u)
+		| S.member u untrusted = have >= numcopies
+		| otherwise = have > numcopies
+	
+	decrcopies (have, numcopies, untrusted) Nothing =
+		(NumCopies (fromNumCopies have - 1), numcopies, untrusted)
+	decrcopies v@(_have, _numcopies, untrusted) (Just u)
+		| S.member u untrusted = v
+		| otherwise = decrcopies v Nothing
+
+	go _ [] n = pure n
+	go fs (r:rest) n
+		| uuid r `S.notMember` slocs = go fs rest n
+		| checkcopies n (Just $ Remote.uuid r) =
+			dropr fs r n >>= go fs rest
+		| otherwise = pure n
+
+	checkdrop fs n u a
+		| null fs = check $ -- no associated files; unused content
+			wantDrop True u (Just key) (AssociatedFile Nothing)
+		| otherwise = check $
+			allM (wantDrop True u (Just key) . AssociatedFile . Just) fs
+		where
+			check c = ifM c
+				( dodrop n u a
+				, return n
+				)
+
+	dodrop n@(have, numcopies, _untrusted) u a = 
+		ifM (safely $ runner $ a numcopies)
+			( do
+				liftIO $ debugM "drop" $ unwords
+					[ "dropped"
+					, case afile of
+						AssociatedFile Nothing -> key2file key
+						AssociatedFile (Just af) -> af
+					, "(from " ++ maybe "here" show u ++ ")"
+					, "(copies now " ++ show (fromNumCopies have - 1) ++ ")"
+					, ": " ++ reason
+					]
+				return $ decrcopies n u
+			, return n
+			)
+
+	dropl fs n = checkdrop fs n Nothing $ \numcopies ->
+		Command.Drop.startLocal afile (mkActionItem afile) numcopies key preverified
+
+	dropr fs r n  = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies ->
+		Command.Drop.startRemote afile (mkActionItem afile) numcopies key r
+
+	slocs = S.fromList locs
+	
+	safely a = either (const False) id <$> tryNonAsync a
+

Annex/Environment.hs

@@ -0,0 +1,58 @@
+{- git-annex environment
+ -
+ - Copyright 2012, 2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Environment where
+
+import Annex.Common
+import Utility.UserInfo
+import qualified Git.Config
+import Config
+import Utility.Env.Set
+
+{- Checks that the system's environment allows git to function.
+ - Git requires a GECOS username, or suitable git configuration, or
+ - environment variables.
+ -
+ - Git also requires the system have a hostname containing a dot.
+ - Otherwise, it tries various methods to find a FQDN, and will fail if it
+ - does not. To avoid replicating that code here, which would break if its
+ - methods change, this function does not check the hostname is valid.
+ - Instead, code that commits can use ensureCommit.
+ -}
+checkEnvironment :: Annex ()
+checkEnvironment = do
+	gitusername <- fromRepo $ Git.Config.getMaybe "user.name"
+	when (isNothing gitusername || gitusername == Just "") $
+		liftIO checkEnvironmentIO
+
+checkEnvironmentIO :: IO ()
+checkEnvironmentIO = whenM (isNothing <$> myUserGecos) $ do
+	username <- either (const "unknown") id <$> myUserName
+	ensureEnv "GIT_AUTHOR_NAME" username
+	ensureEnv "GIT_COMMITTER_NAME" username
+  where
+#ifndef __ANDROID__
+	-- existing environment is not overwritten
+	ensureEnv var val = setEnv var val False
+#else
+	-- Environment setting is broken on Android, so this is dealt with
+	-- in runshell instead.
+	ensureEnv _ _ = noop
+#endif
+
+{- Runs an action that commits to the repository, and if it fails, 
+ - sets user.email and user.name to a dummy value and tries the action again. -}
+ensureCommit :: Annex a -> Annex a
+ensureCommit a = either retry return =<< tryNonAsync a 
+  where
+	retry _ = do
+		name <- liftIO $ either (const "unknown") id <$> myUserName
+		setConfig (ConfigKey "user.name") name
+		setConfig (ConfigKey "user.email") name
+		a

Annex/Export.hs

@@ -0,0 +1,45 @@
+{- git-annex exports
+ -
+ - Copyright 2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Export where
+
+import Annex
+import Annex.CatFile
+import Types.Key
+import Types.Remote
+import qualified Git
+
+import qualified Data.Map as M
+import Control.Applicative
+import Prelude
+
+-- An export includes both annexed files and files stored in git.
+-- For the latter, a SHA1 key is synthesized.
+data ExportKey = AnnexKey Key | GitKey Key
+	deriving (Show, Eq, Ord)
+
+asKey :: ExportKey -> Key
+asKey (AnnexKey k) = k
+asKey (GitKey k) = k
+
+exportKey :: Git.Sha -> Annex ExportKey
+exportKey sha = mk <$> catKey sha
+  where
+	mk (Just k) = AnnexKey k
+	mk Nothing = GitKey $ Key
+		{ keyName = Git.fromRef sha
+		, keyVariety = SHA1Key (HasExt False)
+		, keySize = Nothing
+		, keyMtime = Nothing
+		, keyChunkSize = Nothing
+		, keyChunkNum = Nothing
+		}
+
+exportTree :: RemoteConfig -> Bool
+exportTree c = case M.lookup "exporttree" c of
+	Just "yes" -> True
+	_ -> False

Annex/FileMatcher.hs

@@ -0,0 +1,177 @@
+{- git-annex file matching
+ -
+ - Copyright 2012-2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.FileMatcher (
+	GetFileMatcher,
+	checkFileMatcher,
+	checkMatcher,
+	matchAll,
+	preferredContentParser,
+	parsedToMatcher,
+	mkLargeFilesParser,
+	largeFilesMatcher,
+) where
+
+import qualified Data.Map as M
+
+import Annex.Common
+import Limit
+import Utility.Matcher
+import Types.Group
+import qualified Annex
+import Types.FileMatcher
+import Git.FilePath
+import Types.Remote (RemoteConfig)
+import Annex.CheckAttr
+import Git.CheckAttr (unspecifiedAttr)
+
+#ifdef WITH_MAGICMIME
+import Magic
+import Utility.Env
+#endif
+
+import Data.Either
+import qualified Data.Set as S
+
+type GetFileMatcher = FilePath -> Annex (FileMatcher Annex)
+
+checkFileMatcher :: GetFileMatcher -> FilePath -> Annex Bool
+checkFileMatcher getmatcher file = do
+	matcher <- getmatcher file
+	checkMatcher matcher Nothing (AssociatedFile (Just file)) S.empty True
+
+checkMatcher :: FileMatcher Annex -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Bool -> Annex Bool
+checkMatcher matcher mkey afile notpresent d
+	| isEmpty matcher = return d
+	| otherwise = case (mkey, afile) of
+		(_, AssociatedFile (Just file)) -> go =<< fileMatchInfo file
+		(Just key, _) -> go (MatchingKey key)
+		_ -> return d
+  where
+	go mi = matchMrun matcher $ \a -> a notpresent mi
+
+fileMatchInfo :: FilePath -> Annex MatchInfo
+fileMatchInfo file = do
+	matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)
+	return $ MatchingFile FileInfo
+		{ matchFile = matchfile
+		, currFile = file
+		}
+
+matchAll :: FileMatcher Annex
+matchAll = generate []
+
+parsedToMatcher :: [ParseResult] -> Either String (FileMatcher Annex)
+parsedToMatcher parsed = case partitionEithers parsed of
+	([], vs) -> Right $ generate vs
+	(es, _) -> Left $ unwords $ map ("Parse failure: " ++) es
+
+data ParseToken
+	= SimpleToken String ParseResult
+	| ValueToken String (String -> ParseResult)
+
+type ParseResult = Either String (Token (MatchFiles Annex))
+
+parseToken :: [ParseToken] -> String -> ParseResult
+parseToken l t
+	| t `elem` tokens = Right $ token t
+	| otherwise = go l
+  where
+	go [] = Left $ "near " ++ show t
+	go (SimpleToken s r : _) | s == t = r
+	go (ValueToken s mkr : _) | s == k = mkr v
+	go (_ : ps) = go ps
+	(k, v) = separate (== '=') t
+
+commonTokens :: [ParseToken]
+commonTokens =
+	[ SimpleToken "unused" (simply limitUnused)
+	, SimpleToken "anything" (simply limitAnything)
+	, SimpleToken "nothing" (simply limitNothing)
+	, ValueToken "include" (usev limitInclude)
+	, ValueToken "exclude" (usev limitExclude)
+	, ValueToken "largerthan" (usev $ limitSize (>))
+	, ValueToken "smallerthan" (usev $ limitSize (<))
+	]
+
+{- This is really dumb tokenization; there's no support for quoted values.
+ - Open and close parens are always treated as standalone tokens;
+ - otherwise tokens must be separated by whitespace. -}
+tokenizeMatcher :: String -> [String]
+tokenizeMatcher = filter (not . null ) . concatMap splitparens . words
+  where
+	splitparens = segmentDelim (`elem` "()")
+
+preferredContentParser :: FileMatcher Annex -> FileMatcher Annex -> Annex GroupMap -> M.Map UUID RemoteConfig -> Maybe UUID -> String -> [ParseResult]
+preferredContentParser matchstandard matchgroupwanted getgroupmap configmap mu expr =
+	map parse $ tokenizeMatcher expr
+  where
+ 	parse = parseToken $
+		[ SimpleToken "standard" (call matchstandard)
+		, SimpleToken "groupwanted" (call matchgroupwanted)
+		, SimpleToken "present" (simply $ limitPresent mu)
+		, SimpleToken "inpreferreddir" (simply $ limitInDir preferreddir)
+		, SimpleToken "securehash" (simply limitSecureHash)
+		, ValueToken "copies" (usev limitCopies)
+		, ValueToken "lackingcopies" (usev $ limitLackingCopies False)
+		, ValueToken "approxlackingcopies" (usev $ limitLackingCopies True)
+		, ValueToken "inbacked" (usev limitInBackend)
+		, ValueToken "metadata" (usev limitMetaData)
+		, ValueToken "inallgroup" (usev $ limitInAllGroup getgroupmap)
+		] ++ commonTokens
+	preferreddir = fromMaybe "public" $
+		M.lookup "preferreddir" =<< (`M.lookup` configmap) =<< mu
+
+mkLargeFilesParser :: Annex (String -> [ParseResult])
+mkLargeFilesParser = do
+#ifdef WITH_MAGICMIME
+	magicmime <- liftIO $ catchMaybeIO $ do
+		m <- magicOpen [MagicMimeType]
+		liftIO $ getEnv "GIT_ANNEX_DIR" >>= \case
+			Nothing -> magicLoadDefault m
+			Just d -> magicLoad m
+				(d </> "magic" </> "magic.mgc")
+		return m
+#endif
+	let parse = parseToken $ commonTokens
+#ifdef WITH_MAGICMIME
+		++ [ ValueToken "mimetype" (usev $ matchMagic magicmime) ]
+#else
+		++ [ ValueToken "mimetype" (const $ Left "\"mimetype\" not supported; not built with MagicMime support") ]
+#endif
+	return $ map parse . tokenizeMatcher
+
+{- Generates a matcher for files large enough (or meeting other criteria)
+ - to be added to the annex, rather than directly to git. -}
+largeFilesMatcher :: Annex GetFileMatcher
+largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig
+  where
+	go (Just expr) = do
+		matcher <- mkmatcher expr
+		return $ const $ return matcher
+	go Nothing = return $ \file -> do
+		expr <- checkAttr "annex.largefiles" file
+		if null expr || expr == unspecifiedAttr
+			then return matchAll
+			else mkmatcher expr
+
+	mkmatcher expr = do
+		parser <- mkLargeFilesParser
+		either badexpr return $ parsedToMatcher $ parser expr
+	badexpr e = giveup $ "bad annex.largefiles configuration: " ++ e
+
+simply :: MatchFiles Annex -> ParseResult
+simply = Right . Operation
+
+usev :: MkLimit Annex -> String -> ParseResult
+usev a v = Operation <$> a v
+
+call :: FileMatcher Annex -> ParseResult
+call sub = Right $ Operation $ \notpresent mi ->
+	matchMrun sub $ \a -> a notpresent mi

Annex/Fixup.hs

@@ -0,0 +1,148 @@
+{- git-annex repository fixups
+ -
+ - Copyright 2013-2018 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Fixup where
+
+import Git.Types
+import Git.Config
+import Types.GitConfig
+import qualified Git.BuildVersion
+import Utility.Path
+import Utility.SafeCommand
+import Utility.Directory
+import Utility.Exception
+import Utility.Monad
+import Utility.PartialPrelude
+
+import System.IO
+import System.FilePath
+import System.PosixCompat.Files
+import Data.List
+import Control.Monad
+import Control.Monad.IfElse
+import qualified Data.Map as M
+import Control.Applicative
+import Prelude
+
+fixupRepo :: Repo -> GitConfig -> IO Repo
+fixupRepo r c = do
+	let r' = disableWildcardExpansion r
+	r'' <- fixupUnusualRepos r' c
+	if annexDirect c
+		then return (fixupDirect r'')
+		else return r''
+
+{- Disable git's built-in wildcard expansion, which is not wanted
+ - when using it as plumbing by git-annex. -}
+disableWildcardExpansion :: Repo -> Repo
+disableWildcardExpansion r
+	| Git.BuildVersion.older "1.8.1" = r
+	| otherwise = r
+		{ gitGlobalOpts = gitGlobalOpts r ++ [Param "--literal-pathspecs"] }
+
+{- Direct mode repos have core.bare=true, but are not really bare.
+ - Fix up the Repo to be a non-bare repo, and arrange for git commands
+ - run by git-annex to be passed parameters that override this setting. -}
+fixupDirect :: Repo -> Repo
+fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) }) = do
+	r
+		{ location = l { worktree = Just (parentDir d) }
+		, gitGlobalOpts = gitGlobalOpts r ++
+			[ Param "-c"
+			, Param $ coreBare ++ "=" ++ boolConfig False
+			]
+		}
+fixupDirect r = r
+
+{- Submodules have their gitdir containing ".git/modules/", and
+ - have core.worktree set, and also have a .git file in the top
+ - of the repo. We need to unset core.worktree, and change the .git
+ - file into a symlink to the git directory. This way, annex symlinks will be
+ - of the usual .git/annex/object form, and will consistently work
+ - whether a repo is used as a submodule or not, and wheverever the
+ - submodule is mounted.
+ -
+ - git-worktree directories have a .git file.
+ - That needs to be converted to a symlink, and .git/annex made a symlink
+ - to the main repository's git-annex directory.
+ - The worktree shares git config with the main repository, so the same
+ - annex uuid and other configuration will be used in the worktree as in
+ - the main repository.
+ -
+ - git clone or init with --separate-git-dir similarly makes a .git file,
+ - which in that case points to a different git directory. It's
+ - also converted to a symlink so links to .git/annex will work. 
+ - 
+ - When the filesystem doesn't support symlinks, we cannot make .git
+ - into a symlink. But we don't need too, since the repo will use direct
+ - mode.
+ -}
+fixupUnusualRepos :: Repo -> GitConfig -> IO Repo
+fixupUnusualRepos r@(Repo { location = l@(Local { worktree = Just w, gitdir = d }) }) c
+	| needsSubmoduleFixup r = do
+		when (coreSymlinks c) $
+			(replacedotgit >> unsetcoreworktree)
+				`catchNonAsync` \_e -> hPutStrLn stderr
+					"warning: unable to convert submodule to form that will work with git-annex"
+		return $ r'
+			{ config = M.delete "core.worktree" (config r)
+			}
+	| otherwise = ifM (needsGitLinkFixup r)
+		( do
+			when (coreSymlinks c) $
+				(replacedotgit >> worktreefixup)
+					`catchNonAsync` \_e -> hPutStrLn stderr
+						"warning: unable to convert .git file to symlink that will work with git-annex"
+			return r'
+		, return r
+		)
+  where
+	dotgit = w </> ".git"
+
+	replacedotgit = whenM (doesFileExist dotgit) $ do
+		linktarget <- relPathDirToFile w d
+		nukeFile dotgit
+		createSymbolicLink linktarget dotgit
+	
+	unsetcoreworktree =
+		maybe (error "unset core.worktree failed") (\_ -> return ())
+			=<< Git.Config.unset "core.worktree" r
+	
+	worktreefixup =
+		-- git-worktree sets up a "commondir" file that contains
+		-- the path to the main git directory.
+		-- Using --separate-git-dir does not.
+		catchDefaultIO Nothing (headMaybe . lines <$> readFile (d </> "commondir")) >>= \case
+			Just gd -> do
+				-- Make the worktree's git directory
+				-- contain an annex symlink to the main
+				-- repository's annex directory.
+				let linktarget = gd </> "annex"
+				createSymbolicLink linktarget (dotgit </> "annex")
+			Nothing -> return ()
+
+	-- Repo adjusted, so that symlinks to objects that get checked
+	-- in will have the usual path, rather than pointing off to the
+	-- real .git directory.
+	r'
+		| coreSymlinks c = r { location = l { gitdir = dotgit } }
+		| otherwise = r
+fixupUnusualRepos r _ = return r
+
+needsSubmoduleFixup :: Repo -> Bool
+needsSubmoduleFixup (Repo { location = (Local { worktree = Just _, gitdir = d }) }) =
+	(".git" </> "modules") `isInfixOf` d
+needsSubmoduleFixup _ = False
+
+needsGitLinkFixup :: Repo -> IO Bool
+needsGitLinkFixup (Repo { location = (Local { worktree = Just wt, gitdir = d }) })
+	-- Optimization: Avoid statting .git in the common case; only
+	-- when the gitdir is not in the usual place inside the worktree
+	-- might .git be a file.
+	| wt </> ".git" == d = return False
+	| otherwise = doesFileExist (wt </> ".git")
+needsGitLinkFixup _ = return False

Annex/GitOverlay.hs

@@ -0,0 +1,108 @@
+{- Temporarily changing the files git uses.
+ -
+ - Copyright 2014-2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.GitOverlay where
+
+import qualified Control.Exception as E
+
+import Annex.Common
+import Git
+import Git.Types
+import Git.Index
+import Git.Env
+import qualified Annex
+import qualified Annex.Queue
+
+{- Runs an action using a different git index file. -}
+withIndexFile :: FilePath -> Annex a -> Annex a
+withIndexFile f a = do
+	f' <- liftIO $ indexEnvVal f
+	withAltRepo
+		(usecachedgitenv $ \g -> liftIO $ addGitEnv g indexEnv f')
+		(\g g' -> g' { gitEnv = gitEnv g })
+		a
+  where
+	-- This is an optimisation. Since withIndexFile is run repeatedly,
+	-- and addGitEnv uses the slow copyGitEnv when gitEnv is Nothing, 
+	-- we cache the copied environment the first time, and reuse it in
+	-- subsequent calls.
+	--
+	-- (This could be done at another level; eg when creating the
+	-- Git object in the first place, but it's more efficient to let
+	-- the enviroment be inherited in all calls to git where it
+	-- does not need to be modified.)
+	usecachedgitenv m g = case gitEnv g of
+		Just _ -> m g
+		Nothing -> do
+			e <- Annex.withState $ \s -> case Annex.cachedgitenv s of
+				Nothing -> do
+					e <- copyGitEnv
+					return (s { Annex.cachedgitenv = Just e }, e)
+				Just e -> return (s, e)
+			m (g { gitEnv = Just e })
+
+{- Runs an action using a different git work tree.
+ -
+ - Smudge and clean filters are disabled in this work tree. -}
+withWorkTree :: FilePath -> Annex a -> Annex a
+withWorkTree d = withAltRepo
+	(\g -> return $ g { location = modlocation (location g), gitGlobalOpts = gitGlobalOpts g ++ disableSmudgeConfig })
+	(\g g' -> g' { location = location g, gitGlobalOpts = gitGlobalOpts g })
+  where
+	modlocation l@(Local {}) = l { worktree = Just d }
+	modlocation _ = error "withWorkTree of non-local git repo"
+	disableSmudgeConfig = map Param
+		[ "-c", "filter.annex.smudge="
+		, "-c", "filter.annex.clean="
+		]
+
+{- Runs an action with the git index file and HEAD, and a few other
+ - files that are related to the work tree coming from an overlay
+ - directory other than the usual. This is done by pointing
+ - GIT_COMMON_DIR at the regular git directory, and GIT_DIR at the
+ - overlay directory.
+ -
+ - Needs git 2.2.0 or newer.
+ -}
+withWorkTreeRelated :: FilePath -> Annex a -> Annex a
+withWorkTreeRelated d = withAltRepo modrepo unmodrepo
+  where
+	modrepo g = liftIO $ do
+		g' <- addGitEnv g "GIT_COMMON_DIR" =<< absPath (localGitDir g)
+		g'' <- addGitEnv g' "GIT_DIR" d
+		return (g'' { gitEnvOverridesGitDir = True })
+	unmodrepo g g' = g'
+		{ gitEnv = gitEnv g
+		, gitEnvOverridesGitDir = gitEnvOverridesGitDir g
+		}
+
+withAltRepo 
+	:: (Repo -> Annex Repo)
+	-- ^ modify Repo
+	-> (Repo -> Repo -> Repo)
+	-- ^ undo modifications; first Repo is the original and second
+	-- is the one after running the action.
+	-> Annex a
+	-> Annex a
+withAltRepo modrepo unmodrepo a = do
+	g <- gitRepo
+	g' <- modrepo g
+	q <- Annex.Queue.get
+	v <- tryNonAsync $ do
+		Annex.changeState $ \s -> s
+			{ Annex.repo = g'
+			-- Start a separate queue for any changes made
+			-- with the modified repo.
+			, Annex.repoqueue = Nothing
+			}
+		a
+	void $ tryNonAsync Annex.Queue.flush
+	Annex.changeState $ \s -> s
+		{ Annex.repo = unmodrepo g (Annex.repo s)
+		, Annex.repoqueue = Just q
+		}
+	either E.throw return v

Annex/HashObject.hs

@@ -0,0 +1,47 @@
+{- git hash-object interface, with handle automatically stored in the Annex monad
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.HashObject (
+	hashFile,
+	hashBlob,
+	hashObjectHandle,
+	hashObjectStop,
+) where
+
+import Annex.Common
+import qualified Git.HashObject
+import qualified Annex
+import Git.Types
+
+hashObjectHandle :: Annex Git.HashObject.HashObjectHandle
+hashObjectHandle = maybe startup return =<< Annex.getState Annex.hashobjecthandle
+  where
+	startup = do
+		h <- inRepo $ Git.HashObject.hashObjectStart
+		Annex.changeState $ \s -> s { Annex.hashobjecthandle = Just h }
+		return h
+
+hashObjectStop :: Annex ()
+hashObjectStop = maybe noop stop =<< Annex.getState Annex.hashobjecthandle
+  where
+	stop h = do
+		liftIO $ Git.HashObject.hashObjectStop h
+		Annex.changeState $ \s -> s { Annex.hashobjecthandle = Nothing }
+		return ()
+
+hashFile :: FilePath -> Annex Sha
+hashFile f = do
+	h <- hashObjectHandle
+	liftIO $ Git.HashObject.hashFile h f
+
+{- Note that the content will be written to a temp file.
+ - So it may be faster to use Git.HashObject.hashObject for large
+ - blob contents. -}
+hashBlob :: String -> Annex Sha
+hashBlob content = do
+	h <- hashObjectHandle
+	liftIO $ Git.HashObject.hashBlob h content

Annex/Hook.hs

@@ -0,0 +1,73 @@
+{- git-annex git hooks
+ -
+ - Note that it's important that the scripts installed by git-annex
+ - not change, otherwise removing old hooks using an old version of
+ - the script would fail.
+ -
+ - Copyright 2013-2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Hook where
+
+import Annex.Common
+import qualified Git.Hook as Git
+import Config
+import qualified Annex
+import Utility.Shell
+
+import qualified Data.Map as M
+
+preCommitHook :: Git.Hook
+preCommitHook = Git.Hook "pre-commit" (mkHookScript "git annex pre-commit .")
+
+postReceiveHook :: Git.Hook
+postReceiveHook = Git.Hook "post-receive" (mkHookScript "git annex post-receive")
+
+preCommitAnnexHook :: Git.Hook
+preCommitAnnexHook = Git.Hook "pre-commit-annex" ""
+
+postUpdateAnnexHook :: Git.Hook
+postUpdateAnnexHook = Git.Hook "post-update-annex" ""
+
+mkHookScript :: String -> String
+mkHookScript s = unlines
+	[ shebang_local
+	, "# automatically configured by git-annex"
+	, s
+	]
+
+hookWrite :: Git.Hook -> Annex ()
+hookWrite h = 
+	-- cannot have git hooks in a crippled filesystem (no execute bit)
+	unlessM crippledFileSystem $
+		unlessM (inRepo $ Git.hookWrite h) $
+			hookWarning h "already exists, not configuring"
+
+hookUnWrite :: Git.Hook -> Annex ()
+hookUnWrite h = unlessM (inRepo $ Git.hookUnWrite h) $
+	hookWarning h "contents modified; not deleting. Edit it to remove call to git annex."
+
+hookWarning :: Git.Hook -> String -> Annex ()
+hookWarning h msg = do
+	r <- gitRepo
+	warning $ Git.hookName h ++ " hook (" ++ Git.hookFile h r ++ ") " ++ msg
+
+{- Runs a hook. To avoid checking if the hook exists every time,
+ - the existing hooks are cached. -}
+runAnnexHook :: Git.Hook -> Annex ()
+runAnnexHook hook = do
+	m <- Annex.getState Annex.existinghooks
+	case M.lookup hook m of
+		Just True -> run
+		Just False -> noop
+		Nothing -> do
+			exists <- inRepo $ Git.hookExists hook
+			Annex.changeState $ \s -> s
+				{ Annex.existinghooks = M.insert hook exists m }
+			when exists run
+  where
+	run = unlessM (inRepo $ Git.runHook hook) $ do
+		h <- fromRepo $ Git.hookFile hook
+		warning $ h ++ " failed"

Annex/Ingest.hs

@@ -0,0 +1,391 @@
+{- git-annex content ingestion
+ -
+ - Copyright 2010-2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Ingest (
+	LockedDown(..),
+	LockDownConfig(..),
+	lockDown,
+	ingestAdd,
+	ingestAdd',
+	ingest,
+	ingest',
+	finishIngestDirect,
+	finishIngestUnlocked,
+	cleanOldKeys,
+	addLink,
+	makeLink,
+	addUnlocked,
+	restoreFile,
+	forceParams,
+	addAnnexedFile,
+) where
+
+import Annex.Common
+import Types.KeySource
+import Backend
+import Annex.Content
+import Annex.Content.Direct
+import Annex.Perms
+import Annex.Link
+import Annex.MetaData
+import Annex.Version
+import Logs.Location
+import qualified Annex
+import qualified Annex.Queue
+import qualified Database.Keys
+import qualified Git
+import qualified Git.Branch
+import Config
+import Utility.InodeCache
+import Annex.ReplaceFile
+import Utility.Tmp
+import Utility.CopyFile
+import Utility.Touch
+import Git.FilePath
+import Annex.InodeSentinal
+import Annex.AdjustedBranch
+
+import Control.Exception (IOException)
+
+data LockedDown = LockedDown
+	{ lockDownConfig :: LockDownConfig
+	, keySource :: KeySource
+	}
+	deriving (Show)
+
+data LockDownConfig = LockDownConfig
+	{ lockingFile :: Bool -- ^ write bit removed during lock down
+	, hardlinkFileTmp :: Bool -- ^ hard link to temp directory
+	}
+	deriving (Show)
+
+{- The file that's being ingested is locked down before a key is generated,
+ - to prevent it from being modified in between. This lock down is not
+ - perfect at best (and pretty weak at worst). For example, it does not
+ - guard against files that are already opened for write by another process.
+ - So, the InodeCache can be used to detect any changes that might be made
+ - to the file after it was locked down.
+ -
+ - When possible, the file is hard linked to a temp directory. This guards
+ - against some changes, like deletion or overwrite of the file, and
+ - allows lsof checks to be done more efficiently when adding a lot of files.
+ -
+ - Lockdown can fail if a file gets deleted, and Nothing will be returned.
+ -}
+lockDown :: LockDownConfig -> FilePath -> Annex (Maybe LockedDown)
+lockDown cfg file = either 
+		(\e -> warning (show e) >> return Nothing)
+		(return . Just)
+	=<< lockDown' cfg file
+
+lockDown' :: LockDownConfig -> FilePath -> Annex (Either IOException LockedDown)
+lockDown' cfg file = ifM (pure (not (hardlinkFileTmp cfg)) <||> crippledFileSystem)
+	( withTSDelta $ liftIO . tryIO . nohardlink
+	, tryIO $ do
+		tmp <- fromRepo gitAnnexTmpMiscDir
+		createAnnexDirectory tmp
+		when (lockingFile cfg) $
+			freezeContent file
+		withTSDelta $ \delta -> liftIO $ do
+			(tmpfile, h) <- openTempFile tmp $
+				relatedTemplate $ takeFileName file
+			hClose h
+			nukeFile tmpfile
+			withhardlink delta tmpfile `catchIO` const (nohardlink delta)
+	)
+  where
+	nohardlink delta = do
+		cache <- genInodeCache file delta
+		return $ LockedDown cfg $ KeySource
+			{ keyFilename = file
+			, contentLocation = file
+			, inodeCache = cache
+			}
+	withhardlink delta tmpfile = do
+		createLink file tmpfile
+		cache <- genInodeCache tmpfile delta
+		return $ LockedDown cfg $ KeySource
+			{ keyFilename = file
+			, contentLocation = tmpfile
+			, inodeCache = cache
+			}
+
+{- Ingests a locked down file into the annex. Updates the work tree and
+ - index. -}
+ingestAdd :: Maybe LockedDown -> Annex (Maybe Key)
+ingestAdd ld = ingestAdd' ld Nothing
+
+ingestAdd' :: Maybe LockedDown -> Maybe Key -> Annex (Maybe Key)
+ingestAdd' Nothing _ = return Nothing
+ingestAdd' ld@(Just (LockedDown cfg source)) mk = do
+	(mk', mic) <- ingest ld mk
+	case mk' of
+		Nothing -> return Nothing
+		Just k -> do
+			let f = keyFilename source
+			if lockingFile cfg
+				then addLink f k mic
+				else ifM isDirect
+					( do
+						l <- calcRepo $ gitAnnexLink f k
+						stageSymlink f =<< hashSymlink l
+					, do
+						mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus (contentLocation source)
+						stagePointerFile f mode =<< hashPointerFile k
+					)
+			return (Just k)
+
+{- Ingests a locked down file into the annex. Does not update the working
+ - tree or the index.
+ -}
+ingest :: Maybe LockedDown -> Maybe Key -> Annex (Maybe Key, Maybe InodeCache)
+ingest = ingest' Nothing
+
+ingest' :: Maybe Backend -> Maybe LockedDown -> Maybe Key -> Annex (Maybe Key, Maybe InodeCache)
+ingest' _ Nothing _ = return (Nothing, Nothing)
+ingest' preferredbackend (Just (LockedDown cfg source)) mk = withTSDelta $ \delta -> do
+	k <- case mk of
+		Nothing -> do
+			backend <- maybe (chooseBackend $ keyFilename source) (return . Just) preferredbackend
+			fmap fst <$> genKey source backend
+		Just k -> return (Just k)
+	let src = contentLocation source
+	ms <- liftIO $ catchMaybeIO $ getFileStatus src
+	mcache <- maybe (pure Nothing) (liftIO . toInodeCache delta src) ms
+	case (mcache, inodeCache source) of
+		(_, Nothing) -> go k mcache ms
+		(Just newc, Just c) | compareStrong c newc -> go k mcache ms
+		_ -> failure "changed while it was being added"
+  where
+	go (Just key) mcache (Just s)
+		| lockingFile cfg = golocked key mcache s
+		| otherwise = ifM isDirect
+			( godirect key mcache s
+			, gounlocked key mcache s
+			)
+	go _ _ _ = failure "failed to generate a key"
+
+	golocked key mcache s =
+		tryNonAsync (moveAnnex key $ contentLocation source) >>= \case
+			Right True -> do
+				populateAssociatedFiles key source
+				success key mcache s		
+			Right False -> giveup "failed to add content to annex"
+			Left e -> restoreFile (keyFilename source) key e
+
+	gounlocked key (Just cache) s = do
+		-- Remove temp directory hard link first because
+		-- linkToAnnex falls back to copying if a file
+		-- already has a hard link.
+		cleanCruft source
+		cleanOldKeys (keyFilename source) key
+		linkToAnnex key (keyFilename source) (Just cache) >>= \case
+			LinkAnnexFailed -> failure "failed to link to annex"
+			_ -> do
+				finishIngestUnlocked' key source
+				success key (Just cache) s
+	gounlocked _ _ _ = failure "failed statting file"
+
+	godirect key (Just cache) s = do
+		addInodeCache key cache
+		finishIngestDirect key source
+		success key (Just cache) s
+	godirect _ _ _ = failure "failed statting file"
+
+	success k mcache s = do
+		genMetaData k (keyFilename source) s
+		return (Just k, mcache)
+
+	failure msg = do
+		warning $ keyFilename source ++ " " ++ msg
+		cleanCruft source
+		return (Nothing, Nothing)
+
+finishIngestDirect :: Key -> KeySource -> Annex ()
+finishIngestDirect key source = do
+	void $ addAssociatedFile key $ keyFilename source
+	cleanCruft source
+
+	{- Copy to any other locations using the same key. -}
+	otherfs <- filter (/= keyFilename source) <$> associatedFiles key
+	forM_ otherfs $
+		addContentWhenNotPresent key (keyFilename source)
+
+finishIngestUnlocked :: Key -> KeySource -> Annex ()
+finishIngestUnlocked key source = do
+	cleanCruft source
+	finishIngestUnlocked' key source
+
+finishIngestUnlocked' :: Key -> KeySource -> Annex ()
+finishIngestUnlocked' key source = do
+	Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath (keyFilename source))
+	populateAssociatedFiles key source
+
+{- Copy to any other locations using the same key. -}
+populateAssociatedFiles :: Key -> KeySource -> Annex ()
+populateAssociatedFiles key source = do
+	obj <- calcRepo (gitAnnexLocation key)
+	g <- Annex.gitRepo
+	ingestedf <- flip fromTopFilePath g
+		<$> inRepo (toTopFilePath (keyFilename source))
+	afs <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key
+	forM_ (filter (/= ingestedf) afs) $
+		populatePointerFile key obj
+
+cleanCruft :: KeySource -> Annex ()
+cleanCruft source = when (contentLocation source /= keyFilename source) $
+	liftIO $ nukeFile $ contentLocation source
+
+-- If a worktree file was was hard linked to an annex object before,
+-- modifying the file would have caused the object to have the wrong
+-- content. Clean up from that.
+cleanOldKeys :: FilePath -> Key -> Annex ()
+cleanOldKeys file newkey = do
+	g <- Annex.gitRepo
+	ingestedf <- flip fromTopFilePath g <$> inRepo (toTopFilePath file)
+	topf <- inRepo (toTopFilePath file)
+	oldkeys <- filter (/= newkey)
+		<$> Database.Keys.getAssociatedKey topf
+	forM_ oldkeys $ \key ->
+		unlessM (isUnmodified key =<< calcRepo (gitAnnexLocation key)) $ do
+			caches <- Database.Keys.getInodeCaches key
+			unlinkAnnex key
+			fs <- filter (/= ingestedf)
+				. map (`fromTopFilePath` g)
+				<$> Database.Keys.getAssociatedFiles key
+			filterM (`sameInodeCache` caches) fs >>= \case
+				-- If linkToAnnex fails, the associated 
+				-- file with the content is still present,
+				-- so no need for any recovery.
+				(f:_) -> do
+					ic <- withTSDelta (liftIO . genInodeCache f)
+					void $ linkToAnnex key f ic
+				_ -> logStatus key InfoMissing
+
+{- On error, put the file back so it doesn't seem to have vanished.
+ - This can be called before or after the symlink is in place. -}
+restoreFile :: FilePath -> Key -> SomeException -> Annex a
+restoreFile file key e = do
+	whenM (inAnnex key) $ do
+		liftIO $ nukeFile file
+		-- The key could be used by other files too, so leave the
+		-- content in the annex, and make a copy back to the file.
+		obj <- calcRepo $ gitAnnexLocation key
+		unlessM (liftIO $ copyFileExternal CopyTimeStamps obj file) $
+			warning $ "Unable to restore content of " ++ file ++ "; it should be located in " ++ obj
+		thawContent file
+	throwM e
+
+{- Creates the symlink to the annexed content, returns the link target. -}
+makeLink :: FilePath -> Key -> Maybe InodeCache -> Annex String
+makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do
+	l <- calcRepo $ gitAnnexLink file key
+	replaceFile file $ makeAnnexLink l
+
+	-- touch symlink to have same time as the original file,
+	-- as provided in the InodeCache
+	case mcache of
+		Just c -> liftIO $ touch file (TimeSpec $ inodeCacheToMtime c) False
+		Nothing -> noop
+
+	return l
+
+{- Creates the symlink to the annexed content, and stages it in git.
+ -
+ - As long as the filesystem supports symlinks, we use
+ - git add, rather than directly staging the symlink to git.
+ - Using git add is best because it allows the queuing to work
+ - and is faster (staging the symlink runs hash-object commands each time).
+ - Also, using git add allows it to skip gitignored files, unless forced
+ - to include them.
+ -}
+addLink :: FilePath -> Key -> Maybe InodeCache -> Annex ()
+addLink file key mcache = ifM (coreSymlinks <$> Annex.getGitConfig)
+	( do
+		_ <- makeLink file key mcache
+		ps <- forceParams
+		Annex.Queue.addCommand "add" (ps++[Param "--"]) [file]
+	, do
+		l <- makeLink file key mcache
+		addAnnexLink l file
+	)
+
+{- Parameters to pass to git add, forcing addition of ignored files. -}
+forceParams :: Annex [CommandParam]
+forceParams = ifM (Annex.getState Annex.force)
+	( return [Param "-f"]
+	, return []
+	)
+
+{- Whether a file should be added unlocked or not. Default is to not,
+ - unless symlinks are not supported. annex.addunlocked can override that.
+ - Also, when in an adjusted unlocked branch, always add files unlocked.
+ -}
+addUnlocked :: Annex Bool
+addUnlocked = isDirect <||>
+	(versionSupportsUnlockedPointers <&&>
+	 ((not . coreSymlinks <$> Annex.getGitConfig) <||>
+	  (annexAddUnlocked <$> Annex.getGitConfig) <||>
+	  (maybe False (\b -> getAdjustment b == Just UnlockAdjustment) <$> cachedCurrentBranch)
+	 )
+	)
+
+cachedCurrentBranch :: Annex (Maybe Git.Branch)
+cachedCurrentBranch = maybe cache (return . Just)
+	=<< Annex.getState Annex.cachedcurrentbranch
+  where
+	cache :: Annex (Maybe Git.Branch)
+	cache = inRepo Git.Branch.currentUnsafe >>= \case
+		Nothing -> return Nothing
+		Just b -> do
+			Annex.changeState $ \s ->
+				s { Annex.cachedcurrentbranch = Just b }
+			return (Just b)
+
+{- Adds a file to the work tree for the key, and stages it in the index.
+ - The content of the key may be provided in a temp file, which will be
+ - moved into place.
+ -
+ - When the content of the key is not accepted into the annex, returns False.
+ -}
+addAnnexedFile :: FilePath -> Key -> Maybe FilePath -> Annex Bool
+addAnnexedFile file key mtmp = ifM (addUnlocked <&&> not <$> isDirect)
+	( do
+		mode <- maybe
+			(pure Nothing)
+			(\tmp -> liftIO $ catchMaybeIO $ fileMode <$> getFileStatus tmp)
+			mtmp
+		stagePointerFile file mode =<< hashPointerFile key
+		Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)
+		case mtmp of
+			Just tmp -> ifM (moveAnnex key tmp)
+				( linkunlocked mode >> return True
+				, writepointer mode >> return False
+				)
+			Nothing -> ifM (inAnnex key)
+				( linkunlocked mode >> return True
+				, writepointer mode >> return True
+				)
+	, do
+		addLink file key Nothing
+		whenM isDirect $ do
+			void $ addAssociatedFile key file
+		case mtmp of
+			Just tmp -> do
+				{- For moveAnnex to work in direct mode, the
+				 - symlink must already exist, so flush the queue. -}
+				whenM isDirect $
+					Annex.Queue.flush
+				moveAnnex key tmp
+			Nothing -> return True
+	)
+  where
+	linkunlocked mode = linkFromAnnex key file mode >>= \case
+		LinkAnnexFailed -> liftIO $
+			writePointerFile file key mode
+		_ -> return ()
+	writepointer mode = liftIO $ writePointerFile file key mode

Annex/Init.hs

@@ -0,0 +1,295 @@
+{- git-annex repository initialization
+ -
+ - Copyright 2011-2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Init (
+	AutoInit(..),
+	ensureInitialized,
+	isInitialized,
+	initialize,
+	initialize',
+	uninitialize,
+	probeCrippledFileSystem,
+	probeCrippledFileSystem',
+) where
+
+import Annex.Common
+import qualified Annex
+import qualified Git
+import qualified Git.LsFiles
+import qualified Git.Config
+import qualified Git.Objects
+import qualified Annex.Branch
+import Logs.UUID
+import Logs.Trust.Basic
+import Logs.Config
+import Types.TrustLevel
+import Annex.Version
+import Annex.Difference
+import Annex.UUID
+import Annex.Link
+import Annex.WorkTree
+import Config
+import Annex.Direct
+import Annex.AdjustedBranch
+import Annex.Environment
+import Annex.Hook
+import Annex.InodeSentinal
+import Upgrade
+import Annex.Perms
+import Utility.UserInfo
+#ifndef mingw32_HOST_OS
+import Utility.FileMode
+import System.Posix.User
+import qualified Utility.LockFile.Posix as Posix
+#endif
+
+newtype AutoInit = AutoInit Bool
+
+checkCanInitialize :: AutoInit -> Annex a -> Annex a
+checkCanInitialize (AutoInit True) a = a
+checkCanInitialize (AutoInit False) a = fromRepo Git.repoWorkTree >>= \case
+	Nothing -> a
+	Just wt -> liftIO (catchMaybeIO (readFile (wt </> ".noannex"))) >>= \case
+		Nothing -> a
+		Just noannexmsg -> ifM (Annex.getState Annex.force)
+			( a
+			, do
+				warning "Initialization prevented by .noannex file (use --force to override)"
+				unless (null noannexmsg) $
+					warning noannexmsg
+				giveup "Not initialized."
+			)
+
+genDescription :: Maybe String -> Annex String
+genDescription (Just d) = return d
+genDescription Nothing = do
+	reldir <- liftIO . relHome =<< liftIO . absPath =<< fromRepo Git.repoPath
+	hostname <- fromMaybe "" <$> liftIO getHostname
+	let at = if null hostname then "" else "@"
+	v <- liftIO myUserName
+	return $ concat $ case v of
+		Right username -> [username, at, hostname, ":", reldir]
+		Left _ -> [hostname, ":", reldir]
+
+initialize :: AutoInit -> Maybe String -> Maybe Version -> Annex ()
+initialize ai mdescription mversion = checkCanInitialize ai $ do
+	{- Has to come before any commits are made as the shared
+	 - clone heuristic expects no local objects. -}
+	sharedclone <- checkSharedClone
+
+	{- This will make the first commit to git, so ensure git is set up
+	 - properly to allow commits when running it. -}
+	ensureCommit $ Annex.Branch.create
+
+	prepUUID
+	initialize' (AutoInit True) mversion
+	
+	initSharedClone sharedclone
+
+	u <- getUUID
+	describeUUID u =<< genDescription mdescription
+
+-- Everything except for uuid setup, shared clone setup, and initial
+-- description.
+initialize' :: AutoInit -> Maybe Version -> Annex ()
+initialize' ai mversion = checkCanInitialize ai $ do
+	checkLockSupport
+	checkFifoSupport
+	checkCrippledFileSystem
+	unlessM isBareRepo $ do
+		hookWrite preCommitHook
+		hookWrite postReceiveHook
+	setDifferences
+	unlessM (isJust <$> getVersion) $
+		setVersion (fromMaybe defaultVersion mversion)
+	whenM versionSupportsUnlockedPointers $ do
+		configureSmudgeFilter
+		scanUnlockedFiles
+	checkAdjustedClone >>= \case
+		NeedUpgradeForAdjustedClone -> 
+			void $ upgrade True  versionForAdjustedClone
+		InAdjustedClone -> return ()
+		NotInAdjustedClone ->
+			ifM (crippledFileSystem <&&> (not <$> isBareRepo))
+				( ifM versionSupportsUnlockedPointers
+					( adjustToCrippledFileSystem
+					, do
+						enableDirectMode
+						setDirect True
+					)
+				-- Handle case where this repo was cloned from a
+				-- direct mode repo
+				, unlessM isBareRepo
+					switchHEADBack
+				)
+	propigateSecureHashesOnly
+	createInodeSentinalFile False
+
+uninitialize :: Annex ()
+uninitialize = do
+	hookUnWrite preCommitHook
+	hookUnWrite postReceiveHook
+	removeRepoUUID
+	removeVersion
+
+{- Will automatically initialize if there is already a git-annex
+ - branch from somewhere. Otherwise, require a manual init
+ - to avoid git-annex accidentally being run in git
+ - repos that did not intend to use it.
+ -
+ - Checks repository version and handles upgrades too.
+ -}
+ensureInitialized :: Annex ()
+ensureInitialized = getVersion >>= maybe needsinit checkUpgrade
+  where
+	needsinit = ifM Annex.Branch.hasSibling
+			( initialize (AutoInit True) Nothing Nothing
+			, giveup "First run: git-annex init"
+			)
+
+{- Checks if a repository is initialized. Does not check version for ugrade. -}
+isInitialized :: Annex Bool
+isInitialized = maybe Annex.Branch.hasSibling (const $ return True) =<< getVersion
+
+{- A crippled filesystem is one that does not allow making symlinks,
+ - or removing write access from files. -}
+probeCrippledFileSystem :: Annex Bool
+probeCrippledFileSystem = do
+	tmp <- fromRepo gitAnnexTmpMiscDir
+	createAnnexDirectory tmp
+	(r, warnings) <- liftIO $ probeCrippledFileSystem' tmp
+	mapM_ warning warnings
+	return r
+
+probeCrippledFileSystem' :: FilePath -> IO (Bool, [String])
+#ifdef mingw32_HOST_OS
+probeCrippledFileSystem' _ = return (True, [])
+#else
+probeCrippledFileSystem' tmp = do
+	let f = tmp </> "gaprobe"
+	writeFile f ""
+	r <- probe f
+	void $ tryIO $ allowWrite f
+	removeFile f
+	return r
+  where
+	probe f = catchDefaultIO (True, []) $ do
+		let f2 = f ++ "2"
+		nukeFile f2
+		createSymbolicLink f f2
+		nukeFile f2
+		preventWrite f
+		-- Should be unable to write to the file, unless
+		-- running as root, but some crippled
+		-- filesystems ignore write bit removals.
+		ifM ((== 0) <$> getRealUserID)
+			( return (False, [])
+			, do
+				r <- catchBoolIO $ do
+					writeFile f "2"
+					return True
+				if r
+					then return (True, ["Filesystem allows writing to files whose write bit is not set."])
+					else return (False, [])
+			)
+#endif
+
+checkCrippledFileSystem :: Annex ()
+checkCrippledFileSystem = whenM probeCrippledFileSystem $ do
+	warning "Detected a crippled filesystem."
+	setCrippledFileSystem True
+
+	{- Normally git disables core.symlinks itself when the
+	 - filesystem does not support them. But, even if symlinks are
+	 - supported, we don't use them by default in a crippled
+	 - filesystem. -}
+	whenM (coreSymlinks <$> Annex.getGitConfig) $ do
+		warning "Disabling core.symlinks."
+		setConfig (ConfigKey "core.symlinks")
+			(Git.Config.boolConfig False)
+
+probeLockSupport :: Annex Bool
+probeLockSupport = do
+#ifdef mingw32_HOST_OS
+	return True
+#else
+	tmp <- fromRepo gitAnnexTmpMiscDir
+	let f = tmp </> "lockprobe"
+	createAnnexDirectory tmp
+	mode <- annexFileMode
+	liftIO $ do
+		nukeFile f
+		ok <- catchBoolIO $ do
+			Posix.dropLock =<< Posix.lockExclusive (Just mode) f
+			return True
+		nukeFile f
+		return ok
+#endif
+
+probeFifoSupport :: Annex Bool
+probeFifoSupport = do
+#ifdef mingw32_HOST_OS
+	return False
+#else
+	tmp <- fromRepo gitAnnexTmpMiscDir
+	let f = tmp </> "gaprobe"
+	let f2 = tmp </> "gaprobe2"
+	createAnnexDirectory tmp
+	liftIO $ do
+		nukeFile f
+		nukeFile f2
+		ms <- tryIO $ do
+			createNamedPipe f ownerReadMode
+			createLink f f2
+			getFileStatus f
+		nukeFile f
+		nukeFile f2
+		return $ either (const False) isNamedPipe ms
+#endif
+
+checkLockSupport :: Annex ()
+checkLockSupport = unlessM probeLockSupport $ do
+	warning "Detected a filesystem without POSIX fcntl lock support."
+	warning "Enabling annex.pidlock."
+	setConfig (annexConfig "pidlock") (Git.Config.boolConfig True)
+
+checkFifoSupport :: Annex ()
+checkFifoSupport = unlessM probeFifoSupport $ do
+	warning "Detected a filesystem without fifo support."
+	warning "Disabling ssh connection caching."
+	setConfig (annexConfig "sshcaching") (Git.Config.boolConfig False)
+
+enableDirectMode :: Annex ()
+enableDirectMode = unlessM isDirect $ do
+	warning "Enabling direct mode."
+	top <- fromRepo Git.repoPath
+	(l, clean) <- inRepo $ Git.LsFiles.inRepo [top]
+	forM_ l $ \f ->
+		maybe noop (`toDirect` f) =<< isAnnexLink f
+	void $ liftIO clean
+
+checkSharedClone :: Annex Bool
+checkSharedClone = inRepo Git.Objects.isSharedClone
+
+initSharedClone :: Bool -> Annex ()
+initSharedClone False = return ()
+initSharedClone True = do
+	showLongNote "Repository was cloned with --shared; setting annex.hardlink=true and making repository untrusted."
+	u <- getUUID
+	trustSet u UnTrusted
+	setConfig (annexConfig "hardlink") (Git.Config.boolConfig True)
+
+{- Propigate annex.securehashesonly from then global config to local
+ - config. This makes a clone inherit a parent's setting, but once
+ - a repository has a local setting, changes to the global config won't
+ - affect it. -}
+propigateSecureHashesOnly :: Annex ()
+propigateSecureHashesOnly =
+	maybe noop (setConfig (ConfigKey "annex.securehashesonly"))
+		=<< getGlobalConfig "annex.securehashesonly"

Annex/InodeSentinal.hs

@@ -0,0 +1,96 @@
+{- git-annex inode sentinal file
+ -
+ - Copyright 2012-2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.InodeSentinal where
+
+import Annex.Common
+import qualified Annex
+import Utility.InodeCache
+import Annex.Perms
+
+{- If the sendinal shows the inodes have changed, only the size and mtime
+ - are compared. -}
+compareInodeCaches :: InodeCache -> InodeCache -> Annex Bool
+compareInodeCaches x y
+	| compareStrong x y = return True
+	| otherwise = ifM inodesChanged
+		( return $ compareWeak x y
+		, return False
+		)
+
+compareInodeCachesWith :: Annex InodeComparisonType
+compareInodeCachesWith = ifM inodesChanged ( return Weakly, return Strongly )
+
+{- Checks if one of the provided old InodeCache matches the current
+ - version of a file. -}
+sameInodeCache :: FilePath -> [InodeCache] -> Annex Bool
+sameInodeCache _ [] = return False
+sameInodeCache file old = go =<< withTSDelta (liftIO . genInodeCache file)
+  where
+	go Nothing = return False
+	go (Just curr) = elemInodeCaches curr old
+
+elemInodeCaches :: InodeCache -> [InodeCache] -> Annex Bool
+elemInodeCaches _ [] = return False
+elemInodeCaches c (l:ls) = ifM (compareInodeCaches c l)
+	( return True
+	, elemInodeCaches c ls
+	)
+
+{- Some filesystems get new inodes each time they are mounted.
+ - In order to work on such a filesystem, a sentinal file is used to detect
+ - when the inodes have changed.
+ -
+ - If the sentinal file does not exist, we have to assume that the
+ - inodes have changed.
+ -}
+inodesChanged :: Annex Bool
+inodesChanged = sentinalInodesChanged <$> sentinalStatus
+
+withTSDelta :: (TSDelta -> Annex a) -> Annex a
+withTSDelta a = a =<< getTSDelta
+
+getTSDelta :: Annex TSDelta
+#ifdef mingw32_HOST_OS
+getTSDelta = sentinalTSDelta <$> sentinalStatus
+#else
+getTSDelta = pure noTSDelta -- optimisation
+#endif
+
+sentinalStatus :: Annex SentinalStatus
+sentinalStatus = maybe check return =<< Annex.getState Annex.sentinalstatus
+  where
+	check = do
+		sc <- liftIO . checkSentinalFile =<< annexSentinalFile
+		Annex.changeState $ \s -> s { Annex.sentinalstatus = Just sc }
+		return sc
+
+{- The sentinal file is only created when first initializing a repository.
+ - If there are any annexed objects in the repository already, creating
+ - the file would invalidate their inode caches. -}
+createInodeSentinalFile :: Bool -> Annex ()
+createInodeSentinalFile evenwithobjects = 
+	unlessM (alreadyexists <||> hasobjects) $ do
+		s <- annexSentinalFile
+		createAnnexDirectory (parentDir (sentinalFile s))
+		liftIO $ writeSentinalFile s
+  where
+	alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile
+	hasobjects
+		| evenwithobjects = pure False
+		| otherwise = liftIO . doesDirectoryExist =<< fromRepo gitAnnexObjectDir
+
+annexSentinalFile :: Annex SentinalFile
+annexSentinalFile = do
+	sentinalfile <- fromRepo gitAnnexInodeSentinal
+	sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache
+	return SentinalFile
+		{ sentinalFile = sentinalfile
+		, sentinalCacheFile = sentinalcachefile
+		}

Annex/Journal.hs

@@ -0,0 +1,109 @@
+{- management of the git-annex journal
+ -
+ - The journal is used to queue up changes before they are committed to the
+ - git-annex branch. Among other things, it ensures that if git-annex is
+ - interrupted, its recorded data is not lost.
+ -
+ - Copyright 2011-2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Journal where
+
+import Annex.Common
+import qualified Git
+import Annex.Perms
+import Annex.LockFile
+import Utility.Directory.Stream
+
+{- Records content for a file in the branch to the journal.
+ -
+ - Using the journal, rather than immediatly staging content to the index
+ - avoids git needing to rewrite the index after every change.
+ - 
+ - The file in the journal is updated atomically, which allows
+ - getJournalFileStale to always return a consistent journal file
+ - content, although possibly not the most current one.
+ -}
+setJournalFile :: JournalLocked -> FilePath -> String -> Annex ()
+setJournalFile _jl file content = do
+	tmp <- fromRepo gitAnnexTmpMiscDir
+	createAnnexDirectory =<< fromRepo gitAnnexJournalDir
+	createAnnexDirectory tmp
+	-- journal file is written atomically
+	jfile <- fromRepo $ journalFile file
+	let tmpfile = tmp </> takeFileName jfile
+	liftIO $ do
+		withFile tmpfile WriteMode $ \h -> do
+#ifdef mingw32_HOST_OS
+			hSetNewlineMode h noNewlineTranslation
+#endif
+			hPutStr h content
+		moveFile tmpfile jfile
+
+{- Gets any journalled content for a file in the branch. -}
+getJournalFile :: JournalLocked -> FilePath -> Annex (Maybe String)
+getJournalFile _jl = getJournalFileStale
+
+{- Without locking, this is not guaranteed to be the most recent
+ - version of the file in the journal, so should not be used as a basis for
+ - changes. -}
+getJournalFileStale :: FilePath -> Annex (Maybe String)
+getJournalFileStale file = inRepo $ \g -> catchMaybeIO $
+	readFileStrict $ journalFile file g
+
+{- List of existing journal files, but without locking, may miss new ones
+ - just being added, or may have false positives if the journal is staged
+ - as it is run. -}
+getJournalledFilesStale :: Annex [FilePath]
+getJournalledFilesStale = do
+	g <- gitRepo
+	fs <- liftIO $ catchDefaultIO [] $
+		getDirectoryContents $ gitAnnexJournalDir g
+	return $ filter (`notElem` [".", ".."]) $ map fileJournal fs
+
+withJournalHandle :: (DirectoryHandle -> IO a) -> Annex a
+withJournalHandle a = do
+	d <- fromRepo gitAnnexJournalDir
+	bracketIO (openDirectory d) closeDirectory (liftIO . a)
+
+{- Checks if there are changes in the journal. -}
+journalDirty :: Annex Bool
+journalDirty = do
+	d <- fromRepo gitAnnexJournalDir
+	liftIO $ 
+		(not <$> isDirectoryEmpty d)
+			`catchIO` (const $ doesDirectoryExist d)
+
+{- Produces a filename to use in the journal for a file on the branch.
+ -
+ - The journal typically won't have a lot of files in it, so the hashing
+ - used in the branch is not necessary, and all the files are put directly
+ - in the journal directory.
+ -}
+journalFile :: FilePath -> Git.Repo -> FilePath
+journalFile file repo = gitAnnexJournalDir repo </> concatMap mangle file
+  where
+	mangle c
+		| c == pathSeparator = "_"
+		| c == '_' = "__"
+		| otherwise = [c]
+
+{- Converts a journal file (relative to the journal dir) back to the
+ - filename on the branch. -}
+fileJournal :: FilePath -> FilePath
+fileJournal = replace [pathSeparator, pathSeparator] "_" .
+	replace "_" [pathSeparator]
+
+{- Sentinal value, only produced by lockJournal; required
+ - as a parameter by things that need to ensure the journal is
+ - locked. -}
+data JournalLocked = ProduceJournalLocked
+
+{- Runs an action that modifies the journal, using locking to avoid
+ - contention with other git-annex processes. -}
+lockJournal :: (JournalLocked -> Annex a) -> Annex a
+lockJournal a = withExclusiveLock gitAnnexJournalLock $ a ProduceJournalLocked

Annex/Link.hs

@@ -0,0 +1,191 @@
+{- git-annex links to content
+ -
+ - On file systems that support them, symlinks are used.
+ -
+ - On other filesystems, git instead stores the symlink target in a regular
+ - file.
+ -
+ - Pointer files are used instead of symlinks for unlocked files.
+ -
+ - Copyright 2013-2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP, BangPatterns #-}
+
+module Annex.Link where
+
+import Annex.Common
+import qualified Annex
+import qualified Git.UpdateIndex
+import qualified Annex.Queue
+import Git.Types
+import Git.FilePath
+import Annex.HashObject
+import Utility.FileMode
+import Utility.FileSystemEncoding
+
+import qualified Data.ByteString.Lazy as L
+
+type LinkTarget = String
+
+{- Checks if a file is a link to a key. -}
+isAnnexLink :: FilePath -> Annex (Maybe Key)
+isAnnexLink file = maybe Nothing (fileKey . takeFileName) <$> getAnnexLinkTarget file
+
+{- Gets the link target of a symlink.
+ -
+ - On a filesystem that does not support symlinks, fall back to getting the
+ - link target by looking inside the file.
+ -
+ - Returns Nothing if the file is not a symlink, or not a link to annex
+ - content.
+ -}
+getAnnexLinkTarget :: FilePath -> Annex (Maybe LinkTarget)
+getAnnexLinkTarget f = getAnnexLinkTarget' f
+	=<< (coreSymlinks <$> Annex.getGitConfig)
+
+{- Pass False to force looking inside file. -}
+getAnnexLinkTarget' :: FilePath -> Bool -> Annex (Maybe LinkTarget)
+getAnnexLinkTarget' file coresymlinks = if coresymlinks
+	then check readSymbolicLink $
+		return Nothing
+	else check readSymbolicLink $
+		check probefilecontent $
+			return Nothing
+  where
+	check getlinktarget fallback = 
+		liftIO (catchMaybeIO $ getlinktarget file) >>= \case
+			Just l
+				| isLinkToAnnex (fromInternalGitPath l) -> return (Just l)
+				| otherwise -> return Nothing
+			Nothing -> fallback
+
+	probefilecontent f = withFile f ReadMode $ \h -> do
+		-- The first 8k is more than enough to read; link
+		-- files are small.
+		s <- take 8192 <$> hGetContents h
+		-- If we got the full 8k, the file is too large
+		if length s == 8192
+			then return ""
+			else 
+				-- If there are any NUL or newline
+				-- characters, or whitespace, we
+				-- certianly don't have a link to a
+				-- git-annex key.
+				return $ if any (`elem` s) "\0\n\r \t"
+					then ""
+					else s
+
+makeAnnexLink :: LinkTarget -> FilePath -> Annex ()
+makeAnnexLink = makeGitLink
+
+{- Creates a link on disk.
+ -
+ - On a filesystem that does not support symlinks, writes the link target
+ - to a file. Note that git will only treat the file as a symlink if
+ - it's staged as such, so use addAnnexLink when adding a new file or
+ - modified link to git.
+ -}
+makeGitLink :: LinkTarget -> FilePath -> Annex ()
+makeGitLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
+	( liftIO $ do
+		void $ tryIO $ removeFile file
+		createSymbolicLink linktarget file
+	, liftIO $ writeFile file linktarget
+	)
+
+{- Creates a link on disk, and additionally stages it in git. -}
+addAnnexLink :: LinkTarget -> FilePath -> Annex ()
+addAnnexLink linktarget file = do
+	makeAnnexLink linktarget file
+	stageSymlink file =<< hashSymlink linktarget
+
+{- Injects a symlink target into git, returning its Sha. -}
+hashSymlink :: LinkTarget -> Annex Sha
+hashSymlink linktarget = hashBlob (toInternalGitPath linktarget)
+
+{- Stages a symlink to an annexed object, using a Sha of its target. -}
+stageSymlink :: FilePath -> Sha -> Annex ()
+stageSymlink file sha =
+	Annex.Queue.addUpdateIndex =<<
+		inRepo (Git.UpdateIndex.stageSymlink file sha)
+
+{- Injects a pointer file content into git, returning its Sha. -}
+hashPointerFile :: Key -> Annex Sha
+hashPointerFile key = hashBlob (formatPointer key)
+
+{- Stages a pointer file, using a Sha of its content -}
+stagePointerFile :: FilePath -> Maybe FileMode -> Sha -> Annex ()
+stagePointerFile file mode sha =
+	Annex.Queue.addUpdateIndex =<<
+		inRepo (Git.UpdateIndex.stageFile sha treeitemtype file)
+  where
+	treeitemtype
+		| maybe False isExecutable mode = TreeExecutable
+		| otherwise = TreeFile
+
+writePointerFile :: FilePath -> Key -> Maybe FileMode -> IO ()
+writePointerFile file k mode = do
+	writeFile file (formatPointer k)
+	maybe noop (setFileMode file) mode
+
+{- Parses a symlink target or a pointer file to a Key.
+ - Only looks at the first line, as pointer files can have subsequent
+ - lines. -}
+parseLinkOrPointer :: L.ByteString -> Maybe Key
+parseLinkOrPointer = parseLinkOrPointer' 
+	. decodeBS . L.take (fromIntegral maxPointerSz)
+  where
+
+{- Want to avoid buffering really big files in git into
+ - memory when reading files that may be pointers.
+ -
+ - 8192 bytes is plenty for a pointer to a key.
+ - Pad some more to allow for any pointer files that might have
+ - lines after the key explaining what the file is used for. -}
+maxPointerSz :: Integer
+maxPointerSz = 81920
+
+parseLinkOrPointer' :: String -> Maybe Key
+parseLinkOrPointer' = go . fromInternalGitPath . takeWhile (not . lineend)
+  where
+	go l
+		| isLinkToAnnex l = fileKey $ takeFileName l
+		| otherwise = Nothing
+	lineend '\n' = True
+	lineend '\r' = True
+	lineend _ = False
+
+formatPointer :: Key -> String
+formatPointer k = 
+	toInternalGitPath (pathSeparator:objectDir </> keyFile k) ++ "\n"
+
+{- Checks if a worktree file is a pointer to a key.
+ -
+ - Unlocked files whose content is present are not detected by this. -}
+isPointerFile :: FilePath -> IO (Maybe Key)
+isPointerFile f = catchDefaultIO Nothing $ bracket open close $ \h -> do
+	b <- take (fromIntegral maxPointerSz) <$> hGetContents h
+	-- strict so it reads before the file handle is closed
+	let !mk = parseLinkOrPointer' b
+	return mk
+  where
+	open = openBinaryFile f ReadMode
+	close = hClose
+
+{- Checks a symlink target or pointer file first line to see if it
+ - appears to point to annexed content.
+ -
+ - We only look for paths inside the .git directory, and not at the .git
+ - directory itself, because GIT_DIR may cause a directory name other
+ - than .git to be used.
+ -}
+isLinkToAnnex :: FilePath -> Bool
+isLinkToAnnex s = (pathSeparator:objectDir) `isInfixOf` s
+#ifdef mingw32_HOST_OS
+	-- '/' is still used inside pointer files on Windows, not the native
+	-- '\'
+	|| ('/':objectDir) `isInfixOf` s
+#endif

Annex/Locations.hs

@@ -0,0 +1,543 @@
+{- git-annex file locations
+ -
+ - Copyright 2010-2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Locations (
+	keyFile,
+	fileKey,
+	keyPaths,
+	keyPath,
+	annexDir,
+	objectDir,
+	gitAnnexLocation,
+	gitAnnexLocationDepth,
+	gitAnnexLink,
+	gitAnnexLinkCanonical,
+	gitAnnexContentLock,
+	gitAnnexMapping,
+	gitAnnexInodeCache,
+	gitAnnexInodeSentinal,
+	gitAnnexInodeSentinalCache,
+	annexLocations,
+	gitAnnexDir,
+	gitAnnexObjectDir,
+	gitAnnexTmpMiscDir,
+	gitAnnexTmpObjectDir,
+	gitAnnexTmpObjectLocation,
+	gitAnnexTmpWorkDir,
+	gitAnnexBadDir,
+	gitAnnexBadLocation,
+	gitAnnexUnusedLog,
+	gitAnnexKeysDb,
+	gitAnnexKeysDbLock,
+	gitAnnexFsckState,
+	gitAnnexFsckDbDir,
+	gitAnnexFsckDbLock,
+	gitAnnexFsckResultsLog,
+	gitAnnexExportDbDir,
+	gitAnnexExportLock,
+	gitAnnexScheduleState,
+	gitAnnexTransferDir,
+	gitAnnexCredsDir,
+	gitAnnexWebCertificate,
+	gitAnnexWebPrivKey,
+	gitAnnexFeedStateDir,
+	gitAnnexFeedState,
+	gitAnnexMergeDir,
+	gitAnnexJournalDir,
+	gitAnnexJournalLock,
+	gitAnnexPreCommitLock,
+	gitAnnexMergeLock,
+	gitAnnexIndex,
+	gitAnnexIndexStatus,
+	gitAnnexViewIndex,
+	gitAnnexViewLog,
+	gitAnnexMergedRefs,
+	gitAnnexIgnoredRefs,
+	gitAnnexPidFile,
+	gitAnnexPidLockFile,
+	gitAnnexDaemonStatusFile,
+	gitAnnexLogFile,
+	gitAnnexFuzzTestLogFile,
+	gitAnnexHtmlShim,
+	gitAnnexUrlFile,
+	gitAnnexTmpCfgFile,
+	gitAnnexSshDir,
+	gitAnnexRemotesDir,
+	gitAnnexAssistantDefaultDir,
+	HashLevels(..),
+	hashDirMixed,
+	hashDirLower,
+	preSanitizeKeyName,
+	reSanitizeKeyName,
+
+	prop_isomorphic_fileKey
+) where
+
+import Data.Char
+import Data.Default
+
+import Common
+import Key
+import Types.Key
+import Types.UUID
+import Types.GitConfig
+import Types.Difference
+import qualified Git
+import qualified Git.Types as Git
+import Git.FilePath
+import Annex.DirHashes
+import Annex.Fixup
+
+{- Conventions:
+ -
+ - Functions ending in "Dir" should always return values ending with a
+ - trailing path separator. Most code does not rely on that, but a few
+ - things do. 
+ -
+ - Everything else should not end in a trailing path sepatator. 
+ -
+ - Only functions (with names starting with "git") that build a path
+ - based on a git repository should return full path relative to the git
+ - repository. Everything else returns path segments.
+ -}
+
+{- The directory git annex uses for local state, relative to the .git
+ - directory -}
+annexDir :: FilePath
+annexDir = addTrailingPathSeparator "annex"
+
+{- The directory git annex uses for locally available object content,
+ - relative to the .git directory -}
+objectDir :: FilePath
+objectDir = addTrailingPathSeparator $ annexDir </> "objects"
+
+{- Annexed file's possible locations relative to the .git directory.
+ - There are two different possibilities, using different hashes.
+ -
+ - Also, some repositories have a Difference in hash directory depth.
+ -}
+annexLocations :: GitConfig -> Key -> [FilePath]
+annexLocations config key = map (annexLocation config key) dirHashes
+
+annexLocation :: GitConfig -> Key -> (HashLevels -> Hasher) -> FilePath
+annexLocation config key hasher = objectDir </> keyPath key (hasher $ objectHashLevels config)
+
+{- Number of subdirectories from the gitAnnexObjectDir
+ - to the gitAnnexLocation. -}
+gitAnnexLocationDepth :: GitConfig -> Int
+gitAnnexLocationDepth config = hashlevels + 1
+  where
+	HashLevels hashlevels = objectHashLevels config
+
+{- Annexed object's location in a repository.
+ -
+ - When there are multiple possible locations, returns the one where the
+ - file is actually present.
+ -
+ - When the file is not present, returns the location where the file should
+ - be stored.
+ -
+ - This does not take direct mode into account, so in direct mode it is not
+ - the actual location of the file's content.
+ -}
+gitAnnexLocation :: Key -> Git.Repo -> GitConfig -> IO FilePath
+gitAnnexLocation key r config = gitAnnexLocation' key r config (annexCrippledFileSystem config) (coreSymlinks config) doesFileExist (Git.localGitDir r)
+gitAnnexLocation' :: Key -> Git.Repo -> GitConfig -> Bool -> Bool -> (FilePath -> IO Bool) -> FilePath -> IO FilePath
+gitAnnexLocation' key r config crippled symlinkssupported checker gitdir
+	{- Bare repositories default to hashDirLower for new
+	 - content, as it's more portable. But check all locations. -}
+	| Git.repoIsLocalBare r = checkall
+	| hasDifference ObjectHashLower (annexDifferences config) = 
+		only hashDirLower
+	{- Repositories on crippled filesystems use hashDirLower
+	 - for new content, unless symlinks are supported too.
+	 - Then hashDirMixed is used. But, the content could be
+	 - in either location so check both. -}
+	| crippled = if symlinkssupported
+		then check $ map inrepo $ reverse $ annexLocations config key
+		else checkall
+	{- Regular repositories only use hashDirMixed, so
+	 - don't need to do any work to check if the file is
+	 - present. -}
+	| otherwise = only hashDirMixed
+  where
+	only = return . inrepo . annexLocation config key
+	checkall = check $ map inrepo $ annexLocations config key
+
+	inrepo d = gitdir </> d
+	check locs@(l:_) = fromMaybe l <$> firstM checker locs
+	check [] = error "internal"
+
+{- Calculates a symlink target to link a file to an annexed object. -}
+gitAnnexLink :: FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath
+gitAnnexLink file key r config = do
+	currdir <- getCurrentDirectory
+	let absfile = absNormPathUnix currdir file
+	let gitdir = getgitdir currdir
+	loc <- gitAnnexLocation' key r config False False (\_ -> return True) gitdir
+	toInternalGitPath <$> relPathDirToFile (parentDir absfile) loc
+  where
+	getgitdir currdir
+		{- This special case is for git submodules on filesystems not
+		 - supporting symlinks; generate link target that will
+		 - work portably. -}
+		| not (coreSymlinks config) && needsSubmoduleFixup r =
+			absNormPathUnix currdir $ Git.repoPath r </> ".git"
+		| otherwise = Git.localGitDir r
+	absNormPathUnix d p = toInternalGitPath $
+		absPathFrom (toInternalGitPath d) (toInternalGitPath p)
+
+{- Calculates a symlink target as would be used in a typical git
+ - repository, with .git in the top of the work tree. -}
+gitAnnexLinkCanonical :: FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath
+gitAnnexLinkCanonical file key r config = gitAnnexLink file key r' config'
+  where
+	r' = case r of
+		Git.Repo { Git.location = l@Git.Local { Git.worktree = Just wt } } ->
+			r { Git.location = l { Git.gitdir = wt </> ".git" } }
+		_ -> r
+	config' = config
+		{ annexCrippledFileSystem = False
+		, coreSymlinks = True
+		}
+
+{- File used to lock a key's content. -}
+gitAnnexContentLock :: Key -> Git.Repo -> GitConfig -> IO FilePath
+gitAnnexContentLock key r config = do
+	loc <- gitAnnexLocation key r config
+	return $ loc ++ ".lck"
+
+{- File that maps from a key to the file(s) in the git repository.
+ - Used in direct mode. -}
+gitAnnexMapping :: Key -> Git.Repo -> GitConfig -> IO FilePath
+gitAnnexMapping key r config = do
+	loc <- gitAnnexLocation key r config
+	return $ loc ++ ".map"
+
+{- File that caches information about a key's content, used to determine
+ - if a file has changed.
+ - Used in direct mode. -}
+gitAnnexInodeCache :: Key -> Git.Repo -> GitConfig -> IO FilePath
+gitAnnexInodeCache key r config  = do
+	loc <- gitAnnexLocation key r config
+	return $ loc ++ ".cache"
+
+gitAnnexInodeSentinal :: Git.Repo -> FilePath
+gitAnnexInodeSentinal r = gitAnnexDir r </> "sentinal"
+
+gitAnnexInodeSentinalCache :: Git.Repo -> FilePath
+gitAnnexInodeSentinalCache r = gitAnnexInodeSentinal r ++ ".cache"
+
+{- The annex directory of a repository. -}
+gitAnnexDir :: Git.Repo -> FilePath
+gitAnnexDir r = addTrailingPathSeparator $ Git.localGitDir r </> annexDir
+
+{- The part of the annex directory where file contents are stored. -}
+gitAnnexObjectDir :: Git.Repo -> FilePath
+gitAnnexObjectDir r = addTrailingPathSeparator $ Git.localGitDir r </> objectDir
+
+{- .git/annex/misctmp/ is used for random temp files -}
+gitAnnexTmpMiscDir :: Git.Repo -> FilePath
+gitAnnexTmpMiscDir r = addTrailingPathSeparator $ gitAnnexDir r </> "misctmp"
+
+{- .git/annex/tmp/ is used for temp files for key's contents -}
+gitAnnexTmpObjectDir :: Git.Repo -> FilePath
+gitAnnexTmpObjectDir r = addTrailingPathSeparator $ gitAnnexDir r </> "tmp"
+
+{- The temp file to use for a given key's content. -}
+gitAnnexTmpObjectLocation :: Key -> Git.Repo -> FilePath
+gitAnnexTmpObjectLocation key r = gitAnnexTmpObjectDir r </> keyFile key
+
+{- Given a temp file such as gitAnnexTmpObjectLocation, makes a name for a
+ - subdirectory in the same location, that can be used as a work area
+ - when receiving the key's content.
+ -
+ - There are ordering requirements for creating these directories;
+ - use Annex.Content.withTmpWorkDir to set them up.
+ -}
+gitAnnexTmpWorkDir :: FilePath -> FilePath
+gitAnnexTmpWorkDir p =
+	let (dir, f) = splitFileName p
+	-- Using a prefix avoids name conflict with any other keys.
+	in dir </> "work." ++ f
+
+{- .git/annex/bad/ is used for bad files found during fsck -}
+gitAnnexBadDir :: Git.Repo -> FilePath
+gitAnnexBadDir r = addTrailingPathSeparator $ gitAnnexDir r </> "bad"
+
+{- The bad file to use for a given key. -}
+gitAnnexBadLocation :: Key -> Git.Repo -> FilePath
+gitAnnexBadLocation key r = gitAnnexBadDir r </> keyFile key
+
+{- .git/annex/foounused is used to number possibly unused keys -}
+gitAnnexUnusedLog :: FilePath -> Git.Repo -> FilePath
+gitAnnexUnusedLog prefix r = gitAnnexDir r </> (prefix ++ "unused")
+
+{- .git/annex/keys/ contains a database of information about keys. -}
+gitAnnexKeysDb :: Git.Repo -> FilePath
+gitAnnexKeysDb r = gitAnnexDir r </> "keys"
+
+{- Lock file for the keys database. -}
+gitAnnexKeysDbLock :: Git.Repo -> FilePath
+gitAnnexKeysDbLock r = gitAnnexKeysDb r ++ ".lck"
+
+{- .git/annex/fsck/uuid/ is used to store information about incremental
+ - fscks. -}
+gitAnnexFsckDir :: UUID -> Git.Repo -> FilePath
+gitAnnexFsckDir u r = gitAnnexDir r </> "fsck" </> fromUUID u
+
+{- used to store information about incremental fscks. -}
+gitAnnexFsckState :: UUID -> Git.Repo -> FilePath
+gitAnnexFsckState u r = gitAnnexFsckDir u r </> "state"
+
+{- Directory containing database used to record fsck info. -}
+gitAnnexFsckDbDir :: UUID -> Git.Repo -> FilePath
+gitAnnexFsckDbDir u r = gitAnnexFsckDir u r </> "db"
+
+{- Lock file for the fsck database. -}
+gitAnnexFsckDbLock :: UUID -> Git.Repo -> FilePath
+gitAnnexFsckDbLock u r = gitAnnexFsckDir u r </> "fsck.lck"
+
+{- .git/annex/fsckresults/uuid is used to store results of git fscks -}
+gitAnnexFsckResultsLog :: UUID -> Git.Repo -> FilePath
+gitAnnexFsckResultsLog u r = gitAnnexDir r </> "fsckresults" </> fromUUID u
+
+{- .git/annex/export/uuid/ is used to store information about
+ - exports to special remotes. -}
+gitAnnexExportDir :: UUID -> Git.Repo -> FilePath
+gitAnnexExportDir u r = gitAnnexDir r </> "export" </> fromUUID u
+
+{- Directory containing database used to record export info. -}
+gitAnnexExportDbDir :: UUID -> Git.Repo -> FilePath
+gitAnnexExportDbDir u r = gitAnnexExportDir u r </> "db"
+
+{- Lock file for export state for a special remote. -}
+gitAnnexExportLock :: UUID -> Git.Repo -> FilePath
+gitAnnexExportLock u r = gitAnnexExportDbDir u r ++ ".lck"
+
+{- .git/annex/schedulestate is used to store information about when
+ - scheduled jobs were last run. -}
+gitAnnexScheduleState :: Git.Repo -> FilePath
+gitAnnexScheduleState r = gitAnnexDir r </> "schedulestate"
+
+{- .git/annex/creds/ is used to store credentials to access some special
+ - remotes. -}
+gitAnnexCredsDir :: Git.Repo -> FilePath
+gitAnnexCredsDir r = addTrailingPathSeparator $ gitAnnexDir r </> "creds"
+
+{- .git/annex/certificate.pem and .git/annex/key.pem are used by the webapp
+ - when HTTPS is enabled -}
+gitAnnexWebCertificate :: Git.Repo -> FilePath
+gitAnnexWebCertificate r = gitAnnexDir r </> "certificate.pem"
+gitAnnexWebPrivKey :: Git.Repo -> FilePath
+gitAnnexWebPrivKey r = gitAnnexDir r </> "privkey.pem"
+
+{- .git/annex/feeds/ is used to record per-key (url) state by importfeeds -}
+gitAnnexFeedStateDir :: Git.Repo -> FilePath
+gitAnnexFeedStateDir r = addTrailingPathSeparator $ gitAnnexDir r </> "feedstate"
+
+gitAnnexFeedState :: Key -> Git.Repo -> FilePath
+gitAnnexFeedState k r = gitAnnexFeedStateDir r </> keyFile k
+
+{- .git/annex/merge/ is used as a empty work tree for direct mode merges and
+ - merges in adjusted branches. -}
+gitAnnexMergeDir :: Git.Repo -> FilePath
+gitAnnexMergeDir r = addTrailingPathSeparator $ gitAnnexDir r </> "merge"
+
+{- .git/annex/transfer/ is used to record keys currently
+ - being transferred, and other transfer bookkeeping info. -}
+gitAnnexTransferDir :: Git.Repo -> FilePath
+gitAnnexTransferDir r = addTrailingPathSeparator $ gitAnnexDir r </> "transfer"
+
+{- .git/annex/journal/ is used to journal changes made to the git-annex
+ - branch -}
+gitAnnexJournalDir :: Git.Repo -> FilePath
+gitAnnexJournalDir r = addTrailingPathSeparator $ gitAnnexDir r </> "journal"
+
+{- Lock file for the journal. -}
+gitAnnexJournalLock :: Git.Repo -> FilePath
+gitAnnexJournalLock r = gitAnnexDir r </> "journal.lck"
+
+{- Lock file for the pre-commit hook. -}
+gitAnnexPreCommitLock :: Git.Repo -> FilePath
+gitAnnexPreCommitLock r = gitAnnexDir r </> "precommit.lck"
+
+{- Lock file for direct mode merge. -}
+gitAnnexMergeLock :: Git.Repo -> FilePath
+gitAnnexMergeLock r = gitAnnexDir r </> "merge.lck"
+
+{- .git/annex/index is used to stage changes to the git-annex branch -}
+gitAnnexIndex :: Git.Repo -> FilePath
+gitAnnexIndex r = gitAnnexDir r </> "index"
+
+{- Holds the ref of the git-annex branch that the index was last updated to.
+ -
+ - The .lck in the name is a historical accident; this is not used as a
+ - lock. -}
+gitAnnexIndexStatus :: Git.Repo -> FilePath
+gitAnnexIndexStatus r = gitAnnexDir r </> "index.lck"
+
+{- The index file used to generate a filtered branch view._-}
+gitAnnexViewIndex :: Git.Repo -> FilePath
+gitAnnexViewIndex r = gitAnnexDir r </> "viewindex"
+
+{- File containing a log of recently accessed views. -}
+gitAnnexViewLog :: Git.Repo -> FilePath
+gitAnnexViewLog r = gitAnnexDir r </> "viewlog"
+
+{- List of refs that have already been merged into the git-annex branch. -}
+gitAnnexMergedRefs :: Git.Repo -> FilePath
+gitAnnexMergedRefs r = gitAnnexDir r </> "mergedrefs"
+
+{- List of refs that should not be merged into the git-annex branch. -}
+gitAnnexIgnoredRefs :: Git.Repo -> FilePath
+gitAnnexIgnoredRefs r = gitAnnexDir r </> "ignoredrefs"
+
+{- Pid file for daemon mode. -}
+gitAnnexPidFile :: Git.Repo -> FilePath
+gitAnnexPidFile r = gitAnnexDir r </> "daemon.pid"
+
+{- Pid lock file for pidlock mode -}
+gitAnnexPidLockFile :: Git.Repo -> FilePath
+gitAnnexPidLockFile r = gitAnnexDir r </> "pidlock"
+
+{- Status file for daemon mode. -}
+gitAnnexDaemonStatusFile :: Git.Repo -> FilePath
+gitAnnexDaemonStatusFile r = gitAnnexDir r </> "daemon.status"
+
+{- Log file for daemon mode. -}
+gitAnnexLogFile :: Git.Repo -> FilePath
+gitAnnexLogFile r = gitAnnexDir r </> "daemon.log"
+
+{- Log file for fuzz test. -}
+gitAnnexFuzzTestLogFile :: Git.Repo -> FilePath
+gitAnnexFuzzTestLogFile r = gitAnnexDir r </> "fuzztest.log"
+
+{- Html shim file used to launch the webapp. -}
+gitAnnexHtmlShim :: Git.Repo -> FilePath
+gitAnnexHtmlShim r = gitAnnexDir r </> "webapp.html"
+
+{- File containing the url to the webapp. -}
+gitAnnexUrlFile :: Git.Repo -> FilePath
+gitAnnexUrlFile r = gitAnnexDir r </> "url"
+
+{- Temporary file used to edit configuriation from the git-annex branch. -}
+gitAnnexTmpCfgFile :: Git.Repo -> FilePath
+gitAnnexTmpCfgFile r = gitAnnexDir r </> "config.tmp"
+
+{- .git/annex/ssh/ is used for ssh connection caching -}
+gitAnnexSshDir :: Git.Repo -> FilePath
+gitAnnexSshDir r = addTrailingPathSeparator $ gitAnnexDir r </> "ssh"
+
+{- .git/annex/remotes/ is used for remote-specific state. -}
+gitAnnexRemotesDir :: Git.Repo -> FilePath
+gitAnnexRemotesDir r = addTrailingPathSeparator $ gitAnnexDir r </> "remotes"
+
+{- This is the base directory name used by the assistant when making
+ - repositories, by default. -}
+gitAnnexAssistantDefaultDir :: FilePath
+gitAnnexAssistantDefaultDir = "annex"
+
+{- Sanitizes a String that will be used as part of a Key's keyName,
+ - dealing with characters that cause problems.
+ -
+ - This is used when a new Key is initially being generated, eg by getKey.
+ - Unlike keyFile and fileKey, it does not need to be a reversable
+ - escaping. Also, it's ok to change this to add more problematic
+ - characters later. Unlike changing keyFile, which could result in the
+ - filenames used for existing keys changing and contents getting lost.
+ -
+ - It is, however, important that the input and output of this function
+ - have a 1:1 mapping, to avoid two different inputs from mapping to the
+ - same key.
+ -}
+preSanitizeKeyName :: String -> String
+preSanitizeKeyName = preSanitizeKeyName' False
+
+preSanitizeKeyName' :: Bool -> String -> String
+preSanitizeKeyName' resanitize = concatMap escape
+  where
+	escape c
+		| isAsciiUpper c || isAsciiLower c || isDigit c = [c]
+		| c `elem` ".-_" = [c] -- common, assumed safe
+		| c `elem` "/%:" = [c] -- handled by keyFile
+		-- , is safe and uncommon, so will be used to escape
+		-- other characters. By itself, it is escaped to 
+		-- doubled form.
+		| c == ',' = if not resanitize
+			then ",,"
+			else ","
+		| otherwise = ',' : show (ord c)
+
+{- Converts a keyName that has been santizied with an old version of
+ - preSanitizeKeyName to be sanitized with the new version. -}
+reSanitizeKeyName :: String -> String
+reSanitizeKeyName = preSanitizeKeyName' True
+
+{- Converts a key into a filename fragment without any directory.
+ -
+ - Escape "/" in the key name, to keep a flat tree of files and avoid
+ - issues with keys containing "/../" or ending with "/" etc. 
+ -
+ - "/" is escaped to "%" because it's short and rarely used, and resembles
+ -     a slash
+ - "%" is escaped to "&s", and "&" to "&a"; this ensures that the mapping
+ -     is one to one.
+ - ":" is escaped to "&c", because it seemed like a good idea at the time.
+ -
+ - Changing what this function escapes and how is not a good idea, as it
+ - can cause existing objects to get lost.
+ -}
+keyFile :: Key -> FilePath
+keyFile = concatMap esc . key2file
+  where
+	esc '&' = "&a"
+	esc '%' = "&s"
+	esc ':' = "&c"
+	esc '/' = "%"
+	esc c = [c]
+
+{- Reverses keyFile, converting a filename fragment (ie, the basename of
+ - the symlink target) into a key. -}
+fileKey :: FilePath -> Maybe Key
+fileKey = file2key . unesc [] 
+  where
+	unesc r [] = reverse r
+	unesc r ('%':cs) = unesc ('/':r) cs
+	unesc r ('&':'c':cs) = unesc (':':r) cs
+	unesc r ('&':'s':cs) = unesc ('%':r) cs
+	unesc r ('&':'a':cs) = unesc ('&':r) cs
+	unesc r (c:cs) = unesc (c:r) cs
+
+{- for quickcheck -}
+prop_isomorphic_fileKey :: String -> Bool
+prop_isomorphic_fileKey s
+	| null s = True -- it's not legal for a key to have no keyName
+	| otherwise= Just k == fileKey (keyFile k)
+  where
+	k = stubKey { keyName = s, keyVariety = OtherKey "test" }
+
+{- A location to store a key on a special remote that uses a filesystem.
+ - A directory hash is used, to protect against filesystems that dislike
+ - having many items in a single directory.
+ -
+ - The file is put in a directory with the same name, this allows
+ - write-protecting the directory to avoid accidental deletion of the file.
+ -}
+keyPath :: Key -> Hasher -> FilePath
+keyPath key hasher = hasher key </> f </> f
+  where
+	f = keyFile key
+
+{- All possibile locations to store a key in a special remote
+ - using different directory hashes.
+ -
+ - This is compatible with the annexLocations, for interoperability between
+ - special remotes and git-annex repos.
+ -}
+keyPaths :: Key -> [FilePath]
+keyPaths key = map (\h -> keyPath key (h def)) dirHashes

Annex/LockFile.hs

@@ -0,0 +1,92 @@
+{- git-annex lock files.
+ -
+ - Copyright 2012-2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.LockFile (
+	lockFileCached,
+	unlockFile,
+	getLockCache,
+	fromLockCache,
+	withExclusiveLock,
+	tryExclusiveLock,
+) where
+
+import Annex.Common
+import Annex
+import Types.LockCache
+import qualified Git
+import Annex.Perms
+import Annex.LockPool
+
+import qualified Data.Map as M
+
+{- Create a specified lock file, and takes a shared lock, which is retained
+ - in the cache. -}
+lockFileCached :: FilePath -> Annex ()
+lockFileCached file = go =<< fromLockCache file
+  where
+	go (Just _) = noop -- already locked
+	go Nothing = do
+#ifndef mingw32_HOST_OS
+		mode <- annexFileMode
+		lockhandle <- noUmask mode $ lockShared (Just mode) file
+#else
+		lockhandle <- liftIO $ waitToLock $ lockShared file
+#endif
+		changeLockCache $ M.insert file lockhandle
+
+unlockFile :: FilePath -> Annex ()
+unlockFile file = maybe noop go =<< fromLockCache file
+  where
+	go lockhandle = do
+		liftIO $ dropLock lockhandle
+		changeLockCache $ M.delete file
+
+getLockCache :: Annex LockCache
+getLockCache = getState lockcache
+
+fromLockCache :: FilePath -> Annex (Maybe LockHandle)
+fromLockCache file = M.lookup file <$> getLockCache
+
+changeLockCache :: (LockCache -> LockCache) -> Annex ()
+changeLockCache a = do
+	m <- getLockCache
+	changeState $ \s -> s { lockcache = a m }
+
+{- Runs an action with an exclusive lock held. If the lock is already
+ - held, blocks until it becomes free. -}
+withExclusiveLock :: (Git.Repo -> FilePath) -> Annex a -> Annex a
+withExclusiveLock getlockfile a = do
+	lockfile <- fromRepo getlockfile
+	createAnnexDirectory $ takeDirectory lockfile
+	mode <- annexFileMode
+	bracket (lock mode lockfile) (liftIO . dropLock) (const a)
+  where
+#ifndef mingw32_HOST_OS
+	lock mode = noUmask mode . lockExclusive (Just mode)
+#else
+	lock _mode = liftIO . waitToLock . lockExclusive
+#endif
+
+{- Tries to take an exclusive lock and run an action. If the lock is
+ - already held, returns Nothing. -}
+tryExclusiveLock :: (Git.Repo -> FilePath) -> Annex a -> Annex (Maybe a)
+tryExclusiveLock getlockfile a = do
+	lockfile <- fromRepo getlockfile
+	createAnnexDirectory $ takeDirectory lockfile
+	mode <- annexFileMode
+	bracket (lock mode lockfile) (liftIO . unlock) go
+  where
+#ifndef mingw32_HOST_OS
+	lock mode = noUmask mode . tryLockExclusive (Just mode)
+#else
+	lock _mode = liftIO . lockExclusive
+#endif
+	unlock = maybe noop dropLock
+	go Nothing = return Nothing
+	go (Just _) = Just <$> a

Annex/LockPool.hs

@@ -0,0 +1,17 @@
+{- Wraps Utility.LockPool, making pid locks be used when git-annex is so
+ - configured.
+ -
+ - Copyright 2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.LockPool (module X) where
+
+#ifndef mingw32_HOST_OS
+import Annex.LockPool.PosixOrPid as X
+#else
+import Utility.LockPool.Windows as X
+#endif

Annex/LockPool/PosixOrPid.hs

@@ -0,0 +1,97 @@
+{- Wraps Utility.LockPool, making pid locks be used when git-annex is so
+ - configured.
+ -
+ - Copyright 2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.LockPool.PosixOrPid (
+	LockFile,
+	LockHandle,
+	lockShared,
+	lockExclusive,
+	tryLockShared,
+	tryLockExclusive,
+	dropLock,
+	checkLocked,
+	LockStatus(..),
+	getLockStatus,
+	checkSaneLock,
+) where
+
+import Common
+import Types
+import Annex.Locations
+import qualified Annex
+import qualified Utility.LockPool.Posix as Posix
+import qualified Utility.LockPool.PidLock as Pid
+import qualified Utility.LockPool.LockHandle as H
+import Utility.LockPool.LockHandle (LockHandle, dropLock)
+import Utility.LockFile.Posix (openLockFile)
+import Utility.LockPool.STM (LockFile)
+import Utility.LockFile.LockStatus
+
+import System.Posix
+
+lockShared :: Maybe FileMode -> LockFile -> Annex LockHandle
+lockShared m f = pidLock m f $ Posix.lockShared m f
+
+lockExclusive :: Maybe FileMode -> LockFile -> Annex LockHandle
+lockExclusive m f = pidLock m f $ Posix.lockExclusive m f
+
+tryLockShared :: Maybe FileMode -> LockFile -> Annex (Maybe LockHandle)
+tryLockShared m f = tryPidLock m f $ Posix.tryLockShared m f
+
+tryLockExclusive :: Maybe FileMode -> LockFile -> Annex (Maybe LockHandle)
+tryLockExclusive m f = tryPidLock m f $ Posix.tryLockExclusive m f
+
+checkLocked :: LockFile -> Annex (Maybe Bool)
+checkLocked f = Posix.checkLocked f `pidLockCheck` checkpid
+  where
+	checkpid pidlock = Pid.checkLocked pidlock >>= \case
+		-- Only return true when the posix lock file exists.
+		Just _ -> Posix.checkLocked f
+		Nothing -> return Nothing
+
+getLockStatus :: LockFile -> Annex LockStatus
+getLockStatus f = Posix.getLockStatus f
+	`pidLockCheck` Pid.getLockStatus
+
+checkSaneLock :: LockFile -> LockHandle -> Annex Bool
+checkSaneLock f h = H.checkSaneLock f h
+	`pidLockCheck` flip Pid.checkSaneLock h
+
+pidLockFile :: Annex (Maybe FilePath)
+pidLockFile = ifM (annexPidLock <$> Annex.getGitConfig)
+	( Just <$> Annex.fromRepo gitAnnexPidLockFile
+	, pure Nothing
+	)
+
+pidLockCheck :: IO a -> (LockFile -> IO a) -> Annex a
+pidLockCheck posixcheck pidcheck = 
+	liftIO . maybe posixcheck pidcheck =<< pidLockFile
+
+pidLock :: Maybe FileMode -> LockFile -> IO LockHandle -> Annex LockHandle
+pidLock m f posixlock = go =<< pidLockFile
+  where
+	go Nothing = liftIO posixlock
+	go (Just pidlock) = do
+		timeout <- annexPidLockTimeout <$> Annex.getGitConfig
+		liftIO $ do
+			dummyPosixLock m f
+			Pid.waitLock timeout pidlock
+
+tryPidLock :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle) -> Annex (Maybe LockHandle)
+tryPidLock m f posixlock = liftIO . go =<< pidLockFile
+  where
+	go Nothing = posixlock
+	go (Just pidlock) = do
+		dummyPosixLock m f
+		Pid.tryLock pidlock
+
+-- The posix lock file is created even when using pid locks, in order to
+-- avoid complicating any code that might expect to be able to see that
+-- lock file. But, it's not locked.
+dummyPosixLock :: Maybe FileMode -> LockFile -> IO ()
+dummyPosixLock m f = closeFd =<< openLockFile ReadLock m f

Annex/MakeRepo.hs

@@ -0,0 +1,90 @@
+{- making local repositories (used by webapp mostly)
+ -
+ - Copyright 2012-2014 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.MakeRepo where
+
+import Assistant.WebApp.Common
+import Annex.Init
+import qualified Git.Construct
+import qualified Git.Config
+import qualified Git.Command
+import qualified Git.Branch
+import qualified Annex
+import Annex.UUID
+import Annex.Direct
+import Annex.Action
+import Types.StandardGroups
+import Logs.PreferredContent
+import qualified Annex.Branch
+import Utility.Process.Transcript
+
+{- Makes a new git repository. Or, if a git repository already
+ - exists, returns False. -}
+makeRepo :: FilePath -> Bool -> IO Bool
+makeRepo path bare = ifM (probeRepoExists path)
+	( return False
+	, do
+		(transcript, ok) <-
+			processTranscript "git" (toCommand params) Nothing
+		unless ok $
+			error $ "git init failed!\nOutput:\n" ++ transcript
+		return True
+	)
+  where
+	baseparams = [Param "init", Param "--quiet"]
+	params
+		| bare = baseparams ++ [Param "--bare", File path]
+		| otherwise = baseparams ++ [File path]
+
+{- Runs an action in the git repository in the specified directory. -}
+inDir :: FilePath -> Annex a -> IO a
+inDir dir a = do
+	state <- Annex.new =<< Git.Config.read =<< Git.Construct.fromPath dir
+	Annex.eval state $ a `finally` stopCoProcesses
+
+{- Creates a new repository, and returns its UUID. -}
+initRepo :: Bool -> Bool -> FilePath -> Maybe String -> Maybe StandardGroup -> IO UUID
+initRepo True primary_assistant_repo dir desc mgroup = inDir dir $ do
+	initRepo' desc mgroup
+	{- Initialize the master branch, so things that expect
+	 - to have it will work, before any files are added. -}
+	unlessM (Git.Config.isBare <$> gitRepo) $
+		void $ inRepo $ Git.Branch.commitCommand Git.Branch.AutomaticCommit
+			[ Param "--quiet"
+			, Param "--allow-empty"
+			, Param "-m"
+			, Param "created repository"
+			]
+	{- Repositories directly managed by the assistant use direct mode.
+	 - 
+	 - Automatic gc is disabled, as it can be slow. Insted, gc is done
+	 - once a day.
+	 -}
+	when primary_assistant_repo $ do
+		setDirect True
+		inRepo $ Git.Command.run
+			[Param "config", Param "gc.auto", Param "0"]
+	getUUID
+{- Repo already exists, could be a non-git-annex repo though so
+ - still initialize it. -}
+initRepo False _ dir desc mgroup = inDir dir $ do
+	initRepo' desc mgroup
+	getUUID
+
+initRepo' :: Maybe String -> Maybe StandardGroup -> Annex ()
+initRepo' desc mgroup = unlessM isInitialized $ do
+	initialize (AutoInit False) desc Nothing
+	u <- getUUID
+	maybe noop (defaultStandardGroup u) mgroup
+	{- Ensure branch gets committed right away so it is
+	 - available for merging immediately. -}
+	Annex.Branch.commit =<< Annex.Branch.commitMessage
+
+{- Checks if a git repo exists at a location. -}
+probeRepoExists :: FilePath -> IO Bool
+probeRepoExists dir = isJust <$>
+	catchDefaultIO Nothing (Git.Construct.checkForRepo dir)

Annex/MetaData.hs

@@ -0,0 +1,114 @@
+{- git-annex metadata
+ -
+ - Copyright 2014-2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.MetaData (
+	genMetaData,
+	dateMetaData,
+	parseModMeta,
+	parseMetaDataMatcher,
+	module X
+) where
+
+import Annex.Common
+import qualified Annex
+import Types.MetaData as X
+import Annex.MetaData.StandardFields as X
+import Logs.MetaData
+import Annex.CatFile
+import Utility.Glob
+
+import qualified Data.Set as S
+import Data.Time.Calendar
+import Data.Time.Clock
+import Data.Time.Clock.POSIX
+
+{- Adds metadata for a file that has just been ingested into the
+ - annex, but has not yet been committed to git.
+ -
+ - When the file has been modified, the metadata is copied over
+ - from the old key to the new key. Note that it looks at the old key as
+ - committed to HEAD -- the new key may or may not have already been staged
+ - in the index.
+ -
+ - Also, can generate new metadata, if configured to do so.
+ -}
+genMetaData :: Key -> FilePath -> FileStatus -> Annex ()
+genMetaData key file status = do
+	catKeyFileHEAD file >>= \case
+		Nothing -> noop
+		Just oldkey ->
+			-- Have to copy first, before adding any
+			-- more metadata, because copyMetaData does not
+			-- preserve any metadata already on key.
+			whenM (copyMetaData oldkey key <&&> (not <$> onlydatemeta oldkey)) $
+				warncopied
+	whenM (annexGenMetaData <$> Annex.getGitConfig) $ do
+		old <- getCurrentMetaData key
+		addMetaData key (dateMetaData mtime old)
+  where
+	mtime = posixSecondsToUTCTime $ realToFrac $ modificationTime status
+	warncopied = warning $ 
+		"Copied metadata from old version of " ++ file ++ " to new version. " ++ 
+		"If you don't want this copied metadata, run: git annex metadata --remove-all " ++ file
+	-- If the only fields copied were date metadata, and they'll
+	-- be overwritten with the current mtime, no need to warn about
+	-- copying.
+	onlydatemeta oldkey = ifM (annexGenMetaData <$> Annex.getGitConfig)
+		( null . filter (not . isDateMetaField . fst) . fromMetaData 
+			<$> getCurrentMetaData oldkey
+		, return False
+		)
+
+{- Generates metadata for a file's date stamp.
+ -
+ - Any date fields in the old metadata will be overwritten.
+ - 
+ - Note that the returned MetaData does not contain all the input MetaData,
+ - only changes to add the date fields. -}
+dateMetaData :: UTCTime -> MetaData -> MetaData
+dateMetaData mtime old = modMeta old $
+	(SetMeta yearMetaField $ S.singleton $ toMetaValue $ show y)
+		`ComposeModMeta`
+	(SetMeta monthMetaField $ S.singleton $ toMetaValue $ show m)
+		`ComposeModMeta`
+	(SetMeta dayMetaField $ S.singleton $ toMetaValue $ show d)
+  where
+	(y, m, d) = toGregorian $ utctDay mtime
+
+{- Parses field=value, field+=value, field-=value, field?=value -}
+parseModMeta :: String -> Either String ModMeta
+parseModMeta p = case lastMaybe f of
+	Just '+' -> AddMeta <$> mkMetaField f' <*> v
+	Just '-' -> DelMeta <$> mkMetaField f' <*> (Just <$> v)
+	Just '?' -> MaybeSetMeta <$> mkMetaField f' <*> v
+	_ -> SetMeta <$> mkMetaField f <*> (S.singleton <$> v)
+  where
+	(f, sv) = separate (== '=') p
+	f' = beginning f
+	v = pure (toMetaValue sv)
+
+{- Parses field=value, field<value, field<=value, field>value, field>=value -}
+parseMetaDataMatcher :: String -> Either String (MetaField, MetaValue -> Bool)
+parseMetaDataMatcher p = (,)
+	<$> mkMetaField f
+	<*> pure matcher
+  where
+	(f, op_v) = break (`elem` "=<>") p
+	matcher = case op_v of
+		('=':v) -> checkglob v
+		('<':'=':v) -> checkcmp (<=) v
+		('<':v) -> checkcmp (<) v
+		('>':'=':v) -> checkcmp (>=) v
+		('>':v) -> checkcmp (>) v
+		_ -> checkglob ""
+	checkglob v =
+		let cglob = compileGlob v CaseInsensative
+		in matchGlob cglob . fromMetaValue
+	checkcmp cmp v v' = case (doubleval v, doubleval (fromMetaValue v')) of
+		(Just d, Just d') -> d' `cmp` d
+		_ -> False
+	doubleval v = readish v :: Maybe Double

Annex/MetaData/StandardFields.hs

@@ -0,0 +1,59 @@
+{- git-annex metadata, standard fields
+ -
+ - Copyright 2014 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.MetaData.StandardFields (
+	tagMetaField,
+	yearMetaField,
+	monthMetaField,
+	dayMetaField,
+	isDateMetaField,
+	lastChangedField,
+	mkLastChangedField,
+	isLastChangedField
+) where
+
+import Types.MetaData
+
+import Data.List
+
+tagMetaField :: MetaField
+tagMetaField = mkMetaFieldUnchecked "tag"
+
+yearMetaField :: MetaField
+yearMetaField = mkMetaFieldUnchecked "year"
+
+monthMetaField :: MetaField
+monthMetaField = mkMetaFieldUnchecked "month"
+
+dayMetaField :: MetaField
+dayMetaField = mkMetaFieldUnchecked "day"
+
+isDateMetaField :: MetaField -> Bool
+isDateMetaField f
+	| f == yearMetaField = True
+	| f == monthMetaField = True
+	| f == dayMetaField = True
+	| otherwise = False
+
+lastChangedField :: MetaField
+lastChangedField = mkMetaFieldUnchecked lastchanged
+
+mkLastChangedField :: MetaField -> MetaField
+mkLastChangedField f = mkMetaFieldUnchecked (fromMetaField f ++ lastchangedSuffix)
+
+isLastChangedField :: MetaField -> Bool
+isLastChangedField f
+	| f == lastChangedField = True
+	| otherwise = lastchanged `isSuffixOf` s && s /= lastchangedSuffix
+  where
+	s = fromMetaField f
+
+lastchanged :: String
+lastchanged = "lastchanged"
+
+lastchangedSuffix :: String
+lastchangedSuffix = "-lastchanged"

Annex/Multicast.hs

@@ -0,0 +1,54 @@
+{- git-annex multicast receive callback
+ -
+ - Copyright 2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Multicast where
+
+import Config.Files
+import Utility.Env
+import Utility.PartialPrelude
+
+import System.Process
+import System.IO
+import GHC.IO.Handle.FD
+#if ! MIN_VERSION_process(1,4,2)
+import System.Posix.IO (handleToFd)
+#endif
+import Control.Applicative
+import Prelude
+
+multicastReceiveEnv :: String
+multicastReceiveEnv = "GIT_ANNEX_MULTICAST_RECEIVE"
+
+multicastCallbackEnv :: IO (FilePath, [(String, String)], Handle)
+multicastCallbackEnv = do
+	gitannex <- readProgramFile
+#if MIN_VERSION_process(1,4,2)
+	-- This will even work on Windows
+	(rfd, wfd) <- createPipeFd
+	rh <- fdToHandle rfd
+#else
+	(rh, wh) <- createPipe
+	wfd <- handleToFd wh
+#endif
+	environ <- addEntry multicastReceiveEnv (show wfd) <$> getEnvironment
+	return (gitannex, environ, rh)
+
+-- This is run when uftpd has received a file. Rather than move
+-- the file into the annex here, which would require starting up the
+-- Annex monad, parsing git config, and verifying the content, simply
+-- output to the specified FD the filename. This keeps the time
+-- that uftpd is not receiving the next file as short as possible.
+runMulticastReceive :: [String] -> String -> IO ()
+runMulticastReceive ("-I":_sessionid:fs) hs = case readish hs of
+	Just fd -> do
+		h <- fdToHandle fd
+		mapM_ (hPutStrLn h) fs
+		hClose h
+	Nothing -> return ()
+runMulticastReceive _ _ = return ()

Annex/Notification.hs

@@ -0,0 +1,108 @@
+{- git-annex desktop notifications
+ -
+ - Copyright 2014 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+
+module Annex.Notification (NotifyWitness, noNotification, notifyTransfer, notifyDrop) where
+
+import Annex.Common
+import Types.Transfer
+#ifdef WITH_DBUS_NOTIFICATIONS
+import qualified Annex
+import Types.DesktopNotify
+import qualified DBus.Notify as Notify
+import qualified DBus.Client
+#endif
+
+-- Witness that notification has happened.
+data NotifyWitness = NotifyWitness
+
+-- Only use when no notification should be done.
+noNotification :: NotifyWitness
+noNotification = NotifyWitness
+
+{- Wrap around an action that performs a transfer, which may run multiple
+ - attempts. Displays notification when supported and when the user asked
+ - for it. -}
+notifyTransfer :: Transferrable t => Observable v => Direction -> t -> (NotifyWitness -> Annex v) -> Annex v
+#ifdef WITH_DBUS_NOTIFICATIONS
+notifyTransfer direction t a = case descTransfrerrable t of
+	Nothing -> a NotifyWitness
+	Just desc -> do
+		wanted <- Annex.getState Annex.desktopnotify
+		if (notifyStart wanted || notifyFinish wanted)
+			then do
+				client <- liftIO DBus.Client.connectSession
+				startnotification <- liftIO $ if notifyStart wanted
+					then Just <$> Notify.notify client (startedTransferNote direction desc)
+					else pure Nothing
+				res <- a NotifyWitness
+				let ok = observeBool res
+				when (notifyFinish wanted) $ liftIO $ void $ maybe 
+					(Notify.notify client $ finishedTransferNote ok direction desc)
+					(\n -> Notify.replace client n $ finishedTransferNote ok direction desc)
+					startnotification
+				return res
+			else a NotifyWitness
+#else
+notifyTransfer _ _ a = a NotifyWitness
+#endif
+
+notifyDrop :: AssociatedFile -> Bool -> Annex ()
+notifyDrop (AssociatedFile Nothing) _ = noop
+#ifdef WITH_DBUS_NOTIFICATIONS
+notifyDrop (AssociatedFile (Just f)) ok = do
+	wanted <- Annex.getState Annex.desktopnotify
+	when (notifyFinish wanted) $ liftIO $ do
+		client <- DBus.Client.connectSession
+		void $ Notify.notify client (droppedNote ok f)
+#else
+notifyDrop (AssociatedFile (Just _)) _ = noop
+#endif
+
+#ifdef WITH_DBUS_NOTIFICATIONS
+startedTransferNote :: Direction -> String -> Notify.Note
+startedTransferNote Upload   = mkNote Notify.Transfer Notify.Low iconUpload
+	"Uploading"
+startedTransferNote Download = mkNote Notify.Transfer Notify.Low iconDownload
+	"Downloading"
+
+finishedTransferNote :: Bool -> Direction -> String -> Notify.Note
+finishedTransferNote False Upload   = mkNote Notify.TransferError Notify.Normal iconFailure
+	"Failed to upload"
+finishedTransferNote False Download = mkNote Notify.TransferError Notify.Normal iconFailure
+	"Failed to download"
+finishedTransferNote True  Upload   = mkNote Notify.TransferComplete Notify.Low iconSuccess
+	"Finished uploading"
+finishedTransferNote True  Download = mkNote Notify.TransferComplete Notify.Low iconSuccess
+	"Finished downloading"
+
+droppedNote :: Bool -> String -> Notify.Note
+droppedNote False = mkNote Notify.TransferError Notify.Normal iconFailure
+	"Failed to drop"
+droppedNote True  = mkNote Notify.TransferComplete Notify.Low iconSuccess
+	"Dropped"
+
+iconUpload, iconDownload, iconFailure, iconSuccess :: String
+iconUpload   = "network-transmit"
+iconDownload = "network-receive"
+iconFailure  = "dialog-error"
+iconSuccess  = "git-annex"  -- Is there a standard icon for success/completion?
+
+mkNote :: Notify.Category -> Notify.UrgencyLevel -> String -> String -> FilePath -> Notify.Note
+mkNote category urgency icon desc path = Notify.blankNote
+	{ Notify.appName = "git-annex"
+	, Notify.appImage = Just (Notify.Icon icon)
+	, Notify.summary = desc ++ " " ++ path
+	, Notify.hints =
+		[ Notify.Category category
+		, Notify.Urgency urgency
+		, Notify.SuppressSound True
+		]
+	}
+#endif

Annex/NumCopies.hs

@@ -0,0 +1,222 @@
+{- git-annex numcopies configuration and checking
+ -
+ - Copyright 2014-2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable #-}
+
+module Annex.NumCopies (
+	module Types.NumCopies,
+	module Logs.NumCopies,
+	getFileNumCopies,
+	getAssociatedFileNumCopies,
+	getGlobalFileNumCopies,
+	getNumCopies,
+	deprecatedNumCopies,
+	defaultNumCopies,
+	numCopiesCheck,
+	numCopiesCheck',
+	verifyEnoughCopiesToDrop,
+	verifiableCopies,
+	UnVerifiedCopy(..),
+) where
+
+import Annex.Common
+import qualified Annex
+import Types.NumCopies
+import Logs.NumCopies
+import Logs.Trust
+import Annex.CheckAttr
+import qualified Remote
+import qualified Types.Remote as Remote
+import Annex.Content
+import Annex.UUID
+
+import Control.Exception
+import qualified Control.Monad.Catch as M
+import Data.Typeable
+
+defaultNumCopies :: NumCopies
+defaultNumCopies = NumCopies 1
+
+fromSources :: [Annex (Maybe NumCopies)] -> Annex NumCopies
+fromSources = fromMaybe defaultNumCopies <$$> getM id
+
+{- The git config annex.numcopies is deprecated. -}
+deprecatedNumCopies :: Annex (Maybe NumCopies)
+deprecatedNumCopies = annexNumCopies <$> Annex.getGitConfig
+
+{- Value forced on the command line by --numcopies. -}
+getForcedNumCopies :: Annex (Maybe NumCopies)
+getForcedNumCopies = Annex.getState Annex.forcenumcopies
+
+{- Numcopies value from any of the non-.gitattributes configuration
+ - sources. -}
+getNumCopies :: Annex NumCopies
+getNumCopies = fromSources
+	[ getForcedNumCopies
+	, getGlobalNumCopies
+	, deprecatedNumCopies
+	]
+
+{- Numcopies value for a file, from any configuration source, including the
+ - deprecated git config. -}
+getFileNumCopies :: FilePath -> Annex NumCopies
+getFileNumCopies f = fromSources
+	[ getForcedNumCopies
+	, getFileNumCopies' f
+	, deprecatedNumCopies
+	]
+
+getAssociatedFileNumCopies :: AssociatedFile -> Annex NumCopies
+getAssociatedFileNumCopies (AssociatedFile afile) =
+	maybe getNumCopies getFileNumCopies afile
+
+{- This is the globally visible numcopies value for a file. So it does
+ - not include local configuration in the git config or command line
+ - options. -}
+getGlobalFileNumCopies :: FilePath  -> Annex NumCopies
+getGlobalFileNumCopies f = fromSources
+	[ getFileNumCopies' f
+	]
+
+getFileNumCopies' :: FilePath  -> Annex (Maybe NumCopies)
+getFileNumCopies' file = maybe getGlobalNumCopies (return . Just) =<< getattr
+  where
+	getattr = (NumCopies <$$> readish)
+		<$> checkAttr "annex.numcopies" file
+
+{- Checks if numcopies are satisfied for a file by running a comparison
+ - between the number of (not untrusted) copies that are
+ - belived to exist, and the configured value.
+ -
+ - This is good enough for everything except dropping the file, which
+ - requires active verification of the copies.
+ -}
+numCopiesCheck :: FilePath -> Key -> (Int -> Int -> v) -> Annex v
+numCopiesCheck file key vs = do
+	have <- trustExclude UnTrusted =<< Remote.keyLocations key
+	numCopiesCheck' file vs have
+
+numCopiesCheck' :: FilePath -> (Int -> Int -> v) -> [UUID] -> Annex v
+numCopiesCheck' file vs have = do
+	NumCopies needed <- getFileNumCopies file
+	return $ length have `vs` needed
+
+data UnVerifiedCopy = UnVerifiedRemote Remote | UnVerifiedHere
+	deriving (Ord, Eq)
+
+{- Verifies that enough copies of a key exist amoung the listed remotes,
+ - to safely drop it, running an action with a proof if so, and
+ - printing an informative message if not.
+ -}
+verifyEnoughCopiesToDrop
+	:: String -- message to print when there are no known locations
+	-> Key
+	-> Maybe ContentRemovalLock
+	-> NumCopies
+	-> [UUID] -- repos to skip considering (generally untrusted remotes)
+	-> [VerifiedCopy] -- copies already verified to exist
+	-> [UnVerifiedCopy] -- places to check to see if they have copies
+	-> (SafeDropProof -> Annex a) -- action to perform the drop
+	-> Annex a -- action to perform when unable to drop
+	-> Annex a
+verifyEnoughCopiesToDrop nolocmsg key removallock need skip preverified tocheck dropaction nodropaction = 
+	helper [] [] preverified (nub tocheck)
+  where
+	helper bad missing have [] =
+		liftIO (mkSafeDropProof need have removallock) >>= \case
+			Right proof -> dropaction proof
+			Left stillhave -> do
+				notEnoughCopies key need stillhave (skip++missing) bad nolocmsg
+				nodropaction
+	helper bad missing have (c:cs)
+		| isSafeDrop need have removallock =
+			liftIO (mkSafeDropProof need have removallock) >>= \case
+				Right proof -> dropaction proof
+				Left stillhave -> helper bad missing stillhave (c:cs)
+		| otherwise = case c of
+			UnVerifiedHere -> lockContentShared key contverified
+			UnVerifiedRemote r -> checkremote r contverified $
+				Remote.hasKey r key >>= \case
+					Right True  -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy r : have) cs
+					Left _      -> helper (r:bad) missing have cs
+					Right False -> helper bad (Remote.uuid r:missing) have cs
+		  where
+			contverified vc = helper bad missing (vc : have) cs
+
+	checkremote r cont fallback = case Remote.lockContent r of
+		Just lockcontent -> do
+			-- The remote's lockContent will throw an exception
+			-- when it is unable to lock, in which case the
+			-- fallback should be run. 
+			--
+			-- On the other hand, the continuation could itself
+			-- throw an exception (ie, the eventual drop action
+			-- fails), and in this case we don't want to run the
+			-- fallback since part of the drop action may have
+			-- already been performed.
+			--
+			-- Differentiate between these two sorts
+			-- of exceptions by using DropException.
+			let a = lockcontent key $ \v -> 
+				cont v `catchNonAsync` (throw . DropException)
+			a `M.catches`
+				[ M.Handler (\ (e :: AsyncException) -> throwM e)
+#if MIN_VERSION_base(4,7,0)
+				, M.Handler (\ (e :: SomeAsyncException) -> throwM e)
+#endif
+				, M.Handler (\ (DropException e') -> throwM e')
+				, M.Handler (\ (_e :: SomeException) -> fallback)
+				]
+		Nothing -> fallback
+
+data DropException = DropException SomeException
+	deriving (Typeable, Show)
+
+instance Exception DropException
+
+notEnoughCopies :: Key -> NumCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> Annex ()
+notEnoughCopies key need have skip bad nolocmsg = do
+	showNote "unsafe"
+	if length have < fromNumCopies need
+		then showLongNote $
+			"Could only verify the existence of " ++
+			show (length have) ++ " out of " ++ show (fromNumCopies need) ++ 
+			" necessary copies"
+		else do
+			showLongNote "Unable to lock down 1 copy of file that is required to safely drop it."
+			showLongNote "(This could have happened because of a concurrent drop, or because a remote has too old a version of git-annex-shell installed.)"
+	Remote.showTriedRemotes bad
+	Remote.showLocations True key (map toUUID have++skip) nolocmsg
+
+{- Finds locations of a key that can be used to get VerifiedCopies,
+ - in order to allow dropping the key.
+ -
+ - Provide a list of UUIDs that the key is being dropped from.
+ - The returned lists will exclude any of those UUIDs.
+ -
+ - The return lists also exclude any repositories that are untrusted,
+ - since those should not be used for verification.
+ -
+ - The UnVerifiedCopy list is cost ordered.
+ - The VerifiedCopy list contains repositories that are trusted to
+ - contain the key.
+ -}
+verifiableCopies :: Key -> [UUID] -> Annex ([UnVerifiedCopy], [VerifiedCopy])
+verifiableCopies key exclude = do
+	locs <- Remote.keyLocations key
+	(remotes, trusteduuids) <- Remote.remoteLocations locs
+		=<< trustGet Trusted
+	untrusteduuids <- trustGet UnTrusted
+	let exclude' = exclude ++ untrusteduuids
+	let remotes' = Remote.remotesWithoutUUID remotes (exclude' ++ trusteduuids)
+	let verified = map (mkVerifiedCopy TrustedCopy) $
+		filter (`notElem` exclude') trusteduuids
+	u <- getUUID
+	let herec = if u `elem` locs && u `notElem` exclude'
+		then [UnVerifiedHere]
+		else []
+	return (herec ++ map UnVerifiedRemote remotes', verified)

Annex/Path.hs

@@ -0,0 +1,36 @@
+{- git-annex program path
+ -
+ - Copyright 2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Path where
+
+import Common
+import Config.Files
+import Utility.Env
+
+import System.Environment (getExecutablePath)
+
+{- A fully qualified path to the currently running git-annex program.
+ - 
+ - getExecutablePath is used when possible. On OSs it supports
+ - well, it returns the complete path to the program. But, on other OSs,
+ - it might return just the basename. Fall back to reading the programFile,
+ - or searching for the command name in PATH.
+ -
+ - The standalone build runs git-annex via ld.so, and defeats
+ - getExecutablePath. It sets GIT_ANNEX_PROGRAMPATH to the correct path
+ - to the wrapper script to use.
+ -}
+programPath :: IO FilePath
+programPath = go =<< getEnv "GIT_ANNEX_PROGRAMPATH"
+  where
+	go (Just p) = return p
+	go Nothing = do
+		exe <- getExecutablePath
+		p <- if isAbsolute exe
+			then return exe
+			else readProgramFile
+		maybe cannotFindProgram return =<< searchPath p

Annex/Perms.hs

@@ -0,0 +1,187 @@
+{- git-annex file permissions
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Perms (
+	FileMode,
+	setAnnexFilePerm,
+	setAnnexDirPerm,
+	annexFileMode,
+	createAnnexDirectory,
+	noUmask,
+	freezeContent,
+	isContentWritePermOk,
+	thawContent,
+	chmodContent,
+	createContentDir,
+	freezeContentDir,
+	thawContentDir,
+	modifyContent,
+	withShared,
+) where
+
+import Annex.Common
+import Utility.FileMode
+import Git.ConfigTypes
+import qualified Annex
+import Config
+
+withShared :: (SharedRepository -> Annex a) -> Annex a
+withShared a = a =<< coreSharedRepository <$> Annex.getGitConfig
+
+setAnnexFilePerm :: FilePath -> Annex ()
+setAnnexFilePerm = setAnnexPerm False
+
+setAnnexDirPerm :: FilePath -> Annex ()
+setAnnexDirPerm = setAnnexPerm True
+
+{- Sets appropriate file mode for a file or directory in the annex,
+ - other than the content files and content directory. Normally,
+ - use the default mode, but with core.sharedRepository set,
+ - allow the group to write, etc. -}
+setAnnexPerm :: Bool -> FilePath -> Annex ()
+setAnnexPerm isdir file = unlessM crippledFileSystem $
+	withShared $ liftIO . go
+  where
+	go GroupShared = void $ tryIO $ modifyFileMode file $ addModes $
+		groupSharedModes ++
+		if isdir then [ ownerExecuteMode, groupExecuteMode ] else []
+	go AllShared = void $ tryIO $ modifyFileMode file $ addModes $
+		readModes ++
+		[ ownerWriteMode, groupWriteMode ] ++
+		if isdir then executeModes else []
+	go _ = noop
+
+{- Gets the appropriate mode to use for creating a file in the annex
+ - (other than content files, which are locked down more). -}
+annexFileMode :: Annex FileMode
+annexFileMode = withShared $ return . go
+  where
+	go GroupShared = sharedmode
+	go AllShared = combineModes (sharedmode:readModes)
+	go _ = stdFileMode
+	sharedmode = combineModes groupSharedModes
+
+{- Creates a directory inside the gitAnnexDir, including any parent
+ - directories. Makes directories with appropriate permissions. -}
+createAnnexDirectory :: FilePath -> Annex ()
+createAnnexDirectory dir = walk dir [] =<< top
+  where
+	top = parentDir <$> fromRepo gitAnnexDir
+	walk d below stop
+		| d `equalFilePath` stop = done
+		| otherwise = ifM (liftIO $ doesDirectoryExist d)
+			( done
+			, walk (parentDir d) (d:below) stop
+			)
+	  where
+		done = forM_ below $ \p -> do
+			liftIO $ createDirectoryIfMissing True p
+			setAnnexDirPerm p
+
+{- Normally, blocks writing to an annexed file, and modifies file
+ - permissions to allow reading it.
+ -
+ - When core.sharedRepository is set, the write bits are not removed from
+ - the file, but instead the appropriate group write bits are set. This is
+ - necessary to let other users in the group lock the file. But, in a
+ - shared repository, the current user may not be able to change a file
+ - owned by another user, so failure to set this mode is ignored.
+ -}
+freezeContent :: FilePath -> Annex ()
+freezeContent file = unlessM crippledFileSystem $
+	withShared go
+  where
+	go GroupShared = liftIO $ void $ tryIO $ modifyFileMode file $
+		addModes [ownerReadMode, groupReadMode, ownerWriteMode, groupWriteMode]
+	go AllShared = liftIO $ void $ tryIO $ modifyFileMode file $
+		addModes (readModes ++ writeModes)
+	go _ = liftIO $ modifyFileMode file $
+		removeModes writeModes .
+		addModes [ownerReadMode]
+
+isContentWritePermOk :: FilePath -> Annex Bool
+isContentWritePermOk file = ifM crippledFileSystem
+	( return True
+	, withShared go
+	)
+  where
+	go GroupShared = want [ownerWriteMode, groupWriteMode]
+	go AllShared = want writeModes
+	go _ = return True
+	want wantmode =
+		liftIO (catchMaybeIO $ fileMode <$> getFileStatus file) >>= return . \case
+			Nothing -> True
+			Just havemode -> havemode == combineModes (havemode:wantmode)
+
+{- Adjusts read mode of annexed file per core.sharedRepository setting. -}
+chmodContent :: FilePath -> Annex ()
+chmodContent file = unlessM crippledFileSystem $
+	withShared go
+  where
+	go GroupShared = liftIO $ void $ tryIO $ modifyFileMode file $
+		addModes [ownerReadMode, groupReadMode]
+	go AllShared = liftIO $ void $ tryIO $ modifyFileMode file $
+		addModes readModes
+	go _ = liftIO $ modifyFileMode file $
+		addModes [ownerReadMode]
+
+{- Allows writing to an annexed file that freezeContent was called on
+ - before. -}
+thawContent :: FilePath -> Annex ()
+thawContent file = thawPerms $ withShared go
+  where
+	go GroupShared = liftIO $ void $ tryIO $ groupWriteRead file
+	go AllShared = liftIO $ void $ tryIO $ groupWriteRead file
+	go _ = liftIO $ allowWrite file
+
+{- Runs an action that thaws a file's permissions. This will probably
+ - fail on a crippled filesystem. But, if file modes are supported on a
+ - crippled filesystem, the file may be frozen, so try to thaw it. -}
+thawPerms :: Annex () -> Annex ()
+thawPerms a = ifM crippledFileSystem
+	( void $ tryNonAsync a
+	, a
+	)
+
+{- Blocks writing to the directory an annexed file is in, to prevent the
+ - file accidentally being deleted. However, if core.sharedRepository
+ - is set, this is not done, since the group must be allowed to delete the
+ - file.
+ -}
+freezeContentDir :: FilePath -> Annex ()
+freezeContentDir file = unlessM crippledFileSystem $
+	withShared go
+  where
+	dir = parentDir file
+	go GroupShared = liftIO $ void $ tryIO $ groupWriteRead dir
+	go AllShared = liftIO $ void $ tryIO $ groupWriteRead dir
+	go _ = liftIO $ preventWrite dir
+
+thawContentDir :: FilePath -> Annex ()
+thawContentDir file = thawPerms $ liftIO $ allowWrite $ parentDir file
+
+{- Makes the directory tree to store an annexed file's content,
+ - with appropriate permissions on each level. -}
+createContentDir :: FilePath -> Annex ()
+createContentDir dest = do
+	unlessM (liftIO $ doesDirectoryExist dir) $
+		createAnnexDirectory dir 
+	-- might have already existed with restricted perms
+	unlessM crippledFileSystem $
+		liftIO $ allowWrite dir
+  where
+	dir = parentDir dest
+
+{- Creates the content directory for a file if it doesn't already exist,
+ - or thaws it if it does, then runs an action to modify the file, and
+ - finally, freezes the content directory. -}
+modifyContent :: FilePath -> Annex a -> Annex a
+modifyContent f a = do
+	createContentDir f -- also thaws it
+	v <- tryNonAsync a
+	freezeContentDir f
+	either throwM return v

Annex/Queue.hs

@@ -0,0 +1,79 @@
+{- git-annex command queue
+ -
+ - Copyright 2011, 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns #-}
+
+module Annex.Queue (
+	addCommand,
+	addUpdateIndex,
+	flush,
+	flushWhenFull,
+	size,
+	get,
+	mergeFrom,
+) where
+
+import Annex.Common
+import Annex hiding (new)
+import qualified Git.Queue
+import qualified Git.UpdateIndex
+
+{- Adds a git command to the queue. -}
+addCommand :: String -> [CommandParam] -> [FilePath] -> Annex ()
+addCommand command params files = do
+	q <- get
+	store <=< flushWhenFull <=< inRepo $
+		Git.Queue.addCommand command params files q
+
+{- Adds an update-index stream to the queue. -}
+addUpdateIndex :: Git.UpdateIndex.Streamer -> Annex ()
+addUpdateIndex streamer = do
+	q <- get
+	store <=< flushWhenFull <=< inRepo $
+		Git.Queue.addUpdateIndex streamer q
+
+{- Runs the queue if it is full. -}
+flushWhenFull :: Git.Queue.Queue -> Annex Git.Queue.Queue
+flushWhenFull q
+	| Git.Queue.full q = flush' q
+	| otherwise = return q
+
+{- Runs (and empties) the queue. -}
+flush :: Annex ()
+flush = do
+	q <- get
+	unless (0 == Git.Queue.size q) $ do
+		store =<< flush' q
+
+flush' :: Git.Queue.Queue -> Annex Git.Queue.Queue
+flush' q = do
+	showStoringStateAction
+	inRepo $ Git.Queue.flush q
+
+{- Gets the size of the queue. -}
+size :: Annex Int
+size = Git.Queue.size <$> get
+
+get :: Annex Git.Queue.Queue
+get = maybe new return =<< getState repoqueue
+
+new :: Annex Git.Queue.Queue
+new = do
+	q <- Git.Queue.new . annexQueueSize <$> getGitConfig
+	store q
+	return q
+
+store :: Git.Queue.Queue -> Annex ()
+store q = changeState $ \s -> s { repoqueue = Just q }
+
+mergeFrom :: AnnexState -> Annex ()
+mergeFrom st = case repoqueue st of
+	Nothing -> noop
+	Just newq -> do
+		q <- get
+		let !q' = Git.Queue.merge q newq
+		store =<< flushWhenFull q'

Annex/ReplaceFile.hs

@@ -0,0 +1,55 @@
+{- git-annex file replacing
+ -
+ - Copyright 2013-2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.ReplaceFile where
+
+import Annex.Common
+import Annex.Perms
+import Utility.Tmp.Dir
+import Utility.Path.Max
+
+{- Replaces a possibly already existing file with a new version, 
+ - atomically, by running an action.
+ - 
+ - The action is passed the name of temp file, in a temp directory, 
+ - which it can write to, and once done the temp file is moved into place
+ - and anything else in the temp directory is deleted.
+ -
+ - The action can throw an exception, in which case the temp directory
+ - will be deleted, and the existing file will be preserved.
+ -
+ - Throws an IO exception when it was unable to replace the file.
+ -}
+replaceFile :: FilePath -> (FilePath -> Annex ()) -> Annex ()
+replaceFile file action = do
+	misctmpdir <- fromRepo gitAnnexTmpMiscDir
+	void $ createAnnexDirectory misctmpdir
+#ifndef mingw32_HOST_OS
+	-- Use part of the filename as the template for the temp
+	-- directory. This does not need to be unique, but it
+	-- makes it more clear what this temp directory is for.
+	filemax <- liftIO $ fileNameLengthLimit misctmpdir
+	let basetmp = take (filemax `div` 2) (takeFileName file)
+#else
+	-- Windows has limits on the whole path length, so keep
+	-- it short.
+	let basetmp = "t"
+#endif
+	withTmpDirIn misctmpdir basetmp $ \tmpdir -> do
+		let tmpfile = tmpdir </> basetmp
+		action tmpfile
+		liftIO $ replaceFileFrom tmpfile file
+
+replaceFileFrom :: FilePath -> FilePath -> IO ()
+replaceFileFrom src dest = go `catchIO` fallback
+  where
+	go = moveFile src dest
+	fallback _ = do
+		createDirectoryIfMissing True $ parentDir dest
+		go

Annex/SpecialRemote.hs

@@ -0,0 +1,91 @@
+{- git-annex special remote configuration
+ -
+ - Copyright 2011-2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.SpecialRemote where
+
+import Annex.Common
+import Remote (remoteTypes, remoteMap)
+import Types.Remote (RemoteConfig, RemoteConfigKey, SetupStage(..), typename, setup)
+import Types.GitConfig
+import Logs.Remote
+import Logs.Trust
+import qualified Git.Config
+import Git.Types (RemoteName)
+
+import qualified Data.Map as M
+import Data.Ord
+
+{- See if there's an existing special remote with this name.
+ -
+ - Prefer remotes that are not dead when a name appears multiple times. -}
+findExisting :: RemoteName -> Annex (Maybe (UUID, RemoteConfig))
+findExisting name = do
+	t <- trustMap
+	headMaybe
+		. sortBy (comparing $ \(u, _c) -> Down $ M.lookup u t)
+		. findByName name
+		<$> Logs.Remote.readRemoteLog
+
+newConfig :: RemoteName -> RemoteConfig
+newConfig = M.singleton nameKey
+
+findByName :: RemoteName ->  M.Map UUID RemoteConfig -> [(UUID, RemoteConfig)]
+findByName n = filter (matching . snd) . M.toList
+  where
+	matching c = case M.lookup nameKey c of
+		Nothing -> False
+		Just n'
+			| n' == n -> True
+			| otherwise -> False
+
+specialRemoteMap :: Annex (M.Map UUID RemoteName)
+specialRemoteMap = do
+	m <- Logs.Remote.readRemoteLog
+	return $ M.fromList $ mapMaybe go (M.toList m)
+  where
+	go (u, c) = case M.lookup nameKey c of
+		Nothing -> Nothing
+		Just n -> Just (u, n)
+
+{- find the specified remote type -}
+findType :: RemoteConfig -> Either String RemoteType
+findType config = maybe unspecified specified $ M.lookup typeKey config
+  where
+	unspecified = Left "Specify the type of remote with type="
+	specified s = case filter (findtype s) remoteTypes of
+		[] -> Left $ "Unknown remote type " ++ s
+		(t:_) -> Right t
+	findtype s i = typename i == s
+
+{- The name of a configured remote is stored in its config using this key. -}
+nameKey :: RemoteConfigKey
+nameKey = "name"
+
+{- The type of a remote is stored in its config using this key. -}
+typeKey :: RemoteConfigKey
+typeKey = "type"
+
+autoEnableKey :: RemoteConfigKey
+autoEnableKey = "autoenable"
+
+autoEnable :: Annex ()
+autoEnable = do
+	remotemap <- M.filter configured <$> readRemoteLog
+	enabled <- remoteMap id
+	forM_ (M.toList remotemap) $ \(u, c) -> unless (u `M.member` enabled) $ do
+		case (M.lookup nameKey c, findType c) of
+			(Just name, Right t) -> whenM (canenable u) $ do
+				showSideAction $ "Auto enabling special remote " ++ name
+				dummycfg <- liftIO dummyRemoteGitConfig
+				tryNonAsync (setup t (Enable c) (Just u) Nothing c dummycfg) >>= \case
+					Left e -> warning (show e)
+					Right _ -> return ()
+			_ -> return ()
+  where
+	configured rc = fromMaybe False $
+		Git.Config.isTrue =<< M.lookup autoEnableKey rc
+	canenable u = (/= DeadTrusted) <$> lookupTrust u

Annex/Ssh.hs

@@ -0,0 +1,429 @@
+{- git-annex ssh interface, with connection caching
+ -
+ - Copyright 2012-2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Ssh (
+	ConsumeStdin(..),
+	SshCommand,
+	sshCommand,
+	sshOptions,
+	sshCacheDir,
+	sshReadPort,
+	forceSshCleanup,
+	sshOptionsEnv,
+	sshOptionsTo,
+	inRepoWithSshOptionsTo,
+	runSshOptions,
+	sshAskPassEnv,
+	runSshAskPass
+) where
+
+import Annex.Common
+import Annex.LockFile
+import qualified BuildInfo
+import qualified Annex
+import qualified Git
+import qualified Git.Url
+import Config
+import Annex.Path
+import Utility.Env
+import Utility.FileSystemEncoding
+import Utility.Hash
+import Types.CleanupActions
+import Types.Concurrency
+import Git.Env
+import Git.Ssh
+#ifndef mingw32_HOST_OS
+import Annex.Perms
+import Annex.LockPool
+#endif
+
+import Control.Concurrent.STM
+
+{- Some ssh commands are fed stdin on a pipe and so should be allowed to
+ - consume it. But ssh commands that are not piped stdin should generally
+ - not be allowed to consume the process's stdin. -}
+data ConsumeStdin = ConsumeStdin | NoConsumeStdin
+
+{- Generates a command to ssh to a given host (or user@host) on a given
+ - port. This includes connection caching parameters, and any ssh-options.
+ - If GIT_SSH or GIT_SSH_COMMAND is enabled, they are used instead. -}
+sshCommand :: ConsumeStdin -> (SshHost, Maybe SshPort) -> RemoteGitConfig -> SshCommand -> Annex (FilePath, [CommandParam])
+sshCommand cs (host, port) gc remotecmd = ifM (liftIO safe_GIT_SSH)
+	( maybe go return
+		=<< liftIO (gitSsh' host port remotecmd (consumeStdinParams cs))
+	, go
+	)
+  where
+	go = do
+		ps <- sshOptions cs (host, port) gc []
+		return ("ssh", Param (fromSshHost host):ps++[Param remotecmd])
+
+{- Generates parameters to ssh to a given host (or user@host) on a given
+ - port. This includes connection caching parameters, and any
+ - ssh-options. Note that the host to ssh to and the command to run
+ - are not included in the returned options. -}
+sshOptions :: ConsumeStdin -> (SshHost, Maybe Integer) -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam]
+sshOptions cs (host, port) gc opts = go =<< sshCachingInfo (host, port)
+  where
+	go (Nothing, params) = return $ mkparams cs params
+	go (Just socketfile, params) = do
+		prepSocket socketfile host (mkparams NoConsumeStdin params)
+			
+		return $ mkparams cs params
+	mkparams cs' ps = concat
+		[ ps
+		, map Param (remoteAnnexSshOptions gc)
+		, opts
+		, portParams port
+		, consumeStdinParams cs'
+		, [Param "-T"]
+		]
+
+{- Due to passing -n to GIT_SSH and GIT_SSH_COMMAND, some settings
+ - of those that expect exactly git's parameters will break. So only
+ - use those if the user set GIT_ANNEX_USE_GIT_SSH to say it's ok. -}
+safe_GIT_SSH :: IO Bool
+safe_GIT_SSH = (== Just "1") <$> getEnv "GIT_ANNEX_USE_GIT_SSH"
+
+consumeStdinParams :: ConsumeStdin -> [CommandParam]
+consumeStdinParams ConsumeStdin = []
+consumeStdinParams NoConsumeStdin = [Param "-n"]
+
+{- Returns a filename to use for a ssh connection caching socket, and
+ - parameters to enable ssh connection caching. -}
+sshCachingInfo :: (SshHost, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam])
+sshCachingInfo (host, port) = go =<< sshCacheDir
+  where
+	go Nothing = return (Nothing, [])
+	go (Just dir) =
+		liftIO (bestSocketPath $ dir </> hostport2socket host port) >>= return . \case
+			Nothing -> (Nothing, [])
+			Just socketfile -> (Just socketfile, sshConnectionCachingParams socketfile)
+
+{- Given an absolute path to use for a socket file,
+ - returns whichever is shorter of that or the relative path to the same
+ - file.
+ -
+ - If no path can be constructed that is a valid socket, returns Nothing. -}
+bestSocketPath :: FilePath -> IO (Maybe FilePath)
+bestSocketPath abssocketfile = do
+	relsocketfile <- liftIO $ relPathCwdToFile abssocketfile
+	let socketfile = if length abssocketfile <= length relsocketfile
+		then abssocketfile
+		else relsocketfile
+	return $ if valid_unix_socket_path (socketfile ++ sshgarbage)
+			then Just socketfile
+			else Nothing
+  where
+	-- ssh appends a 16 char extension to the socket when setting it
+	-- up, which needs to be taken into account when checking
+	-- that a valid socket was constructed.
+	sshgarbage = replicate (1+16) 'X'
+
+sshConnectionCachingParams :: FilePath -> [CommandParam]
+sshConnectionCachingParams socketfile = 
+	[ Param "-S", Param socketfile
+	, Param "-o", Param "ControlMaster=auto"
+	, Param "-o", Param "ControlPersist=yes"
+	]
+
+{- ssh connection caching creates sockets, so will not work on a
+ - crippled filesystem. A GIT_ANNEX_TMP_DIR can be provided to use
+ - a different filesystem. -}
+sshCacheDir :: Annex (Maybe FilePath)
+sshCacheDir
+	| BuildInfo.sshconnectioncaching = 
+		ifM (fromMaybe True . annexSshCaching <$> Annex.getGitConfig)
+			( ifM crippledFileSystem
+				( maybe (return Nothing) usetmpdir =<< gettmpdir
+				, Just <$> fromRepo gitAnnexSshDir 
+				)
+			, return Nothing
+			)
+	| otherwise = return Nothing
+  where
+	gettmpdir = liftIO $ getEnv "GIT_ANNEX_TMP_DIR"
+	usetmpdir tmpdir = liftIO $ catchMaybeIO $ do
+		let socktmp = tmpdir </> "ssh"
+		createDirectoryIfMissing True socktmp
+		return socktmp
+
+portParams :: Maybe Integer -> [CommandParam]
+portParams Nothing = []
+portParams (Just port) = [Param "-p", Param $ show port]
+
+{- Prepare to use a socket file for ssh connection caching.
+ -
+ - When concurrency is enabled, this blocks until a ssh connection
+ - has been made to the host. So, any password prompting by ssh will
+ - happen in this call, and only one ssh process will prompt at a time.
+ -
+ - Locks the socket lock file to prevent other git-annex processes from
+ - stopping the ssh multiplexer on this socket.
+ -}
+prepSocket :: FilePath -> SshHost -> [CommandParam] -> Annex ()
+prepSocket socketfile sshhost sshparams = do
+	-- There could be stale ssh connections hanging around
+	-- from a previous git-annex run that was interrupted.
+	-- This must run only once, before we have made any ssh connection,
+	-- and any other prepSocket calls must block while it's run.
+	tv <- Annex.getState Annex.sshstalecleaned
+	join $ liftIO $ atomically $ do
+		cleaned <- takeTMVar tv
+		if cleaned
+			then do
+				putTMVar tv cleaned
+				return noop
+			else return $ do
+				sshCleanup
+				liftIO $ atomically $ putTMVar tv True
+	-- Cleanup at shutdown.
+	Annex.addCleanup SshCachingCleanup sshCleanup
+	
+	liftIO $ createDirectoryIfMissing True $ parentDir socketfile
+	let socketlock = socket2lock socketfile
+
+	Annex.getState Annex.concurrency >>= \case
+		Concurrent {} -> makeconnection socketlock
+		_ -> return ()
+	
+	lockFileCached socketlock
+  where
+	-- When the LockCache already has the socketlock in it,
+	-- the connection has already been started. Otherwise,
+	-- get the connection started now.
+	makeconnection socketlock =
+		whenM (isNothing <$> fromLockCache socketlock) $
+			-- See if ssh can connect in batch mode,
+			-- if so there's no need to block for a password
+			-- prompt.
+			unlessM (tryssh ["-o", "BatchMode=true"]) $
+				-- ssh needs to prompt (probably)
+				-- If the user enters the wrong password,
+				-- ssh will tell them, so we can ignore
+				-- failure.
+				void $ prompt $ tryssh []
+	-- Try to ssh to the host quietly. Returns True if ssh apparently
+	-- connected to the host successfully. If ssh failed to connect,
+	-- returns False.
+	-- Even if ssh is forced to run some specific command, this will
+	-- return True.
+	-- (Except there's an unlikely false positive where a forced
+	-- ssh command exits 255.)
+	tryssh extraps = liftIO $ withNullHandle $ \nullh -> do
+		let p = proc "ssh" $ concat
+			[ extraps
+			, toCommand sshparams
+			, [fromSshHost sshhost, "true"]
+			]
+		(Nothing, Nothing, Nothing, pid) <- createProcess $ p
+			{ std_out = UseHandle nullh
+			, std_err = UseHandle nullh
+			}
+		exitcode <- waitForProcess pid
+		return $ case exitcode of
+			ExitFailure 255 -> False
+			_ -> True
+
+{- Find ssh socket files.
+ -
+ - The check that the lock file exists makes only socket files
+ - that were set up by prepSocket be found. On some NFS systems,
+ - a deleted socket file may linger for a while under another filename;
+ - and this check makes such files be skipped since the corresponding lock
+ - file won't exist.
+ -}
+enumSocketFiles :: Annex [FilePath]
+enumSocketFiles = liftIO . go =<< sshCacheDir
+  where
+	go Nothing = return []
+	go (Just dir) = filterM (doesFileExist . socket2lock)
+		=<< filter (not . isLock)
+		<$> catchDefaultIO [] (dirContents dir)
+
+{- Stop any unused ssh connection caching processes. -}
+sshCleanup :: Annex ()
+sshCleanup = mapM_ cleanup =<< enumSocketFiles
+  where
+	cleanup socketfile = do
+#ifndef mingw32_HOST_OS
+		-- Drop any shared lock we have, and take an
+		-- exclusive lock, without blocking. If the lock
+		-- succeeds, nothing is using this ssh, and it can
+		-- be stopped.
+		--
+		-- After ssh is stopped cannot remove the lock file;
+		-- other processes may be waiting on our exclusive
+		-- lock to use it.
+		let lockfile = socket2lock socketfile
+		unlockFile lockfile
+		mode <- annexFileMode
+		noUmask mode (tryLockExclusive (Just mode) lockfile) >>= \case
+			Nothing -> noop
+			Just lck -> do
+				forceStopSsh socketfile
+				liftIO $ dropLock lck
+#else
+		forceStopSsh socketfile
+#endif
+
+{- Stop all ssh connection caching processes, even when they're in use. -}
+forceSshCleanup :: Annex ()
+forceSshCleanup = mapM_ forceStopSsh =<< enumSocketFiles
+
+forceStopSsh :: FilePath -> Annex ()
+forceStopSsh socketfile = do
+	let (dir, base) = splitFileName socketfile
+	let params = sshConnectionCachingParams base
+	-- "ssh -O stop" is noisy on stderr even with -q
+	void $ liftIO $ catchMaybeIO $
+		withQuietOutput createProcessSuccess $
+			(proc "ssh" $ toCommand $
+				[ Param "-O", Param "stop" ] ++ 
+				params ++ [Param "localhost"])
+				{ cwd = Just dir }
+	liftIO $ nukeFile socketfile
+
+{- This needs to be as short as possible, due to limitations on the length
+ - of the path to a socket file. At the same time, it needs to be unique
+ - for each host.
+ -}
+hostport2socket :: SshHost -> Maybe Integer -> FilePath
+hostport2socket host Nothing = hostport2socket' $ fromSshHost host
+hostport2socket host (Just port) = hostport2socket' $
+	fromSshHost host ++ "!" ++ show port
+hostport2socket' :: String -> FilePath
+hostport2socket' s
+	| length s > lengthofmd5s = show $ md5 $ encodeBS s
+	| otherwise = s
+  where
+	lengthofmd5s = 32
+
+socket2lock :: FilePath -> FilePath
+socket2lock socket = socket ++ lockExt
+
+isLock :: FilePath -> Bool
+isLock f = lockExt `isSuffixOf` f
+
+lockExt :: String
+lockExt = ".lock"
+
+{- This is the size of the sun_path component of sockaddr_un, which
+ - is the limit to the total length of the filename of a unix socket.
+ -
+ - On Linux, this is 108. On OSX, 104. TODO: Probe
+ -}
+sizeof_sockaddr_un_sun_path :: Int
+sizeof_sockaddr_un_sun_path = 100
+
+{- Note that this looks at the true length of the path in bytes, as it will
+ - appear on disk. -}
+valid_unix_socket_path :: FilePath -> Bool
+valid_unix_socket_path f = length (decodeW8 f) < sizeof_sockaddr_un_sun_path
+
+{- Parses the SSH port, and returns the other OpenSSH options. If
+ - several ports are found, the last one takes precedence. -}
+sshReadPort :: [String] -> (Maybe Integer, [String])
+sshReadPort params = (port, reverse args)
+  where
+	(port,args) = aux (Nothing, []) params
+	aux (p,ps) [] = (p,ps)
+	aux (_,ps) ("-p":p:rest) = aux (readPort p, ps) rest
+	aux (p,ps) (q:rest) | "-p" `isPrefixOf` q = aux (readPort $ drop 2 q, ps) rest
+			    | otherwise = aux (p,q:ps) rest
+	readPort p = fmap fst $ listToMaybe $ reads p
+
+{- When this env var is set, git-annex runs ssh with the specified
+ - options. (The options are separated by newlines.)
+ -
+ - This is a workaround for GIT_SSH not being able to contain
+ - additional parameters to pass to ssh. (GIT_SSH_COMMAND can,
+ - but is not supported by older versions of git.) -}
+sshOptionsEnv :: String
+sshOptionsEnv = "GIT_ANNEX_SSHOPTION"
+
+toSshOptionsEnv :: [CommandParam] -> String
+toSshOptionsEnv = unlines . toCommand
+
+fromSshOptionsEnv :: String -> [CommandParam]
+fromSshOptionsEnv = map Param . lines
+
+{- Enables ssh caching for git push/pull to a particular
+ - remote git repo. (Can safely be used on non-ssh remotes.)
+ -
+ - Also propigates any configured ssh-options.
+ -
+ - Like inRepo, the action is run with the local git repo.
+ - But here it's a modified version, with gitEnv to set GIT_SSH=git-annex,
+ - and sshOptionsEnv set so that git-annex will know what socket
+ - file to use. -}
+inRepoWithSshOptionsTo :: Git.Repo -> RemoteGitConfig -> (Git.Repo -> IO a) -> Annex a
+inRepoWithSshOptionsTo remote gc a =
+	liftIO . a =<< sshOptionsTo remote gc =<< gitRepo
+
+{- To make any git commands be run with ssh caching enabled,
+ - and configured ssh-options alters the local Git.Repo's gitEnv
+ - to set GIT_SSH=git-annex, and set sshOptionsEnv when running git
+ - commands.
+ -
+ - If GIT_SSH or GIT_SSH_COMMAND are enabled, this has no effect. -}
+sshOptionsTo :: Git.Repo -> RemoteGitConfig -> Git.Repo -> Annex Git.Repo
+sshOptionsTo remote gc localr
+	| not (Git.repoIsUrl remote) || Git.repoIsHttp remote = unchanged
+	| otherwise = case Git.Url.hostuser remote of
+		Nothing -> unchanged
+		Just host -> ifM (liftIO $ safe_GIT_SSH <&&> gitSshEnvSet)
+			( unchanged
+			, do
+				let port = Git.Url.port remote
+				let sshhost = either error id (mkSshHost host)
+				(msockfile, cacheparams) <- sshCachingInfo (sshhost, port)
+				case msockfile of
+					Nothing -> use []
+					Just sockfile -> do
+						prepSocket sockfile sshhost $ concat
+							[ cacheparams
+							, map Param (remoteAnnexSshOptions gc)
+							, portParams port
+							, consumeStdinParams NoConsumeStdin
+							, [Param "-T"]
+							]
+						use cacheparams
+			)
+  where
+	unchanged = return localr
+
+	use opts = do
+		let sshopts = concat
+			[ opts
+			, map Param (remoteAnnexSshOptions gc)
+			]
+		if null sshopts
+			then unchanged
+			else do
+				command <- liftIO programPath
+				liftIO $ do
+					localr' <- addGitEnv localr sshOptionsEnv
+						(toSshOptionsEnv sshopts)
+					addGitEnv localr' gitSshEnv command
+
+runSshOptions :: [String] -> String -> IO ()
+runSshOptions args s = do
+	let args' = toCommand (fromSshOptionsEnv s) ++ args
+	let p = proc "ssh" args'
+	exitWith =<< waitForProcess . processHandle =<< createProcess p
+
+{- When this env var is set, git-annex is being used as a ssh-askpass
+ - program, and should read the password from the specified location,
+ - and output it for ssh to read. -}
+sshAskPassEnv :: String
+sshAskPassEnv = "GIT_ANNEX_SSHASKPASS"
+
+runSshAskPass :: FilePath -> IO ()
+runSshAskPass passfile = putStrLn =<< readFile passfile

Annex/TaggedPush.hs

@@ -0,0 +1,64 @@
+{- git-annex tagged pushes
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.TaggedPush where
+
+import Annex.Common
+import qualified Remote
+import qualified Annex.Branch
+import qualified Git
+import qualified Git.Ref
+import qualified Git.Command
+import qualified Git.Branch
+import Utility.Base64
+
+{- Converts a git branch into a branch that is tagged with a UUID, typically
+ - the UUID of the repo that will be pushing it, and possibly with other
+ - information.
+ -
+ - Pushing to branches on the remote that have our uuid in them is ugly,
+ - but it reserves those branches for pushing by us, and so our pushes will
+ - never conflict with other pushes.
+ -
+ - To avoid cluttering up the branch display, the branch is put under
+ - refs/synced/, rather than the usual refs/remotes/
+ -
+ - Both UUIDs and Base64 encoded data are always legal to be used in git
+ - refs, per git-check-ref-format.
+ -}
+toTaggedBranch :: UUID -> Maybe String -> Git.Branch -> Git.Ref
+toTaggedBranch u info b = Git.Ref $ intercalate "/" $ catMaybes
+	[ Just "refs/synced"
+	, Just $ fromUUID u
+	, toB64 <$> info
+	, Just $ Git.fromRef $ Git.Ref.base b
+	]
+
+fromTaggedBranch :: Git.Ref -> Maybe (UUID, Maybe String)
+fromTaggedBranch b = case splitc '/' $ Git.fromRef b of
+	("refs":"synced":u:info:_base) ->
+		Just (toUUID u, fromB64Maybe info)
+	("refs":"synced":u:_base) ->
+		Just (toUUID u, Nothing)
+	_ -> Nothing
+
+listTaggedBranches :: Annex [(Git.Sha, Git.Ref)]
+listTaggedBranches = filter (isJust . fromTaggedBranch . snd)
+	<$> inRepo Git.Ref.list
+
+taggedPush :: UUID -> Maybe String -> Git.Ref -> Remote -> Git.Repo -> IO Bool
+taggedPush u info branch remote = Git.Command.runBool
+	[ Param "push"
+	, Param $ Remote.name remote
+	{- Using forcePush here is safe because we "own" the tagged branch
+	 - we're pushing; it has no other writers. Ensures it is pushed
+	 - even if it has been rewritten by a transition. -}
+	, Param $ Git.Branch.forcePush $ refspec Annex.Branch.name
+	, Param $ refspec branch
+	]
+  where
+	refspec b = Git.fromRef b ++ ":" ++ Git.fromRef (toTaggedBranch u info b)

Annex/Transfer.hs

@@ -0,0 +1,282 @@
+{- git-annex transfers
+ -
+ - Copyright 2012-2018 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP, BangPatterns #-}
+
+module Annex.Transfer (
+	module X,
+	upload,
+	download,
+	runTransfer,
+	alwaysRunTransfer,
+	noRetry,
+	stdRetry,
+	pickRemote,
+) where
+
+import Annex.Common
+import qualified Annex
+import Logs.Transfer as X
+import Types.Transfer as X
+import Annex.Notification as X
+import Annex.Perms
+import Utility.Metered
+import Utility.ThreadScheduler
+import Annex.LockPool
+import Types.Key
+import qualified Types.Remote as Remote
+import Types.Concurrency
+
+import Control.Concurrent
+import qualified Data.Map.Strict as M
+import Data.Ord
+
+upload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v
+upload u key f d a _witness = guardHaveUUID u $ 
+	runTransfer (Transfer Upload u key) f d a
+
+download :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v
+download u key f d a _witness = guardHaveUUID u $
+	runTransfer (Transfer Download u key) f d a
+
+guardHaveUUID :: Observable v => UUID -> Annex v -> Annex v
+guardHaveUUID u a
+	| u == NoUUID = return observeFailure
+	| otherwise = a
+
+{- Runs a transfer action. Creates and locks the lock file while the
+ - action is running, and stores info in the transfer information
+ - file.
+ -
+ - If the transfer action returns False, the transfer info is 
+ - left in the failedTransferDir.
+ -
+ - If the transfer is already in progress, returns False.
+ -
+ - An upload can be run from a read-only filesystem, and in this case
+ - no transfer information or lock file is used.
+ -}
+runTransfer :: Observable v => Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
+runTransfer = runTransfer' False
+
+{- Like runTransfer, but ignores any existing transfer lock file for the
+ - transfer, allowing re-running a transfer that is already in progress.
+ -
+ - Note that this may result in confusing progress meter display in the
+ - webapp, if multiple processes are writing to the transfer info file. -}
+alwaysRunTransfer :: Observable v => Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
+alwaysRunTransfer = runTransfer' True
+
+runTransfer' :: Observable v => Bool -> Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
+runTransfer' ignorelock t afile retrydecider transferaction = checkSecureHashes t $ do
+	shouldretry <- retrydecider
+	info <- liftIO $ startTransferInfo afile
+	(meter, tfile, createtfile, metervar) <- mkProgressUpdater t info
+	mode <- annexFileMode
+	(lck, inprogress) <- prep tfile createtfile mode
+	if inprogress && not ignorelock
+		then do
+			showNote "transfer already in progress, or unable to take transfer lock"
+			return observeFailure
+		else do
+			v <- retry shouldretry info metervar $ transferaction meter
+			liftIO $ cleanup tfile lck
+			if observeBool v
+				then removeFailedTransfer t
+				else recordFailedTransfer t info
+			return v
+  where
+	prep :: FilePath -> Annex () -> FileMode -> Annex (Maybe LockHandle, Bool)
+#ifndef mingw32_HOST_OS
+	prep tfile createtfile mode = catchPermissionDenied (const prepfailed) $ do
+		let lck = transferLockFile tfile
+		createAnnexDirectory $ takeDirectory lck
+		tryLockExclusive (Just mode) lck >>= \case
+			Nothing -> return (Nothing, True)
+			Just lockhandle -> ifM (checkSaneLock lck lockhandle)
+				( do
+					createtfile
+					return (Just lockhandle, False)
+				, do
+					liftIO $ dropLock lockhandle
+					return (Nothing, True)
+				)
+#else
+	prep tfile createtfile _mode = catchPermissionDenied (const prepfailed) $ do
+		let lck = transferLockFile tfile
+		createAnnexDirectory $ takeDirectory lck
+		catchMaybeIO (liftIO $ lockExclusive lck) >>= \case
+			Nothing -> return (Nothing, False)
+			Just Nothing -> return (Nothing, True)
+			Just (Just lockhandle) -> do
+				createtfile
+				return (Just lockhandle, False)
+#endif
+	prepfailed = return (Nothing, False)
+
+	cleanup _ Nothing = noop
+	cleanup tfile (Just lockhandle) = do
+		let lck = transferLockFile tfile
+		void $ tryIO $ removeFile tfile
+#ifndef mingw32_HOST_OS
+		void $ tryIO $ removeFile lck
+		dropLock lockhandle
+#else
+		{- Windows cannot delete the lockfile until the lock
+		 - is closed. So it's possible to race with another
+		 - process that takes the lock before it's removed,
+		 - so ignore failure to remove.
+		 -}
+		dropLock lockhandle
+		void $ tryIO $ removeFile lck
+#endif
+	retry shouldretry oldinfo metervar run = tryNonAsync run >>= \case
+		Right v
+			| observeBool v -> return v
+			| otherwise -> checkretry
+		Left e -> do
+			warning (show e)
+			checkretry
+	  where
+		checkretry = do
+			b <- getbytescomplete metervar
+			let newinfo = oldinfo { bytesComplete = Just b }
+			ifM (shouldretry oldinfo newinfo)
+				( retry shouldretry newinfo metervar run
+				, return observeFailure
+				)
+	getbytescomplete metervar
+		| transferDirection t == Upload =
+			liftIO $ readMVar metervar
+		| otherwise = do
+			f <- fromRepo $ gitAnnexTmpObjectLocation (transferKey t)
+			liftIO $ catchDefaultIO 0 $ getFileSize f
+
+{- Avoid download and upload of keys with insecure content when
+ - annex.securehashesonly is configured.
+ -
+ - This is not a security check. Even if this let the content be
+ - downloaded, the actual security checks would prevent the content from
+ - being added to the repository. The only reason this is done here is to
+ - avoid transferring content that's going to be rejected anyway.
+ -
+ - We assume that, if annex.securehashesonly is set and the local repo
+ - still contains content using an insecure hash, remotes will likewise
+ - tend to be configured to reject it, so Upload is also prevented.
+ -}
+checkSecureHashes :: Observable v => Transfer -> Annex v -> Annex v
+checkSecureHashes t a
+	| cryptographicallySecure variety = a
+	| otherwise = ifM (annexSecureHashesOnly <$> Annex.getGitConfig)
+		( do
+			warning $ "annex.securehashesonly blocked transfer of " ++ formatKeyVariety variety ++ " key"
+			return observeFailure
+		, a
+		)
+  where
+	variety = keyVariety (transferKey t)
+
+type RetryDecider = Annex (TransferInfo -> TransferInfo -> Annex Bool)
+
+{- The first RetryDecider will be checked first; only if it says not to
+ - retry will the second one be checked. -}
+combineRetryDeciders :: RetryDecider -> RetryDecider -> RetryDecider
+combineRetryDeciders a b = do
+	ar <- a
+	br <- b
+	return $ \old new -> ar old new <||> br old new
+
+noRetry :: RetryDecider
+noRetry = pure $ \_ _ -> pure False
+
+stdRetry :: RetryDecider
+stdRetry = combineRetryDeciders forwardRetry configuredRetry
+
+{- Retries a transfer when it fails, as long as the failed transfer managed
+ - to send some data. -}
+forwardRetry :: RetryDecider
+forwardRetry = pure $ \old new -> pure $
+	fromMaybe 0 (bytesComplete old) < fromMaybe 0 (bytesComplete new)
+
+{- Retries a number of times with growing delays in between when enabled
+ - by git configuration. -}
+configuredRetry :: RetryDecider
+configuredRetry = do
+	retrycounter <- liftIO $ newMVar 0
+	return $ \_old new -> do
+		(maxretries, Seconds initretrydelay) <- getcfg $ 
+			Remote.gitconfig <$> transferRemote new
+		retries <- liftIO $ modifyMVar retrycounter $
+			\n -> return (n + 1, n + 1)
+		if retries < maxretries
+			then do
+				let retrydelay = Seconds (initretrydelay * 2^(retries-1))
+				showSideAction $ "Delaying " ++ show (fromSeconds retrydelay) ++ "s before retrying."
+				liftIO $ threadDelaySeconds retrydelay
+				return True
+			else return False
+  where
+	globalretrycfg = fromMaybe 0 . annexRetry
+		<$> Annex.getGitConfig
+	globalretrydelaycfg = fromMaybe (Seconds 1) . annexRetryDelay
+		<$> Annex.getGitConfig
+	getcfg Nothing = (,) <$> globalretrycfg <*> globalretrydelaycfg
+	getcfg (Just gc) = (,)
+		<$> maybe globalretrycfg return (remoteAnnexRetry gc)
+		<*> maybe globalretrydelaycfg return (remoteAnnexRetryDelay gc)
+
+{- Picks a remote from the list and tries a transfer to it. If the transfer
+ - does not succeed, goes on to try other remotes from the list.
+ -
+ - The list should already be ordered by remote cost, and is normally
+ - tried in order. However, when concurrent jobs are running, they will
+ - be assigned different remotes of the same cost when possible. This can
+ - increase total transfer speed.
+ -}
+pickRemote :: Observable v => [Remote] -> (Remote -> Annex v) -> Annex v
+pickRemote l a = go l =<< Annex.getState Annex.concurrency
+  where
+	go [] _ = return observeFailure
+	go (r:[]) _ = a r
+	go rs (Concurrent n) | n > 1 = do
+		mv <- Annex.getState Annex.activeremotes
+		active <- liftIO $ takeMVar mv
+		let rs' = sortBy (lessActiveFirst active) rs
+		goconcurrent mv active rs'
+	go (r:rs) _ = do
+		ok <- a r
+		if observeBool ok
+			then return ok
+			else go rs NonConcurrent
+	goconcurrent mv active [] = do
+		liftIO $ putMVar mv active
+		return observeFailure
+	goconcurrent mv active (r:rs) = do
+		let !active' = M.insertWith (+) r 1 active
+		liftIO $ putMVar mv active'
+		let getnewactive = do
+			active'' <- liftIO $ takeMVar mv
+			let !active''' = M.update (\n -> if n > 1 then Just (n-1) else Nothing) r active''
+			return active'''
+		let removeactive = liftIO . putMVar mv =<< getnewactive
+		ok <- a r `onException` removeactive
+		if observeBool ok
+			then do
+				removeactive
+				return ok 
+			else do
+				active'' <- getnewactive
+				-- Re-sort the remaining rs 
+				-- because other threads could have
+				-- been assigned them in the meantime.
+				let rs' = sortBy (lessActiveFirst active'') rs
+				goconcurrent mv active'' rs'
+
+lessActiveFirst :: M.Map Remote Integer -> Remote -> Remote -> Ordering
+lessActiveFirst active a b
+	| Remote.cost a == Remote.cost b = comparing (`M.lookup` active) a b
+	| otherwise = comparing Remote.cost a b

Annex/UUID.hs

@@ -0,0 +1,124 @@
+{- git-annex uuids
+ -
+ - Each git repository used by git-annex has an annex.uuid setting that
+ - uniquely identifies that repository.
+ -
+ - UUIDs of remotes are cached in git config, using keys named
+ - remote.<name>.annex-uuid
+ -
+ - Copyright 2010-2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.UUID (
+	getUUID,
+	getRepoUUID,
+	getUncachedUUID,
+	isUUIDConfigured,
+	prepUUID,
+	genUUID,
+	genUUIDInNameSpace,
+	gCryptNameSpace,
+	removeRepoUUID,
+	storeUUID,
+	storeUUIDIn,
+	setUUID,
+	webUUID,
+	bitTorrentUUID,
+) where
+
+import Annex.Common
+import qualified Annex
+import qualified Git
+import qualified Git.Config
+import Config
+
+import qualified Data.UUID as U
+import qualified Data.UUID.V4 as U4
+import qualified Data.UUID.V5 as U5
+import Utility.FileSystemEncoding
+
+configkey :: ConfigKey
+configkey = annexConfig "uuid"
+
+{- Generates a random UUID, that does not include the MAC address. -}
+genUUID :: IO UUID
+genUUID = UUID . show <$> U4.nextRandom
+
+{- Generates a UUID from a given string, using a namespace.
+ - Given the same namespace, the same string will always result
+ - in the same UUID. -}
+genUUIDInNameSpace :: U.UUID -> String -> UUID
+genUUIDInNameSpace namespace = UUID . show . U5.generateNamed namespace . s2w8
+
+{- Namespace used for UUIDs derived from git-remote-gcrypt ids. -}
+gCryptNameSpace :: U.UUID
+gCryptNameSpace = U5.generateNamed U5.namespaceURL $
+	s2w8 "http://git-annex.branchable.com/design/gcrypt/" 
+
+{- Get current repository's UUID. -}
+getUUID :: Annex UUID
+getUUID = annexUUID <$> Annex.getGitConfig 
+
+{- Looks up a remote repo's UUID, caching it in .git/config if
+ - it's not already. -}
+getRepoUUID :: Git.Repo -> Annex UUID
+getRepoUUID r = do
+	c <- toUUID <$> getConfig cachekey ""
+	let u = getUncachedUUID r
+	
+	if c /= u && u /= NoUUID
+		then do
+			updatecache u
+			return u
+		else return c
+  where
+	updatecache u = do
+		g <- gitRepo
+		when (g /= r) $ storeUUIDIn cachekey u
+	cachekey = remoteConfig r "uuid"
+
+removeRepoUUID :: Annex ()
+removeRepoUUID = do
+	unsetConfig configkey
+	storeUUID NoUUID
+
+getUncachedUUID :: Git.Repo -> UUID
+getUncachedUUID = toUUID . Git.Config.get key ""
+  where
+	(ConfigKey key) = configkey
+
+-- Does the repo's config have a key for the UUID?
+-- True even when the key has no value.
+isUUIDConfigured :: Git.Repo -> Bool
+isUUIDConfigured = isJust . Git.Config.getMaybe key 
+  where
+	(ConfigKey key) = configkey
+
+{- Make sure that the repo has an annex.uuid setting. -}
+prepUUID :: Annex ()
+prepUUID = whenM ((==) NoUUID <$> getUUID) $
+	storeUUID =<< liftIO genUUID
+
+storeUUID :: UUID -> Annex ()
+storeUUID u = do
+	Annex.changeGitConfig $ \c -> c { annexUUID = u }
+	storeUUIDIn configkey u
+
+storeUUIDIn :: ConfigKey -> UUID -> Annex ()
+storeUUIDIn configfield = setConfig configfield . fromUUID
+
+{- Only sets the configkey in the Repo; does not change .git/config -}
+setUUID :: Git.Repo -> UUID -> IO Git.Repo
+setUUID r u = do
+	let s = show configkey ++ "=" ++ fromUUID u
+	Git.Config.store s r
+
+-- Dummy uuid for the whole web. Do not alter.
+webUUID :: UUID
+webUUID = UUID "00000000-0000-0000-0000-000000000001"
+
+-- Dummy uuid for bittorrent. Do not alter.
+bitTorrentUUID :: UUID
+bitTorrentUUID = UUID "00000000-0000-0000-0000-000000000002"

Annex/UpdateInstead.hs

@@ -0,0 +1,27 @@
+{- git-annex UpdateIntead emulation
+ -
+ - Copyright 2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.UpdateInstead where
+
+import qualified Annex
+import Annex.Common
+import Config
+import Annex.Version
+import Annex.AdjustedBranch
+import Git.Branch
+import Git.ConfigTypes
+
+{- receive.denyCurrentBranch=updateInstead does not work in direct mode
+ - repositories or when an adjusted branch is checked out, so must be
+ - emulated. -}
+needUpdateInsteadEmulation :: Annex Bool
+needUpdateInsteadEmulation = updateinsteadset <&&> (isDirect <||> isadjusted)
+  where
+	updateinsteadset = (== UpdateInstead) . receiveDenyCurrentBranch
+		<$> Annex.getGitConfig
+	isadjusted = versionSupportsUnlockedPointers
+		<&&> (maybe False (isJust . getAdjustment) <$> inRepo Git.Branch.current)

Annex/Url.hs

@@ -0,0 +1,100 @@
+{- Url downloading, with git-annex user agent and configured http
+ - headers, security restrictions, etc.
+ -
+ - Copyright 2013-2018 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Url (
+	module U,
+	withUrlOptions,
+	getUrlOptions,
+	getUserAgent,
+	httpAddressesUnlimited,
+) where
+
+import Annex.Common
+import qualified Annex
+import Utility.Url as U
+import Utility.IPAddress
+import Utility.HttpManagerRestricted
+import qualified BuildInfo
+
+import Network.Socket
+
+defaultUserAgent :: U.UserAgent
+defaultUserAgent = "git-annex/" ++ BuildInfo.packageversion
+
+getUserAgent :: Annex U.UserAgent
+getUserAgent = Annex.getState $ 
+	fromMaybe defaultUserAgent . Annex.useragent
+
+getUrlOptions :: Annex U.UrlOptions
+getUrlOptions = Annex.getState Annex.urloptions >>= \case
+	Just uo -> return uo
+	Nothing -> do
+		uo <- mk
+		Annex.changeState $ \s -> s
+			{ Annex.urloptions = Just uo }
+		return uo
+  where
+	mk = do
+		(urldownloader, manager) <- checkallowedaddr
+		mkUrlOptions
+			<$> (Just <$> getUserAgent)
+			<*> headers
+			<*> pure urldownloader
+			<*> pure manager
+			<*> (annexAllowedUrlSchemes <$> Annex.getGitConfig)
+	
+	headers = annexHttpHeadersCommand <$> Annex.getGitConfig >>= \case
+		Just cmd -> lines <$> liftIO (readProcess "sh" ["-c", cmd])
+		Nothing -> annexHttpHeaders <$> Annex.getGitConfig
+	
+	checkallowedaddr = words . annexAllowedHttpAddresses <$> Annex.getGitConfig >>= \case
+		["all"] -> do
+			-- Only allow curl when all are allowed,
+			-- as its interface does not allow preventing
+			-- it from accessing specific IP addresses.
+			curlopts <- map Param . annexWebOptions <$> Annex.getGitConfig
+			let urldownloader = if null curlopts
+				then U.DownloadWithCurl curlopts
+				else U.DownloadWithConduit
+			manager <- liftIO $ U.newManager U.managerSettings
+			return (urldownloader, manager)
+		allowedaddrs -> do
+			addrmatcher <- liftIO $ 
+				(\l v -> any (\f -> f v) l) . catMaybes
+					<$> mapM makeAddressMatcher allowedaddrs
+			-- Default to not allowing access to loopback
+			-- and private IP addresses to avoid data
+			-- leakage.
+			let isallowed addr
+				| addrmatcher addr = True
+				| isLoopbackAddress addr = False
+				| isPrivateAddress addr = False
+				| otherwise = True
+			let connectionrestricted = addrConnectionRestricted 
+				("Configuration of annex.security.allowed-http-addresses does not allow accessing address " ++)
+			let r = Restriction
+				{ addressRestriction = \addr ->
+					if isallowed (addrAddress addr)
+						then Nothing
+						else Just (connectionrestricted addr)
+				}
+			(settings, pr) <- liftIO $ 
+				restrictManagerSettings r U.managerSettings
+			case pr of
+				Nothing -> return ()
+				Just ProxyRestricted -> toplevelWarning True
+					"http proxy settings not used due to annex.security.allowed-http-addresses configuration"
+			manager <- liftIO $ U.newManager settings
+			return (U.DownloadWithConduit, manager)
+
+httpAddressesUnlimited :: Annex Bool
+httpAddressesUnlimited = 
+	("all" == ) . annexAllowedHttpAddresses <$> Annex.getGitConfig
+
+withUrlOptions :: (U.UrlOptions -> Annex a) -> Annex a
+withUrlOptions a = a =<< getUrlOptions

Annex/VariantFile.hs

@@ -0,0 +1,44 @@
+{- git-annex .variant files for automatic merge conflict resolution
+ -
+ - Copyright 2014 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.VariantFile where
+
+import Annex.Common
+import Utility.FileSystemEncoding
+import Utility.Hash
+
+variantMarker :: String
+variantMarker = ".variant-"
+
+mkVariant :: FilePath -> String -> FilePath
+mkVariant file variant = takeDirectory file
+	</> dropExtension (takeFileName file)
+	++ variantMarker ++ variant
+	++ takeExtension file
+
+{- The filename to use when resolving a conflicted merge of a file,
+ - that points to a key.
+ -
+ - Something derived from the key needs to be included in the filename,
+ - but rather than exposing the whole key to the user, a very weak hash
+ - is used. There is a very real, although still unlikely, chance of
+ - conflicts using this hash.
+ -
+ - In the event that there is a conflict with the filename generated
+ - for some other key, that conflict will itself be handled by the
+ - conflicted merge resolution code. That case is detected, and the full
+ - key is used in the filename.
+ -}
+variantFile :: FilePath -> Key -> FilePath
+variantFile file key
+	| doubleconflict = mkVariant file (key2file key)
+	| otherwise = mkVariant file (shortHash $ key2file key)
+  where
+	doubleconflict = variantMarker `isInfixOf` file
+
+shortHash :: String -> String
+shortHash = take 4 . show . md5 . encodeBS

Annex/VectorClock.hs

@@ -0,0 +1,46 @@
+{- git-annex vector clocks
+ -
+ - We don't have a way yet to keep true distributed vector clocks.
+ - The next best thing is a timestamp.
+ -
+ - Copyright 2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.VectorClock where
+
+import Data.Time.Clock.POSIX
+import Control.Applicative
+import Prelude
+
+import Utility.Env
+import Logs.TimeStamp
+import Utility.QuickCheck
+
+-- | Some very old logs did not have any time stamp at all;
+-- Unknown is used for those.
+data VectorClock = Unknown | VectorClock POSIXTime
+	deriving (Eq, Ord)
+
+-- Unknown is oldest.
+prop_VectorClock_sane :: Bool
+prop_VectorClock_sane = Unknown < VectorClock 1
+
+instance Arbitrary  VectorClock where
+	arbitrary = VectorClock <$> arbitrary
+
+currentVectorClock :: IO VectorClock
+currentVectorClock = go =<< getEnv "GIT_ANNEX_VECTOR_CLOCK"
+  where
+	go Nothing = VectorClock <$> getPOSIXTime
+	go (Just s) = case parsePOSIXTime s of
+		Just t -> return (VectorClock t)
+		Nothing -> VectorClock <$> getPOSIXTime
+
+formatVectorClock :: VectorClock -> String
+formatVectorClock  Unknown = "0"
+formatVectorClock (VectorClock t) = show t
+
+parseVectorClock :: String -> Maybe VectorClock
+parseVectorClock t = VectorClock <$> parsePOSIXTime t

Annex/Version.hs

@@ -0,0 +1,68 @@
+{- git-annex repository versioning
+ -
+ - Copyright 2010,2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Version where
+
+import Annex.Common
+import Config
+import qualified Annex
+
+type Version = String
+
+defaultVersion :: Version
+defaultVersion = "5"
+
+latestVersion :: Version
+latestVersion = "6"
+
+supportedVersions :: [Version]
+supportedVersions = ["3", "5", "6"]
+
+versionForAdjustedClone :: Version
+versionForAdjustedClone = "6"
+
+upgradableVersions :: [Version]
+#ifndef mingw32_HOST_OS
+upgradableVersions = ["0", "1", "2", "3", "4", "5"]
+#else
+upgradableVersions = ["2", "3", "4", "5"]
+#endif
+
+autoUpgradeableVersions :: [Version]
+autoUpgradeableVersions = ["3", "4"]
+
+versionField :: ConfigKey
+versionField = annexConfig "version"
+
+getVersion :: Annex (Maybe Version)
+getVersion = annexVersion <$> Annex.getGitConfig
+
+versionSupportsDirectMode :: Annex Bool
+versionSupportsDirectMode = go <$> getVersion
+  where
+	go (Just "6") = False
+	go _ = True
+
+versionSupportsUnlockedPointers :: Annex Bool
+versionSupportsUnlockedPointers = go <$> getVersion
+  where
+	go (Just "6") = True
+	go _ = False
+
+versionSupportsAdjustedBranch :: Annex Bool
+versionSupportsAdjustedBranch = versionSupportsUnlockedPointers
+
+versionUsesKeysDatabase :: Annex Bool
+versionUsesKeysDatabase = versionSupportsUnlockedPointers
+
+setVersion :: Version -> Annex ()
+setVersion = setConfig versionField
+
+removeVersion :: Annex ()
+removeVersion = unsetConfig versionField

Annex/View.hs

@@ -0,0 +1,419 @@
+{- metadata based branch views
+ -
+ - Copyright 2014 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.View where
+
+import Annex.Common
+import Annex.View.ViewedFile
+import Types.View
+import Types.MetaData
+import Annex.MetaData
+import qualified Git
+import qualified Git.DiffTree as DiffTree
+import qualified Git.Branch
+import qualified Git.LsFiles
+import qualified Git.Ref
+import Git.UpdateIndex
+import Git.Sha
+import Git.Types
+import Git.FilePath
+import Annex.WorkTree
+import Annex.GitOverlay
+import Annex.Link
+import Annex.CatFile
+import Logs.MetaData
+import Logs.View
+import Utility.Glob
+import Types.Command
+import CmdLine.Action
+
+import qualified Data.Set as S
+import qualified Data.Map as M
+import "mtl" Control.Monad.Writer
+
+{- Each visible ViewFilter in a view results in another level of
+ - subdirectory nesting. When a file matches multiple ways, it will appear
+ - in multiple subdirectories. This means there is a bit of an exponential
+ - blowup with a single file appearing in a crazy number of places!
+ -
+ - Capping the view size to 5 is reasonable; why wants to dig
+ - through 5+ levels of subdirectories to find anything?
+ -}
+viewTooLarge :: View -> Bool
+viewTooLarge view = visibleViewSize view > 5
+
+visibleViewSize :: View -> Int
+visibleViewSize = length . filter viewVisible . viewComponents
+
+{- Parses field=value, field!=value, tag, and !tag
+ -
+ - Note that the field may not be a legal metadata field name,
+ - but it's let through anyway.
+ - This is useful when matching on directory names with spaces,
+ - which are not legal MetaFields.
+ -}
+parseViewParam :: String -> (MetaField, ViewFilter)
+parseViewParam s = case separate (== '=') s of
+	('!':tag, []) | not (null tag) ->
+		( tagMetaField
+		, mkExcludeValues tag
+		)
+	(tag, []) ->
+		( tagMetaField
+		, mkFilterValues tag
+		)
+	(field, wanted)
+		| end field == "!" ->
+			( mkMetaFieldUnchecked (beginning field)
+			, mkExcludeValues wanted
+			)
+		| otherwise ->
+			( mkMetaFieldUnchecked field
+			, mkFilterValues wanted
+			)
+  where
+	mkFilterValues v
+		| any (`elem` v) "*?" = FilterGlob v
+		| otherwise = FilterValues $ S.singleton $ toMetaValue v
+	mkExcludeValues = ExcludeValues . S.singleton . toMetaValue
+
+data ViewChange = Unchanged | Narrowing | Widening
+	deriving (Ord, Eq, Show)
+
+{- Updates a view, adding new fields to filter on (Narrowing), 
+ - or allowing new values in an existing field (Widening). -}
+refineView :: View -> [(MetaField, ViewFilter)] -> (View, ViewChange)
+refineView origview = checksize . calc Unchanged origview
+  where
+	calc c v [] = (v, c)
+	calc c v ((f, vf):rest) =
+		let (v', c') = refine v f vf
+		in calc (max c c') v' rest
+
+	refine view field vf
+		| field `elem` map viewField (viewComponents view) =
+			let (components', viewchanges) = runWriter $
+				mapM (\c -> updateViewComponent c field vf) (viewComponents view)
+			    viewchange = if field `elem` map viewField (viewComponents origview)
+				then maximum viewchanges
+				else Narrowing
+			in (view { viewComponents = components' }, viewchange)
+		| otherwise = 
+			let component = mkViewComponent field vf
+			    view' = view { viewComponents = component : viewComponents view }
+			in (view', Narrowing)
+	
+	checksize r@(v, _)
+		| viewTooLarge v = giveup $ "View is too large (" ++ show (visibleViewSize v) ++ " levels of subdirectories)"
+		| otherwise = r
+
+updateViewComponent :: ViewComponent -> MetaField -> ViewFilter -> Writer [ViewChange] ViewComponent
+updateViewComponent c field vf
+	| viewField c == field = do
+		let (newvf, viewchange) = combineViewFilter (viewFilter c) vf
+		tell [viewchange]
+		return $ mkViewComponent field newvf
+	| otherwise = return c
+
+{- Adds an additional filter to a view. This can only result in narrowing
+ - the view. Multivalued filters are added in non-visible form. -}
+filterView :: View -> [(MetaField, ViewFilter)] -> View
+filterView v vs = v { viewComponents = viewComponents f' ++ viewComponents v}
+  where
+	f = fst $ refineView (v {viewComponents = []}) vs
+	f' = f { viewComponents = map toinvisible (viewComponents f) }
+	toinvisible c = c { viewVisible = False }
+
+{- Combine old and new ViewFilters, yielding a result that matches
+ - either old+new, or only new.
+ -
+ - If we have FilterValues and change to a FilterGlob,
+ - it's always a widening change, because the glob could match other
+ - values. OTOH, going the other way, it's a Narrowing change if the old
+ - glob matches all the new FilterValues.
+ -
+ - With two globs, the old one is discarded, and the new one is used.
+ - We can tell if that's a narrowing change by checking if the old
+ - glob matches the new glob. For example, "*" matches "foo*",
+ - so that's narrowing. While "f?o" does not match "f??", so that's
+ - widening.
+ -}
+combineViewFilter :: ViewFilter -> ViewFilter -> (ViewFilter, ViewChange)
+combineViewFilter old@(FilterValues olds) (FilterValues news)
+	| combined == old = (combined, Unchanged)
+	| otherwise = (combined, Widening)
+  where
+	combined = FilterValues (S.union olds news)
+combineViewFilter old@(ExcludeValues olds) (ExcludeValues news)
+	| combined == old = (combined, Unchanged)
+	| otherwise = (combined, Narrowing)
+  where
+	combined = ExcludeValues (S.union olds news)
+combineViewFilter (FilterValues _) newglob@(FilterGlob _) =
+	(newglob, Widening)
+combineViewFilter (FilterGlob oldglob) new@(FilterValues s)
+	| all (matchGlob (compileGlob oldglob CaseInsensative) . fromMetaValue) (S.toList s) = (new, Narrowing)
+	| otherwise = (new, Widening)
+combineViewFilter (FilterGlob old) newglob@(FilterGlob new)
+	| old == new = (newglob, Unchanged)
+	| matchGlob (compileGlob old CaseInsensative) new = (newglob, Narrowing)
+	| otherwise = (newglob, Widening)
+combineViewFilter (FilterGlob _) new@(ExcludeValues _) = (new, Narrowing)
+combineViewFilter (ExcludeValues _) new@(FilterGlob _) = (new, Widening)
+combineViewFilter (FilterValues _) new@(ExcludeValues _) = (new, Narrowing)
+combineViewFilter (ExcludeValues _) new@(FilterValues _) = (new, Widening)
+
+{- Generates views for a file from a branch, based on its metadata
+ - and the filename used in the branch.
+ -
+ - Note that a file may appear multiple times in a view, when it
+ - has multiple matching values for a MetaField used in the View.
+ -
+ - Of course if its MetaData does not match the View, it won't appear at
+ - all.
+ -
+ - Note that for efficiency, it's useful to partially
+ - evaluate this function with the view parameter and reuse
+ - the result. The globs in the view will then be compiled and memoized.
+ -}
+viewedFiles :: View -> MkViewedFile -> FilePath -> MetaData -> [ViewedFile]
+viewedFiles view = 
+	let matchers = map viewComponentMatcher (viewComponents view)
+	in \mkviewedfile file metadata ->
+		let matches = map (\m -> m metadata) matchers
+		in if any isNothing matches
+			then []
+			else 
+				let paths = pathProduct $
+					map (map toViewPath) (visible matches)
+				in if null paths
+					then [mkviewedfile file]
+					else map (</> mkviewedfile file) paths
+  where
+	visible = map (fromJust . snd) .
+		filter (viewVisible . fst) .
+		zip (viewComponents view)
+
+{- Checks if metadata matches a ViewComponent filter, and if so
+ - returns the value, or values that match. Self-memoizing on ViewComponent. -}
+viewComponentMatcher :: ViewComponent -> (MetaData -> Maybe [MetaValue])
+viewComponentMatcher viewcomponent = \metadata -> 
+	matcher (currentMetaDataValues metafield metadata)
+  where
+	metafield = viewField viewcomponent
+	matcher = case viewFilter viewcomponent of
+		FilterValues s -> \values -> setmatches $
+			S.intersection s values
+		FilterGlob glob ->
+			let cglob = compileGlob glob CaseInsensative
+			in \values -> setmatches $
+				S.filter (matchGlob cglob . fromMetaValue) values
+		ExcludeValues excludes -> \values -> 
+			if S.null (S.intersection values excludes)
+				then Just []
+				else Nothing
+	setmatches s
+		| S.null s = Nothing
+		| otherwise = Just (S.toList s)
+
+-- This is '∕', a unicode character that displays the same as '/' but is
+-- not it. It is encoded using the filesystem encoding, which allows it
+-- to be used even when not in a unicode capable locale.
+pseudoSlash :: String
+pseudoSlash = "\56546\56456\56469"
+
+-- And this is '╲' similarly.
+pseudoBackslash :: String
+pseudoBackslash = "\56546\56469\56498"
+
+toViewPath :: MetaValue -> FilePath
+toViewPath = escapeslash [] . fromMetaValue
+  where
+	escapeslash s ('/':cs) = escapeslash (pseudoSlash:s) cs
+	escapeslash s ('\\':cs) = escapeslash (pseudoBackslash:s) cs
+	escapeslash s ('%':cs) = escapeslash ("%%":s) cs
+	escapeslash s (c1:c2:c3:cs)
+		| [c1,c2,c3] == pseudoSlash = escapeslash ("%":pseudoSlash:s) cs
+		| [c1,c2,c3] == pseudoBackslash = escapeslash ("%":pseudoBackslash:s) cs
+		| otherwise = escapeslash ([c1]:s) (c2:c3:cs)
+	escapeslash s cs = concat (reverse (cs:s))
+
+fromViewPath :: FilePath -> MetaValue
+fromViewPath = toMetaValue . deescapeslash []
+  where
+	deescapeslash s ('%':escapedc:cs) = deescapeslash ([escapedc]:s) cs
+	deescapeslash s (c1:c2:c3:cs)
+		| [c1,c2,c3] == pseudoSlash = deescapeslash ("/":s) cs
+		| [c1,c2,c3] == pseudoBackslash = deescapeslash ("\\":s) cs
+		| otherwise = deescapeslash ([c1]:s) (c2:c3:cs)
+	deescapeslash s cs = concat (reverse (cs:s))
+
+prop_viewPath_roundtrips :: MetaValue -> Bool
+prop_viewPath_roundtrips v = fromViewPath (toViewPath v) == v
+
+pathProduct :: [[FilePath]] -> [FilePath]
+pathProduct [] = []
+pathProduct (l:ls) = foldl combinel l ls
+  where
+	combinel xs ys = [combine x y | x <- xs, y <- ys]
+
+{- Extracts the metadata from a ViewedFile, based on the view that was used
+ - to construct it.
+ -
+ - Derived metadata is excluded.
+ -}
+fromView :: View -> ViewedFile -> MetaData
+fromView view f = MetaData $
+	M.fromList (zip fields values) `M.difference` derived
+  where
+	visible = filter viewVisible (viewComponents view)
+	fields = map viewField visible
+	paths = splitDirectories (dropFileName f)
+	values = map (S.singleton . fromViewPath) paths
+	MetaData derived = getViewedFileMetaData f
+
+{- Constructing a view that will match arbitrary metadata, and applying
+ - it to a file yields a set of ViewedFile which all contain the same
+ - MetaFields that were present in the input metadata
+ - (excluding fields that are not visible). -}
+prop_view_roundtrips :: FilePath -> MetaData -> Bool -> Bool
+prop_view_roundtrips f metadata visible = null f || viewTooLarge view ||
+	all hasfields (viewedFiles view viewedFileFromReference f metadata)
+  where
+	view = View (Git.Ref "master") $
+		map (\(mf, mv) -> ViewComponent mf (FilterValues $ S.filter (not . null . fromMetaValue) mv) visible)
+			(fromMetaData metadata)
+	visiblefields = sort (map viewField $ filter viewVisible (viewComponents view))
+	hasfields fv = sort (map fst (fromMetaData (fromView view fv))) == visiblefields
+
+{- A directory foo/bar/baz/ is turned into metadata fields
+ - /=foo, foo/=bar, foo/bar/=baz.
+ -
+ - Note that this may generate MetaFields that legalField rejects.
+ - This is necessary to have a 1:1 mapping between directory names and
+ - fields. So this MetaData cannot safely be serialized. -}
+getDirMetaData :: FilePath -> MetaData
+getDirMetaData d = MetaData $ M.fromList $ zip fields values
+  where
+	dirs = splitDirectories d
+	fields = map (mkMetaFieldUnchecked . addTrailingPathSeparator . joinPath)
+		(inits dirs)
+	values = map (S.singleton . toMetaValue . fromMaybe "" . headMaybe)
+		(tails dirs)
+
+getWorkTreeMetaData :: FilePath -> MetaData
+getWorkTreeMetaData = getDirMetaData . dropFileName
+
+getViewedFileMetaData :: FilePath -> MetaData
+getViewedFileMetaData = getDirMetaData . dirFromViewedFile . takeFileName
+
+{- Applies a view to the currently checked out branch, generating a new
+ - branch for the view.
+ -}
+applyView :: View -> Annex Git.Branch
+applyView = applyView' viewedFileFromReference getWorkTreeMetaData
+
+{- Generates a new branch for a View, which must be a more narrow
+ - version of the View originally used to generate the currently
+ - checked out branch. That is, it must match a subset of the files
+ - in view, not any others.
+ -}
+narrowView :: View -> Annex Git.Branch
+narrowView = applyView' viewedFileReuse getViewedFileMetaData
+
+{- Go through each staged file.
+ - If the file is not annexed, skip it, unless it's a dotfile in the top,
+ - or a file in a dotdir in the top. 
+ - Look up the metadata of annexed files, and generate any ViewedFiles,
+ - and stage them.
+ -
+ - Must be run from top of repository.
+ -}
+applyView' :: MkViewedFile -> (FilePath -> MetaData) -> View -> Annex Git.Branch
+applyView' mkviewedfile getfilemetadata view = do
+	top <- fromRepo Git.repoPath
+	(l, clean) <- inRepo $ Git.LsFiles.stagedDetails [top]
+	liftIO . nukeFile =<< fromRepo gitAnnexViewIndex
+	uh <- withViewIndex $ inRepo Git.UpdateIndex.startUpdateIndex
+	forM_ l $ \(f, sha, mode) -> do
+		topf <- inRepo (toTopFilePath f)
+		go uh topf sha (toTreeItemType =<< mode) =<< lookupFile f
+	liftIO $ do
+		void $ stopUpdateIndex uh
+		void clean
+	genViewBranch view
+  where
+	genviewedfiles = viewedFiles view mkviewedfile -- enables memoization
+
+	go uh topf _sha _mode (Just k) = do
+		metadata <- getCurrentMetaData k
+		let f = getTopFilePath topf
+		let metadata' = getfilemetadata f `unionMetaData` metadata
+		forM_ (genviewedfiles f metadata') $ \fv -> do
+			f' <- fromRepo $ fromTopFilePath $ asTopFilePath fv
+			stagesymlink uh f' =<< calcRepo (gitAnnexLink f' k)
+	go uh topf (Just sha) (Just treeitemtype) Nothing
+		| "." `isPrefixOf` getTopFilePath topf =
+			liftIO $ Git.UpdateIndex.streamUpdateIndex' uh $
+				pureStreamer $ updateIndexLine sha treeitemtype topf
+	go _ _ _ _  _ = noop
+
+	stagesymlink uh f linktarget = do
+		sha <- hashSymlink linktarget
+		liftIO . Git.UpdateIndex.streamUpdateIndex' uh
+			=<< inRepo (Git.UpdateIndex.stageSymlink f sha)
+
+{- Diff between currently checked out branch and staged changes, and
+ - update metadata to reflect the changes that are being committed to the
+ - view.
+ -
+ - Adding a file to a directory adds the metadata represented by
+ - that directory to the file, and removing a file from a directory
+ - removes the metadata.
+ -
+ - Note that removes must be handled before adds. This is so
+ - that moving a file from x/foo/ to x/bar/ adds back the metadata for x.
+ -}
+withViewChanges :: (ViewedFile -> Key -> CommandStart) -> (ViewedFile -> Key -> CommandStart) -> Annex ()
+withViewChanges addmeta removemeta = do
+	(diffs, cleanup) <- inRepo $ DiffTree.diffIndex Git.Ref.headRef
+	forM_ diffs handleremovals
+	forM_ diffs handleadds
+	void $ liftIO cleanup
+  where
+	handleremovals item
+		| DiffTree.srcsha item /= nullSha =
+			handlechange item removemeta
+				=<< catKey (DiffTree.srcsha item)
+		| otherwise = noop
+	handleadds item
+		| DiffTree.dstsha item /= nullSha = 
+			handlechange item addmeta
+				=<< catKey (DiffTree.dstsha item)
+		| otherwise = noop
+	handlechange item a = maybe noop
+		(void . commandAction . a (getTopFilePath $ DiffTree.file item))
+
+{- Runs an action using the view index file.
+ - Note that the file does not necessarily exist, or can contain
+ - info staged for an old view. -}
+withViewIndex :: Annex a -> Annex a
+withViewIndex a = do
+	f <- fromRepo gitAnnexViewIndex
+	withIndexFile f a
+
+{- Generates a branch for a view, using the view index file
+ - to make a commit to the view branch. The view branch is not
+ - checked out, but entering it will display the view. -}
+genViewBranch :: View -> Annex Git.Branch
+genViewBranch view = withViewIndex $ do
+	let branch = branchView view
+	void $ inRepo $ Git.Branch.commit Git.Branch.AutomaticCommit True (fromRef branch) branch []
+	return branch
+
+withCurrentView :: (View -> Annex a) -> Annex a
+withCurrentView a = maybe (giveup "Not in a view.") a =<< currentView

Annex/View/ViewedFile.hs

@@ -0,0 +1,86 @@
+{- filenames (not paths) used in views
+ -
+ - Copyright 2014 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.View.ViewedFile (
+	ViewedFile,
+	MkViewedFile,
+	viewedFileFromReference,
+	viewedFileReuse,
+	dirFromViewedFile,
+	prop_viewedFile_roundtrips,
+) where
+
+import Annex.Common
+
+type FileName = String
+type ViewedFile = FileName
+
+type MkViewedFile = FilePath -> ViewedFile
+
+{- Converts a filepath used in a reference branch to the
+ - filename that will be used in the view.
+ -
+ - No two filepaths from the same branch should yeild the same result,
+ - so all directory structure needs to be included in the output filename
+ - in some way.
+ -
+ - So, from dir/subdir/file.foo, generate file_%dir%subdir%.foo
+ -}
+viewedFileFromReference :: MkViewedFile
+viewedFileFromReference f = concat
+	[ escape base
+	, if null dirs then "" else "_%" ++ intercalate "%" (map escape dirs) ++ "%"
+	, escape $ concat extensions
+	]
+  where
+	(path, basefile) = splitFileName f
+	dirs = filter (/= ".") $ map dropTrailingPathSeparator (splitPath path)
+	(base, extensions) = splitShortExtensions basefile
+
+	{- To avoid collisions with filenames or directories that contain
+	 - '%', and to allow the original directories to be extracted
+	 - from the ViewedFile, '%' is escaped. )
+	 -}
+	escape :: String -> String
+	escape = replace "%" (escchar:'%':[]) . replace [escchar] [escchar, escchar]
+
+escchar :: Char
+#ifndef mingw32_HOST_OS
+escchar = '\\'
+#else
+-- \ is path separator on Windows, so instead use !
+escchar = '!'
+#endif
+
+{- For use when operating already within a view, so whatever filepath
+ - is present in the work tree is already a ViewedFile. -}
+viewedFileReuse :: MkViewedFile
+viewedFileReuse = takeFileName
+
+{- Extracts from a ViewedFile the directory where the file is located on
+ - in the reference branch. -}
+dirFromViewedFile :: ViewedFile -> FilePath
+dirFromViewedFile = joinPath . drop 1 . sep [] ""
+  where
+	sep l _ [] = reverse l
+	sep l curr (c:cs)
+		| c == '%' = sep (reverse curr:l) "" cs
+		| c == escchar = case cs of
+			(c':cs') -> sep l (c':curr) cs'
+			[] -> sep l curr cs
+		| otherwise = sep l (c:curr) cs
+
+prop_viewedFile_roundtrips :: FilePath -> Bool
+prop_viewedFile_roundtrips f
+	-- Relative filenames wanted, not directories.
+	| any (isPathSeparator) (end f ++ beginning f) = True
+	| isAbsolute f = True
+	| otherwise = dir == dirFromViewedFile (viewedFileFromReference f)
+  where
+	dir = joinPath $ beginning $ splitDirectories f

Annex/Wanted.hs

@@ -0,0 +1,29 @@
+{- git-annex checking whether content is wanted
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Wanted where
+
+import Annex.Common
+import Logs.PreferredContent
+import Annex.UUID
+
+import qualified Data.Set as S
+
+{- Check if a file is preferred content for the local repository. -}
+wantGet :: Bool -> Maybe Key -> AssociatedFile -> Annex Bool
+wantGet d key file = isPreferredContent Nothing S.empty key file d
+
+{- Check if a file is preferred content for a remote. -}
+wantSend :: Bool -> Maybe Key -> AssociatedFile -> UUID -> Annex Bool
+wantSend d key file to = isPreferredContent (Just to) S.empty key file d
+
+{- Check if a file can be dropped, maybe from a remote.
+ - Don't drop files that are preferred content. -}
+wantDrop :: Bool -> Maybe UUID -> Maybe Key -> AssociatedFile -> Annex Bool
+wantDrop d from key file = do
+	u <- maybe getUUID (return . id) from
+	not <$> isPreferredContent (Just u) (S.singleton u) key file d

Annex/WorkTree.hs

@@ -0,0 +1,90 @@
+{- git-annex worktree files
+ -
+ - Copyright 2013-2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.WorkTree where
+
+import Annex.Common
+import Annex.Link
+import Annex.CatFile
+import Annex.Version
+import Annex.Content
+import Annex.ReplaceFile
+import Config
+import Git.FilePath
+import qualified Git.Ref
+import qualified Git.Branch
+import qualified Git.LsTree
+import qualified Git.Types
+import Database.Types
+import qualified Database.Keys
+import qualified Database.Keys.SQL
+
+{- Looks up the key corresponding to an annexed file in the work tree,
+ - by examining what the file links to.
+ -
+ - An unlocked file will not have a link on disk, so fall back to
+ - looking for a pointer to a key in git.
+ -}
+lookupFile :: FilePath -> Annex (Maybe Key)
+lookupFile file = isAnnexLink file >>= \case
+	Just key -> makeret key
+	Nothing -> ifM (versionSupportsUnlockedPointers <||> isDirect)
+		( ifM (liftIO $ doesFileExist file)
+			( maybe (return Nothing) makeret =<< catKeyFile file
+			, return Nothing
+			)
+		, return Nothing 
+		)
+  where
+	makeret = return . Just
+
+{- Modifies an action to only act on files that are already annexed,
+ - and passes the key on to it. -}
+whenAnnexed :: (FilePath -> Key -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a)
+whenAnnexed a file = ifAnnexed file (a file) (return Nothing)
+
+ifAnnexed :: FilePath -> (Key -> Annex a) -> Annex a -> Annex a
+ifAnnexed file yes no = maybe no yes =<< lookupFile file
+
+{- Find all unlocked files and update the keys database for them. 
+ - 
+ - This is expensive, and so normally the associated files are updated
+ - incrementally when changes are noticed. So, this only needs to be done
+ - when initializing/upgrading a v6 mode repository.
+ -
+ - Also, the content for the unlocked file may already be present as
+ - an annex object. If so, make the unlocked file use that content.
+ -}
+scanUnlockedFiles :: Annex ()
+scanUnlockedFiles = whenM (isJust <$> inRepo Git.Branch.current) $ do
+	showSideAction "scanning for unlocked files"
+	Database.Keys.runWriter $
+		liftIO . Database.Keys.SQL.dropAllAssociatedFiles
+	(l, cleanup) <- inRepo $ Git.LsTree.lsTree Git.Ref.headRef
+	forM_ l $ \i -> 
+		when (isregfile i) $
+			maybe noop (add i)
+				=<< catKey (Git.LsTree.sha i)
+	liftIO $ void cleanup
+  where
+	isregfile i = case Git.Types.toTreeItemType (Git.LsTree.mode i) of
+		Just Git.Types.TreeFile -> True
+		Just Git.Types.TreeExecutable -> True
+		_ -> False
+	add i k = do
+		let tf = Git.LsTree.file i
+		Database.Keys.runWriter $
+			liftIO . Database.Keys.SQL.addAssociatedFileFast (toIKey k) tf
+		whenM (inAnnex k) $ do
+			f <- fromRepo $ fromTopFilePath tf
+			destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f
+			replaceFile f $ \tmp ->
+				linkFromAnnex k tmp destmode >>= \case
+					LinkAnnexOk -> return ()
+					LinkAnnexNoop -> return ()
+					LinkAnnexFailed -> liftIO $
+						writePointerFile tmp k destmode

Annex/YoutubeDl.hs

@@ -0,0 +1,236 @@
+{- youtube-dl integration for git-annex
+ -
+ - Copyright 2017-2018 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.YoutubeDl (
+	youtubeDl,
+	youtubeDlTo,
+	youtubeDlSupported,
+	youtubeDlCheck,
+	youtubeDlFileName,
+	youtubeDlFileNameHtmlOnly,
+) where
+
+import Annex.Common
+import qualified Annex
+import Annex.Content
+import Annex.Url
+import Utility.Url (URLString)
+import Utility.DiskFree
+import Utility.HtmlDetect
+import Utility.Process.Transcript
+import Logs.Transfer
+
+import Network.URI
+import Control.Concurrent.Async
+
+-- youtube-dl is can follow redirects to anywhere, including potentially
+-- localhost or a private address. So, it's only allowed to download
+-- content if the user has allowed access to all addresses.
+youtubeDlAllowed :: Annex Bool
+youtubeDlAllowed = httpAddressesUnlimited
+
+youtubeDlNotAllowedMessage :: String
+youtubeDlNotAllowedMessage = unwords
+	[ "youtube-dl could potentially access any address, and the"
+	, "configuration of annex.security.allowed-http-addresses"
+	, "does not allow that."
+	]
+
+-- Runs youtube-dl in a work directory, to download a single media file
+-- from the url. Reutrns the path to the media file in the work directory.
+--
+-- If youtube-dl fails without writing any files to the work directory, 
+-- or is not installed, returns Right Nothing.
+--
+-- The work directory can contain files from a previous run of youtube-dl
+-- and it will resume. It should not contain any other files though,
+-- and youtube-dl needs to finish up with only one file in the directory
+-- so we know which one it downloaded.
+--
+-- (Note that we can't use --output to specifiy the file to download to,
+-- due to <https://github.com/rg3/youtube-dl/issues/14864>)
+youtubeDl :: URLString -> FilePath -> Annex (Either String (Maybe FilePath))
+youtubeDl url workdir = ifM httpAddressesUnlimited
+	( withUrlOptions $ youtubeDl' url workdir
+	, return $ Left youtubeDlNotAllowedMessage
+	)
+
+youtubeDl' :: URLString -> FilePath -> UrlOptions -> Annex (Either String (Maybe FilePath))
+youtubeDl' url workdir uo
+	| supportedScheme uo url = ifM (liftIO $ inPath "youtube-dl")
+		( runcmd >>= \case
+			Right True -> workdirfiles >>= \case
+				(f:[]) -> return (Right (Just f))
+				[] -> return nofiles
+				fs -> return (toomanyfiles fs)
+			Right False -> workdirfiles >>= \case
+				[] -> return (Right Nothing)
+				_ -> return (Left "youtube-dl download is incomplete. Run the command again to resume.")
+			Left msg -> return (Left msg)
+		, return (Right Nothing)
+		)
+	| otherwise = return (Right Nothing)
+  where
+	nofiles = Left "youtube-dl did not put any media in its work directory, perhaps it's been configured to store files somewhere else?"
+	toomanyfiles fs = Left $ "youtube-dl downloaded multiple media files; git-annex is only able to deal with one per url: " ++ show fs
+	workdirfiles = liftIO $ filterM (doesFileExist) =<< dirContents workdir
+	runcmd = youtubeDlMaxSize workdir >>= \case
+		Left msg -> return (Left msg)
+		Right maxsize -> do
+			quiet <- commandProgressDisabled
+			opts <- youtubeDlOpts $ dlopts ++ maxsize ++ 
+				if quiet then [ Param "--quiet" ] else []
+			ok <- liftIO $ boolSystem' "youtube-dl" opts $
+				\p -> p { cwd = Just workdir }
+			return (Right ok)
+	dlopts = 
+		[ Param url
+		-- To make youtube-dl only download one file when given a
+		-- page with a video and a playlist, download only the video.
+		, Param "--no-playlist"
+		-- And when given a page with only a playlist, download only
+		-- the first video on the playlist. (Assumes the video is
+		-- somewhat stable, but this is the only way to prevent
+		-- youtube-dl from downloading the whole playlist.)
+		, Param "--playlist-items", Param "0"
+		]
+
+-- To honor annex.diskreserve, ask youtube-dl to not download too
+-- large a media file. Factors in other downloads that are in progress,
+-- and any files in the workdir that it may have partially downloaded
+-- before.
+youtubeDlMaxSize :: FilePath -> Annex (Either String [CommandParam])
+youtubeDlMaxSize workdir = ifM (Annex.getState Annex.force)
+	( return $ Right []
+	, liftIO (getDiskFree workdir) >>= \case
+		Just have -> do
+			inprogress <- sizeOfDownloadsInProgress (const True)
+			partial <- liftIO $ sum 
+				<$> (mapM getFileSize =<< dirContents workdir)
+			reserve <- annexDiskReserve <$> Annex.getGitConfig
+			let maxsize = have - reserve - inprogress + partial
+			if maxsize > 0
+				then return $ Right
+					[ Param "--max-filesize"
+					, Param (show maxsize)
+					]
+				else return $ Left $
+					needMoreDiskSpace $
+						negate maxsize + 1024
+		Nothing -> return $ Right []
+	)
+
+-- Download a media file to a destination, 
+youtubeDlTo :: Key -> URLString -> FilePath -> Annex Bool
+youtubeDlTo key url dest = do
+	res <- withTmpWorkDir key $ \workdir ->
+		youtubeDl url workdir >>= \case
+			Right (Just mediafile) -> do
+				liftIO $ renameFile mediafile dest
+				return (Just True)
+			Right Nothing -> return (Just False)
+			Left msg -> do
+				warning msg
+				return Nothing
+	return (fromMaybe False res)
+
+-- youtube-dl supports downloading urls that are not html pages,
+-- but we don't want to use it for such urls, since they can be downloaded
+-- without it. So, this first downloads part of the content and checks 
+-- if it's a html page; only then is youtube-dl used.
+htmlOnly :: URLString -> a -> Annex a -> Annex a
+htmlOnly url fallback a = withUrlOptions $ \uo -> 
+	liftIO (downloadPartial url uo htmlPrefixLength) >>= \case
+		Just bs | isHtmlBs bs -> a
+		_ -> return fallback
+
+-- Check if youtube-dl supports downloading content from an url.
+youtubeDlSupported :: URLString -> Annex Bool
+youtubeDlSupported url = either (const False) id
+	<$> withUrlOptions (youtubeDlCheck' url)
+
+-- Check if youtube-dl can find media in an url.
+--
+-- While this does not download anything, it checks youtubeDlAllowed
+-- for symmetry with youtubeDl; the check should not succeed if the
+-- download won't succeed.
+youtubeDlCheck :: URLString -> Annex (Either String Bool)
+youtubeDlCheck url = ifM youtubeDlAllowed
+	( withUrlOptions $ youtubeDlCheck' url
+	, return $ Left youtubeDlNotAllowedMessage
+	)
+
+youtubeDlCheck' :: URLString -> UrlOptions -> Annex (Either String Bool)
+youtubeDlCheck' url uo
+	| supportedScheme uo url = catchMsgIO $ htmlOnly url False $ do
+		opts <- youtubeDlOpts [ Param url, Param "--simulate" ]
+		liftIO $ snd <$> processTranscript "youtube-dl" (toCommand opts) Nothing
+	| otherwise = return (Right False)
+
+-- Ask youtube-dl for the filename of media in an url.
+--
+-- (This is not always identical to the filename it uses when downloading.)
+youtubeDlFileName :: URLString -> Annex (Either String FilePath)
+youtubeDlFileName url = withUrlOptions go
+  where
+	go uo
+		| supportedScheme uo url = flip catchIO (pure . Left . show) $
+			htmlOnly url nomedia (youtubeDlFileNameHtmlOnly' url uo)
+		| otherwise = return nomedia
+	nomedia = Left "no media in url"
+
+-- Does not check if the url contains htmlOnly; use when that's already
+-- been verified.
+youtubeDlFileNameHtmlOnly :: URLString -> Annex (Either String FilePath)
+youtubeDlFileNameHtmlOnly = withUrlOptions . youtubeDlFileNameHtmlOnly'
+
+youtubeDlFileNameHtmlOnly' :: URLString -> UrlOptions -> Annex (Either String FilePath)
+youtubeDlFileNameHtmlOnly' url uo
+	| supportedScheme uo url = flip catchIO (pure . Left . show) go
+	| otherwise = return nomedia
+  where
+	go = do
+		-- Sometimes youtube-dl will fail with an ugly backtrace
+		-- (eg, http://bugs.debian.org/874321)
+		-- so catch stderr as well as stdout to avoid the user
+		-- seeing it. --no-warnings avoids warning messages that
+		-- are output to stdout.
+		opts <- youtubeDlOpts
+			[ Param url
+			, Param "--get-filename"
+			, Param "--no-warnings"
+			]
+		(Nothing, Just o, Just e, pid) <- liftIO $ createProcess
+			(proc "youtube-dl" (toCommand opts))
+				{ std_out = CreatePipe
+				, std_err = CreatePipe
+				}
+		output <- liftIO $ fmap fst $ 
+			hGetContentsStrict o
+				`concurrently`
+			hGetContentsStrict e
+		ok <- liftIO $ checkSuccessProcess pid
+		return $ case (ok, lines output) of
+			(True, (f:_)) | not (null f) -> Right f
+			_ -> nomedia
+	nomedia = Left "no media in url"
+
+youtubeDlOpts :: [CommandParam] -> Annex [CommandParam]
+youtubeDlOpts addopts = do
+	opts <- map Param . annexYoutubeDlOptions <$> Annex.getGitConfig
+	return (opts ++ addopts)
+
+supportedScheme :: UrlOptions -> URLString -> Bool
+supportedScheme uo url = case parseURIRelaxed url of
+	Nothing -> False
+	Just u -> case uriScheme u of
+		-- avoid ugly message from youtube-dl about not supporting file:
+		"file:" -> False
+		-- ftp indexes may look like html pages, and there's no point
+		-- involving youtube-dl in a ftp download
+		"ftp:" -> False
+		_ -> allowedScheme uo u

Assistant.hs

@@ -0,0 +1,191 @@
+{- git-annex assistant daemon
+ -
+ - Copyright 2012-2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant where
+
+import qualified Annex
+import Assistant.Common
+import Assistant.DaemonStatus
+import Assistant.NamedThread
+import Assistant.Types.ThreadedMonad
+import Assistant.Threads.DaemonStatus
+import Assistant.Threads.Watcher
+import Assistant.Threads.Committer
+import Assistant.Threads.Pusher
+import Assistant.Threads.Exporter
+import Assistant.Threads.Merger
+import Assistant.Threads.TransferWatcher
+import Assistant.Threads.Transferrer
+import Assistant.Threads.RemoteControl
+import Assistant.Threads.SanityChecker
+import Assistant.Threads.Cronner
+import Assistant.Threads.ProblemFixer
+#ifndef mingw32_HOST_OS
+import Assistant.Threads.MountWatcher
+#endif
+import Assistant.Threads.NetWatcher
+import Assistant.Threads.Upgrader
+import Assistant.Threads.UpgradeWatcher
+import Assistant.Threads.TransferScanner
+import Assistant.Threads.TransferPoller
+import Assistant.Threads.ConfigMonitor
+import Assistant.Threads.Glacier
+#ifdef WITH_WEBAPP
+import Assistant.WebApp
+import Assistant.Threads.WebApp
+#ifdef WITH_PAIRING
+import Assistant.Threads.PairListener
+#endif
+#else
+import Assistant.Types.UrlRenderer
+#endif
+import qualified Utility.Daemon
+import Utility.ThreadScheduler
+import Utility.HumanTime
+import qualified BuildInfo
+import Annex.Perms
+import Utility.LogFile
+#ifdef mingw32_HOST_OS
+import Utility.Env
+import Annex.Path
+import System.Environment (getArgs)
+#endif
+
+import System.Log.Logger
+import Network.Socket (HostName)
+
+stopDaemon :: Annex ()
+stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile
+
+{- Starts the daemon. If the daemon is run in the foreground, once it's
+ - running, can start the browser.
+ -
+ - startbrowser is passed the url and html shim file, as well as the original
+ - stdout and stderr descriptors. -}
+startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe String -> Maybe HostName ->  Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex ()
+startDaemon assistant foreground startdelay cannotrun listenhost startbrowser = do
+	
+	Annex.changeState $ \s -> s { Annex.daemon = True }
+	pidfile <- fromRepo gitAnnexPidFile
+	logfile <- fromRepo gitAnnexLogFile
+	liftIO $ debugM desc $ "logging to " ++ logfile
+#ifndef mingw32_HOST_OS
+	createAnnexDirectory (parentDir logfile)
+	logfd <- liftIO $ handleToFd =<< openLog logfile
+	if foreground
+		then do
+			origout <- liftIO $ catchMaybeIO $ 
+				fdToHandle =<< dup stdOutput
+			origerr <- liftIO $ catchMaybeIO $ 
+				fdToHandle =<< dup stdError
+			let undaemonize = Utility.Daemon.foreground logfd (Just pidfile)
+			start undaemonize $ 
+				case startbrowser of
+					Nothing -> Nothing
+					Just a -> Just $ a origout origerr
+		else
+			start (Utility.Daemon.daemonize logfd (Just pidfile) False) Nothing
+#else
+	-- Windows doesn't daemonize, but does redirect output to the
+	-- log file. The only way to do so is to restart the program.
+	when (foreground || not foreground) $ do
+		let flag = "GIT_ANNEX_OUTPUT_REDIR"
+		createAnnexDirectory (parentDir logfile)
+		ifM (liftIO $ isNothing <$> getEnv flag)
+			( liftIO $ withFile devNull WriteMode $ \nullh -> do
+				loghandle <- openLog logfile
+				e <- getEnvironment
+				cmd <- programPath
+				ps <- getArgs
+				(_, _, _, pid) <- createProcess (proc cmd ps)
+					{ env = Just (addEntry flag "1" e)
+					, std_in = UseHandle nullh
+					, std_out = UseHandle loghandle
+					, std_err = UseHandle loghandle
+					}
+				exitWith =<< waitForProcess pid
+			, start (Utility.Daemon.foreground (Just pidfile)) $
+				case startbrowser of
+					Nothing -> Nothing
+					Just a -> Just $ a Nothing Nothing
+			)
+#endif
+  where
+	desc
+		| assistant = "assistant"
+		| otherwise = "watch"
+	start daemonize webappwaiter = withThreadState $ \st -> do
+		checkCanWatch
+		dstatus <- startDaemonStatus
+		logfile <- fromRepo gitAnnexLogFile
+		liftIO $ debugM desc $ "logging to " ++ logfile
+		liftIO $ daemonize $
+			flip runAssistant (go webappwaiter) 
+				=<< newAssistantData st dstatus
+
+#ifdef WITH_WEBAPP
+	go webappwaiter = do
+		d <- getAssistant id
+#else
+	go _webappwaiter = do
+#endif
+		notice ["starting", desc, "version", BuildInfo.packageversion]
+		urlrenderer <- liftIO newUrlRenderer
+#ifdef WITH_WEBAPP
+		let webappthread = [ assist $ webAppThread d urlrenderer False cannotrun Nothing listenhost webappwaiter ]
+#else
+		let webappthread = []
+#endif
+		let threads = if isJust cannotrun
+			then webappthread
+			else webappthread ++
+				[ watch commitThread
+#ifdef WITH_WEBAPP
+#ifdef WITH_PAIRING
+				, assist $ pairListenerThread urlrenderer
+#endif
+#endif
+				, assist pushThread
+				, assist pushRetryThread
+				, assist exportThread
+				, assist exportRetryThread
+				, assist mergeThread
+				, assist transferWatcherThread
+				, assist transferPollerThread
+				, assist transfererThread
+				, assist remoteControlThread
+				, assist daemonStatusThread
+				, assist $ sanityCheckerDailyThread urlrenderer
+				, assist sanityCheckerHourlyThread
+				, assist $ problemFixerThread urlrenderer
+#ifndef mingw32_HOST_OS
+				, assist $ mountWatcherThread urlrenderer
+#endif
+				, assist netWatcherThread
+				, assist $ upgraderThread urlrenderer
+				, assist $ upgradeWatcherThread urlrenderer
+				, assist netWatcherFallbackThread
+				, assist $ transferScannerThread urlrenderer
+				, assist $ cronnerThread urlrenderer
+				, assist configMonitorThread
+				, assist glacierThread
+				, watch watchThread
+				-- must come last so that all threads that wait
+				-- on it have already started waiting
+				, watch $ sanityCheckerStartupThread startdelay
+				]
+	
+		mapM_ (startthread urlrenderer) threads
+		liftIO waitForTermination
+
+	watch a = (True, a)
+	assist a = (False, a)
+	startthread urlrenderer (watcher, t)
+		| watcher || assistant = startNamedThread urlrenderer t
+		| otherwise = noop

Assistant/Alert.hs

@@ -0,0 +1,460 @@
+{- git-annex assistant alerts
+ -
+ - Copyright 2012-2014 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE OverloadedStrings, CPP, BangPatterns #-}
+
+module Assistant.Alert where
+
+import Annex.Common
+import Assistant.Types.Alert
+import Assistant.Alert.Utility
+import qualified Remote
+import Utility.Tense
+import Types.Transfer
+import Types.Distribution
+import Git.Types (RemoteName)
+
+import Data.String
+import qualified Data.Text as T
+import qualified Control.Exception as E
+
+#ifdef WITH_WEBAPP
+import Assistant.DaemonStatus
+import Assistant.WebApp.Types
+import Assistant.WebApp (renderUrl)
+#endif
+import Assistant.Monad
+import Assistant.Types.UrlRenderer
+
+{- Makes a button for an alert that opens a Route. 
+ -
+ - If autoclose is set, the button will close the alert it's
+ - attached to when clicked. -}
+#ifdef WITH_WEBAPP
+mkAlertButton :: Bool -> T.Text -> UrlRenderer -> Route WebApp -> Assistant AlertButton
+mkAlertButton autoclose label urlrenderer route = do
+	close <- asIO1 removeAlert
+	url <- liftIO $ renderUrl urlrenderer route []
+	return $ AlertButton
+		{ buttonLabel = label
+		, buttonUrl = url
+		, buttonAction = if autoclose then Just close else Nothing
+		, buttonPrimary = True
+		}
+#endif
+
+renderData :: Alert -> TenseText
+renderData = tenseWords . alertData
+
+baseActivityAlert :: Alert
+baseActivityAlert = Alert
+	{ alertClass = Activity
+	, alertHeader = Nothing
+	, alertMessageRender = renderData
+	, alertData = []
+	, alertCounter = 0
+	, alertBlockDisplay = False
+	, alertClosable = False
+	, alertPriority = Medium
+	, alertIcon = Just ActivityIcon
+	, alertCombiner = Nothing
+	, alertName = Nothing
+	, alertButtons = []
+	}
+
+warningAlert :: String -> String -> Alert
+warningAlert name msg = Alert
+	{ alertClass = Warning
+	, alertHeader = Just $ tenseWords ["warning"]
+	, alertMessageRender = renderData
+	, alertData = [UnTensed $ T.pack msg]
+	, alertCounter = 0
+	, alertBlockDisplay = True
+	, alertClosable = True
+	, alertPriority = High
+	, alertIcon = Just ErrorIcon
+	, alertCombiner = Just $ dataCombiner $ \_old new -> new
+	, alertName = Just $ WarningAlert name
+	, alertButtons = []
+	}
+
+errorAlert :: String -> [AlertButton] -> Alert
+errorAlert msg buttons = Alert
+	{ alertClass = Error
+	, alertHeader = Nothing
+	, alertMessageRender = renderData
+	, alertData = [UnTensed $ T.pack msg]
+	, alertCounter = 0
+	, alertBlockDisplay = True
+	, alertClosable = True
+	, alertPriority = Pinned
+	, alertIcon = Just ErrorIcon
+	, alertCombiner = Nothing
+	, alertName = Nothing
+	, alertButtons = buttons
+	}
+
+activityAlert :: Maybe TenseText -> [TenseChunk] -> Alert
+activityAlert header dat = baseActivityAlert
+	{ alertHeader = header
+	, alertData = dat
+	}
+
+startupScanAlert :: Alert
+startupScanAlert = activityAlert Nothing
+	[Tensed "Performing" "Performed", "startup scan"]
+
+{- Displayed when a shutdown is occurring, so will be seen after shutdown
+ - has happened. -}
+shutdownAlert :: Alert
+shutdownAlert = warningAlert "shutdown" "git-annex has been shut down"
+
+commitAlert :: Alert
+commitAlert = activityAlert Nothing
+	[Tensed "Committing" "Committed", "changes to git"]
+
+showRemotes :: [RemoteName] -> TenseChunk
+showRemotes = UnTensed . T.intercalate ", " . map T.pack
+
+syncAlert :: [Remote] -> Alert
+syncAlert = syncAlert' . map Remote.name
+
+syncAlert' :: [RemoteName] -> Alert
+syncAlert' rs = baseActivityAlert
+	{ alertName = Just SyncAlert
+	, alertHeader = Just $ tenseWords
+		[Tensed "Syncing" "Synced", "with", showRemotes rs]
+	, alertPriority = Low
+	, alertIcon = Just SyncIcon
+	}
+
+syncResultAlert :: [Remote] -> [Remote] -> Alert
+syncResultAlert succeeded failed = syncResultAlert'
+	(map Remote.name succeeded)
+	(map Remote.name failed)
+
+syncResultAlert' :: [RemoteName] -> [RemoteName] -> Alert
+syncResultAlert' succeeded failed = makeAlertFiller (not $ null succeeded) $
+	baseActivityAlert
+		{ alertName = Just SyncAlert
+		, alertHeader = Just $ tenseWords msg
+		}
+  where
+	msg
+		| null succeeded = ["Failed to sync with", showRemotes failed]
+		| null failed = ["Synced with", showRemotes succeeded]
+		| otherwise =
+			[ "Synced with", showRemotes succeeded
+			, "but not with", showRemotes failed
+			]
+
+sanityCheckAlert :: Alert
+sanityCheckAlert = activityAlert
+	(Just $ tenseWords [Tensed "Running" "Ran", "daily sanity check"])
+	["to make sure everything is ok."]
+
+sanityCheckFixAlert :: String -> Alert
+sanityCheckFixAlert msg = Alert
+	{ alertClass = Warning
+	, alertHeader = Just $ tenseWords ["Fixed a problem"]
+	, alertMessageRender = render
+	, alertData = [UnTensed $ T.pack msg]
+	, alertCounter = 0
+	, alertBlockDisplay = True
+	, alertPriority = High
+	, alertClosable = True
+	, alertIcon = Just ErrorIcon
+	, alertName = Just SanityCheckFixAlert
+	, alertCombiner = Just $ dataCombiner (++)
+	, alertButtons = []
+	}
+  where
+	render alert = tenseWords $ alerthead : alertData alert ++ [alertfoot]
+	alerthead = "The daily sanity check found and fixed a problem:"
+	alertfoot = "If these problems persist, consider filing a bug report."
+
+fsckingAlert :: AlertButton -> Maybe Remote -> Alert
+fsckingAlert button mr = baseActivityAlert
+	{ alertData = case mr of
+		Nothing -> [ UnTensed $ T.pack $ "Consistency check in progress" ]
+		Just r -> [ UnTensed $ T.pack $ "Consistency check of " ++ Remote.name r ++ " in progress"]
+	, alertButtons = [button]
+	}
+
+showFscking :: UrlRenderer -> Maybe Remote -> IO (Either E.SomeException a) -> Assistant a
+showFscking urlrenderer mr a = do
+#ifdef WITH_WEBAPP
+	button <- mkAlertButton False (T.pack "Configure") urlrenderer ConfigFsckR
+	r <- alertDuring (fsckingAlert button mr) $
+		liftIO a
+#else
+	r <- liftIO a
+#endif
+	either (liftIO . E.throwIO) return r
+
+notFsckedNudge :: UrlRenderer -> Maybe Remote -> Assistant ()
+#ifdef WITH_WEBAPP
+notFsckedNudge urlrenderer mr = do
+	button <- mkAlertButton True (T.pack "Configure") urlrenderer ConfigFsckR
+	void $ addAlert (notFsckedAlert mr button)
+#else
+notFsckedNudge _ _ = noop
+#endif
+
+notFsckedAlert :: Maybe Remote -> AlertButton -> Alert
+notFsckedAlert mr button = Alert
+	{ alertHeader = Just $ fromString $ concat
+		[ "You should enable consistency checking to protect your data"
+		, maybe "" (\r -> " in " ++ Remote.name r) mr
+		, "."
+		]
+	, alertIcon = Just InfoIcon
+	, alertPriority = High
+	, alertButtons = [button]
+	, alertClosable = True
+	, alertClass = Message
+	, alertMessageRender = renderData
+	, alertCounter = 0
+	, alertBlockDisplay = True
+	, alertName = Just NotFsckedAlert
+	, alertCombiner = Just $ dataCombiner $ \_old new -> new
+	, alertData = []
+	}
+
+baseUpgradeAlert :: [AlertButton] -> TenseText -> Alert
+baseUpgradeAlert buttons message = Alert
+	{ alertHeader = Just message
+	, alertIcon = Just UpgradeIcon
+	, alertPriority = High
+	, alertButtons = buttons
+	, alertClosable = True
+	, alertClass = Message
+	, alertMessageRender = renderData
+	, alertCounter = 0
+	, alertBlockDisplay = True
+	, alertName = Just UpgradeAlert
+	, alertCombiner = Just $ fullCombiner $ \new _old -> new
+	, alertData = []
+	}
+
+canUpgradeAlert :: AlertPriority -> GitAnnexVersion -> AlertButton -> Alert
+canUpgradeAlert priority version button = 
+	(baseUpgradeAlert [button] $ fromString msg)
+		{ alertPriority = priority
+		, alertData = [fromString $ " (version " ++ version ++ ")"]
+		}
+  where
+	msg = if priority >= High
+		then "An important upgrade of git-annex is available!"
+		else "An upgrade of git-annex is available."
+
+upgradeReadyAlert :: AlertButton -> Alert
+upgradeReadyAlert button = baseUpgradeAlert [button] $
+	fromString "A new version of git-annex has been installed."
+
+upgradingAlert :: Alert
+upgradingAlert = activityAlert Nothing [ fromString "Upgrading git-annex" ]
+
+upgradeFinishedAlert :: Maybe AlertButton -> GitAnnexVersion -> Alert
+upgradeFinishedAlert button version =
+	baseUpgradeAlert (maybeToList button) $ fromString $ 
+		"Finished upgrading git-annex to version " ++ version
+
+upgradeFailedAlert :: String -> Alert
+upgradeFailedAlert msg = (errorAlert msg [])
+	{ alertHeader = Just $ fromString "Upgrade failed." }
+
+unusedFilesAlert :: [AlertButton] -> String -> Alert
+unusedFilesAlert buttons message = Alert
+	{ alertHeader = Just $ fromString $ unwords
+		[ "Old and deleted files are piling up --"
+		, message
+		]
+	, alertIcon = Just InfoIcon
+	, alertPriority = High
+	, alertButtons = buttons
+	, alertClosable = True
+	, alertClass = Message
+	, alertMessageRender = renderData
+	, alertCounter = 0
+	, alertBlockDisplay = True
+	, alertName = Just UnusedFilesAlert
+	, alertCombiner = Just $ fullCombiner $ \new _old -> new
+	, alertData = []
+	}
+
+brokenRepositoryAlert :: [AlertButton] -> Alert
+brokenRepositoryAlert = errorAlert "Serious problems have been detected with your repository. This needs your immediate attention!"
+
+repairingAlert :: String -> Alert
+repairingAlert repodesc = activityAlert Nothing
+	[ Tensed "Attempting to repair" "Repaired"
+	, UnTensed $ T.pack repodesc
+	]
+
+pairingAlert :: AlertButton -> Alert
+pairingAlert button = baseActivityAlert
+	{ alertData = [ UnTensed "Pairing in progress" ]
+	, alertPriority = High
+	, alertButtons = [button]
+	}
+
+pairRequestReceivedAlert :: String -> AlertButton -> Alert
+pairRequestReceivedAlert who button = Alert
+	{ alertClass = Message
+	, alertHeader = Nothing
+	, alertMessageRender = renderData
+	, alertData = [UnTensed $ T.pack $ who ++ " is sending a pair request."]
+	, alertCounter = 0
+	, alertBlockDisplay = False
+	, alertPriority = High
+	, alertClosable = True
+	, alertIcon = Just InfoIcon
+	, alertName = Just $ PairAlert who
+	, alertCombiner = Just $ dataCombiner $ \_old new -> new
+	, alertButtons = [button]
+	}
+
+pairRequestAcknowledgedAlert :: String -> Maybe AlertButton -> Alert
+pairRequestAcknowledgedAlert who button = baseActivityAlert
+	{ alertData = ["Pairing with", UnTensed (T.pack who), Tensed "in progress" "complete"]
+	, alertPriority = High
+	, alertName = Just $ PairAlert who
+	, alertCombiner = Just $ dataCombiner $ \_old new -> new
+	, alertButtons = maybeToList button
+	}
+
+connectionNeededAlert :: AlertButton -> Alert
+connectionNeededAlert button = Alert
+	{ alertHeader = Just "Share with friends, and keep your devices in sync across the cloud."
+	, alertIcon = Just ConnectionIcon
+	, alertPriority = High
+	, alertButtons = [button]
+	, alertClosable = True
+	, alertClass = Message
+	, alertMessageRender = renderData
+	, alertCounter = 0
+	, alertBlockDisplay = True
+	, alertName = Just ConnectionNeededAlert
+	, alertCombiner = Just $ dataCombiner $ \_old new -> new
+	, alertData = []
+	}
+
+cloudRepoNeededAlert :: Maybe String -> AlertButton -> Alert
+cloudRepoNeededAlert friendname button = Alert
+	{ alertHeader = Just $ fromString $ unwords
+		[ "Unable to download files from"
+		, (fromMaybe "your other devices" friendname) ++ "."
+		]
+	, alertIcon = Just ErrorIcon
+	, alertPriority = High
+	, alertButtons = [button]
+	, alertClosable = True
+	, alertClass = Message
+	, alertMessageRender = renderData
+	, alertCounter = 0
+	, alertBlockDisplay = True
+	, alertName = Just $ CloudRepoNeededAlert
+	, alertCombiner = Just $ dataCombiner $ \_old new -> new
+	, alertData = []
+	}
+
+remoteRemovalAlert :: String -> AlertButton -> Alert
+remoteRemovalAlert desc button = Alert
+	{ alertHeader = Just $ fromString $
+		"The repository \"" ++ desc ++ 
+		"\" has been emptied, and can now be removed."
+	, alertIcon = Just InfoIcon
+	, alertPriority = High
+	, alertButtons = [button]
+	, alertClosable = True
+	, alertClass = Message
+	, alertMessageRender = renderData
+	, alertCounter = 0
+	, alertBlockDisplay = True
+	, alertName = Just $ RemoteRemovalAlert desc
+	, alertCombiner = Just $ dataCombiner $ \_old new -> new
+	, alertData = []
+	}
+
+{- Show a message that relates to a list of files.
+ -
+ - The most recent several files are shown, and a count of any others. -}
+fileAlert :: TenseChunk -> [FilePath] -> Alert
+fileAlert msg files = (activityAlert Nothing shortfiles)
+	{ alertName = Just $ FileAlert msg
+	, alertMessageRender = renderer
+	, alertCounter = counter
+	, alertCombiner = Just $ fullCombiner combiner
+	}
+  where
+	maxfilesshown = 10
+
+	(!somefiles, !counter) = splitcounter (dedupadjacent files)
+	!shortfiles = map (fromString . shortFile . takeFileName) somefiles
+
+	renderer alert = tenseWords $ msg : alertData alert ++ showcounter
+	  where
+		showcounter = case alertCounter alert of
+			0 -> []
+			_ -> [fromString $ "and " ++ show (alertCounter alert) ++ " other files"]
+
+	dedupadjacent (x:y:rest)
+		| x == y = dedupadjacent (y:rest)
+		| otherwise = x : dedupadjacent (y:rest)
+	dedupadjacent (x:[]) = [x]
+	dedupadjacent [] = []
+
+	{- Note that this ensures the counter is never 1; no need to say 
+	 - "1 file" when the filename could be shown. -}
+	splitcounter l
+		| length l <= maxfilesshown = (l, 0)
+		| otherwise =
+			let (keep, rest) = splitAt (maxfilesshown - 1) l
+			in (keep, length rest)
+	
+	combiner new old =
+		let (!fs, n) = splitcounter $
+			dedupadjacent $ alertData new ++ alertData old
+		    !cnt = n + alertCounter new + alertCounter old
+		in old
+			{ alertData = fs
+			, alertCounter = cnt
+			}
+
+addFileAlert :: [FilePath] -> Alert
+addFileAlert = fileAlert (Tensed "Adding" "Added")
+
+{- This is only used as a success alert after a transfer, not during it. -}
+transferFileAlert :: Direction -> Bool -> FilePath -> Alert
+transferFileAlert direction True file
+	| direction == Upload = fileAlert "Uploaded" [file]
+	| otherwise = fileAlert "Downloaded" [file]
+transferFileAlert direction False file
+	| direction == Upload = fileAlert "Upload failed" [file]
+	| otherwise = fileAlert "Download failed" [file]
+
+dataCombiner :: ([TenseChunk] -> [TenseChunk] -> [TenseChunk]) -> AlertCombiner
+dataCombiner combiner = fullCombiner $
+	\new old -> old { alertData = alertData new `combiner` alertData old }
+
+fullCombiner :: (Alert -> Alert -> Alert) -> AlertCombiner
+fullCombiner combiner new old
+	| alertClass new /= alertClass old = Nothing
+	| alertName new == alertName old = 
+		Just $! new `combiner` old
+	| otherwise = Nothing
+
+shortFile :: FilePath -> String
+shortFile f
+	| len < maxlen = f
+	| otherwise = take half f ++ ".." ++ drop (len - half) f
+  where
+	len = length f
+	maxlen = 20
+	half = (maxlen - 2) `div` 2 
+

Assistant/Alert/Utility.hs

@@ -0,0 +1,129 @@
+{- git-annex assistant alert utilities
+ -
+ - Copyright 2012, 2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Alert.Utility where
+
+import Annex.Common
+import Assistant.Types.Alert
+import Utility.Tense
+
+import qualified Data.Text as T
+import Data.Text (Text)
+import qualified Data.Map.Strict as M
+
+{- This is as many alerts as it makes sense to display at a time.
+ - A display might be smaller, or larger, the point is to not overwhelm the
+ - user with a ton of alerts. -}
+displayAlerts :: Int
+displayAlerts = 6
+
+{- This is not a hard maximum, but there's no point in keeping a great
+ - many filler alerts in an AlertMap, so when there's more than this many,
+ - they start being pruned, down toward displayAlerts. -}
+maxAlerts :: Int
+maxAlerts = displayAlerts * 2
+
+type AlertPair = (AlertId, Alert)
+
+{- The desired order is the reverse of:
+ -
+ - - Pinned alerts
+ - - High priority alerts, newest first
+ - - Medium priority Activity, newest first (mostly used for Activity)
+ - - Low priority alerts, newest first
+ - - Filler priorty alerts, newest first
+ - - Ties are broken by the AlertClass, with Errors etc coming first.
+ -}
+compareAlertPairs :: AlertPair -> AlertPair -> Ordering
+compareAlertPairs
+	(aid, Alert { alertClass = aclass, alertPriority = aprio })
+	(bid, Alert { alertClass = bclass, alertPriority = bprio })
+	 = compare aprio bprio
+		`mappend` compare aid bid
+			`mappend` compare aclass bclass
+
+sortAlertPairs :: [AlertPair] -> [AlertPair]
+sortAlertPairs = sortBy compareAlertPairs
+
+{- Renders an alert's header for display, if it has one. -}
+renderAlertHeader :: Alert -> Maybe Text
+renderAlertHeader alert = renderTense (alertTense alert) <$> alertHeader alert
+
+{- Renders an alert's message for display. -}
+renderAlertMessage :: Alert -> Text
+renderAlertMessage alert = renderTense (alertTense alert) $
+	(alertMessageRender alert) alert
+
+showAlert :: Alert -> String
+showAlert alert = T.unpack $ T.unwords $ catMaybes
+	[ renderAlertHeader alert
+	, Just $ renderAlertMessage alert
+	]
+
+alertTense :: Alert -> Tense
+alertTense alert
+	| alertClass alert == Activity = Present
+	| otherwise = Past
+
+{- Checks if two alerts display the same. -}
+effectivelySameAlert :: Alert -> Alert -> Bool
+effectivelySameAlert x y = all id 
+	[ alertClass x == alertClass y
+	, alertHeader x == alertHeader y
+	, alertData x == alertData y
+	, alertBlockDisplay x == alertBlockDisplay y
+	, alertClosable x == alertClosable y
+	, alertPriority x == alertPriority y
+	]
+
+makeAlertFiller :: Bool -> Alert -> Alert
+makeAlertFiller success alert
+	| isFiller alert = alert
+	| otherwise = alert
+		{ alertClass = if c == Activity then c' else c
+		, alertPriority = Filler
+		, alertClosable = True
+		, alertButtons = []
+		, alertIcon = Just $ if success then SuccessIcon else ErrorIcon
+		}
+  where
+	c = alertClass alert
+	c'
+		| success = Success
+		| otherwise = Error
+
+isFiller :: Alert -> Bool
+isFiller alert = alertPriority alert == Filler
+
+{- Updates the Alertmap, adding or updating an alert.
+ -
+ - Any old filler that looks the same as the alert is removed.
+ -
+ - Or, if the alert has an alertCombiner that combines it with
+ - an old alert, the old alert is replaced with the result, and the
+ - alert is removed.
+ -
+ - Old filler alerts are pruned once maxAlerts is reached.
+ -}
+mergeAlert :: AlertId -> Alert -> AlertMap -> AlertMap
+mergeAlert i al m = maybe updatePrune updateCombine (alertCombiner al)
+  where
+	pruneSame k al' = k == i || not (effectivelySameAlert al al')
+	pruneBloat m'
+		| bloat > 0 = M.fromList $ pruneold $ M.toList m'
+		| otherwise = m'
+	  where
+		bloat = M.size m' - maxAlerts
+		pruneold l =
+			let (f, rest) = partition (\(_, a) -> isFiller a) l
+			in drop bloat f ++ rest
+	updatePrune = pruneBloat $ M.filterWithKey pruneSame $ M.insert i al m
+	updateCombine combiner = 
+		let combined = M.mapMaybe (combiner al) m
+		in if M.null combined
+			then updatePrune
+			else M.delete i $ M.union combined m

Assistant/BranchChange.hs

@@ -0,0 +1,19 @@
+{- git-annex assistant git-annex branch change tracking
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.BranchChange where
+
+import Assistant.Common
+import Assistant.Types.BranchChange
+
+import Control.Concurrent.MSampleVar
+
+branchChanged :: Assistant ()
+branchChanged = flip writeSV () <<~ (fromBranchChangeHandle . branchChangeHandle)
+
+waitBranchChange :: Assistant ()
+waitBranchChange = readSV <<~ (fromBranchChangeHandle . branchChangeHandle)

Assistant/Changes.hs

@@ -0,0 +1,47 @@
+{- git-annex assistant change tracking
+ -
+ - Copyright 2012-2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Changes where
+
+import Assistant.Common
+import Assistant.Types.Changes
+import Utility.TList
+
+import Data.Time.Clock
+import Control.Concurrent.STM
+
+{- Handlers call this when they made a change that needs to get committed. -}
+madeChange :: FilePath -> ChangeInfo -> Assistant (Maybe Change)
+madeChange f t = Just <$> (Change <$> liftIO getCurrentTime <*> pure f <*> pure t)
+
+noChange :: Assistant (Maybe Change)
+noChange = return Nothing
+
+{- Indicates an add needs to be done, but has not started yet. -}
+pendingAddChange :: FilePath -> Assistant (Maybe Change)
+pendingAddChange f = Just <$> (PendingAddChange <$> liftIO getCurrentTime <*> pure f)
+
+{- Gets all unhandled changes.
+ - Blocks until at least one change is made. -}
+getChanges :: Assistant [Change]
+getChanges = (atomically . getTList) <<~ changePool
+
+{- Gets all unhandled changes, without blocking. -}
+getAnyChanges :: Assistant [Change]
+getAnyChanges = (atomically . takeTList) <<~ changePool
+
+{- Puts unhandled changes back into the pool.
+ - Note: Original order is not preserved. -}
+refillChanges :: [Change] -> Assistant ()
+refillChanges cs = (atomically . flip appendTList cs) <<~ changePool
+
+{- Records a change to the pool. -}
+recordChange :: Change -> Assistant ()
+recordChange c = (atomically . flip snocTList c) <<~ changePool
+
+recordChanges :: [Change] -> Assistant ()
+recordChanges = refillChanges

Assistant/Commits.hs

@@ -0,0 +1,32 @@
+{- git-annex assistant commit tracking
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Commits where
+
+import Assistant.Common
+import Assistant.Types.Commits
+import Utility.TList
+
+import Control.Concurrent.STM
+
+{- Gets all unhandled commits.
+ - Blocks until at least one commit is made. -}
+getCommits :: Assistant [Commit]
+getCommits = (atomically . getTList) <<~ commitChan
+
+{- Records a commit in the channel. -}
+recordCommit :: Assistant ()
+recordCommit = (atomically . flip consTList Commit) <<~ commitChan
+
+{- Gets all unhandled export commits.
+ - Blocks until at least one export commit is made. -}
+getExportCommits :: Assistant [Commit]
+getExportCommits = (atomically . getTList) <<~ exportCommitChan
+
+{- Records an export commit in the channel. -}
+recordExportCommit :: Assistant ()
+recordExportCommit = (atomically . flip consTList Commit) <<~ exportCommitChan

Assistant/Common.hs

@@ -0,0 +1,14 @@
+{- Common infrastructure for the git-annex assistant.
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Common (module X) where
+
+import Annex.Common as X
+import Assistant.Monad as X
+import Assistant.Types.DaemonStatus as X
+import Assistant.Types.NamedThread as X
+import Assistant.Types.Alert as X

Assistant/CredPairCache.hs

@@ -0,0 +1,53 @@
+{- git-annex assistant CredPair cache.
+ -
+ - Copyright 2014 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns #-}
+
+module Assistant.CredPairCache (
+	cacheCred,
+	getCachedCred,
+	expireCachedCred,
+) where
+
+import Assistant.Types.CredPairCache
+import Types.Creds
+import Assistant.Common
+import Utility.ThreadScheduler
+
+import qualified Data.Map as M
+import Control.Concurrent
+
+{- Caches a CredPair, but only for a limited time, after which it
+ - will expire.
+ -
+ - Note that repeatedly caching the same CredPair
+ - does not reset its expiry time.
+ -}
+cacheCred :: CredPair -> Seconds -> Assistant ()
+cacheCred (login, password) expireafter = do
+	cache <- getAssistant credPairCache
+	liftIO $ do
+		changeStrict cache $ M.insert login password
+		void $ forkIO $ do
+			threadDelaySeconds expireafter
+			changeStrict cache $ M.delete login
+
+getCachedCred :: Login -> Assistant (Maybe Password)
+getCachedCred login = do
+	cache <- getAssistant credPairCache
+	liftIO $ M.lookup login <$> readMVar cache
+
+expireCachedCred :: Login -> Assistant ()
+expireCachedCred login = do
+	cache <- getAssistant credPairCache
+	liftIO $ changeStrict cache $ M.delete login
+
+{- Update map strictly to avoid keeping references to old creds in memory. -}
+changeStrict :: CredPairCache -> (M.Map Login Password -> M.Map Login Password) -> IO ()
+changeStrict cache a = modifyMVar_ cache $ \m -> do
+	let !m' = a m
+	return m'

Assistant/DaemonStatus.hs

@@ -0,0 +1,267 @@
+{- git-annex assistant daemon status
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns #-}
+
+module Assistant.DaemonStatus where
+
+import Assistant.Common
+import Assistant.Alert.Utility
+import Utility.Tmp
+import Utility.NotificationBroadcaster
+import Types.Transfer
+import Logs.Transfer
+import Logs.Trust
+import Logs.TimeStamp
+import qualified Remote
+import qualified Types.Remote as Remote
+import Config.DynamicConfig
+import Annex.Export
+
+import Control.Concurrent.STM
+import System.Posix.Types
+import Data.Time.Clock.POSIX
+import qualified Data.Map.Strict as M
+import qualified Data.Set as S
+
+getDaemonStatus :: Assistant DaemonStatus
+getDaemonStatus = (atomically . readTVar) <<~ daemonStatusHandle
+
+modifyDaemonStatus_ :: (DaemonStatus -> DaemonStatus) -> Assistant ()
+modifyDaemonStatus_ a = modifyDaemonStatus $ \s -> (a s, ())
+
+modifyDaemonStatus :: (DaemonStatus -> (DaemonStatus, b)) -> Assistant b
+modifyDaemonStatus a = do
+	dstatus <- getAssistant daemonStatusHandle
+	liftIO $ do
+		(s, b) <- atomically $ do
+			r@(!s, _) <- a <$> readTVar dstatus
+			writeTVar dstatus s
+			return r
+		sendNotification $ changeNotifier s
+		return b
+
+{- Returns a function that updates the lists of syncable remotes
+ - and other associated information. -}
+calcSyncRemotes :: Annex (DaemonStatus -> DaemonStatus)
+calcSyncRemotes = do
+	rs <- filterM (liftIO . getDynamicConfig . remoteAnnexSync . Remote.gitconfig)
+		=<< (concat . Remote.byCost <$> Remote.remoteList)
+	alive <- trustExclude DeadTrusted (map Remote.uuid rs)
+	let good r = Remote.uuid r `elem` alive
+	let syncable = filter good rs
+	contentremotes <- filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) $
+		filter (\r -> Remote.uuid r /= NoUUID) syncable
+	let (exportremotes, dataremotes) = partition (exportTree . Remote.config) contentremotes
+
+	return $ \dstatus -> dstatus
+		{ syncRemotes = syncable
+		, syncGitRemotes = filter Remote.gitSyncableRemote syncable
+		, syncDataRemotes = dataremotes
+		, exportRemotes = exportremotes
+		, downloadRemotes = contentremotes
+		, syncingToCloudRemote = any iscloud contentremotes
+		}
+  where
+	iscloud r = not (Remote.readonly r) && Remote.availability r == Remote.GloballyAvailable
+
+{- Updates the syncRemotes list from the list of all remotes in Annex state. -}
+updateSyncRemotes :: Assistant ()
+updateSyncRemotes = do
+	modifyDaemonStatus_ =<< liftAnnex calcSyncRemotes
+	status <- getDaemonStatus
+	liftIO $ sendNotification $ syncRemotesNotifier status
+
+	when (syncingToCloudRemote status) $
+		updateAlertMap $
+			M.filter $ \alert ->
+				alertName alert /= Just CloudRepoNeededAlert
+
+changeCurrentlyConnected :: (S.Set UUID -> S.Set UUID) -> Assistant ()
+changeCurrentlyConnected sm = do
+	modifyDaemonStatus_ $ \ds -> ds
+		{ currentlyConnectedRemotes = sm (currentlyConnectedRemotes ds)
+		}
+	v <- currentlyConnectedRemotes <$> getDaemonStatus
+	debug [show v]
+	liftIO . sendNotification =<< syncRemotesNotifier <$> getDaemonStatus
+
+updateScheduleLog :: Assistant ()
+updateScheduleLog =
+	liftIO . sendNotification =<< scheduleLogNotifier <$> getDaemonStatus
+
+{- Load any previous daemon status file, and store it in a MVar for this
+ - process to use as its DaemonStatus. Also gets current transfer status. -}
+startDaemonStatus :: Annex DaemonStatusHandle
+startDaemonStatus = do
+	file <- fromRepo gitAnnexDaemonStatusFile
+	status <- liftIO $
+		flip catchDefaultIO (readDaemonStatusFile file) =<< newDaemonStatus
+	transfers <- M.fromList <$> getTransfers
+	addsync <- calcSyncRemotes
+	liftIO $ atomically $ newTVar $ addsync $ status
+		{ scanComplete = False
+		, sanityCheckRunning = False
+		, currentTransfers = transfers
+		}
+
+{- Don't just dump out the structure, because it will change over time,
+ - and parts of it are not relevant. -}
+writeDaemonStatusFile :: FilePath -> DaemonStatus -> IO ()
+writeDaemonStatusFile file status = 
+	viaTmp writeFile file =<< serialized <$> getPOSIXTime
+  where
+	serialized now = unlines
+		[ "lastRunning:" ++ show now
+		, "scanComplete:" ++ show (scanComplete status)
+		, "sanityCheckRunning:" ++ show (sanityCheckRunning status)
+		, "lastSanityCheck:" ++ maybe "" show (lastSanityCheck status)
+		]
+
+readDaemonStatusFile :: FilePath -> IO DaemonStatus
+readDaemonStatusFile file = parse <$> newDaemonStatus <*> readFile file
+  where
+	parse status = foldr parseline status . lines
+	parseline line status
+		| key == "lastRunning" = parseval parsePOSIXTime $ \v ->
+			status { lastRunning = Just v }
+		| key == "scanComplete" = parseval readish $ \v ->
+			status { scanComplete = v }
+		| key == "sanityCheckRunning" = parseval readish $ \v ->
+			status { sanityCheckRunning = v }
+		| key == "lastSanityCheck" = parseval parsePOSIXTime $ \v ->
+			status { lastSanityCheck = Just v }
+		| otherwise = status -- unparsable line
+	  where
+		(key, value) = separate (== ':') line
+		parseval parser a = maybe status a (parser value)
+
+{- Checks if a time stamp was made after the daemon was lastRunning.
+ -
+ - Some slop is built in; this really checks if the time stamp was made
+ - at least ten minutes after the daemon was lastRunning. This is to
+ - ensure the daemon shut down cleanly, and deal with minor clock skew.
+ -
+ - If the daemon has never ran before, this always returns False.
+ -}
+afterLastDaemonRun :: EpochTime -> DaemonStatus -> Bool
+afterLastDaemonRun timestamp status = maybe False (< t) (lastRunning status)
+  where
+	t = realToFrac (timestamp + slop) :: POSIXTime
+	slop = fromIntegral tenMinutes
+
+tenMinutes :: Int
+tenMinutes = 10 * 60
+
+{- Mutates the transfer map. Runs in STM so that the transfer map can
+ - be modified in the same transaction that modifies the transfer queue.
+ - Note that this does not send a notification of the change; that's left
+ - to the caller. -}
+adjustTransfersSTM :: DaemonStatusHandle -> (TransferMap -> TransferMap) -> STM ()
+adjustTransfersSTM dstatus a = do
+	s <- readTVar dstatus
+	let !v = a (currentTransfers s)
+	writeTVar dstatus $ s { currentTransfers = v }
+
+{- Checks if a transfer is currently running. -}
+checkRunningTransferSTM :: DaemonStatusHandle -> Transfer -> STM Bool
+checkRunningTransferSTM dstatus t = M.member t . currentTransfers
+	<$> readTVar dstatus
+
+{- Alters a transfer's info, if the transfer is in the map. -}
+alterTransferInfo :: Transfer -> (TransferInfo -> TransferInfo) -> Assistant ()
+alterTransferInfo t a = updateTransferInfo' $ M.adjust a t
+
+{- Updates a transfer's info. Adds the transfer to the map if necessary,
+ - or if already present, updates it while preserving the old transferTid,
+ - transferPaused, and bytesComplete values, which are not written to disk. -}
+updateTransferInfo :: Transfer -> TransferInfo -> Assistant ()
+updateTransferInfo t info = updateTransferInfo' $ M.insertWith merge t info
+  where
+	merge new old = new
+		{ transferTid = maybe (transferTid new) Just (transferTid old)
+		, transferPaused = transferPaused new || transferPaused old
+		, bytesComplete = maybe (bytesComplete new) Just (bytesComplete old)
+		}
+
+updateTransferInfo' :: (TransferMap -> TransferMap) -> Assistant ()
+updateTransferInfo' a = notifyTransfer `after` modifyDaemonStatus_ update
+  where
+	update s = s { currentTransfers = a (currentTransfers s) }
+
+{- Removes a transfer from the map, and returns its info. -}
+removeTransfer :: Transfer -> Assistant (Maybe TransferInfo)
+removeTransfer t = notifyTransfer `after` modifyDaemonStatus remove
+  where
+	remove s =
+		let (info, ts) = M.updateLookupWithKey
+			(\_k _v -> Nothing)
+			t (currentTransfers s)
+		in (s { currentTransfers = ts }, info)
+
+{- Send a notification when a transfer is changed. -}
+notifyTransfer :: Assistant ()
+notifyTransfer = do
+	dstatus <- getAssistant daemonStatusHandle
+	liftIO $ sendNotification
+		=<< transferNotifier <$> atomically (readTVar dstatus)
+
+{- Send a notification when alerts are changed. -}
+notifyAlert :: Assistant ()
+notifyAlert = do
+	dstatus <- getAssistant daemonStatusHandle
+	liftIO $ sendNotification
+		=<< alertNotifier <$> atomically (readTVar dstatus)
+
+{- Returns the alert's identifier, which can be used to remove it. -}
+addAlert :: Alert -> Assistant AlertId
+addAlert alert = do
+	notice [showAlert alert]
+	notifyAlert `after` modifyDaemonStatus add
+  where
+	add s = (s { lastAlertId = i, alertMap = m }, i)
+	  where
+		!i = nextAlertId $ lastAlertId s
+		!m = mergeAlert i alert (alertMap s)
+
+removeAlert :: AlertId -> Assistant ()
+removeAlert i = updateAlert i (const Nothing)
+
+updateAlert :: AlertId -> (Alert -> Maybe Alert) -> Assistant ()
+updateAlert i a = updateAlertMap $ \m -> M.update a i m
+
+updateAlertMap :: (AlertMap -> AlertMap) -> Assistant ()
+updateAlertMap a = notifyAlert `after` modifyDaemonStatus_ update
+  where
+	update s = 
+		let !m = a (alertMap s)
+		in s { alertMap = m }
+
+{- Displays an alert while performing an activity that returns True on
+ - success.
+ -
+ - The alert is left visible afterwards, as filler.
+ - Old filler is pruned, to prevent the map growing too large. -}
+alertWhile :: Alert -> Assistant Bool -> Assistant Bool
+alertWhile alert a = alertWhile' alert $ do
+	r <- a
+	return (r, r)
+
+{- Like alertWhile, but allows the activity to return a value too. -}
+alertWhile' :: Alert -> Assistant (Bool, a) -> Assistant a
+alertWhile' alert a = do
+	let alert' = alert { alertClass = Activity }
+	i <- addAlert alert'
+	(ok, r) <- a
+	updateAlertMap $ mergeAlert i $ makeAlertFiller ok alert'
+	return r
+
+{- Displays an alert while performing an activity, then removes it. -}
+alertDuring :: Alert -> Assistant a -> Assistant a
+alertDuring alert a = do
+	i <- addAlert $ alert { alertClass = Activity }
+	removeAlert  i `after` a

Assistant/DeleteRemote.hs

@@ -0,0 +1,89 @@
+{- git-annex assistant remote deletion utilities
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.DeleteRemote where
+
+import Assistant.Common
+import Assistant.Types.UrlRenderer
+import Assistant.TransferQueue
+import Types.Transfer
+import Logs.Location
+import Assistant.DaemonStatus
+import qualified Remote
+import Remote.List
+import qualified Git.Remote.Remove
+import Logs.Trust
+import qualified Annex
+
+#ifdef WITH_WEBAPP
+import Assistant.WebApp.Types
+import Assistant.Alert
+import qualified Data.Text as T
+#endif
+
+{- Removes a remote (but leave the repository as-is), and returns the old
+ - Remote data. -}
+disableRemote :: UUID -> Assistant Remote
+disableRemote uuid = do
+	remote <- fromMaybe (error "unknown remote")
+		<$> liftAnnex (Remote.remoteFromUUID uuid)
+	liftAnnex $ do
+		inRepo $ Git.Remote.Remove.remove (Remote.name remote)
+		void $ remoteListRefresh
+	updateSyncRemotes
+	return remote
+
+{- Removes a remote, marking it dead .-}
+removeRemote :: UUID -> Assistant Remote
+removeRemote uuid = do
+	liftAnnex $ trustSet uuid DeadTrusted
+	disableRemote uuid
+
+{- Called when a Remote is probably empty, to remove it.
+ -
+ - This does one last check for any objects remaining in the Remote,
+ - and if there are any, queues Downloads of them, and defers removing
+ - the remote for later. This is to catch any objects not referred to
+ - in keys in the current branch.
+ -}
+removableRemote :: UrlRenderer -> UUID -> Assistant ()
+removableRemote urlrenderer uuid = do
+	keys <- getkeys
+	if null keys
+		then finishRemovingRemote urlrenderer uuid
+		else do
+			r <- fromMaybe (error "unknown remote")
+				<$> liftAnnex (Remote.remoteFromUUID uuid)
+			mapM_ (queueremaining r) keys
+  where
+	queueremaining r k = 
+		queueTransferWhenSmall "remaining object in unwanted remote"
+			(AssociatedFile Nothing) (Transfer Download uuid k) r
+	{- Scanning for keys can take a long time; do not tie up
+	 - the Annex monad while doing it, so other threads continue to
+	 - run. -}
+	getkeys = do
+		a <- liftAnnex $ Annex.withCurrentState $ loggedKeysFor uuid
+		liftIO a
+
+{- With the webapp, this asks the user to click on a button to finish
+ - removing the remote.
+ -
+ - Without the webapp, just do the removal now.
+ -}
+finishRemovingRemote :: UrlRenderer -> UUID -> Assistant ()
+#ifdef WITH_WEBAPP
+finishRemovingRemote urlrenderer uuid = do
+	desc <- liftAnnex $ Remote.prettyUUID uuid
+	button <- mkAlertButton True (T.pack "Finish deletion process") urlrenderer $
+		FinishDeleteRepositoryR uuid
+	void $ addAlert $ remoteRemovalAlert desc button
+#else
+finishRemovingRemote _ uuid = void $ removeRemote uuid
+#endif

Assistant/Drop.hs

@@ -0,0 +1,26 @@
+{- git-annex assistant dropping of unwanted content
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Drop (
+	handleDrops,
+	handleDropsFrom,
+) where
+
+import Assistant.Common
+import Assistant.DaemonStatus
+import Annex.Drop (handleDropsFrom, Reason)
+import Logs.Location
+import CmdLine.Action
+import Types.NumCopies
+
+{- Drop from local and/or remote when allowed by the preferred content and
+ - numcopies settings. -}
+handleDrops :: Reason -> Bool -> Key -> AssociatedFile -> [VerifiedCopy] -> Assistant ()
+handleDrops reason fromhere key f preverified = do
+	syncrs <- syncDataRemotes <$> getDaemonStatus
+	locs <- liftAnnex $ loggedLocations key
+	liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f preverified callCommandAction

Assistant/Fsck.hs

@@ -0,0 +1,50 @@
+{- git-annex assistant fscking
+ -
+ - Copyright 2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Fsck where
+
+import Assistant.Common
+import Types.ScheduledActivity
+import qualified Types.Remote as Remote
+import Annex.UUID
+import Assistant.Alert
+import Assistant.Types.UrlRenderer
+import Logs.Schedule
+import qualified Annex
+
+import qualified Data.Set as S
+
+{- Displays a nudge in the webapp if a fsck is not configured for
+ - the specified remote, or for the local repository. -}
+fsckNudge :: UrlRenderer -> Maybe Remote -> Assistant ()
+fsckNudge urlrenderer mr
+	| maybe True fsckableRemote mr =
+		whenM (liftAnnex $ annexFsckNudge <$> Annex.getGitConfig) $
+			unlessM (liftAnnex $ checkFscked mr) $
+				notFsckedNudge urlrenderer mr
+	| otherwise = noop
+
+fsckableRemote :: Remote -> Bool
+fsckableRemote = isJust . Remote.remoteFsck
+
+{- Checks if the remote, or the local repository, has a fsck scheduled.
+ - Only looks at fscks configured to run via the local repository, not
+ - other repositories. -}
+checkFscked :: Maybe Remote -> Annex Bool
+checkFscked mr = any wanted . S.toList <$> (scheduleGet =<< getUUID)
+  where
+	wanted = case mr of
+		Nothing -> isSelfFsck
+		Just r -> flip isFsckOf (Remote.uuid r)
+
+isSelfFsck :: ScheduledActivity -> Bool
+isSelfFsck (ScheduledSelfFsck _ _) = True
+isSelfFsck _ = False
+
+isFsckOf :: ScheduledActivity -> UUID -> Bool
+isFsckOf (ScheduledRemoteFsck u _ _) u' = u == u'
+isFsckOf _ _ = False

Assistant/Gpg.hs

@@ -0,0 +1,36 @@
+{- git-annex assistant gpg stuff
+ -
+ - Copyright 2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Gpg where
+
+import Utility.Gpg
+import Utility.UserInfo
+import Types.Remote (RemoteConfigKey)
+
+import qualified Data.Map as M
+import Control.Applicative
+import Prelude
+
+{- Generates a gpg user id that is not used by any existing secret key -}
+newUserId :: GpgCmd -> IO UserId
+newUserId cmd = do
+	oldkeys <- secretKeys cmd
+	username <- either (const "unknown") id <$> myUserName
+	let basekeyname = username ++ "'s git-annex encryption key"
+	return $ Prelude.head $ filter (\n -> M.null $ M.filter (== n) oldkeys)
+		( basekeyname
+		: map (\n -> basekeyname ++ show n) ([2..] :: [Int])
+		)
+
+data EnableEncryption = HybridEncryption | SharedEncryption | NoEncryption
+	deriving (Eq)
+
+{- Generates Remote configuration for encryption. -}
+configureEncryption :: EnableEncryption -> (RemoteConfigKey, String)
+configureEncryption SharedEncryption = ("encryption", "shared")
+configureEncryption NoEncryption = ("encryption", "none")
+configureEncryption HybridEncryption = ("encryption", "hybrid")

Assistant/Install.hs

@@ -0,0 +1,194 @@
+{- Assistant installation
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.Install where
+
+import Assistant.Common
+import Assistant.Install.AutoStart
+import Config.Files
+import Utility.FileMode
+import Utility.Shell
+import Utility.Tmp
+import Utility.Env
+import Utility.SshConfig
+
+#ifdef darwin_HOST_OS
+import Utility.OSX
+#else
+import Utility.FreeDesktop
+import Assistant.Install.Menu
+import Utility.UserInfo
+import Utility.Android
+#endif
+
+standaloneAppBase :: IO (Maybe FilePath)
+standaloneAppBase = getEnv "GIT_ANNEX_APP_BASE"
+
+{- The standalone app does not have an installation process.
+ - So when it's run, it needs to set up autostarting of the assistant
+ - daemon, as well as writing the programFile, and putting the
+ - git-annex-shell and git-annex-wrapper wrapper scripts into ~/.ssh
+ -
+ - Note that this is done every time it's started, so if the user moves
+ - it around, the paths this sets up won't break.
+ -
+ - File manager hook script installation is done even for
+ - packaged apps, since it has to go into the user's home directory.
+ -}
+ensureInstalled :: IO ()
+ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL")
+	( go Nothing
+	, go =<< standaloneAppBase
+	)
+  where
+	go Nothing = installFileManagerHooks "git-annex"
+	go (Just base) = do
+		let program = base </> "git-annex"
+		programfile <- programFile
+		createDirectoryIfMissing True (parentDir programfile)
+		writeFile programfile program
+
+#ifdef darwin_HOST_OS
+		autostartfile <- userAutoStart osxAutoStartLabel
+		installAutoStart program autostartfile
+#else
+		ifM osAndroid
+			( do
+				-- Integration with the Termux:Boot app.
+				home <- myHomeDir
+				let bootfile = home </> ".termux" </> "boot" </> "git-annex"
+				unlessM (doesFileExist bootfile) $ do
+					createDirectoryIfMissing True (takeDirectory bootfile)
+					writeFile bootfile "git-annex assistant --autostart"
+			, do
+				menufile <- desktopMenuFilePath "git-annex" <$> userDataDir
+				icondir <- iconDir <$> userDataDir
+				installMenu program menufile base icondir
+				autostartfile <- autoStartPath "git-annex" <$> userConfigDir
+				installAutoStart program autostartfile
+			)
+#endif
+
+		sshdir <- sshDir
+		let runshell var = "exec " ++ base </> "runshell " ++ var
+		let rungitannexshell var = runshell $ "git-annex-shell -c \"" ++ var ++ "\""
+
+		installWrapper (sshdir </> "git-annex-shell") $ unlines
+			[ shebang_local
+			, "set -e"
+			, "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then"
+			,   rungitannexshell "$SSH_ORIGINAL_COMMAND"
+			, "else"
+			,   rungitannexshell "$@"
+			, "fi"
+			]
+		installWrapper (sshdir </> "git-annex-wrapper") $ unlines
+			[ shebang_local
+			, "set -e"
+			, runshell "\"$@\""
+			]
+
+		installFileManagerHooks program
+
+installWrapper :: FilePath -> String -> IO ()
+installWrapper file content = do
+	curr <- catchDefaultIO "" $ readFileStrict file
+	when (curr /= content) $ do
+		createDirectoryIfMissing True (parentDir file)
+		viaTmp writeFile file content
+		modifyFileMode file $ addModes [ownerExecuteMode]
+
+installFileManagerHooks :: FilePath -> IO ()
+#ifdef linux_HOST_OS
+installFileManagerHooks program = unlessM osAndroid $ do
+	let actions = ["get", "drop", "undo"]
+
+	-- Gnome
+	nautilusScriptdir <- (\d -> d </> "nautilus" </> "scripts") <$> userDataDir
+	createDirectoryIfMissing True nautilusScriptdir
+	forM_ actions $
+		genNautilusScript nautilusScriptdir
+
+	-- KDE
+	userdata <- userDataDir
+	let kdeServiceMenusdir = userdata </> "kservices5" </> "ServiceMenus"
+	createDirectoryIfMissing True kdeServiceMenusdir
+	writeFile (kdeServiceMenusdir </> "git-annex.desktop")
+		(kdeDesktopFile actions)
+  where
+	genNautilusScript scriptdir action =
+		installscript (scriptdir </> scriptname action) $ unlines
+			[ shebang_local
+			, autoaddedcomment
+			, "exec " ++ program ++ " " ++ action ++ " --notify-start --notify-finish -- \"$@\""
+			]
+	scriptname action = "git-annex " ++ action
+	installscript f c = whenM (safetoinstallscript f) $ do
+		writeFile f c
+		modifyFileMode f $ addModes [ownerExecuteMode]
+	safetoinstallscript f = catchDefaultIO True $
+		elem autoaddedcomment . lines <$> readFileStrict f
+	autoaddedcomment = "# " ++ autoaddedmsg ++ " (To disable, chmod 600 this file.)"
+	autoaddedmsg = "Automatically added by git-annex, do not edit."
+
+	kdeDesktopFile actions = unlines $ concat $
+		kdeDesktopHeader actions : map kdeDesktopAction actions
+	kdeDesktopHeader actions =
+		[ "# " ++ autoaddedmsg
+		, "[Desktop Entry]"
+		, "Type=Service"
+		, "ServiceTypes=all/allfiles"
+		, "MimeType=all/all;"
+		, "Actions=" ++ intercalate ";" (map kdeDesktopSection actions)
+		, "X-KDE-Priority=TopLevel"
+		, "X-KDE-Submenu=Git-Annex"
+		, "X-KDE-Icon=git-annex"
+		, "X-KDE-ServiceTypes=KonqPopupMenu/Plugin"
+		]
+	kdeDesktopSection command = "GitAnnex" ++ command
+	kdeDesktopAction command = 
+		[ ""
+		, "[Desktop Action " ++ kdeDesktopSection command ++ "]"
+		, "Name=" ++ command
+		, "Icon=git-annex"
+		, unwords
+			[ "Exec=sh -c 'cd \"$(dirname \"$1\")\" &&"
+			, program
+			, command
+			, "--notify-start --notify-finish -- \"$1\"'"
+			, "false" -- this becomes $0 in sh, so unused
+			, "%f"
+			]
+		]
+#else
+installFileManagerHooks _ = noop
+#endif
+
+{- Returns a cleaned up environment that lacks settings used to make the
+ - standalone builds use their bundled libraries and programs.
+ - Useful when calling programs not included in the standalone builds.
+ -
+ - For a non-standalone build, returns Nothing.
+ -}
+cleanEnvironment :: IO (Maybe [(String, String)])
+cleanEnvironment = clean <$> getEnvironment
+  where
+	clean environ
+		| null vars = Nothing
+		| otherwise = Just $ catMaybes $ map (restoreorig environ) environ
+		| otherwise = Nothing
+	  where
+		vars = words $ fromMaybe "" $
+			lookup "GIT_ANNEX_STANDLONE_ENV" environ
+		restoreorig oldenviron p@(k, _v)
+			| k `elem` vars = case lookup ("ORIG_" ++ k) oldenviron of
+				(Just v')
+					| not (null v') -> Just (k, v')
+				_ -> Nothing
+			| otherwise = Just p

Assistant/Install/AutoStart.hs

@@ -0,0 +1,40 @@
+{- Assistant autostart file installation
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Assistant.Install.AutoStart where
+
+import Utility.FreeDesktop
+#ifdef darwin_HOST_OS
+import Utility.OSX
+import Utility.Path
+import Utility.Directory
+#endif
+
+installAutoStart :: FilePath -> FilePath -> IO ()
+installAutoStart command file = do
+#ifdef darwin_HOST_OS
+	createDirectoryIfMissing True (parentDir file)
+	writeFile file $ genOSXAutoStartFile osxAutoStartLabel command
+		["assistant", "--autostart"]
+#else
+	writeDesktopMenuFile (fdoAutostart command) file
+#endif
+
+osxAutoStartLabel :: String
+osxAutoStartLabel = "com.branchable.git-annex.assistant"
+
+fdoAutostart :: FilePath -> DesktopEntry
+fdoAutostart command = genDesktopEntry
+	"Git Annex Assistant"
+	"Autostart"
+	False
+	(command ++ " assistant --autostart")
+	Nothing
+	[]

Assistant/Install/Menu.hs

@@ -0,0 +1,48 @@
+{- Assistant menu installation.
+ -
+ - Copyright 2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Assistant.Install.Menu where
+
+import Common
+
+import Utility.FreeDesktop
+
+installMenu :: FilePath -> FilePath -> FilePath -> FilePath -> IO ()
+#ifdef darwin_HOST_OS
+installMenu _command _menufile _iconsrcdir _icondir = return ()
+#else
+installMenu command menufile iconsrcdir icondir = do
+	writeDesktopMenuFile (fdoDesktopMenu command) menufile
+	installIcon (iconsrcdir </> "logo.svg") $
+		iconFilePath (iconBaseName ++ ".svg") "scalable" icondir
+	installIcon (iconsrcdir </> "logo_16x16.png") $
+		iconFilePath (iconBaseName ++ ".png") "16x16" icondir
+#endif
+
+{- The command can be either just "git-annex", or the full path to use
+ - to run it. -}
+fdoDesktopMenu :: FilePath -> DesktopEntry
+fdoDesktopMenu command = genDesktopEntry
+	"Git Annex"
+	"Track and sync the files in your Git Annex"
+	False
+	(command ++ " webapp")
+	(Just iconBaseName)
+	["Network", "FileTransfer"]
+
+installIcon :: FilePath -> FilePath -> IO ()
+installIcon src dest = do
+	createDirectoryIfMissing True (parentDir dest)
+	withBinaryFile src ReadMode $ \hin ->
+		withBinaryFile dest WriteMode $ \hout ->
+			hGetContents hin >>= hPutStr hout
+
+iconBaseName :: String
+iconBaseName = "git-annex"

Assistant/MakeRemote.hs

@@ -0,0 +1,172 @@
+{- git-annex assistant remote creation utilities
+ -
+ - Copyright 2012, 2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.MakeRemote where
+
+import Assistant.Common
+import Assistant.Ssh
+import qualified Types.Remote as R
+import qualified Remote
+import Remote.List
+import qualified Remote.Rsync as Rsync
+import qualified Remote.GCrypt as GCrypt
+import qualified Git
+import qualified Git.Command
+import qualified Annex
+import qualified Annex.SpecialRemote
+import Logs.UUID
+import Logs.Remote
+import Git.Remote
+import Git.Types (RemoteName)
+import Creds
+import Assistant.Gpg
+import Utility.Gpg (KeyId)
+import Types.GitConfig
+
+import qualified Data.Map as M
+
+{- Sets up a new git or rsync remote, accessed over ssh. -}
+makeSshRemote :: SshData -> Annex RemoteName
+makeSshRemote sshdata = maker (sshRepoName sshdata) (genSshUrl sshdata)
+  where
+	maker
+		| onlyCapability sshdata RsyncCapable = makeRsyncRemote
+		| otherwise = makeGitRemote
+
+{- Runs an action that returns a name of the remote, and finishes adding it. -}
+addRemote :: Annex RemoteName -> Annex Remote
+addRemote a = do
+	name <- a
+	void remoteListRefresh
+	maybe (error "failed to add remote") return
+		=<< Remote.byName (Just name)
+
+{- Inits a rsync special remote, and returns its name. -}
+makeRsyncRemote :: RemoteName -> String -> Annex String
+makeRsyncRemote name location = makeRemote name location $ const $ void $
+	go =<< Annex.SpecialRemote.findExisting name
+  where
+	go Nothing = setupSpecialRemote name Rsync.remote config Nothing
+		(Nothing, R.Init, Annex.SpecialRemote.newConfig name)
+	go (Just (u, c)) = setupSpecialRemote name Rsync.remote config Nothing
+		(Just u, R.Enable c, c)
+	config = M.fromList
+		[ ("encryption", "shared")
+		, ("rsyncurl", location)
+		, ("type", "rsync")
+		]
+
+{- Inits a gcrypt special remote, and returns its name. -}
+makeGCryptRemote :: RemoteName -> String -> KeyId -> Annex RemoteName
+makeGCryptRemote remotename location keyid = 
+	initSpecialRemote remotename GCrypt.remote Nothing $ M.fromList
+		[ ("type", "gcrypt")
+		, ("gitrepo", location)
+		, configureEncryption HybridEncryption
+		, ("keyid", keyid)
+		]
+
+type SpecialRemoteMaker = RemoteName -> RemoteType -> Maybe CredPair -> R.RemoteConfig -> Annex RemoteName
+
+{- Inits a new special remote. The name is used as a suggestion, but
+ - will be changed if there is already a special remote with that name. -}
+initSpecialRemote :: SpecialRemoteMaker
+initSpecialRemote name remotetype mcreds config = go 0
+  where
+	go :: Int -> Annex RemoteName
+	go n = do
+		let fullname = if n == 0  then name else name ++ show n
+		Annex.SpecialRemote.findExisting fullname >>= \case
+			Nothing -> setupSpecialRemote fullname remotetype config mcreds
+				(Nothing, R.Init, Annex.SpecialRemote.newConfig fullname)
+			Just _ -> go (n + 1)
+
+{- Enables an existing special remote. -}
+enableSpecialRemote :: SpecialRemoteMaker
+enableSpecialRemote name remotetype mcreds config =
+	Annex.SpecialRemote.findExisting name >>= \case
+		Nothing -> error $ "Cannot find a special remote named " ++ name
+		Just (u, c) -> setupSpecialRemote' False name remotetype config mcreds (Just u, R.Enable c, c)
+
+setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.SetupStage, R.RemoteConfig) -> Annex RemoteName
+setupSpecialRemote = setupSpecialRemote' True
+
+setupSpecialRemote' :: Bool -> RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.SetupStage, R.RemoteConfig) -> Annex RemoteName
+setupSpecialRemote' setdesc name remotetype config mcreds (mu, ss, c) = do
+	{- Currently, only 'weak' ciphers can be generated from the
+	 - assistant, because otherwise GnuPG may block once the entropy
+	 - pool is drained, and as of now there's no way to tell the user
+	 - to perform IO actions to refill the pool. -}
+	let weakc = M.insert "highRandomQuality" "false" $ M.union config c
+	dummycfg <- liftIO dummyRemoteGitConfig
+	(c', u) <- R.setup remotetype ss mu mcreds weakc dummycfg
+	configSet u c'
+	when setdesc $
+		whenM (isNothing . M.lookup u <$> uuidMap) $
+			describeUUID u name
+	return name
+
+{- Returns the name of the git remote it created. If there's already a
+ - remote at the location, returns its name. -}
+makeGitRemote :: String -> String -> Annex RemoteName
+makeGitRemote basename location = makeRemote basename location $ \name ->
+	void $ inRepo $ Git.Command.runBool
+		[Param "remote", Param "add", Param name, Param location]
+
+{- If there's not already a remote at the location, adds it using the
+ - action, which is passed the name of the remote to make.
+ -
+ - Returns the name of the remote. -}
+makeRemote :: String -> String -> (RemoteName -> Annex ()) -> Annex RemoteName
+makeRemote basename location a = do
+	rs <- Annex.getGitRemotes
+	if not (any samelocation rs)
+		then do
+			let name = uniqueRemoteName basename 0 rs
+			a name
+			return name
+		else return basename
+  where
+	samelocation x = Git.repoLocation x == location
+
+{- Given a list of all remotes, generate an unused name for a new
+ - remote, adding a number if necessary.
+ -
+ - Ensures that the returned name is a legal git remote name. -}
+uniqueRemoteName :: String -> Int -> [Git.Repo] -> RemoteName
+uniqueRemoteName basename n rs
+	| null namecollision = name
+	| otherwise = uniqueRemoteName legalbasename (succ n) rs
+  where
+	namecollision = filter samename rs
+	samename x = Git.remoteName x == Just name
+	name
+		| n == 0 = legalbasename
+		| otherwise = legalbasename ++ show n
+	legalbasename = makeLegalName basename
+
+{- Finds a CredPair belonging to any Remote that is of a given type
+ - and matches some other criteria.
+ -
+ - This can be used as a default when another repository is being set up
+ - using the same service.
+ -
+ - A function must be provided that returns the CredPairStorage
+ - to use for a particular Remote's uuid.
+ -}
+previouslyUsedCredPair
+	:: (UUID -> CredPairStorage)
+	-> RemoteType
+	-> (Remote -> Bool)
+	-> Annex (Maybe CredPair)
+previouslyUsedCredPair getstorage remotetype criteria =
+	getM fromstorage =<< filter criteria . filter sametype <$> remoteList
+  where
+	sametype r = R.typename (R.remotetype r) == R.typename remotetype
+	fromstorage r = do
+		let storage = getstorage (R.uuid r)
+		getRemoteCredPair (R.config r) (R.gitconfig r) storage

Assistant/Monad.hs

@@ -0,0 +1,148 @@
+{- git-annex assistant monad
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
+
+module Assistant.Monad (
+	Assistant,
+	AssistantData(..),
+	newAssistantData,
+	runAssistant,
+	getAssistant,
+	LiftAnnex,
+	liftAnnex,
+	(<~>),
+	(<<~),
+	asIO,
+	asIO1,
+	asIO2,
+	ThreadName,
+	debug,
+	notice
+) where
+
+import "mtl" Control.Monad.Reader
+import System.Log.Logger
+
+import Annex.Common
+import Assistant.Types.ThreadedMonad
+import Assistant.Types.DaemonStatus
+import Assistant.Types.ScanRemotes
+import Assistant.Types.TransferQueue
+import Assistant.Types.TransferSlots
+import Assistant.Types.TransferrerPool
+import Assistant.Types.Pushes
+import Assistant.Types.BranchChange
+import Assistant.Types.Commits
+import Assistant.Types.Changes
+import Assistant.Types.RepoProblem
+import Assistant.Types.ThreadName
+import Assistant.Types.RemoteControl
+import Assistant.Types.CredPairCache
+
+newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
+	deriving (
+		Monad,
+		MonadIO,
+		MonadReader AssistantData,
+		Functor,
+		Applicative
+	)
+
+data AssistantData = AssistantData
+	{ threadName :: ThreadName
+	, threadState :: ThreadState
+	, daemonStatusHandle :: DaemonStatusHandle
+	, scanRemoteMap :: ScanRemoteMap
+	, transferQueue :: TransferQueue
+	, transferSlots :: TransferSlots
+	, transferrerPool :: TransferrerPool
+	, failedPushMap :: FailedPushMap
+	, failedExportMap :: FailedPushMap
+	, commitChan :: CommitChan
+	, exportCommitChan :: CommitChan
+	, changePool :: ChangePool
+	, repoProblemChan :: RepoProblemChan
+	, branchChangeHandle :: BranchChangeHandle
+	, remoteControl :: RemoteControl
+	, credPairCache :: CredPairCache
+	}
+
+newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData
+newAssistantData st dstatus = AssistantData
+	<$> pure (ThreadName "main")
+	<*> pure st
+	<*> pure dstatus
+	<*> newScanRemoteMap
+	<*> newTransferQueue
+	<*> newTransferSlots
+	<*> newTransferrerPool (checkNetworkConnections dstatus)
+	<*> newFailedPushMap
+	<*> newFailedPushMap
+	<*> newCommitChan
+	<*> newCommitChan
+	<*> newChangePool
+	<*> newRepoProblemChan
+	<*> newBranchChangeHandle
+	<*> newRemoteControl
+	<*> newCredPairCache
+
+runAssistant :: AssistantData -> Assistant a -> IO a
+runAssistant d a = runReaderT (mkAssistant a) d
+
+getAssistant :: (AssistantData -> a) -> Assistant a
+getAssistant = reader
+
+{- Using a type class for lifting into the annex monad allows
+ - easily lifting to it from multiple different monads. -}
+class LiftAnnex m where
+	liftAnnex :: Annex a -> m a
+
+{- Runs an action in the git-annex monad. Note that the same monad state
+ - is shared among all assistant threads, so only one of these can run at
+ - a time. Therefore, long-duration actions should be avoided. -}
+instance LiftAnnex Assistant where
+	liftAnnex a = do
+		st <- reader threadState
+		liftIO $ runThreadState st a
+
+{- Runs an IO action, passing it an IO action that runs an Assistant action. -}
+(<~>) :: (IO a -> IO b) -> Assistant a -> Assistant b
+io <~> a = do
+	d <- reader id
+	liftIO $ io $ runAssistant d a
+
+{- Creates an IO action that will run an Assistant action when run. -}
+asIO :: Assistant a -> Assistant (IO a)
+asIO a = do
+	d <- reader id
+	return $ runAssistant d a
+
+asIO1 :: (a -> Assistant b) -> Assistant (a -> IO b)
+asIO1 a = do
+	d <- reader id
+	return $ \v -> runAssistant d $ a v
+
+asIO2 :: (a -> b -> Assistant c) -> Assistant (a -> b -> IO c)
+asIO2 a = do
+	d <- reader id
+	return $ \v1 v2 -> runAssistant d (a v1 v2)
+
+{- Runs an IO action on a selected field of the AssistantData. -}
+(<<~) :: (a -> IO b) -> (AssistantData -> a) -> Assistant b
+io <<~ v = reader v >>= liftIO . io
+
+debug :: [String] -> Assistant ()
+debug = logaction debugM
+
+notice :: [String] -> Assistant ()
+notice = logaction noticeM
+
+logaction :: (String -> String -> IO ()) -> [String] -> Assistant ()
+logaction a ws = do
+	ThreadName name <- getAssistant threadName
+	liftIO $ a name $ unwords $ (name ++ ":") : ws

Assistant/NamedThread.hs

@@ -0,0 +1,99 @@
+{- git-annex assistant named threads.
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.NamedThread where
+
+import Annex.Common
+import Assistant.Types.NamedThread
+import Assistant.Types.ThreadName
+import Assistant.Types.DaemonStatus
+import Assistant.Types.UrlRenderer
+import Assistant.DaemonStatus
+import Assistant.Monad
+import Utility.NotificationBroadcaster
+
+import Control.Concurrent
+import Control.Concurrent.Async
+import qualified Data.Map.Strict as M
+import qualified Control.Exception as E
+
+#ifdef WITH_WEBAPP
+import Assistant.WebApp.Types
+import Assistant.Types.Alert
+import Assistant.Alert
+import qualified Data.Text as T
+#endif
+
+{- Starts a named thread, if it's not already running.
+ -
+ - Named threads are run by a management thread, so if they crash
+ - an alert is displayed, allowing the thread to be restarted. -}
+startNamedThread :: UrlRenderer -> NamedThread -> Assistant ()
+startNamedThread urlrenderer (NamedThread afterstartupsanitycheck name a) =
+	M.lookup name . startedThreads <$> getDaemonStatus >>= \case
+		Nothing -> start
+		Just (aid, _) -> do
+			r <- liftIO (E.try (poll aid) :: IO (Either E.SomeException (Maybe (Either E.SomeException ()))))
+			case r of
+				Right Nothing -> noop
+				_ -> start
+  where
+	start
+		| afterstartupsanitycheck = do
+			status <- getDaemonStatus
+			h <- liftIO $ newNotificationHandle False $
+				startupSanityCheckNotifier status
+			startwith $ runmanaged $
+				liftIO $ waitNotification h
+		| otherwise = startwith $ runmanaged noop
+	startwith runner = do
+		d <- getAssistant id
+		aid <- liftIO $ runner $ d { threadName = name }
+		restart <- asIO $ startNamedThread urlrenderer (NamedThread False name a)
+		modifyDaemonStatus_ $ \s -> s
+			{ startedThreads = M.insert name (aid, restart) (startedThreads s) }
+	runmanaged first d = do
+		aid <- async $ runAssistant d $ do
+			void first
+			a
+		void $ forkIO $ manager d aid
+		return aid
+	manager d aid = (E.try (wait aid) :: IO (Either E.SomeException ())) >>= \case
+		Right _ -> noop
+		Left e -> do
+			let msg = unwords
+				[ fromThreadName $ threadName d
+				, "crashed:", show e
+				]
+			hPutStrLn stderr msg
+#ifdef WITH_WEBAPP
+			button <- runAssistant d $ mkAlertButton True
+				(T.pack "Restart Thread")
+				urlrenderer 
+				(RestartThreadR name)
+			runAssistant d $ void $ addAlert $
+				(warningAlert (fromThreadName name) msg)
+					{ alertButtons = [button] }
+#endif
+
+namedThreadId :: NamedThread -> Assistant (Maybe ThreadId)
+namedThreadId (NamedThread _ name _) = do
+	m <- startedThreads <$> getDaemonStatus
+	return $ asyncThreadId . fst <$> M.lookup name m
+
+{- Waits for all named threads that have been started to finish.
+ -
+ - Note that if a named thread crashes, it will probably
+ - cause this to crash as well. Also, named threads that are started
+ - after this is called will not be waited on. -}
+waitNamedThreads :: Assistant ()
+waitNamedThreads = do
+	m <- startedThreads <$> getDaemonStatus
+	liftIO $ mapM_ (wait . fst) $ M.elems m
+

Assistant/Pairing.hs

@@ -0,0 +1,103 @@
+{- git-annex assistant repo pairing, core data types
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.Pairing where
+
+import Annex.Common
+import Utility.Verifiable
+import Assistant.Ssh
+
+import Control.Concurrent
+import Network.Socket
+import Data.Char
+import qualified Data.Text as T
+
+data PairStage
+	{- "I'll pair with anybody who shares the secret that can be used
+	 - to verify this request." -}
+	 = PairReq
+	{- "I've verified your request, and you can verify this to see
+	 - that I know the secret. I set up your ssh key already.
+	 - Here's mine for you to set up." -}
+	| PairAck
+	{- "I saw your PairAck; you can stop sending them." -}
+	| PairDone
+	deriving (Eq, Read, Show, Ord, Enum)
+
+newtype PairMsg = PairMsg (Verifiable (PairStage, PairData, SomeAddr))
+	deriving (Eq, Read, Show)
+
+verifiedPairMsg :: PairMsg -> PairingInProgress -> Bool
+verifiedPairMsg (PairMsg m) pip = verify m $ inProgressSecret pip
+
+fromPairMsg :: PairMsg -> Verifiable (PairStage, PairData, SomeAddr)
+fromPairMsg (PairMsg m) = m
+
+pairMsgStage :: PairMsg -> PairStage
+pairMsgStage (PairMsg (Verifiable (s, _, _) _)) = s
+
+pairMsgData :: PairMsg -> PairData
+pairMsgData (PairMsg (Verifiable (_, d, _) _)) = d
+
+pairMsgAddr :: PairMsg -> SomeAddr
+pairMsgAddr (PairMsg (Verifiable (_, _, a) _)) = a
+
+data PairData = PairData
+	-- uname -n output, not a full domain name
+	{ remoteHostName :: Maybe HostName
+	, remoteUserName :: UserName
+	, remoteDirectory :: FilePath
+	, remoteSshPubKey :: SshPubKey
+	, pairUUID :: UUID
+	}
+	deriving (Eq, Read, Show)
+
+checkSane :: PairData -> Bool
+checkSane p = all (not . any isControl)
+	[ fromMaybe "" (remoteHostName p)
+	, remoteUserName p
+	, remoteDirectory p
+	, remoteSshPubKey p
+	, fromUUID (pairUUID p)
+	]
+
+type UserName = String
+
+{- A pairing that is in progress has a secret, a thread that is
+ - broadcasting pairing messages, and a SshKeyPair that has not yet been
+ - set up on disk. -}
+data PairingInProgress = PairingInProgress
+	{ inProgressSecret :: Secret
+	, inProgressThreadId :: Maybe ThreadId
+	, inProgressSshKeyPair :: SshKeyPair
+	, inProgressPairData :: PairData
+	, inProgressPairStage :: PairStage
+	}
+	deriving (Show)
+
+data AddrClass = IPv4AddrClass | IPv6AddrClass
+
+data SomeAddr = IPv4Addr HostAddress
+{- My Android build of the Network library does not currently have IPV6
+ - support. -}
+#ifndef __ANDROID__
+	| IPv6Addr HostAddress6
+#endif
+	deriving (Ord, Eq, Read, Show)
+
+{- This contains the whole secret, just lightly obfuscated to make it not
+ - too obvious. It's only displayed in the user's web browser. -}
+newtype SecretReminder = SecretReminder [Int]
+	deriving (Show, Eq, Ord, Read)
+
+toSecretReminder :: T.Text -> SecretReminder
+toSecretReminder = SecretReminder . map ord . T.unpack
+
+fromSecretReminder :: SecretReminder -> T.Text
+fromSecretReminder (SecretReminder s) = T.pack $ map chr s

Assistant/Pairing/MakeRemote.hs

@@ -0,0 +1,98 @@
+{- git-annex assistant pairing remote creation
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Pairing.MakeRemote where
+
+import Assistant.Common
+import Assistant.Ssh
+import Assistant.Pairing
+import Assistant.Pairing.Network
+import Assistant.MakeRemote
+import Assistant.Sync
+import Config.Cost
+import Config
+import qualified Types.Remote as Remote
+
+import Network.Socket
+import qualified Data.Text as T
+
+{- Authorized keys are set up before pairing is complete, so that the other
+ - side can immediately begin syncing. -}
+setupAuthorizedKeys :: PairMsg -> FilePath -> IO ()
+setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pairMsgData msg of
+	Left err -> error err
+	Right pubkey -> do
+		absdir <- absPath repodir
+		unlessM (liftIO $ addAuthorizedKeys True absdir pubkey) $
+			error "failed setting up ssh authorized keys"
+
+{- When local pairing is complete, this is used to set up the remote for
+ - the host we paired with. -}
+finishedLocalPairing :: PairMsg -> SshKeyPair -> Assistant ()
+finishedLocalPairing msg keypair = do
+	sshdata <- liftIO $ installSshKeyPair keypair =<< pairMsgToSshData msg
+	{- Ensure that we know the ssh host key for the host we paired with.
+	 - If we don't, ssh over to get it. -}
+	liftIO $ unlessM (knownHost $ sshHostName sshdata) $
+		void $ sshTranscript
+			[ sshOpt "StrictHostKeyChecking" "no"
+			, sshOpt "NumberOfPasswordPrompts" "0"
+			, "-n"
+			]
+			(genSshHost (sshHostName sshdata) (sshUserName sshdata))
+			("git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata))
+			Nothing
+	r <- liftAnnex $ addRemote $ makeSshRemote sshdata
+	repo <- liftAnnex $ Remote.getRepo r
+	liftAnnex $ setRemoteCost repo semiExpensiveRemoteCost
+	syncRemote r
+
+{- Mostly a straightforward conversion.  Except:
+ -  * Determine the best hostname to use to contact the host.
+ -  * Strip leading ~/ from the directory name.
+ -}
+pairMsgToSshData :: PairMsg -> IO SshData
+pairMsgToSshData msg = do
+	let d = pairMsgData msg
+	hostname <- liftIO $ bestHostName msg
+	let dir = case remoteDirectory d of
+		('~':'/':v) -> v
+		v -> v
+	return SshData
+		{ sshHostName = T.pack hostname
+		, sshUserName = Just (T.pack $ remoteUserName d)
+		, sshDirectory = T.pack dir
+		, sshRepoName = genSshRepoName hostname dir
+		, sshPort = 22
+		, needsPubKey = True
+		, sshCapabilities = [GitAnnexShellCapable, GitCapable, RsyncCapable]
+		, sshRepoUrl = Nothing
+		}
+
+{- Finds the best hostname to use for the host that sent the PairMsg.
+ -
+ - If remoteHostName is set, tries to use a .local address based on it.
+ - That's the most robust, if this system supports .local.
+ - Otherwise, looks up the hostname in the DNS for the remoteAddress,
+ - if any. May fall back to remoteAddress if there's no DNS. Ugh. -}
+bestHostName :: PairMsg -> IO HostName
+bestHostName msg = case remoteHostName $ pairMsgData msg of
+	Just h -> do
+		let localname = h ++ ".local"
+		addrs <- catchDefaultIO [] $
+			getAddrInfo Nothing (Just localname) Nothing
+		maybe fallback (const $ return localname) (headMaybe addrs)
+	Nothing -> fallback
+  where
+	fallback = do
+		let a = pairMsgAddr msg
+		let sockaddr = case a of
+			IPv4Addr addr -> SockAddrInet (fromInteger 0) addr
+			IPv6Addr addr -> SockAddrInet6 (fromInteger 0) 0 addr 0
+		fromMaybe (showAddr a)
+			<$> catchDefaultIO Nothing
+				(fst <$> getNameInfo [] True False sockaddr)

Assistant/Pairing/Network.hs

@@ -0,0 +1,132 @@
+{- git-annex assistant pairing network code
+ -
+ - All network traffic is sent over multicast UDP. For reliability,
+ - each message is repeated until acknowledged. This is done using a
+ - thread, that gets stopped before the next message is sent.
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Pairing.Network where
+
+import Assistant.Common
+import Assistant.Pairing
+import Assistant.DaemonStatus
+import Utility.ThreadScheduler
+import Utility.Verifiable
+
+import Network.Multicast
+import Network.Info
+import Network.Socket
+import qualified Network.Socket.ByteString as B
+import qualified Data.ByteString.UTF8 as BU8
+import qualified Data.Map as M
+import Control.Concurrent
+
+{- This is an arbitrary port in the dynamic port range, that could
+ - conceivably be used for some other broadcast messages.
+ - If so, hope they ignore the garbage from us; we'll certianly
+ - ignore garbage from them. Wild wild west. -}
+pairingPort :: PortNumber
+pairingPort = 55556
+
+{- Goal: Reach all hosts on the same network segment.
+ - Method: Use same address that avahi uses. Other broadcast addresses seem
+ - to not be let through some routers. -}
+multicastAddress :: AddrClass -> HostName
+multicastAddress IPv4AddrClass = "224.0.0.251"
+multicastAddress IPv6AddrClass = "ff02::fb"
+
+{- Multicasts a message repeatedly on all interfaces, with a 2 second
+ - delay between each transmission. The message is repeated forever
+ - unless a number of repeats is specified.
+ -
+ - The remoteHostAddress is set to the interface's IP address.
+ -
+ - Note that new sockets are opened each time. This is hardly efficient,
+ - but it allows new network interfaces to be used as they come up.
+ - On the other hand, the expensive DNS lookups are cached.
+ -}
+multicastPairMsg :: Maybe Int -> Secret -> PairData -> PairStage -> IO ()
+multicastPairMsg repeats secret pairdata stage = go M.empty repeats
+  where
+	go _ (Just 0) = noop
+	go cache n = do
+		addrs <- activeNetworkAddresses
+		let cache' = updatecache cache addrs
+		mapM_ (sendinterface cache') addrs
+		threadDelaySeconds (Seconds 2)
+		go cache' $ pred <$> n
+	{- The multicast library currently chokes on ipv6 addresses. -}
+	sendinterface _ (IPv6Addr _) = noop
+	sendinterface cache i = void $ tryIO $
+		withSocketsDo $ bracket setup cleanup use
+	  where
+		setup = multicastSender (multicastAddress IPv4AddrClass) pairingPort
+		cleanup (sock, _) = close sock -- FIXME does not work
+		use (sock, addr) = do
+			setInterface sock (showAddr i)
+			maybe noop
+				(\s -> void $ B.sendTo sock (BU8.fromString s) addr)
+				(M.lookup i cache)
+	updatecache cache [] = cache
+	updatecache cache (i:is)
+		| M.member i cache = updatecache cache is
+		| otherwise = updatecache (M.insert i (show $ mkmsg i) cache) is
+	mkmsg addr = PairMsg $
+		mkVerifiable (stage, pairdata, addr) secret
+
+startSending :: PairingInProgress -> PairStage -> (PairStage -> IO ()) -> Assistant ()
+startSending pip stage sender = do
+	a <- asIO start
+	void $ liftIO $ forkIO a
+  where
+	start = do
+		tid <- liftIO myThreadId
+		let pip' = pip { inProgressPairStage = stage, inProgressThreadId = Just tid }
+		oldpip <- modifyDaemonStatus $
+			\s -> (s { pairingInProgress = Just pip' }, pairingInProgress s)
+		maybe noop stopold oldpip
+		liftIO $ sender stage
+	stopold = maybe noop (liftIO . killThread) . inProgressThreadId
+
+stopSending :: PairingInProgress -> Assistant ()
+stopSending pip = do
+	maybe noop (liftIO . killThread) $ inProgressThreadId pip
+	modifyDaemonStatus_ $ \s -> s { pairingInProgress = Nothing }
+
+class ToSomeAddr a where
+	toSomeAddr :: a -> SomeAddr
+
+instance ToSomeAddr IPv4 where
+	toSomeAddr (IPv4 a) = IPv4Addr a
+
+instance ToSomeAddr IPv6 where
+	toSomeAddr (IPv6 o1 o2 o3 o4) = IPv6Addr (o1, o2, o3, o4)
+
+showAddr :: SomeAddr -> HostName
+showAddr (IPv4Addr a) = show $ IPv4 a
+showAddr (IPv6Addr (o1, o2, o3, o4)) = show $ IPv6 o1 o2 o3 o4
+
+activeNetworkAddresses :: IO [SomeAddr]
+activeNetworkAddresses = filter (not . all (`elem` "0.:") . showAddr)
+	. concatMap (\ni -> [toSomeAddr $ ipv4 ni, toSomeAddr $ ipv6 ni])
+	<$> getNetworkInterfaces
+
+{- A human-visible description of the repository being paired with.
+ - Note that the repository's description is not shown to the user, because
+ - it could be something like "my repo", which is confusing when pairing
+ - with someone else's repo. However, this has the same format as the
+ - default decription of a repo. -}
+pairRepo :: PairMsg -> String
+pairRepo msg = concat
+	[ remoteUserName d
+	, "@"
+	, fromMaybe (showAddr $ pairMsgAddr msg) (remoteHostName d)
+	, ":"
+	, remoteDirectory d
+	]
+  where
+	d = pairMsgData msg

Assistant/Pushes.hs

@@ -0,0 +1,37 @@
+{- git-annex assistant push tracking
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Pushes where
+
+import Assistant.Common
+import Assistant.Types.Pushes
+
+import Control.Concurrent.STM
+import Data.Time.Clock
+import qualified Data.Map as M
+
+{- Blocks until there are failed pushes.
+ - Returns Remotes whose pushes failed a given time duration or more ago.
+ - (This may be an empty list.) -}
+getFailedPushesBefore :: NominalDiffTime -> FailedPushMap -> Assistant [Remote]
+getFailedPushesBefore duration v = liftIO $ do
+	m <- atomically $ readTMVar v
+	now <- getCurrentTime
+	return $ M.keys $ M.filter (not . toorecent now) m
+  where
+	toorecent now time = now `diffUTCTime` time < duration
+
+{- Modifies the map. -}
+changeFailedPushMap :: FailedPushMap -> (PushMap -> PushMap) -> Assistant ()
+changeFailedPushMap v f = liftIO $ atomically $
+	store . f . fromMaybe M.empty =<< tryTakeTMVar v
+  where
+	{- tryTakeTMVar empties the TMVar; refill it only if
+	 - the modified map is not itself empty -}
+	store m
+		| m == M.empty = noop
+		| otherwise = putTMVar v $! m

Assistant/RemoteControl.hs

@@ -0,0 +1,21 @@
+{- git-annex assistant RemoteDaemon control
+ -
+ - Copyright 2014 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.RemoteControl (
+	sendRemoteControl,
+	RemoteDaemon.Consumed(..)
+) where
+
+import Assistant.Common
+import qualified RemoteDaemon.Types as RemoteDaemon
+
+import Control.Concurrent
+
+sendRemoteControl :: RemoteDaemon.Consumed -> Assistant ()
+sendRemoteControl msg = do
+	clicker <- getAssistant remoteControl
+	liftIO $ writeChan clicker msg

Assistant/Repair.hs

@@ -0,0 +1,159 @@
+{- git-annex assistant repository repair
+ -
+ - Copyright 2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.Repair where
+
+import Assistant.Common
+import Command.Repair (repairAnnexBranch, trackingOrSyncBranch)
+import Git.Fsck (FsckResults, foundBroken)
+import Git.Repair (runRepairOf)
+import qualified Git
+import qualified Remote
+import qualified Types.Remote as Remote
+import Logs.FsckResults
+import Annex.UUID
+import Utility.Batch
+import Annex.Path
+import Assistant.Sync
+import Assistant.Alert
+import Assistant.DaemonStatus
+import Assistant.Types.UrlRenderer
+#ifdef WITH_WEBAPP
+import Assistant.WebApp.Types
+import qualified Data.Text as T
+#endif
+import qualified Utility.Lsof as Lsof
+import Utility.ThreadScheduler
+
+import Control.Concurrent.Async
+
+{- When the FsckResults require a repair, tries to do a non-destructive
+ - repair. If that fails, pops up an alert. -}
+repairWhenNecessary :: UrlRenderer -> UUID -> Maybe Remote -> FsckResults -> Assistant Bool
+repairWhenNecessary urlrenderer u mrmt fsckresults
+	| foundBroken fsckresults = do
+		liftAnnex $ writeFsckResults u fsckresults
+		repodesc <- liftAnnex $ Remote.prettyUUID u
+		ok <- alertWhile (repairingAlert repodesc)
+			(runRepair u mrmt False)
+#ifdef WITH_WEBAPP
+		unless ok $ do
+			button <- mkAlertButton True (T.pack "Click Here") urlrenderer $
+				RepairRepositoryR u
+			void $ addAlert $ brokenRepositoryAlert [button]
+#endif
+		return ok
+	| otherwise = return False
+
+runRepair :: UUID -> Maybe Remote -> Bool -> Assistant Bool
+runRepair u mrmt destructiverepair = do
+	fsckresults <- liftAnnex $ readFsckResults u
+	myu <- liftAnnex getUUID
+	ok <- if u == myu
+		then localrepair fsckresults
+		else remoterepair fsckresults
+	liftAnnex $ clearFsckResults u
+	debug [ "Repaired", show u, show ok ]
+
+	return ok
+  where
+	localrepair fsckresults = do
+		-- Stop the watcher from running while running repairs.
+		changeSyncable Nothing False
+
+		-- 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.
+		ok <- liftAnnex $ repair fsckresults Nothing
+
+		-- Run a background fast fsck if a destructive repair had
+		-- to be done, to ensure that the git-annex branch
+		-- reflects the current state of the repo.
+		when destructiverepair $
+			backgroundfsck [ Param "--fast" ]
+
+		-- 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.
+		when (ok || destructiverepair) $
+			changeSyncable Nothing True
+
+		return ok
+
+	remoterepair fsckresults = case Remote.repairRepo =<< mrmt of
+		Nothing -> return False
+		Just mkrepair -> do
+			thisrepopath <- liftIO . absPath
+				=<< liftAnnex (fromRepo Git.repoPath)
+			a <- liftAnnex $ mkrepair $
+				repair fsckresults (Just thisrepopath)
+			liftIO $ catchBoolIO a
+
+	repair fsckresults referencerepo = do
+		(ok, modifiedbranches) <- inRepo $
+			runRepairOf fsckresults trackingOrSyncBranch destructiverepair referencerepo
+		when destructiverepair $
+			repairAnnexBranch modifiedbranches
+		return ok
+	
+	backgroundfsck params = liftIO $ void $ async $ do
+		program <- programPath
+		batchCommand program (Param "fsck" : params)
+
+{- 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). Also, a few lock-file-ish
+ - things used by git are not kept open, particularly MERGE_HEAD.
+ -
+ - So, 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 work to detect when another machine
+ - is writing out a new index file, since git does so by writing the
+ - new content to index.lock.
+ -
+ - Returns true if locks were cleaned up.
+ -}
+repairStaleGitLocks :: Git.Repo -> Assistant Bool
+repairStaleGitLocks r = do
+	lockfiles <- liftIO $ filter islock <$> findgitfiles r
+	repairStaleLocks lockfiles
+	return $ not $ null lockfiles
+  where
+	findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir) True . Git.localGitDir
+	islock f
+		| "gc.pid" `isInfixOf` f = False
+		| ".lock" `isSuffixOf` f = True
+		| takeFileName f == "MERGE_HEAD" = True
+		| otherwise = False
+
+repairStaleLocks :: [FilePath] -> Assistant ()
+repairStaleLocks lockfiles = go =<< getsizes
+  where
+	getsize lf = catchMaybeIO $ (\s -> (lf, s)) <$> getFileSize 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

Assistant/RepoProblem.hs

@@ -0,0 +1,34 @@
+{- git-annex assistant remote problem handling
+ -
+ - Copyright 2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.RepoProblem where
+
+import Assistant.Common
+import Assistant.Types.RepoProblem
+import Utility.TList
+
+import Control.Concurrent.STM
+
+{- Gets all repositories that have problems. Blocks until there is at
+ - least one. -}
+getRepoProblems :: Assistant [RepoProblem]
+getRepoProblems = nubBy sameRepoProblem
+	<$> (atomically . getTList) <<~ repoProblemChan
+
+{- Indicates that there was a problem with a repository, and the problem
+ - appears to not be a transient (eg network connection) problem.
+ -
+ - If the problem is able to be repaired, the passed action will be run.
+ - (However, if multiple problems are reported with a single repository,
+ - only a single action will be run.)
+ -}
+repoHasProblem :: UUID -> Assistant () -> Assistant ()
+repoHasProblem u afterrepair = do
+	rp <- RepoProblem
+		<$> pure u
+		<*> asIO afterrepair
+	(atomically . flip consTList rp) <<~ repoProblemChan

Assistant/Restart.hs

@@ -0,0 +1,117 @@
+{- git-annex assistant restarting
+ -
+ - Copyright 2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.Restart where
+
+import Assistant.Common
+import Assistant.Threads.Watcher
+import Assistant.DaemonStatus
+import Assistant.NamedThread
+import Utility.ThreadScheduler
+import Utility.NotificationBroadcaster
+import Utility.Url
+import Utility.PID
+import qualified Git.Construct
+import qualified Git.Config
+import qualified Annex
+import qualified Git
+import Annex.Path
+
+import Control.Concurrent
+#ifndef mingw32_HOST_OS
+import System.Posix (signalProcess, sigTERM)
+#else
+import System.Win32.Process (terminateProcessById)
+#endif
+import Network.URI
+
+{- Before the assistant can be restarted, have to remove our 
+ - gitAnnexUrlFile and our gitAnnexPidFile. Pausing the watcher is also
+ - a good idea, to avoid fighting when two assistants are running in the
+ - same repo.
+ -}
+prepRestart :: Assistant ()
+prepRestart = do
+	liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread
+	liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexUrlFile)
+	liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexPidFile)
+
+{- To finish a restart, send a global redirect to the new url
+ - to any web browsers that are displaying the webapp.
+ -
+ - Wait for browser to update before terminating this process. -}
+postRestart :: URLString -> Assistant ()
+postRestart url = do
+	modifyDaemonStatus_ $ \status -> status { globalRedirUrl = Just url }
+	liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus
+	void $ liftIO $ forkIO $ do
+		threadDelaySeconds (Seconds 120)
+		terminateSelf
+
+terminateSelf :: IO ()
+terminateSelf =
+#ifndef mingw32_HOST_OS
+		signalProcess sigTERM =<< getPID
+#else
+		terminateProcessById =<< getPID
+#endif
+
+runRestart :: Assistant URLString
+runRestart = liftIO . newAssistantUrl
+	=<< liftAnnex (Git.repoLocation <$> Annex.gitRepo)
+
+{- Starts up the assistant in the repository, and waits for it to create
+ - a gitAnnexUrlFile. Waits for the assistant to be up and listening for
+ - connections by testing the url. -}
+newAssistantUrl :: FilePath -> IO URLString
+newAssistantUrl repo = do
+	startAssistant repo
+	geturl
+  where
+	geturl = do
+		r <- Git.Config.read =<< Git.Construct.fromPath repo
+		waiturl $ gitAnnexUrlFile r
+	waiturl urlfile = do
+		v <- tryIO $ readFile urlfile
+		case v of
+			Left _ -> delayed $ waiturl urlfile
+			Right url -> ifM (assistantListening url)
+				( return url
+				, delayed $ waiturl urlfile
+				)
+	delayed a = do
+		threadDelay 100000 -- 1/10th of a second
+		a
+
+{- Checks if the assistant is listening on an url.
+ -
+ - Always checks http, because https with self-signed cert is problematic.
+ - warp-tls listens to http, in order to show an error page, so this works.
+ -}
+assistantListening :: URLString -> IO Bool
+assistantListening url = catchBoolIO $ exists url' =<< defUrlOptions
+  where
+	url' = case parseURI url of
+		Nothing -> url
+		Just uri -> show $ uri
+			{ uriScheme = "http:"
+			}
+
+{- Does not wait for assistant to be listening for web connections. 
+ -
+ - On windows, the assistant does not daemonize, which is why the forkIO is
+ - done.
+ -}
+startAssistant :: FilePath -> IO ()
+startAssistant repo = void $ forkIO $ do
+	program <- programPath
+	(_, _, _, pid) <- 
+		createProcess $
+			(proc program ["assistant"]) { cwd = Just repo }
+	void $ checkSuccessProcess pid

Assistant/ScanRemotes.hs

@@ -0,0 +1,41 @@
+{- git-annex assistant remotes needing scanning
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.ScanRemotes where
+
+import Assistant.Common
+import Assistant.Types.ScanRemotes
+import qualified Types.Remote as Remote
+
+import Data.Function
+import Control.Concurrent.STM
+import qualified Data.Map as M
+
+{- Blocks until there is a remote or remotes that need to be scanned.
+ -
+ - The list has higher priority remotes listed first. -}
+getScanRemote :: Assistant [(Remote, ScanInfo)]
+getScanRemote = do
+	v <- getAssistant scanRemoteMap
+	liftIO $ atomically $
+		reverse . sortBy (compare `on` scanPriority . snd) . M.toList
+			<$> takeTMVar v
+
+{- Adds new remotes that need scanning. -}
+addScanRemotes :: Bool -> [Remote] -> Assistant ()
+addScanRemotes _ [] = noop
+addScanRemotes full rs = do
+	v <- getAssistant scanRemoteMap
+	liftIO $ atomically $ do
+		m <- fromMaybe M.empty <$> tryTakeTMVar v
+		putTMVar v $ M.unionWith merge (M.fromList $ zip rs (map info rs)) m
+  where
+	info r = ScanInfo (-1 * Remote.cost r) full
+	merge x y = ScanInfo
+		{ scanPriority = max (scanPriority x) (scanPriority y)
+		, fullScan = fullScan x || fullScan y 
+		}

Assistant/Ssh.hs

@@ -0,0 +1,409 @@
+{- git-annex assistant ssh utilities
+ -
+ - Copyright 2012-2013 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Ssh where
+
+import Annex.Common
+import Utility.Tmp
+import Utility.Tmp.Dir
+import Utility.Shell
+import Utility.Rsync
+import Utility.FileMode
+import Utility.SshConfig
+import Git.Remote
+import Utility.SshHost
+import Utility.Process.Transcript
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Char
+import Network.URI
+
+data SshData = SshData
+	{ sshHostName :: Text
+	, sshUserName :: Maybe Text
+	, sshDirectory :: Text
+	, sshRepoName :: String
+	, sshPort :: Int
+	, needsPubKey :: Bool
+	, sshCapabilities :: [SshServerCapability]
+	, sshRepoUrl :: Maybe String
+	}
+	deriving (Read, Show, Eq)
+
+data SshServerCapability
+	= GitAnnexShellCapable -- server has git-annex-shell installed
+	| GitCapable -- server has git installed
+	| RsyncCapable -- server supports raw rsync access (not only via git-annex-shell)
+	| PushCapable -- repo on server is set up already, and ready to accept pushes
+	deriving (Read, Show, Eq)
+
+hasCapability :: SshData -> SshServerCapability -> Bool
+hasCapability d c = c `elem` sshCapabilities d
+
+addCapability :: SshData -> SshServerCapability -> SshData
+addCapability d c = d { sshCapabilities = c : sshCapabilities d }
+
+onlyCapability :: SshData -> SshServerCapability -> Bool
+onlyCapability d c = all (== c) (sshCapabilities d)
+
+type SshPubKey = String
+type SshPrivKey = String
+
+data SshKeyPair = SshKeyPair
+	{ sshPubKey :: SshPubKey
+	, sshPrivKey :: SshPrivKey
+	}
+
+instance Show SshKeyPair where
+	show = sshPubKey
+
+{- ssh -ofoo=bar command-line option -}
+sshOpt :: String -> String -> String
+sshOpt k v = concat ["-o", k, "=", v]
+
+{- user@host or host -}
+genSshHost :: Text -> Maybe Text -> SshHost
+genSshHost host user = either error id $ mkSshHost $
+	maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
+
+{- Generates a ssh or rsync url from a SshData. -}
+genSshUrl :: SshData -> String
+genSshUrl sshdata = case sshRepoUrl sshdata of
+	Just repourl -> repourl
+	Nothing -> addtrailingslash $ T.unpack $ T.concat $
+		if (onlyCapability sshdata RsyncCapable)
+			then [u, h, T.pack ":", sshDirectory sshdata]
+			else [T.pack "ssh://", u, h, d]
+  where
+	u = maybe (T.pack "") (\v -> T.concat [v, T.pack "@"]) $ sshUserName sshdata
+	h = sshHostName sshdata
+	d
+		| T.pack "/" `T.isPrefixOf` sshDirectory sshdata = sshDirectory sshdata
+		| T.pack "~/" `T.isPrefixOf` sshDirectory sshdata = T.concat [T.pack "/", sshDirectory sshdata]
+		| otherwise = T.concat [T.pack "/~/", sshDirectory sshdata]
+	addtrailingslash s
+		| "/" `isSuffixOf` s = s
+		| otherwise = s ++ "/"
+
+{- Reverses genSshUrl -}
+parseSshUrl :: String -> Maybe SshData
+parseSshUrl u
+	| "ssh://" `isPrefixOf` u = fromssh (drop (length "ssh://") u)
+	| otherwise = fromrsync u
+  where
+	mkdata (userhost, dir) = Just $ SshData
+		{ sshHostName = T.pack host
+		, sshUserName = if null user then Nothing else Just $ T.pack user
+		, sshDirectory = T.pack dir
+		, sshRepoName = genSshRepoName host dir
+		-- dummy values, cannot determine from url
+		, sshPort = 22
+		, needsPubKey = True
+		, sshCapabilities = []
+		, sshRepoUrl = Nothing
+		}
+	  where
+		(user, host) = if '@' `elem` userhost
+			then separate (== '@') userhost
+			else ("", userhost)
+	fromrsync s
+		| not (rsyncUrlIsShell u) = Nothing
+		| otherwise = mkdata $ separate (== ':') s
+	fromssh = mkdata . break (== '/')
+
+{- Generates a git remote name, like host_dir or host -}
+genSshRepoName :: String -> FilePath -> String
+genSshRepoName host dir
+	| null dir = makeLegalName host
+	| otherwise = makeLegalName $ host ++ "_" ++ dir
+
+{- The output of ssh, including both stdout and stderr. -}
+sshTranscript :: [String] -> SshHost -> String -> (Maybe String) -> IO (String, Bool)
+sshTranscript opts sshhost cmd input = processTranscript "ssh"
+	(opts ++ [fromSshHost sshhost, cmd]) input
+
+{- Ensure that the ssh public key doesn't include any ssh options, like
+ - command=foo, or other weirdness.
+ -
+ - The returned version of the key has its comment removed.
+ -}
+validateSshPubKey :: SshPubKey -> Either String SshPubKey
+validateSshPubKey pubkey
+	| length (lines pubkey) == 1 = check $ words pubkey
+	| otherwise = Left "too many lines in ssh public key"
+  where
+	check (prefix:key:_) = checkprefix prefix (unwords [prefix, key])
+	check _ = err "wrong number of words in ssh public key"
+
+	err msg = Left $ unwords [msg, pubkey]
+
+	checkprefix prefix validpubkey
+		| ssh == "ssh" && all isAlphaNum keytype = Right validpubkey
+		| otherwise = err "bad ssh public key prefix"
+	  where
+		(ssh, keytype) = separate (== '-') prefix
+
+addAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO Bool
+addAuthorizedKeys gitannexshellonly dir pubkey = boolSystem "sh"
+	[ Param "-c" , Param $ addAuthorizedKeysCommand gitannexshellonly dir pubkey ]
+
+{- Should only be used within the same process that added the line;
+ - the layout of the line is not kepy stable across versions. -}
+removeAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO ()
+removeAuthorizedKeys gitannexshellonly dir pubkey = do
+	let keyline = authorizedKeysLine gitannexshellonly dir pubkey
+	sshdir <- sshDir
+	let keyfile = sshdir </> "authorized_keys"
+	ls <- lines <$> readFileStrict keyfile
+	viaTmp writeSshConfig keyfile $ unlines $ filter (/= keyline) ls
+
+{- Implemented as a shell command, so it can be run on remote servers over
+ - ssh.
+ -
+ - The ~/.ssh/git-annex-shell wrapper script is created if not already
+ - present.
+ -}
+addAuthorizedKeysCommand :: Bool -> FilePath -> SshPubKey -> String
+addAuthorizedKeysCommand gitannexshellonly dir pubkey = intercalate "&&"
+	[ "mkdir -p ~/.ssh"
+	, intercalate "; "
+		[ "if [ ! -e " ++ wrapper ++ " ]"
+		, "then (" ++ intercalate ";" (map echoval script) ++ ") > " ++ wrapper
+		, "fi"
+		]
+	, "chmod 700 " ++ wrapper
+	, "touch ~/.ssh/authorized_keys"
+	, "chmod 600 ~/.ssh/authorized_keys"
+	, unwords
+		[ "echo"
+		, shellEscape $ authorizedKeysLine gitannexshellonly dir pubkey
+		, ">>~/.ssh/authorized_keys"
+		]
+	]
+  where
+	echoval v = "echo " ++ shellEscape v
+	wrapper = "~/.ssh/git-annex-shell"
+	script =
+		[ shebang_portable
+		, "set -e"
+		, "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then"
+		,   runshell "$SSH_ORIGINAL_COMMAND"
+		, "else"
+		,   runshell "$@"
+		, "fi"
+		]
+	runshell var = "exec git-annex-shell -c \"" ++ var ++ "\""
+
+authorizedKeysLine :: Bool -> FilePath -> SshPubKey -> String
+authorizedKeysLine gitannexshellonly dir pubkey
+	| gitannexshellonly = limitcommand ++ pubkey
+	{- TODO: Locking down rsync is difficult, requiring a rather
+	 - long perl script. -}
+	| otherwise = pubkey
+  where
+	limitcommand = "command=\"env GIT_ANNEX_SHELL_DIRECTORY="++shellEscape dir++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding,no-pty "
+
+{- Generates a ssh key pair. -}
+genSshKeyPair :: IO SshKeyPair
+genSshKeyPair = withTmpDir "git-annex-keygen" $ \dir -> do
+	ok <- boolSystem "ssh-keygen"
+		[ Param "-P", Param "" -- no password
+		, Param "-f", File $ dir </> "key"
+		]
+	unless ok $
+		error "ssh-keygen failed"
+	SshKeyPair
+		<$> readFile (dir </> "key.pub")
+		<*> readFile (dir </> "key")
+
+{- Installs a ssh key pair, and sets up ssh config with a mangled hostname
+ - that will enable use of the key. This way we avoid changing the user's
+ - regular ssh experience at all. Returns a modified SshData containing the
+ - mangled hostname.
+ -
+ - Note that the key files are put in ~/.ssh/git-annex/, rather than directly
+ - in ssh because of an **INSANE** behavior of gnome-keyring: It loads
+ - ~/.ssh/ANYTHING.pub, and uses them indiscriminately. But using this key
+ - for a normal login to the server will force git-annex-shell to run,
+ - and locks the user out. Luckily, it does not recurse into subdirectories.
+ -
+ - Similarly, IdentitiesOnly is set in the ssh config to prevent the
+ - ssh-agent from forcing use of a different key.
+ -
+ - Force strict host key checking to avoid repeated prompts
+ - when git-annex and git try to access the remote, if its
+ - host key has changed.
+ -}
+installSshKeyPair :: SshKeyPair -> SshData -> IO SshData
+installSshKeyPair sshkeypair sshdata = do
+	sshdir <- sshDir
+	createDirectoryIfMissing True $ parentDir $ sshdir </> sshPrivKeyFile sshdata
+
+	unlessM (doesFileExist $ sshdir </> sshPrivKeyFile sshdata) $
+		writeFileProtected (sshdir </> sshPrivKeyFile sshdata) (sshPrivKey sshkeypair)
+	unlessM (doesFileExist $ sshdir </> sshPubKeyFile sshdata) $
+		writeFile (sshdir </> sshPubKeyFile sshdata) (sshPubKey sshkeypair)
+
+	setSshConfig sshdata
+		[ ("IdentityFile", "~/.ssh/" ++ sshPrivKeyFile sshdata)
+		, ("IdentitiesOnly", "yes")
+		, ("StrictHostKeyChecking", "yes")
+		]
+
+sshPrivKeyFile :: SshData -> FilePath
+sshPrivKeyFile sshdata = "git-annex" </> "key." ++ mangleSshHostName sshdata
+
+sshPubKeyFile :: SshData -> FilePath
+sshPubKeyFile sshdata = sshPrivKeyFile sshdata ++ ".pub"
+
+{- Generates an installs a new ssh key pair if one is not already
+ - installed. Returns the modified SshData that will use the key pair,
+ - and the key pair. -}
+setupSshKeyPair :: SshData -> IO (SshData, SshKeyPair)
+setupSshKeyPair sshdata = do
+	sshdir <- sshDir
+	mprivkey <- catchMaybeIO $ readFile (sshdir </> sshPrivKeyFile sshdata)
+	mpubkey <- catchMaybeIO $ readFile (sshdir </> sshPubKeyFile sshdata)
+	keypair <- case (mprivkey, mpubkey) of
+		(Just privkey, Just pubkey) -> return $ SshKeyPair
+			{ sshPubKey = pubkey
+			, sshPrivKey = privkey
+			}
+		_ -> genSshKeyPair
+	sshdata' <- installSshKeyPair keypair sshdata
+	return (sshdata', keypair)
+
+{- Fixes git-annex ssh key pairs configured in .ssh/config 
+ - by old versions to set IdentitiesOnly.
+ -
+ - Strategy: Search for IdentityFile lines with key.git-annex
+ - in their names. These are for git-annex ssh key pairs.
+ - Add the IdentitiesOnly line immediately after them, if not already
+ - present.
+ -}
+fixSshKeyPairIdentitiesOnly :: IO ()
+fixSshKeyPairIdentitiesOnly = changeUserSshConfig $ unlines . go [] . lines
+  where
+	go c [] = reverse c
+	go c (l:[])
+		| all (`isInfixOf` l) indicators = go (fixedline l:l:c) []
+		| otherwise = go (l:c) []
+	go c (l:next:rest)
+		| all (`isInfixOf` l) indicators && not ("IdentitiesOnly" `isInfixOf` next) = 
+			go (fixedline l:l:c) (next:rest)
+		| otherwise = go (l:c) (next:rest)
+	indicators = ["IdentityFile", "key.git-annex"]
+	fixedline tmpl = takeWhile isSpace tmpl ++ "IdentitiesOnly yes"
+
+{- Add StrictHostKeyChecking to any ssh config stanzas that were written
+ - by git-annex. -}
+fixUpSshRemotes :: IO ()
+fixUpSshRemotes = modifyUserSshConfig (map go)
+  where
+	go c@(HostConfig h _)
+		| "git-annex-" `isPrefixOf` h = fixupconfig c
+		| otherwise = c
+	go other = other
+
+	fixupconfig c = case findHostConfigKey c "StrictHostKeyChecking" of
+		Nothing -> addToHostConfig c "StrictHostKeyChecking" "yes"
+		Just _ -> c
+
+{- Setups up a ssh config with a mangled hostname.
+ - Returns a modified SshData containing the mangled hostname. -}
+setSshConfig :: SshData -> [(String, String)] -> IO SshData
+setSshConfig sshdata config = do
+	sshdir <- sshDir
+	createDirectoryIfMissing True sshdir
+	let configfile = sshdir </> "config"
+	unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFile configfile) $ do
+		appendFile configfile $ unlines $
+			[ ""
+			, "# Added automatically by git-annex"
+			, "Host " ++ mangledhost
+			] ++ map (\(k, v) -> "\t" ++ k ++ " " ++ v)
+				(settings ++ config)
+		setSshConfigMode configfile
+
+	return $ sshdata
+		{ sshHostName = T.pack mangledhost
+		, sshRepoUrl = replace orighost mangledhost
+			<$> sshRepoUrl sshdata
+		}
+  where
+	orighost = T.unpack $ sshHostName sshdata
+	mangledhost = mangleSshHostName sshdata
+	settings =
+		[ ("Hostname", orighost)
+		, ("Port", show $ sshPort sshdata)
+		]
+
+{- This hostname is specific to a given repository on the ssh host,
+ - so it is based on the real hostname, the username, and the directory.
+ -
+ - The mangled hostname has the form:
+ - "git-annex-realhostname-username_port_dir"
+ - Note that "-" is only used in the realhostname and as a separator;
+ - this is necessary to allow unMangleSshHostName to work.
+ -
+ - Unusual characters are url encoded, but using "." rather than "%"
+ - (the latter has special meaning to ssh).
+ -
+ - In the username and directory, unusual characters are any
+ - non-alphanumerics, other than "_"
+ -
+ - The real hostname is not normally encoded at all. This is done for
+ - backwards compatability and to avoid unnecessary ugliness in the
+ - filename. However, when it contains special characters
+ - (notably ":" which cannot be used on some filesystems), it is url
+ - encoded. To indicate it was encoded, the mangled hostname
+ - has the form
+ - "git-annex-.encodedhostname-username_port_dir"
+ -}
+mangleSshHostName :: SshData -> String
+mangleSshHostName sshdata = intercalate "-" 
+	[ "git-annex"
+	, escapehostname (T.unpack (sshHostName sshdata))
+	, escape extra
+	]
+  where
+	extra = intercalate "_" $ map T.unpack $ catMaybes
+		[ sshUserName sshdata
+		, Just $ T.pack $ show $ sshPort sshdata
+		, Just $ sshDirectory sshdata
+		]
+	safe c
+		| isAlphaNum c = True
+		| c == '_' = True
+		| otherwise = False
+	escape s = replace "%" "." $ escapeURIString safe s
+	escapehostname s
+		| all (\c -> c == '.' || safe c) s = s
+		| otherwise = '.' : escape s
+
+{- Extracts the real hostname from a mangled ssh hostname. -}
+unMangleSshHostName :: String -> String
+unMangleSshHostName h = case splitc '-' h of
+	("git":"annex":rest) -> unescape (intercalate "-" (beginning rest))
+	_ -> h
+  where
+	unescape ('.':s) = unEscapeString (replace "." "%" s)
+	unescape s = s
+
+{- Does ssh have known_hosts data for a hostname? -}
+knownHost :: Text -> IO Bool
+knownHost hostname = do
+	sshdir <- sshDir
+	ifM (doesFileExist $ sshdir </> "known_hosts")
+		( not . null <$> checkhost
+		, return False
+		)
+  where
+	{- ssh-keygen -F can crash on some old known_hosts file -}
+	checkhost = catchDefaultIO "" $
+		readProcess "ssh-keygen" ["-F", T.unpack hostname]

Assistant/Sync.hs

@@ -0,0 +1,274 @@
+{- git-annex assistant repo syncing
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Sync where
+
+import Assistant.Common
+import Assistant.Pushes
+import Assistant.Alert
+import Assistant.Alert.Utility
+import Assistant.DaemonStatus
+import Assistant.ScanRemotes
+import Assistant.RemoteControl
+import qualified Command.Sync
+import Utility.Parallel
+import qualified Git
+import qualified Git.Command
+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 Annex.Ssh
+import qualified Config
+import Git.Config
+import Config.DynamicConfig
+import Assistant.NamedThread
+import Assistant.Threads.Watcher (watchThread, WatcherControl(..))
+import Assistant.TransferSlots
+import Assistant.TransferQueue
+import Assistant.RepoProblem
+import Assistant.Commits
+import Types.Transfer
+import Database.Export
+
+import Data.Time.Clock
+import qualified Data.Map as M
+import Control.Concurrent
+
+{- Syncs with remotes that may have been disconnected for a while.
+ - 
+ - First gets git in sync, and then prepares any necessary file transfers.
+ -
+ - An expensive full scan is queued when the git-annex branches of some of
+ - the remotes have diverged from the local git-annex branch. Otherwise,
+ - it's sufficient to requeue failed transfers.
+ -
+ - Also handles signaling any connectRemoteNotifiers, after the syncing is
+ - done, and records an export commit to make any exports be updated.
+ -}
+reconnectRemotes :: [Remote] -> Assistant ()
+reconnectRemotes [] = recordExportCommit
+reconnectRemotes rs = void $ do
+	rs' <- liftIO $ filterM (Remote.checkAvailable True) rs
+	unless (null rs') $ do
+		failedrs <- syncAction rs' (const go)
+		forM_ failedrs $ \r ->
+			whenM (liftIO $ Remote.checkAvailable False r) $
+				repoHasProblem (Remote.uuid r) (syncRemote r)
+		mapM_ signal $ filter (`notElem` failedrs) rs'
+	recordExportCommit
+  where
+	gitremotes = liftAnnex $ 
+		filterM (notspecialremote <$$> Remote.getRepo) rs
+	notspecialremote r
+		| Git.repoIsUrl r = True
+		| Git.repoIsLocal r = True
+		| Git.repoIsLocalUnknown r = True
+		| otherwise = False
+	sync currentbranch@(Just _, _) = do
+		(failedpull, diverged) <- manualPull currentbranch =<< gitremotes
+		now <- liftIO getCurrentTime
+		failedpush <- pushToRemotes' now =<< gitremotes
+		return (nub $ failedpull ++ failedpush, diverged)
+	{- No local branch exists yet, but we can try pulling. -}
+	sync (Nothing, _) = manualPull (Nothing, Nothing) =<< gitremotes
+	go = do
+		(failed, diverged) <- sync
+			=<< liftAnnex (join Command.Sync.getCurrBranch)
+		addScanRemotes diverged =<<
+			filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) rs
+		return failed
+	signal r = liftIO . mapM_ (flip tryPutMVar ())
+		=<< fromMaybe [] . M.lookup (Remote.uuid r) . connectRemoteNotifiers
+			<$> getDaemonStatus
+
+{- Pushes the local sync branch to all remotes, in
+ - parallel, along with the git-annex branch. This is the same
+ - as "git annex sync", except in parallel, and will co-exist with use of
+ - "git annex sync".
+ -
+ - Avoids running possibly long-duration commands in the Annex monad, so
+ - as not to block other threads.
+ -
+ - This can fail, when the remote's sync branch (or git-annex branch) has
+ - been updated by some other remote pushing into it, or by the remote
+ - itself. To handle failure, a manual pull and merge is done, and the push
+ - is retried.
+ -
+ - When there's a lot of activity, we may fail more than once.
+ - On the other hand, we may fail because the remote is not available.
+ - Rather than retrying indefinitely, after the first retry we enter a
+ - fallback mode, where our push is guarenteed to succeed if the remote is
+ - reachable. If the fallback fails, the push is queued to be retried
+ - later.
+ -
+ - Returns any remotes that it failed to push to.
+ -}
+pushToRemotes :: [Remote] -> Assistant [Remote]
+pushToRemotes remotes = do
+	now <- liftIO getCurrentTime
+	let remotes' = filter (wantpush . Remote.gitconfig) remotes
+	syncAction remotes' (pushToRemotes' now)
+  where
+	wantpush gc
+		| remoteAnnexReadOnly gc = False
+		| not (remoteAnnexPush gc) = False
+		| otherwise = True
+
+pushToRemotes' :: UTCTime -> [Remote] -> Assistant [Remote]
+pushToRemotes' now remotes = do
+	(g, branch, u) <- liftAnnex $ do
+		Annex.Branch.commit =<< Annex.Branch.commitMessage
+		(,,)
+			<$> gitRepo
+			<*> join Command.Sync.getCurrBranch
+			<*> getUUID
+	ret <- go True branch g u remotes
+	return ret
+  where
+	go _ (Nothing, _) _ _ _ = return [] -- no branch, so nothing to do
+	go _ _ _ _ [] = return [] -- no remotes, so nothing to do
+	go shouldretry currbranch@(Just branch, _) g u rs =  do
+		debug ["pushing to", show rs]
+		(succeeded, failed) <- parallelPush g rs (push branch)
+		updatemap succeeded []
+		if null failed
+			then return []
+			else if shouldretry
+				then retry currbranch g u failed
+				else fallback branch g u failed
+
+	updatemap succeeded failed = do
+		v <- getAssistant failedPushMap 
+		changeFailedPushMap v $ \m ->
+			M.union (makemap failed) $
+				M.difference m (makemap succeeded)
+	makemap l = M.fromList $ zip l (repeat now)
+
+	retry currbranch g u rs = do
+		debug ["trying manual pull to resolve failed pushes"]
+		void $ manualPull currbranch rs
+		go False currbranch g u rs
+
+	fallback branch g u rs = do
+		debug ["fallback pushing to", show rs]
+		(succeeded, failed) <- parallelPush g rs (taggedPush u Nothing branch)
+		updatemap succeeded failed
+		return failed
+		
+	push branch remote = Command.Sync.pushBranch remote branch
+
+parallelPush :: Git.Repo -> [Remote] -> (Remote -> Git.Repo -> IO Bool)-> Assistant ([Remote], [Remote])
+parallelPush g rs a = do
+	rgs <- liftAnnex $ mapM topush rs
+	(succeededrgs, failedrgs) <- liftIO $ inParallel (uncurry a) rgs
+	return (map fst succeededrgs, map fst failedrgs)
+  where
+	topush r = (,)
+		<$> pure r
+		<*> (Remote.getRepo r >>= \repo ->
+			sshOptionsTo repo (Remote.gitconfig r) g)
+
+{- Displays an alert while running an action that syncs with some remotes,
+ - and returns any remotes that it failed to sync with.
+ -
+ - Readonly remotes are also hidden (to hide the web special remote).
+ -}
+syncAction :: [Remote] -> ([Remote] -> Assistant [Remote]) -> Assistant [Remote]
+syncAction rs a
+	| null visibleremotes = a rs
+	| otherwise = do
+		i <- addAlert $ syncAlert visibleremotes
+		failed <- a rs
+		failed' <- filterM (not . Git.repoIsLocalUnknown <$$> liftAnnex . Remote.getRepo) failed
+		let succeeded = filter (`notElem` failed) visibleremotes
+		if null succeeded && null failed'
+			then removeAlert i
+			else updateAlertMap $ mergeAlert i $
+				syncResultAlert succeeded failed'
+		return failed
+  where
+	visibleremotes = filter (not . Remote.readonly) rs
+
+{- Manually pull from remotes and merge their branches. Returns any
+ - remotes that it failed to pull from, and a Bool indicating
+ - whether the git-annex branches of the remotes and local had
+ - diverged before the pull.
+ -}
+manualPull :: Command.Sync.CurrBranch -> [Remote] -> Assistant ([Remote], Bool)
+manualPull currentbranch remotes = do
+	g <- liftAnnex gitRepo
+	failed <- forM remotes $ \r -> if wantpull $ Remote.gitconfig r
+		then do
+			g' <- liftAnnex $ do
+				repo <- Remote.getRepo r
+				sshOptionsTo repo (Remote.gitconfig r) g
+			ifM (liftIO $ Git.Command.runBool [Param "fetch", Param $ Remote.name r] g')
+				( return Nothing
+				, return $ Just r
+				)
+		else return Nothing
+	haddiverged <- liftAnnex Annex.Branch.forceUpdate
+	forM_ remotes $ \r ->
+		liftAnnex $ Command.Sync.mergeRemote r
+			currentbranch Command.Sync.mergeConfig def
+	when haddiverged $
+		updateExportTreeFromLogAll
+	return (catMaybes failed, haddiverged)
+  where
+	wantpull gc = remoteAnnexPull gc
+
+{- Start syncing a remote, using a background thread. -}
+syncRemote :: Remote -> Assistant ()
+syncRemote remote = do
+	updateSyncRemotes
+	thread <- asIO $ do
+		reconnectRemotes [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
+	sendRemoteControl RELOAD
+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
+	repo <- Remote.getRepo r
+	let key = Config.remoteConfig repo "sync"
+	Config.setConfig key (boolConfig enabled)
+	void Remote.remoteListRefresh
+
+updateExportTreeFromLogAll :: Assistant ()
+updateExportTreeFromLogAll = do
+	rs <- exportRemotes <$> getDaemonStatus
+	forM_ rs $ \r -> liftAnnex $
+		openDb (Remote.uuid r) >>= updateExportTreeFromLog

Assistant/Threads/Committer.hs

@@ -0,0 +1,513 @@
+{- git-annex assistant commit thread
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.Threads.Committer where
+
+import Assistant.Common
+import Assistant.Changes
+import Assistant.Types.Changes
+import Assistant.Commits
+import Assistant.Alert
+import Assistant.DaemonStatus
+import Assistant.TransferQueue
+import Assistant.Drop
+import Types.Transfer
+import Logs.Location
+import qualified Annex.Queue
+import qualified Git.LsFiles
+import Utility.ThreadScheduler
+import qualified Utility.Lsof as Lsof
+import qualified Utility.DirWatcher as DirWatcher
+import Types.KeySource
+import Config
+import Annex.Content
+import Annex.Ingest
+import Annex.Link
+import Annex.CatFile
+import Annex.InodeSentinal
+import Annex.Version
+import qualified Annex
+import Utility.InodeCache
+import Annex.Content.Direct
+import qualified Database.Keys
+import qualified Command.Sync
+import qualified Git.Branch
+import Utility.Tuple
+
+import Data.Time.Clock
+import qualified Data.Set as S
+import qualified Data.Map as M
+import Data.Either
+import Control.Concurrent
+
+{- This thread makes git commits at appropriate times. -}
+commitThread :: NamedThread
+commitThread = namedThread "Committer" $ do
+	havelsof <- liftIO $ inPath "lsof"
+	delayadd <- liftAnnex $
+		maybe delayaddDefault (return . Just . Seconds)
+			=<< annexDelayAdd <$> Annex.getGitConfig
+	msg <- liftAnnex Command.Sync.commitMsg
+	waitChangeTime $ \(changes, time) -> do
+		readychanges <- handleAdds havelsof delayadd $
+			simplifyChanges changes
+		if shouldCommit False time (length readychanges) readychanges
+			then do
+				debug
+					[ "committing"
+					, show (length readychanges)
+					, "changes"
+					]
+				void $ alertWhile commitAlert $
+					liftAnnex $ commitStaged msg
+				recordCommit
+				recordExportCommit
+				let numchanges = length readychanges
+				mapM_ checkChangeContent readychanges
+				return numchanges
+			else do
+				refill readychanges
+				return 0
+
+refill :: [Change] -> Assistant ()	
+refill [] = noop
+refill cs = do
+	debug ["delaying commit of", show (length cs), "changes"]
+	refillChanges cs
+
+{- Wait for one or more changes to arrive to be committed, and then
+ - runs an action to commit them. If more changes arrive while this is
+ - going on, they're handled intelligently, batching up changes into
+ - large commits where possible, doing rename detection, and
+ - commiting immediately otherwise. -}
+waitChangeTime :: (([Change], UTCTime) -> Assistant Int) -> Assistant ()
+waitChangeTime a = waitchanges 0
+  where
+	waitchanges lastcommitsize = do
+		-- Wait one one second as a simple rate limiter.
+		liftIO $ threadDelaySeconds (Seconds 1)
+		-- Now, wait until at least one change is available for
+		-- processing.
+		cs <- getChanges
+		handlechanges cs lastcommitsize
+	handlechanges changes lastcommitsize = do
+		let len = length changes
+		-- See if now's a good time to commit.
+		now <- liftIO getCurrentTime
+		scanning <- not . scanComplete <$> getDaemonStatus
+		case (lastcommitsize >= maxCommitSize, shouldCommit scanning now len changes, possiblyrename changes) of
+			(True, True, _)
+				| len > maxCommitSize -> 
+					a (changes, now) >>= waitchanges
+				| otherwise -> aftermaxcommit changes
+			(_, True, False) ->
+				a (changes, now) >>= waitchanges
+			(_, True, True) -> do
+				morechanges <- getrelatedchanges changes
+				a (changes ++ morechanges, now) >>= waitchanges
+			_ -> do
+				refill changes
+				waitchanges lastcommitsize
+	
+	{- Did we perhaps only get one of the AddChange and RmChange pair
+	 - that make up a file rename? Or some of the pairs that make up 
+	 - a directory rename?
+	 -}
+	possiblyrename = all renamepart
+
+	renamepart (PendingAddChange _ _) = True
+	renamepart c = isRmChange c
+
+	{- Gets changes related to the passed changes, without blocking
+	 - very long.
+	 -
+	 - If there are multiple RmChanges, this is probably a directory
+	 - rename, in which case it may be necessary to wait longer to get
+	 - all the Changes involved.
+	 -}
+	getrelatedchanges oldchanges
+		| length (filter isRmChange oldchanges) > 1 =
+			concat <$> getbatchchanges []
+		| otherwise = do
+			liftIO humanImperceptibleDelay
+			getAnyChanges
+	getbatchchanges cs = do
+		liftIO $ threadDelay $ fromIntegral $ oneSecond `div` 10
+		cs' <- getAnyChanges
+		if null cs'
+			then return cs
+			else getbatchchanges (cs':cs)
+
+	{- The last commit was maximum size, so it's very likely there
+	 - are more changes and we'd like to ensure we make another commit
+	 - of maximum size if possible.
+	 -
+	 - But, it can take a while for the Watcher to wake back up
+	 - after a commit. It can get blocked by another thread
+	 - that is using the Annex state, such as a git-annex branch
+	 - commit. Especially after such a large commit, this can
+	 - take several seconds. When this happens, it defeats the
+	 - normal commit batching, which sees some old changes the
+	 - Watcher found while the commit was being prepared, and sees
+	 - no recent ones, and wants to commit immediately.
+	 -
+	 - All that we need to do, then, is wait for the Watcher to
+	 - wake up, and queue up one more change.
+	 -
+	 - However, it's also possible that we're at the end of changes for
+	 - now. So to avoid waiting a really long time before committing
+	 - those changes we have, poll for up to 30 seconds, and then
+	 - commit them.
+	 -
+	 - Also, try to run something in Annex, to ensure we block
+	 - longer if the Annex state is indeed blocked.
+	 -}
+	aftermaxcommit oldchanges = loop (30 :: Int)
+	  where
+		loop 0 = continue oldchanges
+		loop n = do
+			liftAnnex noop -- ensure Annex state is free
+			liftIO $ threadDelaySeconds (Seconds 1)
+			changes <- getAnyChanges
+			if null changes
+				then loop (n - 1)
+				else continue (oldchanges ++ changes)
+		continue cs
+			| null cs = waitchanges 0
+			| otherwise = handlechanges cs 0
+
+isRmChange :: Change -> Bool
+isRmChange (Change { changeInfo = i }) | i == RmChange = True
+isRmChange _ = False
+
+{- An amount of time that is hopefully imperceptably short for humans,
+ - while long enough for a computer to get some work done. 
+ - Note that 0.001 is a little too short for rename change batching to
+ - work. -}
+humanImperceptibleInterval :: NominalDiffTime
+humanImperceptibleInterval = 0.01
+
+humanImperceptibleDelay :: IO ()
+humanImperceptibleDelay = threadDelay $
+	truncate $ humanImperceptibleInterval * fromIntegral oneSecond
+
+maxCommitSize :: Int
+maxCommitSize = 5000
+
+{- Decide if now is a good time to make a commit.
+ - Note that the list of changes has a random order.
+ -
+ - Current strategy: If there have been 10 changes within the past second,
+ - a batch activity is taking place, so wait for later.
+ -}
+shouldCommit :: Bool -> UTCTime -> Int -> [Change] -> Bool
+shouldCommit scanning now len changes
+	| scanning = len >= maxCommitSize
+	| len == 0 = False
+	| len >= maxCommitSize = True
+	| length recentchanges < 10 = True
+	| otherwise = False -- batch activity
+  where
+	thissecond c = timeDelta c <= 1
+	recentchanges = filter thissecond changes
+	timeDelta c = now `diffUTCTime` changeTime c
+
+commitStaged :: String -> Annex Bool
+commitStaged msg = do
+	{- This could fail if there's another commit being made by
+	 - something else. -}
+	v <- tryNonAsync Annex.Queue.flush
+	case v of
+		Left _ -> return False
+		Right _ -> do
+			ok <- Command.Sync.commitStaged Git.Branch.AutomaticCommit msg
+			when ok $
+				Command.Sync.updateSyncBranch =<< join Command.Sync.getCurrBranch
+			return ok
+
+{- OSX needs a short delay after a file is added before locking it down,
+ - as pasting a file seems to try to set file permissions or otherwise
+ - access the file after closing it. -}
+delayaddDefault :: Annex (Maybe Seconds)
+#ifdef darwin_HOST_OS
+delayaddDefault = ifM (isDirect <||> versionSupportsUnlockedPointers)
+	( return Nothing
+	, return $ Just $ Seconds 1
+	)
+#else
+delayaddDefault = return Nothing
+#endif
+
+{- If there are PendingAddChanges, or InProcessAddChanges, the files
+ - have not yet actually been added to the annex, and that has to be done
+ - now, before committing.
+ -
+ - Deferring the adds to this point causes batches to be bundled together,
+ - which allows faster checking with lsof that the files are not still open
+ - for write by some other process, and faster checking with git-ls-files
+ - that the files are not already checked into git.
+ -
+ - When a file is added in locked mode, Inotify will notice the new symlink.
+ - So this waits for additional Changes to arrive, so that the symlink has
+ - hopefully been staged before returning, and will be committed immediately.
+ - (OTOH, for kqueue, eventsCoalesce, so instead the symlink is directly
+ - created and staged.)
+ -
+ - Returns a list of all changes that are ready to be committed.
+ - Any pending adds that are not ready yet are put back into the ChangeChan,
+ - where they will be retried later.
+ -}
+handleAdds :: Bool -> Maybe Seconds -> [Change] -> Assistant [Change]
+handleAdds havelsof delayadd cs = returnWhen (null incomplete) $ do
+	let (pending, inprocess) = partition isPendingAddChange incomplete
+	direct <- liftAnnex isDirect
+	unlocked <- liftAnnex versionSupportsUnlockedPointers
+	let lockingfiles = not (unlocked || direct)
+	let lockdownconfig = LockDownConfig
+		{ lockingFile = lockingfiles
+		, hardlinkFileTmp = True
+		}
+	(pending', cleanup) <- if unlocked || direct
+		then return (pending, noop)
+		else findnew pending
+	(postponed, toadd) <- partitionEithers
+		<$> safeToAdd lockdownconfig havelsof delayadd pending' inprocess
+	cleanup
+
+	unless (null postponed) $
+		refillChanges postponed
+
+	returnWhen (null toadd) $ do
+		added <- addaction toadd $
+			catMaybes <$>
+				if not lockingfiles
+					then addunlocked direct toadd
+					else forM toadd (add lockdownconfig)
+		if DirWatcher.eventsCoalesce || null added || unlocked || direct
+			then return $ added ++ otherchanges
+			else do
+				r <- handleAdds havelsof delayadd =<< getChanges
+				return $ r ++ added ++ otherchanges
+  where
+	(incomplete, otherchanges) = partition (\c -> isPendingAddChange c || isInProcessAddChange c) cs
+	
+	-- Find files that are actually new, and not unlocked annexed
+	-- files. The ls-files is run on a batch of files.
+	findnew [] = return ([], noop)
+	findnew pending@(exemplar:_) = do
+		let segments = segmentXargsUnordered $ map changeFile pending
+		rs <- liftAnnex $ forM segments $ \fs ->
+			inRepo (Git.LsFiles.notInRepo False fs)
+		let (newfiles, cleanup) = foldl'
+			(\(l1, a1) (l2, a2) -> (l1 ++ l2, a1 >> a2))
+			([], return True) rs
+		-- note: timestamp info is lost here
+		let ts = changeTime exemplar
+		return (map (PendingAddChange ts) newfiles, void $ liftIO cleanup)
+
+	returnWhen c a
+		| c = return otherchanges
+		| otherwise = a
+
+	add :: LockDownConfig -> Change -> Assistant (Maybe Change)
+	add lockdownconfig change@(InProcessAddChange { lockedDown = ld }) = 
+		catchDefaultIO Nothing <~> doadd
+	  where
+	  	ks = keySource ld
+		doadd = sanitycheck ks $ do
+			(mkey, mcache) <- liftAnnex $ do
+				showStart "add" $ keyFilename ks
+				ingest (Just $ LockedDown lockdownconfig ks) Nothing
+			maybe (failedingest change) (done change mcache $ keyFilename ks) mkey
+	add _ _ = return Nothing
+
+	{- Avoid overhead of re-injesting a renamed unlocked file, by
+	 - examining the other Changes to see if a removed file has the
+	 - same InodeCache as the new file. If so, we can just update
+	 - bookkeeping, and stage the file in git.
+	 -}
+	addunlocked :: Bool -> [Change] -> Assistant [Maybe Change]
+	addunlocked isdirect toadd = do
+		ct <- liftAnnex compareInodeCachesWith
+		m <- liftAnnex $ removedKeysMap isdirect ct cs
+		delta <- liftAnnex getTSDelta
+		let cfg = LockDownConfig
+			{ lockingFile = False
+			, hardlinkFileTmp = True
+			}
+		if M.null m
+			then forM toadd (add cfg)
+			else forM toadd $ \c -> do
+				mcache <- liftIO $ genInodeCache (changeFile c) delta
+				case mcache of
+					Nothing -> add cfg c
+					Just cache ->
+						case M.lookup (inodeCacheToKey ct cache) m of
+							Nothing -> add cfg c
+							Just k -> fastadd isdirect c k
+
+	fastadd :: Bool -> Change -> Key -> Assistant (Maybe Change)
+	fastadd isdirect change key = do
+		let source = keySource $ lockedDown change
+		liftAnnex $ if isdirect
+			then finishIngestDirect key source
+			else finishIngestUnlocked key source
+		done change Nothing (keyFilename source) key
+
+	removedKeysMap :: Bool -> InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key)
+	removedKeysMap isdirect ct l = do
+		mks <- forM (filter isRmChange l) $ \c ->
+			catKeyFile $ changeFile c
+		M.fromList . concat <$> mapM mkpairs (catMaybes mks)
+	  where
+		mkpairs k = map (\c -> (inodeCacheToKey ct c, k)) <$>
+			if isdirect
+				then recordedInodeCache k
+				else Database.Keys.getInodeCaches k
+
+	failedingest change = do
+		refill [retryChange change]
+		liftAnnex showEndFail
+		return Nothing
+
+	done change mcache file key = liftAnnex $ do
+		logStatus key InfoPresent
+		ifM versionSupportsUnlockedPointers
+			( do
+				mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file
+				stagePointerFile file mode =<< hashPointerFile key
+			, do
+				link <- ifM isDirect
+					( calcRepo $ gitAnnexLink file key
+					, makeLink file key mcache
+					)
+				whenM (pure DirWatcher.eventsCoalesce <||> isDirect) $
+					stageSymlink file =<< hashSymlink link
+			)
+		showEndOk
+		return $ Just $ finishedChange change key
+
+	{- Check that the keysource's keyFilename still exists,
+	 - and is still a hard link to its contentLocation,
+	 - before ingesting it. -}
+	sanitycheck keysource a = do
+		fs <- liftIO $ getSymbolicLinkStatus $ keyFilename keysource
+		ks <- liftIO $ getSymbolicLinkStatus $ contentLocation keysource
+		if deviceID ks == deviceID fs && fileID ks == fileID fs
+			then a
+			else do
+				-- remove the hard link
+				when (contentLocation keysource /= keyFilename keysource) $
+					void $ liftIO $ tryIO $ removeFile $ contentLocation keysource
+				return Nothing
+
+	{- Shown an alert while performing an action to add a file or
+	 - files. When only a few files are added, their names are shown
+	 - in the alert. When it's a batch add, the number of files added
+	 - is shown.
+	 -
+	 - Add errors tend to be transient and will be
+	 - automatically dealt with, so the alert is always told
+	 - the add succeeded.
+	 -}
+	addaction [] a = a
+	addaction toadd a = alertWhile' (addFileAlert $ map changeFile toadd) $
+		(,) 
+			<$> pure True
+			<*> a
+
+{- Files can Either be Right to be added now,
+ - or are unsafe, and must be Left for later.
+ -
+ - Check by running lsof on the repository.
+ -}
+safeToAdd :: LockDownConfig -> Bool -> Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change]
+safeToAdd _ _ _ [] [] = return []
+safeToAdd lockdownconfig havelsof delayadd pending inprocess = do
+	maybe noop (liftIO . threadDelaySeconds) delayadd
+	liftAnnex $ do
+		lockeddown <- forM pending $ lockDown lockdownconfig . changeFile
+		let inprocess' = inprocess ++ mapMaybe mkinprocess (zip pending lockeddown)
+		openfiles <- if havelsof
+			then S.fromList . map fst3 . filter openwrite <$>
+				findopenfiles (map (keySource . lockedDown) inprocess')
+			else pure S.empty
+		let checked = map (check openfiles) inprocess'
+
+		{- If new events are received when files are closed,
+		 - there's no need to retry any changes that cannot
+		 - be done now. -}
+		if DirWatcher.closingTracked
+			then do
+				mapM_ canceladd $ lefts checked
+				allRight $ rights checked
+			else return checked
+  where
+	check openfiles change@(InProcessAddChange { lockedDown = ld })
+		| S.member (contentLocation (keySource ld)) openfiles = Left change
+	check _ change = Right change
+
+	mkinprocess (c, Just ld) = Just InProcessAddChange
+		{ changeTime = changeTime c
+		, lockedDown = ld
+		}
+	mkinprocess (_, Nothing) = Nothing
+
+	canceladd (InProcessAddChange { lockedDown = ld }) = do
+		let ks = keySource ld
+		warning $ keyFilename ks
+			++ " still has writers, not adding"
+		-- remove the hard link
+		when (contentLocation ks /= keyFilename ks) $
+			void $ liftIO $ tryIO $ removeFile $ contentLocation ks
+	canceladd _ = noop
+
+	openwrite (_file, mode, _pid)
+		| mode == Lsof.OpenWriteOnly = True
+		| mode == Lsof.OpenReadWrite = True
+		| mode == Lsof.OpenUnknown = True
+		| otherwise = False
+
+	allRight = return . map Right
+
+	{- Normally the KeySources are locked down inside the temp directory,
+	 - so can just lsof that, which is quite efficient.
+	 -
+	 - In crippled filesystem mode, there is no lock down, so must run lsof
+	 - on each individual file.
+	 -}
+	findopenfiles keysources = ifM crippledFileSystem
+		( liftIO $ do
+			let segments = segmentXargsUnordered $ map keyFilename keysources
+			concat <$> forM segments (\fs -> Lsof.query $ "--" : fs)
+		, do
+			tmpdir <- fromRepo gitAnnexTmpMiscDir
+			liftIO $ Lsof.queryDir tmpdir
+		)
+
+{- After a Change is committed, queue any necessary transfers or drops
+ - of the content of the key.
+ -
+ - This is not done during the startup scan, because the expensive
+ - transfer scan does the same thing then.
+ -}
+checkChangeContent :: Change -> Assistant ()
+checkChangeContent change@(Change { changeInfo = i }) =
+	case changeInfoKey i of
+		Nothing -> noop
+		Just k -> whenM (scanComplete <$> getDaemonStatus) $ do
+			present <- liftAnnex $ inAnnex k
+			void $ if present
+				then queueTransfers "new file created" Next k af Upload
+				else queueTransfers "new or renamed file wanted" Next k af Download
+			handleDrops "file renamed" present k af []
+  where
+	f = changeFile change
+	af = AssociatedFile (Just f)
+checkChangeContent _ = noop

Assistant/Threads/ConfigMonitor.hs

@@ -0,0 +1,92 @@
+{- git-annex assistant config monitor thread
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Threads.ConfigMonitor where
+
+import Assistant.Common
+import Assistant.BranchChange
+import Assistant.DaemonStatus
+import Assistant.Commits
+import Utility.ThreadScheduler
+import Logs
+import Logs.UUID
+import Logs.Trust
+import Logs.PreferredContent
+import Logs.Group
+import Logs.NumCopies
+import Remote.List (remoteListRefresh)
+import qualified Git.LsTree as LsTree
+import Git.Types
+import Git.FilePath
+import qualified Annex.Branch
+
+import qualified Data.Set as S
+
+{- This thread detects when configuration changes have been made to the
+ - git-annex branch and reloads cached configuration.
+ -
+ - If the branch is frequently changing, it's checked for configuration
+ - changes no more often than once every 60 seconds. On the other hand,
+ - if the branch has not changed in a while, configuration changes will
+ - be detected immediately.
+ -}
+configMonitorThread :: NamedThread
+configMonitorThread = namedThread "ConfigMonitor" $ loop =<< getConfigs
+  where
+	loop old = do
+		waitBranchChange
+		new <- getConfigs
+		when (old /= new) $ do
+			let changedconfigs = new `S.difference` old
+			debug $ "reloading config" : 
+				map fst (S.toList changedconfigs)
+			reloadConfigs new
+			{- Record a commit to get this config
+			 - change pushed out to remotes. -}
+			recordCommit
+		liftIO $ threadDelaySeconds (Seconds 60)
+		loop new
+
+{- Config files, and their checksums. -}
+type Configs = S.Set (FilePath, Sha)
+
+{- All git-annex's config files, and actions to run when they change. -}
+configFilesActions :: [(FilePath, Assistant ())]
+configFilesActions =
+	[ (uuidLog, void $ liftAnnex uuidMapLoad)
+	, (remoteLog, void $ liftAnnex remoteListRefresh)
+	, (trustLog, void $ liftAnnex trustMapLoad)
+	, (groupLog, void $ liftAnnex groupMapLoad)
+	, (numcopiesLog, void $ liftAnnex globalNumCopiesLoad)
+	, (scheduleLog, void updateScheduleLog)
+	-- Preferred and required content settings depend on most of the
+	-- other configs, so will be reloaded whenever any configs change.
+	, (preferredContentLog, noop)
+	, (requiredContentLog, noop)
+	, (groupPreferredContentLog, noop)
+	]
+
+reloadConfigs :: Configs -> Assistant ()
+reloadConfigs changedconfigs = do
+	sequence_ as
+	void $ liftAnnex preferredRequiredMapsLoad
+	{- Changes to the remote log, or the trust log, can affect the
+	 - syncRemotes list. Changes to the uuid log may affect its
+	 - display so are also included. -}
+	when (any (`elem` fs) [remoteLog, trustLog, uuidLog])
+		updateSyncRemotes
+  where
+	(fs, as) = unzip $ filter (flip S.member changedfiles . fst)
+		configFilesActions
+	changedfiles = S.map fst changedconfigs
+
+getConfigs :: Assistant Configs
+getConfigs = S.fromList . map extract
+	<$> liftAnnex (inRepo $ LsTree.lsTreeFiles Annex.Branch.fullname files)
+  where
+	files = map fst configFilesActions
+	extract treeitem = (getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem)