.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|.*/||' | sort > upstream_tags
-          git ls-remote ${{ github.server_url}}/${{ github.repository }} "refs/tags/$tags" | grep -v '{' | sed 's|.*/||' | sort > destination_tags
-          comm -23 upstream_tags destination_tags > missing_tags
-          echo "Missing tags:"
-          cat missing_tags
-      - name: Missing tag fetch
-        run: |
-          git remote add upstream $upstream
-          while read tag; do
-            git fetch upstream tag $tag --no-tags
-          done < missing_tags
-      - name: Packaging workflow injection
-        run: |
-          while read tag; do
-            git checkout $tag
-            git tag -d $tag
-            git checkout ci -- ./.forgejo
-            git config user.name "forgejo-actions[bot]"
-            git config user.email "dev@ayakael.net"
-            git commit -m 'Inject custom workflow'
-            git tag -a $tag -m $tag
-          done < missing_tags
-      - name: Push to destination
-        run: git push --force origin refs/tags/*:refs/tags/* --tags   

.gitattributes

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

.gitignore

@@ -0,0 +1,19 @@
+*.hi
+*.o
+test
+configure
+Build/SysConfig.hs
+git-annex
+git-annex-shell
+git-union-merge
+git-annex.1
+git-annex-shell.1
+git-union-merge.1
+doc/.ikiwiki
+html
+*.tix
+.hpc
+Utility/Touch.hs
+Utility/StatFS.hs
+Remote/S3.hs
+dist

Annex.hs

@@ -0,0 +1,134 @@
+{- git-annex monad
+ -
+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Annex (
+	Annex,
+	AnnexState(..),
+	OutputType(..),
+	new,
+	newState,
+	run,
+	eval,
+	getState,
+	changeState,
+	gitRepo,
+	inRepo,
+	fromRepo,
+) where
+
+import Control.Monad.IO.Control
+import Control.Monad.State
+
+import Common
+import qualified Git
+import qualified Git.Config
+import Git.CatFile
+import qualified Git.Queue
+import Types.Backend
+import qualified Types.Remote
+import Types.Crypto
+import Types.BranchState
+import Types.TrustLevel
+import Types.UUID
+import qualified Utility.Matcher
+import qualified Utility.Format
+import qualified Data.Map as M
+
+-- git-annex's monad
+newtype Annex a = Annex { runAnnex :: StateT AnnexState IO a }
+	deriving (
+		Monad,
+		MonadIO,
+		MonadControlIO,
+		MonadState AnnexState,
+		Functor,
+		Applicative
+	)
+
+data OutputType = NormalOutput | QuietOutput | JSONOutput
+
+-- internal state storage
+data AnnexState = AnnexState
+	{ repo :: Git.Repo
+	, backends :: [Backend Annex]
+	, remotes :: [Types.Remote.Remote Annex]
+	, repoqueue :: Git.Queue.Queue
+	, output :: OutputType
+	, force :: Bool
+	, fast :: Bool
+	, auto :: Bool
+	, format :: Maybe Utility.Format.Format
+	, branchstate :: BranchState
+	, catfilehandle :: Maybe CatFileHandle
+	, forcebackend :: Maybe String
+	, forcenumcopies :: Maybe Int
+	, toremote :: Maybe String
+	, fromremote :: Maybe String
+	, limit :: Either [Utility.Matcher.Token (FilePath -> Annex Bool)] (Utility.Matcher.Matcher (FilePath -> Annex Bool))
+	, forcetrust :: [(UUID, TrustLevel)]
+	, trustmap :: Maybe TrustMap
+	, ciphers :: M.Map EncryptedCipher Cipher
+	}
+
+newState :: Git.Repo -> AnnexState
+newState gitrepo = AnnexState
+	{ repo = gitrepo
+	, backends = []
+	, remotes = []
+	, repoqueue = Git.Queue.new
+	, output = NormalOutput
+	, force = False
+	, fast = False
+	, auto = False
+	, format = Nothing
+	, branchstate = startBranchState
+	, catfilehandle = Nothing
+	, forcebackend = Nothing
+	, forcenumcopies = Nothing
+	, toremote = Nothing
+	, fromremote = Nothing
+	, limit = Left []
+	, forcetrust = []
+	, trustmap = Nothing
+	, ciphers = M.empty
+	}
+
+{- Create and returns an Annex state object for the specified git repo. -}
+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
+
+{- Gets a value from the internal state, selected by the passed value
+ - constructor. -}
+getState :: (AnnexState -> a) -> Annex a
+getState = gets
+
+{- Applies a state mutation function to change the internal state. 
+ -
+ - Example: changeState $ \s -> s { output = QuietOutput }
+ -}
+changeState :: (AnnexState -> AnnexState) -> Annex ()
+changeState = modify
+
+{- 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,312 @@
+{- management of the git-annex branch
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Branch (
+	name,
+	hasOrigin,
+	hasSibling,
+	create,
+	update,
+	updateTo,
+	get,
+	change,
+	commit,
+	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 qualified Git.HashObject
+import qualified Git.Index
+import Annex.CatFile
+
+{- 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.matching name
+
+{- Creates the branch, if it does not already exist. -}
+create :: Annex ()
+create = do
+	_ <- getBranch
+	return ()
+
+{- 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 $ do
+			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
+
+{- 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 <- journalDirty
+	(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 $ getStale file >>= return . a >>= 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 journalDirty $ lockJournal $ do
+	stageJournal
+	ref <- getBranch
+	withIndex $ commitBranch ref message [fullname]
+
+{- 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 brannch 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
+	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
+		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"
+
+{- Stages the journal into the index. -}
+stageJournal :: Annex ()
+stageJournal = do
+	fs <- getJournalFiles
+	g <- gitRepo
+	withIndex $ liftIO $ do
+		let dir = gitAnnexJournalDir g
+		let paths = map (dir </>) fs
+		(shas, cleanup) <- Git.HashObject.hashFiles paths g
+		Git.UnionMerge.update_index g $
+			index_lines shas (map fileJournal fs)
+		cleanup
+		mapM_ removeFile paths
+	where
+		index_lines shas = map genline . zip shas
+		genline (sha, file) = Git.UnionMerge.update_index_line sha file

Annex/BranchState.hs

@@ -0,0 +1,56 @@
+{- git-annex branch state management
+ -
+ - Runtime state about the git-annex branch, including a small read cache.
+ -
+ - Copyright 2011 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 }
+
+setCache :: FilePath -> String -> Annex ()
+setCache file content = do
+	state <- getState
+	setState state { cachedFile = Just file, cachedContent = content }
+
+getCache :: FilePath -> Annex (Maybe String)
+getCache file = getState >>= go
+	where
+		go state
+			| cachedFile state == Just file =
+				return $ Just $ cachedContent state
+			| otherwise = return Nothing
+
+invalidateCache :: Annex ()
+invalidateCache = do
+	state <- getState
+	setState state { cachedFile = Nothing, cachedContent = "" }
+
+{- 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 = Annex.changeState setupdated
+	where
+		setupdated s = s { Annex.branchstate = new }
+			where
+				new = old { branchUpdated = True }
+				old = Annex.branchstate s

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/Content.hs

@@ -0,0 +1,283 @@
+{- 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
+) where
+
+import System.IO.Error (try)
+import Control.Exception (bracket_)
+import System.Posix.Types
+
+import Common.Annex
+import Logs.Location
+import Annex.UUID
+import qualified Git
+import qualified Annex
+import qualified Annex.Queue
+import qualified Annex.Branch
+import Utility.StatFS
+import Utility.FileMode
+import Types.Key
+import Utility.DataUnits
+import Config
+import Annex.Exception
+
+{- 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 False >>= check
+	where
+		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 True >>= lock) unlock a
+	where
+		lock Nothing = return Nothing
+		lock (Just l) = do
+			v <- try $ setLock l (WriteLock, AbsoluteSeek, 0, 0)
+			case v of
+				Left _ -> error "content is locked"
+				Right _ -> return $ Just l
+		unlock Nothing = return ()
+		unlock (Just l) = closeFd l
+
+openForLock :: FilePath -> Bool -> IO (Maybe Fd)
+openForLock file writelock = bracket_ prep cleanup go
+	where
+		go = catchMaybeIO $ openFd file mode Nothing defaultFileFlags
+		mode = if writelock then ReadWrite else ReadOnly
+		{- Since files are stored with the write bit disabled,
+		 - have to fiddle with permissions to open for an
+		 - exclusive lock. -}
+		forwritelock a = 
+			when writelock $ whenM (doesFileExist file) a
+		prep = forwritelock $ allowWrite file
+		cleanup = forwritelock $ preventWrite file
+
+{- 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
+	if e
+		then do
+			stat <- liftIO $ getFileStatus tmp
+			checkDiskSpace' (fromIntegral $ fileSize stat) key
+		else checkDiskSpace key
+
+	when e $ liftIO $ allowWrite tmp
+
+	getViaTmpUnchecked key action
+
+prepTmp :: Key -> Annex FilePath
+prepTmp key = do
+	tmp <- fromRepo $ gitAnnexTmpLocation key
+	liftIO $ createDirectoryIfMissing True (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
+	success <- action tmp
+	if success
+		then do
+			moveAnnex key tmp
+			logStatus key InfoPresent
+			return True
+		else 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,
+ - throwing an error if not. -}
+checkDiskSpace :: Key -> Annex ()
+checkDiskSpace = checkDiskSpace' 0
+
+checkDiskSpace' :: Integer -> Key -> Annex ()
+checkDiskSpace' adjustment key = do
+	g <- gitRepo
+	r <- getConfig g "diskreserve" ""
+	let reserve = fromMaybe megabyte $ readSize dataUnits r
+	stats <- liftIO $ getFileSystemStats (gitAnnexDir g)
+	case (stats, keySize key) of
+		(Nothing, _) -> return ()
+		(_, Nothing) -> return ()
+		(Just (FileSystemStats { fsStatBytesAvailable = have }), Just need) ->
+			when (need + reserve > have + adjustment) $
+				needmorespace (need + reserve - have - adjustment)
+	where
+		megabyte :: Integer
+		megabyte = 1000000
+		needmorespace n = unlessM (Annex.getState Annex.force) $
+			error $ "not enough free space, need " ++ 
+				roughSize storageUnits True n ++
+				" more (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
+	let dir = parentDir dest
+	e <- liftIO $ doesFileExist dest
+	if e
+		then liftIO $ removeFile src
+		else liftIO $ do
+			createDirectoryIfMissing True dir
+			allowWrite dir -- in case the directory already exists
+			moveFile src dest
+			preventWrite dest
+			preventWrite dir
+
+withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a
+withObjectLoc key a = do
+	file <- inRepo $ gitAnnexLocation key
+	let dir = parentDir file
+	a (dir, file)
+
+{- Removes a key's file from .git/annex/objects/ -}
+removeAnnex :: Key -> Annex ()
+removeAnnex key = withObjectLoc key $ \(dir, file) -> liftIO $ do
+	allowWrite dir
+	removeFile file
+	removeDirectory dir
+
+{- Moves a key's file out of .git/annex/objects/ -}
+fromAnnex :: Key -> FilePath -> Annex ()
+fromAnnex key dest = withObjectLoc key $ \(dir, file) -> liftIO $ do
+	allowWrite dir
+	allowWrite file
+	moveFile file dest
+	removeDirectory dir
+
+{- 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
+	liftIO $ do
+		createDirectoryIfMissing True (parentDir dest)
+		allowWrite (parentDir src)
+		moveFile src dest
+		removeDirectory (parentDir src)
+	logStatus key InfoMissing
+	return dest
+
+{- List of keys whose content exists in .git/annex/objects/ -}
+getKeysPresent :: Annex [Key]
+getKeysPresent = getKeysPresent' =<< fromRepo gitAnnexObjectDir
+getKeysPresent' :: FilePath -> Annex [Key]
+getKeysPresent' dir = do
+	exists <- liftIO $ doesDirectoryExist dir
+	if not exists
+		then return []
+		else liftIO $ do
+			-- 2 levels of hashing
+			levela <- dirContents dir
+			levelb <- mapM dirContents levela
+			contents <- mapM dirContents (concat levelb)
+			let files = concat contents
+			return $ mapMaybe (fileKey . takeFileName) files
+
+{- Things to do to record changes to content. -}
+saveState :: Annex ()
+saveState = do
+	Annex.Queue.flush False
+	Annex.Branch.commit "update"

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.Control (handle)
+import Control.Monad.IO.Control (liftIOOp)
+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 =
+	liftIOOp (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,94 @@
+{- 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
+
+{- 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
+	g <- gitRepo
+	liftIO $ doRedo (write g) $ do
+		createDirectoryIfMissing True $ gitAnnexJournalDir g
+		createDirectoryIfMissing True $ gitAnnexTmpDir g
+	where
+		-- journal file is written atomically
+		write g = do
+			let jfile = journalFile g file
+			let tmpfile = gitAnnexTmpDir g </> takeFileName jfile
+			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 g file
+
+{- 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 :: Git.Repo -> FilePath -> FilePath
+journalFile repo file = 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
+	bracketIO (lock file) unlock a
+	where
+		lock file = do
+			l <- doRedo (createFile file stdFileMode) $
+				createDirectoryIfMissing True $ takeDirectory file
+			waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)
+			return l
+		unlock = closeFd
+
+{- Runs an action, catching failure and running something to fix it up, and
+ - retrying if necessary. -}
+doRedo :: IO a -> IO b -> IO a
+doRedo a b = catch a $ const $ b >> a

Annex/Queue.hs

@@ -0,0 +1,41 @@
+{- 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
+import qualified Git.Queue
+
+{- Adds a git command to the queue. -}
+add :: String -> [CommandParam] -> [FilePath] -> Annex ()
+add command params files = do
+	q <- getState repoqueue
+	store $ Git.Queue.add q command params files
+
+{- Runs the queue if it is full. Should be called periodically. -}
+flushWhenFull :: Annex ()
+flushWhenFull = do
+	q <- getState repoqueue
+	when (Git.Queue.full q) $ flush False
+
+{- Runs (and empties) the queue. -}
+flush :: Bool -> Annex ()
+flush silent = do
+	q <- getState repoqueue
+	unless (0 == Git.Queue.size q) $ do
+		unless silent $
+			showSideAction "Recording state in git"
+		q' <- inRepo $ Git.Queue.flush q
+		store q'
+
+store :: Git.Queue.Queue -> Annex ()
+store q = changeState $ \s -> s { repoqueue = q }

Annex/Ssh.hs

@@ -0,0 +1,65 @@
+{- git-annex remote access with ssh
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Ssh where
+
+import Common
+import qualified Git
+import qualified Git.Url
+import Types
+import Config
+import Annex.UUID
+
+{- Generates parameters to ssh to a repository's host and run a command.
+ - Caller is responsible for doing any neccessary shellEscaping of the
+ - passed command. -}
+sshToRepo :: Git.Repo -> [CommandParam] -> Annex [CommandParam]
+sshToRepo repo sshcmd = do
+	s <- getConfig repo "ssh-options" ""
+	let sshoptions = map Param (words s)
+	let sshport = case Git.Url.port repo of
+		Nothing -> []
+		Just p -> [Param "-p", Param (show p)]
+	let sshhost = Param $ Git.Url.hostuser repo
+	return $ sshoptions ++ sshport ++ [sshhost] ++ sshcmd
+
+{- Generates parameters to run a git-annex-shell command on a remote
+ - repository. -}
+git_annex_shell :: Git.Repo -> String -> [CommandParam] -> Annex (Maybe (FilePath, [CommandParam]))
+git_annex_shell r command params
+	| not $ Git.repoIsUrl r = return $ Just (shellcmd, shellopts)
+	| Git.repoIsSsh r = do
+		uuid <- getRepoUUID r
+		sshparams <- sshToRepo r [Param $ sshcmd uuid ]
+		return $ Just ("ssh", sshparams)
+	| otherwise = return Nothing
+	where
+		dir = Git.workTree r
+		shellcmd = "git-annex-shell"
+		shellopts = Param command : File dir : params
+		sshcmd uuid = unwords $
+			shellcmd : map shellEscape (toCommand shellopts) ++
+			uuidcheck uuid
+		uuidcheck NoUUID = []
+		uuidcheck (UUID u) = ["--uuid", u]
+
+{- Uses a supplied function (such as boolSystem) to run a git-annex-shell
+ - command on a remote.
+ -
+ - Or, if the remote does not support running remote commands, returns
+ - a specified error value. -}
+onRemote 
+	:: Git.Repo
+	-> (FilePath -> [CommandParam] -> IO a, a)
+	-> String
+	-> [CommandParam]
+	-> Annex a
+onRemote r (with, errorval) command params = do
+	s <- git_annex_shell r command params
+	case s of
+		Just (c, ps) -> liftIO $ with c ps
+		Nothing -> return errorval

Annex/UUID.hs

@@ -0,0 +1,74 @@
+{- 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
+) where
+
+import Common.Annex
+import qualified Git
+import qualified Git.Config
+import qualified Build.SysConfig as SysConfig
+import Config
+
+configkey :: String
+configkey = "annex.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 = if command == "uuid"
+			-- request a random uuid be generated
+			then ["-m"]
+			-- uuidgen generates random uuid by default
+			else []
+
+{- 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 <- fromRepo cached
+	let u = getUncachedUUID r
+	
+	if c /= u && u /= NoUUID
+		then do
+			updatecache u
+			return u
+		else return c
+	where
+		cached = toUUID . Git.Config.get cachekey ""
+		updatecache u = do
+			g <- gitRepo
+			when (g /= r) $ storeUUID cachekey u
+		cachekey = remoteConfig r "uuid"
+
+getUncachedUUID :: Git.Repo -> UUID
+getUncachedUUID = toUUID . Git.Config.get configkey ""
+
+{- Make sure that the repo has an annex.uuid setting. -}
+prepUUID :: Annex ()
+prepUUID = whenM ((==) NoUUID <$> getUUID) $
+	storeUUID configkey =<< liftIO genUUID
+
+storeUUID :: String -> UUID -> Annex ()
+storeUUID configfield = setConfig configfield . fromUUID

Annex/Version.hs

@@ -0,0 +1,44 @@
+{- 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 qualified Git.Config
+import Config
+
+type Version = String
+
+defaultVersion :: Version
+defaultVersion = "3"
+
+supportedVersions :: [Version]
+supportedVersions = [defaultVersion]
+
+upgradableVersions :: [Version]
+upgradableVersions = ["0", "1", "2"]
+
+versionField :: String
+versionField = "annex.version"
+
+getVersion :: Annex (Maybe Version)
+getVersion = handle <$> fromRepo (Git.Config.get versionField "")
+	where
+		handle [] = Nothing
+		handle v = Just v
+
+setVersion :: Annex ()
+setVersion = setConfig versionField defaultVersion
+
+checkVersion :: Version -> Annex ()
+checkVersion v
+	| v `elem` supportedVersions = return ()
+	| 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,120 @@
+{- git-annex key/value backends
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Backend (
+	BackendFile,
+	list,
+	orderedList,
+	genKey,
+	lookupFile,
+	chooseBackends,
+	lookupBackendName,
+	maybeLookupBackendName
+) where
+
+import System.IO.Error (try)
+import System.Posix.Files
+
+import Common.Annex
+import qualified Git.Config
+import qualified Git.CheckAttr
+import qualified Annex
+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 Annex]
+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 Annex]
+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 = fromRepo $ parseBackendList . Git.Config.get "annex.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) -> Annex (Maybe (Key, Backend Annex))
+genKey file trybackend = do
+	bs <- orderedList
+	let bs' = maybe bs (: bs) trybackend
+	genKey' bs' file
+genKey' :: [Backend Annex] -> FilePath -> Annex (Maybe (Key, Backend Annex))
+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 Annex))
+lookupFile file = do
+	tl <- liftIO $ try getsymlink
+	case tl of
+		Left _ -> return Nothing
+		Right l -> makekey l
+	where
+		getsymlink = takeFileName <$> readSymbolicLink file
+		makekey l = maybe (return Nothing) (makeret l) (fileKey l)
+		makeret l k = let bname = keyBackendName k in
+			case maybeLookupBackendName bname of
+				Just backend -> return $ Just (k, backend)
+				Nothing -> do
+					when (isLinkToAnnex l) $ warning $
+						"skipping " ++ file ++
+						" (unknown backend " ++
+						bname ++ ")"
+					return Nothing
+
+type BackendFile = (Maybe (Backend Annex), FilePath)
+
+{- Looks up the backends that should be used for each file in a list.
+ - That can be configured on a per-file basis in the gitattributes file.
+ -}
+chooseBackends :: [FilePath] -> Annex [BackendFile]
+chooseBackends fs = Annex.getState Annex.forcebackend >>= go
+	where
+		go Nothing = do
+			pairs <- inRepo $ Git.CheckAttr.lookup "annex.backend" fs
+			return $ map (\(f,b) -> (maybeLookupBackendName b, f)) pairs
+		go (Just _) = do
+			l <- orderedList
+			return $ map (\f -> (Just $ Prelude.head l, f)) fs
+
+{- Looks up a backend by name. May fail if unknown. -}
+lookupBackendName :: String -> Backend Annex
+lookupBackendName s = fromMaybe unknown $ maybeLookupBackendName s
+	where
+		unknown = error $ "unknown backend " ++ s
+maybeLookupBackendName :: String -> Maybe (Backend Annex)
+maybeLookupBackendName s = headMaybe matches
+	where
+		matches = filter (\b -> s == B.name b) list

Backend/SHA.hs

@@ -0,0 +1,114 @@
+{- 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 Annex.Content
+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 Annex]
+backends = catMaybes $ map genBackend sizes ++ map genBackendE sizes
+
+genBackend :: SHASize -> Maybe (Backend Annex)
+genBackend size
+	| isNothing (shaCommand size) = Nothing
+	| otherwise = Just b
+	where
+		b = Types.Backend.Backend
+			{ name = shaName size
+			, getKey = keyValue size
+			, fsckKey = checkKeyChecksum size
+			}
+
+genBackendE :: SHASize -> Maybe (Backend Annex)
+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 = 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 -> Annex Bool
+checkKeyChecksum size key = do
+	fast <- Annex.getState Annex.fast
+	file <- inRepo $ gitAnnexLocation key
+	present <- liftIO $ doesFileExist file
+	if not present || fast
+		then return True
+		else check =<< shaN size file
+	where
+		check s
+			| s == dropExtension (keyName key) = return True
+			| otherwise = do
+				dest <- moveBad key
+				warning $ "Bad file content; moved to " ++ dest
+				return False

Backend/URL.hs

@@ -0,0 +1,28 @@
+{- 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 Common.Annex
+import Types.Backend
+import Types.Key
+
+backends :: [Backend Annex]
+backends = [backend]
+
+backend :: Backend Annex
+backend = Types.Backend.Backend {
+	name = "URL",
+	getKey = const (return Nothing),
+	fsckKey = const (return True)
+}
+
+fromUrl :: String -> Key
+fromUrl url = stubKey { keyName = url, keyBackendName = "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 Annex]
+backends = [backend]
+
+backend :: Backend Annex
+backend = Types.Backend.Backend {
+	name = "WORM",
+	getKey = keyValue,
+	fsckKey = const (return True)
+}
+
+{- 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/TestConfig.hs

@@ -0,0 +1,114 @@
+{- 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)
+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
+
+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"
+
+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"
+
+status :: String -> IO ()
+status s = putStrLn $ ' ':s

CHANGELOG

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

Checks.hs

@@ -0,0 +1,42 @@
+{- 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
+import qualified Annex
+
+commonChecks :: [CommandCheck]
+commonChecks = [fromOpt, toOpt, repoExists]
+
+repoExists :: CommandCheck
+repoExists = CommandCheck 0 ensureInitialized
+
+fromOpt :: CommandCheck
+fromOpt = CommandCheck 1 $ do
+	v <- Annex.getState Annex.fromremote
+	unless (isNothing v) $ error "cannot use --from with this command"
+
+toOpt :: CommandCheck
+toOpt = CommandCheck 2 $ do
+	v <- Annex.getState Annex.toremote
+	unless (isNothing v) $ error "cannot use --to with this command"
+
+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,106 @@
+{- git-annex command line parsing and dispatch
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module CmdLine (
+	dispatch,
+	usage,
+	shutdown
+) where
+
+import qualified System.IO.Error as IO
+import qualified Control.Exception as E
+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 Annex.Content
+import Command
+
+type Params = [String]
+type Flags = [Annex ()]
+
+{- Runs the passed command line. -}
+dispatch :: Params -> [Command] -> [Option] -> String -> IO Git.Repo -> IO ()
+dispatch args cmds options 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
+				sequence_ flags
+				prepCommand cmd params
+			tryRun state' cmd $ [startup] ++ actions ++ [shutdown]
+	where
+		(flags, cmd, params) = parseCmd args cmds options header
+
+{- Parses command line, and returns actions to run to configure flags,
+ - the Command being run, and the remaining parameters for the command. -} 
+parseCmd :: Params -> [Command] -> [Option] -> String -> (Flags, Command, Params)
+parseCmd argv cmds options header = check $ getOpt Permute options argv
+	where
+		check (_, [], []) = err "missing command"
+		check (flags, name:rest, [])
+			| null matches = err $ "unknown command " ++ name
+			| otherwise = (flags, Prelude.head matches, rest)
+			where
+				matches = filter (\c -> name == cmdname c) cmds
+		check (_, _, errs) = err $ concat errs
+		err msg = error $ msg ++ "\n\n" ++ usage header cmds options
+
+{- Usage message with lists of commands and options. -}
+usage :: String -> [Command] -> [Option] -> String
+usage header cmds options = usageInfo top options ++ commands
+	where
+		top = header ++ "\n\nOptions:"
+		commands = "\nCommands:\n" ++ cmddescs
+		cmddescs = unlines $ map (indent . showcmd) cmds
+		showcmd c =
+			cmdname c ++
+			pad (longest cmdname + 1) (cmdname c) ++
+			cmdparams c ++
+			pad (longest cmdparams + 2) (cmdparams c) ++
+			cmddesc c
+		pad n s = replicate (n - length s) ' '
+		longest f = foldl max 0 $ map (length . f) cmds
+
+{- 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 = return ()
+tryRun' errnum state cmd (a:as) = run >>= handle
+	where
+		run = IO.try $ 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 = tryRun' (if success then errnum else errnum + 1) 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 :: Annex Bool
+shutdown = do
+	saveState
+	liftIO Git.Command.reap -- zombies from long-running git processes
+	return True

Command.hs

@@ -0,0 +1,108 @@
+{- 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,
+	next,
+	stop,
+	stopUnless,
+	prepCommand,
+	doCommand,
+	whenAnnexed,
+	ifAnnexed,
+	notBareRepo,
+	isBareRepo,
+	autoCopies,
+	module ReExported
+) where
+
+import Common.Annex
+import qualified Backend
+import qualified Annex
+import qualified Git
+import Types.Command as ReExported
+import Seek as ReExported
+import Checks as ReExported
+import Options as ReExported
+import Logs.Trust
+import Logs.Location
+import Config
+
+{- Generates a normal command -}
+command :: String -> String -> [CommandSeek] -> String -> Command
+command = Command Nothing commonChecks
+
+{- 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 }
+
+{- 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 = do
+	ok <- c
+	if ok then a else 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) -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a)
+whenAnnexed a file = ifAnnexed file (a file) (return Nothing)
+
+ifAnnexed :: FilePath -> ((Key, Backend Annex) -> 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
+
+{- 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 :: Key -> (Int -> Int -> Bool) -> Maybe Int -> CommandStart -> CommandStart
+autoCopies key vs numcopiesattr a = Annex.getState Annex.auto >>= auto
+	where
+		auto False = a
+		auto True = do
+			needed <- getNumCopies numcopiesattr
+			(_, have) <- trustPartition UnTrusted =<< keyLocations key
+			if length have `vs` needed then a 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
+import Backend
+
+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 :: BackendFile -> CommandStart
+start p@(_, 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 p
+		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 :: BackendFile -> CommandPerform
+perform (backend, 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
+	unlessM (inAnnex key) rethrow -- no cleanup to do
+	liftIO $ whenM (doesFileExist file) $ removeFile file
+	handle tryharder $ fromAnnex key file
+	logStatus key InfoMissing
+	rethrow
+	where
+		rethrow = throw e
+
+		-- 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
+
+	force <- Annex.getState Annex.force
+	if force
+		then Annex.Queue.add "add" [Param "-f", Param "--"] [file]
+		else Annex.Queue.add "add" [Param "--"] [file]
+	return True

Command/AddUrl.hs

@@ -0,0 +1,72 @@
+{- 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 Utility.Url as Url
+import qualified Command.Add
+import qualified Annex
+import qualified Backend.URL
+import Annex.Content
+import Logs.Web
+
+def :: [Command]
+def = [command "addurl" (paramRepeating paramUrl) seek "add urls to annex"]
+
+seek :: [CommandSeek]
+seek = [withStrings start]
+
+start :: String -> CommandStart
+start s = notBareRepo $ go $ parseURI s
+	where
+		go Nothing = error $ "bad url " ++ s
+		go (Just url) = do
+			file <- liftIO $ url2file url
+			showStart "addurl" file
+			next $ perform s file
+
+perform :: String -> FilePath -> CommandPerform
+perform url file = do
+	fast <- Annex.getState Annex.fast
+	if fast then nodownload url file else download url file
+
+download :: String -> FilePath -> CommandPerform
+download url file = do
+	showAction $ "downloading " ++ url ++ " "
+	let dummykey = Backend.URL.fromUrl url
+	tmp <- fromRepo $ gitAnnexTmpLocation dummykey
+	liftIO $ createDirectoryIfMissing True (parentDir tmp)
+	stopUnless (liftIO $ Url.download url tmp) $ do
+		[(backend, _)] <- Backend.chooseBackends [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
+	let key = Backend.URL.fromUrl url
+	setUrlPresent key url
+	next $ Command.Add.cleanup file key False
+
+url2file :: URI -> IO FilePath
+url2file url = do
+	whenM (doesFileExist file) $
+		error $ "already have this url in " ++ file
+	return file
+	where
+		file = escape $ uriRegName auth ++ uriPath url ++ uriQuery url
+		escape = replace "/" "_" . replace "?" "_"
+		auth = fromMaybe (error $ "bad url " ++ show url) $ uriAuthority url

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 = [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,26 @@
+{- 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
+
+def :: [Command]
+def = [dontCheck toOpt $ dontCheck fromOpt $ 
+	command "copy" paramPaths seek
+	"copy content of files to/from another repository"]
+
+seek :: [CommandSeek]
+seek = [withNumCopies $ \n -> whenAnnexed $ start n]
+
+-- A copy is just a move that does not delete the source file.
+-- However, --auto mode avoids unnecessary copies.
+start :: Maybe Int -> FilePath -> (Key, Backend Annex) -> CommandStart
+start numcopies file (key, backend) = autoCopies key (<) numcopies $
+	Command.Move.start 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,132 @@
+{- 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
+
+def :: [Command]
+def = [dontCheck fromOpt $ command "drop" paramPaths seek
+	"indicate content of files not currently wanted"]
+
+seek :: [CommandSeek]
+seek = [withNumCopies $ \n -> whenAnnexed $ start n]
+
+start :: Maybe Int -> FilePath -> (Key, Backend Annex) -> CommandStart
+start numcopies file (key, _) = autoCopies key (>) numcopies $ do
+	from <- Annex.getState Annex.fromremote
+	case from of
+		Nothing -> startLocal file numcopies key
+		Just name -> do
+			remote <- Remote.byName name
+			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.Remote Annex -> 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.Remote Annex -> 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.Remote Annex -> 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 False
+	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.Remote Annex] -> [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.Remote Annex] -> 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.Remote Annex] -> 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 = [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,78 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.DropUnused where
+
+import qualified Data.Map as M
+
+import Common.Annex
+import Command
+import qualified Annex
+import qualified Command.Drop
+import qualified Remote
+import qualified Git
+import Types.Key
+
+type UnusedMap = M.Map String Key
+
+def :: [Command]
+def = [dontCheck fromOpt $ command "dropunused" (paramRepeating paramNumber)
+	seek "drop unused file content"]
+
+seek :: [CommandSeek]
+seek = [withUnusedMaps]
+
+{- Read unused logs once, and pass the maps to each start action. -}
+withUnusedMaps :: CommandSeek
+withUnusedMaps params = do
+	unused <- readUnusedLog ""
+	unusedbad <- readUnusedLog "bad"
+	unusedtmp <- readUnusedLog "tmp"
+	return $ map (start (unused, unusedbad, unusedtmp)) params
+
+start :: (UnusedMap, UnusedMap, UnusedMap) -> FilePath -> CommandStart
+start (unused, unusedbad, unusedtmp) s = search
+	[ (unused, perform)
+	, (unusedbad, performOther gitAnnexBadLocation)
+	, (unusedtmp, performOther gitAnnexTmpLocation)
+	]
+	where
+		search [] = stop
+		search ((m, a):rest) =
+			case M.lookup s m of
+				Nothing -> search rest
+				Just key -> do
+					showStart "dropunused" s
+					next $ a key
+
+perform :: Key -> CommandPerform
+perform key = maybe droplocal dropremote =<< Annex.getState Annex.fromremote
+	where
+		dropremote name = do
+			r <- Remote.byName name
+			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
+
+performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform
+performOther filespec key = do
+	f <- fromRepo $ filespec key
+	liftIO $ whenM (doesFileExist f) $ removeFile f
+	next $ return True
+
+readUnusedLog :: FilePath -> Annex UnusedMap
+readUnusedLog prefix = do
+	f <- fromRepo $ gitAnnexUnusedLog prefix
+	e <- liftIO $ doesFileExist f
+	if e
+		then M.fromList . map parse . lines <$> liftIO (readFile f)
+		else return M.empty
+	where
+		parse line = (num, fromJust $ readKey rest)
+			where
+				(num, rest) = separate (== ' ') line

Command/Find.hs

@@ -0,0 +1,48 @@
+{- git-annex command
+ -
+ - Copyright 2010 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
+
+def :: [Command]
+def = [command "find" paramPaths seek "lists available files"]
+
+seek :: [CommandSeek]
+seek = [withFilesInGit $ whenAnnexed start]
+
+start :: FilePath -> (Key, Backend Annex) -> CommandStart
+start file (key, _) = do
+	-- only files inAnnex are shown, unless the user has requested
+	-- others via a limit
+	whenM (liftM2 (||) limited (inAnnex key)) $
+		unlessM (showFullJSON vars) $ do
+			f <- Annex.getState Annex.format
+			case f 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 Annex) -> 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,168 @@
+{- 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 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
+
+def :: [Command]
+def = [command "fsck" paramPaths seek "check for problems"]
+
+seek :: [CommandSeek]
+seek =
+	[ withNumCopies $ \n -> whenAnnexed $ start n
+	, withBarePresentKeys startBare
+	]
+
+start :: Maybe Int -> FilePath -> (Key, Backend Annex) -> CommandStart
+start numcopies file (key, backend) = do
+	showStart "fsck" file
+	next $ perform key file backend numcopies
+
+perform :: Key -> FilePath -> Backend Annex -> Maybe Int -> CommandPerform
+perform key file backend numcopies = check
+	-- order matters
+	[ verifyLocationLog key file
+	, checkKeySize key
+	, checkKeyNumCopies key file numcopies
+	, checkBackend backend key
+	]
+
+{- 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"
+			prepStart 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 Annex -> 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 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
+		f <- inRepo $ gitAnnexLocation key
+		liftIO $ do
+			preventWrite f
+			preventWrite (parentDir f)
+
+	u <- getUUID
+        uuids <- keyLocations key
+
+	case (present, u `elem` uuids) of
+		(True, False) -> do
+				fix u InfoPresent
+				-- There is no data loss, so do not fail.
+				return True
+		(False, True) -> do
+				fix u 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 u s = do
+			showNote "fixing location log"
+			logChange key u 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
+	present <- liftIO $ doesFileExist file
+	case (present, Types.Key.keySize key) of
+		(_, Nothing) -> return True
+		(False, _) -> return True
+		(True, Just size) -> do
+			stat <- liftIO $ getFileStatus file
+			let size' = fromIntegral (fileSize stat)
+			if size == size'
+				then return True
+				else do
+					dest <- moveBad key
+					warning $ "Bad file size (" ++
+						compareSizes storageUnits True size size' ++ 
+						"); moved to " ++ dest
+					return False
+
+
+checkBackend :: Backend Annex -> Key -> Annex Bool
+checkBackend = Types.Backend.fsckKey
+
+checkKeyNumCopies :: Key -> FilePath -> Maybe Int -> Annex Bool
+checkKeyNumCopies key file numcopies = do
+	needed <- getNumCopies numcopies
+	(untrustedlocations, safelocations) <- trustPartition UnTrusted =<< 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

Command/Get.hs

@@ -0,0 +1,80 @@
+{- 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 Annex
+import qualified Remote
+import Annex.Content
+import qualified Command.Move
+
+def :: [Command]
+def = [dontCheck fromOpt $ command "get" paramPaths seek
+	"make content of annexed files available"]
+
+seek :: [CommandSeek]
+seek = [withNumCopies $ \n -> whenAnnexed $ start n]
+
+start :: Maybe Int -> FilePath -> (Key, Backend Annex) -> CommandStart
+start numcopies file (key, _) = stopUnless (not <$> inAnnex key) $
+	autoCopies key (<) numcopies $ do
+		from <- Annex.getState Annex.fromremote
+		case from of
+			Nothing -> go $ perform key
+			Just name -> do
+				-- get --from = copy --from
+				src <- Remote.byName name
+				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) $ do
+	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 = do
+	remotes <- Remote.keyPossibilities key
+	if null remotes
+		then do
+			showNote "not available"
+			Remote.showLocations key []
+			return False
+		else trycopy remotes remotes
+	where
+		trycopy full [] = do
+			Remote.showTriedRemotes full
+			Remote.showLocations key []
+			return False
+		trycopy full (r:rs) = do
+			probablythere <- probablyPresent r
+			if probablythere
+				then docopy r (trycopy full rs)
+				else trycopy full rs
+		-- This check is to avoid an ugly message if a remote is a
+		-- drive that is not mounted.
+		probablyPresent r =
+			if Remote.hasKeyCheap r
+				then do
+					res <- Remote.hasKey r key
+					case res of
+						Right b -> return b
+						Left _ -> return False
+				else return True
+		docopy r continue = do
+			showAction $ "from " ++ Remote.name r
+			copied <- Remote.retrieveKeyFile r key file
+			if copied
+				then return True
+				else continue

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 = [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 :: R.RemoteType Annex -> 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 (R.RemoteType Annex)
+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,34 @@
+{- 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
+import Backend
+	
+def :: [Command]
+def = [command "lock" paramPaths seek "undo unlock command"]
+
+seek :: [CommandSeek]
+seek = [withFilesUnlocked start, withFilesUnlockedToBeCommitted start]
+
+{- Undo unlock -}
+start :: BackendFile -> CommandStart
+start (_, file) = do
+	showStart "lock" file
+	next $ perform file
+
+perform :: FilePath -> CommandPerform
+perform file = do
+	liftIO $ removeFile file
+	-- Checkout from HEAD to get rid of any changes that might be 
+	-- staged in the index, and get back to the previous symlink to
+	-- the content.
+	Annex.Queue.add "checkout" [Param "HEAD", Param "--"] [file]
+	next $ return True -- no cleanup needed

Command/Map.hs

@@ -0,0 +1,238 @@
+{- 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 Annex.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 $ do
+		fast <- Annex.getState Annex.fast
+		if fast
+			then return True
+			else 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
+	| otherwise = liftIO $ Git.Construct.fromAbsPath =<< absPath (Git.workTree 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.workTree
+	| both Git.repoIsUrl && neither Git.repoIsSsh = matching show
+	| neither Git.repoIsSsh = matching Git.workTree
+	| 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.workTree 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,29 @@
+{- 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
+	next $ return True

Command/Migrate.hs

@@ -0,0 +1,79 @@
+{- 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.Add
+import Logs.Web
+
+def :: [Command]
+def = [command "migrate" paramPaths seek "switch data to different backend"]
+
+seek :: [CommandSeek]
+seek = [withBackendFilesInGit $ \(b, f) -> whenAnnexed (start b) f]
+
+start :: Maybe (Backend Annex) -> FilePath -> (Key, Backend Annex) -> CommandStart
+start b file (key, oldbackend) = do
+	exists <- inAnnex key
+	newbackend <- choosebackend b
+	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 Annex -> CommandPerform
+perform file oldkey newbackend = do
+	src <- inRepo $ gitAnnexLocation oldkey
+	tmp <- fromRepo gitAnnexTmpDir
+	let tmpfile = tmp </> takeFileName file
+	cleantmp tmpfile
+	liftIO $ createLink src tmpfile
+	k <- Backend.genKey tmpfile $ Just newbackend
+	cleantmp tmpfile
+	case k of
+		Nothing -> stop
+		Just (newkey, _) -> stopUnless (link src newkey) $ do
+			-- Update symlink to use the new key.
+			liftIO $ removeFile file
+
+			-- 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
+
+			next $ Command.Add.cleanup file newkey True
+	where
+		cleantmp t = liftIO $ whenM (doesFileExist t) $ removeFile t
+		link src newkey = getViaTmpUnchecked newkey $ \t -> do
+			-- Make a hard link to the old backend's
+			-- cached key, to avoid wasting disk space.
+			liftIO $ unlessM (doesFileExist t) $ createLink src t
+			return True	

Command/Move.hs

@@ -0,0 +1,141 @@
+{- 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
+
+def :: [Command]
+def = [dontCheck toOpt $ dontCheck fromOpt $
+	command "move" paramPaths seek
+	"move content of files to/from another repository"]
+
+seek :: [CommandSeek]
+seek = [withFilesInGit $ whenAnnexed $ start True]
+
+start :: Bool -> FilePath -> (Key, Backend Annex) -> CommandStart
+start move file (key, _) = do
+	noAuto
+	to <- Annex.getState Annex.toremote
+	from <- Annex.getState Annex.fromremote
+	case (from, to) of
+		(Nothing, Nothing) -> error "specify either --from or --to"
+		(Nothing, Just name) -> do
+			dest <- Remote.byName name
+			toStart dest move file key
+		(Just name, Nothing) -> do
+			src <- Remote.byName name
+			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.Remote Annex -> 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.Remote Annex -> 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 True
+			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.Remote Annex -> 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.Remote Annex -> Key -> Annex Bool
+fromOk src key = do
+	u <- getUUID
+	remotes <- Remote.keyPossibilities key
+	return $ u /= Remote.uuid src && any (== src) remotes
+fromPerform :: Remote.Remote Annex -> Bool -> Key -> CommandPerform
+fromPerform src move key = moveLock move key $ do
+	ishere <- inAnnex key
+	if ishere
+		then handle move True
+		else 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,33 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.PreCommit where
+
+import Command
+import qualified Command.Add
+import qualified Command.Fix
+import Backend
+
+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 :: BackendFile -> CommandStart
+start p = next $ perform p
+
+perform :: BackendFile -> CommandPerform
+perform pair@(_, file) = do
+	ok <- doCommand $ Command.Add.start pair
+	if ok
+		then next $ return True
+		else error $ "failed to add " ++ file ++ "; canceling commit"

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 = [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 so queued git commands run
+			_ <- shutdown
+			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 = do
+		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 Annex) -> 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 Annex -> 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 = [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,198 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Status where
+
+import Control.Monad.State
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.Set (Set)
+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 Annex.Content
+import Types.Key
+import Backend
+import Logs.UUID
+import Logs.Trust
+import Remote
+
+-- a named computation that produces a statistic
+type Stat = StatState (Maybe (String, StatState String))
+
+-- cached info that multiple Stats may need
+data StatInfo = StatInfo
+	{ keysPresentCache :: Maybe (Set Key)
+	, keysReferencedCache :: Maybe (Set Key)
+	}
+
+-- 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"
+	]
+slow_stats :: [Stat]
+slow_stats = 
+	[ tmp_size
+	, bad_data_size
+	, local_annex_keys
+	, local_annex_size
+	, visible_annex_keys
+	, visible_annex_size
+	, 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 = calc =<< s
+	where
+		calc (Just (desc, a)) = do
+			(lift . showHeader) desc
+			lift . showRaw =<< a
+		calc Nothing = return ()
+
+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)
+	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 $
+	keySizeSum <$> cachedKeysPresent
+
+local_annex_keys :: Stat
+local_annex_keys = stat "local annex keys" $ json show $
+	S.size <$> cachedKeysPresent
+
+visible_annex_size :: Stat
+visible_annex_size = stat "visible annex size" $ json id $
+	keySizeSum <$> cachedKeysReferenced
+
+visible_annex_keys :: Stat
+visible_annex_keys = stat "visible annex keys" $ json show $
+	S.size <$> cachedKeysReferenced
+
+tmp_size :: Stat
+tmp_size = staleSize "temporary directory size" gitAnnexTmpDir
+
+bad_data_size :: Stat
+bad_data_size = staleSize "bad keys size" gitAnnexBadDir
+
+backend_usage :: Stat
+backend_usage = stat "backend usage" $ nojson $
+	usage <$> cachedKeysReferenced <*> cachedKeysPresent
+	where
+		usage a b = pp "" $ reverse . sort $ map swap $ splits $ S.toList $ S.union a b
+		splits :: [Key] -> [(String, Integer)]
+		splits ks = M.toList $ M.fromListWith (+) $ map tcount ks
+		tcount k = (keyBackendName k, 1)
+		swap (a, b) = (b, a)
+		pp c [] = c
+		pp c ((n, b):xs) = "\n\t" ++ b ++ ": " ++ show n ++ pp c xs
+
+cachedKeysPresent :: StatState (Set Key)
+cachedKeysPresent = do
+	s <- get
+	case keysPresentCache s of
+		Just v -> return v
+		Nothing -> do
+			keys <- S.fromList <$> lift getKeysPresent
+			put s { keysPresentCache = Just keys }
+			return keys
+
+cachedKeysReferenced :: StatState (Set Key)
+cachedKeysReferenced = do
+	s <- get
+	case keysReferencedCache s of
+		Just v -> return v
+		Nothing -> do
+			keys <- S.fromList <$> lift Command.Unused.getKeysReferenced
+			put s { keysReferencedCache = Just keys }
+			return keys
+
+keySizeSum :: Set Key -> String
+keySizeSum s = total ++ missingnote
+	where
+		knownsizes = mapMaybe keySize $ S.toList s
+		total = roughSize storageUnits False $ sum knownsizes
+		missing = S.size s - genericLength knownsizes
+		missingnote
+			| missing == 0 = ""
+			| otherwise = aside $
+				"+ " ++ show missing ++
+				" keys of unknown size"
+
+staleSize :: String -> (Git.Repo -> FilePath) -> Stat
+staleSize label dirspec = do
+	keys <- lift (Command.Unused.staleKeys dirspec)
+	if null keys
+		then nostat
+		else stat label $ json (++ aside "clean up with git-annex unused") $
+			return $ keySizeSum $ S.fromList keys
+
+aside :: String -> String
+aside s = " (" ++ s ++ ")"

Command/Sync.hs

@@ -0,0 +1,74 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Sync where
+
+import Common.Annex
+import Command
+import qualified Annex.Branch
+import qualified Git.Command
+import qualified Git.Config
+import qualified Git.Ref
+import qualified Git
+
+import qualified Data.ByteString.Lazy.Char8 as L
+
+def :: [Command]
+def = [command "sync" paramPaths seek "synchronize local repository with remote"]
+
+-- syncing involves several operations, any of which can independantly fail
+seek :: [CommandSeek]
+seek = map withNothing [commit, pull, push]
+
+commit :: CommandStart
+commit = do
+	showStart "commit" ""
+	next $ next $ do
+		showOutput
+		-- Commit will fail when the tree is clean, so ignore failure.
+		_ <- inRepo $ Git.Command.runBool "commit"
+			[Param "-a", Param "-m", Param "sync"]
+		return True
+
+pull :: CommandStart
+pull = do
+	remote <- defaultRemote
+	showStart "pull" remote
+	next $ next $ do
+		showOutput
+		checkRemote remote
+		inRepo $ Git.Command.runBool "pull" [Param remote]
+
+push :: CommandStart
+push = do
+	remote <- defaultRemote
+	showStart "push" remote
+	next $ next $ do
+		Annex.Branch.update
+		showOutput
+		inRepo $ Git.Command.runBool "push" [Param remote, matchingbranches]
+	where
+		-- git push may be configured to not push matching
+		-- branches; this should ensure it always does.
+		matchingbranches = Param ":"
+
+-- the remote defaults to origin when not configured
+defaultRemote :: Annex String
+defaultRemote = do
+	branch <- currentBranch
+	fromRepo $ Git.Config.get ("branch." ++ branch ++ ".remote") "origin"
+
+currentBranch :: Annex String
+currentBranch = Git.Ref.describe . Git.Ref . firstLine . L.unpack <$>
+	inRepo (Git.Command.pipeRead [Param "symbolic-ref", Param "HEAD"])
+
+checkRemote :: String -> Annex ()
+checkRemote remote = do
+	remoteurl <- fromRepo $
+		Git.Config.get ("remote." ++ remote ++ ".url") ""
+	when (null remoteurl) $ do
+		error $ "No url is configured for the remote: " ++ remote

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/TweakFetch.hs

@@ -0,0 +1,34 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.TweakFetch where
+
+import Common
+import Command
+import qualified Git.TweakFetch
+import qualified Annex.Branch
+
+def :: [Command]
+def = [command "tweak-fetch" paramNothing seek "run by git tweak-fetch hook"]
+
+seek :: [CommandSeek]
+seek = [ withNothing start]
+
+start :: CommandStart
+start = do
+	-- First, pass the hook's input through to its output, unchanged.
+	fetched <- liftIO $ Git.TweakFetch.runHook return
+
+	-- If one of the fetched refs is going to be stored on a git-annex
+	-- tracking branch, then merge in the new sha for that ref.
+	let tomerge = filter siblings fetched
+	unless (null tomerge) $ Annex.Branch.updateTo $ map topairs tomerge
+	stop
+	where
+		siblings f = suffix `isSuffixOf` (show $ Git.TweakFetch.local f)
+		suffix = "/" ++ show Annex.Branch.name
+		topairs f = (Git.TweakFetch.sha f, Git.TweakFetch.local f)

Command/Unannex.hs

@@ -0,0 +1,62 @@
+{- 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 Utility.FileMode
+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 Annex) -> 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]
+
+	fast <- Annex.getState Annex.fast
+	if fast
+		then do
+			-- fast mode: hard link to content in annex
+			src <- inRepo $ gitAnnexLocation key
+			liftIO $ do
+				createLink src file
+				allowWrite file
+		else 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 Annex) -> 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
+	inRepo $ Git.Command.run "branch"
+		[Param "-D", Param $ show Annex.Branch.name]
+	liftIO exitSuccess

Command/Unlock.hs

@@ -0,0 +1,52 @@
+{- 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
+import Utility.FileMode
+
+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 Annex) -> 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"
+	
+	checkDiskSpace key
+
+	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
+				allowWrite 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,235 @@
+{- git-annex command
+ -
+ - Copyright 2010-2011 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 Common.Annex
+import Command
+import Annex.Content
+import Utility.FileMode
+import Utility.TempFile
+import Logs.Location
+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 Annex.CatFile
+
+def :: [Command]
+def = [dontCheck fromOpt $ command "unused" paramNothing seek
+	"look for unused file content"]
+
+seek :: [CommandSeek]
+seek = [withNothing start]
+
+{- Finds unused content in the annex. -} 
+start :: CommandStart
+start = do
+	from <- Annex.getState Annex.fromremote
+	let (name, action) = case from of
+		Nothing -> (".", checkUnused)
+		Just "." -> (".", checkUnused)
+		Just n -> (n, checkRemoteUnused n)
+	showStart "unused" name
+	next action
+
+checkUnused :: CommandPerform
+checkUnused = do
+	(unused, stalebad, staletmp) <- unusedKeys
+	_ <- list "" unusedMsg unused 0 >>=
+		list "bad" staleBadMsg stalebad >>=
+			list "tmp" staleTmpMsg staletmp
+	next $ return True
+	where
+		list file msg l c = do
+			let unusedlist = number c l
+			unless (null l) $ showLongNote $ msg unusedlist
+			writeUnusedFile file unusedlist
+			return $ c + length l
+
+checkRemoteUnused :: String -> CommandPerform
+checkRemoteUnused name = do
+	checkRemoteUnused' =<< Remote.byName name
+	next $ return True
+
+checkRemoteUnused' :: Remote.Remote Annex -> Annex ()
+checkRemoteUnused' r = do
+	showAction "checking for unused data"
+	remotehas <- loggedKeysFor (Remote.uuid r)
+	remoteunused <- excludeReferenced remotehas
+	let list = number 0 remoteunused
+	writeUnusedFile "" list
+	unless (null remoteunused) $ showLongNote $ remoteUnusedMsg r list
+
+writeUnusedFile :: FilePath -> [(Int, Key)] -> Annex ()
+writeUnusedFile prefix l = do
+	logfile <- fromRepo $ gitAnnexUnusedLog prefix
+	liftIO $ viaTmp writeFile logfile $
+		unlines $ map (\(n, k) -> show n ++ " " ++ show k) l
+
+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) ' '
+
+number :: Int -> [a] -> [(Int, a)]
+number _ [] = []
+number n (x:xs) = (n+1, x) : number (n+1) xs
+
+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.Remote Annex -> [(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.Remote Annex) -> 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 whose content is present, but that do not seem to be used
+ - by any files in the git repo, or that are only present as bad or tmp
+ - files. -}
+unusedKeys :: Annex ([Key], [Key], [Key])
+unusedKeys = do
+	fast <- Annex.getState Annex.fast
+	if fast
+		then do
+			showNote "fast mode enabled; only finding stale files"
+			tmp <- staleKeys gitAnnexTmpDir
+			bad <- staleKeys gitAnnexBadDir
+			return ([], bad, tmp)
+		else do
+			showAction "checking for unused data"
+			present <- getKeysPresent
+			unused <- excludeReferenced present
+			staletmp <- staleKeysPrune gitAnnexTmpDir present
+			stalebad <- staleKeysPrune gitAnnexBadDir present
+			return (unused, stalebad, staletmp)
+
+{- Finds keys in the list that are not referenced in the git repository. -}
+excludeReferenced :: [Key] -> Annex [Key]
+excludeReferenced [] = return [] -- optimisation
+excludeReferenced l = do
+	c <- inRepo $ Git.Command.pipeRead [Param "show-ref"]
+	removewith (getKeysReferenced : map getKeysReferencedInGit (refs c))
+		(S.fromList l)
+	where
+		-- Skip the git-annex branches, and get all other unique refs.
+		refs = map (Git.Ref .  snd) .
+			nubBy uniqref .
+			filter ourbranches .
+			map (separate (== ' ')) . lines . L.unpack
+		uniqref (a, _) (b, _) = a == b
+		ourbranchend = '/' : show Annex.Branch.name
+		ourbranches (_, b) = not $ ourbranchend `isSuffixOf` b
+		removewith [] s = return $ S.toList s
+		removewith (a:as) s
+			| s == S.empty = return [] -- optimisation
+			| otherwise = do
+				referenced <- a
+				let !s' = s `S.difference` S.fromList referenced
+				removewith as s'
+
+{- 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
+
+{- List of keys referenced by symlinks in the git repo. -}
+getKeysReferenced :: Annex [Key]
+getKeysReferenced = do
+	top <- fromRepo Git.workTree
+	files <- inRepo $ LsFiles.inRepo [top]
+	keypairs <- mapM Backend.lookupFile files
+	return $ map fst $ catMaybes keypairs
+
+{- List of keys referenced by symlinks in a git ref. -}
+getKeysReferencedInGit :: Git.Ref -> Annex [Key]
+getKeysReferencedInGit ref = do
+	showAction $ "checking " ++ Git.Ref.describe ref
+	findkeys [] =<< inRepo (LsTree.lsTree ref)
+	where
+		findkeys c [] = return c
+		findkeys c (l:ls)
+			| isSymLink (LsTree.mode l) = do
+				content <- catFile ref $ LsTree.file l
+				case fileKey (takeFileName $ L.unpack content) of
+					Nothing -> findkeys c ls
+					Just k -> findkeys (k:c) ls
+			| otherwise = findkeys c 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. 
+ - 
+ - When a list of presently available keys is provided, stale keys
+ - that no longer have value are deleted.
+ -}
+staleKeysPrune :: (Git.Repo -> FilePath) -> [Key] -> Annex [Key]
+staleKeysPrune dirspec present = do
+	contents <- staleKeys dirspec
+	
+	let stale = contents `exclude` present
+	let dups = contents `exclude` stale
+
+	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
+	exists <- liftIO $ doesDirectoryExist dir
+	if not exists
+		then return []
+		else do
+			contents <- liftIO $ getDirectoryContents dir
+			files <- liftIO $ filterM doesFileExist $
+				map (dir </>) contents
+			return $ mapMaybe (fileKey . takeFileName) files

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 = [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,41 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Whereis where
+
+import Common.Annex
+import Logs.Location
+import Command
+import Remote
+import Logs.Trust
+
+def :: [Command]
+def = [command "whereis" paramPaths seek
+	"lists repositories that have file content"]
+
+seek :: [CommandSeek]
+seek = [withFilesInGit $ whenAnnexed start]
+
+start :: FilePath -> (Key, Backend Annex) -> CommandStart
+start file (key, _) = do
+	showStart "whereis" file
+	next $ perform key
+
+perform :: Key -> CommandPerform
+perform key = do
+	(untrustedlocations, safelocations) <- trustPartition UnTrusted =<< keyLocations key
+	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'
+	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"

Common.hs

@@ -0,0 +1,29 @@
+module Common (module X) where
+
+import Control.Monad as X hiding (join)
+import Control.Applicative as X
+import Control.Monad.State 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.Conditional as X
+import Utility.SafeCommand as X
+import Utility.Path as X
+import Utility.Directory as X
+import Utility.Monad 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,85 @@
+{- Git configuration
+ -
+ - Copyright 2011 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
+
+type ConfigKey = String
+
+{- Changes a git config setting in both internal state and .git/config -}
+setConfig :: ConfigKey -> String -> Annex ()
+setConfig k value = do
+	inRepo $ Git.Command.run "config" [Param k, Param value]
+	-- re-read git config and update the repo's state
+	newg <- inRepo Git.Config.read
+	Annex.changeState $ \s -> s { Annex.repo = newg }
+
+{- Looks up a per-remote config setting in git config.
+ - Failing that, tries looking for a global config option. -}
+getConfig :: Git.Repo -> ConfigKey -> String -> Annex String
+getConfig r key def = do
+	def' <- fromRepo $ Git.Config.get ("annex." ++ key) def
+	fromRepo $ Git.Config.get (remoteConfig r key) def'
+
+{- Looks up a per-remote config setting in git config. -}
+remoteConfig :: Git.Repo -> ConfigKey -> String
+remoteConfig r key = "remote." ++ fromMaybe "" (Git.remoteName r) ++ ".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 <- getConfig r "cost-command" ""
+	(fromMaybe def . readMaybe) <$>
+		if not $ null cmd
+			then liftIO $ snd <$> pipeFrom "sh" ["-c", cmd]
+			else getConfig 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, based either on annex-ignore
+ - setting, or on command-line options. Allows command-line to override
+ - annex-ignore. -}
+repoNotIgnored :: Git.Repo -> Annex Bool
+repoNotIgnored r = not . Git.configTrue <$> getConfig r "ignore" "false"
+
+{- 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) =<< 
+			readMaybe <$> fromRepo (Git.Config.get config "1")
+		perhaps fallback = maybe fallback (return . id)
+		config = "annex.numcopies"

Crypto.hs

@@ -0,0 +1,185 @@
+{- git-annex crypto
+ -
+ - Currently using gpg; could later be modified to support different
+ - crypto backends if neccessary.
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Crypto (
+	Cipher,
+	EncryptedCipher,
+	genCipher,
+	updateCipher,
+	describeCipher,
+	storeCipher,
+	extractCipher,
+	decryptCipher,		
+	encryptKey,
+	withEncryptedHandle,
+	withDecryptedHandle,
+	withEncryptedContent,
+	withDecryptedContent,
+
+	prop_hmacWithCipher_sane
+) where
+
+import qualified Data.ByteString.Lazy.Char8 as L
+import qualified Data.Map as M
+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.Remote
+import Utility.Base64
+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 as specified in the remote's configuration -}
+genCipher :: RemoteConfig -> IO EncryptedCipher
+genCipher c = do
+	ks <- configKeyIds c
+	random <- genrandom
+	encryptCipher (Cipher random) ks
+	where
+		genrandom = Gpg.readStrict
+			-- Armor the random data, to avoid newlines,
+			-- since gpg only reads ciphers up to the first
+			-- newline.
+			[ Params "--gen-random --armor"
+			, Param $ show randomquality
+			, Param $ show cipherSize
+			]
+		-- 1 is /dev/urandom; 2 is /dev/random
+		randomquality = 1 :: Int
+
+{- Updates an existing Cipher, re-encrypting it to add KeyIds specified in
+ - the remote's configuration. -}
+updateCipher :: RemoteConfig -> EncryptedCipher -> IO EncryptedCipher
+updateCipher c encipher@(EncryptedCipher _ ks) = do
+	ks' <- configKeyIds c
+	cipher <- decryptCipher c encipher
+	encryptCipher cipher (merge ks ks')
+	where
+		merge (KeyIds a) (KeyIds b) = KeyIds $ a ++ b
+
+describeCipher :: EncryptedCipher -> String
+describeCipher (EncryptedCipher _ (KeyIds ks)) =
+	"with gpg " ++ keys ks ++ " " ++ unwords ks
+	where
+		keys [_] = "key"
+		keys _ = "keys"
+
+{- Stores an EncryptedCipher in a remote's configuration. -}
+storeCipher :: RemoteConfig -> EncryptedCipher -> RemoteConfig
+storeCipher c (EncryptedCipher t ks) = 
+	M.insert "cipher" (toB64 t) $ M.insert "cipherkeys" (showkeys ks) c
+	where
+		showkeys (KeyIds l) = join "," l
+
+{- Extracts an EncryptedCipher from a remote's configuration. -}
+extractCipher :: RemoteConfig -> Maybe EncryptedCipher
+extractCipher c = 
+	case (M.lookup "cipher" c, M.lookup "cipherkeys" c) of
+		(Just t, Just ks) -> Just $ EncryptedCipher (fromB64 t) (readkeys ks)
+		_ -> Nothing
+	where
+		readkeys = KeyIds . split ","
+
+{- Encrypts a Cipher to the specified KeyIds. -}
+encryptCipher :: Cipher -> KeyIds -> IO EncryptedCipher
+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 :: RemoteConfig -> EncryptedCipher -> IO Cipher
+decryptCipher _ (EncryptedCipher encipher _) = 
+	Cipher <$> Gpg.pipeStrict decrypt encipher
+	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 c i a = to c i $ \h -> a =<< L.hGetContents h
+
+configKeyIds :: RemoteConfig -> IO KeyIds
+configKeyIds c = Gpg.findPubKeys $ configGet c "encryption"
+
+configGet :: RemoteConfig -> String -> String
+configGet c key = fromMaybe missing $ M.lookup key c
+	where
+		missing = error $ "missing " ++ key ++ " in remote config"
+
+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,116 @@
+{- git repository handling 
+ -
+ - This is written to be completely independant of git-annex and should be
+ - suitable for other uses.
+ -
+ - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git (
+	Repo(..),
+	Ref(..),
+	Branch,
+	Sha,
+	Tag,
+	repoIsUrl,
+	repoIsSsh,
+	repoIsHttp,
+	repoIsLocalBare,
+	repoDescribe,
+	repoLocation,
+	workTree,
+	gitDir,
+	configTrue,
+	attributes,
+	assertLocal,
+) where
+
+import qualified Data.Map as M
+import Data.Char
+import Network.URI (uriPath, uriScheme)
+
+import Common
+import Git.Types
+
+{- 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 = Dir 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 = Dir dir } = dir
+repoLocation Repo { location = Unknown } = 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
+
+configAvail ::Repo -> Bool
+configAvail Repo { config = c } = c /= M.empty
+
+repoIsLocalBare :: Repo -> Bool
+repoIsLocalBare r@(Repo { location = Dir _ }) = configAvail r && configBare r
+repoIsLocalBare _ = False
+
+assertLocal :: Repo -> a -> a
+assertLocal repo action = 
+	if not $ repoIsUrl repo
+		then action
+		else error $ "acting on non-local git repo " ++  repoDescribe repo ++ 
+				" not supported"
+configBare :: Repo -> Bool
+configBare repo = maybe unknown configTrue $ M.lookup "core.bare" $ config repo
+	where
+		unknown = error $ "it is not known if git repo " ++
+			repoDescribe repo ++
+			" is a bare repository; config not read"
+
+{- Path to a repository's gitattributes file. -}
+attributes :: Repo -> String
+attributes repo
+	| configBare repo = workTree repo ++ "/info/.gitattributes"
+	| otherwise = workTree repo ++ "/.gitattributes"
+
+{- Path to a repository's .git directory. -}
+gitDir :: Repo -> String
+gitDir repo
+	| configBare repo = workTree repo
+	| otherwise = workTree repo </> ".git"
+
+{- Path to a repository's --work-tree, that is, its top.
+ -
+ - Note that for URL repositories, this is the path on the remote host. -}
+workTree :: Repo -> FilePath
+workTree Repo { location = Url u } = uriPath u
+workTree Repo { location = Dir d } = d
+workTree Repo { location = Unknown } = undefined
+
+{- Checks if a string from git config is a true value. -}
+configTrue :: String -> Bool
+configTrue s = map toLower s == "true"

Git/Branch.hs

@@ -0,0 +1,79 @@
+{- 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
+
+{- 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 = do
+	-- First, check that the branch does not contain any
+	-- new commits that are not in the first ref. If it does,
+	-- cannot fast-forward.
+	diverged <- changed first branch repo
+	if diverged
+		then no_ff
+		else 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,75 @@
+{- 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 Control.Monad.State
+import System.Cmd.Utils
+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
+
+type CatFileHandle = (PipeHandle, Handle, Handle)
+
+{- Starts git cat-file running in batch mode in a repo and returns a handle. -}
+catFileStart :: Repo -> IO CatFileHandle
+catFileStart repo = hPipeBoth "git" $ toCommand $
+	gitCommandLine [Param "cat-file", Param "--batch"] repo
+
+{- Stops git cat-file. -}
+catFileStop :: CatFileHandle -> IO ()
+catFileStop (pid, from, to) = do
+	hClose to
+	hClose from
+	forceSuccess pid
+
+{- 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 (_, from, to) object = do
+	hPutStrLn to $ show object
+	hFlush to
+	header <- hGetLine from
+	case words header of
+		[sha, objtype, size]
+			| length sha == shaSize &&
+			  validobjtype objtype -> handle size
+			| otherwise -> dne
+		_
+			| header == show object ++ " missing" -> dne
+			| otherwise -> error $ "unknown response from git cat-file " ++ header
+	where
+		handle size = case reads size of
+			[(bytes, "")] -> readcontent bytes
+			_ -> dne
+		readcontent bytes = 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,66 @@
+{- git check-attr interface
+ -
+ - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.CheckAttr where
+
+import System.Exit
+
+import Common
+import Git
+import Git.Command
+import qualified Git.Filename
+import qualified Git.Version
+
+{- Efficiently looks up a gitattributes value for each file in a list. -}
+lookup :: String -> [FilePath] -> Repo -> IO [(FilePath, String)]
+lookup attr files repo = do
+	cwd <- getCurrentDirectory
+	(_, fromh, toh) <- hPipeBoth "git" (toCommand params)
+        _ <- forkProcess $ do
+		hClose fromh
+                hPutStr toh $ join "\0" $ input cwd
+                hClose toh
+                exitSuccess
+        hClose toh
+	output cwd . lines <$> hGetContents fromh
+	where
+		params = gitCommandLine 
+				[ Param "check-attr"
+				, Param attr
+				, Params "-z --stdin"
+				] repo
+
+		{- 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"
+		input cwd
+			| oldgit = map (absPathFrom cwd) files
+			| otherwise = map (relPathDirToFile cwd . absPathFrom cwd) files
+		output cwd
+			| oldgit = map (torel cwd . topair)
+			| otherwise = map topair
+
+		topair l = (Git.Filename.decode file, value)
+			where 
+				file = join sep $ beginning bits
+				value = end bits !! 0
+				bits = split sep l
+				sep = ": " ++ attr ++ ": "
+
+		torel cwd (file, value) = (relfile, value)
+			where
+				relfile
+					| startswith cwd' file = drop (length cwd') file
+					| otherwise = relPathDirToFile top' file
+				top = workTree repo
+				cwd' = cwd ++ "/"
+				top' = top ++ "/"

Git/Command.hs

@@ -0,0 +1,82 @@
+{- running git commands
+ -
+ - Copyright 2010, 2011 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@(Repo { location = Dir _ } ) =
+	-- force use of specified repo via --git-dir and --work-tree
+	[ Param ("--git-dir=" ++ gitDir repo)
+	, Param ("--work-tree=" ++ workTree repo)
+	] ++ params
+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 $
+	runBool subcommand params repo
+		>>! error $ "git " ++ 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
+	r <- catchDefaultIO (getAnyProcessStatus False True) Nothing
+	maybe (return ()) (const reap) r

Git/Config.hs

@@ -0,0 +1,60 @@
+{- git repository configuration handling
+ -
+ - Copyright 2010,2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Config where
+
+import System.Posix.Directory
+import Control.Exception (bracket_)
+import qualified Data.Map as M
+
+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)
+
+{- Runs git config and populates a repo with its config. -}
+read :: Repo -> IO Repo
+read repo@(Repo { location = Dir d }) = do
+	{- Cannot use pipeRead because it relies on the config having
+	   been already read. Instead, chdir to the repo. -}
+	cwd <- getCurrentDirectory
+	bracket_ (changeWorkingDirectory d) (changeWorkingDirectory cwd) $
+		pOpen ReadFromPipe "git" ["config", "--null", "--list"] $
+			hRead repo
+read r = assertLocal r $ error "internal"
+
+{- 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 inrementally. -}
+store :: String -> Repo -> IO Repo
+store s repo = do
+	let repo' = repo { config = parse s `M.union` config repo }
+	rs <- Git.Construct.fromRemotes repo'
+	return $ repo' { remotes = rs }
+
+{- 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.fromList . map (separate (== c))

Git/Construct.hs

@@ -0,0 +1,215 @@
+{- Construction of Git Repo objects
+ -
+ - Copyright 2010,2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Construct (
+	fromCwd,
+	fromAbsPath,
+	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 current git repository, which may be in a parent directory. -}
+fromCwd :: IO Repo
+fromCwd = getCurrentDirectory >>= seekUp isRepoTop >>= maybe norepo makerepo
+	where
+		makerepo = return . newFrom . Dir
+		norepo = error "Not in a git repository."
+
+{- Local Repo constructor, requires an absolute path to the repo be
+ - specified. -}
+fromAbsPath :: FilePath -> IO Repo
+fromAbsPath dir
+	| "/" `isPrefixOf` dir = do
+ 		-- Git always looks for "dir.git" in preference to
+		-- to "dir", even if dir ends in a "/".
+		let canondir = dropTrailingPathSeparator dir
+		let dir' = canondir ++ ".git"
+		e <- doesDirectoryExist dir'
+		if e
+			then ret dir'
+			else if "/.git" `isSuffixOf` canondir
+				then do
+					-- When dir == "foo/.git", git looks
+					-- for "foo/.git/.git", and failing
+					-- that, uses "foo" as the repository.
+					e' <- doesDirectoryExist $ dir </> ".git"
+					if e'
+						then ret dir
+						else ret $ takeDirectory canondir
+				else ret dir
+	| otherwise = error $ "internal error, " ++ dir ++ " is not absolute"
+	where
+		ret = return . newFrom . Dir
+
+{- Remote Repo constructor. Throws exception on invalid url. -}
+fromUrl :: String -> IO Repo
+fromUrl url
+	| startswith "file://" url = fromAbsPath $ uriPath u
+	| otherwise = return $ 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 = return $ 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 ++
+			workTree 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
+		filterconfig f = filter f $ M.toList $ config repo
+		gen v	
+			| scpstyle v = fromUrl $ scptourl v
+			| isURI 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
+				(prefix, suffix) = ("url." , ".insteadof")
+		-- 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 $ workTree 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 = do
+	ok <- want dir
+	if ok
+		then return $ Just dir
+		else case parentDir dir of
+			"" -> return Nothing
+			d -> seekUp want d
+
+isRepoTop :: FilePath -> IO Bool
+isRepoTop dir = do
+	r <- isRepo
+	b <- isBareRepo
+	return (r || b)
+	where
+		isRepo = gitSignature ".git" ".git/config"
+		isBareRepo = gitSignature "objects" "config"
+		gitSignature subdir file = liftM2 (&&)
+			(doesDirectoryExist (dir ++ "/" ++ subdir))
+			(doesFileExist (dir ++ "/" ++ file))
+
+newFrom :: RepoLocation -> Repo
+newFrom l = 
+	Repo {
+		location = l,
+		config = M.empty,
+		remotes = [],
+		remoteName = Nothing
+	}

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,32 @@
+{- git hash-object interface
+ -
+ - Copyright 2011 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
+
+{- Injects a set of files into git, returning the shas of the objects
+ - and an IO action to call ones the the shas have been used. -}
+hashFiles :: [FilePath] -> Repo -> IO ([Sha], IO ())
+hashFiles paths repo = do
+	(pid, fromh, toh) <- hPipeBoth "git" $ toCommand $ git_hash_object repo
+	_ <- forkProcess (feeder toh)
+	hClose toh
+	shas <- map Ref . lines <$> hGetContentsStrict fromh
+	return (shas, ender fromh pid)
+	where
+		git_hash_object = gitCommandLine
+			[Param "hash-object", Param "-w", Param "--stdin-paths"]
+		feeder toh = do
+			hPutStr toh $ unlines paths
+			hClose toh
+			exitSuccess
+		ender fromh pid = do
+			hClose fromh
+			forceSuccess pid

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,71 @@
+{- 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 = pipeNullSplit $ prefix ++ ps ++ suffix
+	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,93 @@
+{- git repository command queue
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+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 Int (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. -}
+maxSize :: Int
+maxSize = 10240
+
+{- Constructor for empty queue. -}
+new :: Queue
+new = Queue 0 M.empty
+
+{- Adds an action to a queue. -}
+add :: Queue -> String -> [CommandParam] -> [FilePath] -> Queue
+add (Queue n m) subcommand params files = Queue (n + 1) 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
+
+{- Number of items in a queue. -}
+size :: Queue -> Int
+size (Queue n _) = n
+
+{- Is a queue large enough that it should be flushed? -}
+full :: Queue -> Bool
+full (Queue n _) = n > maxSize
+
+{- Runs a queue on a git repository. -}
+flush :: Queue -> Repo -> IO Queue
+flush (Queue _ m) repo = do
+	forM_ (M.toList m) $ uncurry $ runAction repo
+	return new
+
+{- 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 = hPutStr h $ join "\0" files

Git/Ref.hs

@@ -0,0 +1,48 @@
+{- 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
+
+{- Converts a fully qualified git ref into a user-visible version. -}
+describe :: Ref -> String
+describe = remove "refs/heads/" . remove "refs/remotes/" . show
+	where
+		remove prefix s
+			| prefix `isPrefixOf` s = drop (length prefix) s
+			| otherwise = s
+
+{- 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.
+ - Duplicate refs are filtered out. -}
+matching :: Ref -> Repo -> IO [(Ref, Branch)]
+matching ref repo = do
+	r <- pipeRead [Param "show-ref", Param $ show ref] repo
+	return $ nubBy uniqref $ map (gen . L.unpack) (L.lines r)
+	where
+		uniqref (a, _) (b, _) = a == b
+		gen l = let (r, b) = separate (== ' ') l in
+			(Ref r, Ref b)

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
+			| isSha v = Just $ Ref v
+			| otherwise = Nothing
+
+isSha :: String -> Bool
+isSha v = all (`elem` "1234567890ABCDEFabcdef") v && length v == shaSize
+
+{- Size of a git sha. -}
+shaSize :: Int
+shaSize = 40

Git/TweakFetch.hs

@@ -0,0 +1,79 @@
+{- git tweak-fetch hook support
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.TweakFetch (runHook, FetchedRef(..)) where
+
+import Data.Either (rights)
+import System.Posix.IO
+
+import Common
+import Git
+import Git.Sha
+
+data FetchedRef = FetchedRef
+	{ sha :: Sha
+	, merge :: Bool
+	, remote :: Ref
+	, local :: Ref
+	}
+	deriving (Show)
+
+{- Each line fed to the tweak-fetch hook should represent a ref that is
+ - being updated. It's important that the hook always outputs every line
+ - that is fed into it (possibly modified), otherwise incoming refs will
+ - not be stored. So to avoid breaking if the format changes, unparsable
+ - lines are passed through unchanged. -}
+type HookLine = Either String FetchedRef
+
+{- Runs the hook, allowing lines to be mutated, but never be discarded.
+ - Returns same FetchedRefs that are output by the hook, for further use. -}
+runHook :: (FetchedRef -> IO FetchedRef) -> IO [FetchedRef]
+runHook mutate = do
+	ls <- mapM go =<< input
+	output ls
+
+	-- Nothing more should be output to stdout; only hook output
+	-- is accepted by git. Redirect stdout to stderr.
+	hFlush stdout
+	_ <- liftIO $ dupTo stdError stdOutput
+
+	return $ rights ls
+	where
+		go u@(Left _) = return u
+		go (Right r) = Right <$> catchDefaultIO (mutate r) r
+
+input :: IO [HookLine]
+input = map parseLine . lines <$> getContents
+
+output :: [HookLine] -> IO ()
+output = mapM_ $ putStrLn . genLine
+
+parseLine :: String -> HookLine
+parseLine line = go $ words line
+	where
+		go [s, m, r, l]
+			| not $ isSha s = Left line
+			| m == "merge" = parsed True
+			| m == "not-for-merge" = parsed False
+			| otherwise = Left line
+			where
+				parsed v = Right $ FetchedRef
+					{ sha = Ref s
+					, merge = v
+					, remote = Ref r
+					, local = Ref l
+					}
+		go _ = Left line
+
+genLine :: HookLine -> String
+genLine (Left l) = l
+genLine (Right r) = unwords
+	[ show $ sha r
+	, if merge r then "merge" else "not-for-merge"
+	, show $ remote r
+	, show $ local r
+	]

Git/Types.hs

@@ -0,0 +1,36 @@
+{- git data types
+ -
+ - Copyright 2010,2011 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
+
+{- There are two types of repositories; those on local disk and those
+ - accessed via an URL. -}
+data RepoLocation = Dir FilePath | Url URI | Unknown
+	deriving (Show, Eq)
+
+data Repo = Repo {
+	location :: RepoLocation,
+	config :: 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,141 @@
+{- 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)
+	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 returning a list suitable for update_index. -}
+calc_merge :: CatFileHandle -> [String] -> Repo -> Streamer
+calc_merge ch differ repo streamer = gendiff >>= go
+	where
+		gendiff = pipeNullSplit (map Param differ) repo
+		go [] = return ()
+		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
+		nullsha = Ref $ replicate shaSize '0'
+		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) -> readMaybe 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

GitAnnex.hs

@@ -0,0 +1,144 @@
+{- git-annex main program
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module GitAnnex where
+
+import System.Console.GetOpt
+
+import Common.Annex
+import qualified Git.Config
+import qualified Git.Construct
+import CmdLine
+import Command
+import Types.TrustLevel
+import qualified Annex
+import qualified Remote
+import qualified Limit
+import qualified Utility.Format
+
+import qualified Command.Add
+import qualified Command.Unannex
+import qualified Command.Drop
+import qualified Command.Move
+import qualified Command.Copy
+import qualified Command.Get
+import qualified Command.FromKey
+import qualified Command.DropKey
+import qualified Command.Reinject
+import qualified Command.Fix
+import qualified Command.Init
+import qualified Command.Describe
+import qualified Command.InitRemote
+import qualified Command.Fsck
+import qualified Command.Unused
+import qualified Command.DropUnused
+import qualified Command.Unlock
+import qualified Command.Lock
+import qualified Command.PreCommit
+import qualified Command.TweakFetch
+import qualified Command.Find
+import qualified Command.Whereis
+import qualified Command.Merge
+import qualified Command.Status
+import qualified Command.Migrate
+import qualified Command.Uninit
+import qualified Command.Trust
+import qualified Command.Untrust
+import qualified Command.Semitrust
+import qualified Command.Dead
+import qualified Command.Sync
+import qualified Command.AddUrl
+import qualified Command.Map
+import qualified Command.Upgrade
+import qualified Command.Version
+
+cmds :: [Command]
+cmds = concat
+	[ Command.Add.def
+	, Command.Get.def
+	, Command.Drop.def
+	, Command.Move.def
+	, Command.Copy.def
+	, Command.Unlock.def
+	, Command.Lock.def
+	, Command.Sync.def
+	, Command.AddUrl.def
+	, Command.Init.def
+	, Command.Describe.def
+	, Command.InitRemote.def
+	, Command.Reinject.def
+	, Command.Unannex.def
+	, Command.Uninit.def
+	, Command.PreCommit.def
+	, Command.TweakFetch.def
+	, Command.Trust.def
+	, Command.Untrust.def
+	, Command.Semitrust.def
+	, Command.Dead.def
+	, Command.FromKey.def
+	, Command.DropKey.def
+	, Command.Fix.def
+	, Command.Fsck.def
+	, Command.Unused.def
+	, Command.DropUnused.def
+	, Command.Find.def
+	, Command.Whereis.def
+	, Command.Merge.def
+	, Command.Status.def
+	, Command.Migrate.def
+	, Command.Map.def
+	, Command.Upgrade.def
+	, Command.Version.def
+	]
+
+options :: [Option]
+options = commonOptions ++
+	[ Option ['t'] ["to"] (ReqArg setto paramRemote)
+		"specify to where to transfer content"
+	, Option ['f'] ["from"] (ReqArg setfrom paramRemote)
+		"specify from where to transfer content"
+	, Option ['N'] ["numcopies"] (ReqArg setnumcopies paramNumber)
+		"override default number of copies"
+	, Option [] ["trust"] (ReqArg (Remote.forceTrust Trusted) paramRemote)
+		"override trust setting"
+	, Option [] ["semitrust"] (ReqArg (Remote.forceTrust SemiTrusted) paramRemote)
+		"override trust setting back to default"
+	, Option [] ["untrust"] (ReqArg (Remote.forceTrust UnTrusted) paramRemote)
+		"override trust setting to untrusted"
+	, Option ['c'] ["config"] (ReqArg setgitconfig "NAME=VALUE")
+		"override git configuration setting"
+	, Option [] ["print0"] (NoArg setprint0)
+		"terminate output with null"
+	, Option [] ["format"] (ReqArg setformat paramFormat)
+		"control format of output"
+	, Option ['x'] ["exclude"] (ReqArg Limit.addExclude paramGlob)
+		"skip files matching the glob pattern"
+	, Option ['I'] ["include"] (ReqArg Limit.addInclude paramGlob)
+		"don't skip files matching the glob pattern"
+	, Option ['i'] ["in"] (ReqArg Limit.addIn paramRemote)
+		"skip files not present in a remote"
+	, Option ['C'] ["copies"] (ReqArg Limit.addCopies paramNumber)
+		"skip files with fewer copies"
+	, Option ['B'] ["inbackend"] (ReqArg Limit.addInBackend paramName)
+		"skip files not using a key-value backend"
+	] ++ matcherOptions
+	where
+		setto v = Annex.changeState $ \s -> s { Annex.toremote = Just v }
+		setfrom v = Annex.changeState $ \s -> s { Annex.fromremote = Just v }
+		setnumcopies v = Annex.changeState $ \s -> s {Annex.forcenumcopies = readMaybe v }
+		setformat v = Annex.changeState $ \s -> s { Annex.format = Just $ Utility.Format.gen v }
+		setprint0 = setformat "${file}\0"
+		setgitconfig :: String -> Annex ()
+		setgitconfig v = do
+			newg <- inRepo $ Git.Config.store v
+			Annex.changeState $ \s -> s { Annex.repo = newg }
+
+header :: String
+header = "Usage: git-annex command [option ..]"
+
+run :: [String] -> IO ()
+run args = dispatch args cmds options header Git.Construct.fromCwd

INSTALL

@@ -0,0 +1 @@
+doc/install.mdwn

Init.hs

@@ -0,0 +1,83 @@
+{- git-annex repository initialization
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Init (
+	ensureInitialized,
+	initialize,
+	uninitialize
+) where
+
+import Common.Annex
+import Utility.TempFile
+import qualified Git
+import qualified Annex.Branch
+import Logs.UUID
+import Annex.Version
+import Annex.UUID
+
+initialize :: Maybe String -> Annex ()
+initialize mdescription = do
+	prepUUID
+	Annex.Branch.create
+	setVersion
+	gitHooksWrite
+	u <- getUUID
+	maybe (recordUUID u) (describeUUID u) mdescription
+
+uninitialize :: Annex ()
+uninitialize = gitHooksUnWrite
+
+{- Will automatically initialize if there is already a git-annex
+   branch from somewhere. Otherwise, require a manual init
+   to avoid git-annex accidentially being run in git
+   repos that did not intend to use it. -}
+ensureInitialized :: Annex ()
+ensureInitialized = getVersion >>= maybe needsinit checkVersion
+	where
+		needsinit = do
+			annexed <- Annex.Branch.hasSibling
+			if annexed
+				then initialize Nothing
+				else error "First run: git-annex init"
+
+{- set up git hooks, if not already present -}
+gitHooksWrite :: Annex ()
+gitHooksWrite = unlessBare $ forM_ hooks $ \(hook, content) -> do
+	file <- hookFile hook
+	exists <- liftIO $ doesFileExist file
+	if exists
+		then warning $ hook ++ " hook (" ++ file ++ ") already exists, not configuring"
+		else liftIO $ do
+			viaTmp writeFile file content
+			p <- getPermissions file
+			setPermissions file $ p {executable = True}
+
+gitHooksUnWrite :: Annex ()
+gitHooksUnWrite = unlessBare $ forM_ hooks $ \(hook, content) -> do
+	file <- hookFile hook
+	whenM (liftIO $ doesFileExist file) $ do
+		c <- liftIO $ readFile file
+		if c == content
+			then liftIO $ removeFile file
+			else warning $ hook ++ " hook (" ++ file ++ 
+				") contents modified; not deleting." ++
+				" Edit it to remove call to git annex."
+
+unlessBare :: Annex () -> Annex ()
+unlessBare = unlessM $ fromRepo $ Git.repoIsLocalBare
+
+hookFile :: FilePath -> Annex FilePath
+hookFile f = (</>) <$> fromRepo Git.gitDir <*> pure ("hooks/" ++ f)
+
+hooks :: [(String, String)]
+hooks = [ ("pre-commit", hookscript "git annex pre-commit .")
+	, ("tweak-fetch", hookscript "git annex tweak-fetch")
+	]
+	where
+		hookscript s = "#!/bin/sh\n" ++
+			"# automatically configured by git-annex\n" ++
+			s ++ "\n";

Limit.hs

@@ -0,0 +1,103 @@
+{- user-specified limits on files to act on
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Limit where
+
+import Text.Regex.PCRE.Light.Char8
+import System.Path.WildMatch
+
+import Common.Annex
+import qualified Annex
+import qualified Utility.Matcher
+import qualified Remote
+import qualified Backend
+import Logs.Location
+import Annex.Content
+
+type Limit = Utility.Matcher.Token (FilePath -> Annex Bool)
+
+{- Checks if there are user-specified limits. -}
+limited :: Annex Bool
+limited = (not . Utility.Matcher.matchesAny) <$> getMatcher'
+
+{- Gets a matcher for the user-specified limits. The matcher is cached for
+ - speed; once it's obtained the user-specified limits can't change. -}
+getMatcher :: Annex (FilePath -> Annex Bool)
+getMatcher = Utility.Matcher.matchM <$> getMatcher'
+
+getMatcher' :: Annex (Utility.Matcher.Matcher (FilePath -> Annex Bool))
+getMatcher' = do
+	m <- Annex.getState Annex.limit
+	case m of
+		Right r -> return r
+		Left l -> do
+			let matcher = Utility.Matcher.generate (reverse l)
+			Annex.changeState $ \s -> s { Annex.limit = Right matcher }
+			return matcher
+
+{- Adds something to the limit list, which is built up reversed. -}
+add :: Limit -> Annex ()
+add l = Annex.changeState $ \s -> s { Annex.limit = prepend $ Annex.limit s }
+	where
+		prepend (Left ls) = Left $ l:ls
+		prepend _ = error "internal"
+
+{- Adds a new token. -}
+addToken :: String -> Annex ()
+addToken = add . Utility.Matcher.token
+
+{- Adds a new limit. -}
+addLimit :: (FilePath -> Annex Bool) -> Annex ()
+addLimit = add . Utility.Matcher.Operation
+
+{- Add a limit to skip files that do not match the glob. -}
+addInclude :: String -> Annex ()
+addInclude glob = addLimit $ return . matchglob glob
+
+{- Add a limit to skip files that match the glob. -}
+addExclude :: String -> Annex ()
+addExclude glob = addLimit $ return . not . matchglob glob
+
+matchglob :: String -> FilePath -> Bool
+matchglob glob f = isJust $ match cregex f []
+	where
+		cregex = compile regex []
+		regex = '^':wildToRegex glob
+
+{- Adds a limit to skip files not believed to be present
+ - in a specfied repository. -}
+addIn :: String -> Annex ()
+addIn name = addLimit $ check $ if name == "." then inAnnex else inremote
+	where
+		check a = Backend.lookupFile >=> handle a
+		handle _ Nothing = return False
+		handle a (Just (key, _)) = a key
+		inremote key = do
+			u <- Remote.nameToUUID name
+			us <- keyLocations key
+			return $ u `elem` us
+
+{- Adds a limit to skip files not believed to have the specified number
+ - of copies. -}
+addCopies :: String -> Annex ()
+addCopies num =
+	case readMaybe num :: Maybe Int of
+		Nothing -> error "bad number for --copies"
+		Just n -> addLimit $ check n
+	where
+		check n = Backend.lookupFile >=> handle n
+		handle _ Nothing = return False
+		handle n (Just (key, _)) = do
+			us <- keyLocations key
+			return $ length us >= n
+
+{- Adds a limit to skip files not using a specified key-value backend. -}
+addInBackend :: String -> Annex ()
+addInBackend name = addLimit $ Backend.lookupFile >=> check
+	where
+		wanted = Backend.lookupBackendName name
+		check = return . maybe False ((==) wanted . snd)

Locations.hs

@@ -0,0 +1,228 @@
+{- git-annex file locations
+ -
+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Locations (
+	keyFile,
+	fileKey,
+	keyPaths,
+	gitAnnexLocation,
+	annexLocations,
+	gitAnnexDir,
+	gitAnnexObjectDir,
+	gitAnnexTmpDir,
+	gitAnnexTmpLocation,
+	gitAnnexBadDir,
+	gitAnnexBadLocation,
+	gitAnnexUnusedLog,
+	gitAnnexJournalDir,
+	gitAnnexJournalLock,
+	gitAnnexIndex,
+	gitAnnexIndexLock,
+	isLinkToAnnex,
+	annexHashes,
+	hashDirMixed,
+	hashDirLower,
+
+	prop_idempotent_fileKey
+) where
+
+import Data.Bits
+import Data.Word
+import Data.Hash.MD5
+
+import Common
+import Types
+import Types.Key
+import qualified Git
+
+{- Conventions:
+ -
+ - Functions ending in "Dir" should always return values ending with a
+ - trailing path separator. Most code does not rely on that, but a few
+ - things do. 
+ -
+ - Everything else should not end in a trailing path sepatator. 
+ -
+ - Only functions (with names starting with "git") that build a path
+ - based on a git repository should return an absolute path.
+ - Everything else should use relative paths.
+ -}
+
+{- The directory git annex uses for local state, relative to the .git
+ - directory -}
+annexDir :: FilePath
+annexDir = addTrailingPathSeparator "annex"
+
+{- The directory git annex uses for locally available object content,
+ - relative to the .git directory -}
+objectDir :: FilePath
+objectDir = addTrailingPathSeparator $ annexDir </> "objects"
+
+{- Annexed file's possible locations relative to the .git directory.
+ - There are two different possibilities, using different hashes. -}
+annexLocations :: Key -> [FilePath]
+annexLocations key = map (annexLocation key) annexHashes
+annexLocation :: Key -> Hasher -> FilePath
+annexLocation key hasher = objectDir </> keyPath key hasher
+
+{- Annexed file's absolute location in a repository.
+ -
+ - When there are multiple possible locations, returns the one where the
+ - file is actually present.
+ -
+ - When the file is not present, returns the location where the file should
+ - be stored.
+ -}
+gitAnnexLocation :: Key -> Git.Repo -> IO FilePath
+gitAnnexLocation key r
+	| Git.repoIsLocalBare r =
+		{- Bare repositories default to hashDirLower for new
+		 - content, as it's more portable. -}
+		check (map inrepo $ annexLocations key)
+	| otherwise =
+		{- Non-bare repositories only use hashDirMixed, so
+		 - don't need to do any work to check if the file is
+		 - present. -}
+		return $ inrepo ".git" </> annexLocation key hashDirMixed
+	where
+		inrepo d = Git.workTree r </> d
+		check locs@(l:_) = fromMaybe l <$> firstM doesFileExist locs
+		check [] = error "internal"
+
+{- The annex directory of a repository. -}
+gitAnnexDir :: Git.Repo -> FilePath
+gitAnnexDir r
+	| Git.repoIsLocalBare r = addTrailingPathSeparator $ Git.workTree r </> annexDir
+	| otherwise = addTrailingPathSeparator $ Git.workTree r </> ".git" </> annexDir
+
+{- The part of the annex directory where file contents are stored. -}
+gitAnnexObjectDir :: Git.Repo -> FilePath
+gitAnnexObjectDir r
+	| Git.repoIsLocalBare r = addTrailingPathSeparator $ Git.workTree r </> objectDir
+	| otherwise = addTrailingPathSeparator $ Git.workTree r </> ".git" </> objectDir
+
+{- .git/annex/tmp/ is used for temp files -}
+gitAnnexTmpDir :: Git.Repo -> FilePath
+gitAnnexTmpDir r = addTrailingPathSeparator $ gitAnnexDir r </> "tmp"
+
+{- The temp file to use for a given key. -}
+gitAnnexTmpLocation :: Key -> Git.Repo -> FilePath
+gitAnnexTmpLocation key r = gitAnnexTmpDir r </> keyFile key
+
+{- .git/annex/bad/ is used for bad files found during fsck -}
+gitAnnexBadDir :: Git.Repo -> FilePath
+gitAnnexBadDir r = addTrailingPathSeparator $ gitAnnexDir r </> "bad"
+
+{- The bad file to use for a given key. -}
+gitAnnexBadLocation :: Key -> Git.Repo -> FilePath
+gitAnnexBadLocation key r = gitAnnexBadDir r </> keyFile key
+
+{- .git/annex/*unused is used to number possibly unused keys -}
+gitAnnexUnusedLog :: FilePath -> Git.Repo -> FilePath
+gitAnnexUnusedLog prefix r = gitAnnexDir r </> (prefix ++ "unused")
+
+{- .git/annex/journal/ is used to journal changes made to the git-annex
+ - branch -}
+gitAnnexJournalDir :: Git.Repo -> FilePath
+gitAnnexJournalDir r = addTrailingPathSeparator $ gitAnnexDir r </> "journal"
+
+{- Lock file for the journal. -}
+gitAnnexJournalLock :: Git.Repo -> FilePath
+gitAnnexJournalLock r = gitAnnexDir r </> "journal.lck"
+
+{- .git/annex/index is used to stage changes to the git-annex branch -}
+gitAnnexIndex :: Git.Repo -> FilePath
+gitAnnexIndex r = gitAnnexDir r </> "index"
+
+{- Lock file for .git/annex/index. -}
+gitAnnexIndexLock :: Git.Repo -> FilePath
+gitAnnexIndexLock r = gitAnnexDir r </> "index.lck"
+
+{- Checks a symlink target to see if it appears to point to annexed content. -}
+isLinkToAnnex :: FilePath -> Bool
+isLinkToAnnex s = ("/.git/" ++ objectDir) `isInfixOf` s
+
+{- Converts a key into a filename fragment without any directory.
+ -
+ - Escape "/" in the key name, to keep a flat tree of files and avoid
+ - issues with keys containing "/../" or ending with "/" etc. 
+ -
+ - "/" is escaped to "%" because it's short and rarely used, and resembles
+ -     a slash
+ - "%" is escaped to "&s", and "&" to "&a"; this ensures that the mapping
+ -     is one to one.
+ - ":" is escaped to "&c", because despite it being 2011, people still care
+ -     about FAT.
+ -}
+keyFile :: Key -> FilePath
+keyFile key = replace "/" "%" $ replace ":" "&c" $
+	replace "%" "&s" $ replace "&" "&a"  $ show key
+
+{- A location to store a key on the filesystem. A directory hash is used,
+ - to protect against filesystems that dislike having many items in a
+ - single directory.
+ -
+ - The file is put in a directory with the same name, this allows
+ - write-protecting the directory to avoid accidental deletion of the file.
+ -}
+keyPath :: Key -> Hasher -> FilePath
+keyPath key hasher = hasher key </> f </> f
+	where
+		f = keyFile key
+
+{- All possibile locations to store a key using different directory hashes. -}
+keyPaths :: Key -> [FilePath]
+keyPaths key = map (keyPath key) annexHashes
+
+{- Reverses keyFile, converting a filename fragment (ie, the basename of
+ - the symlink target) into a key. -}
+fileKey :: FilePath -> Maybe Key
+fileKey file = readKey $
+	replace "&a" "&" $ replace "&s" "%" $
+		replace "&c" ":" $ replace "%" "/" file
+
+{- for quickcheck -}
+prop_idempotent_fileKey :: String -> Bool
+prop_idempotent_fileKey s = Just k == fileKey (keyFile k)
+	where k = stubKey { keyName = s, keyBackendName = "test" }
+
+{- Two different directory hashes may be used. The mixed case hash
+ - came first, and is fine, except for the problem of case-strict
+ - filesystems such as Linux VFAT (mounted with shortname=mixed),
+ - which do not allow using a directory "XX" when "xx" already exists.
+ - To support that, most repositories use the lower case hash for new data. -}
+type Hasher = Key -> FilePath
+annexHashes :: [Hasher]
+annexHashes = [hashDirLower, hashDirMixed]
+
+hashDirMixed :: Hasher
+hashDirMixed k = addTrailingPathSeparator $ take 2 dir </> drop 2 dir
+	where
+		dir = take 4 $ display_32bits_as_dir =<< [a,b,c,d]
+		ABCD (a,b,c,d) = md5 $ Str $ show k
+
+hashDirLower :: Hasher
+hashDirLower k = addTrailingPathSeparator $ take 3 dir </> drop 3 dir
+	where
+		dir = take 6 $ md5s $ Str $ show k
+
+{- modified version of display_32bits_as_hex from Data.Hash.MD5
+ -   Copyright (C) 2001 Ian Lynagh 
+ -   License: Either BSD or GPL
+ -}
+display_32bits_as_dir :: Word32 -> String
+display_32bits_as_dir w = trim $ swap_pairs cs
+	where 
+		-- Need 32 characters to use. To avoid inaverdently making
+		-- a real word, use letters that appear less frequently.
+		chars = ['0'..'9'] ++ "zqjxkmvwgpfZQJXKMVWGPF"
+		cs = map (\x -> getc $ (shiftR w (6*x)) .&. 31) [0..7]
+		getc n = chars !! fromIntegral n
+		swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs
+		swap_pairs _ = []
+		-- Last 2 will always be 00, so omit.
+		trim = take 6

Logs/Location.hs

@@ -0,0 +1,74 @@
+{-# LANGUAGE BangPatterns #-}
+
+{- git-annex location log
+ -
+ - git-annex keeps track of which repositories have the contents of annexed
+ - files.
+ -
+ - Repositories record their UUID and the date when they --get or --drop
+ - a value.
+ - 
+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Logs.Location (
+	LogStatus(..),
+	logChange,
+	readLog,
+	keyLocations,
+	loggedKeys,
+	loggedKeysFor,
+	logFile,
+	logFileKey
+) where
+
+import Common.Annex
+import qualified Annex.Branch
+import Logs.Presence
+import Logs.Trust
+
+{- Log a change in the presence of a key's value in a repository. -}
+logChange :: Key -> UUID -> LogStatus -> Annex ()
+logChange key (UUID u) s = addLog (logFile key) =<< logNow s u
+logChange _ NoUUID _ = return ()
+
+{- Returns a list of repository UUIDs that, according to the log, have
+ - the value of a key.
+ -
+ - Dead repositories are skipped.
+ -}
+keyLocations :: Key -> Annex [UUID]
+keyLocations key = do
+	l <- map toUUID <$> (currentLog . logFile) key
+	snd <$> trustPartition DeadTrusted l
+
+{- Finds all keys that have location log information.
+ - (There may be duplicate keys in the list.) -}
+loggedKeys :: Annex [Key]
+loggedKeys = mapMaybe (logFileKey . takeFileName) <$> Annex.Branch.files
+
+{- Finds all keys that have location log information indicating
+ - they are present for the specified repository. -}
+loggedKeysFor :: UUID -> Annex [Key]
+loggedKeysFor u = filterM isthere =<< loggedKeys
+	where
+		{- This should run strictly to avoid the filterM
+		 - building many thunks containing keyLocations data. -}
+		isthere k = do
+			us <- keyLocations k
+			let !there = u `elem` us
+			return there
+
+{- The filename of the log file for a given key. -}
+logFile :: Key -> String
+logFile key = hashDirLower key ++ keyFile key ++ ".log"
+
+{- Converts a log filename into a key. -}
+logFileKey :: FilePath -> Maybe Key
+logFileKey file
+	| ext == ".log" = fileKey base
+	| otherwise = Nothing
+	where
+		(base, ext) = splitAt (length file - 4) file

Logs/Presence.hs

@@ -0,0 +1,104 @@
+{- git-annex presence log
+ -
+ - This is used to store presence information in the git-annex branch in
+ - a way that can be union merged.
+ -
+ - A line of the log will look like: "date N INFO"
+ - Where N=1 when the INFO is present, and 0 otherwise.
+ - 
+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Logs.Presence (
+	LogStatus(..),
+	addLog,
+	readLog,
+	parseLog,
+	showLog,
+	logNow,
+	compactLog,
+	currentLog,
+	LogLine
+) where
+
+import Data.Time.Clock.POSIX
+import Data.Time
+import System.Locale
+import qualified Data.Map as M
+
+import Common.Annex
+import qualified Annex.Branch
+
+data LogLine = LogLine {
+	date :: POSIXTime,
+	status :: LogStatus,
+	info :: String
+} deriving (Eq)
+
+data LogStatus = InfoPresent | InfoMissing
+	deriving (Eq)
+
+addLog :: FilePath -> LogLine -> Annex ()
+addLog file line = Annex.Branch.change file $ \s -> 
+	showLog $ compactLog (line : parseLog s)
+
+{- Reads a log file.
+ - Note that the LogLines returned may be in any order. -}
+readLog :: FilePath -> Annex [LogLine]
+readLog file = parseLog <$> Annex.Branch.get file
+
+{- Parses a log file. Unparseable lines are ignored. -}
+parseLog :: String -> [LogLine]
+parseLog = mapMaybe (parseline . words) . lines
+	where
+		parseline (a:b:c:_) = do
+			d <- parseTime defaultTimeLocale "%s%Qs" a
+			s <- parsestatus b
+			Just $ LogLine (utcTimeToPOSIXSeconds d) s c
+		parseline _ = Nothing
+		parsestatus "1" = Just InfoPresent
+		parsestatus "0" = Just InfoMissing
+		parsestatus _ = Nothing
+
+{- Generates a log file. -}
+showLog :: [LogLine] -> String
+showLog = unlines . map genline
+	where
+		genline (LogLine d s i) = unwords [show d, genstatus s, i]
+		genstatus InfoPresent = "1"
+		genstatus InfoMissing = "0"
+
+{- Generates a new LogLine with the current date. -}
+logNow :: LogStatus -> String -> Annex LogLine
+logNow s i = do
+	now <- liftIO getPOSIXTime
+	return $ LogLine now s i
+
+{- Reads a log and returns only the info that is still in effect. -}
+currentLog :: FilePath -> Annex [String]
+currentLog file = map info . filterPresent <$> readLog file
+
+{- Returns the info from LogLines that are in effect. -}
+filterPresent :: [LogLine] -> [LogLine]
+filterPresent = filter (\l -> InfoPresent == status l) . compactLog
+
+{- Compacts a set of logs, returning a subset that contains the current
+ - status. -}
+compactLog :: [LogLine] -> [LogLine]
+compactLog = M.elems . foldr mapLog M.empty
+
+type LogMap = M.Map String LogLine
+
+{- Inserts a log into a map of logs, if the log has better (ie, newer)
+ - information than the other logs in the map -}
+mapLog :: LogLine -> LogMap -> LogMap
+mapLog l m = 
+	if better
+		then M.insert i l m
+		else m
+	where
+		better = maybe True newer $ M.lookup i m
+		newer l' = date l' <= date l
+		i = info l

Logs/Remote.hs

@@ -0,0 +1,86 @@
+{- git-annex remote log
+ - 
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - 
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Logs.Remote (
+	readRemoteLog,
+	configSet,
+	keyValToConfig,
+	configToKeyVal,
+
+	prop_idempotent_configEscape
+) where
+
+import qualified Data.Map as M
+import Data.Time.Clock.POSIX
+import Data.Char
+
+import Common.Annex
+import qualified Annex.Branch
+import Types.Remote
+import Logs.UUIDBased
+
+{- Filename of remote.log. -}
+remoteLog :: FilePath
+remoteLog = "remote.log"
+
+{- Adds or updates a remote's config in the log. -}
+configSet :: UUID -> RemoteConfig -> Annex ()
+configSet u c = do
+	ts <- liftIO getPOSIXTime
+	Annex.Branch.change remoteLog $
+		showLog showConfig . changeLog ts u c . parseLog parseConfig
+
+{- Map of remotes by uuid containing key/value config maps. -}
+readRemoteLog :: Annex (M.Map UUID RemoteConfig)
+readRemoteLog = (simpleMap . parseLog parseConfig) <$> Annex.Branch.get remoteLog
+
+parseConfig :: String -> Maybe RemoteConfig
+parseConfig = Just . keyValToConfig . words
+
+showConfig :: RemoteConfig -> String
+showConfig = unwords . configToKeyVal
+
+{- Given Strings like "key=value", generates a RemoteConfig. -}
+keyValToConfig :: [String] -> RemoteConfig
+keyValToConfig ws = M.fromList $ map (/=/) ws
+	where
+		(/=/) s = (k, v)
+			where
+				k = takeWhile (/= '=') s
+				v = configUnEscape $ drop (1 + length k) s
+
+configToKeyVal :: M.Map String String -> [String]
+configToKeyVal m = map toword $ sort $ M.toList m
+	where
+		toword (k, v) = k ++ "=" ++ configEscape v
+
+configEscape :: String -> String
+configEscape = (>>= escape)
+	where
+		escape c
+			| isSpace c || c `elem` "&" = "&" ++ show (ord c) ++ ";"
+			| otherwise = [c]
+
+configUnEscape :: String -> String
+configUnEscape = unescape
+	where
+		unescape [] = []
+		unescape (c:rest)
+			| c == '&' = entity rest
+			| otherwise = c : unescape rest
+		entity s = if ok
+				then chr (Prelude.read num) : unescape rest
+				else '&' : unescape s
+			where
+				num = takeWhile isNumber s
+				r = drop (length num) s
+				rest = drop 1 r
+				ok = not (null num) && take 1 r == ";"
+
+{- for quickcheck -}
+prop_idempotent_configEscape :: String -> Bool
+prop_idempotent_configEscape s = s == (configUnEscape . configEscape) s

Logs/Trust.hs

@@ -0,0 +1,85 @@
+{- git-annex trust
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Logs.Trust (
+	TrustLevel(..),
+	trustGet,
+	trustSet,
+	trustPartition
+) where
+
+import qualified Data.Map as M
+import Data.Time.Clock.POSIX
+
+import Common.Annex
+import Types.TrustLevel
+import qualified Annex.Branch
+import qualified Annex
+import Logs.UUIDBased
+
+{- Filename of trust.log. -}
+trustLog :: FilePath
+trustLog = "trust.log"
+
+{- Returns a list of UUIDs that the trustLog indicates have the
+ - specified trust level.
+ - Note that the list can be incomplete for SemiTrusted, since that's
+ - the default. -}
+trustGet :: TrustLevel -> Annex [UUID]
+trustGet level = M.keys . M.filter (== level) <$> trustMap
+
+{- Partitions a list of UUIDs to those matching a TrustLevel and not. -}
+trustPartition :: TrustLevel -> [UUID] -> Annex ([UUID], [UUID])
+trustPartition level ls
+	| level == SemiTrusted = do
+		t <- trustGet Trusted
+		u <- trustGet UnTrusted
+		d <- trustGet DeadTrusted
+		let uncandidates = t ++ u ++ d
+		return $ partition (`notElem` uncandidates) ls
+	| otherwise = do
+		candidates <- trustGet level
+		return $ partition (`elem` candidates) ls
+
+{- Read the trustLog into a map, overriding with any
+ - values from forcetrust. The map is cached for speed. -}
+trustMap :: Annex TrustMap
+trustMap = do
+	cached <- Annex.getState Annex.trustmap
+	case cached of
+		Just m -> return m
+		Nothing -> do
+			overrides <- M.fromList <$> Annex.getState Annex.forcetrust
+			m <- (M.union overrides . simpleMap . parseLog (Just . parseTrust)) <$>
+				Annex.Branch.get trustLog
+			Annex.changeState $ \s -> s { Annex.trustmap = Just m }
+			return m
+
+{- The trust.log used to only list trusted repos, without a field for the
+ - trust status, which is why this defaults to Trusted. -}
+parseTrust :: String -> TrustLevel
+parseTrust s = maybe Trusted parse $ headMaybe $ words s
+	where
+		parse "1" = Trusted
+		parse "0" = UnTrusted
+		parse "X" = DeadTrusted
+		parse _ = SemiTrusted
+
+showTrust :: TrustLevel -> String
+showTrust Trusted = "1"
+showTrust UnTrusted = "0"
+showTrust DeadTrusted = "X"
+showTrust SemiTrusted = "?"
+
+{- Changes the trust level for a uuid in the trustLog. -}
+trustSet :: UUID -> TrustLevel -> Annex ()
+trustSet uuid@(UUID _) level = do
+	ts <- liftIO getPOSIXTime
+	Annex.Branch.change trustLog $
+		showLog showTrust . changeLog ts uuid level . parseLog (Just . parseTrust)
+	Annex.changeState $ \s -> s { Annex.trustmap = Nothing }
+trustSet NoUUID _ = error "unknown UUID; cannot modify trust level"

Logs/UUID.hs

@@ -0,0 +1,89 @@
+{- 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
+ -
+ - uuid.log stores a list of known uuids, and their descriptions.
+ -
+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Logs.UUID (
+	describeUUID,
+	recordUUID,
+	uuidMap
+) where
+
+import qualified Data.Map as M
+import Data.Time.Clock.POSIX
+
+import Common.Annex
+import qualified Annex.Branch
+import Logs.UUIDBased
+import qualified Annex.UUID
+
+{- Filename of uuid.log. -}
+logfile :: FilePath
+logfile = "uuid.log"
+
+{- Records a description for a uuid in the log. -}
+describeUUID :: UUID -> String -> Annex ()
+describeUUID uuid desc = do
+	ts <- liftIO getPOSIXTime
+	Annex.Branch.change logfile $
+		showLog id . changeLog ts uuid desc . fixBadUUID . parseLog Just
+
+{- Temporarily here to fix badly formatted uuid logs generated by
+ - versions 3.20111105 and 3.20111025. 
+ -
+ - Those logs contain entries with the UUID and description flipped.
+ - Due to parsing, if the description is multiword, only the first
+ - will be taken to be the UUID. So, if the UUID of an entry does
+ - not look like a UUID, and the last word of the description does,
+ - flip them back.
+ -}
+fixBadUUID :: Log String -> Log String
+fixBadUUID = M.fromList . map fixup . M.toList
+	where
+		fixup (k, v)
+			| isbad = (fixeduuid, LogEntry (Date $ newertime v) fixedvalue)
+			| otherwise = (k, v)
+			where
+				kuuid = fromUUID k
+				isbad = not (isuuid kuuid) && isuuid lastword
+				ws = words $ value v
+				lastword = Prelude.last ws
+				fixeduuid = toUUID lastword
+				fixedvalue = unwords $ kuuid: Prelude.init ws
+		-- For the fixed line to take precidence, it should be
+		-- slightly newer, but only slightly.
+		newertime (LogEntry (Date d) _) = d + minimumPOSIXTimeSlice
+		newertime (LogEntry Unknown _) = minimumPOSIXTimeSlice
+		minimumPOSIXTimeSlice = 0.000001
+		isuuid s = length s == 36 && length (split "-" s) == 5
+
+{- Records the uuid in the log, if it's not already there. -}
+recordUUID :: UUID -> Annex ()
+recordUUID u = go . M.lookup u =<< uuidMap 
+	where
+		go (Just "") = set
+		go Nothing = set
+		go _ = return ()
+		set = describeUUID u ""
+
+{- Read the uuidLog into a simple Map.
+ -
+ - The UUID of the current repository is included explicitly, since
+ - it may not have been described and so otherwise would not appear. -}
+uuidMap :: Annex (M.Map UUID String)
+uuidMap = do
+	m <- (simpleMap . parseLog Just) <$> Annex.Branch.get logfile
+	u <- Annex.UUID.getUUID
+	return $ M.insertWith' preferold u "" m
+	where
+		preferold = flip const

Logs/UUIDBased.hs

@@ -0,0 +1,110 @@
+{- git-annex uuid-based logs
+ -
+ - This is used to store information about a UUID in a way that can
+ - be union merged.
+ -
+ - A line of the log will look like: "UUID[ INFO[ timestamp=foo]]"
+ - The timestamp is last for backwards compatability reasons,
+ - and may not be present on old log lines.
+ - 
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Logs.UUIDBased (
+	Log,
+	LogEntry(..),
+	TimeStamp(..),
+	parseLog,
+	showLog,
+	changeLog,
+	addLog,
+	simpleMap,
+
+	prop_TimeStamp_sane,
+	prop_addLog_sane,
+) where
+
+import qualified Data.Map as M
+import Data.Time.Clock.POSIX
+import Data.Time
+import System.Locale
+
+import Common
+import Types.UUID
+
+data TimeStamp = Unknown | Date POSIXTime
+	deriving (Eq, Ord, Show)
+
+data LogEntry a = LogEntry
+	{ changed :: TimeStamp
+	, value :: a
+	} deriving (Eq, Show)
+
+type Log a = M.Map UUID (LogEntry a)
+
+tskey :: String
+tskey = "timestamp="
+
+showLog :: (a -> String) -> Log a -> String
+showLog shower = unlines . map showpair . M.toList
+	where
+		showpair (k, LogEntry (Date p) v) =
+			unwords [fromUUID k, shower v, tskey ++ show p]
+		showpair (k, LogEntry Unknown v) =
+			unwords [fromUUID k, shower v]
+
+parseLog :: (String -> Maybe a) -> String -> Log a
+parseLog parser = M.fromListWith best . mapMaybe parse . lines
+	where
+		parse line
+			| null ws = Nothing
+			| otherwise = parser (unwords info) >>= makepair
+			where
+				makepair v = Just (toUUID u, LogEntry ts v)
+				ws = words line
+				u = Prelude.head ws
+				t = Prelude.last ws
+				ts
+					| tskey `isPrefixOf` t =
+						pdate $ drop 1 $ dropWhile (/= '=') t
+					| otherwise = Unknown
+				info
+					| ts == Unknown = drop 1 ws
+					| otherwise = drop 1 $ beginning ws
+				pdate s = case parseTime defaultTimeLocale "%s%Qs" s of
+					Nothing -> Unknown
+					Just d -> Date $ utcTimeToPOSIXSeconds d
+
+changeLog :: POSIXTime -> UUID -> a -> Log a -> Log a
+changeLog t u v = M.insert u $ LogEntry (Date t) v
+
+{- Only add an LogEntry if it's newer (or at least as new as) than any
+ - existing LogEntry for a UUID. -}
+addLog :: UUID -> LogEntry a -> Log a -> Log a
+addLog = M.insertWith best
+
+{- Converts a Log into a simple Map without the timestamp information.
+ - This is a one-way trip, but useful for code that never needs to change
+ - the log. -}
+simpleMap :: Log a -> M.Map UUID a
+simpleMap = M.map value
+
+best :: LogEntry a -> LogEntry a -> LogEntry a
+best new old
+	| changed old > changed new = old
+	| otherwise = new
+
+-- Unknown is oldest.
+prop_TimeStamp_sane :: Bool
+prop_TimeStamp_sane = Unknown < Date 1
+
+prop_addLog_sane :: Bool
+prop_addLog_sane = newWins && newestWins
+	where
+		newWins = addLog (UUID "foo") (LogEntry (Date 1) "new") l == l2
+		newestWins = addLog (UUID "foo") (LogEntry (Date 1) "newest") l2 /= l2
+
+		l = M.fromList [(UUID "foo", LogEntry (Date 0) "old")]
+		l2 = M.fromList [(UUID "foo", LogEntry (Date 1) "new")]