.forgejo/patches/ghc-9.8.patch

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

.forgejo/workflows/generate-lockfile.yml

@@ -1,85 +0,0 @@
-on:
-  workflow_dispatch:
-    inputs:
-      ref_name:
-        description: 'Tag or commit'
-        required: true
-        type: string
-
-  push:
-    tags:
-      - '*'
-
-jobs:
-  cabal-config-edge:
-    name: Generate cabal config for edge
-    runs-on: x86_64
-    container:
-      image: alpine:edge
-    env:
-      CI_ALPINE_TARGET_RELEASE: edge
-    steps:
-      - name: Environment setup
-        run: apk add nodejs git cabal patch
-      - name: Repo pull
-        uses: actions/checkout@v4
-        with:
-          fetch-depth: 1
-          ref: ${{ inputs.ref_name }}
-      - name: Config generation
-        run: |
-          patch -p1 -i .forgejo/patches/ghc-9.8.patch
-          HOME="${{ github.workspace}}"/cabal_cache cabal update
-          HOME="${{ github.workspace}}"/cabal_cache cabal v2-freeze --shadow-installed-packages --strong-flags --flags="+assistant +webapp +pairing +production +torrentparser +magicmime +benchmark -debuglocks +dbus +networkbsd +gitlfs +httpclientrestricted"
-          mv cabal.project.freeze git-annex.config
-      - name: Package upload
-        uses: forgejo/upload-artifact@v3
-        with:
-          name: cabalconfigedge
-          path: git-annex*.config
-  cabal-config-v320:
-    name: Generate cabal config for edge
-    runs-on: x86_64
-    container:
-      image: alpine:3.20
-    env:
-      CI_ALPINE_TARGET_RELEASE: v3.20
-    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: cabalconfig320
-          path: git-annex*.config
-  upload-tarball:
-    name: Upload to generic repo
-    runs-on: x86_64
-    needs: [cabal-config-edge,cabal-config-v320]
-    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 ./cabalconfig320/git-annex.config ${{ github.server_url }}/api/packages/mirrors/generic/git-annex/$CI_REF_NAME/git-annex-$CI_REF_NAME-v320.cabal

.forgejo/workflows/mirror-repository.yml

