7695 changed files with 153 additions and 245746 deletions
--- a/.forgejo/patches/ghc-9.8.patch
+++ b/.forgejo/patches/ghc-9.8.patch
@ -0,0 +1,18 @@
 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
--- a/.forgejo/workflows/generate-lockfile.yml
+++ b/.forgejo/workflows/generate-lockfile.yml
@ -0,0 +1,85 @@
 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
--- a/.forgejo/workflows/mirror-repository.yml
+++ b/.forgejo/workflows/mirror-repository.yml
@ -0,0 +1,50 @@
 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   
--- a/.ghci
+++ b/.ghci
@ -1 +0,0 @@
 :load Common
--- a/.gitattributes
+++ b/.gitattributes
@ -1 +0,0 @@
 debian/changelog merge=dpkg-mergechangelogs
--- a/.gitignore
+++ b/.gitignore
@ -1,35 +0,0 @@
 tags
 Setup
 *.hi
 *.o
 tmp
 test
 build-stamp
 Build/SysConfig.hs
 Build/InstallDesktopFile
 Build/EvilSplicer
 Build/Standalone
 Build/OSXMkLibs
 Build/LinuxMkLibs
 Build/BuildVersion
 git-annex
 git-annex.1
 git-annex-shell.1
 git-union-merge
 git-union-merge.1
 doc/.ikiwiki
 html
 *.tix
 .hpc
 dist
 # Sandboxed builds
 cabal-dev
 .cabal-sandbox
 cabal.sandbox.config
 cabal.config
 # Project-local emacs configuration
 .dir-locals.el
 # OSX related
 .DS_Store
 .virthualenv
 .tasty-rerun-log
--- a/.mailmap
+++ b/.mailmap
@ -1,7 +0,0 @@
 Joey Hess <id@joeyh.name> http://joey.kitenet.net/ <joey@web>
 Joey Hess <id@joeyh.name> http://joeyh.name/ <joey@web>
 Joey Hess <id@joeyh.name> http://joeyh.name/ <http://joeyh.name/@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>
 Richard Hartmann <richih@debian.org> https://www.google.com/accounts/o8/id?id=AItOawl9sYlePmv1xK-VvjBdN-5doOa_Xw-jH4U <Richard@web>