@@ -1,50 +0,0 @@
-on:
-  workflow_dispatch:
-
-  schedule:
-    - cron: '@hourly'
-
-jobs:
-  mirror:
-    name: Pull from upstream
-    runs-on: x86_64
-    container:
-      image: alpine:latest
-    env:
-      upstream: https://git.joeyh.name/git/git-annex.git 
-      tags: '10.2024*'
-    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|.*/||' > upstream_tags
-          git ls-remote ${{ github.server_url}}/${{ github.repository }} "refs/tags/$tags" | grep -v '{' | sed 's|.*/||' > destination_tags
-          cat upstream_tags destination_tags | tr ' ' '\n' | sort | uniq -u > missing_tags
-          echo "Missing tags:"
-          cat missing_tags
-      - name: Missing tag fetch
-        run: |
-          git remote add upstream $upstream
-          while read tag; do
-            git fetch upstream tag $tag --no-tags
-          done < missing_tags
-      - name: Packaging workflow injection
-        run: |
-          while read tag; do
-            git checkout $tag
-            git tag -d $tag
-            git checkout ci -- ./.forgejo
-            git config user.name "forgejo-actions[bot]"
-            git config user.email "dev@ayakael.net"
-            git commit -m 'Inject custom workflow'
-            git tag -a $tag -m $tag
-          done < missing_tags
-      - name: Push to destination
-        run: git push --force origin refs/tags/*:refs/tags/* --tags   

.ghci

@@ -0,0 +1,4 @@
+-- make ghci use precompiled modules, and C library
+:set -outputdir=tmp
+:set -IUtility
+:load Common

.gitattributes

@@ -0,0 +1 @@
+debian/changelog merge=dpkg-mergechangelogs

.gitignore

@@ -0,0 +1,15 @@
+tmp
+test
+configure
+Build/SysConfig.hs
+git-annex
+git-annex.1
+git-annex-shell.1
+git-union-merge.1
+doc/.ikiwiki
+html
+*.tix
+.hpc
+Utility/Touch.hs
+Utility/libdiskfree.o
+dist

Annex.hs

@@ -0,0 +1,176 @@
+{- git-annex monad
+ -
+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, MultiParamTypeClasses #-}
+
+module Annex (
+	Annex,
+	AnnexState(..),
+	new,
+	newState,
+	run,
+	eval,
+	getState,
+	changeState,
+	setFlag,
+	setField,
+	setOutput,
+	getFlag,
+	getField,
+	addCleanup,
+	gitRepo,
+	inRepo,
+	fromRepo,
+) where
+
+import Control.Monad.State.Strict
+import Control.Monad.Trans.Control (StM, MonadBaseControl, liftBaseWith, restoreM)
+import Control.Monad.Base (liftBase, MonadBase)
+import System.Posix.Types (Fd)
+
+import Common
+import qualified Git
+import qualified Git.Config
+import Git.CatFile
+import Git.CheckAttr
+import Git.SharedRepository
+import qualified Git.Queue
+import Types.Backend
+import qualified Types.Remote
+import Types.Crypto
+import Types.BranchState
+import Types.TrustLevel
+import Types.Messages
+import Utility.State
+import qualified Utility.Matcher
+import qualified Data.Map as M
+
+-- git-annex's monad
+newtype Annex a = Annex { runAnnex :: StateT AnnexState IO a }
+	deriving (
+		Monad,
+		MonadIO,
+		MonadState AnnexState,
+		Functor,
+		Applicative
+	)
+
+instance MonadBase IO Annex where
+	liftBase = Annex . liftBase
+
+instance MonadBaseControl IO Annex where
+	newtype StM Annex a = StAnnex (StM (StateT AnnexState IO) a)
+	liftBaseWith f = Annex $ liftBaseWith $ \runInIO ->
+		f $ liftM StAnnex . runInIO . runAnnex
+	restoreM = Annex . restoreM . unStAnnex
+		where
+			unStAnnex (StAnnex st) = st
+
+type Matcher a = Either [Utility.Matcher.Token a] (Utility.Matcher.Matcher a)
+
+-- internal state storage
+data AnnexState = AnnexState
+	{ repo :: Git.Repo
+	, backends :: [BackendA Annex]
+	, remotes :: [Types.Remote.RemoteA Annex]
+	, output :: MessageState
+	, force :: Bool
+	, fast :: Bool
+	, auto :: Bool
+	, branchstate :: BranchState
+	, repoqueue :: Maybe Git.Queue.Queue
+	, catfilehandle :: Maybe CatFileHandle
+	, checkattrhandle :: Maybe CheckAttrHandle
+	, forcebackend :: Maybe String
+	, forcenumcopies :: Maybe Int
+	, limit :: Matcher (FilePath -> Annex Bool)
+	, shared :: Maybe SharedRepository
+	, forcetrust :: TrustMap
+	, trustmap :: Maybe TrustMap
+	, ciphers :: M.Map StorableCipher Cipher
+	, lockpool :: M.Map FilePath Fd
+	, flags :: M.Map String Bool
+	, fields :: M.Map String String
+	, cleanup :: M.Map String (Annex ())
+	}
+
+newState :: Git.Repo -> AnnexState
+newState gitrepo = AnnexState
+	{ repo = gitrepo
+	, backends = []
+	, remotes = []
+	, output = defaultMessageState
+	, force = False
+	, fast = False
+	, auto = False
+	, branchstate = startBranchState
+	, repoqueue = Nothing
+	, catfilehandle = Nothing
+	, checkattrhandle = Nothing
+	, forcebackend = Nothing
+	, forcenumcopies = Nothing
+	, limit = Left []
+	, shared = Nothing
+	, forcetrust = M.empty
+	, trustmap = Nothing
+	, ciphers = M.empty
+	, lockpool = M.empty
+	, flags = M.empty
+	, fields = M.empty
+	, cleanup = M.empty
+	}
+
+{- 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 gitrepo = newState <$> Git.Config.read gitrepo
+
+{- performs an action in the Annex monad -}
+run :: AnnexState -> Annex a -> IO (a, AnnexState)
+run s a = runStateT (runAnnex a) s
+eval :: AnnexState -> Annex a -> IO a
+eval s a = evalStateT (runAnnex a) s
+
+{- 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 :: String -> Annex () -> Annex ()
+addCleanup uid a = changeState $ \s ->
+	s { cleanup = M.insertWith' const uid 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

Annex/Branch.hs

@@ -0,0 +1,347 @@
+{- management of the git-annex branch
+ -
+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Branch (
+	fullname,
+	name,
+	hasOrigin,
+	hasSibling,
+	siblingBranches,
+	create,
+	update,
+	forceUpdate,
+	updateTo,
+	get,
+	change,
+	commit,
+	stage,
+	files,
+) where
+
+import qualified Data.ByteString.Lazy.Char8 as L
+
+import Common.Annex
+import Annex.Exception
+import Annex.BranchState
+import Annex.Journal
+import qualified Git
+import qualified Git.Command
+import qualified Git.Ref
+import qualified Git.Branch
+import qualified Git.UnionMerge
+import Git.HashObject
+import qualified Git.Index
+import Annex.CatFile
+import Annex.Perms
+
+{- 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/" ++ show name
+
+{- Branch's name in origin. -}
+originname :: Git.Ref
+originname = Git.Ref $ "origin/" ++ show 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 "branch"
+				[Param $ show name, Param $ show originname]
+			fromMaybe (error $ "failed to create " ++ show name)
+				<$> branchsha
+		go False = withIndex' True $
+			inRepo $ Git.Branch.commit "branch created" fullname []
+		use sha = do
+			setIndexSha sha
+			return sha
+		branchsha = inRepo $ Git.Ref.sha fullname
+
+{- Ensures that the branch and index are is up-to-date; should be
+ - called before data is read from it. Runs only once per git-annex run.
+ -}
+update :: Annex ()
+update = runUpdateOnce $ updateTo =<< siblingBranches
+
+{- Forces an update even if one has already been run. -}
+forceUpdate :: Annex ()
+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.
+ -
+ - 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.
+ - If no Refs are provided, the journal is still staged and committed.
+ -
+ - (It would be cleaner to handle the merge by updating the journal, not the
+ - index, with changes from the branches.)
+ -
+ - The branch is fast-forwarded if possible, otherwise a merge commit is
+ - made.
+ -}
+updateTo :: [(Git.Ref, Git.Branch)] -> Annex ()
+updateTo pairs = do
+	-- ensure branch exists, and get its current ref
+	branchref <- getBranch
+	-- check what needs updating before taking the lock
+	dirty <- unCommitted
+	(refs, branches) <- unzip <$> filterM isnewer pairs
+	if not dirty && null refs
+		then updateIndex branchref
+		else withIndex $ lockJournal $ do
+			when dirty stageJournal
+			let merge_desc = if null branches
+				then "update"
+				else "merging " ++
+					unwords (map Git.Ref.describe branches) ++ 
+					" into " ++ show name
+			unless (null branches) $ do
+				showSideAction merge_desc
+				mergeIndex refs
+			ff <- if dirty
+				then return False
+				else inRepo $ Git.Branch.fastForward fullname refs
+			if ff
+				then updateIndex branchref
+				else commitBranch branchref merge_desc
+					(nub $ fullname:refs)
+			invalidateCache
+	where
+		isnewer (r, _) = inRepo $ Git.Branch.changed fullname r
+
+{- Gets the content of a file on the branch, or content from the journal, or
+ - staged in the index.
+ -
+ - Returns an empty string if the file doesn't exist yet. -}
+get :: FilePath -> Annex String
+get = get' False
+
+{- 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.) -}
+getStale :: FilePath -> Annex String
+getStale = get' True
+
+get' :: Bool -> FilePath -> Annex String
+get' staleok file = fromcache =<< getCache file
+	where
+		fromcache (Just content) = return content
+		fromcache Nothing = fromjournal =<< getJournalFile file
+		fromjournal (Just content) = cache content
+		fromjournal Nothing
+			| staleok = withIndex frombranch
+			| otherwise = withIndexUpdate $ frombranch >>= cache
+		frombranch = L.unpack <$> catFile fullname file
+		cache content = do
+			setCache file content
+			return content
+
+{- 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 $ a <$> getStale file >>= set file
+
+{- Records new content of a file into the journal and cache. -}
+set :: FilePath -> String -> Annex ()
+set file content = do
+	setJournalFile file content
+	setCache file content
+
+{- Stages the journal, and commits staged changes to the branch. -}
+commit :: String -> Annex ()
+commit message = whenM unCommitted $ lockJournal $ do
+	stageJournal
+	ref <- getBranch
+	withIndex $ commitBranch ref message [fullname]
+
+{- Stages the journal, not making a commit to the branch. -}
+stage :: Annex ()
+stage = whenM journalDirty $ lockJournal $ do
+	stageJournal
+	setUnCommitted
+
+{- Commits the staged changes in the index to the branch.
+ - 
+ - Ensures that the branch's index file is first updated to 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.
+ -
+ - Also safely handles a race that can occur if a change is being pushed
+ - into the branch at the same time. When the race happens, the commit will
+ - be made on top of the newly pushed change, but without the index file
+ - being updated to include it. The result is that the newly pushed
+ - change is reverted. This race is detected and another commit made
+ - to fix it.
+ - 
+ - 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.
+ -}
+commitBranch :: Git.Ref -> String -> [Git.Ref] -> Annex ()
+commitBranch branchref message parents = do
+	updateIndex branchref
+	committedref <- inRepo $ Git.Branch.commit message fullname parents
+	setIndexSha committedref
+	parentrefs <- commitparents <$> catObject committedref
+	when (racedetected branchref parentrefs) $
+		fixrace committedref parentrefs
+	setCommitted
+	where
+		-- look for "parent ref" lines and return the refs
+		commitparents = map (Git.Ref . snd) . filter isparent .
+			map (toassoc . L.unpack) . L.lines
+		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, and recommit on top of the bad commit. -}
+		fixrace committedref lostrefs = do
+			mergeIndex lostrefs
+			commitBranch committedref racemessage [committedref]
+		
+		racemessage = message ++ " (recovery from race)"
+
+{- Lists all files on the branch. There may be duplicates in the list. -}
+files :: Annex [FilePath]
+files = withIndexUpdate $ do
+	bfiles <- inRepo $ Git.Command.pipeNullSplit
+		[Params "ls-tree --name-only -r -z", Param $ show fullname]
+	jfiles <- getJournalledFiles
+	return $ jfiles ++ bfiles
+
+
+{- 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.UnionMerge.stream_update_index g
+	[Git.UnionMerge.ls_tree fullname g]
+
+{- Merges the specified refs into the index.
+ - Any changes staged in the index will be preserved. -}
+mergeIndex :: [Git.Ref] -> Annex ()
+mergeIndex branches = do
+	h <- catFileHandle
+	inRepo $ \g -> Git.UnionMerge.merge_index h g branches
+
+{- Runs an action using the branch's index file. -}
+withIndex :: Annex a -> Annex a
+withIndex = withIndex' False
+withIndex' :: Bool -> Annex a -> Annex a
+withIndex' bootstrapping a = do
+	f <- fromRepo gitAnnexIndex
+	bracketIO (Git.Index.override f) id $ do
+		checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do
+			unless bootstrapping create
+			liftIO $ createDirectoryIfMissing True $ takeDirectory f
+			unless bootstrapping $ inRepo genIndex
+		a
+
+{- Runs an action using the branch's index file, first making sure that
+ - the branch and index are up-to-date. -}
+withIndexUpdate :: Annex a -> Annex a
+withIndexUpdate a = update >> withIndex 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 :: Git.Ref -> Annex ()
+updateIndex branchref = do
+	lock <- fromRepo gitAnnexIndexLock
+	lockref <- Git.Ref . firstLine <$>
+		liftIO (catchDefaultIO (readFileStrict lock) "")
+	when (lockref /= branchref) $ do
+		withIndex $ mergeIndex [fullname]
+		setIndexSha 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
+        lock <- fromRepo gitAnnexIndexLock
+	liftIO $ writeFile lock $ show ref ++ "\n"
+	setAnnexPerm lock
+
+{- Checks if there are uncommitted changes in the branch's index or journal. -}
+unCommitted :: Annex Bool
+unCommitted = do
+	d <- liftIO . doesFileExist =<< fromRepo gitAnnexIndexDirty
+	if d
+		then return d
+		else journalDirty
+
+setUnCommitted :: Annex ()
+setUnCommitted = do
+	file <- fromRepo gitAnnexIndexDirty
+	liftIO $ writeFile file "1"
+
+setCommitted :: Annex ()
+setCommitted = void $ do
+	file <- fromRepo gitAnnexIndexDirty
+	liftIO $ tryIO $ removeFile file
+
+{- Stages the journal into the index. -}
+stageJournal :: Annex ()
+stageJournal = do
+	showStoringStateAction
+	fs <- getJournalFiles
+	g <- gitRepo
+	withIndex $ liftIO $ do
+		h <- hashObjectStart g
+		Git.UnionMerge.stream_update_index g
+			[genstream (gitAnnexJournalDir g) h fs]
+		hashObjectStop h
+	where
+		genstream dir h fs streamer = forM_ fs $ \file -> do
+			let path = dir </> file
+			sha <- hashFile h path
+			_ <- streamer $ Git.UnionMerge.update_index_line
+				sha (fileJournal file)
+			removeFile path

Annex/BranchState.hs

@@ -0,0 +1,59 @@
+{- git-annex branch state management
+ -
+ - Runtime state about the git-annex branch, including a small read cache.
+ -
+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
+ -
+ - 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
+
+setCache :: FilePath -> String -> Annex ()
+setCache file content = changeState $ \s -> s
+	{ cachedFile = Just file, cachedContent = content}
+
+getCache :: FilePath -> Annex (Maybe String)
+getCache file = from <$> getState
+	where
+		from state
+			| cachedFile state == Just file =
+				Just $ cachedContent state
+			| otherwise = Nothing
+
+invalidateCache :: Annex ()
+invalidateCache = changeState $ \s -> s
+	{ cachedFile = Nothing, cachedContent = "" }
+
+{- Runs an action to check that the index file exists, if it's not been
+ - checked before in this run of git-annex. -}
+checkIndexOnce :: Annex () -> Annex ()
+checkIndexOnce a = unlessM (indexChecked <$> getState) $ do
+	a
+	changeState $ \s -> s { indexChecked = True }
+
+{- Runs an action to update the branch, if it's not been updated before
+ - in this run of git-annex. -}
+runUpdateOnce :: Annex () -> Annex ()
+runUpdateOnce a = unlessM (branchUpdated <$> getState) $ do
+	a
+	disableUpdate
+
+{- Avoids updating the branch. A useful optimisation when the branch
+ - is known to have not changed, or git-annex won't be relying on info
+ - from it. -}
+disableUpdate :: Annex ()
+disableUpdate = changeState $ \s -> s { branchUpdated = True }

Annex/CatFile.hs

@@ -0,0 +1,37 @@
+{- git cat-file interface, with handle automatically stored in the Annex monad
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.CatFile (
+	catFile,
+	catObject,
+	catFileHandle
+) where
+
+import qualified Data.ByteString.Lazy.Char8 as L
+
+import Common.Annex
+import qualified Git
+import qualified Git.CatFile
+import qualified Annex
+
+catFile :: Git.Branch -> FilePath -> Annex L.ByteString
+catFile branch file = do
+	h <- catFileHandle
+	liftIO $ Git.CatFile.catFile h branch file
+
+catObject :: Git.Ref -> Annex L.ByteString
+catObject ref = do
+	h <- catFileHandle
+	liftIO $ Git.CatFile.catObject h ref
+
+catFileHandle :: Annex Git.CatFile.CatFileHandle
+catFileHandle = maybe startup return =<< Annex.getState Annex.catfilehandle
+	where
+		startup = do
+			h <- inRepo Git.CatFile.catFileStart
+			Annex.changeState $ \s -> s { Annex.catfilehandle = Just h }
+			return h

Annex/CheckAttr.hs

@@ -0,0 +1,35 @@
+{- git check-attr interface, with handle automatically stored in the Annex monad
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - 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

Annex/Content.hs

@@ -0,0 +1,379 @@
+{- git-annex file content managing
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Content (
+	inAnnex,
+	inAnnexSafe,
+	lockContent,
+	calcGitLink,
+	logStatus,
+	getViaTmp,
+	getViaTmpUnchecked,
+	withTmp,
+	checkDiskSpace,
+	moveAnnex,
+	removeAnnex,
+	fromAnnex,
+	moveBad,
+	getKeysPresent,
+	saveState,
+	downloadUrl,
+	preseedTmp,
+	freezeContent,
+	thawContent,
+	freezeContentDir,
+) where
+
+import System.IO.Unsafe (unsafeInterleaveIO)
+
+import Common.Annex
+import Logs.Location
+import Annex.UUID
+import qualified Git
+import qualified Git.Config
+import qualified Annex
+import qualified Annex.Queue
+import qualified Annex.Branch
+import Utility.DiskFree
+import Utility.FileMode
+import qualified Utility.Url as Url
+import Types.Key
+import Utility.DataUnits
+import Utility.CopyFile
+import Config
+import Annex.Exception
+import Git.SharedRepository
+import Annex.Perms
+
+{- Checks if a given key's content is currently present. -}
+inAnnex :: Key -> Annex Bool
+inAnnex = inAnnex' doesFileExist
+inAnnex' :: (FilePath -> IO a) -> Key -> Annex a
+inAnnex' a key = do
+	whenM (fromRepo Git.repoIsUrl) $
+		error "inAnnex cannot check remote repo"
+	inRepo $ \g -> gitAnnexLocation key g >>= a
+
+{- 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 = inAnnex' $ \f -> openforlock f >>= check
+	where
+		openforlock f = catchMaybeIO $
+			openFd f ReadOnly Nothing defaultFileFlags
+		check Nothing = return is_missing
+		check (Just h) = do
+			v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)
+			closeFd h
+			return $ case v of
+				Just _ -> is_locked
+				Nothing -> is_unlocked
+		is_locked = Nothing
+		is_unlocked = Just True
+		is_missing = Just False
+
+{- Content is exclusively locked while running an action that might remove
+ - it. (If the content is not present, no locking is done.) -}
+lockContent :: Key -> Annex a -> Annex a
+lockContent key a = do
+	file <- inRepo $ gitAnnexLocation key
+	bracketIO (openforlock file >>= lock) unlock a
+	where
+		{- Since files are stored with the write bit disabled, have
+		 - to fiddle with permissions to open for an exclusive lock. -}
+		openforlock f = catchMaybeIO $ ifM (doesFileExist f)
+			( withModifiedFileMode f
+				(\cur -> cur `unionFileModes` ownerWriteMode)
+				open
+			, open
+			)
+			where
+				open = openFd f ReadWrite Nothing defaultFileFlags
+		lock Nothing = return Nothing
+		lock (Just fd) = do
+			v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
+			case v of
+				Left _ -> error "content is locked"
+				Right _ -> return $ Just fd
+		unlock Nothing = noop
+		unlock (Just l) = closeFd l
+
+{- Calculates the relative path to use to link a file to a key. -}
+calcGitLink :: FilePath -> Key -> Annex FilePath
+calcGitLink file key = do
+	cwd <- liftIO getCurrentDirectory
+	let absfile = fromMaybe whoops $ absNormPath cwd file
+	loc <- inRepo $ gitAnnexLocation key
+	return $ relPathDirToFile (parentDir absfile) loc
+	where
+		whoops = error $ "unable to normalize " ++ file
+
+{- Updates the Logs.Location when a key's presence changes in the current
+ - repository. -}
+logStatus :: Key -> LogStatus -> Annex ()
+logStatus key status = do
+	u <- getUUID
+	logChange key u status
+
+{- 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 key action = do
+	tmp <- fromRepo $ gitAnnexTmpLocation key
+
+	-- Check that there is enough free disk space.
+	-- When the temp file already exists, count the space
+	-- it is using as free.
+	e <- liftIO $ doesFileExist tmp
+	alreadythere <- if e
+		then fromIntegral . fileSize <$> liftIO (getFileStatus tmp)
+		else return 0
+	ifM (checkDiskSpace Nothing key alreadythere)
+		( do
+			when e $ thawContent tmp
+			getViaTmpUnchecked key action
+		, return False
+		)
+
+prepTmp :: Key -> Annex FilePath
+prepTmp key = do
+	tmp <- fromRepo $ gitAnnexTmpLocation key
+	createAnnexDirectory (parentDir tmp)
+	return tmp
+
+{- 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 key action = do
+	tmp <- prepTmp key
+	ifM (action tmp)
+		( do
+			moveAnnex key tmp
+			logStatus key InfoPresent
+			return True
+		, do
+			-- the tmp file is left behind, in case caller wants
+			-- to resume its transfer
+			return False
+		)
+
+{- Creates a temp file, runs an action on it, and cleans up the temp file. -}
+withTmp :: Key -> (FilePath -> Annex a) -> Annex a
+withTmp key action = do
+	tmp <- prepTmp key
+	res <- action tmp
+	liftIO $ whenM (doesFileExist tmp) $ liftIO $ removeFile 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 <- getDiskReserve
+	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 $ do
+				liftIO $ print (need, reserve, have, alreadythere)
+				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 file into .git/annex/objects/
+ -
+ - 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 = do
+	dest <- inRepo $ gitAnnexLocation key
+	ifM (liftIO $ doesFileExist dest)
+		( liftIO $ removeFile src
+		, do
+			createContentDir dest
+			liftIO $ moveFile src dest
+			freezeContent dest
+			freezeContentDir dest
+		)
+
+withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a
+withObjectLoc key a = do
+	file <- inRepo $ gitAnnexLocation key
+	let dir = parentDir file
+	a (dir, file)
+
+cleanObjectLoc :: Key -> Annex ()
+cleanObjectLoc key = do
+	file <- inRepo $ gitAnnexLocation key
+	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/ -}
+removeAnnex :: Key -> Annex ()
+removeAnnex key = withObjectLoc key $ \(dir, file) -> do
+	liftIO $ do
+		allowWrite dir
+		removeFile file
+	cleanObjectLoc key
+
+{- Moves a key's file out of .git/annex/objects/ -}
+fromAnnex :: Key -> FilePath -> Annex ()
+fromAnnex key dest = withObjectLoc key $ \(dir, file) -> do
+	liftIO $ allowWrite dir
+	thawContent file
+	liftIO $ moveFile file dest
+	cleanObjectLoc key
+
+{- 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 <- inRepo $ gitAnnexLocation key
+	bad <- fromRepo gitAnnexBadDir
+	let dest = bad </> takeFileName src
+	createAnnexDirectory (parentDir dest)
+	liftIO $ do
+		allowWrite (parentDir src)
+		moveFile src dest
+	cleanObjectLoc key
+	logStatus key InfoMissing
+	return dest
+
+{- List of keys whose content exists in .git/annex/objects/ -}
+getKeysPresent :: Annex [Key]
+getKeysPresent = liftIO . traverse (2 :: Int) =<< fromRepo gitAnnexObjectDir
+	where
+		traverse depth dir = do
+			contents <- catchDefaultIO (dirContents dir) []
+			if depth == 0
+				then continue (mapMaybe (fileKey . takeFileName) contents) []
+				else do
+					let deeper = traverse (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
+
+{- 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 oneshot = doSideAction $ do
+	Annex.Queue.flush
+	unless oneshot $
+		ifM alwayscommit
+			( Annex.Branch.commit "update" , Annex.Branch.stage)
+	where
+		alwayscommit = fromMaybe True . Git.Config.isTrue
+			<$> getConfig (annexConfig "alwayscommit") ""
+
+{- Downloads content from any of a list of urls. -}
+downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool
+downloadUrl urls file = do
+	o <- map Param . words <$> getConfig (annexConfig "web-options") ""
+	headers <- getHttpHeaders
+	liftIO $ anyM (\u -> Url.download u headers o file) urls
+
+{- 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 <- inRepo $ gitAnnexLocation key
+					liftIO $ copyFileExternal s file
+				)
+
+{- Blocks writing to an annexed file. The file is made unwritable
+ - to avoid accidental edits. core.sharedRepository may change
+ - who can read it. -}
+freezeContent :: FilePath -> Annex ()
+freezeContent file = liftIO . go =<< fromRepo getSharedRepository
+	where
+		go GroupShared = modifyFileMode file $
+			removeModes writeModes .
+			addModes [ownerReadMode, groupReadMode]
+		go AllShared = modifyFileMode file $
+			removeModes writeModes .
+			addModes readModes
+		go _ = preventWrite file
+
+{- Allows writing to an annexed file that freezeContent was called on
+ - before. -}
+thawContent :: FilePath -> Annex ()
+thawContent file = liftIO . go =<< fromRepo getSharedRepository
+	where
+		go GroupShared = groupWriteRead file
+		go AllShared = groupWriteRead file
+		go _ = allowWrite file
+
+{- 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 = liftIO . go =<< fromRepo getSharedRepository
+	where
+		dir = parentDir file
+		go GroupShared = groupWriteRead dir
+		go AllShared = groupWriteRead dir
+		go _ = preventWrite dir
+
+{- 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
+	liftIO $ allowWrite dir
+	where
+		dir = parentDir dest

Annex/Exception.hs

@@ -0,0 +1,27 @@
+{- exception handling in the git-annex monad
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Exception (
+	bracketIO,
+	handle,
+	throw,
+) where
+
+import Control.Exception.Lifted (handle)
+import Control.Monad.Trans.Control (liftBaseOp)
+import Control.Exception hiding (handle, throw)
+
+import Common.Annex
+
+{- Runs an Annex action, with setup and cleanup both in the IO monad. -}
+bracketIO :: IO c -> (c -> IO b) -> Annex a -> Annex a
+bracketIO setup cleanup go =
+	liftBaseOp (Control.Exception.bracket setup cleanup) (const go)
+
+{- Throws an exception in the Annex monad. -}
+throw :: Control.Exception.Exception e => e -> Annex a
+throw = liftIO . throwIO

Annex/Journal.hs

@@ -0,0 +1,89 @@
+{- management of the git-annex journal and cache
+ -
+ - The journal is used to queue up changes before they are committed to the
+ - git-annex branch. Amoung other things, it ensures that if git-annex is
+ - interrupted, its recorded data is not lost.
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Journal where
+
+import System.IO.Binary
+
+import Common.Annex
+import Annex.Exception
+import qualified Git
+import Annex.Perms
+
+{- 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. -}
+setJournalFile :: FilePath -> String -> Annex ()
+setJournalFile file content = do
+	createAnnexDirectory =<< fromRepo gitAnnexJournalDir
+	createAnnexDirectory =<< fromRepo gitAnnexTmpDir
+	-- journal file is written atomically
+	jfile <- fromRepo $ journalFile file
+	tmp <- fromRepo gitAnnexTmpDir
+	let tmpfile = tmp </> takeFileName jfile
+	liftIO $ do
+		writeBinaryFile tmpfile content
+		moveFile tmpfile jfile
+
+{- Gets any journalled content for a file in the branch. -}
+getJournalFile :: FilePath -> Annex (Maybe String)
+getJournalFile file = inRepo $ \g -> catchMaybeIO $
+	readFileStrict $ journalFile file g
+
+{- List of files that have updated content in the journal. -}
+getJournalledFiles :: Annex [FilePath]
+getJournalledFiles = map fileJournal <$> getJournalFiles
+
+{- List of existing journal files. -}
+getJournalFiles :: Annex [FilePath]
+getJournalFiles = do
+	g <- gitRepo
+	fs <- liftIO $
+		catchDefaultIO (getDirectoryContents $ gitAnnexJournalDir g) []
+	return $ filter (`notElem` [".", ".."]) fs
+
+{- Checks if there are changes in the journal. -}
+journalDirty :: Annex Bool
+journalDirty = not . null <$> getJournalFiles
+
+{- 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 '/' = "_"
+		mangle '_' = "__"
+		mangle c = [c]
+
+{- Converts a journal file (relative to the journal dir) back to the
+ - filename on the branch. -}
+fileJournal :: FilePath -> FilePath
+fileJournal = replace "//" "_" . replace "_" "/"
+
+{- Runs an action that modifies the journal, using locking to avoid
+ - contention with other git-annex processes. -}
+lockJournal :: Annex a -> Annex a
+lockJournal a = do
+	file <- fromRepo gitAnnexJournalLock
+	createAnnexDirectory $ takeDirectory file
+	mode <- annexFileMode
+	bracketIO (lock file mode) unlock a
+	where
+		lock file mode = do
+			l <- noUmask mode $ createFile file mode
+			waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)
+			return l
+		unlock = closeFd

Annex/LockPool.hs

@@ -0,0 +1,45 @@
+{- git-annex lock pool
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.LockPool where
+
+import qualified Data.Map as M
+import System.Posix.Types (Fd)
+
+import Common.Annex
+import Annex
+import Annex.Perms
+
+{- Create a specified lock file, and takes a shared lock. -}
+lockFile :: FilePath -> Annex ()
+lockFile file = go =<< fromPool file
+	where
+		go (Just _) = noop -- already locked
+		go Nothing = do
+			mode <- annexFileMode
+			fd <- liftIO $ noUmask mode $
+				openFd file ReadOnly (Just mode) defaultFileFlags
+			liftIO $ waitToSetLock fd (ReadLock, AbsoluteSeek, 0, 0)
+			changePool $ M.insert file fd
+
+unlockFile :: FilePath -> Annex ()
+unlockFile file = maybe noop go =<< fromPool file
+	where
+		go fd = do
+			liftIO $ closeFd fd
+			changePool $ M.delete file
+
+getPool :: Annex (M.Map FilePath Fd)
+getPool = getState lockpool
+
+fromPool :: FilePath -> Annex (Maybe Fd)
+fromPool file = M.lookup file <$> getPool
+
+changePool :: (M.Map FilePath Fd -> M.Map FilePath Fd) -> Annex ()
+changePool a = do
+	m <- getPool
+	changeState $ \s -> s { lockpool = a m }

Annex/Perms.hs

@@ -0,0 +1,70 @@
+{- git-annex file permissions
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Perms (
+	setAnnexPerm,
+	annexFileMode,
+	createAnnexDirectory,
+	noUmask,
+) where
+
+import Common.Annex
+import Utility.FileMode
+import Git.SharedRepository
+import qualified Annex
+
+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
+
+{- 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 :: FilePath -> Annex ()
+setAnnexPerm file = withShared $ liftIO . go
+	where
+		go GroupShared = groupWriteRead file
+		go AllShared = modifyFileMode file $ addModes $
+			[ ownerWriteMode, groupWriteMode ] ++ readModes
+		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
+			[ ownerWriteMode, groupWriteMode
+			, ownerReadMode, groupReadMode
+			]
+
+{- 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 $ createDirectory p
+					setAnnexPerm p

Annex/Queue.hs

@@ -0,0 +1,52 @@
+{- git-annex command queue
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Queue (
+	add,
+	flush,
+	flushWhenFull
+) where
+
+import Common.Annex
+import Annex hiding (new)
+import qualified Git.Queue
+import Config
+
+{- Adds a git command to the queue. -}
+add :: String -> [CommandParam] -> [FilePath] -> Annex ()
+add command params files = do
+	q <- get
+	store $ Git.Queue.add q command params files
+
+{- 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'
+
+get :: Annex Git.Queue.Queue
+get = maybe new return =<< getState repoqueue
+
+new :: Annex Git.Queue.Queue
+new = do
+	q <- Git.Queue.new <$> queuesize
+	store q
+	return q
+	where
+		queuesize = readish <$> getConfig (annexConfig "queuesize") ""
+
+store :: Git.Queue.Queue -> Annex ()
+store q = changeState $ \s -> s { repoqueue = Just q }

Annex/Ssh.hs

@@ -0,0 +1,120 @@
+{- git-annex ssh interface, with connection caching
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Ssh (
+	sshParams,
+	sshCleanup,
+) where
+
+import qualified Data.Map as M
+
+import Common.Annex
+import Annex.LockPool
+import qualified Git.Config
+import Config
+import qualified Build.SysConfig as SysConfig
+import Annex.Perms
+
+{- Generates parameters to ssh to a given host (or user@host) on a given
+ - port, with connection caching. -}
+sshParams :: (String, Maybe Integer) -> [CommandParam] -> Annex [CommandParam]
+sshParams (host, port) opts = go =<< sshInfo (host, port)
+	where
+		go (Nothing, params) = ret params
+		go (Just socketfile, params) = do
+			cleanstale
+			liftIO $ createDirectoryIfMissing True $ parentDir socketfile
+			lockFile $ socket2lock socketfile
+			ret params
+		ret ps = return $ ps ++ opts ++ portParams port ++ [Param host]
+		-- 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.
+		cleanstale = whenM (not . any isLock . M.keys <$> getPool) $
+			sshCleanup
+
+sshInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam])
+sshInfo (host, port) = ifM caching
+	( do
+		dir <- fromRepo gitAnnexSshDir
+		let socketfile = dir </> hostport2socket host port
+	 	return (Just socketfile, cacheParams socketfile)
+	, return (Nothing, [])
+	)
+	where
+		caching = fromMaybe SysConfig.sshconnectioncaching 
+			. Git.Config.isTrue
+			<$> getConfig (annexConfig "sshcaching") ""
+
+cacheParams :: FilePath -> [CommandParam]
+cacheParams socketfile =
+	[ Param "-S", Param socketfile
+	, Params "-o ControlMaster=auto -o ControlPersist=yes"
+	]
+
+portParams :: Maybe Integer -> [CommandParam]
+portParams Nothing = []
+portParams (Just port) = [Param "-p", Param $ show port]
+
+{- Stop any unused ssh processes. -}
+sshCleanup :: Annex ()
+sshCleanup = do
+	dir <- fromRepo gitAnnexSshDir
+	sockets <- filter (not . isLock) <$>
+		liftIO (catchDefaultIO (dirContents dir) [])
+	forM_ sockets cleanup
+	where
+		cleanup socketfile = do
+			-- 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.
+			let lockfile = socket2lock socketfile
+			unlockFile lockfile
+			mode <- annexFileMode
+			fd <- liftIO $ noUmask mode $
+				openFd lockfile ReadWrite (Just mode) defaultFileFlags
+			v <- liftIO $ tryIO $
+				setLock fd (WriteLock, AbsoluteSeek, 0, 0)
+			case v of
+				Left _ -> noop
+				Right _ -> stopssh socketfile
+			liftIO $ closeFd fd
+		stopssh socketfile = do
+			let (host, port) = socket2hostport socketfile
+			(_, params) <- sshInfo (host, port)
+			void $ liftIO $ do
+				-- "ssh -O stop" is noisy on stderr even with -q
+				let cmd = unwords $ toCommand $
+					[ Params "-O stop"
+					] ++ params ++ [Param host]
+				boolSystem "sh"
+					[ Param "-c"
+					, Param $ "ssh " ++ cmd ++ " >/dev/null 2>/dev/null"
+					]
+				-- Cannot remove the lock file; other processes may
+				-- be waiting on our exclusive lock to use it.
+
+hostport2socket :: String -> Maybe Integer -> FilePath
+hostport2socket host Nothing = host
+hostport2socket host (Just port) = host ++ "!" ++ show port
+
+socket2hostport :: FilePath -> (String, Maybe Integer)
+socket2hostport socket
+	| null p = (h, Nothing)
+	| otherwise = (h, readish p)
+	where
+		(h, p) = separate (== '!') $ takeFileName socket
+
+socket2lock :: FilePath -> FilePath
+socket2lock socket = socket ++ lockExt
+
+isLock :: FilePath -> Bool
+isLock f = lockExt `isSuffixOf` f
+
+lockExt :: String
+lockExt = ".lock"

Annex/UUID.hs

@@ -0,0 +1,79 @@
+{- 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-2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.UUID (
+	getUUID,
+	getRepoUUID,
+	getUncachedUUID,
+	prepUUID,
+	genUUID,
+	removeRepoUUID,
+) where
+
+import Common.Annex
+import qualified Git
+import qualified Git.Config
+import qualified Build.SysConfig as SysConfig
+import Config
+
+configkey :: ConfigKey
+configkey = annexConfig "uuid"
+
+{- Generates a UUID. There is a library for this, but it's not packaged,
+ - so use the command line tool. -}
+genUUID :: IO UUID
+genUUID = pOpen ReadFromPipe command params $ liftM toUUID . hGetLine
+	where
+		command = SysConfig.uuid
+		params
+			-- request a random uuid be generated
+			| command == "uuid" = ["-m"]
+			-- uuidgen generates random uuid by default
+			| otherwise = []
+
+{- 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) $ storeUUID 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 configkey =<< liftIO genUUID
+
+storeUUID :: ConfigKey -> UUID -> Annex ()
+storeUUID configfield = setConfig configfield . fromUUID

Annex/Version.hs

@@ -0,0 +1,43 @@
+{- git-annex repository versioning
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Version where
+
+import Common.Annex
+import Config
+
+type Version = String
+
+defaultVersion :: Version
+defaultVersion = "3"
+
+supportedVersions :: [Version]
+supportedVersions = [defaultVersion]
+
+upgradableVersions :: [Version]
+upgradableVersions = ["0", "1", "2"]
+
+versionField :: ConfigKey
+versionField = annexConfig "version"
+
+getVersion :: Annex (Maybe Version)
+getVersion = handle <$> getConfig versionField ""
+	where
+		handle [] = Nothing
+		handle v = Just v
+
+setVersion :: Annex ()
+setVersion = setConfig versionField defaultVersion
+
+checkVersion :: Version -> Annex ()
+checkVersion v
+	| v `elem` supportedVersions = noop
+	| v `elem` upgradableVersions = err "Upgrade this repository: git-annex upgrade"
+	| otherwise = err "Upgrade git-annex."
+	where
+		err msg = error $ "Repository version " ++ v ++
+			" is not supported. " ++ msg

Backend.hs

@@ -0,0 +1,113 @@
+{- git-annex key/value backends
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Backend (
+	list,
+	orderedList,
+	genKey,
+	lookupFile,
+	chooseBackend,
+	lookupBackendName,
+	maybeLookupBackendName
+) where
+
+import System.Posix.Files
+
+import Common.Annex
+import Config
+import qualified Annex
+import Annex.CheckAttr
+import Types.Key
+import qualified Types.Backend as B
+
+-- When adding a new backend, import it here and add it to the list.
+import qualified Backend.SHA
+import qualified Backend.WORM
+import qualified Backend.URL
+
+list :: [Backend]
+list = Backend.SHA.backends ++ Backend.WORM.backends ++ Backend.URL.backends
+
+{- List of backends in the order to try them when storing a new key. -}
+orderedList :: Annex [Backend]
+orderedList = do
+	l <- Annex.getState Annex.backends -- list is cached here
+	if not $ null l
+		then return l
+		else handle =<< Annex.getState Annex.forcebackend
+	where
+		handle Nothing = standard
+		handle (Just "") = standard
+		handle (Just name) = do
+			l' <- (lookupBackendName name :) <$> standard
+			Annex.changeState $ \s -> s { Annex.backends = l' }
+			return l'
+		standard = parseBackendList <$> getConfig (annexConfig "backends") ""
+		parseBackendList [] = list
+		parseBackendList s = map lookupBackendName $ words s
+
+{- Generates a key for a file, trying each backend in turn until one
+ - accepts it. -}
+genKey :: FilePath -> Maybe Backend -> Annex (Maybe (Key, Backend))
+genKey file trybackend = do
+	bs <- orderedList
+	let bs' = maybe bs (: bs) trybackend
+	genKey' bs' file
+genKey' :: [Backend] -> FilePath -> Annex (Maybe (Key, Backend))
+genKey' [] _ = return Nothing
+genKey' (b:bs) file = do
+	r <- B.getKey b file
+	case r of
+		Nothing -> genKey' bs file
+		Just k -> return $ Just (makesane k, b)
+	where
+		-- keyNames should not contain newline characters.
+		makesane k = k { keyName = map fixbadchar (keyName k) }
+		fixbadchar c
+			| c == '\n' = '_'
+			| otherwise = c
+
+{- Looks up the key and backend corresponding to an annexed file,
+ - by examining what the file symlinks to. -}
+lookupFile :: FilePath -> Annex (Maybe (Key, Backend))
+lookupFile file = do
+	tl <- liftIO $ tryIO $ readSymbolicLink file
+	case tl of
+		Left _ -> return Nothing
+		Right l -> makekey l
+	where
+		makekey l = maybe (return Nothing) (makeret l) (fileKey $ takeFileName l)
+		makeret l k = let bname = keyBackendName k in
+			case maybeLookupBackendName bname of
+				Just backend -> do
+					return $ Just (k, backend)
+				Nothing -> do
+					when (isLinkToAnnex l) $ warning $
+						"skipping " ++ file ++
+						" (unknown backend " ++
+						bname ++ ")"
+					return Nothing
+
+{- Looks up the backend that should be used for a file.
+ - That can be configured on a per-file basis in the gitattributes file.
+ -}
+chooseBackend :: FilePath -> Annex (Maybe Backend)
+chooseBackend f = Annex.getState Annex.forcebackend >>= go
+	where
+		go Nothing =  maybeLookupBackendName <$>
+			checkAttr "annex.backend" f
+		go (Just _) = Just . Prelude.head <$> orderedList
+
+{- Looks up a backend by name. May fail if unknown. -}
+lookupBackendName :: String -> Backend
+lookupBackendName s = fromMaybe unknown $ maybeLookupBackendName s
+	where
+		unknown = error $ "unknown backend " ++ s
+maybeLookupBackendName :: String -> Maybe Backend
+maybeLookupBackendName s = headMaybe matches
+	where
+		matches = filter (\b -> s == B.name b) list

Backend/SHA.hs

@@ -0,0 +1,109 @@
+{- git-annex SHA backend
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Backend.SHA (backends) where
+
+import Common.Annex
+import qualified Annex
+import Types.Backend
+import Types.Key
+import qualified Build.SysConfig as SysConfig
+
+type SHASize = Int
+
+-- order is slightly significant; want SHA256 first, and more general
+-- sizes earlier
+sizes :: [Int]
+sizes = [256, 1, 512, 224, 384]
+
+backends :: [Backend]
+backends = catMaybes $ map genBackend sizes ++ map genBackendE sizes
+
+genBackend :: SHASize -> Maybe Backend
+genBackend size
+	| isNothing (shaCommand size) = Nothing
+	| otherwise = Just b
+	where
+		b = Backend
+			{ name = shaName size
+			, getKey = keyValue size
+			, fsckKey = Just $ checkKeyChecksum size
+			}
+
+genBackendE :: SHASize -> Maybe Backend
+genBackendE size =
+	case genBackend size of
+		Nothing -> Nothing
+		Just b -> Just $ b
+			{ name = shaNameE size
+			, getKey = keyValueE size
+			}
+
+shaCommand :: SHASize -> Maybe String
+shaCommand 1 = SysConfig.sha1
+shaCommand 256 = Just SysConfig.sha256
+shaCommand 224 = SysConfig.sha224
+shaCommand 384 = SysConfig.sha384
+shaCommand 512 = SysConfig.sha512
+shaCommand _ = Nothing
+
+shaName :: SHASize -> String
+shaName size = "SHA" ++ show size
+
+shaNameE :: SHASize -> String
+shaNameE size = shaName size ++ "E"
+
+shaN :: SHASize -> FilePath -> Annex String
+shaN size file = do
+	showAction "checksum"
+	liftIO $ pOpen ReadFromPipe command (toCommand [File file]) $ \h -> do
+		sha <- fst . separate (== ' ') <$> hGetLine h
+		if null sha
+			then error $ command ++ " parse error"
+			else return sha
+	where
+		command = fromJust $ shaCommand size
+
+{- A key is a checksum of its contents. -}
+keyValue :: SHASize -> FilePath -> Annex (Maybe Key)
+keyValue size file = do
+	s <- shaN size file	
+	stat <- liftIO $ getFileStatus file
+	return $ Just $ stubKey
+		{ keyName = s
+		, keyBackendName = shaName size
+		, keySize = Just $ fromIntegral $ fileSize stat
+		}
+
+{- Extension preserving keys. -}
+keyValueE :: SHASize -> FilePath -> Annex (Maybe Key)
+keyValueE size file = keyValue size file >>= maybe (return Nothing) addE
+	where
+		addE k = return $ Just $ k
+			{ keyName = keyName k ++ extension
+			, keyBackendName = shaNameE size
+			}
+		naiveextension = takeExtension file
+		extension
+			-- long or newline containing extensions are 
+			-- probably not really an extension
+			| length naiveextension > 6 ||
+			  '\n' `elem` naiveextension = ""
+			| otherwise = naiveextension
+
+{- A key's checksum is checked during fsck. -}
+checkKeyChecksum :: SHASize -> Key -> FilePath -> Annex Bool
+checkKeyChecksum size key file = do
+	fast <- Annex.getState Annex.fast
+	present <- liftIO $ doesFileExist file
+	if not present || fast
+		then return True
+		else check <$> shaN size file
+	where
+		check s
+			| s == dropExtension (keyName key) = True
+			| otherwise = False

Backend/URL.hs

@@ -0,0 +1,41 @@
+{- git-annex "URL" backend -- keys whose content is available from urls.
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Backend.URL (
+	backends,
+	fromUrl
+) where
+
+import Data.Hash.MD5
+
+import Common.Annex
+import Types.Backend
+import Types.Key
+
+backends :: [Backend]
+backends = [backend]
+
+backend :: Backend
+backend = Backend {
+	name = "URL",
+	getKey = const (return Nothing),
+	fsckKey = Nothing
+}
+
+fromUrl :: String -> Maybe Integer -> Key
+fromUrl url size = stubKey
+	{ keyName = key
+	, keyBackendName = "URL"
+	, keySize = size
+	}
+	where
+		-- when it's not too long, use the url as the key name
+		-- 256 is the absolute filename max, but use a shorter
+		-- length because this is not the entire key filename.
+		key
+			| length url < 128 = url
+			| otherwise = take 128 url ++ "-" ++ md5s (Str url)

Backend/WORM.hs

@@ -0,0 +1,39 @@
+{- git-annex "WORM" backend -- Write Once, Read Many
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Backend.WORM (backends) where
+
+import Common.Annex
+import Types.Backend
+import Types.Key
+
+backends :: [Backend]
+backends = [backend]
+
+backend :: Backend
+backend = Backend {
+	name = "WORM",
+	getKey = keyValue,
+	fsckKey = Nothing
+}
+
+{- The key includes the file size, modification time, and the
+ - basename of the filename.
+ -
+ - That allows multiple files with the same names to have different keys,
+ - while also allowing a file to be moved around while retaining the
+ - same key.
+ -}
+keyValue :: FilePath -> Annex (Maybe Key)
+keyValue file = do
+	stat <- liftIO $ getFileStatus file
+	return $ Just Key {
+		keyName = takeFileName file,
+		keyBackendName = name backend,
+		keySize = Just $ fromIntegral $ fileSize stat,
+		keyMtime = Just $ modificationTime stat
+	}

Build/Configure.hs

@@ -0,0 +1,114 @@
+{- Checks system configuration and generates SysConfig.hs. -}
+
+module Build.Configure where
+
+import System.Directory
+import Data.List
+import System.Cmd.Utils
+import Control.Applicative
+import System.FilePath
+
+import Build.TestConfig
+import Utility.SafeCommand
+
+tests :: [TestCase]
+tests =
+	[ TestCase "version" getVersion
+	, TestCase "git" $ requireCmd "git" "git --version >/dev/null"
+	, TestCase "git version" getGitVersion
+	, testCp "cp_a" "-a"
+	, testCp "cp_p" "-p"
+	, testCp "cp_reflink_auto" "--reflink=auto"
+	, TestCase "uuid generator" $ selectCmd "uuid" ["uuid", "uuidgen"] ""
+	, TestCase "xargs -0" $ requireCmd "xargs_0" "xargs -0 </dev/null"
+	, TestCase "rsync" $ requireCmd "rsync" "rsync --version >/dev/null"
+	, TestCase "curl" $ testCmd "curl" "curl --version >/dev/null"
+	, TestCase "wget" $ testCmd "wget" "wget --version >/dev/null"
+	, TestCase "bup" $ testCmd "bup" "bup --version >/dev/null"
+	, TestCase "gpg" $ testCmd "gpg" "gpg --version >/dev/null"
+	, TestCase "ssh connection caching" getSshConnectionCaching
+	] ++ shaTestCases False [1, 512, 224, 384] ++ shaTestCases True [256]
+
+shaTestCases :: Bool -> [Int] -> [TestCase]
+shaTestCases required l = map make l
+	where
+		make n = TestCase key $ selector key (shacmds n) "</dev/null"
+			where
+				key = "sha" ++ show n
+		selector = if required then selectCmd else maybeSelectCmd
+		shacmds n = concatMap (\x -> [x, osxpath </> x]) $
+			map (\x -> "sha" ++ show n ++ x) ["", "sum"]
+		-- Max OSX puts GNU tools outside PATH, so look in
+		-- the location it uses, and remember where to run them
+		-- from.
+		osxpath = "/opt/local/libexec/gnubin"
+
+tmpDir :: String
+tmpDir = "tmp"
+
+testFile :: String
+testFile = tmpDir ++ "/testfile"
+
+testCp :: ConfigKey -> String -> TestCase
+testCp k option = TestCase cmd $ testCmd k cmdline
+	where
+		cmd = "cp " ++ option
+		cmdline = cmd ++ " " ++ testFile ++ " " ++ testFile ++ ".new"
+
+{- Pulls package version out of the changelog. -}
+getVersion :: Test
+getVersion = do
+	version <- getVersionString
+	return $ Config "packageversion" (StringConfig version)
+	
+getVersionString :: IO String
+getVersionString = do
+	changelog <- readFile "CHANGELOG"
+	let verline = head $ lines changelog
+	return $ middle (words verline !! 1)
+	where
+		middle = drop 1 . init
+
+getGitVersion :: Test
+getGitVersion = do
+	(_, s) <- pipeFrom "git" ["--version"]
+	let version = last $ words $ head $ lines s
+	return $ Config "gitversion" (StringConfig version)
+
+getSshConnectionCaching :: Test
+getSshConnectionCaching = Config "sshconnectioncaching" . BoolConfig <$>
+	boolSystem "sh" [Param "-c", Param "ssh -o ControlPersist=yes -V >/dev/null 2>/dev/null"]
+
+{- Set up cabal file with version. -}
+cabalSetup :: IO ()
+cabalSetup = do
+	version <- getVersionString
+	cabal <- readFile cabalfile
+	writeFile tmpcabalfile $ unlines $ 
+		map (setfield "Version" version) $
+		lines cabal
+	renameFile tmpcabalfile cabalfile
+	where
+		cabalfile = "git-annex.cabal"
+		tmpcabalfile = cabalfile++".tmp"
+		setfield field value s
+			| fullfield `isPrefixOf` s = fullfield ++ value
+			| otherwise = s
+			where
+				fullfield = field ++ ": "
+
+setup :: IO ()
+setup = do
+	createDirectoryIfMissing True tmpDir
+	writeFile testFile "test file contents"
+
+cleanup :: IO ()
+cleanup = removeDirectoryRecursive tmpDir
+
+run :: [TestCase] -> IO ()
+run ts = do
+	setup
+	config <- runTests ts
+	writeSysConfig config
+	cleanup
+	cabalSetup

Build/TestConfig.hs

@@ -0,0 +1,120 @@
+{- Tests the system and generates Build.SysConfig.hs. -}
+
+module Build.TestConfig where
+
+import System.IO
+import System.Cmd
+import System.Exit
+
+type ConfigKey = String
+data ConfigValue =
+	BoolConfig Bool |
+	StringConfig String |
+	MaybeStringConfig (Maybe String) |
+	MaybeBoolConfig (Maybe Bool)
+data Config = Config ConfigKey ConfigValue
+
+type Test = IO Config
+type TestName = String
+data TestCase = TestCase TestName Test
+
+instance Show ConfigValue where
+	show (BoolConfig b) = show b
+	show (StringConfig s) = show s
+	show (MaybeStringConfig s) = show s
+	show (MaybeBoolConfig s) = show s
+
+instance Show Config where
+	show (Config key value) = unlines
+		[ key ++ " :: " ++ valuetype value
+		, key ++ " = " ++ show value
+		]
+		where
+			valuetype (BoolConfig _) = "Bool"
+			valuetype (StringConfig _) = "String"
+			valuetype (MaybeStringConfig _) = "Maybe String"
+			valuetype (MaybeBoolConfig _) = "Maybe Bool"
+
+writeSysConfig :: [Config] -> IO ()
+writeSysConfig config = writeFile "Build/SysConfig.hs" body
+	where
+		body = unlines $ header ++ map show config ++ footer
+		header = [
+			  "{- Automatically generated. -}"
+			, "module Build.SysConfig where"
+			, ""
+			]
+		footer = []
+
+runTests :: [TestCase] -> IO [Config]
+runTests [] = return []
+runTests (TestCase tname t : ts) = do
+	testStart tname
+	c <- t
+	testEnd c
+	rest <- runTests ts
+	return $ c:rest
+
+{- Tests that a command is available, aborting if not. -}
+requireCmd :: ConfigKey -> String -> Test
+requireCmd k cmdline = do
+	ret <- testCmd k cmdline
+	handle ret
+	where
+		handle r@(Config _ (BoolConfig True)) = return r
+		handle r = do
+			testEnd r
+			error $ "** the " ++ c ++ " command is required"
+		c = head $ words cmdline
+
+{- Checks if a command is available by running a command line. -}
+testCmd :: ConfigKey -> String -> Test
+testCmd k cmdline = do
+	ret <- system $ quiet cmdline
+	return $ Config k (BoolConfig $ ret == ExitSuccess)
+
+{- Ensures that one of a set of commands is available by running each in
+ - turn. The Config is set to the first one found. -}
+selectCmd :: ConfigKey -> [String] -> String -> Test
+selectCmd k = searchCmd
+		(return . Config k . StringConfig)
+		(\cmds -> do
+			testEnd $ Config k $ BoolConfig False
+			error $ "* need one of these commands, but none are available: " ++ show cmds
+		)
+
+maybeSelectCmd :: ConfigKey -> [String] -> String -> Test
+maybeSelectCmd k = searchCmd
+		(return . Config k . MaybeStringConfig . Just)
+		(\_ -> return $ Config k $ MaybeStringConfig Nothing)
+
+searchCmd :: (String -> Test) -> ([String] -> Test) -> [String] -> String -> Test
+searchCmd success failure cmds param = search cmds
+	where
+		search [] = failure cmds
+		search (c:cs) = do
+			ret <- system $ quiet c ++ " " ++ param
+			if ret == ExitSuccess
+				then success c
+				else search cs
+
+quiet :: String -> String
+quiet s = s ++ " >/dev/null 2>&1"
+
+testStart :: TestName -> IO ()
+testStart s = do
+	putStr $ "  checking " ++ s ++ "..."
+	hFlush stdout
+
+testEnd :: Config -> IO ()
+testEnd (Config _ (BoolConfig True)) = status "yes"
+testEnd (Config _ (BoolConfig False)) = status "no"
+testEnd (Config _ (StringConfig s)) = status s
+testEnd (Config _ (MaybeStringConfig (Just s))) = status s
+testEnd (Config _ (MaybeStringConfig Nothing)) = status "not available"
+testEnd (Config _ (MaybeBoolConfig (Just True))) = status "yes"
+testEnd (Config _ (MaybeBoolConfig (Just False))) = status "no"
+testEnd (Config _ (MaybeBoolConfig Nothing)) = status "unknown"
+
+status :: String -> IO ()
+status s = putStrLn $ ' ':s

CHANGELOG

@@ -0,0 +1 @@
+debian/changelog

Checks.hs

@@ -0,0 +1,31 @@
+{- git-annex command checks
+ -
+ - Common sanity checks for commands, and an interface to selectively
+ - remove them, or add others.
+ - 
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Checks where
+
+import Common.Annex
+import Types.Command
+import Init
+
+commonChecks :: [CommandCheck]
+commonChecks = [repoExists]
+
+repoExists :: CommandCheck
+repoExists = CommandCheck 0 ensureInitialized
+
+dontCheck :: CommandCheck -> Command -> Command
+dontCheck check cmd = mutateCheck cmd $ \c -> filter (/= check) c
+
+addCheck :: Annex () -> Command -> Command
+addCheck check cmd = mutateCheck cmd $ \c ->
+	CommandCheck (length c + 100) check : c
+
+mutateCheck :: Command -> ([CommandCheck] -> [CommandCheck]) -> Command
+mutateCheck cmd@(Command { cmdcheck = c }) a = cmd { cmdcheck = a c }

CmdLine.hs

@@ -0,0 +1,119 @@
+{- git-annex command line parsing and dispatch
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module CmdLine (
+	dispatch,
+	usage,
+	shutdown
+) where
+
+import qualified Control.Exception as E
+import qualified Data.Map as M
+import Control.Exception (throw)
+import System.Console.GetOpt
+
+import Common.Annex
+import qualified Annex
+import qualified Annex.Queue
+import qualified Git
+import qualified Git.Command
+import qualified Git.AutoCorrect
+import Annex.Content
+import Annex.Ssh
+import Command
+
+type Params = [String]
+type Flags = [Annex ()]
+
+{- Runs the passed command line. -}
+dispatch :: Bool -> Params -> [Command] -> [Option] -> String -> IO Git.Repo -> IO ()
+dispatch fuzzyok allargs allcmds commonoptions header getgitrepo = do
+	setupConsole
+	r <- E.try getgitrepo :: IO (Either E.SomeException Git.Repo)
+	case r of
+		Left e -> fromMaybe (throw e) (cmdnorepo cmd)
+		Right g -> do
+			state <- Annex.new g
+			(actions, state') <- Annex.run state $ do
+				checkfuzzy
+				sequence_ flags
+				prepCommand cmd params
+		 	tryRun state' cmd $ [startup] ++ actions ++ [shutdown $ cmdoneshot cmd]
+	where
+		err msg = msg ++ "\n\n" ++ usage header allcmds commonoptions
+		cmd = Prelude.head cmds
+		(fuzzy, cmds, name, args) = findCmd fuzzyok allargs allcmds err
+		(flags, params) = getOptCmd args cmd commonoptions err
+		checkfuzzy = when fuzzy $
+			inRepo $ Git.AutoCorrect.prepare name cmdname cmds
+
+{- Parses command line params far enough to find the Command to run, and
+ - returns the remaining params.
+ - Does fuzzy matching if necessary, which may result in multiple Commands. -}
+findCmd :: Bool -> Params -> [Command] -> (String -> String) -> (Bool, [Command], String, Params)
+findCmd fuzzyok argv cmds err
+	| isNothing name = error $ err "missing command"
+	| not (null exactcmds) = (False, exactcmds, fromJust name, args)
+	| fuzzyok && not (null inexactcmds) = (True, inexactcmds, fromJust name, args)
+	| otherwise = error $ err $ "unknown command " ++ fromJust name
+	where
+		(name, args) = findname argv []
+		findname [] c = (Nothing, reverse c)
+		findname (a:as) c
+			| "-" `isPrefixOf` a = findname as (a:c)
+			| otherwise = (Just a, reverse c ++ as)
+		exactcmds = filter (\c -> name == Just (cmdname c)) cmds
+		inexactcmds = case name of
+			Nothing -> []
+			Just n -> Git.AutoCorrect.fuzzymatches n cmdname cmds
+
+{- Parses command line options, and returns actions to run to configure flags
+ - and the remaining parameters for the command. -}
+getOptCmd :: Params -> Command -> [Option] -> (String -> String) -> (Flags, Params)
+getOptCmd argv cmd commonoptions err = check $
+	getOpt Permute (commonoptions ++ cmdoptions cmd) argv
+	where
+		check (flags, rest, []) = (flags, rest)
+		check (_, _, errs) = error $ err $ concat errs
+
+{- Runs a list of Annex actions. Catches IO errors and continues
+ - (but explicitly thrown errors terminate the whole command).
+ -}
+tryRun :: Annex.AnnexState -> Command -> [CommandCleanup] -> IO ()
+tryRun = tryRun' 0
+tryRun' :: Integer -> Annex.AnnexState -> Command -> [CommandCleanup] -> IO ()
+tryRun' errnum _ cmd []
+	| errnum > 0 = error $ cmdname cmd ++ ": " ++ show errnum ++ " failed"
+	| otherwise = noop
+tryRun' errnum state cmd (a:as) = do
+	r <- run
+	handle $! r
+	where
+		run = tryIO $ Annex.run state $ do
+			Annex.Queue.flushWhenFull
+			a
+		handle (Left err) = showerr err >> cont False state
+		handle (Right (success, state')) = cont success state'
+		cont success s = do
+			let errnum' = if success then errnum else errnum + 1
+			(tryRun' $! errnum') s cmd as
+		showerr err = Annex.eval state $ do
+			showErr err
+			showEndFail
+
+{- Actions to perform each time ran. -}
+startup :: Annex Bool
+startup = return True
+
+{- Cleanup actions. -}
+shutdown :: Bool -> Annex Bool
+shutdown oneshot = do
+	saveState oneshot
+	sequence_ =<< M.elems <$> Annex.getState Annex.cleanup
+	liftIO Git.Command.reap -- zombies from long-running git processes
+	sshCleanup -- ssh connection caching
+	return True

Command.hs

@@ -0,0 +1,124 @@
+{- git-annex command infrastructure
+ -
+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command (
+	command,
+	noRepo,
+	oneShot,
+	withOptions,
+	next,
+	stop,
+	stopUnless,
+	prepCommand,
+	doCommand,
+	whenAnnexed,
+	ifAnnexed,
+	notBareRepo,
+	isBareRepo,
+	numCopies,
+	autoCopies,
+	module ReExported
+) where
+
+import Common.Annex
+import qualified Backend
+import qualified Annex
+import qualified Git
+import qualified Remote
+import Types.Command as ReExported
+import Types.Option as ReExported
+import Seek as ReExported
+import Checks as ReExported
+import Usage as ReExported
+import Logs.Trust
+import Config
+import Annex.CheckAttr
+
+{- Generates a normal command -}
+command :: String -> String -> [CommandSeek] -> String -> Command
+command = Command [] Nothing commonChecks False
+
+{- Makes a command run in oneshot mode. -}
+oneShot :: Command -> Command
+oneShot c = c { cmdoneshot = True }
+
+{- Adds a fallback action to a command, that will be run if it's used
+ - outside a git repository. -}
+noRepo :: IO () -> Command -> Command
+noRepo a c = c { cmdnorepo = Just a }
+
+{- Adds options to a command. -}
+withOptions :: [Option] -> Command -> Command
+withOptions o c = c { cmdoptions = o }
+
+{- For start and perform stages to indicate what step to run next. -}
+next :: a -> Annex (Maybe a)
+next a = return $ Just a
+
+{- Or to indicate nothing needs to be done. -}
+stop :: Annex (Maybe a)
+stop = return Nothing
+
+{- Stops unless a condition is met. -}
+stopUnless :: Annex Bool -> Annex (Maybe a) -> Annex (Maybe a)
+stopUnless c a = ifM c ( a , stop )
+
+{- Prepares to run a command via the check and seek stages, returning a
+ - list of actions to perform to run the command. -}
+prepCommand :: Command -> [String] -> Annex [CommandCleanup]
+prepCommand Command { cmdseek = seek, cmdcheck = c } params = do
+	mapM_ runCheck c
+	map doCommand . concat <$> mapM (\s -> s params) seek
+
+{- Runs a command through the start, perform and cleanup stages -}
+doCommand :: CommandStart -> CommandCleanup
+doCommand = start
+	where
+		start   = stage $ maybe skip perform
+		perform = stage $ maybe failure cleanup
+		cleanup = stage $ status
+		stage = (=<<)
+		skip = return True
+		failure = showEndFail >> return False
+		status r = showEndResult r >> return r
+
+{- Modifies an action to only act on files that are already annexed,
+ - and passes the key and backend on to it. -}
+whenAnnexed :: (FilePath -> (Key, Backend) -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a)
+whenAnnexed a file = ifAnnexed file (a file) (return Nothing)
+
+ifAnnexed :: FilePath -> ((Key, Backend) -> Annex a) -> Annex a -> Annex a
+ifAnnexed file yes no = maybe no yes =<< Backend.lookupFile file
+
+notBareRepo :: Annex a -> Annex a
+notBareRepo a = do
+	whenM isBareRepo $
+		error "You cannot run this subcommand in a bare repository."
+	a
+
+isBareRepo :: Annex Bool
+isBareRepo = fromRepo Git.repoIsLocalBare
+
+numCopies :: FilePath  -> Annex (Maybe Int)
+numCopies file = readish <$> checkAttr "annex.numcopies" file
+
+{- Used for commands that have an auto mode that checks the number of known
+ - copies of a key.
+ -
+ - In auto mode, first checks that the number of known
+ - copies of the key is > or < than the numcopies setting, before running
+ - the action. -}
+autoCopies :: FilePath -> Key -> (Int -> Int -> Bool) -> (Maybe Int -> CommandStart) -> CommandStart
+autoCopies file key vs a = do
+	numcopiesattr <- numCopies file
+	Annex.getState Annex.auto >>= auto numcopiesattr
+	where
+		auto numcopiesattr False = a numcopiesattr
+		auto numcopiesattr True = do
+			needed <- getNumCopies numcopiesattr
+			(_, have) <- trustPartition UnTrusted =<< Remote.keyLocations key
+			if length have `vs` needed then a numcopiesattr else stop

Command/Add.hs

@@ -0,0 +1,93 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Add where
+
+import Common.Annex
+import Annex.Exception
+import Command
+import qualified Annex
+import qualified Annex.Queue
+import qualified Backend
+import Logs.Location
+import Annex.Content
+import Utility.Touch
+
+def :: [Command]
+def = [command "add" paramPaths seek "add files to annex"]
+
+{- Add acts on both files not checked into git yet, and unlocked files. -}
+seek :: [CommandSeek]
+seek = [withFilesNotInGit start, withFilesUnlocked start]
+
+{- The add subcommand annexes a file, storing it in a backend, and then
+ - moving it into the annex directory and setting up the symlink pointing
+ - to its content. -}
+start :: FilePath -> CommandStart
+start file = notBareRepo $ ifAnnexed file fixup add
+	where
+		add = do
+			s <- liftIO $ getSymbolicLinkStatus file
+			if isSymbolicLink s || not (isRegularFile s)
+				then stop
+				else do
+					showStart "add" file
+					next $ perform file
+		fixup (key, _) = do
+			-- fixup from an interrupted add; the symlink
+			-- is present but not yet added to git
+			showStart "add" file
+			liftIO $ removeFile file
+			next $ next $ cleanup file key =<< inAnnex key
+
+perform :: FilePath -> CommandPerform
+perform file = do
+	backend <- Backend.chooseBackend file
+	Backend.genKey file backend >>= go
+	where
+		go Nothing = stop
+		go (Just (key, _)) = do
+			handle (undo file key) $ moveAnnex key file
+			next $ cleanup file key True
+
+{- On error, put the file back so it doesn't seem to have vanished.
+ - This can be called before or after the symlink is in place. -}
+undo :: FilePath -> Key -> IOException -> Annex a
+undo file key e = do
+	whenM (inAnnex key) $ do
+		liftIO $ whenM (doesFileExist file) $ removeFile file
+		handle tryharder $ fromAnnex key file
+		logStatus key InfoMissing
+	throw e
+	where
+		-- fromAnnex could fail if the file ownership is weird
+		tryharder :: IOException -> Annex ()
+		tryharder _ = do
+			src <- inRepo $ gitAnnexLocation key
+			liftIO $ moveFile src file
+
+cleanup :: FilePath -> Key -> Bool -> CommandCleanup
+cleanup file key hascontent = do
+	handle (undo file key) $ do
+		link <- calcGitLink file key
+		liftIO $ createSymbolicLink link file
+
+		when hascontent $ do
+			logStatus key InfoPresent
+	
+			-- touch the symlink to have the same mtime as the
+			-- file it points to
+			liftIO $ do
+				mtime <- modificationTime <$> getFileStatus file
+				touch file (TimeSpec mtime) False
+
+	params <- ifM (Annex.getState Annex.force)
+		( return [Param "-f"]
+		, return []
+		)
+	Annex.Queue.add "add" (params++[Param "--"]) [file]
+	return True

Command/AddUnused.hs

@@ -0,0 +1,34 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.AddUnused where
+
+import Common.Annex
+import Logs.Unused
+import Command
+import qualified Command.Add
+
+def :: [Command]
+def = [command "addunused" (paramRepeating paramNumRange)
+	seek "add back unused files"]
+
+seek :: [CommandSeek]
+seek = [withUnusedMaps start]
+
+start :: UnusedMaps -> Int -> CommandStart
+start = startUnused "addunused" perform (performOther "bad") (performOther "tmp")
+
+perform :: Key -> CommandPerform
+perform key = next $ Command.Add.cleanup file key True
+	where
+		file = "unused." ++ show key
+
+{- The content is not in the annex, but in another directory, and
+ - it seems better to error out, rather than moving bad/tmp content into
+ - the annex. -}
+performOther :: String -> Key -> CommandPerform
+performOther other _ = error $ "cannot addunused " ++ other ++ "content"

Command/AddUrl.hs

@@ -0,0 +1,110 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.AddUrl where
+
+import Network.URI
+
+import Common.Annex
+import Command
+import qualified Backend
+import qualified Command.Add
+import qualified Annex
+import qualified Backend.URL
+import qualified Utility.Url as Url
+import Annex.Content
+import Logs.Web
+import qualified Option
+import Types.Key
+import Config
+
+def :: [Command]
+def = [withOptions [fileOption, pathdepthOption] $
+	command "addurl" (paramRepeating paramUrl) seek "add urls to annex"]
+
+fileOption :: Option
+fileOption = Option.field [] "file" paramFile "specify what file the url is added to"
+
+pathdepthOption :: Option
+pathdepthOption = Option.field [] "pathdepth" paramNumber "path components to use in filename"
+
+seek :: [CommandSeek]
+seek = [withField fileOption return $ \f ->
+	withField pathdepthOption (return . maybe Nothing readish) $ \d ->
+	withStrings $ start f d]
+
+start :: Maybe FilePath -> Maybe Int -> String -> CommandStart
+start optfile pathdepth s = notBareRepo $ go $ fromMaybe bad $ parseURI s
+	where
+		bad = fromMaybe (error $ "bad url " ++ s) $
+			parseURI $ escapeURIString isUnescapedInURI s
+		go url = do
+			let file = fromMaybe (url2file url pathdepth) optfile
+			showStart "addurl" file
+			next $ perform s file
+
+perform :: String -> FilePath -> CommandPerform
+perform url file = ifAnnexed file addurl geturl
+	where
+		geturl = do
+			liftIO $ createDirectoryIfMissing True (parentDir file)
+			ifM (Annex.getState Annex.fast)
+				( nodownload url file , download url file )
+		addurl (key, _backend) = do
+			headers <- getHttpHeaders
+			ifM (liftIO $ Url.check url headers $ keySize key)
+				( do
+					setUrlPresent key url
+					next $ return True
+				, do
+					warning $ "failed to verify url: " ++ url
+					stop
+				)
+
+download :: String -> FilePath -> CommandPerform
+download url file = do
+	showAction $ "downloading " ++ url ++ " "
+	let dummykey = Backend.URL.fromUrl url Nothing
+	tmp <- fromRepo $ gitAnnexTmpLocation dummykey
+	liftIO $ createDirectoryIfMissing True (parentDir tmp)
+	stopUnless (downloadUrl [url] tmp) $ do
+		backend <- Backend.chooseBackend file
+		k <- Backend.genKey tmp backend
+		case k of
+			Nothing -> stop
+			Just (key, _) -> do
+				moveAnnex key tmp
+				setUrlPresent key url
+				next $ Command.Add.cleanup file key True
+
+nodownload :: String -> FilePath -> CommandPerform
+nodownload url file = do
+	headers <- getHttpHeaders
+	(exists, size) <- liftIO $ Url.exists url headers
+	if exists
+		then do
+			let key = Backend.URL.fromUrl url size
+			setUrlPresent key url
+			next $ Command.Add.cleanup file key False
+		else do
+			warning $ "unable to access url: " ++ url
+			stop
+
+url2file :: URI -> Maybe Int -> FilePath
+url2file url pathdepth = case pathdepth of
+	Nothing -> filesize $ escape fullurl
+	Just depth
+		| depth > 0 -> frombits $ drop depth
+		| depth < 0 -> frombits $ reverse . take (negate depth) . reverse
+		| otherwise -> error "bad --pathdepth"
+	where
+		fullurl = uriRegName auth ++ uriPath url ++ uriQuery url
+		frombits a = join "/" $ a urlbits
+		urlbits = map (filesize . escape) $ filter (not . null) $ split "/" fullurl
+		auth = fromMaybe (error $ "bad url " ++ show url) $ uriAuthority url
+		filesize = take 255
+		escape = replace "/" "_" . replace "?" "_"

Command/Commit.hs

@@ -0,0 +1,29 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Commit where
+
+import Common.Annex
+import Command
+import qualified Annex.Branch
+import qualified Git
+
+def :: [Command]
+def = [command "commit" paramNothing seek
+	"commits any staged changes to the git-annex branch"]
+
+seek :: [CommandSeek]
+seek = [withNothing start]
+
+start :: CommandStart
+start = next $ next $ do
+	Annex.Branch.commit "update"
+	_ <- runhook =<< (inRepo $ Git.hookPath "annex-content")
+	return True
+	where
+		runhook (Just hook) = liftIO $ boolSystem hook []
+		runhook Nothing = return True

Command/ConfigList.hs

@@ -0,0 +1,25 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.ConfigList where
+
+import Common.Annex
+import Command
+import Annex.UUID
+
+def :: [Command]
+def = [oneShot $ command "configlist" paramNothing seek
+	"outputs relevant git configuration"]
+
+seek :: [CommandSeek]
+seek = [withNothing start]
+
+start :: CommandStart
+start = do
+	u <- getUUID
+	liftIO $ putStrLn $ "annex.uuid=" ++ fromUUID u
+	stop

Command/Copy.hs

@@ -0,0 +1,28 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Copy where
+
+import Common.Annex
+import Command
+import qualified Command.Move
+import qualified Remote
+
+def :: [Command]
+def = [withOptions Command.Move.options $ command "copy" paramPaths seek
+	"copy content of files to/from another repository"]
+
+seek :: [CommandSeek]
+seek = [withField Command.Move.toOption Remote.byName $ \to ->
+		withField Command.Move.fromOption Remote.byName $ \from ->
+			withFilesInGit $ whenAnnexed $ start to from]
+
+-- A copy is just a move that does not delete the source file.
+-- However, --auto mode avoids unnecessary copies.
+start :: Maybe Remote -> Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
+start to from file (key, backend) = autoCopies file key (<) $ \_numcopies ->
+	Command.Move.start to from False file (key, backend)

Command/Dead.hs

@@ -0,0 +1,32 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Dead where
+
+import Common.Annex
+import Command
+import qualified Remote
+import Logs.Trust
+
+def :: [Command]
+def = [command "dead" (paramRepeating paramRemote) seek
+	"hide a lost repository"]
+
+seek :: [CommandSeek]
+seek = [withWords start]
+
+start :: [String] -> CommandStart
+start ws = do
+	let name = unwords ws
+	showStart "dead " name
+	u <- Remote.nameToUUID name
+	next $ perform u
+
+perform :: UUID -> CommandPerform
+perform uuid = do
+	trustSet uuid DeadTrusted
+	next $ return True

Command/Describe.hs

@@ -0,0 +1,32 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Describe where
+
+import Common.Annex
+import Command
+import qualified Remote
+import Logs.UUID
+
+def :: [Command]
+def = [command "describe" (paramPair paramRemote paramDesc) seek
+	"change description of a repository"]
+
+seek :: [CommandSeek]
+seek = [withWords start]
+
+start :: [String] -> CommandStart
+start (name:description) = do
+	showStart "describe" name
+	u <- Remote.nameToUUID name
+	next $ perform u $ unwords description
+start _ = error "Specify a repository and a description."	
+
+perform :: UUID -> String -> CommandPerform
+perform u description = do
+	describeUUID u description
+	next $ return True

Command/Drop.hs

@@ -0,0 +1,135 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Drop where
+
+import Common.Annex
+import Command
+import qualified Remote
+import qualified Annex
+import Annex.UUID
+import Logs.Location
+import Logs.Trust
+import Annex.Content
+import Config
+import qualified Option
+
+def :: [Command]
+def = [withOptions [fromOption] $ command "drop" paramPaths seek
+	"indicate content of files not currently wanted"]
+
+fromOption :: Option
+fromOption = Option.field ['f'] "from" paramRemote "drop content from a remote"
+
+seek :: [CommandSeek]
+seek = [withField fromOption Remote.byName $ \from ->
+	withFilesInGit $ whenAnnexed $ start from]
+
+start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
+start from file (key, _) = autoCopies file key (>) $ \numcopies ->
+	case from of
+		Nothing -> startLocal file numcopies key
+		Just remote -> do
+			u <- getUUID
+			if Remote.uuid remote == u
+				then startLocal file numcopies key
+				else startRemote file numcopies key remote
+
+startLocal :: FilePath -> Maybe Int -> Key -> CommandStart
+startLocal file numcopies key = stopUnless (inAnnex key) $ do
+	showStart "drop" file
+	next $ performLocal key numcopies
+
+startRemote :: FilePath -> Maybe Int -> Key -> Remote -> CommandStart
+startRemote file numcopies key remote = do
+	showStart "drop" file
+	next $ performRemote key numcopies remote
+
+performLocal :: Key -> Maybe Int -> CommandPerform
+performLocal key numcopies = lockContent key $ do
+	(remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
+	untrusteduuids <- trustGet UnTrusted
+	let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids++untrusteduuids)
+	stopUnless (canDropKey key numcopies trusteduuids tocheck []) $ do
+		whenM (inAnnex key) $ removeAnnex key
+		next $ cleanupLocal key
+
+performRemote :: Key -> Maybe Int -> Remote -> CommandPerform
+performRemote key numcopies remote = lockContent key $ do
+	-- Filter the remote it's being dropped from out of the lists of
+	-- places assumed to have the key, and places to check.
+	-- When the local repo has the key, that's one additional copy.
+	(remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
+	present <- inAnnex key
+	u <- getUUID
+	let have = filter (/= uuid) $
+		if present then u:trusteduuids else trusteduuids
+	untrusteduuids <- trustGet UnTrusted
+	let tocheck = filter (/= remote) $
+		Remote.remotesWithoutUUID remotes (have++untrusteduuids)
+	stopUnless (canDropKey key numcopies have tocheck [uuid]) $ do
+		ok <- Remote.removeKey remote key
+		next $ cleanupRemote key remote ok
+	where
+		uuid = Remote.uuid remote
+
+cleanupLocal :: Key -> CommandCleanup
+cleanupLocal key = do
+	logStatus key InfoMissing
+	return True
+
+cleanupRemote :: Key -> Remote -> Bool -> CommandCleanup
+cleanupRemote key remote ok = do
+	-- better safe than sorry: assume the remote dropped the key
+	-- even if it seemed to fail; the failure could have occurred
+	-- after it really dropped it
+	Remote.logStatus remote key InfoMissing
+	return ok
+
+{- Checks specified remotes to verify that enough copies of a key exist to
+ - allow it to be safely removed (with no data loss). Can be provided with
+ - some locations where the key is known/assumed to be present. -}
+canDropKey :: Key -> Maybe Int -> [UUID] -> [Remote] -> [UUID] -> Annex Bool
+canDropKey key numcopiesM have check skip = do
+	force <- Annex.getState Annex.force
+	if force || numcopiesM == Just 0
+		then return True
+		else do
+			need <- getNumCopies numcopiesM
+			findCopies key need skip have check
+
+findCopies :: Key -> Int -> [UUID] -> [UUID] -> [Remote] -> Annex Bool
+findCopies key need skip = helper []
+	where
+		helper bad have []
+			| length have >= need = return True
+			| otherwise = notEnoughCopies key need have skip bad
+		helper bad have (r:rs)
+			| length have >= need = return True
+			| otherwise = do
+				let u = Remote.uuid r
+				let duplicate = u `elem` have
+				haskey <- Remote.hasKey r key
+				case (duplicate, haskey) of
+					(False, Right True) -> helper bad (u:have) rs
+					(False, Left _)     -> helper (r:bad) have rs
+					_                   -> helper bad have rs
+
+notEnoughCopies :: Key -> Int -> [UUID] -> [UUID] -> [Remote] -> Annex Bool
+notEnoughCopies key need have skip bad = do
+	unsafe
+	showLongNote $
+		"Could only verify the existence of " ++
+		show (length have) ++ " out of " ++ show need ++ 
+		" necessary copies"
+	Remote.showTriedRemotes bad
+	Remote.showLocations key (have++skip)
+	hint
+	return False
+	where
+		unsafe = showNote "unsafe"
+		hint = showLongNote "(Use --force to override this check, or adjust annex.numcopies.)"

Command/DropKey.hs

@@ -0,0 +1,38 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.DropKey where
+
+import Common.Annex
+import Command
+import qualified Annex
+import Logs.Location
+import Annex.Content
+
+def :: [Command]
+def = [oneShot $ command "dropkey" (paramRepeating paramKey) seek
+	"drops annexed content for specified keys"] 
+
+seek :: [CommandSeek]
+seek = [withKeys start]
+
+start :: Key -> CommandStart
+start key = stopUnless (inAnnex key) $ do
+	unlessM (Annex.getState Annex.force) $
+		error "dropkey can cause data loss; use --force if you're sure you want to do this"
+	showStart "dropkey" (show key)
+	next $ perform key
+
+perform :: Key -> CommandPerform
+perform key = lockContent key $ do
+	removeAnnex key
+	next $ cleanup key
+
+cleanup :: Key -> CommandCleanup
+cleanup key = do
+	logStatus key InfoMissing
+	return True

Command/DropUnused.hs

@@ -0,0 +1,44 @@
+{- git-annex command
+ -
+ - Copyright 2010,2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.DropUnused where
+
+import Logs.Unused
+import Common.Annex
+import Command
+import qualified Annex
+import qualified Command.Drop
+import qualified Remote
+import qualified Git
+import qualified Option
+
+def :: [Command]
+def = [withOptions [Command.Drop.fromOption] $
+	command "dropunused" (paramRepeating paramNumRange)
+		seek "drop unused file content"]
+
+seek :: [CommandSeek]
+seek = [withUnusedMaps start]
+
+start :: UnusedMaps -> Int -> CommandStart
+start = startUnused "dropunused" perform (performOther gitAnnexBadLocation) (performOther gitAnnexTmpLocation)
+
+perform :: Key -> CommandPerform
+perform key = maybe droplocal dropremote =<< Remote.byName =<< from
+	where
+		dropremote r = do
+			showAction $ "from " ++ Remote.name r
+			ok <- Remote.removeKey r key
+			next $ Command.Drop.cleanupRemote key r ok
+		droplocal = Command.Drop.performLocal key (Just 0) -- force drop
+		from = Annex.getField $ Option.name Command.Drop.fromOption
+
+performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform
+performOther filespec key = do
+	f <- fromRepo $ filespec key
+	liftIO $ whenM (doesFileExist f) $ removeFile f
+	next $ return True

Command/Find.hs

@@ -0,0 +1,61 @@
+{- git-annex command
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Find where
+
+import qualified Data.Map as M
+
+import Common.Annex
+import Command
+import Annex.Content
+import Limit
+import qualified Annex
+import qualified Utility.Format
+import Utility.DataUnits
+import Types.Key
+import qualified Option
+
+def :: [Command]
+def = [withOptions [formatOption, print0Option] $
+	command "find" paramPaths seek "lists available files"]
+
+formatOption :: Option
+formatOption = Option.field [] "format" paramFormat "control format of output"
+
+print0Option :: Option
+print0Option = Option.Option [] ["print0"] (Option.NoArg set)
+	"terminate output with null"
+	where
+		set = Annex.setField (Option.name formatOption) "${file}\0"
+
+seek :: [CommandSeek]
+seek = [withField formatOption formatconverter $ \f ->
+		withFilesInGit $ whenAnnexed $ start f]
+	where
+		formatconverter = return . fmap Utility.Format.gen
+
+start :: Maybe Utility.Format.Format -> FilePath -> (Key, Backend) -> CommandStart
+start format file (key, _) = do
+	-- only files inAnnex are shown, unless the user has requested
+	-- others via a limit
+	whenM (limited <||> inAnnex key) $
+		unlessM (showFullJSON vars) $
+			case format of
+				Nothing -> liftIO $ putStrLn file
+				Just formatter -> liftIO $ putStr $
+					Utility.Format.format formatter $
+						M.fromList vars
+	stop
+	where
+		vars =
+			[ ("file", file)
+			, ("key", show key)
+			, ("backend", keyBackendName key)
+			, ("bytesize", size show)
+			, ("humansize", size $ roughSize storageUnits True)
+			]
+		size c = maybe "unknown" c $ keySize key

Command/Fix.hs

@@ -0,0 +1,40 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Fix where
+
+import Common.Annex
+import Command
+import qualified Annex.Queue
+import Annex.Content
+
+def :: [Command]
+def = [command "fix" paramPaths seek
+	"fix up symlinks to point to annexed content"]
+
+seek :: [CommandSeek]
+seek = [withFilesInGit $ whenAnnexed start]
+
+{- Fixes the symlink to an annexed file. -}
+start :: FilePath -> (Key, Backend) -> CommandStart
+start file (key, _) = do
+	link <- calcGitLink file key
+	stopUnless ((/=) link <$> liftIO (readSymbolicLink file)) $ do
+		showStart "fix" file
+		next $ perform file link
+
+perform :: FilePath -> FilePath -> CommandPerform
+perform file link = do
+	liftIO $ createDirectoryIfMissing True (parentDir file)
+	liftIO $ removeFile file
+	liftIO $ createSymbolicLink link file
+	next $ cleanup file
+
+cleanup :: FilePath -> CommandCleanup
+cleanup file = do
+	Annex.Queue.add "add" [Param "--force", Param "--"] [file]
+	return True

Command/FromKey.hs

@@ -0,0 +1,43 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.FromKey where
+
+import Common.Annex
+import Command
+import qualified Annex.Queue
+import Annex.Content
+import Types.Key
+
+def :: [Command]
+def = [command "fromkey" (paramPair paramKey paramPath) seek
+	"adds a file using a specific key"]
+
+seek :: [CommandSeek]
+seek = [withWords start]
+
+start :: [String] -> CommandStart
+start (keyname:file:[]) = notBareRepo $ do
+	let key = fromMaybe (error "bad key") $ readKey keyname
+	inbackend <- inAnnex key
+	unless inbackend $ error $
+		"key ("++ keyname ++") is not present in backend"
+	showStart "fromkey" file
+	next $ perform key file
+start _ = error "specify a key and a dest file"
+
+perform :: Key -> FilePath -> CommandPerform
+perform key file = do
+	link <- calcGitLink file key
+	liftIO $ createDirectoryIfMissing True (parentDir file)
+	liftIO $ createSymbolicLink link file
+	next $ cleanup file
+
+cleanup :: FilePath -> CommandCleanup
+cleanup file = do
+	Annex.Queue.add "add" [Param "--"] [file]
+	return True

Command/Fsck.hs

@@ -0,0 +1,300 @@
+{- git-annex command
+ -
+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Fsck where
+
+import Common.Annex
+import Command
+import qualified Annex
+import qualified Annex.Queue
+import qualified Remote
+import qualified Types.Backend
+import qualified Types.Key
+import qualified Backend
+import Annex.Content
+import Logs.Location
+import Logs.Trust
+import Annex.UUID
+import Utility.DataUnits
+import Utility.FileMode
+import Config
+import qualified Option
+
+def :: [Command]
+def = [withOptions options $ command "fsck" paramPaths seek
+	"check for problems"]
+
+fromOption :: Option
+fromOption = Option.field ['f'] "from" paramRemote "check remote"
+
+options :: [Option]
+options = [fromOption]
+
+seek :: [CommandSeek]
+seek =
+	[ withField fromOption Remote.byName $ \from ->
+		withFilesInGit $ whenAnnexed $ start from
+	, withBarePresentKeys startBare
+	]
+
+start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
+start from file (key, backend) = do
+	numcopies <- numCopies file
+	showStart "fsck" file
+	case from of
+		Nothing -> next $ perform key file backend numcopies
+		Just r -> next $ performRemote key file backend numcopies r
+
+perform :: Key -> FilePath -> Backend -> Maybe Int -> CommandPerform
+perform key file backend numcopies = check
+	-- order matters
+	[ fixLink key file
+	, verifyLocationLog key file
+	, checkKeySize key
+	, checkBackend backend key
+	, checkKeyNumCopies key file numcopies
+	]
+
+{- To fsck a remote, the content is retrieved to a tmp file,
+ - and checked locally. -}
+performRemote :: Key -> FilePath -> Backend -> Maybe Int -> Remote -> CommandPerform
+performRemote key file backend numcopies remote =
+	dispatch =<< Remote.hasKey remote key
+	where
+		dispatch (Left err) = do
+			showNote err
+			stop
+		dispatch (Right True) = withtmp $ \tmpfile ->
+			ifM (getfile tmpfile)
+				( go True (Just tmpfile)
+				, go True Nothing
+				)
+		dispatch (Right False) = go False Nothing
+		go present localcopy = check
+			[ verifyLocationLogRemote key file remote present
+			, checkKeySizeRemote key remote localcopy
+			, checkBackendRemote backend key remote localcopy
+			, checkKeyNumCopies key file numcopies
+			]
+		withtmp a = do
+			pid <- liftIO getProcessID
+			t <- fromRepo gitAnnexTmpDir
+			let tmp = t </> "fsck" ++ show pid ++ "." ++ keyFile key
+			liftIO $ createDirectoryIfMissing True t
+			let cleanup = liftIO $ catchIO (removeFile tmp) (const noop)
+			cleanup
+			cleanup `after` a tmp
+		getfile tmp =
+			ifM (Remote.retrieveKeyFileCheap remote key tmp)
+				( return True
+				, ifM (Annex.getState Annex.fast)
+					( return False
+					, Remote.retrieveKeyFile remote key tmp
+					)
+				)
+
+{- To fsck a bare repository, fsck each key in the location log. -}
+withBarePresentKeys :: (Key -> CommandStart) -> CommandSeek
+withBarePresentKeys a params = isBareRepo >>= go
+	where
+		go False = return []
+		go True = do
+			unless (null params) $
+				error "fsck should be run without parameters in a bare repository"
+			map a <$> loggedKeys
+
+startBare :: Key -> CommandStart
+startBare key = case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of
+	Nothing -> stop
+	Just backend -> do
+		showStart "fsck" (show key)
+		next $ performBare key backend
+
+{- Note that numcopies cannot be checked in a bare repository, because
+ - getting the numcopies value requires a working copy with .gitattributes
+ - files. -}
+performBare :: Key -> Backend -> CommandPerform
+performBare key backend = check
+	[ verifyLocationLog key (show key)
+	, checkKeySize key
+	, checkBackend backend key
+	]
+
+check :: [Annex Bool] -> CommandPerform	
+check = sequence >=> dispatch
+	where
+		dispatch vs
+			| all (== True) vs = next $ return True
+			| otherwise = stop
+
+
+{- Checks that the file's symlink points correctly to the content. -}
+fixLink :: Key -> FilePath -> Annex Bool
+fixLink key file = do
+	want <- calcGitLink file key
+	have <- liftIO $ readSymbolicLink file
+	when (want /= have) $ do
+		{- Version 3.20120227 had a bug that could cause content
+		 - to be stored in the wrong hash directory. Clean up
+		 - after the bug by moving the content.
+		 -}
+		whenM (liftIO $ doesFileExist file) $
+			unlessM (inAnnex key) $ do
+				showNote $ "fixing content location"
+				dir <- liftIO $ parentDir <$> absPath file
+				let content = absPathFrom dir have
+				liftIO $ allowWrite (parentDir content)
+				moveAnnex key content
+
+		showNote $ "fixing link"
+		liftIO $ createDirectoryIfMissing True (parentDir file)
+		liftIO $ removeFile file
+		liftIO $ createSymbolicLink want file
+		Annex.Queue.add "add" [Param "--force", Param "--"] [file]
+	return True
+
+{- Checks that the location log reflects the current status of the key,
+   in this repository only. -}
+verifyLocationLog :: Key -> String -> Annex Bool
+verifyLocationLog key desc = do
+	present <- inAnnex key
+	
+	-- Since we're checking that a key's file is present, throw
+	-- in a permission fixup here too.
+	when present $ do
+		file <- inRepo $ gitAnnexLocation key
+		freezeContent file
+		freezeContentDir file
+
+	u <- getUUID
+	verifyLocationLog' key desc present u (logChange key u)
+
+verifyLocationLogRemote :: Key -> String -> Remote -> Bool -> Annex Bool
+verifyLocationLogRemote key desc remote present =
+	verifyLocationLog' key desc present (Remote.uuid remote)
+		(Remote.logStatus remote key)
+
+verifyLocationLog' :: Key -> String -> Bool -> UUID -> (LogStatus -> Annex ()) -> Annex Bool
+verifyLocationLog' key desc present u bad = do
+	uuids <- Remote.keyLocations key
+	case (present, u `elem` uuids) of
+		(True, False) -> do
+				fix InfoPresent
+				-- There is no data loss, so do not fail.
+				return True
+		(False, True) -> do
+				fix InfoMissing
+				warning $
+					"** Based on the location log, " ++ desc
+					++ "\n** was expected to be present, " ++
+					"but its content is missing."
+				return False
+		_ -> return True
+	where
+		fix s = do
+			showNote "fixing location log"
+			bad s
+
+{- The size of the data for a key is checked against the size encoded in
+ - the key's metadata, if available. -}
+checkKeySize :: Key -> Annex Bool
+checkKeySize key = do
+	file <- inRepo $ gitAnnexLocation key
+	ifM (liftIO $ doesFileExist file)
+		( checkKeySize' key file badContent
+		, return True
+		)
+
+checkKeySizeRemote :: Key -> Remote -> Maybe FilePath -> Annex Bool
+checkKeySizeRemote _ _ Nothing = return True
+checkKeySizeRemote key remote (Just file) = checkKeySize' key file
+	(badContentRemote remote)
+
+checkKeySize' :: Key -> FilePath -> (Key -> Annex String) -> Annex Bool
+checkKeySize' key file bad = case Types.Key.keySize key of
+	Nothing -> return True
+	Just size -> do
+		size' <- fromIntegral . fileSize
+			<$> (liftIO $ getFileStatus file)
+		comparesizes size size'
+	where
+		comparesizes a b = do
+			let same = a == b
+			unless same $ badsize a b
+			return same
+		badsize a b = do
+			msg <- bad key
+			warning $ concat
+				[ "Bad file size ("
+				, compareSizes storageUnits True a b
+				, "); "
+				, msg
+				]
+
+checkBackend :: Backend -> Key -> Annex Bool
+checkBackend backend key = do
+	file <- inRepo (gitAnnexLocation key)
+	checkBackend' backend key (Just file) badContent
+
+checkBackendRemote :: Backend -> Key -> Remote -> Maybe FilePath -> Annex Bool
+checkBackendRemote backend key remote localcopy =
+	checkBackend' backend key localcopy (badContentRemote remote)
+
+checkBackend' :: Backend -> Key -> Maybe FilePath -> (Key -> Annex String) -> Annex Bool
+checkBackend' _ _ Nothing _ = return True
+checkBackend' backend key (Just file) bad = case Types.Backend.fsckKey backend of
+	Nothing -> return True
+	Just a -> do
+		ok <- a key file
+		unless ok $ do
+			msg <- bad key
+			warning $ "Bad file content; " ++ msg
+		return ok
+
+checkKeyNumCopies :: Key -> FilePath -> Maybe Int -> Annex Bool
+checkKeyNumCopies key file numcopies = do
+	needed <- getNumCopies numcopies
+	(untrustedlocations, safelocations) <- trustPartition UnTrusted =<< Remote.keyLocations key
+	let present = length safelocations
+	if present < needed
+		then do
+			ppuuids <- Remote.prettyPrintUUIDs "untrusted" untrustedlocations
+			warning $ missingNote file present needed ppuuids
+			return False
+		else return True
+
+missingNote :: String -> Int -> Int -> String -> String
+missingNote file 0 _ [] = 
+		"** No known copies exist of " ++ file
+missingNote file 0 _ untrusted =
+		"Only these untrusted locations may have copies of " ++ file ++
+		"\n" ++ untrusted ++
+		"Back it up to trusted locations with git-annex copy."
+missingNote file present needed [] =
+		"Only " ++ show present ++ " of " ++ show needed ++ 
+		" trustworthy copies exist of " ++ file ++
+		"\nBack it up with git-annex copy."
+missingNote file present needed untrusted = 
+		missingNote file present needed [] ++
+		"\nThe following untrusted locations may also have copies: " ++
+		"\n" ++ untrusted
+
+{- Bad content is moved aside. -}
+badContent :: Key -> Annex String
+badContent key = do
+	dest <- moveBad key
+	return $ "moved to " ++ dest
+
+badContentRemote :: Remote -> Key -> Annex String
+badContentRemote remote key = do
+	ok <- Remote.removeKey remote key
+	-- better safe than sorry: assume the remote dropped the key
+	-- even if it seemed to fail; the failure could have occurred
+	-- after it really dropped it
+	Remote.logStatus remote key InfoMissing
+	return $ (if ok then "dropped from " else "failed to drop from ")
+		++ Remote.name remote

Command/Get.hs

@@ -0,0 +1,70 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Get where
+
+import Common.Annex
+import Command
+import qualified Remote
+import Annex.Content
+import qualified Command.Move
+
+def :: [Command]
+def = [withOptions [Command.Move.fromOption] $ command "get" paramPaths seek
+	"make content of annexed files available"]
+
+seek :: [CommandSeek]
+seek = [withField Command.Move.fromOption Remote.byName $ \from ->
+	withFilesInGit $ whenAnnexed $ start from]
+
+start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
+start from file (key, _) = stopUnless (not <$> inAnnex key) $
+	autoCopies file key (<) $ \_numcopies ->
+		case from of
+			Nothing -> go $ perform key
+			Just src -> do
+				-- get --from = copy --from
+				stopUnless (Command.Move.fromOk src key) $
+					go $ Command.Move.fromPerform src False key
+	where
+		go a = do
+			showStart "get" file
+			next a	
+
+perform :: Key -> CommandPerform
+perform key = stopUnless (getViaTmp key $ getKeyFile key) $
+	next $ return True -- no cleanup needed
+
+{- Try to find a copy of the file in one of the remotes,
+ - and copy it to here. -}
+getKeyFile :: Key -> FilePath -> Annex Bool
+getKeyFile key file = dispatch =<< Remote.keyPossibilities key
+	where
+		dispatch [] = do
+			showNote "not available"
+			Remote.showLocations key []
+			return False
+		dispatch remotes = trycopy remotes remotes
+		trycopy full [] = do
+			Remote.showTriedRemotes full
+			Remote.showLocations key []
+			return False
+		trycopy full (r:rs) =
+			ifM (probablyPresent r)
+				( docopy r (trycopy full rs)
+				, trycopy full rs
+				)
+		-- This check is to avoid an ugly message if a remote is a
+		-- drive that is not mounted.
+		probablyPresent r
+			| Remote.hasKeyCheap r =
+				either (const False) id <$> Remote.hasKey r key
+			| otherwise = return True
+		docopy r continue = do
+			showAction $ "from " ++ Remote.name r
+			ifM (Remote.retrieveKeyFile r key file)
+				( return True , continue)

Command/Import.hs

@@ -0,0 +1,39 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Import where
+
+import Common.Annex
+import Command
+import qualified Annex
+import qualified Command.Add
+
+def :: [Command]
+def = [command "import" paramPaths seek "move and add files from outside git working copy"]
+
+seek :: [CommandSeek]
+seek = [withPathContents start]
+
+start :: (FilePath, FilePath) -> CommandStart
+start (srcfile, destfile) = notBareRepo $
+	ifM (liftIO $ isRegularFile <$> getSymbolicLinkStatus srcfile)
+		( do
+			showStart "import" destfile
+			next $ perform srcfile destfile
+		, stop
+		)
+
+perform :: FilePath -> FilePath -> CommandPerform
+perform srcfile destfile = do
+	whenM (liftIO $ doesFileExist destfile) $
+		unlessM (Annex.getState Annex.force) $
+			error $ "not overwriting existing " ++ destfile ++
+				" (use --force to override)"
+ 
+	liftIO $ createDirectoryIfMissing True (parentDir destfile)
+	liftIO $ moveFile srcfile destfile
+	Command.Add.perform destfile

Command/InAnnex.hs

@@ -0,0 +1,27 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.InAnnex where
+
+import Common.Annex
+import Command
+import Annex.Content
+
+def :: [Command]
+def = [oneShot $ command "inannex" (paramRepeating paramKey) seek
+	"checks if keys are present in the annex"]
+
+seek :: [CommandSeek]
+seek = [withKeys start]
+
+start :: Key -> CommandStart
+start key = inAnnexSafe key >>= dispatch
+	where
+		dispatch (Just True) = stop
+		dispatch (Just False) = exit 1
+		dispatch Nothing = exit 100
+		exit n = liftIO $ exitWith $ ExitFailure n

Command/Init.hs

@@ -0,0 +1,31 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Init where
+
+import Common.Annex
+import Command
+import Init
+	
+def :: [Command]
+def = [dontCheck repoExists $
+	command "init" paramDesc seek "initialize git-annex"]
+
+seek :: [CommandSeek]
+seek = [withWords start]
+
+start :: [String] -> CommandStart
+start ws = do
+	showStart "init" description
+	next $ perform description
+	where
+		description = unwords ws
+
+perform :: String -> CommandPerform
+perform description = do
+	initialize $ if null description then Nothing else Just description
+	next $ return True

Command/InitRemote.hs

@@ -0,0 +1,95 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.InitRemote where
+
+import qualified Data.Map as M
+
+import Common.Annex
+import Command
+import qualified Remote
+import qualified Logs.Remote
+import qualified Types.Remote as R
+import Annex.UUID
+
+def :: [Command]
+def = [command "initremote"
+	(paramPair paramName $ paramOptional $ paramRepeating paramKeyValue)
+	seek "sets up a special (non-git) remote"]
+
+seek :: [CommandSeek]
+seek = [withWords start]
+
+start :: [String] -> CommandStart
+start [] = do
+	names <- remoteNames
+	error $ "Specify a name for the remote. " ++
+		if null names
+			then ""
+			else "Either a new name, or one of these existing special remotes: " ++ join " " names
+start (name:ws) = do
+	(u, c) <- findByName name
+	let fullconfig = config `M.union` c	
+	t <- findType fullconfig
+
+	showStart "initremote" name
+	next $ perform t u $ M.union config c
+
+	where
+		config = Logs.Remote.keyValToConfig ws
+
+perform :: RemoteType -> UUID -> R.RemoteConfig -> CommandPerform
+perform t u c = do
+	c' <- R.setup t u c
+	next $ cleanup u c'
+
+cleanup :: UUID -> R.RemoteConfig -> CommandCleanup
+cleanup u c = do
+	Logs.Remote.configSet u c
+        return True
+
+{- Look up existing remote's UUID and config by name, or generate a new one -}
+findByName :: String -> Annex (UUID, R.RemoteConfig)
+findByName name = do
+	m <- Logs.Remote.readRemoteLog
+	maybe generate return $ findByName' name m
+	where
+		generate = do
+			uuid <- liftIO genUUID
+			return (uuid, M.insert nameKey name M.empty)
+
+findByName' :: String ->  M.Map UUID R.RemoteConfig -> Maybe (UUID, R.RemoteConfig)
+findByName' n = headMaybe . filter (matching . snd) . M.toList
+	where
+		matching c = case M.lookup nameKey c of
+			Nothing -> False
+			Just n'
+				| n' == n -> True
+				| otherwise -> False
+
+remoteNames :: Annex [String]
+remoteNames = do
+	m <- Logs.Remote.readRemoteLog
+	return $ mapMaybe (M.lookup nameKey . snd) $ M.toList m
+
+{- find the specified remote type -}
+findType :: R.RemoteConfig -> Annex RemoteType
+findType config = maybe unspecified specified $ M.lookup typeKey config
+	where
+		unspecified = error "Specify the type of remote with type="
+		specified s = case filter (findtype s) Remote.remoteTypes of
+			[] -> error $ "Unknown remote type " ++ s
+			(t:_) -> return t
+		findtype s i = R.typename i == s
+
+{- The name of a configured remote is stored in its config using this key. -}
+nameKey :: String
+nameKey = "name"
+
+{- The type of a remote is stored in its config using this key. -}
+typeKey :: String
+typeKey = "type"

Command/Lock.hs

@@ -0,0 +1,28 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Lock where
+
+import Common.Annex
+import Command
+import qualified Annex.Queue
+	
+def :: [Command]
+def = [command "lock" paramPaths seek "undo unlock command"]
+
+seek :: [CommandSeek]
+seek = [withFilesUnlocked start, withFilesUnlockedToBeCommitted start]
+
+start :: FilePath -> CommandStart
+start file = do
+	showStart "lock" file
+	next $ perform file
+
+perform :: FilePath -> CommandPerform
+perform file = do
+	Annex.Queue.add "checkout" [Param "--"] [file]
+	next $ return True -- no cleanup needed

Command/Log.hs

@@ -0,0 +1,172 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Log where
+
+import qualified Data.Set as S
+import qualified Data.Map as M
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.Time.Clock.POSIX
+import Data.Time
+import System.Locale
+import Data.Char
+
+import Common.Annex
+import Command
+import qualified Logs.Location
+import qualified Logs.Presence
+import Annex.CatFile
+import qualified Annex.Branch
+import qualified Git
+import Git.Command
+import qualified Remote
+import qualified Option
+import qualified Annex
+
+data RefChange = RefChange 
+	{ changetime :: POSIXTime
+	, oldref :: Git.Ref
+	, newref :: Git.Ref
+	}
+
+type Outputter = Bool -> POSIXTime -> [UUID] -> Annex ()
+
+def :: [Command]
+def = [withOptions options $
+	command "log" paramPaths seek "shows location log"]
+
+options :: [Option]
+options = passthruOptions ++ [gourceOption]
+
+passthruOptions :: [Option]
+passthruOptions = map odate ["since", "after", "until", "before"] ++
+	[ Option.field ['n'] "max-count" paramNumber
+		"limit number of logs displayed"
+	]
+	where
+		odate n = Option.field [] n paramDate $
+			"show log " ++ n ++ " date"
+
+gourceOption :: Option
+gourceOption = Option.flag [] "gource" "format output for gource"
+
+seek :: [CommandSeek]
+seek = [withValue Remote.uuidDescriptions $ \m ->
+	withValue (liftIO getCurrentTimeZone) $ \zone ->
+	withValue (concat <$> mapM getoption passthruOptions) $ \os ->
+	withFlag gourceOption $ \gource ->
+	withFilesInGit $ whenAnnexed $ start m zone os gource]
+	where
+		getoption o = maybe [] (use o) <$>
+			Annex.getField (Option.name o)
+		use o v = [Param ("--" ++ Option.name o), Param v]
+
+start :: M.Map UUID String -> TimeZone -> [CommandParam] -> Bool ->
+	FilePath -> (Key, Backend) -> CommandStart
+start m zone os gource file (key, _) = do
+	showLog output =<< readLog <$> getLog key os
+	liftIO Git.Command.reap
+	stop
+	where
+		output
+			| gource = gourceOutput lookupdescription file
+			| otherwise = normalOutput lookupdescription file zone
+		lookupdescription u = fromMaybe (fromUUID u) $ M.lookup u m
+
+showLog :: Outputter -> [RefChange] -> Annex ()
+showLog outputter ps = do
+	sets <- mapM (getset newref) ps
+	previous <- maybe (return genesis) (getset oldref) (lastMaybe ps)
+	sequence_ $ compareChanges outputter $ sets ++ [previous]
+	where
+		genesis = (0, S.empty)
+		getset select change = do
+			s <- S.fromList <$> get (select change)
+			return (changetime change, s)
+		get ref = map toUUID . Logs.Presence.getLog . L.unpack <$>
+			catObject ref
+
+normalOutput :: (UUID -> String) -> FilePath -> TimeZone -> Outputter
+normalOutput lookupdescription file zone present ts us =
+	liftIO $ mapM_ (putStrLn . format) us
+	where
+		time = showTimeStamp zone ts
+		addel = if present then "+" else "-"
+		format u = unwords [ addel, time, file, "|", 
+			fromUUID u ++ " -- " ++ lookupdescription u ]
+
+gourceOutput :: (UUID -> String) -> FilePath -> Outputter
+gourceOutput lookupdescription file present ts us =
+	liftIO $ mapM_ (putStrLn . intercalate "|" . format) us
+	where
+		time = takeWhile isDigit $ show ts
+		addel = if present then "A" else "M"
+		format u = [ time, lookupdescription u, addel, file ]
+
+{- Generates a display of the changes (which are ordered with newest first),
+ - by comparing each change with the previous change.
+ - Uses a formatter to generate a display of items that are added and
+ - removed. -}
+compareChanges :: Ord a => (Bool -> POSIXTime -> [a] -> b) -> [(POSIXTime, S.Set a)] -> [b]
+compareChanges format changes = concatMap diff $ zip changes (drop 1 changes)
+	where
+		diff ((ts, new), (_, old)) =
+			[format True ts added, format False ts removed]
+			where
+				added = S.toList $ S.difference new old
+				removed = S.toList $ S.difference old new
+
+{- Gets the git log for a given location log file.
+ -
+ - This is complicated by git log using paths relative to the current
+ - directory, even when looking at files in a different branch. A wacky
+ - relative path to the log file has to be used.
+ -
+ - The --remove-empty is a significant optimisation. It relies on location
+ - log files never being deleted in normal operation. Letting git stop
+ - once the location log file is gone avoids it checking all the way back
+ - to commit 0 to see if it used to exist, so generally speeds things up a
+ - *lot* for newish files. -}
+getLog :: Key -> [CommandParam] -> Annex [String]
+getLog key os = do
+	top <- fromRepo Git.repoPath
+	p <- liftIO $ relPathCwdToFile top
+	let logfile = p </> Logs.Location.logFile key
+	inRepo $ pipeNullSplit $
+		[ Params "log -z --pretty=format:%ct --raw --abbrev=40"
+		, Param "--remove-empty"
+		] ++ os ++
+		[ Param $ show Annex.Branch.fullname
+		, Param "--"
+		, Param logfile
+		]
+
+readLog :: [String] -> [RefChange]
+readLog = mapMaybe (parse . lines)
+	where
+		parse (ts:raw:[]) = let (old, new) = parseRaw raw in
+			Just RefChange
+				{ changetime = parseTimeStamp ts
+				, oldref = old
+				, newref = new
+				}
+		parse _ = Nothing
+
+-- Parses something like ":100644 100644 oldsha newsha M"
+parseRaw :: String -> (Git.Ref, Git.Ref)
+parseRaw l = (Git.Ref oldsha, Git.Ref newsha)
+	where
+		ws = words l
+		oldsha = ws !! 2
+		newsha = ws !! 3
+
+parseTimeStamp :: String -> POSIXTime
+parseTimeStamp = utcTimeToPOSIXSeconds . fromMaybe (error "bad timestamp") .
+	parseTime defaultTimeLocale "%s"
+
+showTimeStamp :: TimeZone -> POSIXTime -> String
+showTimeStamp zone = show . utcToLocalTime zone . posixSecondsToUTCTime

Command/Map.hs

@@ -0,0 +1,239 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Map where
+
+import Control.Exception.Extensible
+import qualified Data.Map as M
+
+import Common.Annex
+import Command
+import qualified Git
+import qualified Git.Url
+import qualified Git.Config
+import qualified Git.Construct
+import qualified Annex
+import Annex.UUID
+import Logs.UUID
+import Logs.Trust
+import Remote.Helper.Ssh
+import qualified Utility.Dot as Dot
+
+-- a link from the first repository to the second (its remote)
+data Link = Link Git.Repo Git.Repo
+
+def :: [Command]
+def = [dontCheck repoExists $
+	command "map" paramNothing seek "generate map of repositories"]
+
+seek :: [CommandSeek]
+seek = [withNothing start]
+
+start :: CommandStart
+start = do
+	rs <- spider =<< gitRepo
+
+	umap <- uuidMap
+	trusted <- trustGet Trusted
+
+	liftIO $ writeFile file (drawMap rs umap trusted)
+	next $ next $
+		ifM (Annex.getState Annex.fast)
+			( return True
+			, do
+				showLongNote $ "running: dot -Tx11 " ++ file
+				showOutput
+				liftIO $ boolSystem "dot" [Param "-Tx11", File file]
+			)
+	where
+		file = "map.dot"
+
+{- Generates a graph for dot(1). Each repository, and any other uuids, are
+ - displayed as a node, and each of its remotes is represented as an edge
+ - pointing at the node for the remote.
+ -
+ - The order nodes are added to the graph matters, since dot will draw
+ - the first ones near to the top and left. So it looks better to put
+ - the repositories first, followed by uuids that were not matched
+ - to a repository.
+ -}
+drawMap :: [Git.Repo] -> M.Map UUID String -> [UUID] -> String
+drawMap rs umap ts = Dot.graph $ repos ++ trusted ++ others
+	where
+		repos = map (node umap rs) rs
+		ruuids = ts ++ map getUncachedUUID rs
+		others = map (unreachable . uuidnode) $
+			filter (`notElem` ruuids) (M.keys umap)
+		trusted = map (trustworthy . uuidnode) ts
+		uuidnode u = Dot.graphNode (fromUUID u) $
+			M.findWithDefault "" u umap
+
+hostname :: Git.Repo -> String
+hostname r
+	| Git.repoIsUrl r = Git.Url.host r
+	| otherwise = "localhost"
+
+basehostname :: Git.Repo -> String
+basehostname r = Prelude.head $ split "." $ hostname r
+
+{- A name to display for a repo. Uses the name from uuid.log if available,
+ - or the remote name if not. -}
+repoName :: M.Map UUID String -> Git.Repo -> String
+repoName umap r
+	| repouuid == NoUUID = fallback
+	| otherwise = M.findWithDefault fallback repouuid umap
+	where
+		repouuid = getUncachedUUID r
+		fallback = fromMaybe "unknown" $ Git.remoteName r
+
+{- A unique id for the node for a repo. Uses the annex.uuid if available. -}
+nodeId :: Git.Repo -> String
+nodeId r =
+	case getUncachedUUID r of
+		NoUUID -> Git.repoLocation r
+		UUID u -> u
+
+{- A node representing a repo. -}
+node :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> String
+node umap fullinfo r = unlines $ n:edges
+	where
+		n = Dot.subGraph (hostname r) (basehostname r) "lightblue" $
+			decorate $ Dot.graphNode (nodeId r) (repoName umap r)
+		edges = map (edge umap fullinfo r) (Git.remotes r)
+		decorate
+			| Git.config r == M.empty = unreachable
+			| otherwise = reachable
+
+{- An edge between two repos. The second repo is a remote of the first. -}
+edge :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> Git.Repo -> String	
+edge umap fullinfo from to =
+	Dot.graphEdge (nodeId from) (nodeId fullto) edgename
+	where
+		-- get the full info for the remote, to get its UUID
+		fullto = findfullinfo to
+		findfullinfo n =
+			case filter (same n) fullinfo of
+				[] -> n
+				(n':_) -> n'
+		{- Only name an edge if the name is different than the name
+		 - that will be used for the destination node, and is
+		 - different from its hostname. (This reduces visual clutter.) -}
+		edgename = maybe Nothing calcname $ Git.remoteName to
+		calcname n
+			| n `elem` [repoName umap fullto, hostname fullto] = Nothing
+			| otherwise = Just n
+
+unreachable :: String -> String
+unreachable = Dot.fillColor "red"
+reachable :: String -> String
+reachable = Dot.fillColor "white"
+trustworthy :: String -> String
+trustworthy = Dot.fillColor "green"
+
+{- Recursively searches out remotes starting with the specified repo. -}
+spider :: Git.Repo -> Annex [Git.Repo]
+spider r = spider' [r] []
+spider' :: [Git.Repo] -> [Git.Repo] -> Annex [Git.Repo]
+spider' [] known = return known
+spider' (r:rs) known
+	| any (same r) known = spider' rs known
+	| otherwise = do
+		r' <- scan r
+
+		-- The remotes will be relative to r', and need to be
+		-- made absolute for later use.
+		remotes <- mapM (absRepo r') (Git.remotes r')
+		let r'' = r' { Git.remotes = remotes }
+
+		spider' (rs ++ remotes) (r'':known)
+
+{- Converts repos to a common absolute form. -}
+absRepo :: Git.Repo -> Git.Repo -> Annex Git.Repo
+absRepo reference r
+	| Git.repoIsUrl reference = return $ Git.Construct.localToUrl reference r
+	| Git.repoIsUrl r = return r
+	| otherwise = liftIO $ Git.Construct.fromAbsPath =<< absPath (Git.repoPath r)
+
+{- Checks if two repos are the same. -}
+same :: Git.Repo -> Git.Repo -> Bool
+same a b
+	| both Git.repoIsSsh = matching Git.Url.authority && matching Git.repoPath
+	| both Git.repoIsUrl && neither Git.repoIsSsh = matching show
+	| neither Git.repoIsSsh = matching Git.repoPath
+	| otherwise = False
+		
+	where
+		matching t = t a == t b
+		both t = t a && t b
+		neither t = not (t a) && not (t b)
+
+{- reads the config of a remote, with progress display -}
+scan :: Git.Repo -> Annex Git.Repo
+scan r = do
+	showStart "map" $ Git.repoDescribe r
+	v <- tryScan r
+	case v of
+		Just r' -> do
+			showEndOk
+			return r'
+		Nothing -> do
+			showOutput
+			showEndFail
+			return r
+
+{- tries to read the config of a remote, returning it only if it can
+ - be accessed -}
+tryScan :: Git.Repo -> Annex (Maybe Git.Repo)
+tryScan r
+	| Git.repoIsSsh r = sshscan
+	| Git.repoIsUrl r = return Nothing
+	| otherwise = safely $ Git.Config.read r
+	where
+		safely a = do
+			result <- liftIO (try a :: IO (Either SomeException Git.Repo))
+			case result of
+				Left _ -> return Nothing
+				Right r' -> return $ Just r'
+		pipedconfig cmd params = safely $
+			pOpen ReadFromPipe cmd (toCommand params) $
+				Git.Config.hRead r
+
+		configlist =
+			onRemote r (pipedconfig, Nothing) "configlist" []
+		manualconfiglist = do
+			sshparams <- sshToRepo r [Param sshcmd]
+			liftIO $ pipedconfig "ssh" sshparams
+			where
+				sshcmd = cddir ++ " && " ++
+					"git config --null --list"
+				dir = Git.repoPath r
+				cddir
+					| "/~" `isPrefixOf` dir =
+						let (userhome, reldir) = span (/= '/') (drop 1 dir)
+						in "cd " ++ userhome ++ " && cd " ++ shellEscape (drop 1 reldir)
+					| otherwise = "cd " ++ shellEscape dir
+
+		-- First, try sshing and running git config manually,
+		-- only fall back to git-annex-shell configlist if that
+		-- fails.
+		-- 
+		-- This is done for two reasons, first I'd like this
+		-- subcommand to be usable on non-git-annex repos.
+		-- Secondly, configlist doesn't include information about
+		-- the remote's remotes.
+		sshscan = do
+			sshnote
+			v <- manualconfiglist
+			case v of
+				Nothing -> do
+					sshnote
+					configlist
+				ok -> return ok
+
+		sshnote = do
+			showAction "sshing"
+			showOutput

Command/Merge.hs

@@ -0,0 +1,31 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Merge where
+
+import Common.Annex
+import Command
+import qualified Annex.Branch
+
+def :: [Command]
+def = [command "merge" paramNothing seek
+		"auto-merge remote changes into git-annex branch"]
+
+seek :: [CommandSeek]
+seek = [withNothing start]
+
+start :: CommandStart
+start = do
+	showStart "merge" "."
+	next perform
+
+perform :: CommandPerform
+perform = do
+	Annex.Branch.update
+	-- commit explicitly, in case no remote branches were merged
+	Annex.Branch.commit "update"
+	next $ return True

Command/Migrate.hs

@@ -0,0 +1,64 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Migrate where
+
+import Common.Annex
+import Command
+import qualified Backend
+import qualified Types.Key
+import Annex.Content
+import qualified Command.ReKey
+
+def :: [Command]
+def = [command "migrate" paramPaths seek "switch data to different backend"]
+
+seek :: [CommandSeek]
+seek = [withFilesInGit $ whenAnnexed start]
+
+start :: FilePath -> (Key, Backend) -> CommandStart
+start file (key, oldbackend) = do
+	exists <- inAnnex key
+	newbackend <- choosebackend =<< Backend.chooseBackend file
+	if (newbackend /= oldbackend || upgradableKey key) && exists
+		then do
+			showStart "migrate" file
+			next $ perform file key newbackend
+		else stop
+	where
+		choosebackend Nothing = Prelude.head <$> Backend.orderedList
+		choosebackend (Just backend) = return backend
+
+{- Checks if a key is upgradable to a newer representation. -}
+{- Ideally, all keys have file size metadata. Old keys may not. -}
+upgradableKey :: Key -> Bool
+upgradableKey key = isNothing $ Types.Key.keySize key
+
+{- Store the old backend's key in the new backend
+ - The old backend's key is not dropped from it, because there may
+ - be other files still pointing at that key.
+ -
+ - Use the same filename as the file for the temp file name, to support
+ - backends that allow the filename to influence the keys they
+ - generate.
+ -}
+perform :: FilePath -> Key -> Backend -> CommandPerform
+perform file oldkey newbackend = maybe stop go =<< genkey
+	where
+		go newkey = stopUnless (Command.ReKey.linkKey oldkey newkey) $
+			next $ Command.ReKey.cleanup file oldkey newkey
+		genkey = do
+			src <- inRepo $ gitAnnexLocation oldkey
+			tmp <- fromRepo gitAnnexTmpDir
+			let tmpfile = tmp </> takeFileName file
+			cleantmp tmpfile
+			liftIO $ createLink src tmpfile
+			newkey <- liftM fst <$>
+				Backend.genKey tmpfile (Just newbackend)
+			cleantmp tmpfile
+			return newkey
+		cleantmp t = liftIO $ whenM (doesFileExist t) $ removeFile t

Command/Move.hs

@@ -0,0 +1,152 @@
+{- git-annex command
+ -
+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Move where
+
+import Common.Annex
+import Command
+import qualified Command.Drop
+import qualified Annex
+import Annex.Content
+import qualified Remote
+import Annex.UUID
+import qualified Option
+import Logs.Presence
+
+def :: [Command]
+def = [withOptions options $ command "move" paramPaths seek
+	"move content of files to/from another repository"]
+
+fromOption :: Option
+fromOption = Option.field ['f'] "from" paramRemote "source remote"
+
+toOption :: Option
+toOption = Option.field ['t'] "to" paramRemote "destination remote"
+
+options :: [Option]
+options = [fromOption, toOption]
+
+seek :: [CommandSeek]
+seek = [withField toOption Remote.byName $ \to ->
+		withField fromOption Remote.byName $ \from ->
+			withFilesInGit $ whenAnnexed $ start to from True]
+
+start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> (Key, Backend) -> CommandStart
+start to from move file (key, _) = do
+	noAuto
+	case (from, to) of
+		(Nothing, Nothing) -> error "specify either --from or --to"
+		(Nothing, Just dest) -> toStart dest move file key
+		(Just src, Nothing) -> fromStart src move file key
+		(_ ,  _) -> error "only one of --from or --to can be specified"
+	where
+		noAuto = when move $ whenM (Annex.getState Annex.auto) $ error
+			"--auto is not supported for move"
+
+showMoveAction :: Bool -> FilePath -> Annex ()
+showMoveAction True file = showStart "move" file
+showMoveAction False file = showStart "copy" file
+
+{- Moves (or copies) the content of an annexed file to a remote.
+ -
+ - If the remote already has the content, it is still removed from
+ - the current repository.
+ -
+ - Note that unlike drop, this does not honor annex.numcopies.
+ - A file's content can be moved even if there are insufficient copies to
+ - allow it to be dropped.
+ -}
+toStart :: Remote -> Bool -> FilePath -> Key -> CommandStart
+toStart dest move file key = do
+	u <- getUUID
+	ishere <- inAnnex key
+	if not ishere || u == Remote.uuid dest
+		then stop -- not here, so nothing to do
+		else do
+			showMoveAction move file
+			next $ toPerform dest move key
+toPerform :: Remote -> Bool -> Key -> CommandPerform
+toPerform dest move key = moveLock move key $ do
+	-- Checking the remote is expensive, so not done in the start step.
+	-- In fast mode, location tracking is assumed to be correct,
+	-- and an explicit check is not done, when copying. When moving,
+	-- it has to be done, to avoid inaverdent data loss.
+	fast <- Annex.getState Annex.fast
+	let fastcheck = fast && not move && not (Remote.hasKeyCheap dest)
+	isthere <- if fastcheck
+		then do
+			remotes <- Remote.keyPossibilities key
+			return $ Right $ dest `elem` remotes
+		else Remote.hasKey dest key
+	case isthere of
+		Left err -> do
+			showNote err
+			stop
+		Right False -> do
+			showAction $ "to " ++ Remote.name dest
+			ok <- Remote.storeKey dest key
+			if ok
+				then finish
+				else do
+					when fastcheck $
+						warning "This could have failed because --fast is enabled."
+					stop
+		Right True -> finish
+	where
+		finish = do
+			Remote.logStatus dest key InfoPresent
+			if move
+				then do
+					whenM (inAnnex key) $ removeAnnex key
+					next $ Command.Drop.cleanupLocal key
+				else next $ return True
+
+{- Moves (or copies) the content of an annexed file from a remote
+ - to the current repository.
+ -
+ - If the current repository already has the content, it is still removed
+ - from the remote.
+ -}
+fromStart :: Remote -> Bool -> FilePath -> Key -> CommandStart
+fromStart src move file key
+	| move = go
+	| otherwise = stopUnless (not <$> inAnnex key) go
+	where
+		go = stopUnless (fromOk src key) $ do
+			showMoveAction move file
+			next $ fromPerform src move key
+fromOk :: Remote -> Key -> Annex Bool
+fromOk src key
+	| Remote.hasKeyCheap src =
+		either (const expensive) return =<< Remote.hasKey src key
+	| otherwise = expensive
+	where
+		expensive = do
+			u <- getUUID
+			remotes <- Remote.keyPossibilities key
+			return $ u /= Remote.uuid src && any (== src) remotes
+fromPerform :: Remote -> Bool -> Key -> CommandPerform
+fromPerform src move key = moveLock move key $ do
+	ifM (inAnnex key)
+		( handle move True
+		, do
+			showAction $ "from " ++ Remote.name src
+			ok <- getViaTmp key $ Remote.retrieveKeyFile src key
+			handle move ok
+		)
+	where
+		handle _ False = stop -- failed
+		handle False True = next $ return True -- copy complete
+		handle True True = do -- finish moving
+			ok <- Remote.removeKey src key
+			next $ Command.Drop.cleanupRemote key src ok
+
+{- Locks a key in order for it to be moved.
+ - No lock is needed when a key is being copied. -}
+moveLock :: Bool -> Key -> Annex a -> Annex a
+moveLock True key a = lockContent key a
+moveLock False _ a = a

Command/PreCommit.hs

@@ -0,0 +1,32 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.PreCommit where
+
+import Common.Annex
+import Command
+import qualified Command.Add
+import qualified Command.Fix
+
+def :: [Command]
+def = [command "pre-commit" paramPaths seek "run by git pre-commit hook"]
+
+{- The pre-commit hook needs to fix symlinks to all files being committed.
+ - And, it needs to inject unlocked files into the annex. -}
+seek :: [CommandSeek]
+seek =
+	[ withFilesToBeCommitted $ whenAnnexed Command.Fix.start
+	, withFilesUnlockedToBeCommitted start]
+
+start :: FilePath -> CommandStart
+start file = next $ perform file
+
+perform :: FilePath -> CommandPerform
+perform file = do
+	unlessM (doCommand $ Command.Add.start file) $
+		error $ "failed to add " ++ file ++ "; canceling commit"
+	next $ return True

Command/ReKey.hs

@@ -0,0 +1,64 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.ReKey where
+
+import Common.Annex
+import Command
+import qualified Annex
+import Types.Key
+import Annex.Content
+import qualified Command.Add
+import Logs.Web
+
+def :: [Command]
+def = [command "rekey"
+	(paramOptional $ paramRepeating $ paramPair paramPath paramKey)
+	seek "change keys used for files"]
+
+seek :: [CommandSeek]
+seek = [withPairs start]
+
+start :: (FilePath, String) -> CommandStart
+start (file, keyname) = ifAnnexed file go stop
+	where
+		newkey = fromMaybe (error "bad key") $ readKey keyname
+		go (oldkey, _)
+			| oldkey == newkey = stop
+			| otherwise = do
+				showStart "rekey" file
+				next $ perform file oldkey newkey
+
+perform :: FilePath -> Key -> Key -> CommandPerform
+perform file oldkey newkey = do
+	present <- inAnnex oldkey
+	_ <- if present
+		then linkKey oldkey newkey
+		else do
+			unlessM (Annex.getState Annex.force) $
+				error $ file ++ " is not available (use --force to override)"
+			return True
+	next $ cleanup file oldkey newkey
+
+{- Make a hard link to the old key content, to avoid wasting disk space. -}
+linkKey :: Key -> Key -> Annex Bool
+linkKey oldkey newkey = getViaTmpUnchecked newkey $ \tmp -> do
+	src <- inRepo $ gitAnnexLocation oldkey
+	liftIO $ unlessM (doesFileExist tmp) $ createLink src tmp
+	return True
+
+cleanup :: FilePath -> Key -> Key -> CommandCleanup
+cleanup file oldkey newkey = do
+	-- If the old key had some associated urls, record them for
+	-- the new key as well.
+	urls <- getUrls oldkey
+	unless (null urls) $
+		mapM_ (setUrlPresent newkey) urls
+
+	-- Update symlink to use the new key.
+	liftIO $ removeFile file
+	Command.Add.cleanup file newkey True

Command/RecvKey.hs

@@ -0,0 +1,34 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.RecvKey where
+
+import Common.Annex
+import Command
+import CmdLine
+import Annex.Content
+import Utility.RsyncFile
+
+def :: [Command]
+def = [oneShot $ command "recvkey" paramKey seek
+	"runs rsync in server mode to receive content"]
+
+seek :: [CommandSeek]
+seek = [withKeys start]
+
+start :: Key -> CommandStart
+start key = do
+	whenM (inAnnex key) $ error "key is already present in annex"
+	
+	ok <- getViaTmp key (liftIO . rsyncServerReceive)
+	if ok
+		then do
+			-- forcibly quit after receiving one key,
+			-- and shutdown cleanly
+			_ <- shutdown True
+			liftIO exitSuccess
+		else liftIO exitFailure

Command/Reinject.hs

@@ -0,0 +1,56 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Reinject where
+
+import Common.Annex
+import Command
+import Logs.Location
+import Annex.Content
+import qualified Command.Fsck
+
+def :: [Command]
+def = [command "reinject" (paramPair "SRC" "DEST") seek
+	"sets content of annexed file"]
+
+seek :: [CommandSeek]
+seek = [withWords start]
+
+start :: [FilePath] -> CommandStart
+start (src:dest:[])
+	| src == dest = stop
+	| otherwise =
+		ifAnnexed src
+			(error $ "cannot used annexed file as src: " ++ src)
+			go
+	where
+		go = do
+			showStart "reinject" dest
+			next $ whenAnnexed (perform src) dest
+start _ = error "specify a src file and a dest file"
+
+perform :: FilePath -> FilePath -> (Key, Backend) -> CommandPerform
+perform src _dest (key, backend) = do
+	unlessM move $ error "mv failed!"
+	next $ cleanup key backend
+	where
+		-- the file might be on a different filesystem,
+		-- so mv is used rather than simply calling
+		-- moveToObjectDir; disk space is also
+		-- checked this way.
+		move = getViaTmp key $ \tmp ->
+			liftIO $ boolSystem "mv" [File src, File tmp]
+
+cleanup :: Key -> Backend -> CommandCleanup
+cleanup key backend = do
+	logStatus key InfoPresent
+
+	-- fsck the new content
+	size_ok <- Command.Fsck.checkKeySize key
+	backend_ok <- Command.Fsck.checkBackend backend key
+
+	return $ size_ok && backend_ok

Command/Semitrust.hs

@@ -0,0 +1,32 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Semitrust where
+
+import Common.Annex
+import Command
+import qualified Remote
+import Logs.Trust
+
+def :: [Command]
+def = [command "semitrust" (paramRepeating paramRemote) seek
+	"return repository to default trust level"]
+
+seek :: [CommandSeek]
+seek = [withWords start]
+
+start :: [String] -> CommandStart
+start ws = do
+	let name = unwords ws
+	showStart "semitrust" name
+	u <- Remote.nameToUUID name
+	next $ perform u
+
+perform :: UUID -> CommandPerform
+perform uuid = do
+	trustSet uuid SemiTrusted
+	next $ return True

Command/SendKey.hs

@@ -0,0 +1,28 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.SendKey where
+
+import Common.Annex
+import Command
+import Annex.Content
+import Utility.RsyncFile
+
+def :: [Command]
+def = [oneShot $ command "sendkey" paramKey seek
+	"runs rsync in server mode to send content"]
+
+seek :: [CommandSeek]
+seek = [withKeys start]
+
+start :: Key -> CommandStart
+start key = do
+	file <- inRepo $ gitAnnexLocation key
+	whenM (inAnnex key) $
+		liftIO $ rsyncServerSend file -- does not return
+	warning "requested key is not present"
+	liftIO exitFailure

Command/Status.hs

@@ -0,0 +1,266 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns #-}
+
+module Command.Status where
+
+import Control.Monad.State.Strict
+import qualified Data.Map as M
+import Text.JSON
+
+import Common.Annex
+import qualified Types.Backend as B
+import qualified Types.Remote as R
+import qualified Remote
+import qualified Command.Unused
+import qualified Git
+import qualified Annex
+import Command
+import Utility.DataUnits
+import Utility.DiskFree
+import Annex.Content
+import Types.Key
+import Backend
+import Logs.UUID
+import Logs.Trust
+import Remote
+import Config
+import Utility.Percentage
+
+-- a named computation that produces a statistic
+type Stat = StatState (Maybe (String, StatState String))
+
+-- data about a set of keys
+data KeyData = KeyData
+	{ countKeys :: Integer
+	, sizeKeys :: Integer
+	, unknownSizeKeys :: Integer
+	, backendsKeys :: M.Map String Integer
+	}
+
+-- cached info that multiple Stats use
+data StatInfo = StatInfo
+	{ presentData :: Maybe KeyData
+	, referencedData :: Maybe KeyData
+	}
+
+-- a state monad for running Stats in
+type StatState = StateT StatInfo Annex
+
+def :: [Command]
+def = [command "status" paramNothing seek
+	"shows status information about the annex"]
+
+seek :: [CommandSeek]
+seek = [withNothing start]
+
+{- Order is significant. Less expensive operations, and operations
+ - that share data go together.
+ -}
+fast_stats :: [Stat]
+fast_stats = 
+	[ supported_backends
+	, supported_remote_types
+	, remote_list Trusted "trusted"
+	, remote_list SemiTrusted "semitrusted"
+	, remote_list UnTrusted "untrusted"
+	, remote_list DeadTrusted "dead"
+	, disk_size
+	]
+slow_stats :: [Stat]
+slow_stats = 
+	[ tmp_size
+	, bad_data_size
+	, local_annex_keys
+	, local_annex_size
+	, known_annex_keys
+	, known_annex_size
+	, bloom_info
+	, backend_usage
+	]
+
+start :: CommandStart
+start = do
+	fast <- Annex.getState Annex.fast
+	let stats = if fast then fast_stats else fast_stats ++ slow_stats
+	showCustom "status" $ do
+		evalStateT (mapM_ showStat stats) (StatInfo Nothing Nothing)
+		return True
+	stop
+
+stat :: String -> (String -> StatState String) -> Stat
+stat desc a = return $ Just (desc, a desc)
+
+nostat :: Stat
+nostat = return Nothing
+
+json :: JSON j => (j -> String) -> StatState j -> String -> StatState String
+json serialize a desc = do
+	j <- a
+	lift $ maybeShowJSON [(desc, j)]
+	return $ serialize j
+
+nojson :: StatState String -> String -> StatState String
+nojson a _ = a
+
+showStat :: Stat -> StatState ()
+showStat s = maybe noop calc =<< s
+	where
+		calc (desc, a) = do
+			(lift . showHeader) desc
+			lift . showRaw =<< a
+
+supported_backends :: Stat
+supported_backends = stat "supported backends" $ json unwords $
+	return $ map B.name Backend.list
+
+supported_remote_types :: Stat
+supported_remote_types = stat "supported remote types" $ json unwords $
+	return $ map R.typename Remote.remoteTypes
+
+remote_list :: TrustLevel -> String -> Stat
+remote_list level desc = stat n $ nojson $ lift $ do
+	us <- M.keys <$> (M.union <$> uuidMap <*> remoteMap Remote.name)
+	rs <- fst <$> trustPartition level us
+	s <- prettyPrintUUIDs n rs
+	return $ if null s then "0" else show (length rs) ++ "\n" ++ beginning s
+	where
+		n = desc ++ " repositories"
+	
+local_annex_size :: Stat
+local_annex_size = stat "local annex size" $ json id $
+	showSizeKeys <$> cachedPresentData
+
+local_annex_keys :: Stat
+local_annex_keys = stat "local annex keys" $ json show $
+	countKeys <$> cachedPresentData
+
+known_annex_size :: Stat
+known_annex_size = stat "known annex size" $ json id $
+	showSizeKeys <$> cachedReferencedData
+
+known_annex_keys :: Stat
+known_annex_keys = stat "known annex keys" $ json show $
+	countKeys <$> cachedReferencedData
+
+tmp_size :: Stat
+tmp_size = staleSize "temporary directory size" gitAnnexTmpDir
+
+bad_data_size :: Stat
+bad_data_size = staleSize "bad keys size" gitAnnexBadDir
+
+bloom_info :: Stat
+bloom_info = stat "bloom filter size" $ json id $ do
+	localkeys <- countKeys <$> cachedPresentData
+	capacity <- fromIntegral <$> lift Command.Unused.bloomCapacity
+	let note = aside $
+		if localkeys >= capacity
+		then "appears too small for this repository; adjust annex.bloomcapacity"
+		else showPercentage 1 (percentage capacity localkeys) ++ " full"
+
+	-- Two bloom filters are used at the same time, so double the size
+	-- of one.
+	size <- roughSize memoryUnits False . (* 2) . fromIntegral . fst <$>
+		lift Command.Unused.bloomBitsHashes
+
+	return $ size ++ note
+
+disk_size :: Stat
+disk_size = stat "available local disk space" $ json id $ lift $
+	calcfree
+		<$> getDiskReserve
+		<*> inRepo (getDiskFree . gitAnnexDir)
+	where
+		calcfree reserve (Just have) = unwords
+			[ roughSize storageUnits False $ nonneg $ have - reserve
+			, "(+" ++ roughSize storageUnits False reserve
+			, "reserved)"
+			]
+			
+		calcfree _ _ = "unknown"
+		nonneg x
+			| x >= 0 = x
+			| otherwise = 0
+
+backend_usage :: Stat
+backend_usage = stat "backend usage" $ nojson $
+	calc
+		<$> (backendsKeys <$> cachedReferencedData)
+		<*> (backendsKeys <$> cachedPresentData)
+	where
+		calc a b = pp "" $ reverse . sort $ map swap $ M.toList $ M.unionWith (+) a b
+		pp c [] = c
+		pp c ((n, b):xs) = "\n\t" ++ b ++ ": " ++ show n ++ pp c xs
+		swap (a, b) = (b, a)
+
+cachedPresentData :: StatState KeyData
+cachedPresentData = do
+	s <- get
+	case presentData s of
+		Just v -> return v
+		Nothing -> do
+			v <- foldKeys <$> lift getKeysPresent
+			put s { presentData = Just v }
+			return v
+
+cachedReferencedData :: StatState KeyData
+cachedReferencedData = do
+	s <- get
+	case referencedData s of
+		Just v -> return v
+		Nothing -> do
+			!v <- lift $ Command.Unused.withKeysReferenced
+				emptyKeyData addKey
+			put s { referencedData = Just v }
+			return v
+
+emptyKeyData :: KeyData
+emptyKeyData = KeyData 0 0 0 M.empty
+
+foldKeys :: [Key] -> KeyData
+foldKeys = foldl' (flip addKey) emptyKeyData
+
+addKey :: Key -> KeyData -> KeyData
+addKey key (KeyData count size unknownsize backends) =
+	KeyData count' size' unknownsize' backends'
+	where
+		{- All calculations strict to avoid thunks when repeatedly
+		 - applied to many keys. -}
+		!count' = count + 1
+		!backends' = M.insertWith' (+) (keyBackendName key) 1 backends
+		!size' = maybe size (+ size) ks
+		!unknownsize' = maybe (unknownsize + 1) (const unknownsize) ks
+		ks = keySize key
+
+showSizeKeys :: KeyData -> String
+showSizeKeys d = total ++ missingnote
+	where
+		total = roughSize storageUnits False $ sizeKeys d
+		missingnote
+			| unknownSizeKeys d == 0 = ""
+			| otherwise = aside $
+				"+ " ++ show (unknownSizeKeys d) ++
+				" keys of unknown size"
+
+staleSize :: String -> (Git.Repo -> FilePath) -> Stat
+staleSize label dirspec = go =<< lift (Command.Unused.staleKeys dirspec)
+	where
+		go [] = nostat
+		go keys = onsize =<< sum <$> keysizes keys
+		onsize 0 = nostat
+		onsize size = stat label $
+			json (++ aside "clean up with git-annex unused") $
+				return $ roughSize storageUnits False size
+		keysizes keys = map (fromIntegral . fileSize) <$> stats keys
+		stats keys = do
+			dir <- lift $ fromRepo dirspec
+			liftIO $ forM keys $ \k ->
+				getFileStatus (dir </> keyFile k)
+
+aside :: String -> String
+aside s = " (" ++ s ++ ")"

Command/Sync.hs

@@ -0,0 +1,176 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2011 Joachim Breitner <mail@joachim-breitner.de>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns #-}
+
+module Command.Sync where
+
+import Common.Annex
+import Command
+import qualified Remote
+import qualified Annex
+import qualified Annex.Branch
+import qualified Git.Command
+import qualified Git.Branch
+import qualified Git.Ref
+import qualified Git
+import qualified Types.Remote
+import qualified Remote.Git
+
+import qualified Data.Map as M
+
+def :: [Command]
+def = [command "sync" (paramOptional (paramRepeating paramRemote))
+	[seek] "synchronize local repository with remotes"]
+
+-- syncing involves several operations, any of which can independently fail
+seek :: CommandSeek
+seek rs = do
+	!branch <- fromMaybe nobranch <$> inRepo Git.Branch.current
+	remotes <- syncRemotes rs
+	return $ concat
+		[ [ commit ]
+		, [ mergeLocal branch ]
+		, [ pullRemote remote branch | remote <- remotes ]
+		, [ mergeAnnex ]
+		, [ pushLocal branch ]
+		, [ pushRemote remote branch | remote <- remotes ]
+		]
+	where
+		nobranch = error "no branch is checked out"
+
+syncBranch :: Git.Ref -> Git.Ref
+syncBranch = Git.Ref.under "refs/heads/synced/"
+
+remoteBranch :: Remote -> Git.Ref -> Git.Ref
+remoteBranch remote = Git.Ref.under $ "refs/remotes/" ++ Remote.name remote
+
+syncRemotes :: [String] -> Annex [Remote]
+syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted )
+	where
+		pickfast = (++) <$> listed <*> (good =<< fastest <$> available)
+		wanted
+			| null rs = good =<< concat . byspeed <$> available
+			| otherwise = listed
+		listed = do
+			l <- catMaybes <$> mapM (Remote.byName . Just) rs
+			let s = filter special l
+			unless (null s) $
+				error $ "cannot sync special remotes: " ++
+					unwords (map Types.Remote.name s)
+			return l
+		available = filter nonspecial <$> Remote.enabledRemoteList
+		good = filterM $ Remote.Git.repoAvail . Types.Remote.repo
+		nonspecial r = Types.Remote.remotetype r == Remote.Git.remote
+		special = not . nonspecial
+		fastest = fromMaybe [] . headMaybe . byspeed
+		byspeed = map snd . sort . M.toList . costmap
+		costmap = M.fromListWith (++) . map costpair
+		costpair r = (Types.Remote.cost r, [r])
+
+commit :: CommandStart
+commit = do
+	showStart "commit" ""
+	next $ next $ do
+		showOutput
+		Annex.Branch.commit "update"
+		-- Commit will fail when the tree is clean, so ignore failure.
+		_ <- inRepo $ Git.Command.runBool "commit"
+			[Param "-a", Param "-m", Param "git-annex automatic sync"]
+		return True
+
+mergeLocal :: Git.Ref -> CommandStart
+mergeLocal branch = go =<< needmerge
+	where
+		syncbranch = syncBranch branch
+		needmerge = do
+			unlessM (inRepo $ Git.Ref.exists syncbranch) $
+				updateBranch syncbranch
+			inRepo $ Git.Branch.changed branch syncbranch
+		go False = stop
+		go True = do
+			showStart "merge" $ Git.Ref.describe syncbranch
+			next $ next $ mergeFrom syncbranch
+
+pushLocal :: Git.Ref -> CommandStart
+pushLocal branch = do
+	updateBranch $ syncBranch branch
+	stop
+
+updateBranch :: Git.Ref -> Annex ()
+updateBranch syncbranch = 
+	unlessM go $ error $ "failed to update " ++ show syncbranch
+	where
+		go = inRepo $ Git.Command.runBool "branch"
+			[ Param "-f"
+			, Param $ show $ Git.Ref.base syncbranch
+			]
+
+pullRemote :: Remote -> Git.Ref -> CommandStart
+pullRemote remote branch = do
+	showStart "pull" (Remote.name remote)
+	next $ do
+		showOutput
+		stopUnless fetch $
+			next $ mergeRemote remote branch
+	where
+		fetch = inRepo $ Git.Command.runBool "fetch"
+			[Param $ Remote.name remote]
+
+{- The remote probably has both a master and a synced/master branch.
+ - Which to merge from? Well, the master has whatever latest changes
+ - were committed, while the synced/master may have changes that some
+ - other remote synced to this remote. So, merge them both. -}
+mergeRemote :: Remote -> Git.Ref -> CommandCleanup
+mergeRemote remote branch = all id <$> (mapM merge =<< tomerge)
+	where
+		merge = mergeFrom . remoteBranch remote
+		tomerge = filterM (changed remote) [branch, syncBranch branch]
+
+pushRemote :: Remote -> Git.Ref -> CommandStart
+pushRemote remote branch = go =<< needpush
+	where
+		needpush = anyM (newer remote) [syncbranch, Annex.Branch.name]
+		go False = stop
+		go True = do
+			showStart "push" (Remote.name remote)
+			next $ next $ do
+				showOutput
+				inRepo $ Git.Command.runBool "push"
+					[ Param (Remote.name remote)
+					, Param (show Annex.Branch.name)
+					, Param refspec
+					]
+		refspec = show (Git.Ref.base branch) ++ ":" ++ show (Git.Ref.base syncbranch)
+		syncbranch = syncBranch branch
+
+mergeAnnex :: CommandStart
+mergeAnnex = do
+	Annex.Branch.forceUpdate
+	stop
+
+mergeFrom :: Git.Ref -> CommandCleanup
+mergeFrom branch = do
+	showOutput
+	inRepo $ Git.Command.runBool "merge" [Param $ show branch]
+
+changed :: Remote -> Git.Ref -> Annex Bool
+changed remote b = do
+	let r = remoteBranch remote b
+	ifM (inRepo $ Git.Ref.exists r)
+		( inRepo $ Git.Branch.changed b r
+		, return False
+		)
+
+newer :: Remote -> Git.Ref -> Annex Bool
+newer remote b = do
+	let r = remoteBranch remote b
+	ifM (inRepo $ Git.Ref.exists r)
+		( inRepo $ Git.Branch.changed r b
+		, return True
+		)

Command/Trust.hs

@@ -0,0 +1,31 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Trust where
+
+import Common.Annex
+import Command
+import qualified Remote
+import Logs.Trust
+
+def :: [Command]
+def = [command "trust" (paramRepeating paramRemote) seek "trust a repository"]
+
+seek :: [CommandSeek]
+seek = [withWords start]
+
+start :: [String] -> CommandStart
+start ws = do
+	let name = unwords ws
+	showStart "trust" name
+	u <- Remote.nameToUUID name
+	next $ perform u
+
+perform :: UUID -> CommandPerform
+perform uuid = do
+	trustSet uuid Trusted
+	next $ return True

Command/Unannex.hs

@@ -0,0 +1,60 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Unannex where
+
+import Common.Annex
+import Command
+import qualified Annex
+import Logs.Location
+import Annex.Content
+import qualified Git.Command
+import qualified Git.LsFiles as LsFiles
+
+def :: [Command]
+def = [command "unannex" paramPaths seek "undo accidential add command"]
+
+seek :: [CommandSeek]
+seek = [withFilesInGit $ whenAnnexed start]
+
+start :: FilePath -> (Key, Backend) -> CommandStart
+start file (key, _) = stopUnless (inAnnex key) $ do
+	showStart "unannex" file
+	next $ perform file key
+
+perform :: FilePath -> Key -> CommandPerform
+perform file key = next $ cleanup file key
+
+cleanup :: FilePath -> Key -> CommandCleanup
+cleanup file key = do
+	liftIO $ removeFile file
+	-- git rm deletes empty directory without --cached
+	inRepo $ Git.Command.run "rm" [Params "--cached --quiet --", File file]
+	
+	-- If the file was already committed, it is now staged for removal.
+	-- Commit that removal now, to avoid later confusing the
+	-- pre-commit hook if this file is later added back to
+	-- git as a normal, non-annexed file.
+	whenM (not . null <$> inRepo (LsFiles.staged [file])) $ do
+		showOutput
+		inRepo $ Git.Command.run "commit" [
+			Param "-q",
+			Params "-m", Param "content removed from git annex",
+			Param "--", File file]
+
+	ifM (Annex.getState Annex.fast)
+		( do
+			-- fast mode: hard link to content in annex
+			src <- inRepo $ gitAnnexLocation key
+			liftIO $ createLink src file
+			thawContent file
+		, do
+			fromAnnex key file
+			logStatus key InfoMissing
+		)
+
+	return True

Command/Uninit.hs

@@ -0,0 +1,63 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Uninit where
+
+import qualified Data.ByteString.Lazy.Char8 as B
+
+import Common.Annex
+import Command
+import qualified Git
+import qualified Git.Command
+import qualified Annex
+import qualified Command.Unannex
+import Init
+import qualified Annex.Branch
+import Annex.Content
+
+def :: [Command]
+def = [addCheck check $ command "uninit" paramPaths seek 
+        "de-initialize git-annex and clean out repository"]
+
+check :: Annex ()
+check = do
+	b <- current_branch	
+	when (b == Annex.Branch.name) $ error $
+		"cannot uninit when the " ++ show b ++ " branch is checked out"
+	where
+		current_branch = Git.Ref . Prelude.head . lines . B.unpack <$> revhead
+		revhead = inRepo $ Git.Command.pipeRead 
+			[Params "rev-parse --abbrev-ref HEAD"]
+
+seek :: [CommandSeek]
+seek = [withFilesInGit $ whenAnnexed startUnannex, withNothing start]
+
+startUnannex :: FilePath -> (Key, Backend) -> CommandStart
+startUnannex file info = do
+	-- Force fast mode before running unannex. This way, if multiple
+	-- files link to a key, it will be left in the annex and hardlinked
+	-- to by each.
+	Annex.changeState $ \s -> s { Annex.fast = True }
+	Command.Unannex.start file info
+
+start :: CommandStart
+start = next perform
+
+perform :: CommandPerform
+perform = next cleanup
+
+cleanup :: CommandCleanup
+cleanup = do
+	annexdir <- fromRepo gitAnnexDir
+	uninitialize
+	mapM_ removeAnnex =<< getKeysPresent
+	liftIO $ removeDirectoryRecursive annexdir
+	-- avoid normal shutdown
+	saveState False
+	inRepo $ Git.Command.run "branch"
+		[Param "-D", Param $ show Annex.Branch.name]
+	liftIO exitSuccess

Command/Unlock.hs

@@ -0,0 +1,50 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Unlock where
+
+import Common.Annex
+import Command
+import Annex.Content
+import Utility.CopyFile
+
+def :: [Command]
+def =
+	[ c "unlock" "unlock files for modification"
+	, c "edit" "same as unlock"
+	]
+	where
+		c n = command n paramPaths seek
+
+seek :: [CommandSeek]
+seek = [withFilesInGit $ whenAnnexed start]
+
+{- The unlock subcommand replaces the symlink with a copy of the file's
+ - content. -}
+start :: FilePath -> (Key, Backend) -> CommandStart
+start file (key, _) = do
+	showStart "unlock" file
+	next $ perform file key
+
+perform :: FilePath -> Key -> CommandPerform
+perform dest key = do
+	unlessM (inAnnex key) $ error "content not present"
+	unlessM (checkDiskSpace Nothing key 0) $ error "cannot unlock"
+
+	src <- inRepo $ gitAnnexLocation key
+	tmpdest <- fromRepo $ gitAnnexTmpLocation key
+	liftIO $ createDirectoryIfMissing True (parentDir tmpdest)
+	showAction "copying"
+	ok <- liftIO $ copyFileExternal src tmpdest
+        if ok
+                then do
+			liftIO $ do
+				removeFile dest
+				moveFile tmpdest dest
+			thawContent dest
+			next $ return True
+                else error "copy failed!"

Command/Untrust.hs

@@ -0,0 +1,32 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Untrust where
+
+import Common.Annex
+import Command
+import qualified Remote
+import Logs.Trust
+
+def :: [Command]
+def = [command "untrust" (paramRepeating paramRemote) seek
+	"do not trust a repository"]
+
+seek :: [CommandSeek]
+seek = [withWords start]
+
+start :: [String] -> CommandStart
+start ws = do
+	let name = unwords ws
+	showStart "untrust" name
+	u <- Remote.nameToUUID name
+	next $ perform u
+
+perform :: UUID -> CommandPerform
+perform uuid = do
+	trustSet uuid UnTrusted
+	next $ return True

Command/Unused.hs

@@ -0,0 +1,302 @@
+{- git-annex command
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns #-}
+
+module Command.Unused where
+
+import qualified Data.Set as S
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.BloomFilter
+import Data.BloomFilter.Easy
+import Data.BloomFilter.Hash
+import Control.Monad.ST
+
+import Common.Annex
+import Command
+import Logs.Unused
+import Annex.Content
+import Utility.FileMode
+import Logs.Location
+import Config
+import qualified Annex
+import qualified Git
+import qualified Git.Command
+import qualified Git.Ref
+import qualified Git.LsFiles as LsFiles
+import qualified Git.LsTree as LsTree
+import qualified Backend
+import qualified Remote
+import qualified Annex.Branch
+import qualified Option
+import Annex.CatFile
+
+def :: [Command]
+def = [withOptions [fromOption] $ command "unused" paramNothing seek
+	"look for unused file content"]
+
+fromOption :: Option
+fromOption = Option.field ['f'] "from" paramRemote "remote to check for unused content"
+
+seek :: [CommandSeek]
+seek = [withNothing start]
+
+{- Finds unused content in the annex. -} 
+start :: CommandStart
+start = do
+	from <- Annex.getField $ Option.name fromOption
+	let (name, action) = case from of
+		Nothing -> (".", checkUnused)
+		Just "." -> (".", checkUnused)
+		Just "here" -> (".", checkUnused)
+		Just n -> (n, checkRemoteUnused n)
+	showStart "unused" name
+	next action
+
+checkUnused :: CommandPerform
+checkUnused = chain 0
+	[ check "" unusedMsg $ findunused =<< Annex.getState Annex.fast
+	, check "bad" staleBadMsg $ staleKeysPrune gitAnnexBadDir
+	, check "tmp" staleTmpMsg $ staleKeysPrune gitAnnexTmpDir
+	]
+	where
+		findunused True = do
+			showNote "fast mode enabled; only finding stale files"
+			return []
+		findunused False = do
+			showAction "checking for unused data"
+			excludeReferenced =<< getKeysPresent
+		chain _ [] = next $ return True
+		chain v (a:as) = do
+			v' <- a v
+			chain v' as
+
+checkRemoteUnused :: String -> CommandPerform
+checkRemoteUnused name = go =<< fromJust <$> Remote.byName (Just name)
+	where
+		go r = do
+			showAction "checking for unused data"
+			_ <- check "" (remoteUnusedMsg r) (remoteunused r) 0
+			next $ return True
+		remoteunused r =
+			excludeReferenced =<< loggedKeysFor (Remote.uuid r)
+
+check :: FilePath -> ([(Int, Key)] -> String) -> Annex [Key] -> Int -> Annex Int
+check file msg a c = do
+	l <- a
+	let unusedlist = number c l
+	unless (null l) $ showLongNote $ msg unusedlist
+	writeUnusedLog file unusedlist
+	return $ c + length l
+
+number :: Int -> [a] -> [(Int, a)]
+number _ [] = []
+number n (x:xs) = (n+1, x) : number (n+1) xs
+
+table :: [(Int, Key)] -> [String]
+table l = "  NUMBER  KEY" : map cols l
+	where
+		cols (n,k) = "  " ++ pad 6 (show n) ++ "  " ++ show k
+		pad n s = s ++ replicate (n - length s) ' '
+
+staleTmpMsg :: [(Int, Key)] -> String
+staleTmpMsg t = unlines $ 
+	["Some partially transferred data exists in temporary files:"]
+	++ table t ++ [dropMsg Nothing]
+
+staleBadMsg :: [(Int, Key)] -> String
+staleBadMsg t = unlines $ 
+	["Some corrupted files have been preserved by fsck, just in case:"]
+	++ table t ++ [dropMsg Nothing]
+
+unusedMsg :: [(Int, Key)] -> String
+unusedMsg u = unusedMsg' u
+	["Some annexed data is no longer used by any files:"]
+	[dropMsg Nothing]
+unusedMsg' :: [(Int, Key)] -> [String] -> [String] -> String
+unusedMsg' u header trailer = unlines $
+	header ++
+	table u ++
+	["(To see where data was previously used, try: git log --stat -S'KEY')"] ++
+	trailer
+
+remoteUnusedMsg :: Remote -> [(Int, Key)] -> String
+remoteUnusedMsg r u = unusedMsg' u
+	["Some annexed data on " ++ name ++ " is not used by any files:"]
+	[dropMsg $ Just r]
+	where
+		name = Remote.name r 
+
+dropMsg :: Maybe Remote -> String
+dropMsg Nothing = dropMsg' ""
+dropMsg (Just r) = dropMsg' $ " --from " ++ Remote.name r
+dropMsg' :: String -> String
+dropMsg' s = "\nTo remove unwanted data: git-annex dropunused" ++ s ++ " NUMBER\n"
+
+{- Finds keys in the list that are not referenced in the git repository.
+ -
+ - Strategy:
+ -
+ - * Build a bloom filter of all keys referenced by symlinks. This 
+ -   is the fastest one to build and will filter out most keys.
+ - * If keys remain, build a second bloom filter of keys referenced by
+ -   all branches.
+ - * The list is streamed through these bloom filters lazily, so both will
+ -   exist at the same time. This means that twice the memory is used,
+ -   but they're relatively small, so the added complexity of using a
+ -   mutable bloom filter does not seem worthwhile.
+ - * Generating the second bloom filter can take quite a while, since
+ -   it needs enumerating all keys in all git branches. But, the common
+ -   case, if the second filter is needed, is for some keys to be globally
+ -   unused, and in that case, no short-circuit is possible.
+ -   Short-circuiting if the first filter filters all the keys handles the
+ -   other common case.
+ -}
+excludeReferenced :: [Key] -> Annex [Key]
+excludeReferenced ks = runfilter firstlevel ks >>= runfilter secondlevel
+	where
+		runfilter _ [] = return [] -- optimisation
+		runfilter a l = bloomFilter show l <$> genBloomFilter show a
+		firstlevel = withKeysReferencedM
+		secondlevel = withKeysReferencedInGit
+
+{- Finds items in the first, smaller list, that are not
+ - present in the second, larger list.
+ - 
+ - Constructing a single set, of the list that tends to be
+ - smaller, appears more efficient in both memory and CPU
+ - than constructing and taking the S.difference of two sets. -}
+exclude :: Ord a => [a] -> [a] -> [a]
+exclude [] _ = [] -- optimisation
+exclude smaller larger = S.toList $ remove larger $ S.fromList smaller
+	where
+		remove a b = foldl (flip S.delete) b a
+
+{- A bloom filter capable of holding half a million keys with a
+ - false positive rate of 1 in 1000 uses around 8 mb of memory,
+ - so will easily fit on even my lowest memory systems.
+ -}
+bloomCapacity :: Annex Int
+bloomCapacity = fromMaybe 500000 . readish
+	<$> getConfig (annexConfig "bloomcapacity") ""
+bloomAccuracy :: Annex Int
+bloomAccuracy = fromMaybe 1000 . readish
+	<$> getConfig (annexConfig "bloomaccuracy") ""
+bloomBitsHashes :: Annex (Int, Int)
+bloomBitsHashes = do
+	capacity <- bloomCapacity
+	accuracy <- bloomAccuracy
+	return $ suggestSizing capacity (1/ fromIntegral accuracy)
+
+{- Creates a bloom filter, and runs an action, such as withKeysReferenced,
+ - to populate it.
+ -
+ - The action is passed a callback that it can use to feed values into the
+ - bloom filter. 
+ -
+ - Once the action completes, the mutable filter is frozen
+ - for later use.
+ -}
+genBloomFilter :: Hashable t => (v -> t) -> ((v -> Annex ()) -> Annex b) -> Annex (Bloom t)
+genBloomFilter convert populate = do
+	(numbits, numhashes) <- bloomBitsHashes
+	bloom <- lift $ newMB (cheapHashes numhashes) numbits
+	_ <- populate $ \v -> lift $ insertMB bloom (convert v)
+	lift $ unsafeFreezeMB bloom
+	where
+		lift = liftIO . stToIO
+
+bloomFilter :: Hashable t => (v -> t) -> [v] -> Bloom t -> [v]
+bloomFilter convert l bloom = filter (\k -> convert k `notElemB` bloom) l
+
+{- Given an initial value, folds it with each key referenced by
+ - symlinks in the git repo. -}
+withKeysReferenced :: v -> (Key -> v -> v) -> Annex v
+withKeysReferenced initial a = withKeysReferenced' initial folda
+	where
+		folda k v = return $ a k v
+
+{- Runs an action on each referenced key in the git repo. -}
+withKeysReferencedM :: (Key -> Annex ()) -> Annex ()
+withKeysReferencedM a = withKeysReferenced' () calla
+	where
+		calla k _ = a k
+
+withKeysReferenced' :: v -> (Key -> v -> Annex v) -> Annex v
+withKeysReferenced' initial a = go initial =<< files
+	where
+		files = do
+			top <- fromRepo Git.repoPath
+			inRepo $ LsFiles.inRepo [top]
+		go v [] = return v
+		go v (f:fs) = do
+			x <- Backend.lookupFile f
+			case x of
+				Nothing -> go v fs
+				Just (k, _) -> do
+					!v' <- a k v
+					go v' fs
+
+
+withKeysReferencedInGit :: (Key -> Annex ()) -> Annex ()
+withKeysReferencedInGit a = do
+	rs <- relevantrefs <$> showref
+	forM_ rs (withKeysReferencedInGitRef a)
+	where
+		showref = inRepo $ Git.Command.pipeRead [Param "show-ref"]
+		relevantrefs = map (Git.Ref .  snd) .
+			nubBy uniqref .
+			filter ourbranches .
+			map (separate (== ' ')) . lines . L.unpack
+		uniqref (x, _) (y, _) = x == y
+		ourbranchend = '/' : show Annex.Branch.name
+		ourbranches (_, b) = not $ ourbranchend `isSuffixOf` b
+
+withKeysReferencedInGitRef :: (Key -> Annex ()) -> Git.Ref -> Annex ()
+withKeysReferencedInGitRef a ref = do
+	showAction $ "checking " ++ Git.Ref.describe ref
+	go =<< inRepo (LsTree.lsTree ref)
+	where
+		go [] = noop
+		go (l:ls)
+			| isSymLink (LsTree.mode l) = do
+				content <- catFile ref $ LsTree.file l
+				case fileKey (takeFileName $ L.unpack content) of
+					Nothing -> go ls
+					Just k -> do
+						a k
+						go ls
+			| otherwise = go ls
+
+{- Looks in the specified directory for bad/tmp keys, and returns a list
+ - of those that might still have value, or might be stale and removable.
+ - 
+ - Also, stale keys that can be proven to have no value are deleted.
+ -}
+staleKeysPrune :: (Git.Repo -> FilePath) -> Annex [Key]
+staleKeysPrune dirspec = do
+	contents <- staleKeys dirspec
+	
+	dups <- filterM inAnnex contents
+	let stale = contents `exclude` dups
+
+	dir <- fromRepo dirspec
+	liftIO $ forM_ dups $ \t -> removeFile $ dir </> keyFile t
+
+	return stale
+
+staleKeys :: (Git.Repo -> FilePath) -> Annex [Key]
+staleKeys 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 []
+		)

Command/Upgrade.hs

@@ -0,0 +1,27 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Upgrade where
+
+import Common.Annex
+import Command
+import Upgrade
+import Annex.Version
+
+def :: [Command]
+def = [dontCheck repoExists $ -- because an old version may not seem to exist
+	command "upgrade" paramNothing seek "upgrade repository layout"]
+
+seek :: [CommandSeek]
+seek = [withNothing start]
+
+start :: CommandStart
+start = do
+	showStart "upgrade" "."
+	r <- upgrade
+	setVersion
+	next $ next $ return r

Command/Version.hs

@@ -0,0 +1,36 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Version where
+
+import Common.Annex
+import Command
+import qualified Build.SysConfig as SysConfig
+import Annex.Version
+
+def :: [Command]
+def = [oneShot $ noRepo showPackageVersion $ dontCheck repoExists $
+	command "version" paramNothing seek "show version info"]
+
+seek :: [CommandSeek]
+seek = [withNothing start]
+
+start :: CommandStart
+start = do
+	v <- getVersion
+	liftIO $ do
+		showPackageVersion
+		putStrLn $ "local repository version: " ++ fromMaybe "unknown" v
+		putStrLn $ "default repository version: " ++ defaultVersion
+		putStrLn $ "supported repository versions: " ++ vs supportedVersions
+		putStrLn $ "upgrade supported from repository versions: " ++ vs upgradableVersions
+	stop
+	where
+		vs = join " "
+
+showPackageVersion :: IO ()
+showPackageVersion = putStrLn $ "git-annex version: " ++ SysConfig.packageversion

Command/Whereis.hs

@@ -0,0 +1,54 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Whereis where
+
+import qualified Data.Map as M
+
+import Common.Annex
+import Command
+import Remote
+import Logs.Trust
+
+def :: [Command]
+def = [command "whereis" paramPaths seek
+	"lists repositories that have file content"]
+
+seek :: [CommandSeek]
+seek = [withValue (remoteMap id) $ \m ->
+	withFilesInGit $ whenAnnexed $ start m]
+
+start :: M.Map UUID Remote -> FilePath -> (Key, Backend) -> CommandStart
+start remotemap file (key, _) = do
+	showStart "whereis" file
+	next $ perform remotemap key
+
+perform :: M.Map UUID Remote -> Key -> CommandPerform
+perform remotemap key = do
+	locations <- keyLocations key
+	(untrustedlocations, safelocations) <- trustPartition UnTrusted locations
+	let num = length safelocations
+	showNote $ show num ++ " " ++ copiesplural num
+	pp <- prettyPrintUUIDs "whereis" safelocations
+	unless (null safelocations) $ showLongNote pp
+	pp' <- prettyPrintUUIDs "untrusted" untrustedlocations
+	unless (null untrustedlocations) $ showLongNote $ untrustedheader ++ pp'
+	forM_ (catMaybes $ map (`M.lookup` remotemap) locations) $
+		performRemote key
+	if null safelocations then stop else next $ return True
+	where
+		copiesplural 1 = "copy"
+		copiesplural _ = "copies"
+		untrustedheader = "The following untrusted locations may also have copies:\n"
+
+performRemote :: Key -> Remote -> Annex () 
+performRemote key remote = maybe noop go $ whereisKey remote
+	where
+		go a = do
+			ls <- a key
+			unless (null ls) $ showLongNote $ unlines $
+				map (\l -> name remote ++ ": " ++ l) ls

Common.hs

@@ -0,0 +1,31 @@
+module Common (module X) where
+
+import Control.Monad as X hiding (join)
+import Control.Monad.IfElse as X
+import Control.Applicative as X
+import Control.Monad.State.Strict as X (liftIO)
+import Control.Exception.Extensible as X (IOException)
+
+import Data.Maybe as X
+import Data.List as X hiding (head, tail, init, last)
+import Data.String.Utils as X
+
+import System.Path as X
+import System.FilePath as X
+import System.Directory as X
+import System.Cmd.Utils as X hiding (safeSystem)
+import System.IO as X hiding (FilePath)
+import System.Posix.Files as X
+import System.Posix.IO as X
+import System.Posix.Process as X hiding (executeFile)
+import System.Exit as X
+
+import Utility.Misc as X
+import Utility.Exception as X
+import Utility.SafeCommand as X
+import Utility.Path as X
+import Utility.Directory as X
+import Utility.Monad as X
+import Utility.FileSystemEncoding as X
+
+import Utility.PartialPrelude as X

Common/Annex.hs

@@ -0,0 +1,8 @@
+module Common.Annex (module X) where
+
+import Common as X
+import Types as X
+import Types.UUID as X (toUUID, fromUUID)
+import Annex as X (gitRepo, inRepo, fromRepo)
+import Locations as X
+import Messages as X

Config.hs

@@ -0,0 +1,119 @@
+{- Git configuration
+ -
+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Config where
+
+import Common.Annex
+import qualified Git
+import qualified Git.Config
+import qualified Git.Command
+import qualified Annex
+import Utility.DataUnits
+
+type UnqualifiedConfigKey = String
+data ConfigKey = ConfigKey String
+
+{- Changes a git config setting in both internal state and .git/config -}
+setConfig :: ConfigKey -> String -> Annex ()
+setConfig (ConfigKey key) value = do
+	inRepo $ Git.Command.run "config" [Param key, Param value]
+	newg <- inRepo Git.Config.reRead
+	Annex.changeState $ \s -> s { Annex.repo = newg }
+
+{- Unsets a git config setting. (Leaves it in state currently.) -}
+unsetConfig :: ConfigKey -> Annex ()
+unsetConfig (ConfigKey key) = inRepo $ Git.Command.run "config"
+        [Param "--unset", Param key]
+
+{- Looks up a setting in git config. -}
+getConfig :: ConfigKey -> String -> Annex String
+getConfig (ConfigKey key) def = fromRepo $ Git.Config.get key def
+
+{- Looks up a per-remote config setting in git config.
+ - Failing that, tries looking for a global config option. -}
+getRemoteConfig :: Git.Repo -> UnqualifiedConfigKey -> String -> Annex String
+getRemoteConfig r key def = 
+	getConfig (remoteConfig r key) =<< getConfig (annexConfig key) def
+
+{- A per-remote config setting in git config. -}
+remoteConfig :: Git.Repo -> UnqualifiedConfigKey -> ConfigKey
+remoteConfig r key = ConfigKey $
+	"remote." ++ fromMaybe "" (Git.remoteName r) ++ ".annex-" ++ key
+
+{- A global annex setting in git config. -}
+annexConfig :: UnqualifiedConfigKey -> ConfigKey
+annexConfig key = ConfigKey $ "annex." ++ key
+
+{- Calculates cost for a remote. Either the default, or as configured 
+ - by remote.<name>.annex-cost, or if remote.<name>.annex-cost-command
+ - is set and prints a number, that is used. -}
+remoteCost :: Git.Repo -> Int -> Annex Int
+remoteCost r def = do
+	cmd <- getRemoteConfig r "cost-command" ""
+	(fromMaybe def . readish) <$>
+		if not $ null cmd
+			then liftIO $ snd <$> pipeFrom "sh" ["-c", cmd]
+			else getRemoteConfig r "cost" ""
+
+cheapRemoteCost :: Int
+cheapRemoteCost = 100
+semiCheapRemoteCost :: Int
+semiCheapRemoteCost = 110
+expensiveRemoteCost :: Int
+expensiveRemoteCost = 200
+
+{- Adjusts a remote's cost to reflect it being encrypted. -}
+encryptedRemoteCostAdj :: Int
+encryptedRemoteCostAdj = 50
+
+{- Make sure the remote cost numbers work out. -}
+prop_cost_sane :: Bool
+prop_cost_sane = False `notElem`
+	[ expensiveRemoteCost > 0
+	, cheapRemoteCost < semiCheapRemoteCost
+	, semiCheapRemoteCost < expensiveRemoteCost
+	, cheapRemoteCost + encryptedRemoteCostAdj > semiCheapRemoteCost
+	, cheapRemoteCost + encryptedRemoteCostAdj < expensiveRemoteCost
+	, semiCheapRemoteCost + encryptedRemoteCostAdj < expensiveRemoteCost
+	]
+
+{- Checks if a repo should be ignored. -}
+repoNotIgnored :: Git.Repo -> Annex Bool
+repoNotIgnored r = not . fromMaybe False . Git.Config.isTrue
+	<$> getRemoteConfig r "ignore" ""
+
+{- If a value is specified, it is used; otherwise the default is looked up
+ - in git config. forcenumcopies overrides everything. -}
+getNumCopies :: Maybe Int -> Annex Int
+getNumCopies v = perhaps (use v) =<< Annex.getState Annex.forcenumcopies
+	where
+		use (Just n) = return n
+		use Nothing = perhaps (return 1) =<< 
+			readish <$> getConfig (annexConfig "numcopies") "1"
+		perhaps fallback = maybe fallback (return . id)
+
+{- Gets the trust level set for a remote in git config. -}
+getTrustLevel :: Git.Repo -> Annex (Maybe String)
+getTrustLevel r = fromRepo $ Git.Config.getMaybe key
+	where
+		(ConfigKey key) = remoteConfig r "trustlevel"
+
+{- Gets annex.diskreserve setting. -}
+getDiskReserve :: Annex Integer
+getDiskReserve = fromMaybe megabyte . readSize dataUnits
+	<$> getConfig (annexConfig "diskreserve") ""
+	where
+		megabyte = 1000000
+
+{- Gets annex.httpheaders or annex.httpheaders-command setting,
+ - splitting it into lines. -}
+getHttpHeaders :: Annex [String]
+getHttpHeaders = do
+	cmd <- getConfig (annexConfig "http-headers-command") ""
+	if (null cmd)
+		then fromRepo $ Git.Config.getList "annex.http-headers"
+		else lines . snd <$> liftIO (pipeFrom "sh" ["-c", cmd])

Crypto.hs

@@ -0,0 +1,152 @@
+{- git-annex crypto
+ -
+ - Currently using gpg; could later be modified to support different
+ - crypto backends if neccessary.
+ -
+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Crypto (
+	Cipher,
+	KeyIds(..),
+	StorableCipher(..),
+	genEncryptedCipher,
+	genSharedCipher,
+	updateEncryptedCipher,
+	describeCipher,
+	decryptCipher,		
+	encryptKey,
+	withEncryptedHandle,
+	withDecryptedHandle,
+	withEncryptedContent,
+	withDecryptedContent,
+
+	prop_hmacWithCipher_sane
+) where
+
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.ByteString.Lazy.UTF8 (fromString)
+import Data.Digest.Pure.SHA
+import Control.Applicative
+
+import Common.Annex
+import qualified Utility.Gpg as Gpg
+import Types.Key
+import Types.Crypto
+
+{- The first half of a Cipher is used for HMAC; the remainder
+ - is used as the GPG symmetric encryption passphrase.
+ -
+ - HMAC SHA1 needs only 64 bytes. The remainder is for expansion,
+ - perhaps to HMAC SHA512, which needs 128 bytes (ideally).
+ -
+ - 256 is enough for gpg's symetric cipher; unlike weaker public key
+ - crypto, the key does not need to be too large.
+ -}
+cipherHalf :: Int
+cipherHalf = 256
+
+cipherSize :: Int
+cipherSize = cipherHalf * 2
+
+cipherPassphrase :: Cipher -> String
+cipherPassphrase (Cipher c) = drop cipherHalf c
+
+cipherHmac :: Cipher -> String
+cipherHmac (Cipher c) = take cipherHalf c
+
+{- Creates a new Cipher, encrypted to the specificed key id. -}
+genEncryptedCipher :: String -> IO StorableCipher
+genEncryptedCipher keyid = do
+	ks <- Gpg.findPubKeys keyid
+	random <- Gpg.genRandom cipherSize
+	encryptCipher (Cipher random) ks
+
+{- Creates a new, shared Cipher. -}
+genSharedCipher :: IO StorableCipher
+genSharedCipher = SharedCipher <$> Gpg.genRandom cipherSize
+
+{- Updates an existing Cipher, re-encrypting it to add a keyid. -}
+updateEncryptedCipher :: String -> StorableCipher -> IO StorableCipher
+updateEncryptedCipher _ (SharedCipher _) = undefined
+updateEncryptedCipher keyid encipher@(EncryptedCipher _ ks) = do
+	ks' <- Gpg.findPubKeys keyid
+	cipher <- decryptCipher encipher
+	encryptCipher cipher (merge ks ks')
+	where
+		merge (KeyIds a) (KeyIds b) = KeyIds $ a ++ b
+
+describeCipher :: StorableCipher -> String
+describeCipher (SharedCipher _) = "shared cipher"
+describeCipher (EncryptedCipher _ (KeyIds ks)) =
+	"with gpg " ++ keys ks ++ " " ++ unwords ks
+	where
+		keys [_] = "key"
+		keys _ = "keys"
+
+{- Encrypts a Cipher to the specified KeyIds. -}
+encryptCipher :: Cipher -> KeyIds -> IO StorableCipher
+encryptCipher (Cipher c) (KeyIds ks) = do
+	let ks' = nub $ sort ks -- gpg complains about duplicate recipient keyids
+	encipher <- Gpg.pipeStrict (encrypt++recipients ks') c
+	return $ EncryptedCipher encipher (KeyIds ks')
+	where
+		encrypt = [ Params "--encrypt" ]
+		recipients l = force_recipients :
+			concatMap (\k -> [Param "--recipient", Param k]) l
+		-- Force gpg to only encrypt to the specified
+		-- recipients, not configured defaults.
+		force_recipients = Params "--no-encrypt-to --no-default-recipient"
+
+{- Decrypting an EncryptedCipher is expensive; the Cipher should be cached. -}
+decryptCipher :: StorableCipher -> IO Cipher
+decryptCipher (SharedCipher t) = return $ Cipher t
+decryptCipher (EncryptedCipher t _) = Cipher <$> Gpg.pipeStrict decrypt t
+	where
+		decrypt = [ Param "--decrypt" ]
+
+{- Generates an encrypted form of a Key. The encryption does not need to be
+ - reversable, nor does it need to be the same type of encryption used
+ - on content. It does need to be repeatable. -}
+encryptKey :: Cipher -> Key -> Key
+encryptKey c k = Key
+	{ keyName = hmacWithCipher c (show k)
+	, keyBackendName = "GPGHMACSHA1"
+	, keySize = Nothing -- size and mtime omitted
+	, keyMtime = Nothing -- to avoid leaking data
+	}
+
+{- Runs an action, passing it a handle from which it can 
+ - stream encrypted content. -}
+withEncryptedHandle :: Cipher -> IO L.ByteString -> (Handle -> IO a) -> IO a
+withEncryptedHandle = Gpg.passphraseHandle [Params "--symmetric --force-mdc"] . cipherPassphrase
+
+{- Runs an action, passing it a handle from which it can
+ - stream decrypted content. -}
+withDecryptedHandle :: Cipher -> IO L.ByteString -> (Handle -> IO a) -> IO a
+withDecryptedHandle = Gpg.passphraseHandle [Param "--decrypt"] . cipherPassphrase
+
+{- Streams encrypted content to an action. -}
+withEncryptedContent :: Cipher -> IO L.ByteString -> (L.ByteString -> IO a) -> IO a
+withEncryptedContent = pass withEncryptedHandle
+
+{- Streams decrypted content to an action. -}
+withDecryptedContent :: Cipher -> IO L.ByteString -> (L.ByteString -> IO a) -> IO a
+withDecryptedContent = pass withDecryptedHandle
+
+pass :: (Cipher -> IO L.ByteString -> (Handle -> IO a) -> IO a) 
+      -> Cipher -> IO L.ByteString -> (L.ByteString -> IO a) -> IO a
+pass to n s a = to n s $ \h -> a =<< L.hGetContents h
+
+hmacWithCipher :: Cipher -> String -> String
+hmacWithCipher c = hmacWithCipher' (cipherHmac c) 
+hmacWithCipher' :: String -> String -> String
+hmacWithCipher' c s = showDigest $ hmacSha1 (fromString c) (fromString s)
+
+{- Ensure that hmacWithCipher' returns the same thing forevermore. -}
+prop_hmacWithCipher_sane :: Bool
+prop_hmacWithCipher_sane = known_good == hmacWithCipher' "foo" "bar"
+	where
+		known_good = "46b4ec586117154dacd49d664e5d63fdc88efb51"

GPL

@@ -0,0 +1 @@
+doc/GPL

Git.hs

@@ -0,0 +1,125 @@
+{- git repository handling 
+ -
+ - This is written to be completely independant of git-annex and should be
+ - suitable for other uses.
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git (
+	Repo(..),
+	Ref(..),
+	Branch,
+	Sha,
+	Tag,
+	repoIsUrl,
+	repoIsSsh,
+	repoIsHttp,
+	repoIsLocal,
+	repoIsLocalBare,
+	repoDescribe,
+	repoLocation,
+	repoPath,
+	localGitDir,
+	attributes,
+	hookPath,
+	assertLocal,
+) where
+
+import Network.URI (uriPath, uriScheme, unEscapeString)
+import System.Posix.Files
+
+import Common
+import Git.Types
+import Utility.FileMode
+
+{- User-visible description of a git repo. -}
+repoDescribe :: Repo -> String
+repoDescribe Repo { remoteName = Just name } = name
+repoDescribe Repo { location = Url url } = show url
+repoDescribe Repo { location = Local { worktree = Just dir } } = dir
+repoDescribe Repo { location = Local { gitdir = dir } } = dir
+repoDescribe Repo { location = LocalUnknown dir } = dir
+repoDescribe Repo { location = Unknown } = "UNKNOWN"
+
+{- Location of the repo, either as a path or url. -}
+repoLocation :: Repo -> String
+repoLocation Repo { location = Url url } = show url
+repoLocation Repo { location = Local { worktree = Just dir } } = dir
+repoLocation Repo { location = Local { gitdir = dir } } = dir
+repoLocation Repo { location = LocalUnknown dir } = dir
+repoLocation Repo { location = Unknown } = undefined
+
+{- Path to a repository. For non-bare, this is the worktree, for bare, 
+ - it's the gitdir, and for URL repositories, is the path on the remote
+ - host. -}
+repoPath :: Repo -> FilePath
+repoPath Repo { location = Url u } = unEscapeString $ uriPath u
+repoPath Repo { location = Local { worktree = Just d } } = d
+repoPath Repo { location = Local { gitdir = d } } = d
+repoPath Repo { location = LocalUnknown dir } = dir
+repoPath Repo { location = Unknown } = undefined
+
+{- Path to a local repository's .git directory. -}
+localGitDir :: Repo -> FilePath
+localGitDir Repo { location = Local { gitdir = d } } = d
+localGitDir _ = undefined
+
+{- Some code needs to vary between URL and normal repos,
+ - or bare and non-bare, these functions help with that. -}
+repoIsUrl :: Repo -> Bool
+repoIsUrl Repo { location = Url _ } = True
+repoIsUrl _ = False
+
+repoIsSsh :: Repo -> Bool
+repoIsSsh Repo { location = Url url } 
+	| scheme == "ssh:" = True
+	-- git treats these the same as ssh
+	| scheme == "git+ssh:" = True
+	| scheme == "ssh+git:" = True
+	| otherwise = False
+	where
+		scheme = uriScheme url
+repoIsSsh _ = False
+
+repoIsHttp :: Repo -> Bool
+repoIsHttp Repo { location = Url url } 
+	| uriScheme url == "http:" = True
+	| uriScheme url == "https:" = True
+	| otherwise = False
+repoIsHttp _ = False
+
+repoIsLocal :: Repo -> Bool
+repoIsLocal Repo { location = Local { } } = True
+repoIsLocal _ = False
+
+repoIsLocalBare :: Repo -> Bool
+repoIsLocalBare Repo { location = Local { worktree = Nothing } } = True
+repoIsLocalBare _ = False
+
+assertLocal :: Repo -> a -> a
+assertLocal repo action
+	| repoIsUrl repo = error $ unwords
+		[ "acting on non-local git repo"
+		, repoDescribe repo
+		, "not supported"
+		]
+	| otherwise = action
+
+{- Path to a repository's gitattributes file. -}
+attributes :: Repo -> FilePath
+attributes repo
+	| repoIsLocalBare repo = repoPath repo ++ "/info/.gitattributes"
+	| otherwise = repoPath repo ++ "/.gitattributes"
+
+{- Path to a given hook script in a repository, only if the hook exists
+ - and is executable. -}
+hookPath :: String -> Repo -> IO (Maybe FilePath)
+hookPath script repo = do
+	let hook = localGitDir repo </> "hooks" </> script
+	ifM (catchBoolIO $ isexecutable hook)
+		( return $ Just hook , return Nothing )
+	where
+		isexecutable f = isExecutable . fileMode <$> getFileStatus f

Git/AutoCorrect.hs

@@ -0,0 +1,71 @@
+{- git autocorrection using Damerau-Levenshtein edit distance
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.AutoCorrect where
+
+import Common
+import Git.Types
+import qualified Git.Config
+
+import Text.EditDistance
+import Control.Concurrent
+
+{- These are the same cost values as used in git. -}
+gitEditCosts :: EditCosts
+gitEditCosts = EditCosts
+	{ deletionCosts = ConstantCost 4
+	, insertionCosts = ConstantCost 1
+	, substitutionCosts = ConstantCost 2
+	, transpositionCosts = ConstantCost 0
+	}
+		
+{- Git's source calls this "an empirically derived magic number" -}
+similarityFloor :: Int
+similarityFloor = 7
+
+{- Finds inexact matches for the input amoung the choices.
+ - Returns an ordered list of good enough matches, or an empty list if
+ - nothing matches well. -}
+fuzzymatches :: String -> (c -> String) -> [c] -> [c]
+fuzzymatches input showchoice choices = fst $ unzip $
+	sortBy comparecost $ filter similarEnough $ zip choices costs
+        where
+                distance = restrictedDamerauLevenshteinDistance gitEditCosts input
+                costs = map (distance . showchoice) choices
+                comparecost a b = compare (snd a) (snd b)
+                similarEnough (_, cst) = cst < similarityFloor
+
+{- Takes action based on git's autocorrect configuration, in preparation for
+ - an autocorrected command being run. -}
+prepare :: String -> (c -> String) -> [c] -> Repo -> IO ()
+prepare input showmatch matches r =
+	case readish $ Git.Config.get "help.autocorrect" "0" r of
+		Just n
+			| n == 0 -> list
+			| n < 0 -> warn
+			| otherwise -> sleep n
+		Nothing -> list
+	where
+		list = error $ unlines $
+			[ "Unknown command '" ++ input ++ "'"
+			, ""
+			, "Did you mean one of these?"
+			] ++ map (\m -> "\t" ++ showmatch m) matches
+		warn = 
+			hPutStr stderr $ unlines
+				[ "WARNING: You called a command named '" ++
+				  input ++ "', which does not exist."
+				, "Continuing under the assumption that you meant '" ++
+				  showmatch (Prelude.head matches) ++ "'"
+				]
+		sleep n = do
+			warn
+			hPutStrLn stderr $ unwords
+				[ "in"
+				, show (fromIntegral n / 10 :: Float)
+				, "seconds automatically..."]
+			threadDelay (n * 100000) -- deciseconds to microseconds

Git/Branch.hs

@@ -0,0 +1,87 @@
+{- git branch stuff
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Branch where
+
+import qualified Data.ByteString.Lazy.Char8 as L
+
+import Common
+import Git
+import Git.Sha
+import Git.Command
+
+{- The currently checked out branch. -}
+current :: Repo -> IO (Maybe Git.Ref)
+current r = parse <$> pipeRead [Param "symbolic-ref", Param "HEAD"] r
+	where
+		parse v
+			| L.null v = Nothing
+			| otherwise = Just $ Git.Ref $ firstLine $ L.unpack v
+
+{- Checks if the second branch has any commits not present on the first
+ - branch. -}
+changed :: Branch -> Branch -> Repo -> IO Bool
+changed origbranch newbranch repo
+	| origbranch == newbranch = return False
+	| otherwise = not . L.null <$> diffs
+	where
+		diffs = pipeRead
+			[ Param "log"
+			, Param (show origbranch ++ ".." ++ show newbranch)
+			, Params "--oneline -n1"
+			] repo
+
+{- Given a set of refs that are all known to have commits not
+ - on the branch, tries to update the branch by a fast-forward.
+ -
+ - In order for that to be possible, one of the refs must contain
+ - every commit present in all the other refs.
+ -}
+fastForward :: Branch -> [Ref] -> Repo -> IO Bool
+fastForward _ [] _ = return True
+fastForward branch (first:rest) repo =
+	-- First, check that the branch does not contain any
+	-- new commits that are not in the first ref. If it does,
+	-- cannot fast-forward.
+	ifM (changed first branch repo)
+		( no_ff
+		, maybe no_ff do_ff =<< findbest first rest
+		)
+	where
+		no_ff = return False
+		do_ff to = do
+			run "update-ref"
+				[Param $ show branch, Param $ show to] repo
+			return True
+		findbest c [] = return $ Just c
+		findbest c (r:rs)
+			| c == r = findbest c rs
+			| otherwise = do
+			better <- changed c r repo
+			worse <- changed r c repo
+			case (better, worse) of
+				(True, True) -> return Nothing -- divergent fail
+				(True, False) -> findbest r rs -- better
+				(False, True) -> findbest c rs -- worse
+				(False, False) -> findbest c rs -- same
+
+{- Commits the index into the specified branch (or other ref), 
+ - with the specified parent refs, and returns the committed sha -}
+commit :: String -> Branch -> [Ref] -> Repo -> IO Sha
+commit message branch parentrefs repo = do
+	tree <- getSha "write-tree" $ asString $
+		pipeRead [Param "write-tree"] repo
+	sha <- getSha "commit-tree" $ asString $
+		ignorehandle $ pipeWriteRead
+			(map Param $ ["commit-tree", show tree] ++ ps)
+			(L.pack message) repo
+	run "update-ref" [Param $ show branch, Param $ show sha] repo
+	return sha
+	where
+		ignorehandle a = snd <$> a
+		asString a = L.unpack <$> a
+		ps = concatMap (\r -> ["-p", show r]) parentrefs

Git/CatFile.hs

@@ -0,0 +1,74 @@
+{- git cat-file interface
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.CatFile (
+	CatFileHandle,
+	catFileStart,
+	catFileStop,
+	catFile,
+	catObject
+) where
+
+import System.IO
+import qualified Data.ByteString.Char8 as S
+import qualified Data.ByteString.Lazy.Char8 as L
+
+import Common
+import Git
+import Git.Sha
+import Git.Command
+import qualified Utility.CoProcess as CoProcess
+
+type CatFileHandle = CoProcess.CoProcessHandle
+
+catFileStart :: Repo -> IO CatFileHandle
+catFileStart = CoProcess.start "git" . toCommand . gitCommandLine
+	[ Param "cat-file"
+	, Param "--batch"
+	]
+
+catFileStop :: CatFileHandle -> IO ()
+catFileStop = CoProcess.stop
+
+{- Reads a file from a specified branch. -}
+catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString
+catFile h branch file = catObject h $ Ref $ show branch ++ ":" ++ file
+
+{- Uses a running git cat-file read the content of an object.
+ - Objects that do not exist will have "" returned. -}
+catObject :: CatFileHandle -> Ref -> IO L.ByteString
+catObject h object = CoProcess.query h send receive
+	where
+		send to = do
+			fileEncoding to
+			hPutStrLn to $ show object
+		receive from = do
+			fileEncoding from
+			header <- hGetLine from
+			case words header of
+				[sha, objtype, size]
+					| length sha == shaSize &&
+					  validobjtype objtype -> 
+						case reads size of
+							[(bytes, "")] -> readcontent bytes from
+							_ -> dne
+					| otherwise -> dne
+				_
+					| header == show object ++ " missing" -> dne
+					| otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)
+		readcontent bytes from = do
+			content <- S.hGet from bytes
+			c <- hGetChar from
+			when (c /= '\n') $
+				error "missing newline from git cat-file"
+			return $ L.fromChunks [content]
+		dne = return L.empty
+		validobjtype t
+			| t == "blob" = True
+			| t == "commit" = True
+			| t == "tree" = True
+			| otherwise = False

Git/CheckAttr.hs

@@ -0,0 +1,67 @@
+{- git check-attr interface
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.CheckAttr where
+
+import Common
+import Git
+import Git.Command
+import qualified Git.Version
+import qualified Utility.CoProcess as CoProcess
+
+type CheckAttrHandle = (CoProcess.CoProcessHandle, [Attr], String)
+
+type Attr = String
+
+{- Starts git check-attr running to look up the specified gitattributes
+ - values and returns a handle.  -}
+checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle
+checkAttrStart attrs repo = do
+	cwd <- getCurrentDirectory
+	h <- CoProcess.start "git" $ toCommand $ gitCommandLine params repo
+	return (h, attrs, cwd)
+	where
+		params =
+			[ Param "check-attr" 
+			, Params "-z --stdin"
+			] ++ map Param attrs ++
+			[ Param "--" ]
+
+checkAttrStop :: CheckAttrHandle -> IO ()
+checkAttrStop (h, _, _) = CoProcess.stop h
+
+{- Gets an attribute of a file. -}
+checkAttr :: CheckAttrHandle -> Attr -> FilePath -> IO String
+checkAttr (h, attrs, cwd) want file = do
+	pairs <- CoProcess.query h send receive
+	let vals = map snd $ filter (\(attr, _) -> attr == want) pairs
+	case vals of
+		[v] -> return v
+		_ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file
+	where
+		send to = do
+			fileEncoding to
+			hPutStr to $ file' ++ "\0"
+		receive from = forM attrs $ \attr -> do
+			fileEncoding from
+			l <- hGetLine from
+			return (attr, attrvalue attr l)
+		{- Before git 1.7.7, git check-attr worked best with
+		 - absolute filenames; using them worked around some bugs
+		 - with relative filenames.
+		 - 
+		 - With newer git, git check-attr chokes on some absolute
+		 - filenames, and the bugs that necessitated them were fixed,
+		 - so use relative filenames. -}
+		oldgit = Git.Version.older "1.7.7"
+		file'
+			| oldgit = absPathFrom cwd file
+			| otherwise = relPathDirToFile cwd $ absPathFrom cwd file
+		attrvalue attr l = end bits !! 0
+			where
+				bits = split sep l
+				sep = ": " ++ attr ++ ": "

Git/Command.hs

@@ -0,0 +1,83 @@
+{- running git commands
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Command where
+
+import qualified Data.ByteString.Lazy.Char8 as L
+
+import Common
+import Git
+import Git.Types
+
+{- Constructs a git command line operating on the specified repo. -}
+gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
+gitCommandLine params Repo { location = l@(Local _ _ ) } = setdir : settree ++ params
+	where
+		setdir = Param $ "--git-dir=" ++ gitdir l
+		settree = case worktree l of
+			Nothing -> []
+			Just t -> [Param $ "--work-tree=" ++ t]
+gitCommandLine _ repo = assertLocal repo $ error "internal"
+
+{- Runs git in the specified repo. -}
+runBool :: String -> [CommandParam] -> Repo -> IO Bool
+runBool subcommand params repo = assertLocal repo $
+	boolSystem "git" $ gitCommandLine (Param subcommand : params) repo
+
+{- Runs git in the specified repo, throwing an error if it fails. -}
+run :: String -> [CommandParam] -> Repo -> IO ()
+run subcommand params repo = assertLocal repo $
+	unlessM (runBool subcommand params repo) $
+		error $ "git " ++ subcommand ++ " " ++ show params ++ " failed"
+
+{- Runs a git subcommand and returns its output, lazily. 
+ -
+ - Note that this leaves the git process running, and so zombies will
+ - result unless reap is called.
+ -}
+pipeRead :: [CommandParam] -> Repo -> IO L.ByteString
+pipeRead params repo = assertLocal repo $ do
+	(_, h) <- hPipeFrom "git" $ toCommand $ gitCommandLine params repo
+	hSetBinaryMode h True
+	L.hGetContents h
+
+{- Runs a git subcommand, feeding it input.
+ - You should call either getProcessStatus or forceSuccess on the PipeHandle. -}
+pipeWrite :: [CommandParam] -> L.ByteString -> Repo -> IO PipeHandle
+pipeWrite params s repo = assertLocal repo $ do
+	(p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo)
+	L.hPut h s
+	hClose h
+	return p
+
+{- Runs a git subcommand, feeding it input, and returning its output.
+ - You should call either getProcessStatus or forceSuccess on the PipeHandle. -}
+pipeWriteRead :: [CommandParam] -> L.ByteString -> Repo -> IO (PipeHandle, L.ByteString)
+pipeWriteRead params s repo = assertLocal repo $ do
+	(p, from, to) <- hPipeBoth "git" (toCommand $ gitCommandLine params repo)
+	hSetBinaryMode from True
+	L.hPut to s
+	hClose to
+	c <- L.hGetContents from
+	return (p, c)
+
+{- Reads null terminated output of a git command (as enabled by the -z 
+ - parameter), and splits it. -}
+pipeNullSplit :: [CommandParam] -> Repo -> IO [String]
+pipeNullSplit params repo = map L.unpack <$> pipeNullSplitB params repo
+
+{- For when Strings are not needed. -}
+pipeNullSplitB ::[CommandParam] -> Repo -> IO [L.ByteString]
+pipeNullSplitB params repo = filter (not . L.null) . L.split '\0' <$>
+	pipeRead params repo
+
+{- Reaps any zombie git processes. -}
+reap :: IO ()
+reap = do
+	-- throws an exception when there are no child processes
+	catchDefaultIO (getAnyProcessStatus False True) Nothing
+		>>= maybe noop (const reap)

Git/Config.hs

@@ -0,0 +1,118 @@
+{- git repository configuration handling
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Config where
+
+import qualified Data.Map as M
+import Data.Char
+
+import Common
+import Git
+import Git.Types
+import qualified Git.Construct
+
+{- Returns a single git config setting, or a default value if not set. -}
+get :: String -> String -> Repo -> String
+get key defaultValue repo = M.findWithDefault defaultValue key (config repo)
+
+{- Returns a list with each line of a multiline config setting. -}
+getList :: String -> Repo -> [String]
+getList key repo = M.findWithDefault [] key (fullconfig repo)
+
+{- Returns a single git config setting, if set. -}
+getMaybe :: String -> Repo -> Maybe String
+getMaybe key repo = M.lookup key (config repo)
+
+{- Runs git config and populates a repo with its config.
+ - Avoids re-reading config when run repeatedly. -}
+read :: Repo -> IO Repo
+read repo@(Repo { config = c })
+	| c == M.empty = read' repo
+	| otherwise = return repo
+
+{- Reads config even if it was read before. -}
+reRead :: Repo -> IO Repo
+reRead = read'
+
+{- Cannot use pipeRead because it relies on the config having been already
+ - read. Instead, chdir to the repo.
+ -}
+read' :: Repo -> IO Repo
+read' repo = go repo
+	where
+		go Repo { location = Local { gitdir = d } } = git_config d
+		go Repo { location = LocalUnknown d } = git_config d
+		go _ = assertLocal repo $ error "internal"
+		git_config d = bracketCd d $
+			pOpen ReadFromPipe "git" ["config", "--null", "--list"] $
+				hRead repo
+
+{- Reads git config from a handle and populates a repo with it. -}
+hRead :: Repo -> Handle -> IO Repo
+hRead repo h = do
+	val <- hGetContentsStrict h
+	store val repo
+
+{- Stores a git config into a Repo, returning the new version of the Repo.
+ - The git config may be multiple lines, or a single line.
+ - Config settings can be updated incrementally.
+ -}
+store :: String -> Repo -> IO Repo
+store s repo = do
+	let c = parse s
+	let repo' = updateLocation $ repo
+		{ config = (M.map Prelude.head c) `M.union` config repo
+		, fullconfig = M.unionWith (++) c (fullconfig repo)
+		}
+	rs <- Git.Construct.fromRemotes repo'
+	return $ repo' { remotes = rs }
+
+{- Updates the location of a repo, based on its configuration.
+ -
+ - Git.Construct makes LocalUknown repos, of which only a directory is
+ - known. Once the config is read, this can be fixed up to a Local repo, 
+ - based on the core.bare and core.worktree settings.
+ -}
+updateLocation :: Repo -> Repo
+updateLocation r@(Repo { location = LocalUnknown d })
+	| isBare r = newloc $ Local d Nothing
+	| otherwise = newloc $ Local (d </> ".git") (Just d)
+	where
+		newloc l = r { location = getworktree l }
+		getworktree l = case workTree r of
+			Nothing -> l
+			wt -> l { worktree = wt }
+updateLocation r = r
+
+{- Parses git config --list or git config --null --list output into a
+ - config map. -}
+parse :: String -> M.Map String [String]
+parse [] = M.empty
+parse s
+	-- --list output will have an = in the first line
+	| all ('=' `elem`) (take 1 ls) = sep '=' ls
+	-- --null --list output separates keys from values with newlines
+	| otherwise = sep '\n' $ split "\0" s
+	where
+		ls = lines s
+		sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .
+			map (separate (== c))
+
+{- Checks if a string from git config is a true value. -}
+isTrue :: String -> Maybe Bool
+isTrue s
+	| s' == "true" = Just True
+	| s' == "false" = Just False
+	| otherwise = Nothing
+	where
+		s' = map toLower s
+
+isBare :: Repo -> Bool
+isBare r = fromMaybe False $ isTrue =<< getMaybe "core.bare" r
+
+workTree :: Repo -> Maybe FilePath
+workTree = getMaybe "core.worktree"

Git/Construct.hs

@@ -0,0 +1,230 @@
+{- Construction of Git Repo objects
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Construct (
+	fromCwd,
+	fromAbsPath,
+	fromPath,
+	fromUrl,
+	fromUnknown,
+	localToUrl,
+	remoteNamed,
+	remoteNamedFromKey,
+	fromRemotes,
+	fromRemoteLocation,
+	repoAbsPath,
+) where
+
+import System.Posix.User
+import qualified Data.Map as M hiding (map, split)
+import Network.URI
+
+import Common
+import Git.Types
+import Git
+import qualified Git.Url as Url
+
+{- Finds the git repository used for the Cwd, which may be in a parent
+ - directory. -}
+fromCwd :: IO Repo
+fromCwd = getCurrentDirectory >>= seekUp isRepoTop >>= maybe norepo makerepo
+	where
+		makerepo = newFrom . LocalUnknown
+		norepo = error "Not in a git repository."
+
+{- Local Repo constructor, accepts a relative or absolute path. -}
+fromPath :: FilePath -> IO Repo
+fromPath dir = fromAbsPath =<< absPath dir
+
+{- Local Repo constructor, requires an absolute path to the repo be
+ - specified. -}
+fromAbsPath :: FilePath -> IO Repo
+fromAbsPath dir
+	| "/" `isPrefixOf` dir =
+		ifM (doesDirectoryExist dir') ( ret dir' , hunt )
+	| otherwise =
+		error $ "internal error, " ++ dir ++ " is not absolute"
+	where
+		ret = newFrom . LocalUnknown
+ 		{- Git always looks for "dir.git" in preference to
+		 - to "dir", even if dir ends in a "/". -}
+		canondir = dropTrailingPathSeparator dir
+		dir' = canondir ++ ".git"
+		{- When dir == "foo/.git", git looks for "foo/.git/.git",
+		 - and failing that, uses "foo" as the repository. -}
+		hunt
+			| "/.git" `isSuffixOf` canondir =
+				ifM (doesDirectoryExist $ dir </> ".git")
+					( ret dir
+					, ret $ takeDirectory canondir
+					)
+			| otherwise = ret dir
+
+{- Remote Repo constructor. Throws exception on invalid url.
+ -
+ - Git is somewhat forgiving about urls to repositories, allowing
+ - eg spaces that are not normally allowed unescaped in urls.
+ -}
+fromUrl :: String -> IO Repo
+fromUrl url
+	| not (isURI url) = fromUrlStrict $ escapeURIString isUnescapedInURI url
+	| otherwise = fromUrlStrict url
+
+fromUrlStrict :: String -> IO Repo
+fromUrlStrict url
+	| startswith "file://" url = fromAbsPath $ uriPath u
+	| otherwise = newFrom $ Url u
+	where
+		u = fromMaybe bad $ parseURI url
+		bad = error $ "bad url " ++ url
+
+{- Creates a repo that has an unknown location. -}
+fromUnknown :: IO Repo
+fromUnknown = newFrom Unknown
+
+{- Converts a local Repo into a remote repo, using the reference repo
+ - which is assumed to be on the same host. -}
+localToUrl :: Repo -> Repo -> Repo
+localToUrl reference r
+	| not $ repoIsUrl reference = error "internal error; reference repo not url"
+	| repoIsUrl r = r
+	| otherwise = r { location = Url $ fromJust $ parseURI absurl }
+	where
+		absurl =
+			Url.scheme reference ++ "//" ++
+			Url.authority reference ++
+			repoPath r
+
+{- Calculates a list of a repo's configured remotes, by parsing its config. -}
+fromRemotes :: Repo -> IO [Repo]
+fromRemotes repo = mapM construct remotepairs
+	where
+		filterconfig f = filter f $ M.toList $ config repo
+		filterkeys f = filterconfig (\(k,_) -> f k)
+		remotepairs = filterkeys isremote
+		isremote k = startswith "remote." k && endswith ".url" k
+		construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo
+
+{- Sets the name of a remote when constructing the Repo to represent it. -}
+remoteNamed :: String -> IO Repo -> IO Repo
+remoteNamed n constructor = do
+	r <- constructor
+	return $ r { remoteName = Just n }
+
+{- Sets the name of a remote based on the git config key, such as
+   "remote.foo.url". -}
+remoteNamedFromKey :: String -> IO Repo -> IO Repo
+remoteNamedFromKey k = remoteNamed basename
+	where
+		basename = join "." $ reverse $ drop 1 $
+				reverse $ drop 1 $ split "." k
+
+{- Constructs a new Repo for one of a Repo's remotes using a given
+ - location (ie, an url). -}
+fromRemoteLocation :: String -> Repo -> IO Repo
+fromRemoteLocation s repo = gen $ calcloc s
+	where
+		gen v	
+			| scpstyle v = fromUrl $ scptourl v
+			| urlstyle v = fromUrl v
+			| otherwise = fromRemotePath v repo
+		-- insteadof config can rewrite remote location
+		calcloc l
+			| null insteadofs = l
+			| otherwise = replacement ++ drop (length bestvalue) l
+			where
+				replacement = drop (length prefix) $
+					take (length bestkey - length suffix) bestkey
+				(bestkey, bestvalue) = maximumBy longestvalue insteadofs
+				longestvalue (_, a) (_, b) = compare b a
+				insteadofs = filterconfig $ \(k, v) -> 
+					startswith prefix k &&
+					endswith suffix k &&
+					startswith v l
+				filterconfig f = filter f $
+					concatMap splitconfigs $
+						M.toList $ fullconfig repo
+				splitconfigs (k, vs) = map (\v -> (k, v)) vs
+				(prefix, suffix) = ("url." , ".insteadof")
+		urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v
+		-- git remotes can be written scp style -- [user@]host:dir
+		scpstyle v = ":" `isInfixOf` v && not ("//" `isInfixOf` v)
+		scptourl v = "ssh://" ++ host ++ slash dir
+			where
+				(host, dir) = separate (== ':') v
+				slash d	| d == "" = "/~/" ++ d
+					| "/" `isPrefixOf` d = d
+					| "~" `isPrefixOf` d = '/':d
+					| otherwise = "/~/" ++ d
+
+{- Constructs a Repo from the path specified in the git remotes of
+ - another Repo. -}
+fromRemotePath :: FilePath -> Repo -> IO Repo
+fromRemotePath dir repo = do
+	dir' <- expandTilde dir
+	fromAbsPath $ repoPath repo </> dir'
+
+{- Git remotes can have a directory that is specified relative
+ - to the user's home directory, or that contains tilde expansions.
+ - This converts such a directory to an absolute path.
+ - Note that it has to run on the system where the remote is.
+ -}
+repoAbsPath :: FilePath -> IO FilePath
+repoAbsPath d = do
+	d' <- expandTilde d
+	h <- myHomeDir
+	return $ h </> d'
+
+expandTilde :: FilePath -> IO FilePath
+expandTilde = expandt True
+	where
+		expandt _ [] = return ""
+		expandt _ ('/':cs) = do
+			v <- expandt True cs
+			return ('/':v)
+		expandt True ('~':'/':cs) = do
+			h <- myHomeDir
+			return $ h </> cs
+		expandt True ('~':cs) = do
+			let (name, rest) = findname "" cs
+			u <- getUserEntryForName name
+			return $ homeDirectory u </> rest
+		expandt _ (c:cs) = do
+			v <- expandt False cs
+			return (c:v)
+		findname n [] = (n, "")
+		findname n (c:cs)
+			| c == '/' = (n, cs)
+			| otherwise = findname (n++[c]) cs
+
+seekUp :: (FilePath -> IO Bool) -> FilePath -> IO (Maybe FilePath)
+seekUp want dir =
+	ifM (want dir)
+		( return $ Just dir
+		, case parentDir dir of
+			"" -> return Nothing
+			d -> seekUp want d
+		)
+
+isRepoTop :: FilePath -> IO Bool
+isRepoTop dir = ifM isRepo ( return True , isBareRepo )
+	where
+		isRepo = gitSignature (".git" </> "config")
+		isBareRepo = ifM (doesDirectoryExist $ dir </> "objects")
+			( gitSignature "config" , return False )
+		gitSignature file = doesFileExist (dir </> file)
+
+newFrom :: RepoLocation -> IO Repo
+newFrom l = return Repo
+	{ location = l
+	, config = M.empty
+	, fullconfig = M.empty
+	, remotes = []
+	, remoteName = Nothing
+	}
+
+

Git/CurrentRepo.hs

@@ -0,0 +1,58 @@
+{- The current git repository.
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.CurrentRepo where
+
+import System.Posix.Directory (changeWorkingDirectory)
+import System.Posix.Env (getEnv, unsetEnv)
+
+import Common
+import Git.Types
+import Git.Construct
+import qualified Git.Config
+
+{- Gets the current git repository.
+ -
+ - Honors GIT_DIR and GIT_WORK_TREE.
+ - Both environment variables are unset, to avoid confusing other git
+ - commands that also look at them. Instead, the Git module passes
+ - --work-tree and --git-dir to git commands it runs.
+ -
+ - When GIT_WORK_TREE or core.worktree are set, changes the working
+ - directory if necessary to ensure it is within the repository's work
+ - tree. While not needed for git commands, this is useful for anything
+ - else that looks for files in the worktree.
+ -}
+get :: IO Repo
+get = do
+	gd <- pathenv "GIT_DIR"
+	r <- configure gd =<< maybe fromCwd fromPath gd
+	wt <- maybe (Git.Config.workTree r) Just <$> pathenv "GIT_WORK_TREE"
+	case wt of
+		Nothing -> return r
+		Just d -> do
+			cwd <- getCurrentDirectory
+			unless (d `dirContains` cwd) $
+				changeWorkingDirectory d
+			return $ addworktree wt r
+	where
+		pathenv s = do
+			v <- getEnv s
+			when (isJust v) $
+				unsetEnv s
+			case v of
+				Nothing -> return Nothing
+				Just d -> Just <$> absPath d
+		configure Nothing r = Git.Config.read r
+		configure (Just d) r = do
+			r' <- Git.Config.read r
+			-- Let GIT_DIR override the default gitdir.
+			return $ changelocation r' $
+				Local { gitdir = d, worktree = worktree (location r') }
+		addworktree w r = changelocation r $
+			Local { gitdir = gitdir (location r), worktree = w }
+		changelocation r l = r { location = l }

Git/Filename.hs

@@ -0,0 +1,28 @@
+{- Some git commands output encoded filenames, in a rather annoyingly complex
+ - C-style encoding.
+ -
+ - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Filename where
+
+import Utility.Format (decode_c, encode_c)
+
+import Common
+
+decode :: String -> FilePath
+decode [] = []
+decode f@(c:s)
+	-- encoded strings will be inside double quotes
+	| c == '"' && end s == ['"'] = decode_c $ beginning s
+	| otherwise = f
+
+{- Should not need to use this, except for testing decode. -}
+encode :: FilePath -> String
+encode s = "\"" ++ encode_c s ++ "\""
+
+{- for quickcheck -}
+prop_idempotent_deencode :: String -> Bool
+prop_idempotent_deencode s = s == decode (encode s)

Git/HashObject.hs

@@ -0,0 +1,34 @@
+{- git hash-object interface
+ -
+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.HashObject where
+
+import Common
+import Git
+import Git.Command
+import qualified Utility.CoProcess as CoProcess
+
+type HashObjectHandle = CoProcess.CoProcessHandle
+
+hashObjectStart :: Repo -> IO HashObjectHandle
+hashObjectStart = CoProcess.start "git" . toCommand . gitCommandLine
+	[ Param "hash-object"
+	, Param "-w"
+	, Param "--stdin-paths"
+	]
+
+hashObjectStop :: HashObjectHandle -> IO ()
+hashObjectStop = CoProcess.stop
+
+{- Injects a file into git, returning the shas of the objects. -}
+hashFile :: HashObjectHandle -> FilePath -> IO Sha
+hashFile h file = CoProcess.query h send receive
+	where
+		send to = do
+			fileEncoding to
+			hPutStrLn to file
+		receive from = Ref <$> hGetLine from

Git/Index.hs

@@ -0,0 +1,24 @@
+{- git index file stuff
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Index where
+
+import System.Posix.Env (setEnv, unsetEnv, getEnv)
+
+{- Forces git to use the specified index file.
+ -
+ - Returns an action that will reset back to the default
+ - index file. -}
+override :: FilePath -> IO (IO ())
+override index = do
+	res <- getEnv var
+	setEnv var index True
+	return $ reset res
+	where
+		var = "GIT_INDEX_FILE"
+		reset (Just v) = setEnv var v True
+		reset _ = unsetEnv var

Git/LsFiles.hs

@@ -0,0 +1,77 @@
+{- git ls-files interface
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.LsFiles (
+	inRepo,
+	notInRepo,
+	staged,
+	stagedNotDeleted,
+	changedUnstaged,
+	typeChanged,
+	typeChangedStaged,
+) where
+
+import Common
+import Git
+import Git.Command
+
+{- Scans for files that are checked into git at the specified locations. -}
+inRepo :: [FilePath] -> Repo -> IO [FilePath]
+inRepo l = pipeNullSplit $ Params "ls-files --cached -z --" : map File l
+
+{- Scans for files at the specified locations that are not checked into git. -}
+notInRepo :: Bool -> [FilePath] -> Repo -> IO [FilePath]
+notInRepo include_ignored l repo = pipeNullSplit params repo
+	where
+		params = [Params "ls-files --others"] ++ exclude ++
+			[Params "-z --"] ++ map File l
+		exclude
+			| include_ignored = []
+			| otherwise = [Param "--exclude-standard"]
+
+{- Returns a list of all files that are staged for commit. -}
+staged :: [FilePath] -> Repo -> IO [FilePath]
+staged = staged' []
+
+{- Returns a list of the files, staged for commit, that are being added,
+ - moved, or changed (but not deleted), from the specified locations. -}
+stagedNotDeleted :: [FilePath] -> Repo -> IO [FilePath]
+stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"]
+
+staged' :: [CommandParam] -> [FilePath] -> Repo -> IO [FilePath]
+staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix
+	where
+		prefix = [Params "diff --cached --name-only -z"]
+		suffix = Param "--" : map File l
+
+{- Returns a list of files that have unstaged changes. -}
+changedUnstaged :: [FilePath] -> Repo -> IO [FilePath]
+changedUnstaged l = pipeNullSplit params
+	where
+		params = Params "diff --name-only -z --" : map File l
+
+{- Returns a list of the files in the specified locations that are staged
+ - for commit, and whose type has changed. -}
+typeChangedStaged :: [FilePath] -> Repo -> IO [FilePath]
+typeChangedStaged = typeChanged' [Param "--cached"]
+
+{- Returns a list of the files in the specified locations whose type has
+ - changed.  Files only staged for commit will not be included. -}
+typeChanged :: [FilePath] -> Repo -> IO [FilePath]
+typeChanged = typeChanged' []
+
+typeChanged' :: [CommandParam] -> [FilePath] -> Repo -> IO [FilePath]
+typeChanged' ps l repo = do
+	fs <- pipeNullSplit (prefix ++ ps ++ suffix) repo
+	-- git diff returns filenames relative to the top of the git repo;
+	-- convert to filenames relative to the cwd, like git ls-files.
+	let top = repoPath repo
+	cwd <- getCurrentDirectory
+	return $ map (\f -> relPathDirToFile cwd $ top </> f) fs
+	where
+		prefix = [Params "diff --name-only --diff-filter=T -z"]
+		suffix = Param "--" : map File l

Git/LsTree.hs

@@ -0,0 +1,52 @@
+{- git ls-tree interface
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.LsTree (
+	TreeItem(..),
+	lsTree,
+	parseLsTree
+) where
+
+import Numeric
+import Control.Applicative
+import System.Posix.Types
+import qualified Data.ByteString.Lazy.Char8 as L
+
+import Common
+import Git
+import Git.Command
+import qualified Git.Filename
+
+data TreeItem = TreeItem
+	{ mode :: FileMode
+	, typeobj :: String
+	, sha :: String
+	, file :: FilePath
+	} deriving Show
+
+{- Lists the contents of a Ref -}
+lsTree :: Ref -> Repo -> IO [TreeItem]
+lsTree t repo = map parseLsTree <$>
+	pipeNullSplitB [Params "ls-tree --full-tree -z -r --", File $ show t] repo
+
+{- Parses a line of ls-tree output.
+ - (The --long format is not currently supported.) -}
+parseLsTree :: L.ByteString -> TreeItem
+parseLsTree l = TreeItem 
+	{ mode = fst $ Prelude.head $ readOct $ L.unpack m
+	, typeobj = L.unpack t
+	, sha = L.unpack s
+	, file = Git.Filename.decode $ L.unpack f
+	}
+	where
+		-- l = <mode> SP <type> SP <sha> TAB <file>
+		-- All fields are fixed, so we can pull them out of
+		-- specific positions in the line.
+		(m, past_m) = L.splitAt 7 l
+		(t, past_t) = L.splitAt 4 past_m
+		(s, past_s) = L.splitAt 40 $ L.tail past_t
+		f = L.tail past_s

Git/Queue.hs

@@ -0,0 +1,97 @@
+{- git repository command queue
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns #-}
+
+module Git.Queue (
+	Queue,
+	new,
+	add,
+	size,
+	full,
+	flush,
+) where
+
+import qualified Data.Map as M
+import System.IO
+import System.Cmd.Utils
+import Data.String.Utils
+
+import Utility.SafeCommand
+import Common
+import Git
+import Git.Command
+
+{- An action to perform in a git repository. The file to act on
+ - is not included, and must be able to be appended after the params. -}
+data Action = Action
+	{ getSubcommand :: String
+	, getParams :: [CommandParam]
+	} deriving (Show, Eq, Ord)
+
+{- A queue of actions to perform (in any order) on a git repository,
+ - with lists of files to perform them on. This allows coalescing 
+ - similar git commands. -}
+data Queue = Queue
+	{ size :: Int
+	, _limit :: Int
+	, _items :: M.Map Action [FilePath]
+	}
+	deriving (Show, Eq)
+
+{- A recommended maximum size for the queue, after which it should be
+ - run.
+ -
+ - 10240 is semi-arbitrary. If we assume git filenames are between 10 and
+ - 255 characters long, then the queue will build up between 100kb and
+ - 2550kb long commands. The max command line length on linux is somewhere
+ - above 20k, so this is a fairly good balance -- the queue will buffer
+ - only a few megabytes of stuff and a minimal number of commands will be
+ - run by xargs. -}
+defaultLimit :: Int
+defaultLimit = 10240
+
+{- Constructor for empty queue. -}
+new :: Maybe Int -> Queue
+new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty
+
+{- Adds an action to a queue. -}
+add :: Queue -> String -> [CommandParam] -> [FilePath] -> Queue
+add (Queue cur lim m) subcommand params files = Queue (cur + 1) lim m'
+	where
+		action = Action subcommand params
+		-- There are probably few items in the map, but there
+		-- can be a lot of files per item. So, optimise adding
+		-- files.
+		m' = M.insertWith' const action fs m
+		!fs = files ++ M.findWithDefault [] action m
+
+{- Is a queue large enough that it should be flushed? -}
+full :: Queue -> Bool
+full (Queue cur lim  _) = cur > lim
+
+{- Runs a queue on a git repository. -}
+flush :: Queue -> Repo -> IO Queue
+flush (Queue _ lim m) repo = do
+	forM_ (M.toList m) $ uncurry $ runAction repo
+	return $ Queue 0 lim M.empty
+
+{- Runs an Action on a list of files in a git repository.
+ -
+ - Complicated by commandline length limits.
+ -
+ - Intentionally runs the command even if the list of files is empty;
+ - this allows queueing commands that do not need a list of files. -}
+runAction :: Repo -> Action -> [FilePath] -> IO ()
+runAction repo action files =
+	pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs
+	where
+		params = toCommand $ gitCommandLine
+			(Param (getSubcommand action):getParams action) repo
+		feedxargs h = do
+			fileEncoding h
+			hPutStr h $ join "\0" files

Git/Ref.hs

@@ -0,0 +1,94 @@
+{- git ref stuff
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Ref where
+
+import qualified Data.ByteString.Lazy.Char8 as L
+
+import Common
+import Git
+import Git.Command
+
+import Data.Char (chr)
+
+{- Converts a fully qualified git ref into a user-visible string. -}
+describe :: Ref -> String
+describe = show . base
+
+{- Often git refs are fully qualified (eg: refs/heads/master).
+ - Converts such a fully qualified ref into a base ref (eg: master). -}
+base :: Ref -> Ref
+base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show
+	where
+		remove prefix s
+			| prefix `isPrefixOf` s = drop (length prefix) s
+			| otherwise = s
+
+
+{- Given a directory such as "refs/remotes/origin", and a ref such as
+ - refs/heads/master, yields a version of that ref under the directory,
+ - such as refs/remotes/origin/master. -}
+under :: String -> Ref -> Ref
+under dir r = Ref $ dir </> show (base r)
+
+{- Checks if a ref exists. -}
+exists :: Ref -> Repo -> IO Bool
+exists ref = runBool "show-ref" 
+	[Param "--verify", Param "-q", Param $ show ref]
+
+{- Get the sha of a fully qualified git ref, if it exists. -}
+sha :: Branch -> Repo -> IO (Maybe Sha)
+sha branch repo = process . L.unpack <$> showref repo
+	where
+		showref = pipeRead [Param "show-ref",
+			Param "--hash", -- get the hash
+			Param $ show branch]
+		process [] = Nothing
+		process s = Just $ Ref $ firstLine s
+
+{- List of (refs, branches) matching a given ref spec. -}
+matching :: Ref -> Repo -> IO [(Ref, Branch)]
+matching ref repo = do
+	r <- pipeRead [Param "show-ref", Param $ show ref] repo
+	return $ map (gen . L.unpack) (L.lines r)
+	where
+		gen l = let (r, b) = separate (== ' ') l in
+			(Ref r, Ref b)
+
+{- List of (refs, branches) matching a given ref spec.
+ - Duplicate refs are filtered out. -}
+matchingUniq :: Ref -> Repo -> IO [(Ref, Branch)]
+matchingUniq ref repo = nubBy uniqref <$> matching ref repo
+	where
+		uniqref (a, _) (b, _) = a == b
+
+{- Checks if a String is a legal git ref name.
+ -
+ - The rules for this are complex; see git-check-ref-format(1) -}
+legal :: Bool -> String -> Bool
+legal allowonelevel s = all (== False) illegal
+	where
+		illegal =
+			[ any ("." `isPrefixOf`) pathbits
+			, any (".lock" `isSuffixOf`) pathbits
+			, not allowonelevel && length pathbits < 2
+			, contains ".."
+			, any (\c -> contains [c]) illegalchars
+			, begins "/"
+			, ends "/"
+			, contains "//"
+			, ends "."
+			, contains "@{"
+			, null s
+			]
+		contains v = v `isInfixOf` s
+		ends v = v `isSuffixOf` s
+		begins v = v `isPrefixOf` s
+
+		pathbits = split "/" s
+		illegalchars = " ~^:?*[\\" ++ controlchars
+		controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)]

Git/Sha.hs

@@ -0,0 +1,39 @@
+{- git SHA stuff
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Sha where
+
+import Common
+import Git.Types
+
+{- Runs an action that causes a git subcommand to emit a Sha, and strips
+   any trailing newline, returning the sha. -}
+getSha :: String -> IO String -> IO Sha
+getSha subcommand a = maybe bad return =<< extractSha <$> a
+	where
+		bad = error $ "failed to read sha from git " ++ subcommand
+
+{- Extracts the Sha from a string. There can be a trailing newline after
+ - it, but nothing else. -}
+extractSha :: String -> Maybe Sha
+extractSha s
+	| len == shaSize = val s
+	| len == shaSize + 1 && length s' == shaSize = val s'
+	| otherwise = Nothing
+	where
+		len = length s
+		s' = firstLine s
+		val v
+			| all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v
+			| otherwise = Nothing
+
+{- Size of a git sha. -}
+shaSize :: Int
+shaSize = 40
+
+nullSha :: Ref		
+nullSha = Ref $ replicate shaSize '0'

Git/SharedRepository.hs

@@ -0,0 +1,27 @@
+{- git core.sharedRepository handling
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.SharedRepository where
+
+import Data.Char
+
+import Common
+import Git
+import qualified Git.Config
+
+data SharedRepository = UnShared | GroupShared | AllShared | UmaskShared Int
+
+getSharedRepository :: Repo -> SharedRepository
+getSharedRepository r =
+	case map toLower $ Git.Config.get "core.sharedrepository" "" r of
+		"1" -> GroupShared
+		"group" -> GroupShared
+		"true" -> GroupShared
+		"all" -> AllShared
+		"world" -> AllShared
+		"everybody" -> AllShared
+		v -> maybe UnShared UmaskShared (readish v)

Git/Types.hs

@@ -0,0 +1,50 @@
+{- git data types
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Types where
+
+import Network.URI
+import qualified Data.Map as M
+
+{- Support repositories on local disk, and repositories accessed via an URL.
+ -
+ - Repos on local disk have a git directory, and unless bare, a worktree.
+ -
+ - A local repo may not have had its config read yet, in which case all
+ - that's known about it is its path.
+ -
+ - Finally, an Unknown repository may be known to exist, but nothing
+ - else known about it.
+ -}
+data RepoLocation
+	= Local { gitdir :: FilePath, worktree :: Maybe FilePath }
+	| LocalUnknown FilePath
+	| Url URI
+	| Unknown
+	deriving (Show, Eq)
+
+data Repo = Repo {
+	location :: RepoLocation,
+	config :: M.Map String String,
+	-- a given git config key can actually have multiple values
+	fullconfig :: M.Map String [String],
+	remotes :: [Repo],
+	-- remoteName holds the name used for this repo in remotes
+	remoteName :: Maybe String 
+} deriving (Show, Eq)
+
+{- A git ref. Can be a sha1, or a branch or tag name. -}
+newtype Ref = Ref String
+	deriving (Eq)
+
+instance Show Ref where
+	show (Ref v) = v
+
+{- Aliases for Ref. -}
+type Branch = Ref
+type Sha = Ref
+type Tag = Ref

Git/UnionMerge.hs

@@ -0,0 +1,142 @@
+{- git-union-merge library
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.UnionMerge (
+	merge,
+	merge_index,
+	update_index,
+	stream_update_index,
+	update_index_line,
+	ls_tree
+) where
+
+import System.Cmd.Utils
+import qualified Data.ByteString.Lazy.Char8 as L
+import qualified Data.Set as S
+
+import Common
+import Git
+import Git.Sha
+import Git.CatFile
+import Git.Command
+
+type Streamer = (String -> IO ()) -> IO ()
+
+{- Performs a union merge between two branches, staging it in the index.
+ - Any previously staged changes in the index will be lost.
+ -
+ - Should be run with a temporary index file configured by useIndex.
+ -}
+merge :: Ref -> Ref -> Repo -> IO ()
+merge x y repo = do
+	h <- catFileStart repo
+	stream_update_index repo
+		[ ls_tree x repo
+		, merge_trees x y h repo
+		]
+	catFileStop h
+
+{- Merges a list of branches into the index. Previously staged changed in
+ - the index are preserved (and participate in the merge). -}
+merge_index :: CatFileHandle -> Repo -> [Ref] -> IO ()
+merge_index h repo bs =
+	stream_update_index repo $ map (\b -> merge_tree_index b h repo) bs
+
+{- Feeds content into update-index. Later items in the list can override
+ - earlier ones, so the list can be generated from any combination of
+ - ls_tree, merge_trees, and merge_tree_index. -}
+update_index :: Repo -> [String] -> IO ()
+update_index repo ls = stream_update_index repo [(`mapM_` ls)]
+
+{- Streams content into update-index. -}
+stream_update_index :: Repo -> [Streamer] -> IO ()
+stream_update_index repo as = do
+	(p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo)
+	fileEncoding h
+	forM_ as (stream h)
+	hClose h
+	forceSuccess p
+	where
+		params = map Param ["update-index", "-z", "--index-info"]
+		stream h a = a (streamer h)
+		streamer h s = do
+			hPutStr h s
+			hPutStr h "\0"
+
+{- Generates a line suitable to be fed into update-index, to add
+ - a given file with a given sha. -}
+update_index_line :: Sha -> FilePath -> String
+update_index_line sha file = "100644 blob " ++ show sha ++ "\t" ++ file
+
+{- Gets the current tree for a ref. -}
+ls_tree :: Ref -> Repo -> Streamer
+ls_tree (Ref x) repo streamer = mapM_ streamer =<< pipeNullSplit params repo
+	where
+		params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
+
+{- For merging two trees. -}
+merge_trees :: Ref -> Ref -> CatFileHandle -> Repo -> Streamer
+merge_trees (Ref x) (Ref y) h = calc_merge h $ "diff-tree":diff_opts ++ [x, y]
+
+{- For merging a single tree into the index. -}
+merge_tree_index :: Ref -> CatFileHandle -> Repo -> Streamer
+merge_tree_index (Ref x) h = calc_merge h $
+	"diff-index" : diff_opts ++ ["--cached", x]
+
+diff_opts :: [String]
+diff_opts = ["--raw", "-z", "-r", "--no-renames", "-l0"]
+
+{- Calculates how to perform a merge, using git to get a raw diff,
+ - and generating update-index input. -}
+calc_merge :: CatFileHandle -> [String] -> Repo -> Streamer
+calc_merge ch differ repo streamer = gendiff >>= go
+	where
+		gendiff = pipeNullSplit (map Param differ) repo
+		go [] = noop
+		go (info:file:rest) = mergeFile info file ch repo >>=
+			maybe (go rest) (\l -> streamer l >> go rest)
+		go (_:[]) = error "calc_merge parse error"
+
+{- Given an info line from a git raw diff, and the filename, generates
+ - a line suitable for update-index that union merges the two sides of the
+ - diff. -}
+mergeFile :: String -> FilePath -> CatFileHandle -> Repo -> IO (Maybe String)
+mergeFile info file h repo = case filter (/= nullSha) [Ref asha, Ref bsha] of
+	[] -> return Nothing
+	(sha:[]) -> use sha
+	shas -> use =<< either return (hashObject repo . L.unlines) =<<
+		calcMerge . zip shas <$> mapM getcontents shas
+	where
+		[_colonmode, _bmode, asha, bsha, _status] = words info
+		getcontents s = L.lines <$> catObject h s
+		use sha = return $ Just $ update_index_line sha file
+
+{- Injects some content into git, returning its Sha. -}
+hashObject :: Repo -> L.ByteString -> IO Sha
+hashObject repo content = getSha subcmd $ do
+	(h, s) <- pipeWriteRead (map Param params) content repo
+	L.length s `seq` do
+		forceSuccess h
+		reap -- XXX unsure why this is needed
+		return $ L.unpack s
+	where
+		subcmd = "hash-object"
+		params = [subcmd, "-w", "--stdin"]
+
+{- Calculates a union merge between a list of refs, with contents.
+ -
+ - When possible, reuses the content of an existing ref, rather than
+ - generating new content.
+ -}
+calcMerge :: [(Ref, [L.ByteString])] -> Either Ref [L.ByteString]
+calcMerge shacontents
+	| null reuseable = Right $ new
+	| otherwise = Left $ fst $ Prelude.head reuseable
+	where
+		reuseable = filter (\c -> sorteduniq (snd c) == new) shacontents
+		new = sorteduniq $ concat $ map snd shacontents
+		sorteduniq = S.toList . S.fromList

Git/Url.hs

@@ -0,0 +1,70 @@
+{- git repository urls
+ -
+ - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Url (
+	scheme,
+	host,
+	port,
+	hostuser,
+	authority,
+) where
+
+import Network.URI hiding (scheme, authority)
+
+import Common
+import Git.Types
+import Git
+
+{- Scheme of an URL repo. -}
+scheme :: Repo -> String
+scheme Repo { location = Url u } = uriScheme u
+scheme repo = notUrl repo
+
+{- Work around a bug in the real uriRegName
+ - <http://trac.haskell.org/network/ticket/40> -}
+uriRegName' :: URIAuth -> String
+uriRegName' a = fixup $ uriRegName a
+	where
+		fixup x@('[':rest)
+			| rest !! len == ']' = take len rest
+			| otherwise = x
+			where
+				len  = length rest - 1
+		fixup x = x
+
+{- Hostname of an URL repo. -}
+host :: Repo -> String
+host = authpart uriRegName'
+
+{- Port of an URL repo, if it has a nonstandard one. -}
+port :: Repo -> Maybe Integer
+port r = 
+	case authpart uriPort r of
+		":" -> Nothing
+		(':':p) -> readish p
+		_ -> Nothing
+
+{- Hostname of an URL repo, including any username (ie, "user@host") -}
+hostuser :: Repo -> String
+hostuser r = authpart uriUserInfo r ++ authpart uriRegName' r
+
+{- The full authority portion an URL repo. (ie, "user@host:port") -}
+authority :: Repo -> String
+authority = authpart assemble
+	where
+		assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a
+
+{- Applies a function to extract part of the uriAuthority of an URL repo. -}
+authpart :: (URIAuth -> a) -> Repo -> a
+authpart a Repo { location = Url u } = a auth
+	where
+		auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
+authpart _ repo = notUrl repo
+
+notUrl :: Repo -> a
+notUrl repo = error $
+	"acting on local git repo " ++ repoDescribe repo ++ " not supported"

Git/Version.hs

@@ -0,0 +1,38 @@
+{- git version checking
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Version where
+
+import Common
+import qualified Build.SysConfig
+
+{- Using the version it was configured for avoids running git to check its
+ - version, at the cost that upgrading git won't be noticed.
+ - This is only acceptable because it's rare that git's version influences
+ - code's behavior. -}
+version :: String
+version = Build.SysConfig.gitversion
+
+older :: String -> Bool
+older v = normalize version < normalize v
+
+{- To compare dotted versions like 1.7.7 and 1.8, they are normalized to
+ - a somewhat arbitrary integer representation. -}
+normalize :: String -> Integer
+normalize = sum . mult 1 . reverse .
+		extend precision . take precision .
+		map readi . split "."
+	where
+		extend n l = l ++ replicate (n - length l) 0
+		mult _ [] = []
+		mult n (x:xs) = (n*x) : mult (n*10^width) xs
+		readi :: String -> Integer
+		readi s = case reads s of
+			((x,_):_) -> x
+			_ -> 0
+		precision = 10 -- number of segments of the version to compare
+		width = length "yyyymmddhhmmss" -- maximum width of a segment