--- a/Annex.hs
+++ b/Annex.hs
@ -1,312 +0,0 @@
 {- git-annex monad
 -
 - Copyright 2010-2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, PackageImports #-}
 module Annex (
 	Annex,
 	AnnexState(..),
 	new,
 	run,
 	eval,
 	getState,
 	changeState,
 	withState,
 	setFlag,
 	setField,
 	setOutput,
 	getFlag,
 	getField,
 	addCleanup,
 	gitRepo,
 	inRepo,
 	fromRepo,
 	calcRepo,
 	getGitConfig,
 	changeGitConfig,
 	changeGitRepo,
 	getRemoteGitConfig,
 	withCurrentState,
 	changeDirectory,
 ) where
 import Common
 import qualified Git
 import qualified Git.Config
 import Annex.Direct.Fixup
 import Git.CatFile
 import Git.CheckAttr
 import Git.CheckIgnore
 import Git.SharedRepository
 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.UUID
 import Types.FileMatcher
 import Types.NumCopies
 import Types.LockPool
 import Types.MetaData
 import Types.DesktopNotify
 import Types.CleanupActions
 #ifdef WITH_QUVI
 import Utility.Quvi (QuviVersion)
 #endif
 import Utility.InodeCache
 import Utility.Url
 import "mtl" Control.Monad.Reader
 import Control.Concurrent
 import qualified Data.Map 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,
 - ny 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
 	, gitconfig :: GitConfig
 	, backends :: [BackendA Annex]
 	, remotes :: [Types.Remote.RemoteA Annex]
 	, remoteannexstate :: M.Map UUID AnnexState
 	, output :: MessageState
 	, force :: Bool
 	, fast :: Bool
 	, auto :: Bool
 	, daemon :: Bool
 	, branchstate :: BranchState
 	, repoqueue :: Maybe Git.Queue.Queue
 	, catfilehandles :: M.Map FilePath CatFileHandle
 	, 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)
 	, shared :: Maybe SharedRepository
 	, forcetrust :: TrustMap
 	, trustmap :: Maybe TrustMap
 	, groupmap :: Maybe GroupMap
 	, ciphers :: M.Map StorableCipher Cipher
 	, lockpool :: LockPool
 	, flags :: M.Map String Bool
 	, fields :: M.Map String String
 	, modmeta :: [ModMeta]
 	, cleanup :: M.Map CleanupAction (Annex ())
 	, sentinalstatus :: Maybe SentinalStatus
 	, useragent :: Maybe String
 	, errcounter :: Integer
 	, unusedkeys :: Maybe (S.Set Key)
 	, tempurls :: M.Map Key URLString
 #ifdef WITH_QUVI
 	, quviversion :: Maybe QuviVersion
 #endif
 	, existinghooks :: M.Map Git.Hook.Hook Bool
 	, desktopnotify :: DesktopNotify
 	}
 newState :: GitConfig -> Git.Repo -> AnnexState
 newState c r = AnnexState
 	{ repo = r
 	, gitconfig = c
 	, backends = []
 	, remotes = []
 	, remoteannexstate = M.empty
 	, output = defaultMessageState
 	, force = False
 	, fast = False
 	, auto = False
 	, daemon = False
 	, branchstate = startBranchState
 	, repoqueue = Nothing
 	, catfilehandles = M.empty
 	, checkattrhandle = Nothing
 	, checkignorehandle = Nothing
 	, forcebackend = Nothing
 	, globalnumcopies = Nothing
 	, forcenumcopies = Nothing
 	, limit = BuildingMatcher []
 	, uuidmap = Nothing
 	, preferredcontentmap = Nothing
 	, requiredcontentmap = Nothing
 	, shared = Nothing
 	, forcetrust = M.empty
 	, trustmap = Nothing
 	, groupmap = Nothing
 	, ciphers = M.empty
 	, lockpool = M.empty
 	, flags = M.empty
 	, fields = M.empty
 	, modmeta = []
 	, cleanup = M.empty
 	, sentinalstatus = Nothing
 	, useragent = Nothing
 	, errcounter = 0
 	, unusedkeys = Nothing
 	, tempurls = M.empty
 #ifdef WITH_QUVI
 	, quviversion = Nothing
 #endif
 	, existinghooks = M.empty
 	, desktopnotify = mempty
 	}
 {- Makes an Annex state object for the specified git repo.
 - Ensures the config is read, if it was not already. -}
 new :: Git.Repo -> IO AnnexState
 new r = do
 	r' <- Git.Config.read =<< Git.relPath r
 	let c = extractGitConfig r'
 	newState c <$> if annexDirect c then fixupDirect r' else return r'
 {- 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 = do
 	mvar <- newMVar s
 	r <- runReaderT (runAnnex a) mvar
 	s' <- takeMVar mvar
 	return (r, s')
 {- 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 = do
 	mvar <- newMVar s
 	runReaderT (runAnnex a) mvar
 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 -> (AnnexState, b)) -> Annex b
 withState modifier = do
 	mvar <- ask
 	liftIO $ modifyMVar mvar $ return . modifier
 {- Sets a flag to True -}
 setFlag :: String -> Annex ()
 setFlag flag = changeState $ \s ->
 	s { flags = M.insertWith' const flag True $ flags s }
 {- Sets a field to a value -}
 setField :: String -> String -> Annex ()
 setField field value = changeState $ \s ->
 	s { fields = M.insertWith' const field value $ fields s }
 {- Adds a cleanup action to perform. -}
 addCleanup :: CleanupAction -> Annex () -> Annex ()
 addCleanup k a = changeState $ \s ->
 	s { cleanup = M.insertWith' const k a $ cleanup s }
 {- Sets the type of output to emit. -}
 setOutput :: OutputType -> Annex ()
 setOutput o = changeState $ \s ->
 	s { output = (output s) { outputType = 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 = changeState $ \s -> s
 	{ repo = r
 	, gitconfig = extractGitConfig r
 	}
 {- Gets the RemoteGitConfig from a remote, given the Git.Repo for that
 - remote. -}
 getRemoteGitConfig :: Git.Repo -> Annex RemoteGitConfig
 getRemoteGitConfig r = do
 	g <- gitRepo
 	return $ 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' }
--- a/Annex/AutoMerge.hs
+++ b/Annex/AutoMerge.hs
@ -1,206 +0,0 @@
 {- git-annex automatic merge conflict resolution
 -
 - Copyright 2012-2014 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Annex.AutoMerge
 	( autoMergeFrom
 	, resolveMerge
 	, commitResolvedMerge
 	) where
 import Common.Annex
 import qualified Annex.Queue
 import Annex.Direct
 import Annex.CatFile
 import Annex.Link
 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 (BlobType(..))
 import Config
 import Annex.ReplaceFile
 import Git.FileMode
 import Annex.VariantFile
 import qualified Data.Set as S
 {- 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 changed from the current branch to the branch being merged in.
 -}
 autoMergeFrom :: Git.Ref -> (Maybe Git.Ref) -> Git.Branch.CommitMode -> Annex Bool
 autoMergeFrom branch currbranch 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 old branch) commitmode
 		, inRepo (Git.Merge.mergeNonInteractive branch commitmode)
 			<||> (resolveMerge old branch <&&> commitResolvedMerge commitmode)
 		)
 {- 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.
 -}
 resolveMerge :: Maybe Git.Ref -> Git.Ref -> Annex Bool
 resolveMerge us them = do
 	top <- fromRepo Git.repoPath
 	(fs, cleanup) <- inRepo (LsFiles.unmerged [top])
 	mergedfs <- catMaybes <$> mapM (resolveMerge' us them) fs
 	let merged = not (null mergedfs)
 	void $ liftIO cleanup
 	unlessM isDirect $ do
 		(deleted, cleanup2) <- inRepo (LsFiles.deleted [top])
 		unless (null deleted) $
 			Annex.Queue.addCommand "rm" [Params "--quiet -f --"] deleted
 		void $ liftIO cleanup2
 	when merged $ do
 		unlessM isDirect $
 			cleanConflictCruft mergedfs top
 		Annex.Queue.flush
 		showLongNote "Merge conflict was automatically resolved; you may want to examine the result."
 	return merged
 resolveMerge' :: Maybe Git.Ref -> Git.Ref -> LsFiles.Unmerged -> Annex (Maybe FilePath)
 resolveMerge' Nothing _ _ = return Nothing
 resolveMerge' (Just us) them u = do
 	kus <- getkey LsFiles.valUs LsFiles.valUs 
 	kthem <- getkey LsFiles.valThem LsFiles.valThem
 	case (kus, kthem) of
 		-- Both sides of conflict are annexed files
 		(Just keyUs, Just keyThem)
 			| keyUs /= keyThem -> resolveby $ do
 				makelink keyUs
 				makelink keyThem
 			| otherwise -> resolveby $
 				makelink keyUs
 		-- Our side is annexed file, other side is not.
 		(Just keyUs, Nothing) -> resolveby $ do
 			graftin them file LsFiles.valThem LsFiles.valThem
 			makelink keyUs
 		-- Our side is not annexed file, other side is.
 		(Nothing, Just keyThem) -> resolveby $ do
 			graftin us file LsFiles.valUs LsFiles.valUs
 			makelink keyThem
 		-- Neither side is annexed file; cannot resolve.
 		(Nothing, Nothing) -> return Nothing
  where
 	file = LsFiles.unmergedFile u
 	getkey select select'
 		| select (LsFiles.unmergedBlobType u) == Just SymlinkBlob =
 			case select' (LsFiles.unmergedSha u) of
 				Nothing -> return Nothing
 				Just sha -> catKey sha symLinkMode
 		| otherwise = return Nothing
 	makelink key = do
 		let dest = variantFile file key
 		l <- calcRepo $ gitAnnexLink dest key
 		replacewithlink dest l
 		stageSymlink dest =<< hashSymlink l
 	replacewithlink dest link = ifM isDirect
 		( do
 			d <- fromRepo gitAnnexMergeDir
 			replaceFile (d </> dest) $ makeGitLink link
 		, replaceFile dest $ makeGitLink link
 		)
 	{- Stage a graft of a directory or file from a branch.
 	 -
 	 - When there is a conflicted merge where one side is a directory
 	 - or file, and the other side is a symlink, git merge always
 	 - updates the work tree to contain the non-symlink. So, the
 	 - directory or file will already be in the work tree correctly,
 	 - and they just need to be staged into place. Do so by copying the
 	 - index. (Note that this is also better than calling git-add
 	 - because on a crippled filesystem, it preserves any symlink
 	 - bits.)
 	 -
 	 - It's also possible for the branch to have a symlink in it,
 	 - which is not a git-annex symlink. In this special case,
 	 - git merge does not update the work tree to contain the symlink
 	 - from the branch, so we have to do so manually.
 	 -}
 	graftin b item select select' = do
 		Annex.Queue.addUpdateIndex
 			=<< fromRepo (UpdateIndex.lsSubTree b item)
 		when (select (LsFiles.unmergedBlobType u) == Just SymlinkBlob) $
 			case select' (LsFiles.unmergedSha u) of
 				Nothing -> noop
 				Just sha -> do
 					link <- catLink True sha
 					replacewithlink item link
 	resolveby a = do
 		{- Remove conflicted file from index so merge can be resolved. -}
 		Annex.Queue.addCommand "rm" [Params "--quiet -f --cached --"] [file]
 		void a
 		return (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) look like git-annex symlinks.
 -}
 cleanConflictCruft :: [FilePath] -> FilePath -> Annex ()
 cleanConflictCruft resolvedfs top = do
 	(fs, cleanup) <- inRepo $ LsFiles.notInRepo False [top]
 	mapM_ clean fs
 	void $ liftIO cleanup
  where
 	clean f
 		| matchesresolved f = whenM (isJust <$> isAnnexLink f) $
 			liftIO $ nukeFile f
 		| otherwise = noop
 	s = S.fromList resolvedfs
 	matchesresolved f = S.member f s || S.member (base f) s
 	base f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f
 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"
 	]
--- a/Annex/Branch.hs
+++ b/Annex/Branch.hs
@ -1,559 +0,0 @@
 {- management of the git-annex branch
 -
 - Copyright 2011-2013 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,
 	commit,
 	forceCommit,
 	files,
 	withIndex,
 	performTransitions,
 ) where
 import qualified Data.ByteString.Lazy as L
 import qualified Data.Set as S
 import qualified Data.Map as M
 import Data.Bits.Utils
 import Control.Concurrent (threadDelay)
 import Common.Annex
 import Annex.BranchState
 import Annex.Journal
 import Annex.Index
 import qualified Git
 import qualified Git.Command
 import qualified Git.Ref
 import qualified Git.Sha
 import qualified Git.Branch
 import qualified Git.UnionMerge
 import qualified Git.UpdateIndex
 import Git.HashObject
 import Git.Types
 import Git.FilePath
 import Annex.CatFile
 import Annex.Perms
 import Logs
 import Logs.Transitions
 import Logs.Trust.Pure
 import Logs.Difference.Pure
 import Annex.ReplaceFile
 import qualified Annex.Queue
 import Annex.Branch.Transitions
 import qualified Annex
 {- 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 (refs, branches), including the main one and any
 - from remotes. Duplicate refs are filtered out. -}
 siblingBranches :: Annex [(Git.Ref, 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.Ref, Git.Branch)] -> Annex Bool
 updateTo pairs = do
 	-- ensure branch exists, and get its current ref
 	branchref <- getBranch
 	dirty <- journalDirty
 	ignoredrefs <- getIgnoredRefs
 	(refs, branches) <- unzip <$> filterM (isnewer ignoredrefs) pairs
 	if null refs
 		{- Even when no refs need to be merged, the index
 		 - may still be updated if the branch has gotten ahead 
 		 - of the index. -}
 		then 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 refs branches
 	return $ not $ null refs
  where
 	isnewer ignoredrefs (r, _)
 		| S.member r ignoredrefs = return False
 		| otherwise = inRepo $ Git.Branch.changed fullname r
 	go branchref dirty refs branches jl = withIndex $ do
 		cleanjournal <- if dirty then stageJournal jl else return noop
 		let merge_desc = if null branches
 			then "update"
 			else "merging " ++
 				unwords (map Git.Ref.describe branches) ++ 
 				" into " ++ fromRef name
 		localtransitions <- parseTransitionsStrictly "local"
 			<$> getLocal transitionsLog
 		unless (null branches) $ do
 			showSideAction merge_desc
 			mapM_ checkBranchDifferences refs
 			mergeIndex jl refs
 		let commitrefs = nub $ fullname:refs
 		unlessM (handleTransitions jl localtransitions commitrefs) $ 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
 		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 = getRaw file
 getRaw :: FilePath -> Annex String
 getRaw = getRef fullname
 getHistorical :: RefDate -> FilePath -> Annex String
 getHistorical date = getRef (Git.Ref.dateRef fullname date)
 getRef :: Ref -> FilePath -> Annex String
 getRef ref file = withIndex $ decodeBS <$> catFile ref file
 {- Applies a function to modifiy 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 a = lockJournal $ \jl -> a <$> getLocal file >>= set jl file
 {- Records new content of a file into the journal -}
 set :: JournalLocked -> FilePath -> String -> Annex ()
 set = setJournalFile
 {- 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 = c2w8 '\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. There may be duplicates in the list. -}
 files :: Annex [FilePath]
 files = do
 	update
 	(++)
 		<$> branchFiles
 		<*> getJournalledFilesStale
 {- Files in the branch, not including any from journalled changes,
 - and without updating the branch. -}
 branchFiles :: Annex [FilePath]
 branchFiles = withIndex $ inRepo $ Git.Command.pipeNullSplitZombie
 	[ Params "ls-tree --name-only -r -z"
 	, Param $ fromRef fullname
 	]
 {- 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
 	h <- catFileHandle
 	inRepo $ \g -> Git.UnionMerge.mergeIndex h 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 <- liftIO . absPath =<< 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
 	liftIO $ writeFile f $ fromRef ref ++ "\n"
 	setAnnexFilePerm f
 {- 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
 	withJournalHandle $ \jh -> do
 		h <- hashObjectStart g
 		Git.UpdateIndex.streamUpdateIndex g
 			[genstream dir h jh jlogh]
 		hashObjectStop h
 	return $ cleanup dir jlogh jlogf
  where
 	genstream dir h jh jlogh streamer = do
 		v <- readDirectory jh
 		case v of
 			Nothing -> return ()
 			Just file -> do
 				unless (dirCruft file) $ do
 					let path = dir </> file
 					sha <- hashFile h path
 					hPutStrLn jlogh file
 					streamer $ Git.UpdateIndex.updateIndexLine
 						sha FileBlob (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)
 ignoreRefs :: [Git.Ref] -> Annex ()
 ignoreRefs rs = do
 	old <- getIgnoredRefs
 	let s = S.unions [old, S.fromList rs]
 	f <- fromRepo gitAnnexIgnoredRefs
 	replaceFile f $ \tmp -> liftIO $ writeFile tmp $
 		unlines $ map fromRef $ S.elems s
 getIgnoredRefs :: Annex (S.Set Git.Ref)
 getIgnoredRefs = S.fromList . mapMaybe Git.Sha.extractSha . lines <$> content
  where
 	content = do
 		f <- fromRepo gitAnnexIgnoredRefs
 		liftIO $ catchDefaultIO "" $ readFile f
 {- 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
 	withIndex $ do
 		prepareModifyIndex jl
 		run $ mapMaybe getTransitionCalculator $ transitionList ts
 		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 $ 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,
 	 - that value is remembered and fed into the code for subsequent
 	 - transitions.
 	 -}
 	run [] = noop
 	run changers = do
 		trustmap <- calcTrustMap <$> getRaw trustLog
 		fs <- branchFiles
 		hasher <- inRepo hashObjectStart
 		forM_ fs $ \f -> do
 			content <- getRaw f
 			apply changers hasher f content trustmap
 		liftIO $ hashObjectStop hasher
 	apply [] _ _ _ _ = return ()
 	apply (changer:rest) hasher 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 <- inRepo $ hashObject BlobObject content'
 				Annex.Queue.addUpdateIndex $ Git.UpdateIndex.pureStreamer $
 					Git.UpdateIndex.updateIndexLine sha FileBlob (asTopFilePath file)
 				apply rest hasher file content' trustmap
 			PreserveFile ->
 				apply rest hasher file content trustmap
 checkBranchDifferences :: Git.Ref -> Annex ()
 checkBranchDifferences ref = do
 	theirdiffs <- allDifferences . parseDifferencesLog . decodeBS
 		<$> catFile ref differenceLog
 	mydiffs <- annexDifferences <$> Annex.getGitConfig
 	when (theirdiffs /= mydiffs) $
 		error "Remote repository is tuned in incompatable way; cannot be merged with local repository."
--- a/Annex/Branch/Transitions.hs
+++ b/Annex/Branch/Transitions.hs
@ -1,64 +0,0 @@
 {- 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 :: Ord k => 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
--- a/Annex/BranchState.hs
+++ b/Annex/BranchState.hs
@ -1,43 +0,0 @@
 {- 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 Common.Annex
 import Types.BranchState
 import qualified Annex
 getState :: Annex BranchState
 getState = Annex.getState Annex.branchstate
 setState :: BranchState -> Annex ()
 setState state = Annex.changeState $ \s -> s { Annex.branchstate = state }
 changeState :: (BranchState -> BranchState) -> Annex ()
 changeState changer = setState =<< changer <$> getState
 {- 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 }
--- a/Annex/CatFile.hs
+++ b/Annex/CatFile.hs
@ -1,158 +0,0 @@
 {- git cat-file interface, with handle automatically stored in the Annex monad
 -
 - Copyright 2011-2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Annex.CatFile (
 	catFile,
 	catFileDetails,
 	catObject,
 	catTree,
 	catObjectDetails,
 	catFileHandle,
 	catFileStop,
 	catKey,
 	catKeyFile,
 	catKeyFileHEAD,
 	catLink,
 ) where
 import qualified Data.ByteString.Lazy as L
 import qualified Data.Map as M
 import System.PosixCompat.Types
 import Common.Annex
 import qualified Git
 import qualified Git.CatFile
 import qualified Annex
 import Git.Types
 import Git.FilePath
 import Git.FileMode
 import qualified Git.Ref
 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
 catTree :: Git.Ref -> Annex [(FilePath, FileMode)]
 catTree ref = do
 	h <- catFileHandle
 	liftIO $ Git.CatFile.catTree 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 "GIT_INDEX_FILE")
 		<$> 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 $ \s ->
 		(s { Annex.catfilehandles = M.empty }, Annex.catfilehandles s)
 	liftIO $ mapM_ Git.CatFile.catFileStop (M.elems m)
 {- From the Sha or Ref of a symlink back to the key.
 -
 - Requires a mode witness, to guarantee that the file is a symlink.
 -}
 catKey :: Ref -> FileMode -> Annex (Maybe Key)
 catKey = catKey' True
 catKey' :: Bool -> Sha -> FileMode -> Annex (Maybe Key)
 catKey' modeguaranteed sha mode
 	| isSymLink mode = do
 		l <- catLink modeguaranteed sha
 		return $ if isLinkToAnnex l
 			then fileKey $ takeFileName l
 			else Nothing
 	| otherwise = return Nothing
 {- Gets a symlink target. -}
 catLink :: Bool -> Sha -> Annex String
 catLink modeguaranteed sha = fromInternalGitPath . decodeBS <$> get
  where
 	-- If the mode is not guaranteed to be correct, avoid
 	-- buffering the whole file content, which might be large.
 	-- 8192 is enough if it really is a symlink.
 	get
 		| modeguaranteed = catObject sha
 		| otherwise = L.take 8192 <$> catObject sha
 {- Looks up the key corresponding to the Ref using the running cat-file.
 -
 - Currently this always has to look in HEAD, because cat-file --batch
 - does not offer a way to specify that we want to look up a tree object
 - in the index. So if the index has a file staged not as a symlink,
 - and it is a symlink in head, the wrong mode is gotten.
 - Also, we have to assume the file is a symlink if it's not yet committed
 - to HEAD. For these reasons, modeguaranteed is not set.
 -}
 catKeyChecked :: Bool -> Ref -> Annex (Maybe Key)
 catKeyChecked needhead ref@(Ref r) =
 	catKey' False ref =<< findmode <$> catTree treeref
  where
 	pathparts = split "/" r
 	dir = intercalate "/" $ take (length pathparts - 1) pathparts
 	file = fromMaybe "" $ lastMaybe pathparts
 	treeref = Ref $ if needhead then "HEAD" ++ dir ++ "/" else dir ++ "/"
 	findmode = fromMaybe symLinkMode . headMaybe .
 		 map snd . filter (\p -> fst p == file)
 {- 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
 	, catKeyChecked True $ Git.Ref.fileRef f
 	)
 catKeyFileHEAD :: FilePath -> Annex (Maybe Key)
 catKeyFileHEAD f = catKeyChecked False $ Git.Ref.fileFromRef Git.Ref.headRef f
--- a/Annex/CheckAttr.hs
+++ b/Annex/CheckAttr.hs
@ -1,35 +0,0 @@
 {- 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
 ) where
 import Common.Annex
 import qualified Git.CheckAttr as Git
 import qualified Annex
 {- All gitattributes used by git-annex. -}
 annexAttrs :: [Git.Attr]
 annexAttrs =
 	[ "annex.backend"
 	, "annex.numcopies"
 	]
 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
--- a/Annex/CheckIgnore.hs
+++ b/Annex/CheckIgnore.hs
@ -1,32 +0,0 @@
 {- 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
 ) where
 import Common.Annex
 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
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@ -1,637 +0,0 @@
 {- git-annex file content managing
 -
 - Copyright 2010-2014 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE CPP #-}
 module Annex.Content (
 	inAnnex,
 	inAnnexSafe,
 	inAnnexCheck,
 	lockContent,
 	getViaTmp,
 	getViaTmpChecked,
 	getViaTmpUnchecked,
 	prepGetViaTmpChecked,
 	prepTmp,
 	withTmp,
 	checkDiskSpace,
 	moveAnnex,
 	sendAnnex,
 	prepSendAnnex,
 	removeAnnex,
 	fromAnnex,
 	moveBad,
 	KeyLocation(..),
 	getKeysPresent,
 	saveState,
 	downloadUrl,
 	preseedTmp,
 	freezeContent,
 	thawContent,
 	dirKeys,
 	withObjectLoc,
 ) where
 import System.IO.Unsafe (unsafeInterleaveIO)
 import Common.Annex
 import Logs.Location
 import qualified Git
 import qualified Annex
 import qualified Annex.Queue
 import qualified Annex.Branch
 import Utility.DiskFree
 import Utility.FileMode
 import qualified Annex.Url as Url
 import Types.Key
 import Utility.DataUnits
 import Utility.CopyFile
 import Config
 import Git.SharedRepository
 import Annex.Perms
 import Annex.Link
 import Annex.Content.Direct
 import Annex.ReplaceFile
 import Utility.LockFile
 {- Checks if a given key's content is currently present. -}
 inAnnex :: Key -> Annex Bool
 inAnnex key = inAnnexCheck key $ liftIO . doesFileExist
 {- Runs an arbitrary check on a key's content. -}
 inAnnexCheck :: Key -> (FilePath -> Annex Bool) -> Annex Bool
 inAnnexCheck key check = inAnnex' id False check key
 {- Generic inAnnex, handling both indirect and direct mode.
 -
 - In direct mode, at least one of the associated files must pass the
 - check. Additionally, the file must be unmodified.
 -}
 inAnnex' :: (a -> Bool) -> a -> (FilePath -> Annex a) -> Key -> Annex a
 inAnnex' isgood bad check key = withObjectLoc key checkindirect checkdirect
  where
 	checkindirect loc = do
 		whenM (fromRepo Git.repoIsUrl) $
 			error "inAnnex cannot check remote repo"
 		check loc
 	checkdirect [] = return bad
 	checkdirect (loc:locs) = do
 		r <- check loc
 		if isgood r
 			then ifM (goodContent key loc)
 				( return r
 				, checkdirect locs
 				)
 			else checkdirect locs
 {- A safer check; the key's content must not only be present, but
 - is not in the process of being removed. -}
 inAnnexSafe :: Key -> Annex (Maybe Bool)
 inAnnexSafe key = inAnnex' (fromMaybe False) (Just False) go key
  where
 	is_locked = Nothing
 	is_unlocked = Just True
 	is_missing = Just False
 	go contentfile = maybe (checkindirect contentfile) (checkdirect contentfile)
 		=<< contentLockFile key
 #ifndef mingw32_HOST_OS
 	checkindirect contentfile = liftIO $ checkOr is_missing contentfile
 	{- In direct mode, the content file must exist, but
 	 - the lock file generally won't exist unless a removal is in
 	 - process. -}
 	checkdirect contentfile lockfile = liftIO $
 		ifM (doesFileExist contentfile)
 			( checkOr is_unlocked lockfile
 			, return is_missing
 			)
 	checkOr d lockfile = do
 		v <- checkLocked lockfile
 		return $ case v of
 			Nothing -> d
 			Just True -> is_locked
 			Just False -> is_unlocked
 #else
 	checkindirect f = liftIO $ ifM (doesFileExist f)
 		( do
 			v <- lockShared f
 			case v of
 				Nothing -> return is_locked
 				Just lockhandle -> do
 					dropLock lockhandle
 					return is_unlocked
 		, return is_missing
 		)
 	{- In Windows, see if we can take a shared lock. If so, 
 	 - remove the lock file to clean up after ourselves. -}
 	checkdirect contentfile lockfile =
 		ifM (liftIO $ doesFileExist contentfile)
 			( modifyContent lockfile $ liftIO $ do
 				v <- lockShared lockfile
 				case v of
 					Nothing -> return is_locked
 					Just lockhandle -> do
 						dropLock lockhandle
 						void $ tryIO $ nukeFile lockfile
 						return is_unlocked
 			, return is_missing
 			)
 #endif
 {- Direct mode and especially Windows has to use a separate lock
 - file from the content, since locking the actual content file
 - would interfere with the user's use of it. -}
 contentLockFile :: Key -> Annex (Maybe FilePath)
 contentLockFile key = ifM isDirect
 	( Just <$> calcRepo (gitAnnexContentLock key)
 	, return Nothing
 	)
 newtype ContentLock = ContentLock Key
 {- Content is exclusively locked while running an action that might remove
 - it. (If the content is not present, no locking is done.)
 -}
 lockContent :: Key -> (ContentLock -> Annex a) -> Annex a
 lockContent key a = do
 	contentfile <- calcRepo $ gitAnnexLocation key
 	lockfile <- contentLockFile key
 	maybe noop setuplockfile lockfile
 	bracket
 		(lock contentfile lockfile)
 		(unlock lockfile)
 		(const $ a $ ContentLock key)
  where
 	alreadylocked = error "content is locked"
 	setuplockfile lockfile = modifyContent lockfile $
 		void $ liftIO $ tryIO $
 			writeFile lockfile ""
 	cleanuplockfile lockfile = modifyContent lockfile $
 		void $ liftIO $ tryIO $
 			nukeFile lockfile
 #ifndef mingw32_HOST_OS
 	lock contentfile Nothing = liftIO $
 		opencontentforlock contentfile >>= dolock
 	lock _ (Just lockfile) = do
 		mode <- annexFileMode
 		liftIO $ createLockFile mode lockfile >>= dolock . Just
 	{- Since content files are stored with the write bit disabled, have
 	 - to fiddle with permissions to open for an exclusive lock. -}
 	opencontentforlock f = catchDefaultIO Nothing $ 
 		withModifiedFileMode f
 			(`unionFileModes` ownerWriteMode)
 			(openExistingLockFile f)
 	dolock Nothing = return Nothing
 	dolock (Just fd) = do
 		v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
 		case v of
 			Left _ -> alreadylocked
 			Right _ -> return $ Just fd
 	unlock mlockfile mfd = do
 		maybe noop cleanuplockfile mlockfile
 		liftIO $ maybe noop closeFd mfd
 #else
 	lock _ (Just lockfile) = liftIO $
 		maybe alreadylocked (return . Just) =<< lockExclusive lockfile
 	lock _ Nothing = return Nothing
 	unlock mlockfile mlockhandle = do
 		liftIO $ maybe noop dropLock mlockhandle
 		maybe noop cleanuplockfile mlockfile
 #endif
 {- Runs an action, passing it a temporary filename to get,
 - and if the action succeeds, moves the temp file into 
 - the annex as a key's content. -}
 getViaTmp :: Key -> (FilePath -> Annex Bool) -> Annex Bool
 getViaTmp = getViaTmpChecked (return True)
 {- Like getViaTmp, but does not check that there is enough disk space
 - for the incoming key. For use when the key content is already on disk
 - and not being copied into place. -}
 getViaTmpUnchecked :: Key -> (FilePath -> Annex Bool) -> Annex Bool
 getViaTmpUnchecked = finishGetViaTmp (return True)
 getViaTmpChecked :: Annex Bool -> Key -> (FilePath -> Annex Bool) -> Annex Bool
 getViaTmpChecked check key action = 
 	prepGetViaTmpChecked key False $
 		finishGetViaTmp check key action
 {- Prepares to download a key via a tmp file, and checks that there is
 - enough free disk space.
 -
 - When the temp file already exists, count the space it is using as
 - free, since the download will overwrite it or resume.
 -
 - Wen there's enough free space, runs the download action.
 -}
 prepGetViaTmpChecked :: Key -> a -> Annex a -> Annex a
 prepGetViaTmpChecked key unabletoget getkey = do
 	tmp <- fromRepo $ gitAnnexTmpObjectLocation key
 	e <- liftIO $ doesFileExist tmp
 	alreadythere <- liftIO $ if e
 		then getFileSize tmp
 		else return 0
 	ifM (checkDiskSpace Nothing key alreadythere)
 		( do
 			-- The tmp file may not have been left writable
 			when e $ thawContent tmp
 			getkey
 		, return unabletoget
 		)
 finishGetViaTmp :: Annex Bool -> Key -> (FilePath -> Annex Bool) -> Annex Bool
 finishGetViaTmp check key action = do
 	tmpfile <- prepTmp key
 	ifM (action tmpfile <&&> check)
 		( do
 			moveAnnex key tmpfile
 			logStatus key InfoPresent
 			return True
 		-- the tmp file is left behind, in case caller wants
 		-- to resume its transfer
 		, return False
 		)
 prepTmp :: Key -> Annex FilePath
 prepTmp key = do
 	tmp <- fromRepo $ gitAnnexTmpObjectLocation key
 	createAnnexDirectory (parentDir tmp)
 	return tmp
 {- Creates a temp file for a key, runs an action on it, and cleans up
 - the temp file. If the action throws an exception, the temp file is
 - left behind, which allows for resuming.
 -}
 withTmp :: Key -> (FilePath -> Annex a) -> Annex a
 withTmp key action = do
 	tmp <- prepTmp key
 	res <- action tmp
 	liftIO $ nukeFile tmp
 	return res
 {- Checks that there is disk space available to store a given key,
 - in a destination (or the annex) printing a warning if not. -}
 checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Annex Bool
 checkDiskSpace destination key alreadythere = do
 	reserve <- annexDiskReserve <$> Annex.getGitConfig
 	free <- liftIO . getDiskFree =<< dir
 	force <- Annex.getState Annex.force
 	case (free, keySize key) of
 		(Just have, Just need) -> do
 			let ok = (need + reserve <= have + alreadythere) || force
 			unless ok $
 				needmorespace (need + reserve - have - alreadythere)
 			return ok
 		_ -> return True
  where
 	dir = maybe (fromRepo gitAnnexDir) return destination
 	needmorespace n =
 		warning $ "not enough free space, need " ++ 
 			roughSize storageUnits True n ++
 			" more" ++ forcemsg
 	forcemsg = " (use --force to override this check or adjust annex.diskreserve)"
 {- Moves a key's content into .git/annex/objects/
 -
 - In direct mode, moves it to the associated file, or files.
 -
 - What if the key there already has content? This could happen for
 - various reasons; perhaps the same content is being annexed again.
 - Perhaps there has been a hash collision generating the keys.
 -
 - The current strategy is to assume that in this case it's safe to delete
 - one of the two copies of the content; and the one already in the annex
 - is left there, assuming it's the original, canonical copy.
 -
 - I considered being more paranoid, and checking that both files had
 - the same content. Decided against it because A) users explicitly choose
 - a backend based on its hashing properties and so if they're dealing
 - with colliding files it's their own fault and B) adding such a check
 - would not catch all cases of colliding keys. For example, perhaps 
 - a remote has a key; if it's then added again with different content then
 - the overall system now has two different peices of content for that
 - key, and one of them will probably get deleted later. So, adding the
 - check here would only raise expectations that git-annex cannot truely
 - meet.
 -}
 moveAnnex :: Key -> FilePath -> Annex ()
 moveAnnex key src = withObjectLoc key storeobject storedirect
  where
 	storeobject dest = ifM (liftIO $ doesFileExist dest)
 		( alreadyhave
 		, modifyContent dest $ do
 			liftIO $ moveFile src dest
 			freezeContent dest
 		)
 	storeindirect = storeobject =<< calcRepo (gitAnnexLocation key)
 	{- In direct mode, the associated file's content may be locally
 	 - modified. In that case, it's preserved. However, the content
 	 - we're moving into the annex may be the only extant copy, so
 	 - it's important we not lose it. So, when the key's content
 	 - cannot be moved to any associated file, it's stored in indirect
 	 - mode.
 	 -}
 	storedirect = storedirect' storeindirect
 	storedirect' fallback [] = fallback
 	storedirect' fallback (f:fs) = do
 		thawContent src
 		v <- isAnnexLink f
 		if Just key == v
 			then do
 				updateInodeCache key src
 				replaceFile f $ liftIO . moveFile src
 				chmodContent f
 				forM_ fs $
 					addContentWhenNotPresent key f
 			else ifM (goodContent key f)
 				( storedirect' alreadyhave fs
 				, storedirect' fallback fs
 				)
 	alreadyhave = liftIO $ removeFile src
 {- Runs an action to transfer an object's content.
 -
 - In direct mode, it's possible for the file to change as it's being sent.
 - If this happens, runs the rollback action and returns False. The
 - rollback action should remove the data that was transferred.
 -}
 sendAnnex :: Key -> Annex () -> (FilePath -> Annex Bool) -> Annex Bool
 sendAnnex key rollback sendobject = go =<< prepSendAnnex key
  where
 	go Nothing = return False
 	go (Just (f, checksuccess)) = do
 		r <- sendobject f
 		ifM checksuccess
 			( return r
 			, do
 				rollback
 				return False
 			)
 {- Returns a file that contains an object's content,
 - and a check to run after the transfer is complete.
 -
 - In direct mode, it's possible for the file to change as it's being sent,
 - and the check detects this case and returns False.
 -
 - Note that the returned check action is, in some cases, run in the
 - Annex monad of the remote that is receiving the object, rather than
 - the sender. So it cannot rely on Annex state.
 -}
 prepSendAnnex :: Key -> Annex (Maybe (FilePath, Annex Bool))
 prepSendAnnex key = withObjectLoc key indirect direct
  where
 	indirect f = return $ Just (f, return True)
 	direct [] = return Nothing
 	direct (f:fs) = do
 		cache <- recordedInodeCache key
 		-- check that we have a good file
 		ifM (sameInodeCache f cache)
 			( return $ Just (f, sameInodeCache f cache)
 			, direct fs
 			)
 {- Performs an action, passing it the location to use for a key's content.
 -
 - In direct mode, the associated files will be passed. But, if there are
 - no associated files for a key, the indirect mode action will be
 - performed instead. -}
 withObjectLoc :: Key -> (FilePath -> Annex a) -> ([FilePath] -> Annex a) -> Annex a
 withObjectLoc key indirect direct = ifM isDirect
 	( do
 		fs <- associatedFiles key
 		if null fs
 			then goindirect
 			else direct fs
 	, goindirect
 	)
  where
 	goindirect = indirect =<< calcRepo (gitAnnexLocation key)
 cleanObjectLoc :: Key -> Annex () -> Annex ()
 cleanObjectLoc key cleaner = do
 	file <- calcRepo $ gitAnnexLocation key
 	void $ tryIO $ thawContentDir file
 	cleaner
 	liftIO $ removeparents file (3 :: Int)
  where
 	removeparents _ 0 = noop
 	removeparents file n = do
 		let dir = parentDir file
 		maybe noop (const $ removeparents dir (n-1))
 			<=< catchMaybeIO $ removeDirectory dir
 {- Removes a key's file from .git/annex/objects/
 -
 - In direct mode, deletes the associated files or files, and replaces
 - them with symlinks.
 -}
 removeAnnex :: ContentLock -> Annex ()
 removeAnnex (ContentLock key) = withObjectLoc key remove removedirect
  where
 	remove file = cleanObjectLoc key $ do
 		secureErase file
 		liftIO $ nukeFile file
 		removeInodeCache key
 	removedirect fs = do
 		cache <- recordedInodeCache key
 		removeInodeCache key
 		mapM_ (resetfile cache) fs
 	resetfile cache f = whenM (sameInodeCache f cache) $ do
 		l <- calcRepo $ gitAnnexLink f key
 		secureErase f
 		replaceFile f $ makeAnnexLink l
 {- Runs the secure erase command if set, otherwise does nothing.
 - File may or may not be deleted at the end; caller is responsible for
 - making sure it's deleted. -}
 secureErase :: FilePath -> Annex ()
 secureErase file = maybe noop go =<< annexSecureEraseCommand <$> Annex.getGitConfig
  where
 	go basecmd = void $ liftIO $
 		boolSystem "sh" [Param "-c", Param $ gencmd basecmd]
 	gencmd = massReplace [ ("%file", shellEscape file) ]
 {- Moves a key's file out of .git/annex/objects/ -}
 fromAnnex :: Key -> FilePath -> Annex ()
 fromAnnex key dest = cleanObjectLoc key $ do
 	file <- calcRepo $ gitAnnexLocation key
 	thawContent file
 	liftIO $ moveFile file dest
 {- Moves a key out of .git/annex/objects/ into .git/annex/bad, and
 - returns the file it was moved to. -}
 moveBad :: Key -> Annex FilePath
 moveBad key = do
 	src <- calcRepo $ gitAnnexLocation key
 	bad <- fromRepo gitAnnexBadDir
 	let dest = bad </> takeFileName src
 	createAnnexDirectory (parentDir dest)
 	cleanObjectLoc key $
 		liftIO $ moveFile src dest
 	logStatus key InfoMissing
 	return dest
 data KeyLocation = InAnnex | InRepository
 {- List of keys whose content exists in the specified location.
 - InAnnex only lists keys under .git/annex/objects,
 - while InRepository, in direct mode, also finds keys located in the
 - work tree.
 -
 - Note that InRepository has to check whether direct mode files
 - have goodContent.
 -}
 getKeysPresent :: KeyLocation -> Annex [Key]
 getKeysPresent keyloc = do
 	direct <- isDirect
 	dir <- fromRepo gitAnnexObjectDir
 	s <- getstate direct
 	liftIO $ traverse s direct (2 :: Int) dir
  where
 	traverse s direct depth dir = do
 		contents <- catchDefaultIO [] (dirContents dir)
 		if depth == 0
 			then do
 				contents' <- filterM (present s direct) contents
 				let keys = mapMaybe (fileKey . takeFileName) contents'
 				continue keys []
 			else do
 				let deeper = traverse s direct (depth - 1)
 				continue [] (map deeper contents)
 	continue keys [] = return keys
 	continue keys (a:as) = do
 		{- Force lazy traversal with unsafeInterleaveIO. -}
 		morekeys <- unsafeInterleaveIO a
 		continue (morekeys++keys) as
 	present _ False d = presentInAnnex d
 	present s True d = presentDirect s d <||> presentInAnnex d
 	presentInAnnex = doesFileExist . contentfile
 	contentfile d = d </> takeFileName d
 	presentDirect s d = case keyloc of
 		InAnnex -> return False
 		InRepository -> case fileKey (takeFileName d) of
 			Nothing -> return False
 			Just k -> Annex.eval s $ 
 				anyM (goodContent k) =<< associatedFiles k
 	{- In order to run Annex monad actions within unsafeInterleaveIO,
 	 - the current state is taken and reused. No changes made to this
 	 - state will be preserved. 
 	 -
 	 - As an optimsation, call inodesChanged to prime the state with
 	 - a cached value that will be used in the call to goodContent.
 	 -}
 	getstate direct = do
 		when direct $
 			void $ inodesChanged
 		Annex.getState id
 {- Things to do to record changes to content when shutting down.
 -
 - It's acceptable to avoid committing changes to the branch,
 - especially if performing a short-lived action.
 -}
 saveState :: Bool -> Annex ()
 saveState nocommit = doSideAction $ do
 	Annex.Queue.flush
 	unless nocommit $
 		whenM (annexAlwaysCommit <$> Annex.getGitConfig) $
 			Annex.Branch.commit "update"
 {- Downloads content from any of a list of urls. -}
 downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool
 downloadUrl urls file = go =<< annexWebDownloadCommand <$> Annex.getGitConfig
  where
 	go Nothing = Url.withUrlOptions $ \uo ->
 		anyM (\u -> Url.download u file uo) urls
 	go (Just basecmd) = liftIO $ anyM (downloadcmd basecmd) urls
 	downloadcmd basecmd url =
 		boolSystem "sh" [Param "-c", Param $ gencmd url basecmd]
 			<&&> doesFileExist file
 	gencmd url = massReplace
 		[ ("%file", shellEscape file)
 		, ("%url", shellEscape url)
 		]
 {- Copies a key's content, when present, to a temp file.
 - This is used to speed up some rsyncs. -}
 preseedTmp :: Key -> FilePath -> Annex Bool
 preseedTmp key file = go =<< inAnnex key
  where
 	go False = return False
 	go True = do
 		ok <- copy
 		when ok $ thawContent file
 		return ok
 	copy = ifM (liftIO $ doesFileExist file)
 		( return True
 		, do
 			s <- calcRepo $ gitAnnexLocation key
 			liftIO $ copyFileExternal CopyTimeStamps s file
 		)
 {- Blocks writing to an annexed file, and modifies file permissions to
 - allow reading it, per core.sharedRepository setting. -}
 freezeContent :: FilePath -> Annex ()
 freezeContent file = unlessM crippledFileSystem $
 	liftIO . go =<< fromRepo getSharedRepository
  where
 	go GroupShared = modifyFileMode file $
 		removeModes writeModes .
 		addModes [ownerReadMode, groupReadMode]
 	go AllShared = modifyFileMode file $
 		removeModes writeModes .
 		addModes readModes
 	go _ = modifyFileMode file $
 		removeModes writeModes .
 		addModes [ownerReadMode]
 {- Adjusts read mode of annexed file per core.sharedRepository setting. -}
 chmodContent :: FilePath -> Annex ()
 chmodContent file = unlessM crippledFileSystem $
 	liftIO . go =<< fromRepo getSharedRepository
  where
 	go GroupShared = modifyFileMode file $
 		addModes [ownerReadMode, groupReadMode]
 	go AllShared = modifyFileMode file $
 		addModes readModes
 	go _ = modifyFileMode file $
 		addModes [ownerReadMode]
 {- Allows writing to an annexed file that freezeContent was called on
 - before. -}
 thawContent :: FilePath -> Annex ()
 thawContent file = unlessM crippledFileSystem $
 	liftIO . go =<< fromRepo getSharedRepository
  where
 	go GroupShared = groupWriteRead file
 	go AllShared = groupWriteRead file
 	go _ = allowWrite file
 {- Finds files directly inside a directory like gitAnnexBadDir 
 - (not in subdirectories) and returns the corresponding keys. -}
 dirKeys :: (Git.Repo -> FilePath) -> Annex [Key]
 dirKeys dirspec = do
 	dir <- fromRepo dirspec
 	ifM (liftIO $ doesDirectoryExist dir)
 		( do
 			contents <- liftIO $ getDirectoryContents dir
 			files <- liftIO $ filterM doesFileExist $
 				map (dir </>) contents
 			return $ mapMaybe (fileKey . takeFileName) files
 		, return []
 		)
--- a/Annex/Content/Direct.hs
+++ b/Annex/Content/Direct.hs
@ -1,263 +0,0 @@
 {- git-annex file content managing for direct mode
 -
 - Copyright 2012-2014 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE CPP #-}
 module Annex.Content.Direct (
 	associatedFiles,
 	associatedFilesRelative,
 	removeAssociatedFile,
 	removeAssociatedFileUnchecked,
 	removeAssociatedFiles,
 	addAssociatedFile,
 	goodContent,
 	recordedInodeCache,
 	updateInodeCache,
 	addInodeCache,
 	writeInodeCache,
 	compareInodeCaches,
 	compareInodeCachesWith,
 	sameInodeCache,
 	elemInodeCaches,
 	sameFileStatus,
 	removeInodeCache,
 	toInodeCache,
 	inodesChanged,
 	createInodeSentinalFile,
 	addContentWhenNotPresent,
 	withTSDelta,
 	getTSDelta,
 ) where
 import Common.Annex
 import qualified Annex
 import Annex.Perms
 import qualified Git
 import Utility.Tmp
 import Logs.Location
 import Utility.InodeCache
 import Utility.CopyFile
 import Annex.ReplaceFile
 import Annex.Link
 {- 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 -> do
 		fileEncoding 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 $
 			liftIO $ viaTmp writeFileAnyEncoding 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 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
 {- 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
 {- If 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
 		)
 elemInodeCaches :: InodeCache -> [InodeCache] -> Annex Bool
 elemInodeCaches _ [] = return False
 elemInodeCaches c (l:ls) = ifM (compareInodeCaches c l)
 	( return True
 	, elemInodeCaches c ls
 	)
 compareInodeCachesWith :: Annex InodeComparisonType
 compareInodeCachesWith = ifM inodesChanged ( return Weakly, return Strongly )
 {- 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	
 {- 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 :: Annex ()
 createInodeSentinalFile = unlessM (alreadyexists <||> hasobjects) $ do
 	s <- annexSentinalFile
 	createAnnexDirectory (parentDir (sentinalFile s))
 	liftIO $ writeSentinalFile s
  where
 	alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile
 	hasobjects = liftIO . doesDirectoryExist =<< fromRepo gitAnnexObjectDir
 annexSentinalFile :: Annex SentinalFile
 annexSentinalFile = do
 	sentinalfile <- fromRepo gitAnnexInodeSentinal
 	sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache
 	return $ SentinalFile
 		{ sentinalFile = sentinalfile
 		, sentinalCacheFile = sentinalcachefile
 		}
--- a/Annex/Difference.hs
+++ b/Annex/Difference.hs
@ -1,58 +0,0 @@
 {- 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 Common.Annex
 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 (not . null . filter (/= 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
--- a/Annex/DirHashes.hs
+++ b/Annex/DirHashes.hs
@ -1,86 +0,0 @@
 {- git-annex file locations
 -
 - Copyright 2010-2015 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,
 ) where
 import Data.Bits
 import Data.Word
 import Data.Hash.MD5
 import Data.Default
 import Common
 import Types.Key
 import Types.GitConfig
 import Types.Difference
 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 config key = hashDirLower (branchHashLevels config) key
 {- 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
 hashDirMixed :: HashLevels -> Hasher
 hashDirMixed n k = hashDirs n 2 $ take 4 $ display_32bits_as_dir =<< [a,b,c,d]
  where
 	ABCD (a,b,c,d) = md5 $ md5FilePath $ key2file $ nonChunkKey k
 hashDirLower :: HashLevels -> Hasher
 hashDirLower n k = hashDirs n 3 $ take 6 $ md5s $ md5FilePath $ key2file $ nonChunkKey k
 {- modified version of display_32bits_as_hex from Data.Hash.MD5
 -   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
--- a/Annex/Direct.hs
+++ b/Annex/Direct.hs
@ -1,456 +0,0 @@
 {- git-annex direct mode
 -
 - Copyright 2012-2014 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Annex.Direct where
 import Common.Annex
 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.Index
 import Annex.LockFile
 {- 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 mode
 		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) $ do
 			k <- catKey sha mode
 			case k of
 				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 change 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.Branch.CommitMode -> Annex Bool
 mergeDirect startbranch oldref branch resolvemerge commitmode = exclusively $ do
 	reali <- liftIO . absPath =<< fromRepo indexFile
 	tmpi <- liftIO . absPath =<< fromRepo indexFileLock
 	liftIO $ copyFile reali tmpi
 	d <- fromRepo gitAnnexMergeDir
 	liftIO $ do
 		whenM (doesDirectoryExist d) $
 			removeDirectoryRecursive d
 		createDirectoryIfMissing True d
 	withIndexFile tmpi $ do
 		merged <- stageMerge d branch commitmode
 		r <- if merged
 			then return True
 			else resolvemerge
 		mergeDirectCleanup d (fromMaybe Git.Sha.emptyTree oldref)
 		mergeDirectCommit merged startbranch branch commitmode
 		liftIO $ rename tmpi reali
 		return r
  where
 	exclusively = withExclusiveLock gitAnnexMergeLock
 {- Stage a merge into the index, avoiding changing HEAD or the current
 - branch. -}
 stageMerge :: FilePath -> Git.Branch -> Git.Branch.CommitMode -> Annex Bool
 stageMerge d branch commitmode = do
 	-- XXX A bug in git makes stageMerge unsafe to use if the git repo
 	-- is configured with core.symlinks=false
 	-- Using mergeNonInteractive 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 Git.Merge.stageMerge
 		, return $ \ref -> Git.Merge.mergeNonInteractive ref 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 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 = do
 	updateWorkTree d oldref
 	liftIO $ removeDirectoryRecursive d
 {- 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 -> Annex ()
 updateWorkTree d oldref = 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 DiffTree.srcmode moveout moveout_raw
 	forM_ fsitems $
 		go makeabs DiffTree.dstsha DiffTree.dstmode movein movein_raw
 	void $ liftIO cleanup
  where
 	go makeabs getsha getmode 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) (getmode 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
 		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
 		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) $
 		ifM (goodContent k f)
 			( moveAnnex k f
 			, 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
 {- 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
 	setbare = setConfig (ConfigKey Git.Config.coreBare) val
 {- 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 split "/" $ 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 split "/" $ 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 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
 		v <- inRepo $ Git.Ref.sha currhead
 		case v of
 			Just headsha
 				| orighead /= currhead -> do
 					inRepo $ Git.Branch.update orighead headsha
 					inRepo $ Git.Branch.checkout orighead
 					inRepo $ Git.Branch.delete currhead
 			_ -> inRepo $ Git.Branch.checkout orighead
--- a/Annex/Direct/Fixup.hs
+++ b/Annex/Direct/Fixup.hs
@ -1,31 +0,0 @@
 {- git-annex direct mode guard fixup
 -
 - Copyright 2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Annex.Direct.Fixup where
 import Git.Types
 import Git.Config
 import qualified Git.Construct as Construct
 import Utility.Path
 import Utility.SafeCommand
 {- 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 -> IO Repo
 fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) }) = do
 	let r' = r
 		{ location = l { worktree = Just (parentDir d) }
 		, gitGlobalOpts = gitGlobalOpts r ++
 			[ Param "-c"
 			, Param $ coreBare ++ "=" ++ boolConfig False
 			]
 		}
 	-- Recalc now that the worktree is correct.
 	rs' <- Construct.fromRemotes r'
 	return $ r' { remotes = rs' }
 fixupDirect r = return r
--- a/Annex/Drop.hs
+++ b/Annex/Drop.hs
@ -1,123 +0,0 @@
 {- 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 Common.Annex
 import Logs.Trust
 import Config.NumCopies
 import Types.Remote (uuid)
 import Types.Key (key2file)
 import qualified Remote
 import qualified Command.Drop
 import Command
 import Annex.Wanted
 import Config
 import Annex.Content.Direct
 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 tried first.
 -
 - A remote can be specified that is known to have the key. This can be
 - used an 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 -> Maybe Remote -> CommandActionRunner -> Annex ()
 handleDropsFrom locs rs reason fromhere key afile knownpresentremote runner = do
 	fs <- ifM isDirect
 		( do
 			l <- associatedFilesRelative key
 			return $ if null l
 				then maybeToList afile
 				else l
 		, return $ maybeToList afile
 		)
 	n <- getcopies fs
 	if fromhere && checkcopies n Nothing
 		then go fs rs =<< dropl fs n
 		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 _ [] _ = noop
 	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 = noop
 	checkdrop fs n u a
 		| null fs = check $ -- no associated files; unused content
 			wantDrop True u (Just key) Nothing
 		| otherwise = check $
 			allM (wantDrop True u (Just key) . 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"
 					, fromMaybe (key2file key) afile
 					, "(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 numcopies key knownpresentremote
 	dropr fs r n  = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies ->
 		Command.Drop.startRemote afile numcopies key r
 	slocs = S.fromList locs
 	safely a = either (const False) id <$> tryNonAsync a
--- a/Annex/Environment.hs
+++ b/Annex/Environment.hs
@ -1,58 +0,0 @@
 {- 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 Common.Annex
 import Utility.UserInfo
 import qualified Git.Config
 import Config
 import Utility.Env
 {- 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 <- 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 myUserName
 		setConfig (ConfigKey "user.name") name
 		setConfig (ConfigKey "user.email") name
 		a
--- a/Annex/FileMatcher.hs
+++ b/Annex/FileMatcher.hs
@ -1,116 +0,0 @@
 {- git-annex file matching
 -
 - Copyright 2012-2014 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Annex.FileMatcher where
 import qualified Data.Map as M
 import Common.Annex
 import Limit
 import Utility.Matcher
 import Types.Group
 import Logs.Group
 import Logs.Remote
 import Annex.UUID
 import qualified Annex
 import Types.FileMatcher
 import Git.FilePath
 import Types.Remote (RemoteConfig)
 import Data.Either
 import qualified Data.Set as S
 checkFileMatcher :: (FileMatcher Annex) -> FilePath -> Annex Bool
 checkFileMatcher matcher file = checkMatcher matcher Nothing (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
 		(_, 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 :: [Either String (Token (MatchFiles Annex))] -> Either String (FileMatcher Annex)
 parsedToMatcher parsed = case partitionEithers parsed of
 	([], vs) -> Right $ generate vs
 	(es, _) -> Left $ unwords $ map ("Parse failure: " ++) es
 exprParser :: FileMatcher Annex -> FileMatcher Annex -> GroupMap -> M.Map UUID RemoteConfig -> Maybe UUID -> String -> [Either String (Token (MatchFiles Annex))]
 exprParser matchstandard matchgroupwanted groupmap configmap mu expr =
 	map parse $ tokenizeMatcher expr
  where
 	parse = parseToken
 		matchstandard
 		matchgroupwanted
 		(limitPresent mu)
 		(limitInDir preferreddir)
 		groupmap
 	preferreddir = fromMaybe "public" $
 		M.lookup "preferreddir" =<< (`M.lookup` configmap) =<< mu
 parseToken :: FileMatcher Annex -> FileMatcher Annex -> MkLimit Annex -> MkLimit Annex -> GroupMap -> String -> Either String (Token (MatchFiles Annex))
 parseToken matchstandard matchgroupwanted checkpresent checkpreferreddir groupmap t
 	| t `elem` tokens = Right $ token t
 	| t == "standard" = call matchstandard
 	| t == "groupwanted" = call matchgroupwanted
 	| t == "present" = use checkpresent
 	| t == "inpreferreddir" = use checkpreferreddir
 	| t == "unused" = Right $ Operation limitUnused
 	| otherwise = maybe (Left $ "near " ++ show t) use $ M.lookup k $
 		M.fromList
 			[ ("include", limitInclude)
 			, ("exclude", limitExclude)
 			, ("copies", limitCopies)
 			, ("lackingcopies", limitLackingCopies False)
 			, ("approxlackingcopies", limitLackingCopies True)
 			, ("inbackend", limitInBackend)
 			, ("largerthan", limitSize (>))
 			, ("smallerthan", limitSize (<))
 			, ("metadata", limitMetaData)
 			, ("inallgroup", limitInAllGroup groupmap)
 			]
  where
 	(k, v) = separate (== '=') t
 	use a = Operation <$> a v
 	call sub = Right $ Operation $ \notpresent mi ->
 		matchMrun sub $ \a -> a notpresent mi
 {- 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` "()")
 {- Generates a matcher for files large enough (or meeting other criteria)
 - to be added to the annex, rather than directly to git. -}
 largeFilesMatcher :: Annex (FileMatcher Annex)
 largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig
  where
 	go Nothing = return matchAll
 	go (Just expr) = do
 		gm <- groupMap
 		rc <- readRemoteLog
 		u <- getUUID
 		either badexpr return $
 			parsedToMatcher $ exprParser matchAll matchAll gm rc (Just u) expr
 	badexpr e = error $ "bad annex.largefiles configuration: " ++ e
--- a/Annex/Hook.hs
+++ b/Annex/Hook.hs
@ -1,67 +0,0 @@
 {- 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-2014 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Annex.Hook where
 import Common.Annex
 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 .")
 preCommitAnnexHook :: Git.Hook
 preCommitAnnexHook = Git.Hook "pre-commit-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"
--- a/Annex/Index.hs
+++ b/Annex/Index.hs
@ -1,52 +0,0 @@
 {- Using other git index files
 -
 - Copyright 2014 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE CPP #-}
 module Annex.Index (
 	withIndexFile,
 	addGitEnv,
 ) where
 import qualified Control.Exception as E
 import Common.Annex
 import Git.Types
 import qualified Annex
 import Utility.Env
 {- Runs an action using a different git index file. -}
 withIndexFile :: FilePath -> Annex a -> Annex a
 withIndexFile f a = do
 	g <- gitRepo
 	g' <- liftIO $ addGitEnv g "GIT_INDEX_FILE" f
 	r <- tryNonAsync $ do
 		Annex.changeState $ \s -> s { Annex.repo = g' }
 		a
 	Annex.changeState $ \s -> s { Annex.repo = (Annex.repo s) { gitEnv = gitEnv g} }
 	either E.throw return r
 addGitEnv :: Repo -> String -> String -> IO Repo
 addGitEnv g var val = do
 	e <- maybe copyenv return (gitEnv g)
 	let e' = addEntry var val e
 	return $ g { gitEnv = Just e' }
  where
 	copyenv = do
 #ifdef __ANDROID__
 		{- This should not be necessary on Android, but there is some
 		 - weird getEnvironment breakage. See
 		 - https://github.com/neurocyte/ghc-android/issues/7
 		 - Use getEnv to get some key environment variables that
 		 - git expects to have. -}
 		let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME"
 		let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k
 		liftIO $ catMaybes <$> forM keyenv getEnvPair
 #else
 		liftIO getEnvironment
 #endif
--- a/Annex/Init.hs
+++ b/Annex/Init.hs
@ -1,195 +0,0 @@
 {- git-annex repository initialization
 -
 - Copyright 2011 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE CPP #-}
 module Annex.Init (
 	ensureInitialized,
 	isInitialized,
 	initialize,
 	initialize',
 	uninitialize,
 	probeCrippledFileSystem,
 ) where
 import Common.Annex
 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 Types.TrustLevel
 import Annex.Version
 import Annex.Difference
 import Annex.UUID
 import Config
 import Annex.Direct
 import Annex.Content.Direct
 import Annex.Environment
 import Backend
 import Annex.Hook
 import Upgrade
 #ifndef mingw32_HOST_OS
 import Utility.UserInfo
 import Utility.FileMode
 import Annex.Perms
 #endif
 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
 #ifndef mingw32_HOST_OS
 	let at = if null hostname then "" else "@"
 	username <- liftIO myUserName
 	return $ concat [username, at, hostname, ":", reldir]
 #else
 	return $ concat [hostname, ":", reldir]
 #endif
 initialize :: Maybe String -> Annex ()
 initialize mdescription = do
 	prepUUID
 	initialize'
 	u <- getUUID
 	{- This will make the first commit to git, so ensure git is set up
 	 - properly to allow commits when running it. -}
 	ensureCommit $ do
 		Annex.Branch.create
 		describeUUID u =<< genDescription mdescription
 -- Everything except for uuid setup.
 initialize' :: Annex ()
 initialize' = do
 	checkFifoSupport
 	checkCrippledFileSystem
 	unlessM isBare $
 		hookWrite preCommitHook
 	setDifferences
 	setVersion supportedVersion
 	ifM (crippledFileSystem <&&> not <$> isBare)
 		( do
 			enableDirectMode
 			setDirect True
 		-- Handle case where this repo was cloned from a
 		-- direct mode repo
 		, unlessM isBare
 			switchHEADBack
 		)
 	createInodeSentinalFile
 	checkSharedClone
 uninitialize :: Annex ()
 uninitialize = do
 	hookUnWrite preCommitHook
 	removeRepoUUID
 	removeVersion
 {- Will automatically initialize if there is already a git-annex
 - branch from somewhere. Otherwise, require a manual init
 - to avoid git-annex accidentially 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 Nothing
 			, error "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
 isBare :: Annex Bool
 isBare = fromRepo Git.repoIsLocalBare
 {- A crippled filesystem is one that does not allow making symlinks,
 - or removing write access from files. -}
 probeCrippledFileSystem :: Annex Bool
 probeCrippledFileSystem = do
 #ifdef mingw32_HOST_OS
 	return True
 #else
 	tmp <- fromRepo gitAnnexTmpMiscDir
 	let f = tmp </> "gaprobe"
 	createAnnexDirectory tmp
 	liftIO $ writeFile f ""
 	uncrippled <- liftIO $ probe f
 	liftIO $ removeFile f
 	return $ not uncrippled
  where
 	probe f = catchBoolIO $ do
 		let f2 = f ++ "2"
 		nukeFile f2
 		createSymbolicLink f f2
 		nukeFile f2
 		preventWrite f
 		allowWrite f
 		return True
 #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 in Cygwin, git
 	 - does support symlinks, while git-annex, not linking
 	 - with Cygwin, does not. -}
 	whenM (coreSymlinks <$> Annex.getGitConfig) $ do
 		warning "Disabling core.symlinks."
 		setConfig (ConfigKey "core.symlinks")
 			(Git.Config.boolConfig False)
 probeFifoSupport :: Annex Bool
 probeFifoSupport = do
 #ifdef mingw32_HOST_OS
 	return False
 #else
 	tmp <- fromRepo gitAnnexTmpMiscDir
 	let f = tmp </> "gaprobe"
 	createAnnexDirectory tmp
 	liftIO $ do
 		nukeFile f
 		ms <- tryIO $ do
 			createNamedPipe f ownerReadMode
 			getFileStatus f
 		nukeFile f
 		return $ either (const False) isNamedPipe ms
 #endif
 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 ()
 checkSharedClone = whenM (inRepo Git.Objects.isSharedClone) $ do
 	showSideAction "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)
--- a/Annex/Journal.hs
+++ b/Annex/Journal.hs
@ -1,120 +0,0 @@
 {- 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 Common.Annex
 import qualified Git
 import Annex.Perms
 import Annex.LockFile
 {- 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
 			fileEncoding h
 #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 $
 	readFileStrictAnyEncoding $ journalFile file g
 {- List of files that have updated content in the journal. -}
 getJournalledFiles :: JournalLocked -> Annex [FilePath]
 getJournalledFiles jl = map fileJournal <$> getJournalFiles jl
 getJournalledFilesStale :: Annex [FilePath]
 getJournalledFilesStale = map fileJournal <$> getJournalFilesStale
 {- List of existing journal files. -}
 getJournalFiles :: JournalLocked -> Annex [FilePath]
 getJournalFiles _jl = getJournalFilesStale
 {- 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. -}
 getJournalFilesStale :: Annex [FilePath]
 getJournalFilesStale = do
 	g <- gitRepo
 	fs <- liftIO $ catchDefaultIO [] $
 		getDirectoryContents $ gitAnnexJournalDir g
 	return $ filter (`notElem` [".", ".."]) 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
--- a/Annex/Link.hs
+++ b/Annex/Link.hs
@ -1,112 +0,0 @@
 {- 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.
 -
 - Copyright 2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Annex.Link where
 import Common.Annex
 import qualified Annex
 import qualified Git.HashObject
 import qualified Git.UpdateIndex
 import qualified Annex.Queue
 import Git.Types
 import Git.FilePath
 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 = do
 		v <- liftIO $ catchMaybeIO $ getlinktarget file
 		case v of
 			Just l
 				| isLinkToAnnex (fromInternalGitPath l) -> return v
 				| otherwise -> return Nothing
 			Nothing -> fallback
 	probefilecontent f = withFile f ReadMode $ \h -> do
 		fileEncoding h
 		-- 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 = inRepo $ Git.HashObject.hashObject BlobObject $ 
 	toInternalGitPath linktarget
 hashSymlink' :: Git.HashObject.HashObjectHandle -> LinkTarget -> Annex Sha
 hashSymlink' h linktarget = liftIO $ Git.HashObject.hashBlob h $
 	toInternalGitPath linktarget
 {- Stages a symlink to the annex, using a Sha of its target. -}
 stageSymlink :: FilePath -> Sha -> Annex ()
 stageSymlink file sha =
 	Annex.Queue.addUpdateIndex =<<
 		inRepo (Git.UpdateIndex.stageSymlink file sha)
--- a/Annex/LockFile.hs
+++ b/Annex/LockFile.hs
@ -1,72 +0,0 @@
 {- git-annex lock files.
 -
 - Copyright 2012, 2014 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE CPP #-}
 module Annex.LockFile (
 	lockFileShared,
 	unlockFile,
 	getLockPool,
 	withExclusiveLock,
 ) where
 import Common.Annex
 import Annex
 import Types.LockPool
 import qualified Git
 import Annex.Perms
 import Utility.LockFile
 import qualified Data.Map as M
 {- Create a specified lock file, and takes a shared lock, which is retained
 - in the pool. -}
 lockFileShared :: FilePath -> Annex ()
 lockFileShared file = go =<< fromLockPool file
  where
 	go (Just _) = noop -- already locked
 	go Nothing = do
 #ifndef mingw32_HOST_OS
 		mode <- annexFileMode
 		lockhandle <- liftIO $ noUmask mode $ lockShared (Just mode) file
 #else
 		lockhandle <- liftIO $ waitToLock $ lockShared file
 #endif
 		changeLockPool $ M.insert file lockhandle
 unlockFile :: FilePath -> Annex ()
 unlockFile file = maybe noop go =<< fromLockPool file
  where
 	go lockhandle = do
 		liftIO $ dropLock lockhandle
 		changeLockPool $ M.delete file
 getLockPool :: Annex LockPool
 getLockPool = getState lockpool
 fromLockPool :: FilePath -> Annex (Maybe LockHandle)
 fromLockPool file = M.lookup file <$> getLockPool
 changeLockPool :: (LockPool -> LockPool) -> Annex ()
 changeLockPool a = do
 	m <- getLockPool
 	changeState $ \s -> s { lockpool = 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
 	bracketIO (lock mode lockfile) dropLock (const a)
  where
 #ifndef mingw32_HOST_OS
 	lock mode = noUmask mode . lockExclusive (Just mode)
 #else
 	lock _mode = waitToLock . lockExclusive
 #endif
--- a/Annex/MakeRepo.hs
+++ b/Annex/MakeRepo.hs
@ -1,88 +0,0 @@
 {- 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 Types.StandardGroups
 import Logs.PreferredContent
 import qualified Annex.Branch
 {- 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
 {- 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 desc
 	u <- getUUID
 	maybe noop (defaultStandardGroup u) mgroup
 	{- Ensure branch gets committed right away so it is
 	 - available for merging immediately. -}
 	Annex.Branch.commit "update"
 {- Checks if a git repo exists at a location. -}
 probeRepoExists :: FilePath -> IO Bool
 probeRepoExists dir = isJust <$>
 	catchDefaultIO Nothing (Git.Construct.checkForRepo dir)
--- a/Annex/MetaData.hs
+++ b/Annex/MetaData.hs
@ -1,55 +0,0 @@
 {- git-annex metadata
 -
 - Copyright 2014 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Annex.MetaData (
 	genMetaData,
 	dateMetaData,
 	module X
 ) where
 import Common.Annex
 import qualified Annex
 import Types.MetaData as X
 import Annex.MetaData.StandardFields as X
 import Logs.MetaData
 import Annex.CatFile
 import qualified Data.Set as S
 import qualified Data.Map as M
 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 th annex.
 -
 - Also, can generate new metadata, if configured to do so.
 -}
 genMetaData :: Key -> FilePath -> FileStatus -> Annex ()
 genMetaData key file status = do
 	maybe noop (flip copyMetaData key) =<< catKeyFileHEAD file
 	whenM (annexGenMetaData <$> Annex.getGitConfig) $ do
 		curr <- getCurrentMetaData key
 		addMetaData key (dateMetaData mtime curr)
  where
 	mtime = posixSecondsToUTCTime $ realToFrac $ modificationTime status
 {- Generates metadata for a file's date stamp.
 - Does not overwrite any existing metadata values. -}
 dateMetaData :: UTCTime -> MetaData -> MetaData
 dateMetaData mtime old = MetaData $ M.fromList $ filter isnew
 	[ (yearMetaField, S.singleton $ toMetaValue $ show y)
 	, (monthMetaField, S.singleton $ toMetaValue $ show m)
 	]
  where
 	isnew (f, _) = S.null (currentMetaDataValues f old)
 	(y, m, _d) = toGregorian $ utctDay $ mtime
--- a/Annex/MetaData/StandardFields.hs
+++ b/Annex/MetaData/StandardFields.hs
@ -1,47 +0,0 @@
 {- 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,
 	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"
 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"
--- a/Annex/Notification.hs
+++ b/Annex/Notification.hs
@ -1,101 +0,0 @@
 {- git-annex desktop notifications
 -
 - Copyright 2014 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE CPP #-}
 module Annex.Notification (NotifyWitness, notifyTransfer, notifyDrop) where
 import Common.Annex
 import Logs.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
 {- 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 :: Direction -> Maybe FilePath -> (NotifyWitness -> Annex Bool) -> Annex Bool
 notifyTransfer _ Nothing a = a NotifyWitness
 #ifdef WITH_DBUS_NOTIFICATIONS
 notifyTransfer direction (Just f) a = 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 f)
 				else pure Nothing
 			ok <- a NotifyWitness
 			when (notifyFinish wanted) $ liftIO $ void $ maybe 
 				(Notify.notify client $ finishedTransferNote ok direction f)
 				(\n -> Notify.replace client n $ finishedTransferNote ok direction f)
 				startnotification
 			return ok
 		else a NotifyWitness
 #else
 notifyTransfer _ (Just _) a = do a NotifyWitness
 #endif
 notifyDrop :: Maybe FilePath -> Bool -> Annex ()
 notifyDrop Nothing _ = noop
 #ifdef WITH_DBUS_NOTIFICATIONS
 notifyDrop (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 (Just _) _ = noop
 #endif
 #ifdef WITH_DBUS_NOTIFICATIONS
 startedTransferNote :: Direction -> FilePath -> Notify.Note
 startedTransferNote Upload   = mkNote Notify.Transfer Notify.Low iconUpload
 	"Uploading"
 startedTransferNote Download = mkNote Notify.Transfer Notify.Low iconDownload
 	"Downloading"
 finishedTransferNote :: Bool -> Direction -> FilePath -> 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 -> FilePath -> 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
--- a/Annex/Path.hs
+++ b/Annex/Path.hs
@ -1,34 +0,0 @@
 {- git-annex program path
 -
 - Copyright 2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE CPP #-}
 module Annex.Path where
 import Common
 import Config.Files
 import System.Environment
 {- A fully qualified path to the currently running git-annex program.
 - 
 - getExecutablePath is available since ghc 7.4.2. On OSs it supports
 - well, it returns the complete path to the program. But, on other OSs,
 - it might return just the basename.
 -}
 programPath :: IO (Maybe FilePath)
 programPath = do
 #if MIN_VERSION_base(4,6,0)
 	exe <- getExecutablePath
 	p <- if isAbsolute exe
 		then return exe
 		else readProgramFile
 #else
 	p <- readProgramFile
 #endif
 	-- In case readProgramFile returned just the command name,
 	-- fall back to finding it in PATH.
 	searchPath p
--- a/Annex/Perms.hs
+++ b/Annex/Perms.hs
@ -1,124 +0,0 @@
 {- git-annex file permissions
 -
 - Copyright 2012 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Annex.Perms (
 	setAnnexFilePerm,
 	setAnnexDirPerm,
 	annexFileMode,
 	createAnnexDirectory,
 	noUmask,
 	createContentDir,
 	freezeContentDir,
 	thawContentDir,
 	modifyContent,
 ) where
 import Common.Annex
 import Utility.FileMode
 import Git.SharedRepository
 import qualified Annex
 import Config
 import System.Posix.Types
 withShared :: (SharedRepository -> Annex a) -> Annex a
 withShared a = maybe startup a =<< Annex.getState Annex.shared
  where
 	startup = do
 		shared <- fromRepo getSharedRepository
 		Annex.changeState $ \s -> s { Annex.shared = Just shared }
 		a shared
 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 = modifyFileMode file $ addModes $
 		groupSharedModes ++
 		if isdir then [ ownerExecuteMode, groupExecuteMode ] else []
 	go AllShared = 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 = traverse dir [] =<< top
  where
 	top = parentDir <$> fromRepo gitAnnexDir
 	traverse d below stop
 		| d `equalFilePath` stop = done
 		| otherwise = ifM (liftIO $ doesDirectoryExist d)
 			( done
 			, traverse (parentDir d) (d:below) stop
 			)
 	  where
 		done = forM_ below $ \p -> do
 			liftIO $ createDirectoryIfMissing True p
 			setAnnexDirPerm p
 {- Blocks writing to the directory an annexed file is in, to prevent the
 - file accidentially 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 $
 	liftIO . go =<< fromRepo getSharedRepository
  where
 	dir = parentDir file
 	go GroupShared = groupWriteRead dir
 	go AllShared = groupWriteRead dir
 	go _ = preventWrite dir
 thawContentDir :: FilePath -> Annex ()
 thawContentDir file = unlessM crippledFileSystem $
 	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
--- a/Annex/Queue.hs
+++ b/Annex/Queue.hs
@ -1,62 +0,0 @@
 {- git-annex command queue
 -
 - Copyright 2011, 2012 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Annex.Queue (
 	addCommand,
 	addUpdateIndex,
 	flush,
 	flushWhenFull,
 	size
 ) where
 import Common.Annex
 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 <=< 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 <=< inRepo $ Git.Queue.addUpdateIndex streamer q
 {- Runs the queue if it is full. Should be called periodically. -}
 flushWhenFull :: Annex ()
 flushWhenFull = do
 	q <- get
 	when (Git.Queue.full q) flush
 {- Runs (and empties) the queue. -}
 flush :: Annex ()
 flush = do
 	q <- get
 	unless (0 == Git.Queue.size q) $ do
 		showStoringStateAction
 		q' <- inRepo $ Git.Queue.flush q
 		store 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 }
--- a/Annex/Quvi.hs
+++ b/Annex/Quvi.hs
@ -1,33 +0,0 @@
 {- quvi options for git-annex
 -
 - Copyright 2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE Rank2Types #-}
 module Annex.Quvi where
 import Common.Annex
 import qualified Annex
 import Utility.Quvi
 import Utility.Url
 withQuviOptions :: forall a. Query a -> [QuviParam] -> URLString -> Annex a
 withQuviOptions a ps url = do
 	v <- quviVersion
 	opts <- map Param . annexQuviOptions <$> Annex.getGitConfig
 	liftIO $ a v (map (\mkp -> mkp v) ps++opts) url
 quviSupported :: URLString -> Annex Bool
 quviSupported u = liftIO . flip supported u =<< quviVersion
 quviVersion :: Annex QuviVersion
 quviVersion = go =<< Annex.getState Annex.quviversion
  where
 	go (Just v) = return v
 	go Nothing = do
 		v <- liftIO probeVersion
 		Annex.changeState $ \s -> s { Annex.quviversion = Just v }
 		return v
--- a/Annex/ReplaceFile.hs
+++ b/Annex/ReplaceFile.hs
@ -1,50 +0,0 @@
 {- git-annex file replacing
 -
 - Copyright 2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Annex.ReplaceFile where
 import Common.Annex
 import Annex.Perms
 {- Replaces a possibly already existing file with a new version, 
 - atomically, by running an action.
 - 
 - The action is passed a temp file, which it can write to, and once
 - done the temp file is moved into place.
 -
 - The action can throw an IO exception, in which case the temp file
 - 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 = replaceFileOr file action (liftIO . nukeFile)
 {- If unable to replace the file with the temp file, runs the
 - rollback action, which is responsible for cleaning up the temp file. -}
 replaceFileOr :: FilePath -> (FilePath -> Annex ()) -> (FilePath -> Annex ()) -> Annex ()
 replaceFileOr file action rollback = do
 	tmpdir <- fromRepo gitAnnexTmpMiscDir
 	void $ createAnnexDirectory tmpdir
 	tmpfile <- liftIO $ setup tmpdir
 	go tmpfile `catchNonAsync` (const $ rollback tmpfile)
  where
 	setup tmpdir = do
 		(tmpfile, h) <- openTempFileWithDefaultPermissions tmpdir "tmp"
 		hClose h
 		return tmpfile
 	go tmpfile = do
 		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
--- a/Annex/Ssh.hs
+++ b/Annex/Ssh.hs
@ -1,301 +0,0 @@
 {- git-annex ssh interface, with connection caching
 -
 - Copyright 2012-2015 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE CPP #-}
 module Annex.Ssh (
 	sshOptions,
 	sshCacheDir,
 	sshReadPort,
 	forceSshCleanup,
 	sshOptionsEnv,
 	sshOptionsTo,
 	inRepoWithSshOptionsTo,
 	runSshOptions,
 	sshAskPassEnv,
 	runSshAskPass
 ) where
 import qualified Data.Map as M
 import Data.Hash.MD5
 import System.Exit
 import Common.Annex
 import Annex.LockFile
 import qualified Build.SysConfig as SysConfig
 import qualified Annex
 import qualified Git
 import qualified Git.Url
 import Config
 import Config.Files
 import Utility.Env
 import Types.CleanupActions
 import Annex.Index (addGitEnv)
 #ifndef mingw32_HOST_OS
 import Annex.Perms
 import Utility.LockFile
 #endif
 {- Generates parameters to ssh to a given host (or user@host) on a given
 - port. This includes connection caching parameters, and any ssh-options. -}
 sshOptions :: (String, Maybe Integer) -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam]
 sshOptions (host, port) gc opts = go =<< sshCachingInfo (host, port)
  where
 	go (Nothing, params) = ret params
 	go (Just socketfile, params) = do
 		prepSocket socketfile
 		ret params
 	ret ps = return $ concat
 		[ ps
 		, map Param (remoteAnnexSshOptions gc)
 		, opts
 		, portParams port
 		, [Param "-T"]
 		]
 {- Returns a filename to use for a ssh connection caching socket, and
 - parameters to enable ssh connection caching. -}
 sshCachingInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam])
 sshCachingInfo (host, port) = go =<< sshCacheDir
  where
 	go Nothing = return (Nothing, [])
 	go (Just dir) = do
 		r <- liftIO $ bestSocketPath $ dir </> hostport2socket host port
 		return $ case r of
 			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
 	, Params "-o ControlMaster=auto -o 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
 	| SysConfig.sshconnectioncaching = ifM crippledFileSystem
 		( maybe (return Nothing) usetmpdir =<< gettmpdir
 		, ifM (fromMaybe True . annexSshCaching <$> Annex.getGitConfig)
 			( 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. Locks a lock file to prevent
 - other git-annex processes from stopping the ssh on this socket. -}
 prepSocket :: FilePath -> Annex ()
 prepSocket socketfile = do
 	-- If the lock pool is empty, this is the first ssh of this
 	-- run. There could be stale ssh connections hanging around
 	-- from a previous git-annex run that was interrupted.
 	whenM (not . any isLock . M.keys <$> getLockPool)
 		sshCleanup
 	-- Cleanup at end of this run.
 	Annex.addCleanup SshCachingCleanup sshCleanup
 	liftIO $ createDirectoryIfMissing True $ parentDir socketfile
 	lockFileShared $ socket2lock socketfile
 enumSocketFiles :: Annex [FilePath]
 enumSocketFiles = go =<< sshCacheDir
  where
 	go Nothing = return []
 	go (Just dir) = liftIO $ 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
 		v <- liftIO $ noUmask mode $ tryLockExclusive (Just mode) lockfile
 		case v of
 			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 $
 				[ Params "-O 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 :: String -> Maybe Integer -> FilePath
 hostport2socket host Nothing = hostport2socket' host
 hostport2socket host (Just port) = hostport2socket' $ host ++ "!" ++ show port
 hostport2socket' :: String -> FilePath
 hostport2socket' s
 	| length s > lengthofmd5s = md5s (Str 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. -}
 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 sets sshOptionsEnv. -}
 sshOptionsTo :: Git.Repo -> RemoteGitConfig -> Git.Repo -> Annex Git.Repo
 sshOptionsTo remote gc g 
 	| not (Git.repoIsUrl remote) || Git.repoIsHttp remote = uncached
 	| otherwise = case Git.Url.hostuser remote of
 		Nothing -> uncached
 		Just host -> do
 			(msockfile, _) <- sshCachingInfo (host, Git.Url.port remote)
 			case msockfile of
 				Nothing -> return g
 				Just sockfile -> do
 					command <- liftIO readProgramFile
 					prepSocket sockfile
 					let val = toSshOptionsEnv $ concat
 						[ sshConnectionCachingParams sockfile
 						, map Param (remoteAnnexSshOptions gc)
 						]
 					liftIO $ do
 						g' <- addGitEnv g sshOptionsEnv val
 						addGitEnv g' "GIT_SSH" command
  where
 	uncached = return g
 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
--- a/Annex/TaggedPush.hs
+++ b/Annex/TaggedPush.hs
@ -1,61 +0,0 @@
 {- 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 Common.Annex
 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.Branch
 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.Branch -> Maybe (UUID, Maybe String)
 fromTaggedBranch b = case split "/" $ Git.fromRef b of
 	("refs":"synced":u:info:_base) ->
 		Just (toUUID u, fromB64Maybe info)
 	("refs":"synced":u:_base) ->
 		Just (toUUID u, Nothing)
 	_ -> Nothing
  where
 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)
--- a/Annex/Transfer.hs
+++ b/Annex/Transfer.hs
@ -1,145 +0,0 @@
 {- git-annex transfers
 -
 - Copyright 2012-2014 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE CPP #-}
 module Annex.Transfer (
 	module X,
 	upload,
 	download,
 	runTransfer,
 	alwaysRunTransfer,
 	noRetry,
 	forwardRetry,
 ) where
 import Common.Annex
 import Logs.Transfer as X
 import Annex.Notification as X
 import Annex.Perms
 import Utility.Metered
 #ifdef mingw32_HOST_OS
 import Utility.LockFile
 #endif
 import Control.Concurrent
 upload :: UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex Bool) -> NotifyWitness -> Annex Bool
 upload u key f d a _witness = runTransfer (Transfer Upload u key) f d a
 download :: UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex Bool) -> NotifyWitness -> Annex Bool
 download u key f d a _witness = runTransfer (Transfer Download u key) f d 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 :: Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex Bool) -> Annex Bool
 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 :: Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex Bool) -> Annex Bool
 alwaysRunTransfer = runTransfer' True
 runTransfer' :: Bool -> Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex Bool) -> Annex Bool
 runTransfer' ignorelock t file shouldretry a = do
 	info <- liftIO $ startTransferInfo file
 	(meter, tfile, metervar) <- mkProgressUpdater t info
 	mode <- annexFileMode
 	(fd, inprogress) <- liftIO $ prep tfile mode info
 	if inprogress && not ignorelock
 		then do
 			showNote "transfer already in progress"
 			return False
 		else do
 			ok <- retry info metervar $
 				bracketIO (return fd) (cleanup tfile) (const $ a meter)
 			unless ok $ recordFailedTransfer t info
 			return ok
  where
 #ifndef mingw32_HOST_OS
 	prep tfile mode info = do
 		mfd <- catchMaybeIO $
 			openFd (transferLockFile tfile) ReadWrite (Just mode)
 				defaultFileFlags { trunc = True }
 		case mfd of
 			Nothing -> return (Nothing, False)
 			Just fd -> do
 				setFdOption fd CloseOnExec True
 				locked <- catchMaybeIO $
 					setLock fd (WriteLock, AbsoluteSeek, 0, 0)
 				if isNothing locked
 					then do
 						closeFd fd
 						return (Nothing, True)
 					else do
 						void $ tryIO $ writeTransferInfoFile info tfile
 						return (mfd, False)
 #else
 	prep tfile _mode info = do
 		v <- catchMaybeIO $ lockExclusive (transferLockFile tfile)
 		case v of
 			Nothing -> return (Nothing, False)
 			Just Nothing -> return (Nothing, True)
 			Just (Just lockhandle) -> do
 				void $ tryIO $ writeTransferInfoFile info tfile
 				return (Just lockhandle, False)
 #endif
 	cleanup _ Nothing = noop
 	cleanup tfile (Just lockhandle) = do
 		void $ tryIO $ removeFile tfile
 #ifndef mingw32_HOST_OS
 		void $ tryIO $ removeFile $ transferLockFile tfile
 		closeFd 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 $ transferLockFile tfile
 #endif
 	retry oldinfo metervar run = do
 		v <- tryNonAsync run
 		case v of
 			Right b -> return b
 			Left e -> do
 				warning (show e)
 				b <- getbytescomplete metervar
 				let newinfo = oldinfo { bytesComplete = Just b }
 				if shouldretry oldinfo newinfo
 					then retry newinfo metervar run
 					else return False
 	getbytescomplete metervar
 		| transferDirection t == Upload =
 			liftIO $ readMVar metervar
 		| otherwise = do
 			f <- fromRepo $ gitAnnexTmpObjectLocation (transferKey t)
 			liftIO $ catchDefaultIO 0 $ getFileSize f
 type RetryDecider = TransferInfo -> TransferInfo -> Bool
 noRetry :: RetryDecider
 noRetry _ _ = False
 {- Retries a transfer when it fails, as long as the failed transfer managed
 - to send some data. -}
 forwardRetry :: RetryDecider
 forwardRetry old new = bytesComplete old < bytesComplete new
--- a/Annex/UUID.hs
+++ b/Annex/UUID.hs
@ -1,110 +0,0 @@
 {- 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-2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Annex.UUID (
 	getUUID,
 	getRepoUUID,
 	getUncachedUUID,
 	prepUUID,
 	genUUID,
 	genUUIDInNameSpace,
 	gCryptNameSpace,
 	removeRepoUUID,
 	storeUUID,
 	storeUUIDIn,
 	setUUID,
 	webUUID,
 	bitTorrentUUID,
 ) where
 import Common.Annex
 import qualified Git
 import qualified Git.Config
 import Config
 import qualified Data.UUID as U
 import qualified Data.UUID.V5 as U5
 import System.Random
 import Data.Bits.Utils
 configkey :: ConfigKey
 configkey = annexConfig "uuid"
 {- Generates a random UUID, that does not include the MAC address. -}
 genUUID :: IO UUID
 genUUID = UUID . show <$> (randomIO :: IO U.UUID)
 {- 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 = getRepoUUID =<< gitRepo
 {- Looks up a 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 = unsetConfig configkey
 getUncachedUUID :: Git.Repo -> UUID
 getUncachedUUID = toUUID . Git.Config.get 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 = storeUUIDIn configkey
 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"
--- a/Annex/Url.hs
+++ b/Annex/Url.hs
@ -1,42 +0,0 @@
 {- Url downloading, with git-annex user agent and configured http
 - headers and wget/curl options.
 -
 - Copyright 2013-2014 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Annex.Url (
 	module U,
 	withUrlOptions,
 	getUrlOptions,
 	getUserAgent,
 ) where
 import Common.Annex
 import qualified Annex
 import Utility.Url as U
 import qualified Build.SysConfig as SysConfig
 defaultUserAgent :: U.UserAgent
 defaultUserAgent = "git-annex/" ++ SysConfig.packageversion
 getUserAgent :: Annex (Maybe U.UserAgent)
 getUserAgent = Annex.getState $ 
 	Just . fromMaybe defaultUserAgent . Annex.useragent
 getUrlOptions :: Annex U.UrlOptions
 getUrlOptions = mkUrlOptions
 	<$> getUserAgent
 	<*> headers
 	<*> options
  where
 	headers = do
 		v <- annexHttpHeadersCommand <$> Annex.getGitConfig
 		case v of
 			Just cmd -> lines <$> liftIO (readProcess "sh" ["-c", cmd])
 			Nothing -> annexHttpHeaders <$> Annex.getGitConfig
 	options = map Param . annexWebOptions <$> Annex.getGitConfig
 withUrlOptions :: (U.UrlOptions -> IO a) -> Annex a
 withUrlOptions a = liftIO . a =<< getUrlOptions
--- a/Annex/VariantFile.hs
+++ b/Annex/VariantFile.hs
@ -1,45 +0,0 @@
 {- 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 Common.Annex
 import Types.Key
 import Data.Hash.MD5
 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 . md5s . md5FilePath
--- a/Annex/Version.hs
+++ b/Annex/Version.hs
@ -1,41 +0,0 @@
 {- 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 Common.Annex
 import Config
 import qualified Annex
 type Version = String
 supportedVersion :: Version
 supportedVersion = "5"
 upgradableVersions :: [Version]
 #ifndef mingw32_HOST_OS
 upgradableVersions = ["0", "1", "2", "4"]
 #else
 upgradableVersions = ["2", "3", "4"]
 #endif
 autoUpgradeableVersions :: [Version]
 autoUpgradeableVersions = ["3", "4"]
 versionField :: ConfigKey
 versionField = annexConfig "version"
 getVersion :: Annex (Maybe Version)
 getVersion = annexVersion <$> Annex.getGitConfig
 setVersion :: Version -> Annex ()
 setVersion = setConfig versionField
 removeVersion :: Annex ()
 removeVersion = unsetConfig versionField
--- a/Annex/View.hs
+++ b/Annex/View.hs
@ -1,450 +0,0 @@
 {- 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 Common.Annex
 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.HashObject
 import Git.Types
 import Git.FilePath
 import qualified Backend
 import Annex.Index
 import Annex.Link
 import Annex.CatFile
 import Logs.MetaData
 import Logs.View
 import Utility.Glob
 import Utility.FileMode
 import Types.Command
 import Config
 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 = error $ "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)
 toViewPath :: MetaValue -> FilePath
 toViewPath = concatMap escapeslash . fromMetaValue
  where
 	escapeslash c
 		| c == '/' = [pseudoSlash]
 		| c == '\\' = [pseudoBackslash]
 		| c == pseudoSlash = [pseudoSlash, pseudoSlash]
 		| c == pseudoBackslash = [pseudoBackslash, pseudoBackslash]
 		| otherwise = [c]
 fromViewPath :: FilePath -> MetaValue
 fromViewPath = toMetaValue . deescapeslash []
  where
 	deescapeslash s [] = reverse s
 	deescapeslash s (c:cs)
 		| c == pseudoSlash = case cs of
 			(c':cs')
 				| c' == pseudoSlash -> deescapeslash (pseudoSlash:s) cs'
 			_ -> deescapeslash ('/':s) cs
 		| c == pseudoBackslash = case cs of
 			(c':cs')
 				| c' == pseudoBackslash -> deescapeslash (pseudoBackslash:s) cs'
 			_ -> deescapeslash ('/':s) cs
 		| otherwise = deescapeslash (c:s) cs
 pseudoSlash :: Char
 pseudoSlash = '\8725' -- '∕' /= '/'
 pseudoBackslash :: Char
 pseudoBackslash = '\9586' -- '╲' /= '\'
 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 view = applyView' viewedFileFromReference getWorkTreeMetaData view
 {- 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 file in the currently checked out branch.
 - If the file is not annexed, skip it, unless it's a dotfile in the top.
 - Look up the metadata of annexed files, and generate any ViewedFiles,
 - and stage them.
 -
 - Currently only works in indirect mode. 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.inRepo [top]
 	liftIO . nukeFile =<< fromRepo gitAnnexViewIndex
 	genViewBranch view $ do
 		uh <- inRepo Git.UpdateIndex.startUpdateIndex
 		hasher <- inRepo hashObjectStart
 		forM_ l $ \f -> do
 			relf <- getTopFilePath <$> inRepo (toTopFilePath f)
 			go uh hasher relf =<< Backend.lookupFile f
 		liftIO $ do
 			hashObjectStop hasher
 			void $ stopUpdateIndex uh
 			void clean
  where
 	genviewedfiles = viewedFiles view mkviewedfile -- enables memoization
 	go uh hasher f (Just k) = do
 		metadata <- getCurrentMetaData k
 		let metadata' = getfilemetadata f `unionMetaData` metadata
 		forM_ (genviewedfiles f metadata') $ \fv -> do
 			f' <- fromRepo $ fromTopFilePath $ asTopFilePath fv
 			stagesymlink uh hasher f' =<< calcRepo (gitAnnexLink f' k)
 	go uh hasher f Nothing
 		| "." `isPrefixOf` f = do
 			s <- liftIO $ getSymbolicLinkStatus f
 			if isSymbolicLink s
 				then stagesymlink uh hasher f =<< liftIO (readSymbolicLink f)
 				else do
 					sha <- liftIO $ Git.HashObject.hashFile hasher f
 					let blobtype = if isExecutable (fileMode s)
 						then ExecutableBlob
 						else FileBlob
 					liftIO . Git.UpdateIndex.streamUpdateIndex' uh
 						=<< inRepo (Git.UpdateIndex.stageFile sha blobtype f)
 		| otherwise = noop
 	stagesymlink uh hasher f linktarget = do
 		sha <- hashSymlink' hasher linktarget
 		liftIO . Git.UpdateIndex.streamUpdateIndex' uh
 			=<< inRepo (Git.UpdateIndex.stageSymlink f sha)
 {- Applies a view to the reference branch, generating a new branch
 - for the View.
 -
 - This needs to work incrementally, to quickly update the view branch
 - when the reference branch is changed. So, it works based on an
 - old version of the reference branch, uses diffTree to find the
 - changes, and applies those changes to the view branch.
 -}
 updateView :: View -> Git.Ref -> Git.Ref -> Annex Git.Branch
 updateView view ref oldref = genViewBranch view $ do
 	(diffs, cleanup) <- inRepo $ DiffTree.diffTree oldref ref
 	forM_ diffs go
 	void $ liftIO cleanup
  where
 	go diff
 		| DiffTree.dstsha diff == nullSha = error "TODO delete file"
 		| otherwise = error "TODO add file"
 {- 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
 	makeabs <- flip fromTopFilePath <$> gitRepo
 	(diffs, cleanup) <- inRepo $ DiffTree.diffIndex Git.Ref.headRef
 	forM_ diffs handleremovals
 	forM_ diffs (handleadds makeabs)
 	void $ liftIO cleanup
  where
 	handleremovals item
 		| DiffTree.srcsha item /= nullSha =
 			handlechange item removemeta
 				=<< catKey (DiffTree.srcsha item) (DiffTree.srcmode item)
 		| otherwise = noop
 	handleadds makeabs item
 		| DiffTree.dstsha item /= nullSha = 
 			handlechange item addmeta
 				=<< ifM isDirect
 					( catKey (DiffTree.dstsha item) (DiffTree.dstmode item)
 					-- optimisation
 					, isAnnexLink $ makeabs $ DiffTree.file item
 					)
 		| otherwise = noop
 	handlechange item a = maybe noop
 		(void . commandAction . a (getTopFilePath $ DiffTree.file item))
 {- Generates a branch for a view. This is done using a different index
 - file. An action is run to stage the files that will be in the branch.
 - Then a commit is made, to the view branch. The view branch is not
 - checked out, but entering it will display the view. -}
 genViewBranch :: View -> Annex () -> Annex Git.Branch
 genViewBranch view a = withIndex $ do
 	a
 	let branch = branchView view
 	void $ inRepo $ Git.Branch.commit Git.Branch.AutomaticCommit True (fromRef branch) branch []
 	return branch
 {- 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. -}
 withIndex :: Annex a -> Annex a
 withIndex a = do
 	f <- fromRepo gitAnnexViewIndex
 	withIndexFile f a
 withCurrentView :: (View -> Annex a) -> Annex a
 withCurrentView a = maybe (error "Not in a view.") a =<< currentView
--- a/Annex/View/ViewedFile.hs
+++ b/Annex/View/ViewedFile.hs
@ -1,86 +0,0 @@
 {- 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 Common.Annex
 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
--- a/Annex/Wanted.hs
+++ b/Annex/Wanted.hs
@ -1,29 +0,0 @@
 {- 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 Common.Annex
 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
--- a/Assistant.hs
+++ b/Assistant.hs
@ -1,197 +0,0 @@
 {- 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.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
 #ifdef WITH_CLIBS
 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
 #ifdef WITH_XMPP
 import Assistant.Threads.XMPPClient
 import Assistant.Threads.XMPPPusher
 #endif
 #else
 import Assistant.Types.UrlRenderer
 #endif
 import qualified Utility.Daemon
 import Utility.ThreadScheduler
 import Utility.HumanTime
 import qualified Build.SysConfig as SysConfig
 import Annex.Perms
 import Utility.LogFile
 #ifdef mingw32_HOST_OS
 import Utility.Env
 import Config.Files
 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 <- readProgramFile
 				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", SysConfig.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
 #ifdef WITH_XMPP
 				, assist $ xmppClientThread urlrenderer
 				, assist $ xmppSendPackThread urlrenderer
 				, assist $ xmppReceivePackThread urlrenderer
 #endif
 #endif
 				, assist pushThread
 				, assist pushRetryThread
 				, assist mergeThread
 				, assist transferWatcherThread
 				, assist transferPollerThread
 				, assist transfererThread
 				, assist remoteControlThread
 				, assist daemonStatusThread
 				, assist $ sanityCheckerDailyThread urlrenderer
 				, assist sanityCheckerHourlyThread
 				, assist $ problemFixerThread urlrenderer
 #ifdef WITH_CLIBS
 				, 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
--- a/Assistant/Alert.hs
+++ b/Assistant/Alert.hs
@ -1,461 +0,0 @@
 {- 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 Common.Annex
 import Assistant.Types.Alert
 import Assistant.Alert.Utility
 import qualified Remote
 import Utility.Tense
 import Logs.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)
 import Yesod
 #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 
--- a/Assistant/Alert/Utility.hs
+++ b/Assistant/Alert/Utility.hs
@ -1,130 +0,0 @@
 {- 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 Common.Annex
 import Assistant.Types.Alert
 import Utility.Tense
 import qualified Data.Text as T
 import Data.Text (Text)
 import qualified Data.Map 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.insertWith' const 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
--- a/Assistant/BranchChange.hs
+++ b/Assistant/BranchChange.hs
@ -1,19 +0,0 @@
 {- 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)
--- a/Assistant/Changes.hs
+++ b/Assistant/Changes.hs
@ -1,47 +0,0 @@
 {- 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
--- a/Assistant/Commits.hs
+++ b/Assistant/Commits.hs
@ -1,23 +0,0 @@
 {- 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
--- a/Assistant/Common.hs
+++ b/Assistant/Common.hs
@ -1,14 +0,0 @@
 {- 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 Common.Annex 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
--- a/Assistant/CredPairCache.hs
+++ b/Assistant/CredPairCache.hs
@ -1,53 +0,0 @@
 {- 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'
--- a/Assistant/DaemonStatus.hs
+++ b/Assistant/DaemonStatus.hs
@ -1,271 +0,0 @@
 {- 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 Assistant.Types.NetMessager
 import Utility.NotificationBroadcaster
 import Logs.Transfer
 import Logs.Trust
 import qualified Remote
 import qualified Types.Remote as Remote
 import qualified Git
 import Control.Concurrent.STM
 import System.Posix.Types
 import Data.Time.Clock.POSIX
 import Data.Time
 import System.Locale
 import qualified Data.Map as M
 import qualified Data.Set as S
 import qualified Data.Text as T
 getDaemonStatus :: Assistant DaemonStatus
 getDaemonStatus = (atomically . readTMVar) <<~ 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 <$> takeTMVar dstatus
 			putTMVar 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 <- filter (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
 	let syncdata = filter (not . remoteAnnexIgnore . Remote.gitconfig) $
 		filter (not . Remote.isXMPPRemote) syncable
 	return $ \dstatus -> dstatus
 		{ syncRemotes = syncable
 		, syncGitRemotes = filter Remote.gitSyncableRemote syncable
 		, syncDataRemotes = syncdata
 		, syncingToCloudRemote = any iscloud syncdata
 		}
  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 $ newTMVar $ 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 readtime $ \v ->
 			status { lastRunning = Just v }
 		| key == "scanComplete" = parseval readish $ \v ->
 			status { scanComplete = v }
 		| key == "sanityCheckRunning" = parseval readish $ \v ->
 			status { sanityCheckRunning = v }
 		| key == "lastSanityCheck" = parseval readtime $ \v ->
 			status { lastSanityCheck = Just v }
 		| otherwise = status -- unparsable line
 	  where
 		(key, value) = separate (== ':') line
 		parseval parser a = maybe status a (parser value)
 		readtime s = do
 			d <- parseTime defaultTimeLocale "%s%Qs" s
 			Just $ utcTimeToPOSIXSeconds d
 {- 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 <- takeTMVar dstatus
 	let !v = a (currentTransfers s)
 	putTMVar dstatus $ s { currentTransfers = v }
 {- Checks if a transfer is currently running. -}
 checkRunningTransferSTM :: DaemonStatusHandle -> Transfer -> STM Bool
 checkRunningTransferSTM dstatus t = M.member t . currentTransfers
 	<$> readTMVar 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 (readTMVar dstatus)
 {- Send a notification when alerts are changed. -}
 notifyAlert :: Assistant ()
 notifyAlert = do
 	dstatus <- getAssistant daemonStatusHandle
 	liftIO $ sendNotification
 		=<< alertNotifier <$> atomically (readTMVar 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
 getXMPPClientID :: Remote -> ClientID
 getXMPPClientID r = T.pack $ drop (length "xmpp::") (Git.repoLocation (Remote.repo r))
--- a/Assistant/DeleteRemote.hs
+++ b/Assistant/DeleteRemote.hs
@ -1,89 +0,0 @@
 {- 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 Logs.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"
 			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
--- a/Assistant/Drop.hs
+++ b/Assistant/Drop.hs
@ -1,25 +0,0 @@
 {- 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
 {- Drop from local and/or remote when allowed by the preferred content and
 - numcopies settings. -}
 handleDrops :: Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Assistant ()
 handleDrops reason fromhere key f knownpresentremote = do
 	syncrs <- syncDataRemotes <$> getDaemonStatus
 	locs <- liftAnnex $ loggedLocations key
 	liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f knownpresentremote callCommandAction
--- a/Assistant/Fsck.hs
+++ b/Assistant/Fsck.hs
@ -1,50 +0,0 @@
 {- git-annex assistant fscking
 -
 - Copyright 2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL 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
--- a/Assistant/Gpg.hs
+++ b/Assistant/Gpg.hs
@ -1,36 +0,0 @@
 {- git-annex assistant gpg stuff
 -
 - Copyright 2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}
 {-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
 module Assistant.Gpg where
 import Utility.Gpg
 import Utility.UserInfo
 import Types.Remote (RemoteConfigKey)
 import qualified Data.Map as M
 {- Generates a gpg user id that is not used by any existing secret key -}
 newUserId :: IO UserId
 newUserId = do
 	oldkeys <- secretKeys
 	username <- 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")
--- a/Assistant/Install.hs
+++ b/Assistant/Install.hs
@ -1,179 +0,0 @@
 {- 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
 #ifdef linux_HOST_OS
 import Utility.UserInfo
 #endif
 import Assistant.Install.Menu
 #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 = 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
 #else
 		menufile <- desktopMenuFilePath "git-annex" <$> userDataDir
 		icondir <- iconDir <$> userDataDir
 		installMenu program menufile base icondir
 		autostartfile <- autoStartPath "git-annex" <$> userConfigDir
 #endif
 		installAutoStart program autostartfile
 		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 = do
 	let actions = ["get", "drop", "undo"]
 	-- Gnome
 	nautilusScriptdir <- (\d -> d </> "nautilus" </> "scripts") <$> userDataDir
 	createDirectoryIfMissing True nautilusScriptdir
 	forM_ actions $
 		genNautilusScript nautilusScriptdir
 	-- KDE
 	home <- myHomeDir
 	let kdeServiceMenusdir = home </> ".kde" </> "share" </> "kde4" </> "services" </> "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 '%U')\" &&"
 			, program
 			, command
 			, "--notify-start --notify-finish -- %U'"
 			]
 		]
 #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
--- a/Assistant/Install/AutoStart.hs
+++ b/Assistant/Install/AutoStart.hs
@ -1,39 +0,0 @@
 {- Assistant autostart file installation
 -
 - Copyright 2012 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE CPP #-}
 module Assistant.Install.AutoStart where
 import Utility.FreeDesktop
 #ifdef darwin_HOST_OS
 import Utility.OSX
 import Utility.Path
 import System.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
 	[]
--- a/Assistant/Install/Menu.hs
+++ b/Assistant/Install/Menu.hs
@ -1,47 +0,0 @@
 {- Assistant menu installation.
 -
 - Copyright 2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE CPP #-}
 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"
--- a/Assistant/MakeRemote.hs
+++ b/Assistant/MakeRemote.hs
@ -1,171 +0,0 @@
 {- 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 Command.InitRemote
 import Logs.UUID
 import Logs.Remote
 import Git.Remote
 import Git.Types (RemoteName)
 import Creds
 import Assistant.Gpg
 import Utility.Gpg (KeyId)
 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 =<< Command.InitRemote.findExisting name
  where
 	go Nothing = setupSpecialRemote name Rsync.remote config Nothing
 		(Nothing, Command.InitRemote.newConfig name)
 	go (Just (u, c)) = setupSpecialRemote name Rsync.remote config Nothing
 		(Just u, 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
 		r <- Command.InitRemote.findExisting fullname
 		case r of
 			Nothing -> setupSpecialRemote fullname remotetype config mcreds
 				(Nothing, Command.InitRemote.newConfig fullname)
 			Just _ -> go (n + 1)
 {- Enables an existing special remote. -}
 enableSpecialRemote :: SpecialRemoteMaker
 enableSpecialRemote name remotetype mcreds config = do
 	r <- Command.InitRemote.findExisting name
 	case r of
 		Nothing -> error $ "Cannot find a special remote named " ++ name
 		Just (u, c) -> setupSpecialRemote' False name remotetype config mcreds (Just u, c)
 setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName
 setupSpecialRemote = setupSpecialRemote' True
 setupSpecialRemote' :: Bool -> RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName
 setupSpecialRemote' setdesc name remotetype config mcreds (mu, 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. -}
 	(c', u) <- R.setup remotetype mu mcreds $
 		M.insert "highRandomQuality" "false" $ M.union config c
 	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
 	g <- gitRepo
 	if not (any samelocation $ Git.remotes g)
 		then do
 			let name = uniqueRemoteName basename 0 g
 			a name
 			return name
 		else return basename
  where
 	samelocation x = Git.repoLocation x == location
 {- Generate an unused name for a 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 r
 	| null namecollision = name
 	| otherwise = uniqueRemoteName legalbasename (succ n) r
  where
 	namecollision = filter samename (Git.remotes r)
 	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) storage
--- a/Assistant/Monad.hs
+++ b/Assistant/Monad.hs
@ -1,150 +0,0 @@
 {- 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 Common.Annex
 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.Buddies
 import Assistant.Types.NetMessager
 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
 	, commitChan :: CommitChan
 	, changePool :: ChangePool
 	, repoProblemChan :: RepoProblemChan
 	, branchChangeHandle :: BranchChangeHandle
 	, buddyList :: BuddyList
 	, netMessager :: NetMessager
 	, 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
 	<*> newCommitChan
 	<*> newChangePool
 	<*> newRepoProblemChan
 	<*> newBranchChangeHandle
 	<*> newBuddyList
 	<*> newNetMessager
 	<*> 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
--- a/Assistant/NamedThread.hs
+++ b/Assistant/NamedThread.hs
@ -1,102 +0,0 @@
 {- 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 Common.Annex
 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 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) = do
 	m <- startedThreads <$> getDaemonStatus
 	case M.lookup name m of
 		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.insertWith' const 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 = do
 		r <- E.try (wait aid) :: IO (Either E.SomeException ())
 		case r of
 			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
--- a/Assistant/NetMessager.hs
+++ b/Assistant/NetMessager.hs
@ -1,180 +0,0 @@
 {- git-annex assistant out of band network messager interface
 -
 - Copyright 2012-2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE BangPatterns #-}
 module Assistant.NetMessager where
 import Assistant.Common
 import Assistant.Types.NetMessager
 import Control.Concurrent.STM
 import Control.Concurrent.MSampleVar
 import qualified Data.Set as S
 import qualified Data.Map as M
 import qualified Data.DList as D
 sendNetMessage :: NetMessage -> Assistant ()
 sendNetMessage m = 
 	(atomically . flip writeTChan m) <<~ (netMessages . netMessager)
 waitNetMessage :: Assistant (NetMessage)
 waitNetMessage = (atomically . readTChan) <<~ (netMessages . netMessager)
 notifyNetMessagerRestart :: Assistant ()
 notifyNetMessagerRestart =
 	flip writeSV () <<~ (netMessagerRestart . netMessager)
 {- This can be used to get an early indication if the network has
 - changed, to immediately restart a connection. However, that is not
 - available on all systems, so clients also need to deal with
 - restarting dropped connections in the usual way. -}
 waitNetMessagerRestart :: Assistant ()
 waitNetMessagerRestart = readSV <<~ (netMessagerRestart . netMessager)
 {- Store a new important NetMessage for a client, and if an equivilant
 - older message is already stored, remove it from both importantNetMessages
 - and sentImportantNetMessages. -}
 storeImportantNetMessage :: NetMessage -> ClientID -> (ClientID -> Bool) -> Assistant ()
 storeImportantNetMessage m client matchingclient = go <<~ netMessager
  where
 	go nm = atomically $ do
 		q <- takeTMVar $ importantNetMessages nm
 		sent <- takeTMVar $ sentImportantNetMessages nm
 		putTMVar (importantNetMessages nm) $
 			M.alter (Just . maybe (S.singleton m) (S.insert m)) client $
 				M.mapWithKey removematching q
 		putTMVar (sentImportantNetMessages nm) $
 			M.mapWithKey removematching sent
 	removematching someclient s
 		| matchingclient someclient = S.filter (not . equivilantImportantNetMessages m) s
 		| otherwise = s
 {- Indicates that an important NetMessage has been sent to a client. -}
 sentImportantNetMessage :: NetMessage -> ClientID -> Assistant ()
 sentImportantNetMessage m client = go <<~ (sentImportantNetMessages . netMessager)
  where
 	go v = atomically $ do
 		sent <- takeTMVar v
 		putTMVar v $
 			M.alter (Just . maybe (S.singleton m) (S.insert m)) client sent
 {- Checks for important NetMessages that have been stored for a client, and
 - sent to a client. Typically the same client for both, although 
 - a modified or more specific client may need to be used. -}
 checkImportantNetMessages :: (ClientID, ClientID) -> Assistant (S.Set NetMessage, S.Set NetMessage)
 checkImportantNetMessages (storedclient, sentclient) = go <<~ netMessager
  where
 	go nm = atomically $ do
 		stored <- M.lookup storedclient <$> (readTMVar $ importantNetMessages nm)
 		sent <- M.lookup sentclient <$> (readTMVar $ sentImportantNetMessages nm)
 		return (fromMaybe S.empty stored, fromMaybe S.empty sent)
 {- Queues a push initiation message in the queue for the appropriate
 - side of the push but only if there is not already an initiation message
 - from the same client in the queue. -}
 queuePushInitiation :: NetMessage -> Assistant ()
 queuePushInitiation msg@(Pushing clientid stage) = do
 	tv <- getPushInitiationQueue side
 	liftIO $ atomically $ do
 		r <- tryTakeTMVar tv
 		case r of
 			Nothing -> putTMVar tv [msg]
 			Just l -> do
 				let !l' = msg : filter differentclient l
 				putTMVar tv l'
  where
 	side = pushDestinationSide stage
 	differentclient (Pushing cid _) = cid /= clientid
 	differentclient _ = True
 queuePushInitiation _ = noop
 {- Waits for a push inititation message to be received, and runs
 - function to select a message from the queue. -}
 waitPushInitiation :: PushSide -> ([NetMessage] -> (NetMessage, [NetMessage])) -> Assistant NetMessage
 waitPushInitiation side selector = do
 	tv <- getPushInitiationQueue side
 	liftIO $ atomically $ do
 		q <- takeTMVar tv
 		if null q
 			then retry
 			else do
 				let (msg, !q') = selector q
 				unless (null q') $
 					putTMVar tv q'
 				return msg
 {- Stores messages for a push into the appropriate inbox.
 -
 - To avoid overflow, only 1000 messages max are stored in any
 - inbox, which should be far more than necessary.
 -
 - TODO: If we have more than 100 inboxes for different clients,
 - discard old ones that are not currently being used by any push.
 -}
 storeInbox :: NetMessage -> Assistant ()
 storeInbox msg@(Pushing clientid stage) = do
 	inboxes <- getInboxes side
 	stored <- liftIO $ atomically $ do
 		m <- readTVar inboxes
 		let update = \v -> do
 			writeTVar inboxes $
 				M.insertWith' const clientid v m
 			return True
 		case M.lookup clientid m of
 			Nothing -> update (1, tostore)
 			Just (sz, l)
 				| sz > 1000 -> return False
 				| otherwise ->
 					let !sz' = sz + 1
 					    !l' = D.append l tostore
 					in update (sz', l')
 	if stored
 		then netMessagerDebug clientid ["stored", logNetMessage msg, "in", show side, "inbox"]
 		else netMessagerDebug clientid ["discarded", logNetMessage msg, "; ", show side, "inbox is full"]
  where
 	side = pushDestinationSide stage
 	tostore = D.singleton msg
 storeInbox _ = noop
 {- Gets the new message for a push from its inbox.
 - Blocks until a message has been received. -}
 waitInbox :: ClientID -> PushSide -> Assistant (NetMessage)
 waitInbox clientid side = do
 	inboxes <- getInboxes side
 	liftIO $ atomically $ do
 		m <- readTVar inboxes
 		case M.lookup clientid m of
 			Nothing -> retry
 			Just (sz, dl)
 				| sz < 1 -> retry
 				| otherwise -> do
 					let msg = D.head dl
 					let dl' = D.tail dl
 					let !sz' = sz - 1
 					writeTVar inboxes $
 						M.insertWith' const clientid (sz', dl') m
 					return msg
 emptyInbox :: ClientID -> PushSide -> Assistant ()
 emptyInbox clientid side = do
 	inboxes <- getInboxes side
 	liftIO $ atomically $
 		modifyTVar' inboxes $
 			M.delete clientid
 getInboxes :: PushSide -> Assistant Inboxes
 getInboxes side =
 	getSide side . netMessagerInboxes <$> getAssistant netMessager
 getPushInitiationQueue :: PushSide -> Assistant (TMVar [NetMessage])
 getPushInitiationQueue side =
 	getSide side . netMessagerPushInitiations <$> getAssistant netMessager
 netMessagerDebug :: ClientID -> [String] -> Assistant ()
 netMessagerDebug clientid l = debug $
 	"NetMessager" : l ++ [show $ logClientID clientid]
--- a/Assistant/Pairing.hs
+++ b/Assistant/Pairing.hs
@ -1,101 +0,0 @@
 {- 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 Common.Annex
 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 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
--- a/Assistant/Pairing/MakeRemote.hs
+++ b/Assistant/Pairing/MakeRemote.hs
@ -1,95 +0,0 @@
 {- 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 -> 
 		unlessM (liftIO $ addAuthorizedKeys True repodir 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 $ setupSshKeyPair 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
 	liftAnnex $ setRemoteCost (Remote.repo r) 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]
 		}
 {- 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 (PortNum 0) addr
 			IPv6Addr addr -> SockAddrInet6 (PortNum 0) 0 addr 0
 		fromMaybe (showAddr a)
 			<$> catchDefaultIO Nothing
 				(fst <$> getNameInfo [] True False sockaddr)
--- a/Assistant/Pairing/Network.hs
+++ b/Assistant/Pairing/Network.hs
@ -1,129 +0,0 @@
 {- 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 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 :: SomeAddr -> HostName
 multicastAddress (IPv4Addr _) = "224.0.0.251"
 multicastAddress (IPv6Addr _) = "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 i) pairingPort
 		cleanup (sock, _) = sClose sock -- FIXME does not work
 		use (sock, addr) = do
 			setInterface sock (showAddr i)
 			maybe noop (\s -> void $ sendTo sock 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
--- a/Assistant/Pushes.hs
+++ b/Assistant/Pushes.hs
@ -1,40 +0,0 @@
 {- 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 -> Assistant [Remote]
 getFailedPushesBefore duration = do
 	v <- getAssistant failedPushMap
 	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 :: (PushMap -> PushMap) -> Assistant ()
 changeFailedPushMap a = do
 	v <- getAssistant failedPushMap
 	liftIO $ atomically $ store v . a . fromMaybe M.empty =<< tryTakeTMVar v
  where
 	{- tryTakeTMVar empties the TMVar; refill it only if
 	 - the modified map is not itself empty -}
 	store v m
 		| m == M.empty = noop
 		| otherwise = putTMVar v $! m
--- a/Assistant/RemoteControl.hs
+++ b/Assistant/RemoteControl.hs
@ -1,21 +0,0 @@
 {- 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
--- a/Assistant/Repair.hs
+++ b/Assistant/Repair.hs
@ -1,159 +0,0 @@
 {- git-annex assistant repository repair
 -
 - Copyright 2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL 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 Config.Files
 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 <- readProgramFile
 		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
--- a/Assistant/RepoProblem.hs
+++ b/Assistant/RepoProblem.hs
@ -1,34 +0,0 @@
 {- 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
--- a/Assistant/Restart.hs
+++ b/Assistant/Restart.hs
@ -1,117 +0,0 @@
 {- git-annex assistant restarting
 -
 - Copyright 2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL 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 Config.Files
 import qualified Annex
 import qualified Git
 import Control.Concurrent
 #ifndef mingw32_HOST_OS
 import System.Posix (signalProcess, sigTERM)
 #else
 import Utility.WinProcess
 #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
 		terminatePID =<< 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 problimatic.
 - warp-tls listens to http, in order to show an error page, so this works.
 -}
 assistantListening :: URLString -> IO Bool
 assistantListening url = catchBoolIO $ exists url' def
  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 <- readProgramFile
 	(_, _, _, pid) <- 
 		createProcess $
 			(proc program ["assistant"]) { cwd = Just repo }
 	void $ checkSuccessProcess pid
--- a/Assistant/ScanRemotes.hs
+++ b/Assistant/ScanRemotes.hs
@ -1,41 +0,0 @@
 {- 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 
 		}
--- a/Assistant/Ssh.hs
+++ b/Assistant/Ssh.hs
@ -1,345 +0,0 @@
 {- 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 Common.Annex
 import Utility.Tmp
 import Utility.Shell
 import Utility.Rsync
 import Utility.FileMode
 import Utility.SshConfig
 import Git.Remote
 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]
 	}
 	deriving (Read, Show, Eq)
 data SshServerCapability = GitAnnexShellCapable | GitCapable | RsyncCapable
 	deriving (Read, Show, Eq)
 hasCapability :: SshData -> SshServerCapability -> Bool
 hasCapability d c = c `elem` sshCapabilities d
 onlyCapability :: SshData -> SshServerCapability -> Bool
 onlyCapability d c = all (== c) (sshCapabilities d)
 data SshKeyPair = SshKeyPair
 	{ sshPubKey :: String
 	, sshPrivKey :: String
 	}
 instance Show SshKeyPair where
 	show = sshPubKey
 type SshPubKey = String
 {- 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 -> String
 genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
 {- Generates a ssh or rsync url from a SshData. -}
 genSshUrl :: SshData -> String
 genSshUrl sshdata = 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 = []
 		}
 	  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] -> (Maybe String) -> IO (String, Bool)
 sshTranscript opts input = processTranscript "ssh" opts 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.
 -}
 setupSshKeyPair :: SshKeyPair -> SshData -> IO SshData
 setupSshKeyPair sshkeypair sshdata = do
 	sshdir <- sshDir
 	createDirectoryIfMissing True $ parentDir $ sshdir </> sshprivkeyfile
 	unlessM (doesFileExist $ sshdir </> sshprivkeyfile) $
 		writeFileProtected (sshdir </> sshprivkeyfile) (sshPrivKey sshkeypair)
 	unlessM (doesFileExist $ sshdir </> sshpubkeyfile) $
 		writeFile (sshdir </> sshpubkeyfile) (sshPubKey sshkeypair)
 	setSshConfig sshdata
 		[ ("IdentityFile", "~/.ssh/" ++ sshprivkeyfile)
 		, ("IdentitiesOnly", "yes")
 		, ("StrictHostKeyChecking", "yes")
 		]
  where
 	sshprivkeyfile = "git-annex" </> "key." ++ mangleSshHostName sshdata
 	sshpubkeyfile = sshprivkeyfile ++ ".pub"
 {- 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 }
  where
 	mangledhost = mangleSshHostName sshdata
 	settings =
 		[ ("Hostname", T.unpack $ sshHostName sshdata)
 		, ("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".
 - The only use of "-" is to separate the parts shown; this is necessary
 - to allow unMangleSshHostName to work. Any unusual characters in the
 - username or directory are url encoded, except using "." rather than "%"
 - (the latter has special meaning to ssh).
 -}
 mangleSshHostName :: SshData -> String
 mangleSshHostName sshdata = "git-annex-" ++ 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
 {- Extracts the real hostname from a mangled ssh hostname. -}
 unMangleSshHostName :: String -> String
 unMangleSshHostName h = case split "-" h of
 	("git":"annex":rest) -> intercalate "-" (beginning rest)
 	_ -> h
 {- 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]
--- a/Assistant/Sync.hs
+++ b/Assistant/Sync.hs
@ -1,278 +0,0 @@
 {- 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.NetMessager
 import Assistant.Types.NetMessager
 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.Branch
 import qualified Git.Command
 import qualified Git.Ref
 import qualified Remote
 import qualified Types.Remote as Remote
 import qualified Remote.List as Remote
 import qualified Annex.Branch
 import Annex.UUID
 import Annex.TaggedPush
 import qualified Config
 import Git.Config
 import Assistant.NamedThread
 import Assistant.Threads.Watcher (watchThread, WatcherControl(..))
 import Assistant.TransferSlots
 import Assistant.TransferQueue
 import Assistant.RepoProblem
 import Logs.Transfer
 import Data.Time.Clock
 import qualified Data.Map as M
 import qualified Data.Set as S
 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.
 -
 - XMPP remotes are also signaled that we can push to them, and we request
 - they push to us. Since XMPP pushes run ansynchronously, any scan of the
 - XMPP remotes has to be deferred until they're done pushing to us, so
 - all XMPP remotes are marked as possibly desynced.
 -
 - Also handles signaling any connectRemoteNotifiers, after the syncing is
 - done.
 -}
 reconnectRemotes :: Bool -> [Remote] -> Assistant ()
 reconnectRemotes _ [] = noop
 reconnectRemotes notifypushes rs = void $ do
 	rs' <- liftIO $ filterM (Remote.checkAvailable True) rs
 	unless (null rs') $ do
 		modifyDaemonStatus_ $ \s -> s
 			{ desynced = S.union (S.fromList $ map Remote.uuid xmppremotes) (desynced s) }
 		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'
  where
 	gitremotes = filter (notspecialremote . Remote.repo) rs
 	(xmppremotes, nonxmppremotes) = partition Remote.isXMPPRemote rs
 	notspecialremote r
 		| Git.repoIsUrl r = True
 		| Git.repoIsLocal r = True
 		| Git.repoIsLocalUnknown r = True
 		| otherwise = False
 	sync (Just branch) = do
 		(failedpull, diverged) <- manualPull (Just branch) gitremotes
 		now <- liftIO getCurrentTime
 		failedpush <- pushToRemotes' now notifypushes gitremotes
 		return (nub $ failedpull ++ failedpush, diverged)
 	{- No local branch exists yet, but we can try pulling. -}
 	sync Nothing = manualPull Nothing gitremotes
 	go = do
 		(failed, diverged) <- sync
 			=<< liftAnnex (inRepo Git.Branch.current)
 		addScanRemotes diverged $
 			filter (not . remoteAnnexIgnore . Remote.gitconfig)
 				nonxmppremotes
 		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".
 -
 - After the pushes to normal git remotes, also signals XMPP clients that
 - they can request an XMPP push.
 -
 - 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 :: Bool -> [Remote] -> Assistant [Remote]
 pushToRemotes notifypushes remotes = do
 	now <- liftIO getCurrentTime
 	let remotes' = filter (not . remoteAnnexReadOnly . Remote.gitconfig) remotes
 	syncAction remotes' (pushToRemotes' now notifypushes)
 pushToRemotes' :: UTCTime -> Bool -> [Remote] -> Assistant [Remote]
 pushToRemotes' now notifypushes remotes = do
 	(g, branch, u) <- liftAnnex $ do
 		Annex.Branch.commit "update"
 		(,,)
 			<$> gitRepo
 			<*> inRepo Git.Branch.current
 			<*> getUUID
 	let (xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
 	ret <- go True branch g u normalremotes
 	unless (null xmppremotes) $ do
 		shas <- liftAnnex $ map fst <$>
 			inRepo (Git.Ref.matchingWithHEAD
 				[Annex.Branch.fullname, Git.Ref.headRef])
 		forM_ xmppremotes $ \r -> sendNetMessage $
 			Pushing (getXMPPClientID r) (CanPush u shas)
 	return ret
  where
 	go _ Nothing _ _ _ = return [] -- no branch, so nothing to do
 	go _ _ _ _ [] = return [] -- no remotes, so nothing to do
 	go shouldretry (Just branch) g u rs =  do
 		debug ["pushing to", show rs]
 		(succeeded, failed) <- liftIO $ inParallel (push g branch) rs
 		updatemap succeeded []
 		if null failed
 			then do
 				when notifypushes $
 					sendNetMessage $ NotifyPush $
 						map Remote.uuid succeeded
 				return failed
 			else if shouldretry
 				then retry branch g u failed
 				else fallback branch g u failed
 	updatemap succeeded failed = changeFailedPushMap $ \m ->
 		M.union (makemap failed) $
 			M.difference m (makemap succeeded)
 	makemap l = M.fromList $ zip l (repeat now)
 	retry branch g u rs = do
 		debug ["trying manual pull to resolve failed pushes"]
 		void $ manualPull (Just branch) rs
 		go False (Just branch) g u rs
 	fallback branch g u rs = do
 		debug ["fallback pushing to", show rs]
 		(succeeded, failed) <- liftIO $
 			inParallel (\r -> taggedPush u Nothing branch r g) rs
 		updatemap succeeded failed
 		when (notifypushes && (not $ null succeeded)) $
 			sendNetMessage $ NotifyPush $
 				map Remote.uuid succeeded
 		return failed
 	push g branch remote = Command.Sync.pushBranch remote branch g
 {- Displays an alert while running an action that syncs with some remotes,
 - and returns any remotes that it failed to sync with.
 -
 - XMPP remotes are handled specially; since the action can only start
 - an async process for them, they are not included in the alert, but are
 - still passed to the action.
 -
 - 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
 		let failed' = filter (not . Git.repoIsLocalUnknown . Remote.repo) 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) $
 		filter (not . Remote.isXMPPRemote) 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.
 -
 - After pulling from the normal git remotes, requests pushes from any
 - XMPP remotes. However, those pushes will run asynchronously, so their
 - results are not included in the return data.
 -}
 manualPull :: Maybe Git.Ref -> [Remote] -> Assistant ([Remote], Bool)
 manualPull currentbranch remotes = do
 	g <- liftAnnex gitRepo
 	let (xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
 	failed <- liftIO $ forM normalremotes $ \r ->
 		ifM (Git.Command.runBool [Param "fetch", Param $ Remote.name r] g)
 			( return Nothing
 			, return $ Just r
 			)
 	haddiverged <- liftAnnex Annex.Branch.forceUpdate
 	forM_ normalremotes $ \r ->
 		liftAnnex $ Command.Sync.mergeRemote r currentbranch
 	u <- liftAnnex getUUID
 	forM_ xmppremotes $ \r ->
 		sendNetMessage $ Pushing (getXMPPClientID r) (PushRequest u)
 	return (catMaybes failed, haddiverged)
 {- Start syncing a remote, using a background thread. -}
 syncRemote :: Remote -> Assistant ()
 syncRemote remote = do
 	updateSyncRemotes
 	thread <- asIO $ do
 		reconnectRemotes False [remote]
 		addScanRemotes True [remote]
 	void $ liftIO $ forkIO $ thread
 {- Use Nothing to change autocommit setting; or a remote to change
 - its sync setting. -}
 changeSyncable :: Maybe Remote -> Bool -> Assistant ()
 changeSyncable Nothing enable = do
 	liftAnnex $ Config.setConfig key (boolConfig enable)
 	liftIO . maybe noop (`throwTo` signal)
 		=<< namedThreadId watchThread
  where
 	key = Config.annexConfig "autocommit"
 	signal
 		| enable = ResumeWatcher
 		| otherwise = PauseWatcher
 changeSyncable (Just r) True = do
 	liftAnnex $ changeSyncFlag r True
 	syncRemote r
 	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
 	Config.setConfig key (boolConfig enabled)
 	void Remote.remoteListRefresh
  where
 	key = Config.remoteConfig (Remote.repo r) "sync"
--- a/Assistant/Threads/Committer.hs
+++ b/Assistant/Threads/Committer.hs
@ -1,479 +0,0 @@
 {- 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 Logs.Transfer
 import Logs.Location
 import qualified Annex.Queue
 import qualified Git.LsFiles
 import qualified Command.Add
 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.Link
 import Annex.CatFile
 import qualified Annex
 import Utility.InodeCache
 import Annex.Content.Direct
 import qualified Command.Sync
 import qualified Git.Branch
 import Data.Time.Clock
 import Data.Tuple.Utils
 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 changes
 		if shouldCommit False time (length readychanges) readychanges
 			then do
 				debug
 					[ "committing"
 					, show (length readychanges)
 					, "changes"
 					]
 				void $ alertWhile commitAlert $
 					liftAnnex $ commitStaged msg
 				recordCommit
 				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 an undefined 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 =<< inRepo Git.Branch.current
 			return ok
 {- OSX needs a short delay after a file is added before locking it down,
 - when using a non-direct mode repository, 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
 	( 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, 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
 	(pending', cleanup) <- if direct
 		then return (pending, noop)
 		else findnew pending
 	(postponed, toadd) <- partitionEithers <$> safeToAdd havelsof delayadd pending' inprocess
 	cleanup
 	unless (null postponed) $
 		refillChanges postponed
 	returnWhen (null toadd) $ do
 		added <- addaction toadd $
 			catMaybes <$> if direct
 				then adddirect toadd
 				else forM toadd add
 		if DirWatcher.eventsCoalesce || null added || 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
 	findnew [] = return ([], noop)
 	findnew pending@(exemplar:_) = do
 		(newfiles, cleanup) <- liftAnnex $
 			inRepo (Git.LsFiles.notInRepo False $ map changeFile pending)
 		-- 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 :: Change -> Assistant (Maybe Change)
 	add change@(InProcessAddChange { keySource = ks }) = 
 		catchDefaultIO Nothing <~> doadd
 	  where
 		doadd = sanitycheck ks $ do
 			(mkey, mcache) <- liftAnnex $ do
 				showStart "add" $ keyFilename ks
 				Command.Add.ingest $ Just ks
 			maybe (failedingest change) (done change mcache $ keyFilename ks) mkey
 	add _ = return Nothing
 	{- In direct mode, avoid overhead of re-injesting a renamed
 	 - 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.
 	 -}
 	adddirect :: [Change] -> Assistant [Maybe Change]
 	adddirect toadd = do
 		ct <- liftAnnex compareInodeCachesWith
 		m <- liftAnnex $ removedKeysMap ct cs
 		delta <- liftAnnex getTSDelta
 		if M.null m
 			then forM toadd add
 			else forM toadd $ \c -> do
 				mcache <- liftIO $ genInodeCache (changeFile c) delta
 				case mcache of
 					Nothing -> add c
 					Just cache ->
 						case M.lookup (inodeCacheToKey ct cache) m of
 							Nothing -> add c
 							Just k -> fastadd c k
 	fastadd :: Change -> Key -> Assistant (Maybe Change)
 	fastadd change key = do
 		let source = keySource change
 		liftAnnex $ Command.Add.finishIngestDirect key source
 		done change Nothing (keyFilename source) key
 	removedKeysMap :: InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key)
 	removedKeysMap 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)) <$>
 			recordedInodeCache k
 	failedingest change = do
 		refill [retryChange change]
 		liftAnnex showEndFail
 		return Nothing
 	done change mcache file key = liftAnnex $ do
 		logStatus key InfoPresent
 		link <- ifM isDirect
 			( calcRepo $ gitAnnexLink file key
 			, Command.Add.link 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 :: Bool -> Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change]
 safeToAdd _ _ [] [] = return []
 safeToAdd havelsof delayadd pending inprocess = do
 	maybe noop (liftIO . threadDelaySeconds) delayadd
 	liftAnnex $ do
 		keysources <- forM pending $ Command.Add.lockDown . changeFile
 		let inprocess' = inprocess ++ mapMaybe mkinprocess (zip pending keysources)
 		openfiles <- if havelsof
 			then S.fromList . map fst3 . filter openwrite <$>
 				findopenfiles (map keySource 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 { keySource = ks })
 		| S.member (contentLocation ks) openfiles = Left change
 	check _ change = Right change
 	mkinprocess (c, Just ks) = Just InProcessAddChange
 		{ changeTime = changeTime c
 		, keySource = ks
 		}
 	mkinprocess (_, Nothing) = Nothing
 	canceladd (InProcessAddChange { keySource = ks }) = do
 		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 = segmentXargs $ 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 (Just f) Upload
 				else queueTransfers "new or renamed file wanted" Next k (Just f) Download
 			handleDrops "file renamed" present k (Just f) Nothing
  where
 	f = changeFile change
 checkChangeContent _ = noop
--- a/Assistant/Threads/ConfigMonitor.hs
+++ b/Assistant/Threads/ConfigMonitor.hs
@ -1,91 +0,0 @@
 {- 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.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, String)
 {- 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)
--- a/Assistant/Threads/Cronner.hs
+++ b/Assistant/Threads/Cronner.hs
@ -1,225 +0,0 @@
 {- git-annex assistant sceduled jobs runner
 -
 - Copyright 2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE DeriveDataTypeable #-}
 module Assistant.Threads.Cronner (
 	cronnerThread
 ) where
 import Assistant.Common
 import Assistant.DaemonStatus
 import Utility.NotificationBroadcaster
 import Annex.UUID
 import Config.Files
 import Logs.Schedule
 import Utility.Scheduled
 import Types.ScheduledActivity
 import Utility.ThreadScheduler
 import Utility.HumanTime
 import Utility.Batch
 import Assistant.TransferQueue
 import Annex.Content
 import Logs.Transfer
 import Assistant.Types.UrlRenderer
 import Assistant.Alert
 import Remote
 import qualified Types.Remote as Remote
 import qualified Git
 import qualified Git.Fsck
 import Assistant.Fsck
 import Assistant.Repair
 import Control.Concurrent.Async
 import Control.Concurrent.MVar
 import Data.Time.LocalTime
 import Data.Time.Clock
 import qualified Data.Map as M
 import qualified Data.Set as S
 {- Loads schedules for this repository, and fires off one thread for each 
 - scheduled event that runs on this repository. Each thread sleeps until
 - its event is scheduled to run.
 -
 - To handle events that run on remotes, which need to only run when
 - their remote gets connected, threads are also started, and are passed
 - a MVar to wait on, which is stored in the DaemonStatus's
 - connectRemoteNotifiers.
 -
 - In the meantime the main thread waits for any changes to the
 - schedules. When there's a change, compare the old and new list of
 - schedules to find deleted and added ones. Start new threads for added
 - ones, and kill the threads for deleted ones. -}
 cronnerThread :: UrlRenderer -> NamedThread
 cronnerThread urlrenderer = namedThreadUnchecked "Cronner" $ do
 	fsckNudge urlrenderer Nothing
 	dstatus <- getDaemonStatus
 	h <- liftIO $ newNotificationHandle False (scheduleLogNotifier dstatus)
 	go h M.empty M.empty
  where
 	go h amap nmap = do
 		activities <- liftAnnex $ scheduleGet =<< getUUID
 		let addedactivities = activities `S.difference` M.keysSet amap
 		let removedactivities = M.keysSet amap `S.difference` activities
 		forM_ (S.toList removedactivities) $ \activity ->
 			case M.lookup activity amap of
 				Just a -> do
 					debug ["stopping removed job for", fromScheduledActivity activity, show (asyncThreadId a)]
 					liftIO $ cancel a
 				Nothing -> noop
 		lastruntimes <- liftAnnex getLastRunTimes
 		started <- startactivities (S.toList addedactivities) lastruntimes
 		let addedamap = M.fromList $ map fst started
 		let addednmap = M.fromList $ catMaybes $ map snd started
 		let removefiltered = M.filterWithKey (\k _ -> S.member k removedactivities)
 		let amap' = M.difference (M.union addedamap amap) (removefiltered amap)
 		let nmap' = M.difference (M.union addednmap nmap) (removefiltered nmap)
 		modifyDaemonStatus_ $ \s -> s { connectRemoteNotifiers = M.fromListWith (++) (M.elems nmap') }
 		liftIO $ waitNotification h
 		debug ["reloading changed activities"]
 		go h amap' nmap'
 	startactivities as lastruntimes = forM as $ \activity ->
 		case connectActivityUUID activity of
 			Nothing -> do
 				runner <- asIO2 (sleepingActivityThread urlrenderer)
 				a <- liftIO $ async $
 					runner activity (M.lookup activity lastruntimes)
 				return ((activity, a), Nothing)
 			Just u -> do
 				mvar <- liftIO newEmptyMVar
 				runner <- asIO2 (remoteActivityThread urlrenderer mvar)
 				a <- liftIO $ async $
 					runner activity (M.lookup activity lastruntimes)
 				return ((activity, a), Just (activity, (u, [mvar])))
 {- Calculate the next time the activity is scheduled to run, then
 - sleep until that time, and run it. Then call setLastRunTime, and
 - loop.
 -}
 sleepingActivityThread :: UrlRenderer -> ScheduledActivity -> Maybe LocalTime -> Assistant ()
 sleepingActivityThread urlrenderer activity lasttime = go lasttime =<< getnexttime lasttime
  where
 	getnexttime = liftIO . nextTime schedule
 	go _ Nothing = debug ["no scheduled events left for", desc]
 	go l (Just (NextTimeExactly t)) = waitrun l t Nothing
 	go l (Just (NextTimeWindow windowstart windowend)) =
 		waitrun l windowstart (Just windowend)
 	desc = fromScheduledActivity activity
 	schedule = getSchedule activity
 	waitrun l t mmaxt = do
 		seconds <- liftIO $ secondsUntilLocalTime t
 		when (seconds > Seconds 0) $ do
 			debug ["waiting", show seconds, "for next scheduled", desc]
 			liftIO $ threadDelaySeconds seconds
 		now <- liftIO getCurrentTime
 		tz <- liftIO $ getTimeZone now
 		let nowt = utcToLocalTime tz now
 		if tolate nowt tz
 			then do
 				debug ["too late to run scheduled", desc]
 				go l =<< getnexttime l
 			else run nowt
 	  where
 		tolate nowt tz = case mmaxt of
 			Just maxt -> nowt > maxt
 			-- allow the job to start 10 minutes late
 			Nothing ->diffUTCTime 
 				(localTimeToUTC tz nowt)
 				(localTimeToUTC tz t) > 600
 	run nowt = do
 		runActivity urlrenderer activity nowt
 		go (Just nowt) =<< getnexttime (Just nowt)
 {- Wait for the remote to become available by waiting on the MVar.
 - Then check if the time is within a time window when activity
 - is scheduled to run, and if so run it.
 - Otherwise, just wait again on the MVar.
 -}
 remoteActivityThread :: UrlRenderer -> MVar () -> ScheduledActivity -> Maybe LocalTime -> Assistant ()
 remoteActivityThread urlrenderer mvar activity lasttime = do
 	liftIO $ takeMVar mvar
 	go =<< liftIO (nextTime (getSchedule activity) lasttime)
  where
 	go (Just (NextTimeWindow windowstart windowend)) = do
 		now <- liftIO getCurrentTime
 		tz <- liftIO $ getTimeZone now
 		if now >= localTimeToUTC tz windowstart && now <= localTimeToUTC tz windowend
 			then do
 				let nowt = utcToLocalTime tz now
 				runActivity urlrenderer activity nowt
 				loop (Just nowt)
 			else loop lasttime
 	go _ = noop -- running at exact time not handled here
 	loop = remoteActivityThread urlrenderer mvar activity
 secondsUntilLocalTime :: LocalTime -> IO Seconds
 secondsUntilLocalTime t = do
 	now <- getCurrentTime
 	tz <- getTimeZone now
 	let secs = truncate $ diffUTCTime (localTimeToUTC tz t) now
 	return $ if secs > 0
 		then Seconds secs
 		else Seconds 0
 runActivity :: UrlRenderer -> ScheduledActivity -> LocalTime -> Assistant ()
 runActivity urlrenderer activity nowt = do
 	debug ["starting", desc]
 	runActivity' urlrenderer activity
 	debug ["finished", desc]
 	liftAnnex $ setLastRunTime activity nowt
  where
 	desc = fromScheduledActivity activity
 runActivity' :: UrlRenderer -> ScheduledActivity -> Assistant ()
 runActivity' urlrenderer (ScheduledSelfFsck _ d) = do
 	program <- liftIO $ readProgramFile
 	g <- liftAnnex gitRepo
 	fsckresults <- showFscking urlrenderer Nothing $ tryNonAsync $ do
 		void $ batchCommand program (Param "fsck" : annexFsckParams d)
 		Git.Fsck.findBroken True g
 	u <- liftAnnex getUUID
 	void $ repairWhenNecessary urlrenderer u Nothing fsckresults
 	mapM_ reget =<< liftAnnex (dirKeys gitAnnexBadDir)
  where
 	reget k = queueTransfers "fsck found bad file; redownloading" Next k Nothing Download
 runActivity' urlrenderer (ScheduledRemoteFsck u s d) = dispatch =<< liftAnnex (remoteFromUUID u)
  where
 	dispatch Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s]
 	dispatch (Just rmt) = void $ case Remote.remoteFsck rmt of
 		Nothing -> go rmt $ do
 			program <- readProgramFile
 			void $ batchCommand program $ 
 				[ Param "fsck"
 				-- avoid downloading files
 				, Param "--fast"
 				, Param "--from"
 				, Param $ Remote.name rmt
 				] ++ annexFsckParams d
 		Just mkfscker -> do
 			{- Note that having mkfsker return an IO action
 			 - avoids running a long duration fsck in the
 			 - Annex monad. -}
 			go rmt =<< liftAnnex (mkfscker (annexFsckParams d))
 	go rmt annexfscker = do
 		fsckresults <- showFscking urlrenderer (Just rmt) $ tryNonAsync $ do
 			void annexfscker
 			let r = Remote.repo rmt
 			if Git.repoIsLocal r && not (Git.repoIsLocalUnknown r)
 				then Just <$> Git.Fsck.findBroken True r
 				else pure Nothing
 		maybe noop (void . repairWhenNecessary urlrenderer u (Just rmt)) fsckresults
 annexFsckParams :: Duration -> [CommandParam]
 annexFsckParams d =
 	[ Param "--incremental-schedule=1d"
 	, Param $ "--time-limit=" ++ fromDuration d
 	]
--- a/Assistant/Threads/DaemonStatus.hs
+++ b/Assistant/Threads/DaemonStatus.hs
@ -1,29 +0,0 @@
 {- git-annex assistant daemon status thread
 -
 - Copyright 2012 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Assistant.Threads.DaemonStatus where
 import Assistant.Common
 import Assistant.DaemonStatus
 import Utility.ThreadScheduler
 import Utility.NotificationBroadcaster
 {- This writes the daemon status to disk, when it changes, but no more
 - frequently than once every ten minutes.
 -}
 daemonStatusThread :: NamedThread
 daemonStatusThread = namedThread "DaemonStatus" $ do
 	notifier <- liftIO . newNotificationHandle False
 		=<< changeNotifier <$> getDaemonStatus
 	checkpoint
 	runEvery (Seconds tenMinutes) <~> do
 		liftIO $ waitNotification notifier
 		checkpoint
  where
 	checkpoint = do
 		file <- liftAnnex $ fromRepo gitAnnexDaemonStatusFile
 		liftIO . writeDaemonStatusFile file =<< getDaemonStatus
--- a/Assistant/Threads/Glacier.hs
+++ b/Assistant/Threads/Glacier.hs
@ -1,43 +0,0 @@
 {- git-annex assistant Amazon Glacier retrieval
 -
 - Copyright 2012 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Assistant.Threads.Glacier where
 import Assistant.Common
 import Utility.ThreadScheduler
 import qualified Types.Remote as Remote
 import qualified Remote.Glacier as Glacier
 import Logs.Transfer
 import Assistant.DaemonStatus
 import Assistant.TransferQueue
 import qualified Data.Set as S
 {- Wakes up every half hour and checks if any glacier remotes have failed
 - downloads. If so, runs glacier-cli to check if the files are now
 - available, and queues the downloads. -}
 glacierThread :: NamedThread
 glacierThread = namedThread "Glacier" $ runEvery (Seconds 3600) <~> go
  where
 	isglacier r = Remote.remotetype r == Glacier.remote
 	go = do
 		rs <- filter isglacier . syncDataRemotes <$> getDaemonStatus
 		forM_ rs $ \r -> 
 			check r =<< liftAnnex (getFailedTransfers $ Remote.uuid r)
 	check _ [] = noop
 	check r l = do
 		let keys = map getkey l
 		(availkeys, failedkeys) <- liftAnnex $ Glacier.jobList r keys
 		let s = S.fromList (failedkeys ++ availkeys)
 		let l' = filter (\p -> S.member (getkey p) s) l
 		forM_ l' $ \(t, info) -> do
 			liftAnnex $ removeFailedTransfer t
 			queueTransferWhenSmall "object available from glacier" (associatedFile info) t r
 	getkey = transferKey . fst
--- a/Assistant/Threads/Merger.hs
+++ b/Assistant/Threads/Merger.hs
@ -1,119 +0,0 @@
 {- git-annex assistant git merge thread
 -
 - Copyright 2012 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Assistant.Threads.Merger where
 import Assistant.Common
 import Assistant.TransferQueue
 import Assistant.BranchChange
 import Assistant.DaemonStatus
 import Assistant.ScanRemotes
 import Utility.DirWatcher
 import Utility.DirWatcher.Types
 import qualified Annex.Branch
 import qualified Git
 import qualified Git.Branch
 import Annex.AutoMerge
 import Annex.TaggedPush
 import Remote (remoteFromUUID)
 import qualified Data.Set as S
 import qualified Data.Text as T
 {- This thread watches for changes to .git/refs/, and handles incoming
 - pushes. -}
 mergeThread :: NamedThread
 mergeThread = namedThread "Merger" $ do
 	g <- liftAnnex gitRepo
 	let dir = Git.localGitDir g </> "refs"
 	liftIO $ createDirectoryIfMissing True dir
 	let hook a = Just <$> asIO2 (runHandler a)
 	changehook <- hook onChange
 	errhook <- hook onErr
 	let hooks = mkWatchHooks
 		{ addHook = changehook
 		, modifyHook = changehook
 		, errHook = errhook
 		}
 	void $ liftIO $ watchDir dir (const False) True hooks id
 	debug ["watching", dir]
 type Handler = FilePath -> Assistant ()
 {- Runs an action handler.
 -
 - Exceptions are ignored, otherwise a whole thread could be crashed.
 -}
 runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
 runHandler handler file _filestatus =
 	either (liftIO . print) (const noop) =<< tryIO <~> handler file
 {- Called when there's an error with inotify. -}
 onErr :: Handler
 onErr = error
 {- Called when a new branch ref is written, or a branch ref is modified.
 -
 - At startup, synthetic add events fire, causing this to run, but that's
 - ok; it ensures that any changes pushed since the last time the assistant
 - ran are merged in.
 -}
 onChange :: Handler
 onChange file
 	| ".lock" `isSuffixOf` file = noop
 	| isAnnexBranch file = do
 		branchChanged
 		diverged <- liftAnnex Annex.Branch.forceUpdate
 		when diverged $
 			unlessM handleDesynced $
 				queueDeferredDownloads "retrying deferred download" Later
 	| "/synced/" `isInfixOf` file =
 		mergecurrent =<< liftAnnex (inRepo Git.Branch.current)
 	| otherwise = noop
  where
 	changedbranch = fileToBranch file
 	mergecurrent (Just current)
 		| equivBranches changedbranch current =
 			whenM (liftAnnex $ inRepo $ Git.Branch.changed current changedbranch) $ do
 				debug
 					[ "merging", Git.fromRef changedbranch
 					, "into", Git.fromRef current
 					]
 				void $ liftAnnex $ autoMergeFrom changedbranch (Just current) Git.Branch.AutomaticCommit
 	mergecurrent _ = noop
 	handleDesynced = case fromTaggedBranch changedbranch of
 		Nothing -> return False
 		Just (u, info) -> do
 			mr <- liftAnnex $ remoteFromUUID u
 			case mr of
 				Nothing -> return False
 				Just r -> do
 					s <- desynced <$> getDaemonStatus
 					if S.member u s || Just (T.unpack $ getXMPPClientID r) == info
 						then do
 							modifyDaemonStatus_ $ \st -> st
 								{ desynced = S.delete u s }
 							addScanRemotes True [r]
 							return True
 						else return False
 equivBranches :: Git.Ref -> Git.Ref -> Bool
 equivBranches x y = base x == base y
  where
 	base = takeFileName . Git.fromRef
 isAnnexBranch :: FilePath -> Bool
 isAnnexBranch f = n `isSuffixOf` f
  where
 	n = '/' : Git.fromRef Annex.Branch.name
 fileToBranch :: FilePath -> Git.Ref
 fileToBranch f = Git.Ref $ "refs" </> base
  where
 	base = Prelude.last $ split "/refs/" f
--- a/Assistant/Threads/MountWatcher.hs
+++ b/Assistant/Threads/MountWatcher.hs
@ -1,199 +0,0 @@
 {- git-annex assistant mount watcher, using either dbus or mtab polling
 -
 - Copyright 2012 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Assistant.Threads.MountWatcher where
 import Assistant.Common
 import Assistant.DaemonStatus
 import Assistant.Sync
 import qualified Annex
 import qualified Git
 import Utility.ThreadScheduler
 import Utility.Mounts
 import Remote.List
 import qualified Types.Remote as Remote
 import Assistant.Types.UrlRenderer
 import Assistant.Fsck
 import qualified Data.Set as S
 #if WITH_DBUS
 import Utility.DBus
 import DBus.Client
 import DBus
 import Data.Word (Word32)
 import Control.Concurrent
 import qualified Control.Exception as E
 #else
 #warning Building without dbus support; will use mtab polling
 #endif
 mountWatcherThread :: UrlRenderer -> NamedThread
 mountWatcherThread urlrenderer = namedThread "MountWatcher" $
 #if WITH_DBUS
 	dbusThread urlrenderer
 #else
 	pollingThread urlrenderer
 #endif
 #if WITH_DBUS
 dbusThread :: UrlRenderer -> Assistant ()
 dbusThread urlrenderer = do
 	runclient <- asIO1 go
 	r <- liftIO $ E.try $ runClient getSessionAddress runclient
 	either onerr (const noop) r
  where
 	go client = ifM (checkMountMonitor client)
 		( do
 			{- Store the current mount points in an MVar, to be
 			 - compared later. We could in theory work out the
 			 - mount point from the dbus message, but this is
 			 - easier. -}
 			mvar <- liftIO $ newMVar =<< currentMountPoints
 			handleevent <- asIO1 $ \_event -> do
 				nowmounted <- liftIO $ currentMountPoints
 				wasmounted <- liftIO $ swapMVar mvar nowmounted
 				handleMounts urlrenderer wasmounted nowmounted
 			liftIO $ forM_ mountChanged $ \matcher ->
 #if MIN_VERSION_dbus(0,10,7)
 				void $ addMatch client matcher handleevent
 #else
 				listen client matcher handleevent
 #endif
 		, do
 			liftAnnex $
 				warning "No known volume monitor available through dbus; falling back to mtab polling"
 			pollingThread urlrenderer
 		)
 	onerr :: E.SomeException -> Assistant ()
 	onerr e = do
 		{- If the session dbus fails, the user probably
 		 - logged out of their desktop. Even if they log
 		 - back in, we won't have access to the dbus
 		 - session key, so polling is the best that can be
 		 - done in this situation. -}
 		liftAnnex $
 			warning $ "dbus failed; falling back to mtab polling (" ++ show e ++ ")"
 		pollingThread urlrenderer
 {- Examine the list of services connected to dbus, to see if there
 - are any we can use to monitor mounts. If not, will attempt to start one. -}
 checkMountMonitor :: Client -> Assistant Bool
 checkMountMonitor client = do
 	running <- filter (`elem` usableservices)
 		<$> liftIO (listServiceNames client)
 	case running of
 		[] -> startOneService client startableservices
 		(service:_) -> do
 			debug [ "Using running DBUS service"
 				, service
 				, "to monitor mount events."
 				]
 			return True
  where
 	startableservices = [gvfs, gvfsgdu]
 	usableservices = startableservices ++ [kde]
 	gvfs = "org.gtk.Private.UDisks2VolumeMonitor"
 	gvfsgdu = "org.gtk.Private.GduVolumeMonitor"
 	kde = "org.kde.DeviceNotifications"
 startOneService :: Client -> [ServiceName] -> Assistant Bool
 startOneService _ [] = return False
 startOneService client (x:xs) = do
 	_ <- liftIO $ tryNonAsync $ callDBus client "StartServiceByName"
 		[toVariant x, toVariant (0 :: Word32)]
 	ifM (liftIO $ elem x <$> listServiceNames client)
 		( do
 			debug
 				[ "Started DBUS service", x
 				, "to monitor mount events."
 				]
 			return True
 		, startOneService client xs
 		)
 {- Filter matching events recieved when drives are mounted and unmounted. -}	
 mountChanged :: [MatchRule]
 mountChanged = [gvfs True, gvfs False, kde, kdefallback]
  where
 	{- gvfs reliably generates this event whenever a
 	 - drive is mounted/unmounted, whether automatically, or manually -}
 	gvfs mount = matchAny
 		{ matchInterface = Just "org.gtk.Private.RemoteVolumeMonitor"
 		, matchMember = Just $ if mount then "MountAdded" else "MountRemoved"
 		}
 	{- This event fires when KDE prompts the user what to do with a drive,
 	 - but maybe not at other times. And it's not received -}
 	kde = matchAny
 		{ matchInterface = Just "org.kde.Solid.Device"
 		, matchMember = Just "setupDone"
 		}
 	{- This event may not be closely related to mounting a drive, but it's
 	 - observed reliably when a drive gets mounted or unmounted. -}
 	kdefallback = matchAny
 		{ matchInterface = Just "org.kde.KDirNotify"
 		, matchMember = Just "enteredDirectory"
 		}
 #endif
 pollingThread :: UrlRenderer -> Assistant ()
 pollingThread urlrenderer = go =<< liftIO currentMountPoints
  where
 	go wasmounted = do
 		liftIO $ threadDelaySeconds (Seconds 10)
 		nowmounted <- liftIO currentMountPoints
 		handleMounts urlrenderer wasmounted nowmounted
 		go nowmounted
 handleMounts :: UrlRenderer -> MountPoints -> MountPoints -> Assistant ()
 handleMounts urlrenderer wasmounted nowmounted =
 	mapM_ (handleMount urlrenderer . mnt_dir) $
 		S.toList $ newMountPoints wasmounted nowmounted
 handleMount :: UrlRenderer -> FilePath -> Assistant ()
 handleMount urlrenderer dir = do
 	debug ["detected mount of", dir]
 	rs <- filter (Git.repoIsLocal . Remote.repo) <$> remotesUnder dir
 	mapM_ (fsckNudge urlrenderer . Just) rs
 	reconnectRemotes True rs
 {- Finds remotes located underneath the mount point.
 -
 - Updates state to include the remotes.
 -
 - The config of git remotes is re-read, as it may not have been available
 - at startup time, or may have changed (it could even be a different
 - repository at the same remote location..)
 -}
 remotesUnder :: FilePath -> Assistant [Remote]
 remotesUnder dir = do
 	repotop <- liftAnnex $ fromRepo Git.repoPath
 	rs <- liftAnnex remoteList
 	pairs <- liftAnnex $ mapM (checkremote repotop) rs
 	let (waschanged, rs') = unzip pairs
 	when (or waschanged) $ do
 		liftAnnex $ Annex.changeState $ \s -> s { Annex.remotes = catMaybes rs' }
 		updateSyncRemotes
 	return $ mapMaybe snd $ filter fst pairs
  where
 	checkremote repotop r = case Remote.localpath r of
 		Just p | dirContains dir (absPathFrom repotop p) ->
 			(,) <$> pure True <*> updateRemote r
 		_ -> return (False, Just r)
 type MountPoints = S.Set Mntent
 currentMountPoints :: IO MountPoints
 currentMountPoints = S.fromList <$> getMounts
 newMountPoints :: MountPoints -> MountPoints -> MountPoints
 newMountPoints old new = S.difference new old
--- a/Assistant/Threads/NetWatcher.hs
+++ b/Assistant/Threads/NetWatcher.hs
@ -1,184 +0,0 @@
 {- git-annex assistant network connection watcher, using dbus
 -
 - Copyright 2012 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Assistant.Threads.NetWatcher where
 import Assistant.Common
 import Assistant.Sync
 import Utility.ThreadScheduler
 import qualified Types.Remote as Remote
 import Assistant.DaemonStatus
 import Utility.NotificationBroadcaster
 #if WITH_DBUS
 import Assistant.RemoteControl
 import Utility.DBus
 import DBus.Client
 import DBus
 import Assistant.NetMessager
 #else
 #ifdef linux_HOST_OS
 #warning Building without dbus support; will poll for network connection changes
 #endif
 #endif
 netWatcherThread :: NamedThread
 #if WITH_DBUS
 netWatcherThread = thread dbusThread
 #else
 netWatcherThread = thread noop
 #endif
  where
 	thread = namedThread "NetWatcher"
 {- This is a fallback for when dbus cannot be used to detect
 - network connection changes, but it also ensures that
 - any networked remotes that may have not been routable for a
 - while (despite the local network staying up), are synced with
 - periodically.
 -
 - Note that it does not call notifyNetMessagerRestart, or
 - signal the RemoteControl, because it doesn't know that the
 - network has changed.
 -}
 netWatcherFallbackThread :: NamedThread
 netWatcherFallbackThread = namedThread "NetWatcherFallback" $
 	runEvery (Seconds 3600) <~> handleConnection
 #if WITH_DBUS
 dbusThread :: Assistant ()
 dbusThread = do
 	handleerr <- asIO2 onerr
 	runclient <- asIO1 go
 	liftIO $ persistentClient getSystemAddress () handleerr runclient
  where
 	go client = ifM (checkNetMonitor client)
 		( do
 			callback <- asIO1 connchange
 			liftIO $ do
 				listenNMConnections client callback
 				listenWicdConnections client callback
 		, do
 			liftAnnex $
 				warning "No known network monitor available through dbus; falling back to polling"
 		)
 	connchange False = do
 		debug ["detected network disconnection"]
 		sendRemoteControl LOSTNET
 	connchange True = do
 		debug ["detected network connection"]
 		notifyNetMessagerRestart
 		handleConnection
 		sendRemoteControl RESUME
 	onerr e _ = do
 		liftAnnex $
 			warning $ "lost dbus connection; falling back to polling (" ++ show e ++ ")"
 		{- Wait, in hope that dbus will come back -}
 		liftIO $ threadDelaySeconds (Seconds 60)
 {- Examine the list of services connected to dbus, to see if there
 - are any we can use to monitor network connections. -}
 checkNetMonitor :: Client -> Assistant Bool
 checkNetMonitor client = do
 	running <- liftIO $ filter (`elem` [networkmanager, wicd])
 		<$> listServiceNames client
 	case running of
 		[] -> return False
 		(service:_) -> do
 			debug [ "Using running DBUS service"
 				, service
 				, "to monitor network connection events."
 				]
 			return True
  where
 	networkmanager = "org.freedesktop.NetworkManager"
 	wicd = "org.wicd.daemon"
 {- Listens for NetworkManager connections and diconnections.
 -
 - Connection example (once fully connected):
 - [Variant {"ActivatingConnection": Variant (ObjectPath "/"), "PrimaryConnection": Variant (ObjectPath "/org/freedesktop/NetworkManager/ActiveConnection/34"), "State": Variant 70}]
 -
 - Disconnection example:
 - [Variant {"ActiveConnections": Variant []}]
 -}
 listenNMConnections :: Client -> (Bool -> IO ()) -> IO ()
 listenNMConnections client setconnected =
 #if MIN_VERSION_dbus(0,10,7)
 	void $ addMatch client matcher
 #else
 	listen client matcher
 #endif
 		$ \event -> mapM_ handleevent
 			(map dictionaryItems $ mapMaybe fromVariant $ signalBody event)
  where
 	matcher = matchAny
 		{ matchInterface = Just "org.freedesktop.NetworkManager"
 		, matchMember = Just "PropertiesChanged"
 		}
 	nm_active_connections_key = toVariant ("ActiveConnections" :: String)
 	nm_activatingconnection_key = toVariant ("ActivatingConnection" :: String)
 	noconnections = Just $ toVariant $ toVariant ([] :: [ObjectPath])
 	rootconnection = Just $ toVariant $ toVariant $ objectPath_ "/"
 	handleevent m
 		| lookup nm_active_connections_key m == noconnections =
 			setconnected False
 		| lookup nm_activatingconnection_key m == rootconnection =
 			setconnected True
 		| otherwise = noop
 {- Listens for Wicd connections and disconnections.
 -
 - Connection example:
 -   ConnectResultsSent:
 -     Variant "success"
 -
 - Diconnection example:
 -   StatusChanged
 -     [Variant 0, Variant [Varient ""]]
 -}
 listenWicdConnections :: Client -> (Bool -> IO ()) -> IO ()
 listenWicdConnections client setconnected = do
 	match connmatcher $ \event ->
 		when (any (== wicd_success) (signalBody event)) $
 			setconnected True
 	match statusmatcher $ \event -> handleevent (signalBody event)
  where
 	connmatcher = matchAny
 		{ matchInterface = Just "org.wicd.daemon"
 		, matchMember = Just "ConnectResultsSent"
 		}
 	statusmatcher = matchAny
 		{ matchInterface = Just "org.wicd.daemon"
 		, matchMember = Just "StatusChanged"
 		}
 	wicd_success = toVariant ("success" :: String)
 	wicd_disconnected = toVariant [toVariant ("" :: String)]
 	handleevent status
 		| any (== wicd_disconnected) status = setconnected False
 		| otherwise = noop
 	match matcher a = 
 #if MIN_VERSION_dbus(0,10,7)
 		void $ addMatch client matcher a
 #else
 		listen client matcher a
 #endif
 #endif
 handleConnection :: Assistant ()
 handleConnection = do
 	liftIO . sendNotification . networkConnectedNotifier =<< getDaemonStatus
 	reconnectRemotes True =<< networkRemotes
 {- Network remotes to sync with. -}
 networkRemotes :: Assistant [Remote]
 networkRemotes = filter (isNothing . Remote.localpath) . syncRemotes
 	<$> getDaemonStatus
--- a/Assistant/Threads/PairListener.hs
+++ b/Assistant/Threads/PairListener.hs
@ -1,151 +0,0 @@
 {- git-annex assistant thread to listen for incoming pairing traffic
 -
 - Copyright 2012 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Assistant.Threads.PairListener where
 import Assistant.Common
 import Assistant.Pairing
 import Assistant.Pairing.Network
 import Assistant.Pairing.MakeRemote
 import Assistant.WebApp (UrlRenderer)
 import Assistant.WebApp.Types
 import Assistant.Alert
 import Assistant.DaemonStatus
 import Utility.ThreadScheduler
 import Git
 import Network.Multicast
 import Network.Socket
 import qualified Data.Text as T
 pairListenerThread :: UrlRenderer -> NamedThread
 pairListenerThread urlrenderer = namedThread "PairListener" $ do
 	listener <- asIO1 $ go [] []
 	liftIO $ withSocketsDo $
 		runEvery (Seconds 60) $ void $ tryIO $ 
 			listener =<< getsock
  where
 	{- Note this can crash if there's no network interface,
 	 - or only one like lo that doesn't support multicast. -}
 	getsock = multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort
 	go reqs cache sock = liftIO (getmsg sock []) >>= \msg -> case readish msg of
 		Nothing -> go reqs cache sock
 		Just m -> do
 			debug ["received", show msg]
 			(pip, verified) <- verificationCheck m
 				=<< (pairingInProgress <$> getDaemonStatus)
 			let wrongstage = maybe False (\p -> pairMsgStage m <= inProgressPairStage p) pip
 			let fromus = maybe False (\p -> remoteSshPubKey (pairMsgData m) == remoteSshPubKey (inProgressPairData p)) pip
 			case (wrongstage, fromus, checkSane (pairMsgData m), pairMsgStage m) of
 				(_, True, _, _) -> do
 					debug ["ignoring message that looped back"]
 					go reqs cache sock
 				(_, _, False, _) -> do
 					liftAnnex $ warning
 						"illegal control characters in pairing message; ignoring"
 					go reqs cache sock
 				-- PairReq starts a pairing process, so a
 				-- new one is always heeded, even if
 				-- some other pairing is in process.
 				(_, _, _, PairReq) -> if m `elem` reqs
 					then go reqs (invalidateCache m cache) sock
 					else do
 						pairReqReceived verified urlrenderer m
 						go (m:take 10 reqs) (invalidateCache m cache) sock
 				(True, _, _, _) -> do
 					debug
 						["ignoring out of order message"
 						, show (pairMsgStage m)
 						, "expected"
 						, show (succ . inProgressPairStage <$> pip)
 						]
 					go reqs cache sock
 				(_, _, _, PairAck) -> do
 					cache' <- pairAckReceived verified pip m cache
 					go reqs cache' sock
 				(_,_ , _, PairDone) -> do
 					pairDoneReceived verified pip m
 					go reqs cache sock
 	{- As well as verifying the message using the shared secret,
 	 - check its UUID against the UUID we have stored. If
 	 - they're the same, someone is sending bogus messages,
 	 - which could be an attempt to brute force the shared secret. -}
 	verificationCheck _ Nothing = return (Nothing, False)
 	verificationCheck m (Just pip)
 		| not verified && sameuuid = do
 			liftAnnex $ warning
 				"detected possible pairing brute force attempt; disabled pairing"
 			stopSending pip
 			return (Nothing, False)
 		| otherwise = return (Just pip, verified && sameuuid)
 	  where
 		verified = verifiedPairMsg m pip
 		sameuuid = pairUUID (inProgressPairData pip) == pairUUID (pairMsgData m)
 	{- PairReqs invalidate the cache of recently finished pairings.
 	 - This is so that, if a new pairing is started with the
 	 - same secret used before, a bogus PairDone is not sent. -}
 	invalidateCache msg = filter (not . verifiedPairMsg msg)
 	getmsg sock c = do
 		(msg, n, _) <- recvFrom sock chunksz
 		if n < chunksz
 			then return $ c ++ msg
 			else getmsg sock $ c ++ msg
 	  where
 		chunksz = 1024
 {- Show an alert when a PairReq is seen. -}
 pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant ()
 pairReqReceived True _ _ = noop -- ignore our own PairReq
 pairReqReceived False urlrenderer msg = do
 	button <- mkAlertButton True (T.pack "Respond") urlrenderer (FinishLocalPairR msg)
 	void $ addAlert $ pairRequestReceivedAlert repo button
  where
 	repo = pairRepo msg
 {- When a verified PairAck is seen, a host is ready to pair with us, and has
 - already configured our ssh key. Stop sending PairReqs, finish the pairing,
 - and send a single PairDone. -}
 pairAckReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> [PairingInProgress] -> Assistant [PairingInProgress]
 pairAckReceived True (Just pip) msg cache = do
 	stopSending pip
 	repodir <- repoPath <$> liftAnnex gitRepo
 	liftIO $ setupAuthorizedKeys msg repodir
 	finishedLocalPairing msg (inProgressSshKeyPair pip)
 	startSending pip PairDone $ multicastPairMsg
 		(Just 1) (inProgressSecret pip) (inProgressPairData pip)
 	return $ pip : take 10 cache
 {- A stale PairAck might also be seen, after we've finished pairing.
 - Perhaps our PairDone was not received. To handle this, we keep
 - a cache of recently finished pairings, and re-send PairDone in
 - response to stale PairAcks for them. -}
 pairAckReceived _ _ msg cache = do
 	let pips = filter (verifiedPairMsg msg) cache
 	unless (null pips) $
 		forM_ pips $ \pip ->
 			startSending pip PairDone $ multicastPairMsg
 				(Just 1) (inProgressSecret pip) (inProgressPairData pip)
 	return cache
 {- If we get a verified PairDone, the host has accepted our PairAck, and
 - has paired with us. Stop sending PairAcks, and finish pairing with them.
 -
 - TODO: Should third-party hosts remove their pair request alert when they
 - see a PairDone?
 - Complication: The user could have already clicked on the alert and be
 - entering the secret. Would be better to start a fresh pair request in this
 - situation.
 -}
 pairDoneReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> Assistant ()
 pairDoneReceived False _ _ = noop -- not verified
 pairDoneReceived True Nothing _ = noop -- not in progress
 pairDoneReceived True (Just pip) msg = do
 	stopSending pip
 	finishedLocalPairing msg (inProgressSshKeyPair pip)
--- a/Assistant/Threads/ProblemFixer.hs
+++ b/Assistant/Threads/ProblemFixer.hs
@ -1,70 +0,0 @@
 {- git-annex assistant thread to handle fixing problems with repositories
 -
 - Copyright 2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Assistant.Threads.ProblemFixer (
 	problemFixerThread
 ) where
 import Assistant.Common
 import Assistant.Types.RepoProblem
 import Assistant.RepoProblem
 import Assistant.Types.UrlRenderer
 import Assistant.Alert
 import Remote
 import qualified Types.Remote as Remote
 import qualified Git.Fsck
 import Assistant.Repair
 import qualified Git
 import Annex.UUID
 import Utility.ThreadScheduler
 {- Waits for problems with a repo, and tries to fsck the repo and repair
 - the problem. -}
 problemFixerThread :: UrlRenderer -> NamedThread
 problemFixerThread urlrenderer = namedThread "ProblemFixer" $
 	go =<< getRepoProblems
  where
 	go problems = do
 		mapM_ (handleProblem urlrenderer) problems
 		liftIO $ threadDelaySeconds (Seconds 60)
 		-- Problems may have been re-reported while they were being
 		-- fixed, so ignore those. If a new unique problem happened
 		-- 60 seconds after the last was fixed, we're unlikely
 		-- to do much good anyway.
 		go =<< filter (\p -> not (any (sameRepoProblem p) problems))
 			<$> getRepoProblems
 handleProblem :: UrlRenderer -> RepoProblem -> Assistant ()
 handleProblem urlrenderer repoproblem = do
 	fixed <- ifM ((==) (problemUUID repoproblem) <$> liftAnnex getUUID)
 		( handleLocalRepoProblem urlrenderer
 		, maybe (return False) (handleRemoteProblem urlrenderer)
 			=<< liftAnnex (remoteFromUUID $ problemUUID repoproblem)
 		)
 	when fixed $
 		liftIO $ afterFix repoproblem
 handleRemoteProblem :: UrlRenderer -> Remote -> Assistant Bool
 handleRemoteProblem urlrenderer rmt
 	| Git.repoIsLocal r && not (Git.repoIsLocalUnknown r) =
 		ifM (liftIO $ checkAvailable True rmt)
 			( do
 				fixedlocks <- repairStaleGitLocks r
 				fsckresults <- showFscking urlrenderer (Just rmt) $ tryNonAsync $
 					Git.Fsck.findBroken True r
 				repaired <- repairWhenNecessary urlrenderer (Remote.uuid rmt) (Just rmt) fsckresults
 				return $ fixedlocks || repaired
 			, return False
 			)
 	| otherwise = return False
  where
 	r = Remote.repo rmt
 {- This is not yet used, and should probably do a fsck. -}
 handleLocalRepoProblem :: UrlRenderer -> Assistant Bool
 handleLocalRepoProblem _urlrenderer = do
 	repairStaleGitLocks =<< liftAnnex gitRepo
--- a/Assistant/Threads/Pusher.hs
+++ b/Assistant/Threads/Pusher.hs
@ -1,49 +0,0 @@
 {- git-annex assistant git pushing thread
 -
 - Copyright 2012 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Assistant.Threads.Pusher where
 import Assistant.Common
 import Assistant.Commits
 import Assistant.Pushes
 import Assistant.DaemonStatus
 import Assistant.Sync
 import Utility.ThreadScheduler
 import qualified Remote
 import qualified Types.Remote as Remote
 {- This thread retries pushes that failed before. -}
 pushRetryThread :: NamedThread
 pushRetryThread = namedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do
 	-- We already waited half an hour, now wait until there are failed
 	-- pushes to retry.
 	topush <- getFailedPushesBefore (fromIntegral halfhour)
 	unless (null topush) $ do
 		debug ["retrying", show (length topush), "failed pushes"]
 		void $ pushToRemotes True topush
  where
 	halfhour = 1800
 {- This thread pushes git commits out to remotes soon after they are made. -}
 pushThread :: NamedThread
 pushThread = namedThread "Pusher" $ runEvery (Seconds 2) <~> do
 	-- We already waited two seconds as a simple rate limiter.
 	-- Next, wait until at least one commit has been made
 	void getCommits
 	-- Now see if now's a good time to push.
 	void $ pushToRemotes True =<< pushTargets
 {- We want to avoid pushing to remotes that are marked readonly.
 -
 - Also, avoid pushing to local remotes we can easily tell are not available,
 - to avoid ugly messages when a removable drive is not attached.
 -}
 pushTargets :: Assistant [Remote]
 pushTargets = liftIO . filterM (Remote.checkAvailable True)
 	=<< candidates <$> getDaemonStatus
  where
 	candidates = filter (not . Remote.readonly) . syncGitRemotes
--- a/Assistant/Threads/RemoteControl.hs
+++ b/Assistant/Threads/RemoteControl.hs
@ -1,121 +0,0 @@
 {- git-annex assistant communication with remotedaemon
 -
 - Copyright 2014 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Assistant.Threads.RemoteControl where
 import Assistant.Common
 import RemoteDaemon.Types
 import Config.Files
 import Utility.Batch
 import Utility.SimpleProtocol
 import Assistant.Alert
 import Assistant.Alert.Utility
 import Assistant.DaemonStatus
 import qualified Git
 import qualified Git.Types as Git
 import qualified Remote
 import qualified Types.Remote as Remote
 import Control.Concurrent
 import Control.Concurrent.Async
 import Network.URI
 import qualified Data.Map as M
 import qualified Data.Set as S
 remoteControlThread :: NamedThread
 remoteControlThread = namedThread "RemoteControl" $ do
 	program <- liftIO readProgramFile
 	(cmd, params) <- liftIO $ toBatchCommand
 		(program, [Param "remotedaemon"])
 	let p = proc cmd (toCommand params)
 	(Just toh, Just fromh, _, pid) <- liftIO $ createProcess p
 		{ std_in = CreatePipe
 		, std_out = CreatePipe
 		}
 	urimap <- liftIO . newMVar =<< liftAnnex getURIMap
 	controller <- asIO $ remoteControllerThread toh
 	responder <- asIO $ remoteResponderThread fromh urimap
 	-- run controller and responder until the remotedaemon dies
 	liftIO $ void $ tryNonAsync $ controller `concurrently` responder
 	debug ["remotedaemon exited"]
 	liftIO $ forceSuccessProcess p pid
 -- feed from the remoteControl channel into the remotedaemon
 remoteControllerThread :: Handle -> Assistant ()
 remoteControllerThread toh = do
 	clicker <- getAssistant remoteControl
 	forever $ do
 		msg <- liftIO $ readChan clicker
 		debug [show msg]
 		liftIO $ do
 			hPutStrLn toh $ unwords $ formatMessage msg
 			hFlush toh
 -- read status messages emitted by the remotedaemon and handle them
 remoteResponderThread :: Handle -> MVar (M.Map URI Remote) -> Assistant ()
 remoteResponderThread fromh urimap = go M.empty
  where
 	go syncalerts = do
 		l <- liftIO $ hGetLine fromh
 		debug [l]
 		case parseMessage l of
 			Just (CONNECTED uri) -> changeconnected S.insert uri
 			Just (DISCONNECTED uri) -> changeconnected S.delete uri
 			Just (SYNCING uri) -> withr uri $ \r ->
 				if M.member (Remote.uuid r) syncalerts
 					then go syncalerts
 					else do
 						i <- addAlert $ syncAlert [r]
 						go (M.insert (Remote.uuid r) i syncalerts)
 			Just (DONESYNCING uri status) -> withr uri $ \r ->
 				case M.lookup (Remote.uuid r) syncalerts of
 					Nothing -> cont
 					Just i -> do
 						let (succeeded, failed) = if status
 							then ([r], [])
 							else ([], [r])
 						updateAlertMap $ mergeAlert i $
 							syncResultAlert succeeded failed
 						go (M.delete (Remote.uuid r) syncalerts)
 			Just (WARNING (RemoteURI uri) msg) -> do
 				void $ addAlert $
 					warningAlert ("RemoteControl "++ show uri) msg
 				cont
 			Nothing -> do
 				debug ["protocol error from remotedaemon: ", l]
 				cont
 	  where
 		cont = go syncalerts
 		withr uri = withRemote uri urimap cont
 		changeconnected sm uri = withr uri $ \r -> do
 			changeCurrentlyConnected $ sm $ Remote.uuid r
 			cont
 getURIMap :: Annex (M.Map URI Remote)
 getURIMap = Remote.remoteMap' id (mkk . Git.location . Remote.repo)
  where
 	mkk (Git.Url u) = Just u
 	mkk _ = Nothing
 withRemote
 	:: RemoteURI
 	-> MVar (M.Map URI Remote)
 	-> Assistant a
 	-> (Remote -> Assistant a)
 	-> Assistant a
 withRemote (RemoteURI uri) remotemap noremote a = do
 	m <- liftIO $ readMVar remotemap
 	case M.lookup uri m of
 		Just r -> a r
 		Nothing -> do
 			{- Reload map, in case a new remote has been added. -}
 			m' <- liftAnnex getURIMap
 			void $ liftIO $ swapMVar remotemap $ m'
 			maybe noremote a (M.lookup uri m')
--- a/Assistant/Threads/SanityChecker.hs
+++ b/Assistant/Threads/SanityChecker.hs
@ -1,327 +0,0 @@
 {- git-annex assistant sanity checker
 -
 - Copyright 2012, 2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE CPP #-}
 module Assistant.Threads.SanityChecker (
 	sanityCheckerStartupThread,
 	sanityCheckerDailyThread,
 	sanityCheckerHourlyThread
 ) where
 import Assistant.Common
 import Assistant.DaemonStatus
 import Assistant.Alert
 import Assistant.Repair
 import Assistant.Drop
 import Assistant.Ssh
 import Assistant.TransferQueue
 import Assistant.Types.UrlRenderer
 import Assistant.Restart
 import qualified Annex.Branch
 import qualified Git
 import qualified Git.LsFiles
 import qualified Git.Command.Batch
 import qualified Git.Config
 import Utility.ThreadScheduler
 import qualified Assistant.Threads.Watcher as Watcher
 import Utility.Batch
 import Utility.NotificationBroadcaster
 import Config
 import Utility.HumanTime
 import Utility.Tense
 import Git.Repair
 import Git.Index
 import Assistant.Unused
 import Logs.Unused
 import Logs.Transfer
 import Config.Files
 import Types.Key (keyBackendName)
 import qualified Annex
 #ifdef WITH_WEBAPP
 import Assistant.WebApp.Types
 #endif
 #ifndef mingw32_HOST_OS
 import Utility.LogFile
 import Utility.DiskFree
 #endif
 import Data.Time.Clock.POSIX
 import qualified Data.Text as T
 {- This thread runs once at startup, and most other threads wait for it
 - to finish. (However, the webapp thread does not, to prevent the UI
 - being nonresponsive.) -}
 sanityCheckerStartupThread :: Maybe Duration -> NamedThread
 sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerStartup" $ do
 	{- Stale git locks can prevent commits from happening, etc. -}
 	void $ repairStaleGitLocks =<< liftAnnex gitRepo
 	{- A corrupt index file can prevent the assistant from working at
 	 - all, so detect and repair. -}
 	ifM (not <$> liftAnnex (inRepo checkIndexFast))
 		( do
 			notice ["corrupt index file found at startup; removing and restaging"]
 			liftAnnex $ inRepo $ nukeFile . indexFile
 			{- Normally the startup scan avoids re-staging files,
 			 - but with the index deleted, everything needs to be
 			 - restaged. -}
 			modifyDaemonStatus_ $ \s -> s { forceRestage = True }
 		, whenM (liftAnnex $ inRepo missingIndex) $ do
 			debug ["no index file; restaging"]
 			modifyDaemonStatus_ $ \s -> s { forceRestage = True }
 		)
 	{- If the git-annex index file is corrupt, it's ok to remove it;
 	 - the data from the git-annex branch will be used, and the index
 	 - will be automatically regenerated. -}
 	unlessM (liftAnnex $ Annex.Branch.withIndex $ inRepo $ Git.Repair.checkIndexFast) $ do
 		notice ["corrupt annex/index file found at startup; removing"]
 		liftAnnex $ liftIO . nukeFile =<< fromRepo gitAnnexIndex
 	{- Fix up ssh remotes set up by past versions of the assistant. -}
 	liftIO $ fixUpSshRemotes
 	{- Clean up old temp files. -}
 	void $ liftAnnex $ tryNonAsync $ do
 		cleanOldTmpMisc
 		cleanReallyOldTmp
 	{- If there's a startup delay, it's done here. -}
 	liftIO $ maybe noop (threadDelaySeconds . Seconds . fromIntegral . durationSeconds) startupdelay
 	{- Notify other threads that the startup sanity check is done. -}
 	status <- getDaemonStatus
 	liftIO $ sendNotification $ startupSanityCheckNotifier status
 {- This thread wakes up hourly for inxepensive frequent sanity checks. -}
 sanityCheckerHourlyThread :: NamedThread
 sanityCheckerHourlyThread = namedThread "SanityCheckerHourly" $ forever $ do
 	liftIO $ threadDelaySeconds $ Seconds oneHour
 	hourlyCheck
 {- This thread wakes up daily to make sure the tree is in good shape. -}
 sanityCheckerDailyThread :: UrlRenderer -> NamedThread
 sanityCheckerDailyThread urlrenderer = namedThread "SanityCheckerDaily" $ forever $ do
 	waitForNextCheck
 	debug ["starting sanity check"]
 	void $ alertWhile sanityCheckAlert go
 	debug ["sanity check complete"]
  where
 	go = do
 		modifyDaemonStatus_ $ \s -> s { sanityCheckRunning = True }
 		now <- liftIO getPOSIXTime -- before check started
 		r <- either showerr return 
 			=<< (tryIO . batch) <~> dailyCheck urlrenderer
 		modifyDaemonStatus_ $ \s -> s
 			{ sanityCheckRunning = False
 			, lastSanityCheck = Just now
 			}
 		return r
 	showerr e = do
 		liftAnnex $ warning $ show e
 		return False
 {- Only run one check per day, from the time of the last check. -}
 waitForNextCheck :: Assistant ()
 waitForNextCheck = do
 	v <- lastSanityCheck <$> getDaemonStatus
 	now <- liftIO getPOSIXTime
 	liftIO $ threadDelaySeconds $ Seconds $ calcdelay now v
  where
 	calcdelay _ Nothing = oneDay
 	calcdelay now (Just lastcheck)
 		| lastcheck < now = max oneDay $
 			oneDay - truncate (now - lastcheck)
 		| otherwise = oneDay
 {- It's important to stay out of the Annex monad as much as possible while
 - running potentially expensive parts of this check, since remaining in it
 - will block the watcher. -}
 dailyCheck :: UrlRenderer -> Assistant Bool
 dailyCheck urlrenderer = do
 	checkRepoExists
 	g <- liftAnnex gitRepo
 	batchmaker <- liftIO getBatchCommandMaker
 	-- Find old unstaged symlinks, and add them to git.
 	(unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo False ["."] g
 	now <- liftIO getPOSIXTime
 	forM_ unstaged $ \file -> do
 		ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file
 		case ms of
 			Just s	| toonew (statusChangeTime s) now -> noop
 				| isSymbolicLink s -> addsymlink file ms
 			_ -> noop
 	liftIO $ void cleanup
 	{- Allow git-gc to run once per day. More frequent gc is avoided
 	 - by default to avoid slowing things down. Only run repacks when 100x
 	 - the usual number of loose objects are present; we tend
 	 - to have a lot of small objects and they should not be a
 	 - significant size. -}
 	when (Git.Config.getMaybe "gc.auto" g == Just "0") $
 		liftIO $ void $ Git.Command.Batch.run batchmaker
 			[ Param "-c", Param "gc.auto=670000"
 			, Param "gc"
 			, Param "--auto"
 			] g
 	{- Check if the unused files found last time have been dealt with. -}
 	checkOldUnused urlrenderer
 	{- Run git-annex unused once per day. This is run as a separate
 	 - process to stay out of the annex monad and so it can run as a
 	 - batch job. -}
 	program <- liftIO readProgramFile
 	let (program', params') = batchmaker (program, [Param "unused"])
 	void $ liftIO $ boolSystem program' params'
 	{- Invalidate unused keys cache, and queue transfers of all unused
 	 - keys, or if no transfers are called for, drop them. -}
 	unused <- liftAnnex unusedKeys'
 	void $ liftAnnex $ setUnusedKeys unused
 	forM_ unused $ \k -> do
 		unlessM (queueTransfers "unused" Later k Nothing Upload) $
 			handleDrops "unused" True k Nothing Nothing
 	return True
  where
 	toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime)
 	slop = fromIntegral tenMinutes
 	insanity msg = do
 		liftAnnex $ warning msg
 		void $ addAlert $ sanityCheckFixAlert msg
 	addsymlink file s = do
 		isdirect <- liftAnnex isDirect
 		Watcher.runHandler (Watcher.onAddSymlink isdirect) file s
 		insanity $ "found unstaged symlink: " ++ file
 hourlyCheck :: Assistant ()
 hourlyCheck = do
 	checkRepoExists
 #ifndef mingw32_HOST_OS
 	checkLogSize 0
 #else
 	noop
 #endif
 #ifndef mingw32_HOST_OS
 {- Rotate logs once when total log file size is > 2 mb.
 -
 - If total log size is larger than the amount of free disk space,
 - continue rotating logs until size is < 2 mb, even if this
 - results in immediately losing the just logged data.
 -}
 checkLogSize :: Int -> Assistant ()
 checkLogSize n = do
 	f <- liftAnnex $ fromRepo gitAnnexLogFile
 	logs <- liftIO $ listLogs f
 	totalsize <- liftIO $ sum <$> mapM getFileSize logs
 	when (totalsize > 2 * oneMegabyte) $ do
 		notice ["Rotated logs due to size:", show totalsize]
 		liftIO $ openLog f >>= handleToFd >>= redirLog
 		when (n < maxLogs + 1) $ do
 			df <- liftIO $ getDiskFree $ takeDirectory f
 			case df of
 				Just free
 					| free < fromIntegral totalsize ->
 						checkLogSize (n + 1)
 				_ -> noop
  where
 	oneMegabyte :: Integer
 	oneMegabyte = 1000000
 #endif
 oneHour :: Int
 oneHour = 60 * 60
 oneDay :: Int
 oneDay = 24 * oneHour
 {- If annex.expireunused is set, find any keys that have lingered unused
 - for the specified duration, and remove them.
 -
 - Otherwise, check to see if unused keys are piling up, and let the user
 - know. -}
 checkOldUnused :: UrlRenderer -> Assistant ()
 checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGitConfig
  where
 	go (Just Nothing) = noop
 	go (Just (Just expireunused)) = expireUnused (Just expireunused)
 	go Nothing = maybe noop prompt =<< describeUnusedWhenBig
 	prompt msg = 
 #ifdef WITH_WEBAPP
 		do
 			button <- mkAlertButton True (T.pack "Configure") urlrenderer ConfigUnusedR
 			void $ addAlert $ unusedFilesAlert [button] $ T.unpack $ renderTense Present msg
 #else
 		debug [show $ renderTense Past msg]
 #endif
 {- Files may be left in misctmp by eg, an interrupted add of files
 - by the assistant, which hard links files to there as part of lockdown
 - checks. Delete these files if they're more than a day old.
 -
 - Note that this is not safe to run after the Watcher starts up, since it
 - will create such files, and due to hard linking they may have old
 - mtimes. So, this should only be called from the
 - sanityCheckerStartupThread, which runs before the Watcher starts up.
 -
 - Also, if a git-annex add is being run at the same time the assistant
 - starts up, its tmp files could be deleted. However, the watcher will
 - come along and add everything once it starts up anyway, so at worst
 - this would make the git-annex add fail unexpectedly.
 -}
 cleanOldTmpMisc :: Annex ()
 cleanOldTmpMisc = do
 	now <- liftIO getPOSIXTime
 	let oldenough = now - (60 * 60 * 24)
 	tmp <- fromRepo gitAnnexTmpMiscDir
 	liftIO $ mapM_ (cleanOld (<= oldenough)) =<< dirContentsRecursive tmp
 {- While .git/annex/tmp is now only used for storing partially transferred
 - objects, older versions of git-annex used it for misctemp. Clean up any
 - files that might be left from that, by looking for files whose names
 - cannot be the key of an annexed object. Only delete files older than
 - 1 week old.
 -
 - Also, some remotes such as rsync may use this temp directory for storing
 - eg, encrypted objects that are being transferred. So, delete old
 - objects that use a GPGHMAC backend.
 -}
 cleanReallyOldTmp :: Annex ()
 cleanReallyOldTmp = do
 	now <- liftIO getPOSIXTime
 	let oldenough = now - (60 * 60 * 24 * 7)
 	tmp <- fromRepo gitAnnexTmpObjectDir
 	liftIO $ mapM_ (cleanjunk (<= oldenough)) =<< dirContentsRecursive tmp
  where
 	cleanjunk check f = case fileKey (takeFileName f) of
 		Nothing -> cleanOld check f
 		Just k
 			| "GPGHMAC" `isPrefixOf` keyBackendName k ->
 				cleanOld check f
 			| otherwise -> noop
 cleanOld :: (POSIXTime -> Bool) -> FilePath -> IO ()
 cleanOld check f = go =<< catchMaybeIO getmtime
  where
 	getmtime = realToFrac . modificationTime <$> getSymbolicLinkStatus f
 	go (Just mtime) | check mtime = nukeFile f
 	go _ = noop
 checkRepoExists :: Assistant ()
 checkRepoExists = do
 	g <- liftAnnex gitRepo
 	liftIO $ unlessM (doesDirectoryExist $ Git.repoPath g) $
 		terminateSelf
--- a/Assistant/Threads/TransferPoller.hs
+++ b/Assistant/Threads/TransferPoller.hs
@ -1,55 +0,0 @@
 {- git-annex assistant transfer polling thread
 -
 - Copyright 2012 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Assistant.Threads.TransferPoller where
 import Assistant.Common
 import Assistant.DaemonStatus
 import Logs.Transfer
 import Utility.NotificationBroadcaster
 import qualified Assistant.Threads.TransferWatcher as TransferWatcher
 import Control.Concurrent
 import qualified Data.Map as M
 {- This thread polls the status of ongoing transfers, determining how much
 - of each transfer is complete. -}
 transferPollerThread :: NamedThread
 transferPollerThread = namedThread "TransferPoller" $ do
 	g <- liftAnnex gitRepo
 	tn <- liftIO . newNotificationHandle True =<<
 		transferNotifier <$> getDaemonStatus
 	forever $ do
 		liftIO $ threadDelay 500000 -- 0.5 seconds
 		ts <- currentTransfers <$> getDaemonStatus
 		if M.null ts
 			-- block until transfers running
 			then liftIO $ waitNotification tn
 			else mapM_ (poll g) $ M.toList ts
  where
 	poll g (t, info)
 		{- Downloads are polled by checking the size of the
 		 - temp file being used for the transfer. -}
 		| transferDirection t == Download = do
 			let f = gitAnnexTmpObjectLocation (transferKey t) g
 			sz <- liftIO $ catchMaybeIO $ getFileSize f
 			newsize t info sz
 		{- Uploads don't need to be polled for when the TransferWatcher
 		 - thread can track file modifications. -}
 		| TransferWatcher.watchesTransferSize = noop
 		{- Otherwise, this code polls the upload progress
 		 - by reading the transfer info file. -}
 		| otherwise = do
 			let f = transferFile t g
 			mi <- liftIO $ catchDefaultIO Nothing $
 				readTransferInfoFile Nothing f
 			maybe noop (newsize t info . bytesComplete) mi
 	newsize t info sz
 		| bytesComplete info /= sz && isJust sz =
 			alterTransferInfo t $ \i -> i { bytesComplete = sz }
 		| otherwise = noop
--- a/Assistant/Threads/TransferScanner.hs
+++ b/Assistant/Threads/TransferScanner.hs
@ -1,182 +0,0 @@
 {- git-annex assistant thread to scan remotes to find needed transfers
 -
 - Copyright 2012 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Assistant.Threads.TransferScanner where
 import Assistant.Common
 import Assistant.Types.ScanRemotes
 import Assistant.ScanRemotes
 import Assistant.TransferQueue
 import Assistant.DaemonStatus
 import Assistant.Drop
 import Assistant.Sync
 import Assistant.DeleteRemote
 import Assistant.Types.UrlRenderer
 import Logs.Transfer
 import Logs.Location
 import Logs.Group
 import qualified Remote
 import qualified Types.Remote as Remote
 import Utility.ThreadScheduler
 import Utility.NotificationBroadcaster
 import Utility.Batch
 import qualified Git.LsFiles as LsFiles
 import qualified Backend
 import Annex.Content
 import Annex.Wanted
 import CmdLine.Action
 import qualified Data.Set as S
 {- This thread waits until a remote needs to be scanned, to find transfers
 - that need to be made, to keep data in sync.
 -}
 transferScannerThread :: UrlRenderer -> NamedThread
 transferScannerThread urlrenderer = namedThread "TransferScanner" $ do
 	startupScan
 	go S.empty
  where
 	go scanned = do
 		scanrunning False
 		liftIO $ threadDelaySeconds (Seconds 2)
 		(rs, infos) <- unzip <$> getScanRemote
 		scanrunning True
 		if any fullScan infos || any (`S.notMember` scanned) rs
 			then do
 				expensiveScan urlrenderer rs
 				go $ scanned `S.union` S.fromList rs
 			else do
 				mapM_ failedTransferScan rs
 				go scanned
 	scanrunning b = do
 		ds <- modifyDaemonStatus $ \s -> 
 			(s { transferScanRunning = b }, s)
 		liftIO $ sendNotification $ transferNotifier ds
 	{- All git remotes are synced, and all available remotes
 	 - are scanned in full on startup, for multiple reasons, including:
 	 -
 	 - * This may be the first run, and there may be remotes
 	 -   already in place, that need to be synced.
 	 - * Changes may have been made last time we run, but remotes were
 	 -   not available to be synced with.
 	 - * Changes may have been made to remotes while we were down.
 	 - * We may have run before, and scanned a remote, but
 	 -   only been in a subdirectory of the git remote, and so
 	 -   not synced it all.
 	 - * We may have run before, and had transfers queued,
 	 -   and then the system (or us) crashed, and that info was
 	 -   lost.
 	 - * A remote may be in the unwanted group, and this is a chance
 	 -   to determine if the remote has been emptied.
 	 -}
 	startupScan = do
 		reconnectRemotes True =<< syncGitRemotes <$> getDaemonStatus
 		addScanRemotes True =<< syncDataRemotes <$> getDaemonStatus
 {- This is a cheap scan for failed transfers involving a remote. -}
 failedTransferScan :: Remote -> Assistant ()
 failedTransferScan r = do
 	failed <- liftAnnex $ clearFailedTransfers (Remote.uuid r)
 	mapM_ retry failed
  where
 	retry (t, info)
 		| transferDirection t == Download =
 			{- Check if the remote still has the key.
 			 - If not, relies on the expensiveScan to
 			 - get it queued from some other remote. -}
 			whenM (liftAnnex $ remoteHas r $ transferKey t) $
 				requeue t info
 		| otherwise =
 			{- The Transferrer checks when uploading
 			 - that the remote doesn't already have the
 			 - key, so it's not redundantly checked here. -}
 			requeue t info
 	requeue t info = queueTransferWhenSmall "retrying failed transfer" (associatedFile info) t r
 {- This is a expensive scan through the full git work tree, finding
 - files to transfer. The scan is blocked when the transfer queue gets
 - too large. 
 -
 - This also finds files that are present either here or on a remote
 - but that are not preferred content, and drops them. Searching for files
 - to drop is done concurrently with the scan for transfers.
 -
 - TODO: It would be better to first drop as much as we can, before
 - transferring much, to minimise disk use.
 - 
 - During the scan, we'll also check if any unwanted repositories are empty,
 - and can be removed. While unrelated, this is a cheap place to do it,
 - since we need to look at the locations of all keys anyway.
 -}
 expensiveScan :: UrlRenderer -> [Remote] -> Assistant ()
 expensiveScan urlrenderer rs = batch <~> do
 	debug ["starting scan of", show visiblers]
 	let us = map Remote.uuid rs
 	mapM_ (liftAnnex . clearFailedTransfers) us
 	unwantedrs <- liftAnnex $ S.fromList
 		<$> filterM inUnwantedGroup us
 	g <- liftAnnex gitRepo
 	(files, cleanup) <- liftIO $ LsFiles.inRepo [] g
 	removablers <- scan unwantedrs files
 	void $ liftIO cleanup
 	debug ["finished scan of", show visiblers]
 	remove <- asIO1 $ removableRemote urlrenderer
 	liftIO $ mapM_ (void . tryNonAsync . remove) $ S.toList removablers
  where
 	visiblers = let rs' = filter (not . Remote.readonly) rs
 		in if null rs' then rs else rs'
 	scan unwanted [] = return unwanted
 	scan unwanted (f:fs) = do
 		(unwanted', ts) <- maybe
 			(return (unwanted, []))
 			(findtransfers f unwanted)
 				=<< liftAnnex (Backend.lookupFile f)
 		mapM_ (enqueue f) ts
 		scan unwanted' fs
 	enqueue f (r, t) =
 		queueTransferWhenSmall "expensive scan found missing object"
 			(Just f) t r
 	findtransfers f unwanted key = do
 		{- The syncable remotes may have changed since this
 		 - scan began. -}
 		syncrs <- syncDataRemotes <$> getDaemonStatus
 		locs <- liftAnnex $ loggedLocations key
 		present <- liftAnnex $ inAnnex key
 		liftAnnex $ handleDropsFrom locs syncrs
 			"expensive scan found too many copies of object"
 			present key (Just f) Nothing callCommandAction
 		liftAnnex $ do
 			let slocs = S.fromList locs
 			let use a = return $ mapMaybe (a key slocs) syncrs
 			ts <- if present
 				then filterM (wantSend True (Just key) (Just f) . Remote.uuid . fst)
 					=<< use (genTransfer Upload False)
 				else ifM (wantGet True (Just key) (Just f))
 					( use (genTransfer Download True) , return [] )
 			let unwanted' = S.difference unwanted slocs
 			return (unwanted', ts)
 genTransfer :: Direction -> Bool -> Key -> S.Set UUID -> Remote -> Maybe (Remote, Transfer)
 genTransfer direction want key slocs r
 	| direction == Upload && Remote.readonly r = Nothing
 	| S.member (Remote.uuid r) slocs == want = Just
 		(r, Transfer direction (Remote.uuid r) key)
 	| otherwise = Nothing
 remoteHas :: Remote -> Key -> Annex Bool
 remoteHas r key = elem
 	<$> pure (Remote.uuid r)
 	<*> loggedLocations key
--- a/Assistant/Threads/TransferWatcher.hs
+++ b/Assistant/Threads/TransferWatcher.hs
@ -1,104 +0,0 @@
 {- git-annex assistant transfer watching thread
 -
 - Copyright 2012 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Assistant.Threads.TransferWatcher where
 import Assistant.Common
 import Assistant.DaemonStatus
 import Assistant.TransferSlots
 import Logs.Transfer
 import Utility.DirWatcher
 import Utility.DirWatcher.Types
 import qualified Remote
 import Control.Concurrent
 import qualified Data.Map as M
 {- This thread watches for changes to the gitAnnexTransferDir,
 - and updates the DaemonStatus's map of ongoing transfers. -}
 transferWatcherThread :: NamedThread
 transferWatcherThread = namedThread "TransferWatcher" $ do
 	dir <- liftAnnex $ gitAnnexTransferDir <$> gitRepo
 	liftIO $ createDirectoryIfMissing True dir
 	let hook a = Just <$> asIO2 (runHandler a)
 	addhook <- hook onAdd
 	delhook <- hook onDel
 	modifyhook <- hook onModify
 	errhook <- hook onErr
 	let hooks = mkWatchHooks
 		{ addHook = addhook
 		, delHook = delhook
 		, modifyHook = modifyhook
 		, errHook = errhook
 		}
 	void $ liftIO $ watchDir dir (const False) True hooks id
 	debug ["watching for transfers"]
 type Handler = FilePath -> Assistant ()
 {- Runs an action handler.
 -
 - Exceptions are ignored, otherwise a whole thread could be crashed.
 -}
 runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
 runHandler handler file _filestatus =
 	either (liftIO . print) (const noop) =<< tryIO <~> handler file
 {- Called when there's an error with inotify. -}
 onErr :: Handler
 onErr = error
 {- Called when a new transfer information file is written. -}
 onAdd :: Handler
 onAdd file = case parseTransferFile file of
 	Nothing -> noop
 	Just t -> go t =<< liftAnnex (checkTransfer t)
  where
 	go _ Nothing = noop -- transfer already finished
 	go t (Just info) = do
 		debug [ "transfer starting:", describeTransfer t info ]
 		r <- liftAnnex $ Remote.remoteFromUUID $ transferUUID t
 		updateTransferInfo t info { transferRemote = r }
 {- Called when a transfer information file is updated.
 -
 - The only thing that should change in the transfer info is the
 - bytesComplete, so that's the only thing updated in the DaemonStatus. -}
 onModify :: Handler
 onModify file = case parseTransferFile file of
 	Nothing -> noop
 	Just t -> go t =<< liftIO (readTransferInfoFile Nothing file)
  where
 	go _ Nothing = noop
 	go t (Just newinfo) = alterTransferInfo t $
 		\i -> i { bytesComplete = bytesComplete newinfo }
 {- This thread can only watch transfer sizes when the DirWatcher supports
 - tracking modificatons to files. -}
 watchesTransferSize :: Bool
 watchesTransferSize = modifyTracked
 {- Called when a transfer information file is removed. -}
 onDel :: Handler
 onDel file = case parseTransferFile file of
 	Nothing -> noop
 	Just t -> do
 		debug [ "transfer finishing:", show t]
 		minfo <- removeTransfer t
 		-- Run transfer hook.
 		m <- transferHook <$> getDaemonStatus
 		maybe noop (\hook -> void $ liftIO $ forkIO $ hook t)
 			(M.lookup (transferKey t) m)
 		finished <- asIO2 finishedTransfer
 		void $ liftIO $ forkIO $ do
 			{- XXX race workaround delay. The location
 			 - log needs to be updated before finishedTransfer
 			 - runs. -}
 			threadDelay 10000000 -- 10 seconds
 			finished t minfo
--- a/Assistant/Threads/Transferrer.hs
+++ b/Assistant/Threads/Transferrer.hs
@ -1,27 +0,0 @@
 {- git-annex assistant data transferrer thread
 -
 - Copyright 2012 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 module Assistant.Threads.Transferrer where
 import Assistant.Common
 import Assistant.TransferQueue
 import Assistant.TransferSlots
 import Logs.Transfer
 import Config.Files
 import Utility.Batch
 {- Dispatches transfers from the queue. -}
 transfererThread :: NamedThread
 transfererThread = namedThread "Transferrer" $ do
 	program <- liftIO readProgramFile
 	batchmaker <- liftIO getBatchCommandMaker
 	forever $ inTransferSlot program batchmaker $
 		maybe (return Nothing) (uncurry genTransfer)
 			=<< getNextTransfer notrunning
  where
 	{- Skip transfers that are already running. -}
 	notrunning = isNothing . startedTime
--- a/Assistant/Threads/UpgradeWatcher.hs
+++ b/Assistant/Threads/UpgradeWatcher.hs
@ -1,110 +0,0 @@
 {- git-annex assistant thread to detect when git-annex is upgraded
 -
 - Copyright 2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE CPP #-}
 module Assistant.Threads.UpgradeWatcher (
 	upgradeWatcherThread
 ) where
 import Assistant.Common
 import Assistant.Upgrade
 import Utility.DirWatcher
 import Utility.DirWatcher.Types
 import Utility.ThreadScheduler
 import Assistant.Types.UrlRenderer
 import Assistant.Alert
 import Assistant.DaemonStatus
 #ifdef WITH_WEBAPP
 import Assistant.WebApp.Types
 import qualified Build.SysConfig
 #endif
 import Control.Concurrent.MVar
 import qualified Data.Text as T
 data WatcherState = InStartupScan | Started | Upgrading
 	deriving (Eq)
 upgradeWatcherThread :: UrlRenderer -> NamedThread
 upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do
 	whenM (liftIO checkSuccessfulUpgrade) $
 		showSuccessfulUpgrade urlrenderer
 	go =<< liftIO upgradeFlagFile
  where
 	go Nothing = debug [ "cannot determine program path" ]
 	go (Just flagfile) = do
 		mvar <- liftIO $ newMVar InStartupScan
 		changed <- Just <$> asIO2 (changedFile urlrenderer mvar flagfile)
 		let hooks = mkWatchHooks
 			{ addHook = changed
 			, delHook = changed
 			, addSymlinkHook = changed
 			, modifyHook = changed
 			, delDirHook = changed
 			}
 		let dir = parentDir flagfile
 		let depth = length (splitPath dir) + 1
 		let nosubdirs f = length (splitPath f) == depth
 		void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar)
 	-- Ignore bogus events generated during the startup scan.
 	-- We ask the watcher to not generate them, but just to be safe..
 	startup mvar scanner = do
 		r <- scanner
 		void $ swapMVar mvar Started
 		return r
 changedFile :: UrlRenderer -> MVar WatcherState -> FilePath -> FilePath -> Maybe FileStatus -> Assistant ()
 changedFile urlrenderer mvar flagfile file _status
 	| flagfile /= file = noop
 	| otherwise = do
 		state <- liftIO $ readMVar mvar
 		when (state == Started) $ do
 			setstate Upgrading
 			ifM (liftIO upgradeSanityCheck)
 				( handleUpgrade urlrenderer
 				, do
 					debug ["new version failed sanity check; not using"]
 					setstate Started
 				)
  where
 	setstate = void . liftIO . swapMVar mvar
 handleUpgrade :: UrlRenderer -> Assistant ()
 handleUpgrade urlrenderer = do
 	-- Wait 2 minutes for any final upgrade changes to settle.
 	-- (For example, other associated files may be being put into
 	-- place.) Not needed when using a distribution bundle, because
 	-- in that case git-annex handles the upgrade in a non-racy way.
 	liftIO $ unlessM usingDistribution $
 		threadDelaySeconds (Seconds 120)
 	ifM autoUpgradeEnabled
 		( do
 			debug ["starting automatic upgrade"]
 			unattendedUpgrade
 #ifdef WITH_WEBAPP
 		, do
 			button <- mkAlertButton True (T.pack "Finish Upgrade") urlrenderer ConfigFinishUpgradeR
 			void $ addAlert $ upgradeReadyAlert button
 #else
 		, noop
 #endif
 		)
 showSuccessfulUpgrade :: UrlRenderer -> Assistant ()
 showSuccessfulUpgrade urlrenderer = do
 #ifdef WITH_WEBAPP
 	button <- ifM autoUpgradeEnabled 
 		( pure Nothing
 		, Just <$> mkAlertButton True
 			(T.pack "Enable Automatic Upgrades")
 			urlrenderer ConfigEnableAutomaticUpgradeR
 		)
 	void $ addAlert $ upgradeFinishedAlert button Build.SysConfig.packageversion
 #else
 	noop
 #endif
--- a/Assistant/Threads/Upgrader.hs
+++ b/Assistant/Threads/Upgrader.hs
@ -1,85 +0,0 @@
 {- git-annex assistant thread to detect when upgrade is available
 -
 - Copyright 2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE CPP #-}
 module Assistant.Threads.Upgrader (
 	upgraderThread
 ) where
 import Assistant.Common
 import Assistant.Upgrade
 import Assistant.Types.UrlRenderer
 import Assistant.DaemonStatus
 import Assistant.Alert
 import Utility.NotificationBroadcaster
 import qualified Annex
 import qualified Build.SysConfig
 import qualified Git.Version
 import Types.Distribution
 #ifdef WITH_WEBAPP
 import Assistant.WebApp.Types
 #endif
 import Data.Time.Clock
 import qualified Data.Text as T
 upgraderThread :: UrlRenderer -> NamedThread
 upgraderThread urlrenderer = namedThread "Upgrader" $
 	when (isJust Build.SysConfig.upgradelocation) $ do
 		{- Check for upgrade on startup, unless it was just
 		 - upgraded. -}
 		unlessM (liftIO checkSuccessfulUpgrade) $
 			checkUpgrade urlrenderer
 		h <- liftIO . newNotificationHandle False . networkConnectedNotifier =<< getDaemonStatus
 		go h =<< liftIO getCurrentTime
  where
 	{- Wait for a network connection event. Then see if it's been
 	 - half a day since the last upgrade check. If so, proceed with
 	 - check. -}
 	go h lastchecked = do
 		liftIO $ waitNotification h
 		autoupgrade <- liftAnnex $ annexAutoUpgrade <$> Annex.getGitConfig
 		if autoupgrade == NoAutoUpgrade
 			then go h lastchecked
 			else do
 				now <- liftIO getCurrentTime
 				if diffUTCTime now lastchecked > halfday
 					then do
 						checkUpgrade urlrenderer
 						go h =<< liftIO getCurrentTime
 					else go h lastchecked
 	halfday = 12 * 60 * 60
 checkUpgrade :: UrlRenderer -> Assistant ()
 checkUpgrade urlrenderer = do
 	debug [ "Checking if an upgrade is available." ]
 	go =<< downloadDistributionInfo
  where
 	go Nothing = debug [ "Failed to check if upgrade is available." ]
 	go (Just d) = do
 		let installed = Git.Version.normalize Build.SysConfig.packageversion
 		let avail = Git.Version.normalize $ distributionVersion d
 		let old = Git.Version.normalize <$> distributionUrgentUpgrade d
 		if Just installed <= old
 			then canUpgrade High urlrenderer d
 			else if installed < avail
 				then canUpgrade Low urlrenderer d
 				else debug [ "No new version found." ]
 canUpgrade :: AlertPriority -> UrlRenderer -> GitAnnexDistribution -> Assistant ()
 canUpgrade urgency urlrenderer d = ifM autoUpgradeEnabled
 	( startDistributionDownload d
 	, do
 #ifdef WITH_WEBAPP
 		button <- mkAlertButton True (T.pack "Upgrade") urlrenderer (ConfigStartUpgradeR d)
 		void $ addAlert (canUpgradeAlert urgency (distributionVersion d) button)
 #else
 		noop
 #endif
 	)
--- a/Assistant/Threads/Watcher.hs
+++ b/Assistant/Threads/Watcher.hs
@ -1,368 +0,0 @@
 {- git-annex assistant tree watcher
 -
 - Copyright 2012-2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}
 {-# LANGUAGE DeriveDataTypeable, CPP #-}
 module Assistant.Threads.Watcher (
 	watchThread,
 	WatcherControl(..),
 	checkCanWatch,
 	needLsof,
 	onAddSymlink,
 	runHandler,
 ) where
 import Assistant.Common
 import Assistant.DaemonStatus
 import Assistant.Changes
 import Assistant.Types.Changes
 import Assistant.Alert
 import Utility.DirWatcher
 import Utility.DirWatcher.Types
 import qualified Annex
 import qualified Annex.Queue
 import qualified Git
 import qualified Git.UpdateIndex
 import qualified Git.LsFiles as LsFiles
 import qualified Backend
 import Annex.Direct
 import Annex.Content.Direct
 import Annex.CatFile
 import Annex.CheckIgnore
 import Annex.Link
 import Annex.FileMatcher
 import Types.FileMatcher
 import Annex.ReplaceFile
 import Git.Types
 import Config
 import Utility.ThreadScheduler
 #ifndef mingw32_HOST_OS
 import qualified Utility.Lsof as Lsof
 #endif
 import Data.Bits.Utils
 import Data.Typeable
 import qualified Data.ByteString.Lazy as L
 import qualified Control.Exception as E
 import Data.Time.Clock
 checkCanWatch :: Annex ()
 checkCanWatch
 	| canWatch = do
 #ifndef mingw32_HOST_OS
 		liftIO Lsof.setup
 		unlessM (liftIO (inPath "lsof") <||> Annex.getState Annex.force)
 			needLsof
 #else
 		noop
 #endif
 	| otherwise = error "watch mode is not available on this system"
 needLsof :: Annex ()
 needLsof = error $ unlines
 	[ "The lsof command is needed for watch mode to be safe, and is not in PATH."
 	, "To override lsof checks to ensure that files are not open for writing"
 	, "when added to the annex, you can use --force"
 	, "Be warned: This can corrupt data in the annex, and make fsck complain."
 	]
 {- A special exception that can be thrown to pause or resume the watcher. -}
 data WatcherControl = PauseWatcher | ResumeWatcher
 	deriving (Show, Eq, Typeable)
 instance E.Exception WatcherControl
 watchThread :: NamedThread
 watchThread = namedThread "Watcher" $
 	ifM (liftAnnex $ annexAutoCommit <$> Annex.getGitConfig)
 		( runWatcher
 		, waitFor ResumeWatcher runWatcher
 		)
 runWatcher :: Assistant ()
 runWatcher = do
 	startup <- asIO1 startupScan
 	matcher <- liftAnnex largeFilesMatcher
 	direct <- liftAnnex isDirect
 	symlinkssupported <- liftAnnex $ coreSymlinks <$> Annex.getGitConfig
 	addhook <- hook $ if direct
 		then onAddDirect symlinkssupported matcher
 		else onAdd matcher
 	delhook <- hook onDel
 	addsymlinkhook <- hook $ onAddSymlink direct
 	deldirhook <- hook onDelDir
 	errhook <- hook onErr
 	let hooks = mkWatchHooks
 		{ addHook = addhook
 		, delHook = delhook
 		, addSymlinkHook = addsymlinkhook
 		, delDirHook = deldirhook
 		, errHook = errhook
 		}
 	scanevents <- liftAnnex $ annexStartupScan <$> Annex.getGitConfig
 	h <- liftIO $ watchDir "." ignored scanevents hooks startup
 	debug [ "watching", "."]
 	{- Let the DirWatcher thread run until signalled to pause it,
 	 - then wait for a resume signal, and restart. -}
 	waitFor PauseWatcher $ do
 		liftIO $ stopWatchDir h
 		waitFor ResumeWatcher runWatcher
  where
 	hook a = Just <$> asIO2 (runHandler a)
 waitFor :: WatcherControl -> Assistant () -> Assistant ()
 waitFor sig next = do
 	r <- liftIO (E.try pause :: IO (Either E.SomeException ()))
 	case r of
 		Left e -> case E.fromException e of
 			Just s
 				| s == sig -> next
 			_ -> noop
 		_ -> noop
  where
 	pause = runEvery (Seconds 86400) noop
 {- Initial scartup scan. The action should return once the scan is complete. -}
 startupScan :: IO a -> Assistant a
 startupScan scanner = do
 	liftAnnex $ showAction "scanning"
 	alertWhile' startupScanAlert $ do
 		r <- liftIO scanner
 		-- Notice any files that were deleted before
 		-- watching was started.
 		top <- liftAnnex $ fromRepo Git.repoPath
 		(fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [top]
 		forM_ fs $ \f -> do
 			liftAnnex $ onDel' f
 			maybe noop recordChange =<< madeChange f RmChange
 		void $ liftIO cleanup
 		liftAnnex $ showAction "started"
 		liftIO $ putStrLn ""
 		modifyDaemonStatus_ $ \s -> s { scanComplete = True }
 		-- Ensure that the Committer sees any changes
 		-- that it did not process, and acts on them now that
 		-- the scan is complete.
 		refillChanges =<< getAnyChanges
 		return (True, r)
 {- Hardcoded ignores, passed to the DirWatcher so it can avoid looking
 - at the entire .git directory. Does not include .gitignores. -}
 ignored :: FilePath -> Bool
 ignored = ig . takeFileName
  where
 	ig ".git" = True
 	ig ".gitignore" = True
 	ig ".gitattributes" = True
 #ifdef darwin_HOST_OS
 	ig ".DS_Store" = True
 #endif
 	ig _ = False
 unlessIgnored :: FilePath -> Assistant (Maybe Change) -> Assistant (Maybe Change)
 unlessIgnored file a = ifM (liftAnnex $ checkIgnored file)
 	( noChange
 	, a
 	)
 type Handler = FilePath -> Maybe FileStatus -> Assistant (Maybe Change)
 {- Runs an action handler, and if there was a change, adds it to the ChangeChan.
 -
 - Exceptions are ignored, otherwise a whole watcher thread could be crashed.
 -}
 runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
 runHandler handler file filestatus = void $ do
 	r <- tryIO <~> handler (normalize file) filestatus
 	case r of
 		Left e -> liftIO $ warningIO $ show e
 		Right Nothing -> noop
 		Right (Just change) -> do
 			-- Just in case the commit thread is not
 			-- flushing the queue fast enough.
 			liftAnnex Annex.Queue.flushWhenFull
 			recordChange change
  where
 	normalize f
 		| "./" `isPrefixOf` file = drop 2 f
 		| otherwise = f
 {- Small files are added to git as-is, while large ones go into the annex. -}
 add :: FileMatcher Annex -> FilePath -> Assistant (Maybe Change)
 add bigfilematcher file = ifM (liftAnnex $ checkFileMatcher bigfilematcher file)
 	( pendingAddChange file
 	, do
 		liftAnnex $ Annex.Queue.addCommand "add"
 			[Params "--force --"] [file]
 		madeChange file AddFileChange
 	)
 onAdd :: FileMatcher Annex -> Handler
 onAdd matcher file filestatus
 	| maybe False isRegularFile filestatus =
 		unlessIgnored file $
 			add matcher file
 	| otherwise = noChange
 shouldRestage :: DaemonStatus -> Bool
 shouldRestage ds = scanComplete ds || forceRestage ds
 {- In direct mode, add events are received for both new files, and
 - modified existing files.
 -}
 onAddDirect :: Bool -> FileMatcher Annex -> Handler
 onAddDirect symlinkssupported matcher file fs = do
 	v <- liftAnnex $ catKeyFile file
 	case (v, fs) of
 		(Just key, Just filestatus) ->
 			ifM (liftAnnex $ sameFileStatus key file filestatus)
 				{- It's possible to get an add event for
 				 - an existing file that is not
 				 - really modified, but it might have
 				 - just been deleted and been put back,
 				 - so it symlink is restaged to make sure. -}
 				( ifM (shouldRestage <$> getDaemonStatus)
 					( do
 						link <- liftAnnex $ calcRepo $ gitAnnexLink file key
 						addLink file link (Just key)
 					, noChange
 					)
 				, guardSymlinkStandin (Just key) $ do
 					debug ["changed direct", file]
 					liftAnnex $ changedDirect key file
 					add matcher file
 				)
 		_ -> unlessIgnored file $
 			guardSymlinkStandin Nothing $ do
 				debug ["add direct", file]
 				add matcher file
  where
 	{- On a filesystem without symlinks, we'll get changes for regular
 	 - files that git uses to stand-in for symlinks. Detect when
 	 - this happens, and stage the symlink, rather than annexing the
 	 - file. -}
 	guardSymlinkStandin mk a
 		| symlinkssupported = a
 		| otherwise = do
 			linktarget <- liftAnnex $ getAnnexLinkTarget file
 			case linktarget of
 				Nothing -> a
 				Just lt -> do
 					case fileKey $ takeFileName lt of
 						Nothing -> noop
 						Just key -> void $ liftAnnex $
 							addAssociatedFile key file
 					onAddSymlink' linktarget mk True file fs
 {- A symlink might be an arbitrary symlink, which is just added.
 - Or, if it is a git-annex symlink, ensure it points to the content
 - before adding it.
 -}
 onAddSymlink :: Bool -> Handler
 onAddSymlink isdirect file filestatus = unlessIgnored file $ do
 	linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file)
 	kv <- liftAnnex (Backend.lookupFile file)
 	onAddSymlink' linktarget kv isdirect file filestatus
 onAddSymlink' :: Maybe String -> Maybe Key -> Bool -> Handler
 onAddSymlink' linktarget mk isdirect file filestatus = go mk
  where
 	go (Just key) = do
 		when isdirect $
 			liftAnnex $ void $ addAssociatedFile key file
 		link <- liftAnnex $ calcRepo $ gitAnnexLink file key
 		if linktarget == Just link
 			then ensurestaged (Just link) =<< getDaemonStatus
 			else do
 				unless isdirect $
 					liftAnnex $ replaceFile file $
 						makeAnnexLink link
 				addLink file link (Just key)
 	-- other symlink, not git-annex
 	go Nothing = ensurestaged linktarget =<< getDaemonStatus
 	{- This is often called on symlinks that are already
 	 - staged correctly. A symlink may have been deleted
 	 - and being re-added, or added when the watcher was
 	 - not running. So they're normally restaged to make sure.
 	 -
 	 - As an optimisation, during the startup scan, avoid
 	 - restaging everything. Only links that were created since
 	 - the last time the daemon was running are staged.
 	 - (If the daemon has never ran before, avoid staging
 	 - links too.)
 	 -}
 	ensurestaged (Just link) daemonstatus
 		| shouldRestage daemonstatus = addLink file link mk
 		| otherwise = case filestatus of
 			Just s
 				| not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> noChange
 			_ -> addLink file link mk
 	ensurestaged Nothing _ = noChange
 {- For speed, tries to reuse the existing blob for symlink target. -}
 addLink :: FilePath -> FilePath -> Maybe Key -> Assistant (Maybe Change)
 addLink file link mk = do
 	debug ["add symlink", file]
 	liftAnnex $ do
 		v <- catObjectDetails $ Ref $ ':':file
 		case v of
 			Just (currlink, sha, _type)
 				| s2w8 link == L.unpack currlink ->
 					stageSymlink file sha
 			_ -> stageSymlink file =<< hashSymlink link
 	madeChange file $ LinkChange mk
 onDel :: Handler
 onDel file _ = do
 	debug ["file deleted", file]
 	liftAnnex $ onDel' file
 	madeChange file RmChange
 onDel' :: FilePath -> Annex ()
 onDel' file = do
 	whenM isDirect $ do
 		mkey <- catKeyFile file
 		case mkey of
 			Nothing -> noop
 			Just key -> void $ removeAssociatedFile key file
 	Annex.Queue.addUpdateIndex =<<
 		inRepo (Git.UpdateIndex.unstageFile file)
 {- A directory has been deleted, or moved, so tell git to remove anything
 - that was inside it from its cache. Since it could reappear at any time,
 - use --cached to only delete it from the index.
 -
 - This queues up a lot of RmChanges, which assists the Committer in
 - pairing up renamed files when the directory was renamed. -}
 onDelDir :: Handler
 onDelDir dir _ = do
 	debug ["directory deleted", dir]
 	(fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [dir]
 	liftAnnex $ mapM_ onDel' fs
 	-- Get the events queued up as fast as possible, so the
 	-- committer sees them all in one block.
 	now <- liftIO getCurrentTime
 	recordChanges $ map (\f -> Change now f RmChange) fs
 	void $ liftIO clean
 	liftAnnex Annex.Queue.flushWhenFull
 	noChange
 {- Called when there's an error with inotify or kqueue. -}
 onErr :: Handler
 onErr msg _ = do
 	liftAnnex $ warning msg
 	void $ addAlert $ warningAlert "watcher" msg
 	noChange
--- a/Show more
+++ b/Show more