Merge branch 'master' into watch

.gitignore

@@ -1,12 +1,8 @@
 tmp
-*.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
@@ -15,5 +11,5 @@ html
 *.tix
 .hpc
 Utility/Touch.hs
-Utility/StatFS.hs
+Utility/libdiskfree.o
 dist

Annex.hs

@@ -10,7 +10,6 @@
 module Annex (
 	Annex,
 	AnnexState(..),
-	OutputType(..),
 	new,
 	newState,
 	run,
@@ -19,6 +18,7 @@ module Annex (
 	changeState,
 	setFlag,
 	setField,
+	setOutput,
 	getFlag,
 	getField,
 	addCleanup,
@@ -37,12 +37,14 @@ import qualified Git
 import qualified Git.Config
 import Git.CatFile
 import Git.CheckAttr
+import Git.SharedRepository
 import qualified Git.Queue
 import Types.Backend
 import qualified Types.Remote
 import Types.Crypto
 import Types.BranchState
 import Types.TrustLevel
+import Types.Messages
 import Utility.State
 import qualified Utility.Matcher
 import qualified Data.Map as M
@@ -68,8 +70,6 @@ instance MonadBaseControl IO Annex where
 		where
 			unStAnnex (StAnnex st) = st
 
-data OutputType = NormalOutput | QuietOutput | JSONOutput
-
 type Matcher a = Either [Utility.Matcher.Token a] (Utility.Matcher.Matcher a)
 
 -- internal state storage
@@ -77,7 +77,7 @@ data AnnexState = AnnexState
 	{ repo :: Git.Repo
 	, backends :: [BackendA Annex]
 	, remotes :: [Types.Remote.RemoteA Annex]
-	, output :: OutputType
+	, output :: MessageState
 	, force :: Bool
 	, fast :: Bool
 	, auto :: Bool
@@ -88,9 +88,10 @@ data AnnexState = AnnexState
 	, forcebackend :: Maybe String
 	, forcenumcopies :: Maybe Int
 	, limit :: Matcher (FilePath -> Annex Bool)
+	, shared :: Maybe SharedRepository
 	, forcetrust :: TrustMap
 	, trustmap :: Maybe TrustMap
-	, ciphers :: M.Map EncryptedCipher Cipher
+	, ciphers :: M.Map StorableCipher Cipher
 	, lockpool :: M.Map FilePath Fd
 	, flags :: M.Map String Bool
 	, fields :: M.Map String String
@@ -102,7 +103,7 @@ newState gitrepo = AnnexState
 	{ repo = gitrepo
 	, backends = []
 	, remotes = []
-	, output = NormalOutput
+	, output = defaultMessageState
 	, force = False
 	, fast = False
 	, auto = False
@@ -113,6 +114,7 @@ newState gitrepo = AnnexState
 	, forcebackend = Nothing
 	, forcenumcopies = Nothing
 	, limit = Left []
+	, shared = Nothing
 	, forcetrust = M.empty
 	, trustmap = Nothing
 	, ciphers = M.empty
@@ -122,7 +124,8 @@ newState gitrepo = AnnexState
 	, cleanup = M.empty
 	}
 
-{- Create and returns an Annex state object for the specified git repo. -}
+{- Makes an Annex state object for the specified git repo.
+ - Ensures the config is read, if it was not already. -}
 new :: Git.Repo -> IO AnnexState
 new gitrepo = newState <$> Git.Config.read gitrepo
 
@@ -147,6 +150,11 @@ addCleanup :: String -> Annex () -> Annex ()
 addCleanup uid a = changeState $ \s ->
 	s { cleanup = M.insertWith' const uid a $ cleanup s }
 
+{- Sets the type of output to emit. -}
+setOutput :: OutputType -> Annex ()
+setOutput o = changeState $ \s ->
+	s { output = (output s) { outputType = o } }
+
 {- Checks if a flag was set. -}
 getFlag :: String -> Annex Bool
 getFlag flag = fromMaybe False . M.lookup flag <$> getState flags

Annex/Branch.hs

@@ -36,6 +36,7 @@ import qualified Git.UnionMerge
 import Git.HashObject
 import qualified Git.Index
 import Annex.CatFile
+import Annex.Perms
 
 {- Name of the branch that is used to store git-annex's information. -}
 name :: Git.Ref
@@ -64,9 +65,7 @@ siblingBranches = inRepo $ Git.Ref.matchingUniq name
 
 {- Creates the branch, if it does not already exist. -}
 create :: Annex ()
-create = do
-	_ <- getBranch
-	return ()
+create = void $ getBranch
 
 {- Returns the ref of the branch, creating it first if necessary. -}
 getBranch :: Annex Git.Ref
@@ -308,6 +307,7 @@ setIndexSha :: Git.Ref -> Annex ()
 setIndexSha ref = do
         lock <- fromRepo gitAnnexIndexLock
 	liftIO $ writeFile lock $ show ref ++ "\n"
+	setAnnexPerm lock
 
 {- Checks if there are uncommitted changes in the branch's index or journal. -}
 unCommitted :: Annex Bool
@@ -323,14 +323,14 @@ setUnCommitted = do
 	liftIO $ writeFile file "1"
 
 setCommitted :: Annex ()
-setCommitted = do
+setCommitted = void $ do
 	file <- fromRepo gitAnnexIndexDirty
-	_ <- liftIO $ tryIO $ removeFile file
-	return ()
+	liftIO $ tryIO $ removeFile file
 
 {- Stages the journal into the index. -}
 stageJournal :: Annex ()
 stageJournal = do
+	showStoringStateAction
 	fs <- getJournalFiles
 	g <- gitRepo
 	withIndex $ liftIO $ do

Annex/Content.hs

@@ -23,16 +23,18 @@ module Annex.Content (
 	saveState,
 	downloadUrl,
 	preseedTmp,
+	freezeContent,
+	thawContent,
+	freezeContentDir,
 ) where
 
-import Control.Exception (bracket_)
-import System.Posix.Types
 import System.IO.Unsafe (unsafeInterleaveIO)
 
 import Common.Annex
 import Logs.Location
 import Annex.UUID
 import qualified Git
+import qualified Git.Config
 import qualified Annex
 import qualified Annex.Queue
 import qualified Annex.Branch
@@ -44,6 +46,8 @@ import Utility.DataUnits
 import Utility.CopyFile
 import Config
 import Annex.Exception
+import Git.SharedRepository
+import Annex.Perms
 
 {- Checks if a given key's content is currently present. -}
 inAnnex :: Key -> Annex Bool
@@ -57,8 +61,10 @@ inAnnex' a key = do
 {- 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
+inAnnexSafe = inAnnex' $ \f -> openforlock f >>= check
 	where
+		openforlock f = catchMaybeIO $
+			openFd f ReadOnly Nothing defaultFileFlags
 		check Nothing = return is_missing
 		check (Just h) = do
 			v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)
@@ -75,30 +81,27 @@ inAnnexSafe = inAnnex' $ \f -> openForLock f False >>= check
 lockContent :: Key -> Annex a -> Annex a
 lockContent key a = do
 	file <- inRepo $ gitAnnexLocation key
-	bracketIO (openForLock file True >>= lock) unlock a
+	bracketIO (openforlock file >>= lock) unlock a
 	where
+		{- Since files are stored with the write bit disabled, have
+		 - to fiddle with permissions to open for an exclusive lock. -}
+		openforlock f = catchMaybeIO $ ifM (doesFileExist f)
+			( withModifiedFileMode f
+				(\cur -> cur `unionFileModes` ownerWriteMode)
+				open
+			, open
+			)
+			where
+				open = openFd f ReadWrite Nothing defaultFileFlags
 		lock Nothing = return Nothing
-		lock (Just l) = do
-			v <- tryIO $ setLock l (WriteLock, AbsoluteSeek, 0, 0)
+		lock (Just fd) = do
+			v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
 			case v of
 				Left _ -> error "content is locked"
-				Right _ -> return $ Just l
-		unlock Nothing = return ()
+				Right _ -> return $ Just fd
+		unlock Nothing = noop
 		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
@@ -127,20 +130,20 @@ getViaTmp key action = do
 	-- 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
+	alreadythere <- if e
+		then fromIntegral . fileSize <$> liftIO (getFileStatus tmp)
+		else return 0
+	ifM (checkDiskSpace Nothing key alreadythere)
+		( do
+			when e $ thawContent tmp
+			getViaTmpUnchecked key action
+		, return False
+		)
 
 prepTmp :: Key -> Annex FilePath
 prepTmp key = do
 	tmp <- fromRepo $ gitAnnexTmpLocation key
-	liftIO $ createDirectoryIfMissing True (parentDir tmp)
+	createAnnexDirectory (parentDir tmp)
 	return tmp
 
 {- Like getViaTmp, but does not check that there is enough disk space
@@ -169,22 +172,24 @@ withTmp key action = do
 	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
+ - in a destination (or the annex) printing a warning if not. -}
+checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Annex Bool
+checkDiskSpace destination key alreadythere = do
 	reserve <- getDiskReserve
-	free <- inRepo $ getDiskFree . gitAnnexDir
+	free <- liftIO . getDiskFree =<< dir
+	force <- Annex.getState Annex.force
 	case (free, keySize key) of
-		(Just have, Just need) ->
-			when (need + reserve > have + adjustment) $
-				needmorespace (need + reserve - have - adjustment)
-		_ -> return ()
+		(Just have, Just need) -> do
+			let ok = (need + reserve <= have + alreadythere) || force
+			unless ok $ do
+				liftIO $ print (need, reserve, have, alreadythere)
+				needmorespace (need + reserve - have - alreadythere)
+			return ok
+		_ -> return True
 	where
-		needmorespace n = unlessM (Annex.getState Annex.force) $
-			error $ "not enough free space, need " ++ 
+		dir = maybe (fromRepo gitAnnexDir) return destination
+		needmorespace n =
+			warning $ "not enough free space, need " ++ 
 				roughSize storageUnits True n ++
 				" more" ++ forcemsg
 		forcemsg = " (use --force to override this check or adjust annex.diskreserve)"
@@ -213,15 +218,13 @@ checkDiskSpace' adjustment key = do
 moveAnnex :: Key -> FilePath -> Annex ()
 moveAnnex key src = do
 	dest <- inRepo $ gitAnnexLocation key
-	let dir = parentDir dest
-	liftIO $ ifM (doesFileExist dest)
-		( removeFile src
+	ifM (liftIO $ doesFileExist dest)
+		( liftIO $ removeFile src
 		, do
-			createDirectoryIfMissing True dir
-			allowWrite dir -- in case the directory already exists
-			moveFile src dest
-			preventWrite dest
-			preventWrite dir
+			createContentDir dest
+			liftIO $ moveFile src dest
+			freezeContent dest
+			freezeContentDir dest
 		)
 
 withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a
@@ -235,10 +238,10 @@ cleanObjectLoc key = do
 	file <- inRepo $ gitAnnexLocation key
 	liftIO $ removeparents file (3 :: Int)
 	where
-		removeparents _ 0 = return ()
+		removeparents _ 0 = noop
 		removeparents file n = do
 			let dir = parentDir file
-			maybe (return ()) (const $ removeparents dir (n-1))
+			maybe noop (const $ removeparents dir (n-1))
 				=<< catchMaybeIO (removeDirectory dir)
 
 {- Removes a key's file from .git/annex/objects/ -}
@@ -252,10 +255,9 @@ removeAnnex key = withObjectLoc key $ \(dir, file) -> do
 {- Moves a key's file out of .git/annex/objects/ -}
 fromAnnex :: Key -> FilePath -> Annex ()
 fromAnnex key dest = withObjectLoc key $ \(dir, file) -> do
-	liftIO $ do
-		allowWrite dir
-		allowWrite file
-		moveFile file dest
+	liftIO $ allowWrite dir
+	thawContent file
+	liftIO $ moveFile file dest
 	cleanObjectLoc key
 
 {- Moves a key out of .git/annex/objects/ into .git/annex/bad, and
@@ -265,8 +267,8 @@ moveBad key = do
 	src <- inRepo $ gitAnnexLocation key
 	bad <- fromRepo gitAnnexBadDir
 	let dest = bad </> takeFileName src
+	createAnnexDirectory (parentDir dest)
 	liftIO $ do
-		createDirectoryIfMissing True (parentDir dest)
 		allowWrite (parentDir src)
 		moveFile src dest
 	cleanObjectLoc key
@@ -296,20 +298,21 @@ getKeysPresent = liftIO . traverse (2 :: Int) =<< fromRepo gitAnnexObjectDir
  - especially if performing a short-lived action.
  -}
 saveState :: Bool -> Annex ()
-saveState oneshot = do
-	Annex.Queue.flush False
+saveState oneshot = doSideAction $ do
+	Annex.Queue.flush
 	unless oneshot $
 		ifM alwayscommit
 			( Annex.Branch.commit "update" , Annex.Branch.stage)
 	where
-		alwayscommit = fromMaybe True . Git.configTrue
-			<$> getConfig "annex.alwayscommit" ""
+		alwayscommit = fromMaybe True . Git.Config.isTrue
+			<$> getConfig (annexConfig "alwayscommit") ""
 
 {- Downloads content from any of a list of urls. -}
 downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool
 downloadUrl urls file = do
-	o <- map Param . words <$> getConfig "annex.web-options" ""
-	liftIO $ anyM (\u -> Url.download u o file) urls
+	o <- map Param . words <$> getConfig (annexConfig "web-options") ""
+	headers <- getHttpHeaders
+	liftIO $ anyM (\u -> Url.download u headers o file) urls
 
 {- Copies a key's content, when present, to a temp file.
  - This is used to speed up some rsyncs. -}
@@ -319,7 +322,7 @@ preseedTmp key file = go =<< inAnnex key
 		go False = return False
 		go True = do
 			ok <- copy
-			when ok $ liftIO $ allowWrite file
+			when ok $ thawContent file
 			return ok
 		copy = ifM (liftIO $ doesFileExist file)
 				( return True
@@ -327,3 +330,50 @@ preseedTmp key file = go =<< inAnnex key
 					s <- inRepo $ gitAnnexLocation key
 					liftIO $ copyFileExternal s file
 				)
+
+{- Blocks writing to an annexed file. The file is made unwritable
+ - to avoid accidental edits. core.sharedRepository may change
+ - who can read it. -}
+freezeContent :: FilePath -> Annex ()
+freezeContent file = liftIO . go =<< fromRepo getSharedRepository
+	where
+		go GroupShared = modifyFileMode file $
+			removeModes writeModes .
+			addModes [ownerReadMode, groupReadMode]
+		go AllShared = modifyFileMode file $
+			removeModes writeModes .
+			addModes readModes
+		go _ = preventWrite file
+
+{- Allows writing to an annexed file that freezeContent was called on
+ - before. -}
+thawContent :: FilePath -> Annex ()
+thawContent file = liftIO . go =<< fromRepo getSharedRepository
+	where
+		go GroupShared = groupWriteRead file
+		go AllShared = groupWriteRead file
+		go _ = allowWrite file
+
+{- Blocks writing to the directory an annexed file is in, to prevent the
+ - file accidentially being deleted. However, if core.sharedRepository
+ - is set, this is not done, since the group must be allowed to delete the
+ - file.
+ -}
+freezeContentDir :: FilePath -> Annex ()
+freezeContentDir file = liftIO . go =<< fromRepo getSharedRepository
+	where
+		dir = parentDir file
+		go GroupShared = groupWriteRead dir
+		go AllShared = groupWriteRead dir
+		go _ = preventWrite dir
+
+{- Makes the directory tree to store an annexed file's content,
+ - with appropriate permissions on each level. -}
+createContentDir :: FilePath -> Annex ()
+createContentDir dest = do
+	unlessM (liftIO $ doesDirectoryExist dir) $
+		createAnnexDirectory dir 
+	-- might have already existed with restricted perms
+	liftIO $ allowWrite dir
+	where
+		dir = parentDir dest

Annex/Journal.hs

@@ -16,6 +16,7 @@ import System.IO.Binary
 import Common.Annex
 import Annex.Exception
 import qualified Git
+import Annex.Perms
 
 {- Records content for a file in the branch to the journal.
  -
@@ -23,22 +24,20 @@ import qualified Git
  - 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
+	createAnnexDirectory =<< fromRepo gitAnnexJournalDir
+	createAnnexDirectory =<< fromRepo gitAnnexTmpDir
+	-- journal file is written atomically
+	jfile <- fromRepo $ journalFile file
+	tmp <- fromRepo gitAnnexTmpDir
+	let tmpfile = tmp </> takeFileName jfile
+	liftIO $ do
+		writeBinaryFile tmpfile content
+		moveFile tmpfile jfile
 
 {- Gets any journalled content for a file in the branch. -}
 getJournalFile :: FilePath -> Annex (Maybe String)
 getJournalFile file = inRepo $ \g -> catchMaybeIO $
-	readFileStrict $ journalFile g file
+	readFileStrict $ journalFile file g
 
 {- List of files that have updated content in the journal. -}
 getJournalledFiles :: Annex [FilePath]
@@ -62,8 +61,8 @@ journalDirty = not . null <$> getJournalFiles
  - 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
+journalFile :: FilePath -> Git.Repo -> FilePath
+journalFile file repo = gitAnnexJournalDir repo </> concatMap mangle file
 	where
 		mangle '/' = "_"
 		mangle '_' = "__"
@@ -79,16 +78,12 @@ fileJournal = replace "//" "_" . replace "_" "/"
 lockJournal :: Annex a -> Annex a
 lockJournal a = do
 	file <- fromRepo gitAnnexJournalLock
-	bracketIO (lock file) unlock a
+	createAnnexDirectory $ takeDirectory file
+	mode <- annexFileMode
+	bracketIO (lock file mode) unlock a
 	where
-		lock file = do
-			l <- doRedo (createFile file stdFileMode) $
-				createDirectoryIfMissing True $ takeDirectory file
+		lock file mode = do
+			l <- noUmask mode $ createFile file mode
 			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 = catchIO a $ const $ b >> a

Annex/LockPool.hs

@@ -12,22 +12,24 @@ import System.Posix.Types (Fd)
 
 import Common.Annex
 import Annex
+import Annex.Perms
 
 {- Create a specified lock file, and takes a shared lock. -}
 lockFile :: FilePath -> Annex ()
 lockFile file = go =<< fromPool file
 	where
-		go (Just _) = return () -- already locked
+		go (Just _) = noop -- already locked
 		go Nothing = do
-			fd <- liftIO $ openFd file ReadOnly (Just stdFileMode) defaultFileFlags
+			mode <- annexFileMode
+			fd <- liftIO $ noUmask mode $
+				openFd file ReadOnly (Just mode) defaultFileFlags
 			liftIO $ waitToSetLock fd (ReadLock, AbsoluteSeek, 0, 0)
 			changePool $ M.insert file fd
 
 unlockFile :: FilePath -> Annex ()
-unlockFile file = go =<< fromPool file
+unlockFile file = maybe noop go =<< fromPool file
 	where
-		go Nothing = return ()
-		go (Just fd) = do
+		go fd = do
 			liftIO $ closeFd fd
 			changePool $ M.delete file
 

Annex/Perms.hs

@@ -0,0 +1,70 @@
+{- git-annex file permissions
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Perms (
+	setAnnexPerm,
+	annexFileMode,
+	createAnnexDirectory,
+	noUmask,
+) where
+
+import Common.Annex
+import Utility.FileMode
+import Git.SharedRepository
+import qualified Annex
+
+import System.Posix.Types
+
+withShared :: (SharedRepository -> Annex a) -> Annex a
+withShared a = maybe startup a =<< Annex.getState Annex.shared
+	where
+		startup = do
+			shared <- fromRepo getSharedRepository
+			Annex.changeState $ \s -> s { Annex.shared = Just shared }
+			a shared
+
+{- Sets appropriate file mode for a file or directory in the annex,
+ - other than the content files and content directory. Normally,
+ - use the default mode, but with core.sharedRepository set,
+ - allow the group to write, etc. -}
+setAnnexPerm :: FilePath -> Annex ()
+setAnnexPerm file = withShared $ liftIO . go
+	where
+		go GroupShared = groupWriteRead file
+		go AllShared = modifyFileMode file $ addModes $
+			[ ownerWriteMode, groupWriteMode ] ++ readModes
+		go _ = noop
+
+{- Gets the appropriate mode to use for creating a file in the annex
+ - (other than content files, which are locked down more). -}
+annexFileMode :: Annex FileMode
+annexFileMode = withShared $ return . go
+	where
+		go GroupShared = sharedmode
+		go AllShared = combineModes (sharedmode:readModes)
+		go _ = stdFileMode
+		sharedmode = combineModes
+			[ ownerWriteMode, groupWriteMode
+			, ownerReadMode, groupReadMode
+			]
+
+{- Creates a directory inside the gitAnnexDir, including any parent
+ - directories. Makes directories with appropriate permissions. -}
+createAnnexDirectory :: FilePath -> Annex ()
+createAnnexDirectory dir = traverse dir [] =<< top
+	where
+		top = parentDir <$> fromRepo gitAnnexDir
+		traverse d below stop
+			| d `equalFilePath` stop = done
+			| otherwise = ifM (liftIO $ doesDirectoryExist d)
+				( done
+				, traverse (parentDir d) (d:below) stop
+				)
+			where
+				done = forM_ below $ \p -> do
+					liftIO $ createDirectory p
+					setAnnexPerm p

Annex/Queue.hs

@@ -26,15 +26,14 @@ add command params files = do
 flushWhenFull :: Annex ()
 flushWhenFull = do
 	q <- get
-	when (Git.Queue.full q) $ flush False
+	when (Git.Queue.full q) flush
 
 {- Runs (and empties) the queue. -}
-flush :: Bool -> Annex ()
-flush silent = do
+flush :: Annex ()
+flush = do
 	q <- get
 	unless (0 == Git.Queue.size q) $ do
-		unless silent $
-			showSideAction "Recording state in git"
+		showStoringStateAction
 		q' <- inRepo $ Git.Queue.flush q
 		store q'
 
@@ -47,7 +46,7 @@ new = do
 	store q
 	return q
 	where
-		queuesize = readish <$> getConfig "annex.queuesize" ""
+		queuesize = readish <$> getConfig (annexConfig "queuesize") ""
 
 store :: Git.Queue.Queue -> Annex ()
 store q = changeState $ \s -> s { repoqueue = Just q }

Annex/Ssh.hs

@@ -14,9 +14,10 @@ import qualified Data.Map as M
 
 import Common.Annex
 import Annex.LockPool
-import qualified Git
+import qualified Git.Config
 import Config
 import qualified Build.SysConfig as SysConfig
+import Annex.Perms
 
 {- Generates parameters to ssh to a given host (or user@host) on a given
  - port, with connection caching. -}
@@ -46,8 +47,8 @@ sshInfo (host, port) = ifM caching
 	)
 	where
 		caching = fromMaybe SysConfig.sshconnectioncaching 
-			. Git.configTrue
-			<$> getConfig "annex.sshcaching" ""
+			. Git.Config.isTrue
+			<$> getConfig (annexConfig "sshcaching") ""
 
 cacheParams :: FilePath -> [CommandParam]
 cacheParams socketfile =
@@ -74,30 +75,29 @@ sshCleanup = do
 			-- be stopped.
 			let lockfile = socket2lock socketfile
 			unlockFile lockfile
-			fd <- liftIO $ openFd lockfile ReadWrite (Just stdFileMode) defaultFileFlags
+			mode <- annexFileMode
+			fd <- liftIO $ noUmask mode $
+				openFd lockfile ReadWrite (Just mode) defaultFileFlags
 			v <- liftIO $ tryIO $
 				setLock fd (WriteLock, AbsoluteSeek, 0, 0)
 			case v of
-				Left _ -> return ()
+				Left _ -> noop
 				Right _ -> stopssh socketfile
 			liftIO $ closeFd fd
 		stopssh socketfile = do
 			let (host, port) = socket2hostport socketfile
 			(_, params) <- sshInfo (host, port)
-			_ <- liftIO $ do
+			void $ liftIO $ do
 				-- "ssh -O stop" is noisy on stderr even with -q
 				let cmd = unwords $ toCommand $
 					[ Params "-O stop"
 					] ++ params ++ [Param host]
-				_ <- boolSystem "sh"
+				boolSystem "sh"
 					[ Param "-c"
 					, Param $ "ssh " ++ cmd ++ " >/dev/null 2>/dev/null"
 					]
-				--try $ removeFile socketfile
-				return ()
-			-- Cannot remove the lock file; other processes may
-			-- be waiting on our exclusive lock to use it.
-			return ()
+				-- Cannot remove the lock file; other processes may
+				-- be waiting on our exclusive lock to use it.
 
 hostport2socket :: String -> Maybe Integer -> FilePath
 hostport2socket host Nothing = host

Annex/UUID.hs

@@ -16,7 +16,8 @@ module Annex.UUID (
 	getRepoUUID,
 	getUncachedUUID,
 	prepUUID,
-	genUUID
+	genUUID,
+	removeRepoUUID,
 ) where
 
 import Common.Annex
@@ -25,8 +26,8 @@ import qualified Git.Config
 import qualified Build.SysConfig as SysConfig
 import Config
 
-configkey :: String
-configkey = "annex.uuid"
+configkey :: ConfigKey
+configkey = annexConfig "uuid"
 
 {- Generates a UUID. There is a library for this, but it's not packaged,
  - so use the command line tool. -}
@@ -61,13 +62,18 @@ getRepoUUID r = do
 			when (g /= r) $ storeUUID cachekey u
 		cachekey = remoteConfig r "uuid"
 
+removeRepoUUID :: Annex ()
+removeRepoUUID = unsetConfig configkey
+
 getUncachedUUID :: Git.Repo -> UUID
-getUncachedUUID = toUUID . Git.Config.get configkey ""
+getUncachedUUID = toUUID . Git.Config.get key ""
+	where
+		(ConfigKey key) = configkey
 
 {- Make sure that the repo has an annex.uuid setting. -}
 prepUUID :: Annex ()
 prepUUID = whenM ((==) NoUUID <$> getUUID) $
 	storeUUID configkey =<< liftIO genUUID
 
-storeUUID :: String -> UUID -> Annex ()
+storeUUID :: ConfigKey -> UUID -> Annex ()
 storeUUID configfield = setConfig configfield . fromUUID

Annex/Version.hs

@@ -21,8 +21,8 @@ supportedVersions = [defaultVersion]
 upgradableVersions :: [Version]
 upgradableVersions = ["0", "1", "2"]
 
-versionField :: String
-versionField = "annex.version"
+versionField :: ConfigKey
+versionField = annexConfig "version"
 
 getVersion :: Annex (Maybe Version)
 getVersion = handle <$> getConfig versionField ""
@@ -35,7 +35,7 @@ setVersion = setConfig versionField defaultVersion
 
 checkVersion :: Version -> Annex ()
 checkVersion v
-	| v `elem` supportedVersions = return ()
+	| v `elem` supportedVersions = noop
 	| v `elem` upgradableVersions = err "Upgrade this repository: git-annex upgrade"
 	| otherwise = err "Upgrade git-annex."
 	where

Backend.hs

@@ -46,7 +46,7 @@ orderedList = do
 			l' <- (lookupBackendName name :) <$> standard
 			Annex.changeState $ \s -> s { Annex.backends = l' }
 			return l'
-		standard = parseBackendList <$> getConfig "annex.backends" ""
+		standard = parseBackendList <$> getConfig (annexConfig "backends") ""
 		parseBackendList [] = list
 		parseBackendList s = map lookupBackendName $ words s
 
@@ -75,16 +75,16 @@ genKey' (b:bs) file = do
  - by examining what the file symlinks to. -}
 lookupFile :: FilePath -> Annex (Maybe (Key, Backend))
 lookupFile file = do
-	tl <- liftIO $ tryIO getsymlink
+	tl <- liftIO $ tryIO $ readSymbolicLink file
 	case tl of
 		Left _ -> return Nothing
 		Right l -> makekey l
 	where
-		getsymlink = takeFileName <$> readSymbolicLink file
-		makekey l = maybe (return Nothing) (makeret l) (fileKey l)
+		makekey l = maybe (return Nothing) (makeret l) (fileKey $ takeFileName l)
 		makeret l k = let bname = keyBackendName k in
 			case maybeLookupBackendName bname of
-				Just backend -> return $ Just (k, backend)
+				Just backend -> do
+					return $ Just (k, backend)
 				Nothing -> do
 					when (isLinkToAnnex l) $ warning $
 						"skipping " ++ file ++

Backend/SHA.hs

@@ -45,7 +45,7 @@ genBackendE size =
 
 shaCommand :: SHASize -> Maybe String
 shaCommand 1 = SysConfig.sha1
-shaCommand 256 = SysConfig.sha256
+shaCommand 256 = Just SysConfig.sha256
 shaCommand 224 = SysConfig.sha224
 shaCommand 384 = SysConfig.sha384
 shaCommand 512 = SysConfig.sha512

Build/Configure.hs

@@ -6,6 +6,7 @@ import System.Directory
 import Data.List
 import System.Cmd.Utils
 import Control.Applicative
+import System.FilePath
 
 import Build.TestConfig
 import Utility.SafeCommand
@@ -26,15 +27,21 @@ tests =
 	, TestCase "bup" $ testCmd "bup" "bup --version >/dev/null"
 	, TestCase "gpg" $ testCmd "gpg" "gpg --version >/dev/null"
 	, TestCase "ssh connection caching" getSshConnectionCaching
-	] ++ shaTestCases [1, 256, 512, 224, 384]
+	] ++ shaTestCases False [1, 512, 224, 384] ++ shaTestCases True [256]
 
-shaTestCases :: [Int] -> [TestCase]
-shaTestCases l = map make l
-	where make n =
-		let
-			cmds = map (\x -> "sha" ++ show n ++ x) ["", "sum"]
-			key = "sha" ++ show n
-		in TestCase key $ maybeSelectCmd key cmds "</dev/null"
+shaTestCases :: Bool -> [Int] -> [TestCase]
+shaTestCases required l = map make l
+	where
+		make n = TestCase key $ selector key (shacmds n) "</dev/null"
+			where
+				key = "sha" ++ show n
+		selector = if required then selectCmd else maybeSelectCmd
+		shacmds n = concatMap (\x -> [x, osxpath </> x]) $
+			map (\x -> "sha" ++ show n ++ x) ["", "sum"]
+		-- Max OSX puts GNU tools outside PATH, so look in
+		-- the location it uses, and remember where to run them
+		-- from.
+		osxpath = "/opt/local/libexec/gnubin"
 
 tmpDir :: String
 tmpDir = "tmp"

CmdLine.hs

@@ -46,19 +46,19 @@ dispatch fuzzyok allargs allcmds commonoptions header getgitrepo = do
 	where
 		err msg = msg ++ "\n\n" ++ usage header allcmds commonoptions
 		cmd = Prelude.head cmds
-		(cmds, name, args) = findCmd fuzzyok allargs allcmds err
+		(fuzzy, cmds, name, args) = findCmd fuzzyok allargs allcmds err
 		(flags, params) = getOptCmd args cmd commonoptions err
-		checkfuzzy = when (length cmds > 1) $
+		checkfuzzy = when fuzzy $
 			inRepo $ Git.AutoCorrect.prepare name cmdname cmds
 
 {- Parses command line params far enough to find the Command to run, and
  - returns the remaining params.
  - Does fuzzy matching if necessary, which may result in multiple Commands. -}
-findCmd :: Bool -> Params -> [Command] -> (String -> String) -> ([Command], String, Params)
+findCmd :: Bool -> Params -> [Command] -> (String -> String) -> (Bool, [Command], String, Params)
 findCmd fuzzyok argv cmds err
 	| isNothing name = error $ err "missing command"
-	| not (null exactcmds) = (exactcmds, fromJust name, args)
-	| fuzzyok && not (null inexactcmds) = (inexactcmds, fromJust name, args)
+	| not (null exactcmds) = (False, exactcmds, fromJust name, args)
+	| fuzzyok && not (null inexactcmds) = (True, inexactcmds, fromJust name, args)
 	| otherwise = error $ err $ "unknown command " ++ fromJust name
 	where
 		(name, args) = findname argv []
@@ -88,7 +88,7 @@ tryRun = tryRun' 0
 tryRun' :: Integer -> Annex.AnnexState -> Command -> [CommandCleanup] -> IO ()
 tryRun' errnum _ cmd []
 	| errnum > 0 = error $ cmdname cmd ++ ": " ++ show errnum ++ " failed"
-	| otherwise = return ()
+	| otherwise = noop
 tryRun' errnum state cmd (a:as) = do
 	r <- run
 	handle $! r

Command/AddUnused.hs

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

Command/AddUrl.hs

@@ -20,6 +20,7 @@ import Annex.Content
 import Logs.Web
 import qualified Option
 import Types.Key
+import Config
 
 def :: [Command]
 def = [withOptions [fileOption, pathdepthOption] $
@@ -53,8 +54,9 @@ perform url file = ifAnnexed file addurl geturl
 			liftIO $ createDirectoryIfMissing True (parentDir file)
 			ifM (Annex.getState Annex.fast)
 				( nodownload url file , download url file )
-		addurl (key, _backend) =
-			ifM (liftIO $ Url.check url $ keySize key)
+		addurl (key, _backend) = do
+			headers <- getHttpHeaders
+			ifM (liftIO $ Url.check url headers $ keySize key)
 				( do
 					setUrlPresent key url
 					next $ return True
@@ -81,7 +83,8 @@ download url file = do
 
 nodownload :: String -> FilePath -> CommandPerform
 nodownload url file = do
-	(exists, size) <- liftIO $ Url.exists url
+	headers <- getHttpHeaders
+	(exists, size) <- liftIO $ Url.exists url headers
 	if exists
 		then do
 			let key = Backend.URL.fromUrl url size

Command/DropUnused.hs

@@ -1,14 +1,13 @@
 {- git-annex command
  -
- - Copyright 2010 Joey Hess <joey@kitenet.net>
+ - Copyright 2010,2012 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 Logs.Unused
 import Common.Annex
 import Command
 import qualified Annex
@@ -16,40 +15,17 @@ import qualified Command.Drop
 import qualified Remote
 import qualified Git
 import qualified Option
-import Types.Key
-
-type UnusedMap = M.Map String Key
 
 def :: [Command]
 def = [withOptions [Command.Drop.fromOption] $
-	command "dropunused" (paramRepeating paramNumber)
+	command "dropunused" (paramRepeating paramNumRange)
 		seek "drop unused file content"]
 
 seek :: [CommandSeek]
-seek = [withUnusedMaps]
+seek = [withUnusedMaps start]
 
-{- 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
+start :: UnusedMaps -> Int -> CommandStart
+start = startUnused "dropunused" perform (performOther gitAnnexBadLocation) (performOther gitAnnexTmpLocation)
 
 perform :: Key -> CommandPerform
 perform key = maybe droplocal dropremote =<< Remote.byName =<< from
@@ -66,15 +42,3 @@ 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/Fsck.hs

@@ -85,7 +85,7 @@ performRemote key file backend numcopies remote =
 			t <- fromRepo gitAnnexTmpDir
 			let tmp = t </> "fsck" ++ show pid ++ "." ++ keyFile key
 			liftIO $ createDirectoryIfMissing True t
-			let cleanup = liftIO $ catchIO (removeFile tmp) (const $ return ())
+			let cleanup = liftIO $ catchIO (removeFile tmp) (const noop)
 			cleanup
 			cleanup `after` a tmp
 		getfile tmp =
@@ -166,10 +166,9 @@ verifyLocationLog key desc = do
 	-- 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)
+		file <- inRepo $ gitAnnexLocation key
+		freezeContent file
+		freezeContentDir file
 
 	u <- getUUID
 	verifyLocationLog' key desc present u (logChange key u)

Command/Import.hs

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

Command/Lock.hs

@@ -24,9 +24,5 @@ start file = do
 
 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]
+	Annex.Queue.add "checkout" [Param "--"] [file]
 	next $ return True -- no cleanup needed

Command/Log.hs

@@ -133,7 +133,7 @@ compareChanges format changes = concatMap diff $ zip changes (drop 1 changes)
  - *lot* for newish files. -}
 getLog :: Key -> [CommandParam] -> Annex [String]
 getLog key os = do
-	top <- fromRepo Git.workTree
+	top <- fromRepo Git.repoPath
 	p <- liftIO $ relPathCwdToFile top
 	let logfile = p </> Logs.Location.logFile key
 	inRepo $ pipeNullSplit $

Command/Map.hs

@@ -156,14 +156,14 @@ absRepo :: Git.Repo -> Git.Repo -> Annex Git.Repo
 absRepo reference r
 	| Git.repoIsUrl reference = return $ Git.Construct.localToUrl reference r
 	| Git.repoIsUrl r = return r
-	| otherwise = liftIO $ Git.Construct.fromAbsPath =<< absPath (Git.workTree r)
+	| otherwise = liftIO $ Git.Construct.fromAbsPath =<< absPath (Git.repoPath r)
 
 {- Checks if two repos are the same. -}
 same :: Git.Repo -> Git.Repo -> Bool
 same a b
-	| both Git.repoIsSsh = matching Git.Url.authority && matching Git.workTree
+	| both Git.repoIsSsh = matching Git.Url.authority && matching Git.repoPath
 	| both Git.repoIsUrl && neither Git.repoIsSsh = matching show
-	| neither Git.repoIsSsh = matching Git.workTree
+	| neither Git.repoIsSsh = matching Git.repoPath
 	| otherwise = False
 		
 	where
@@ -210,7 +210,7 @@ tryScan r
 			where
 				sshcmd = cddir ++ " && " ++
 					"git config --null --list"
-				dir = Git.workTree r
+				dir = Git.repoPath r
 				cddir
 					| "/~" `isPrefixOf` dir =
 						let (userhome, reldir) = span (/= '/') (drop 1 dir)

Command/Status.hs

@@ -30,6 +30,7 @@ import Logs.UUID
 import Logs.Trust
 import Remote
 import Config
+import Utility.Percentage
 
 -- a named computation that produces a statistic
 type Stat = StatState (Maybe (String, StatState String))
@@ -69,6 +70,7 @@ fast_stats =
 	, remote_list SemiTrusted "semitrusted"
 	, remote_list UnTrusted "untrusted"
 	, remote_list DeadTrusted "dead"
+	, disk_size
 	]
 slow_stats :: [Stat]
 slow_stats = 
@@ -78,7 +80,6 @@ slow_stats =
 	, local_annex_size
 	, known_annex_keys
 	, known_annex_size
-	, disk_size
 	, bloom_info
 	, backend_usage
 	]
@@ -108,12 +109,11 @@ nojson :: StatState String -> String -> StatState String
 nojson a _ = a
 
 showStat :: Stat -> StatState ()
-showStat s = calc =<< s
+showStat s = maybe noop calc =<< s
 	where
-		calc (Just (desc, a)) = do
+		calc (desc, a) = do
 			(lift . showHeader) desc
 			lift . showRaw =<< a
-		calc Nothing = return ()
 
 supported_backends :: Stat
 supported_backends = stat "supported backends" $ json unwords $
@@ -161,7 +161,7 @@ bloom_info = stat "bloom filter size" $ json id $ do
 	let note = aside $
 		if localkeys >= capacity
 		then "appears too small for this repository; adjust annex.bloomcapacity"
-		else "has room for " ++ show (capacity - localkeys) ++ " more local annex keys"
+		else showPercentage 1 (percentage capacity localkeys) ++ " full"
 
 	-- Two bloom filters are used at the same time, so double the size
 	-- of one.
@@ -176,8 +176,12 @@ disk_size = stat "available local disk space" $ json id $ lift $
 		<$> getDiskReserve
 		<*> inRepo (getDiskFree . gitAnnexDir)
 	where
-		calcfree reserve (Just have) =
-			roughSize storageUnits False $ nonneg $ have - reserve
+		calcfree reserve (Just have) = unwords
+			[ roughSize storageUnits False $ nonneg $ have - reserve
+			, "(+" ++ roughSize storageUnits False reserve
+			, "reserved)"
+			]
+			
 		calcfree _ _ = "unknown"
 		nonneg x
 			| x >= 0 = x

Command/Sync.hs

@@ -57,10 +57,17 @@ syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted )
 		wanted
 			| null rs = good =<< concat . byspeed <$> available
 			| otherwise = listed
-		listed = catMaybes <$> mapM (Remote.byName . Just) rs
+		listed = do
+			l <- catMaybes <$> mapM (Remote.byName . Just) rs
+			let s = filter special l
+			unless (null s) $
+				error $ "cannot sync special remotes: " ++
+					unwords (map Types.Remote.name s)
+			return l
 		available = filter nonspecial <$> Remote.enabledRemoteList
 		good = filterM $ Remote.Git.repoAvail . Types.Remote.repo
 		nonspecial r = Types.Remote.remotetype r == Remote.Git.remote
+		special = not . nonspecial
 		fastest = fromMaybe [] . headMaybe . byspeed
 		byspeed = map snd . sort . M.toList . costmap
 		costmap = M.fromListWith (++) . map costpair

Command/Unannex.hs

@@ -10,7 +10,6 @@ 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
@@ -51,9 +50,8 @@ cleanup file key = do
 		( do
 			-- fast mode: hard link to content in annex
 			src <- inRepo $ gitAnnexLocation key
-			liftIO $ do
-				createLink src file
-				allowWrite file
+			liftIO $ createLink src file
+			thawContent file
 		, do
 			fromAnnex key file
 			logStatus key InfoMissing

Command/Unlock.hs

@@ -11,7 +11,6 @@ import Common.Annex
 import Command
 import Annex.Content
 import Utility.CopyFile
-import Utility.FileMode
 
 def :: [Command]
 def =
@@ -34,8 +33,7 @@ start file (key, _) = do
 perform :: FilePath -> Key -> CommandPerform
 perform dest key = do
 	unlessM (inAnnex key) $ error "content not present"
-	
-	checkDiskSpace key
+	unlessM (checkDiskSpace Nothing key 0) $ error "cannot unlock"
 
 	src <- inRepo $ gitAnnexLocation key
 	tmpdest <- fromRepo $ gitAnnexTmpLocation key
@@ -47,6 +45,6 @@ perform dest key = do
 			liftIO $ do
 				removeFile dest
 				moveFile tmpdest dest
-				allowWrite dest
+			thawContent dest
 			next $ return True
                 else error "copy failed!"

Command/Unused.hs

@@ -19,9 +19,9 @@ import Control.Monad.ST
 
 import Common.Annex
 import Command
+import Logs.Unused
 import Annex.Content
 import Utility.FileMode
-import Utility.TempFile
 import Logs.Location
 import Config
 import qualified Annex
@@ -91,19 +91,13 @@ check file msg a c = do
 	l <- a
 	let unusedlist = number c l
 	unless (null l) $ showLongNote $ msg unusedlist
-	writeUnusedFile file unusedlist
+	writeUnusedLog file unusedlist
 	return $ c + length l
 
 number :: Int -> [a] -> [(Int, a)]
 number _ [] = []
 number n (x:xs) = (n+1, x) : number (n+1) xs
 
-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
@@ -189,10 +183,10 @@ exclude smaller larger = S.toList $ remove larger $ S.fromList smaller
  -}
 bloomCapacity :: Annex Int
 bloomCapacity = fromMaybe 500000 . readish
-	<$> getConfig "annex.bloomcapacity" ""
+	<$> getConfig (annexConfig "bloomcapacity") ""
 bloomAccuracy :: Annex Int
 bloomAccuracy = fromMaybe 1000 . readish
-	<$> getConfig "annex.bloomaccuracy" ""
+	<$> getConfig (annexConfig "bloomaccuracy") ""
 bloomBitsHashes :: Annex (Int, Int)
 bloomBitsHashes = do
 	capacity <- bloomCapacity
@@ -237,7 +231,7 @@ withKeysReferenced' :: v -> (Key -> v -> Annex v) -> Annex v
 withKeysReferenced' initial a = go initial =<< files
 	where
 		files = do
-			top <- fromRepo Git.workTree
+			top <- fromRepo Git.repoPath
 			inRepo $ LsFiles.inRepo [top]
 		go v [] = return v
 		go v (f:fs) = do
@@ -268,7 +262,7 @@ withKeysReferencedInGitRef a ref = do
 	showAction $ "checking " ++ Git.Ref.describe ref
 	go =<< inRepo (LsTree.lsTree ref)
 	where
-		go [] = return ()
+		go [] = noop
 		go (l:ls)
 			| isSymLink (LsTree.mode l) = do
 				content <- L.decodeUtf8 <$> catFile ref (LsTree.file l)

Command/Whereis.hs

@@ -46,9 +46,9 @@ perform remotemap key = do
 		untrustedheader = "The following untrusted locations may also have copies:\n"
 
 performRemote :: Key -> Remote -> Annex () 
-performRemote key remote = case whereisKey remote of
-	Nothing -> return ()
-	Just a -> do
-		ls <- a key
-		unless (null ls) $ showLongNote $
-			unlines $ map (\l -> name remote ++ ": " ++ l) ls
+performRemote key remote = maybe noop go $ whereisKey remote
+	where
+		go a = do
+			ls <- a key
+			unless (null ls) $ showLongNote $ unlines $
+				map (\l -> name remote ++ ": " ++ l) ls

Config.hs

@@ -1,6 +1,6 @@
 {- Git configuration
  -
- - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -14,29 +14,39 @@ import qualified Git.Command
 import qualified Annex
 import Utility.DataUnits
 
-type ConfigKey = String
+type UnqualifiedConfigKey = String
+data ConfigKey = 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
+setConfig (ConfigKey key) value = do
+	inRepo $ Git.Command.run "config" [Param key, Param value]
+	newg <- inRepo Git.Config.reRead
 	Annex.changeState $ \s -> s { Annex.repo = newg }
 
-{- Looks up a git config setting in git config. -}
+{- Unsets a git config setting. (Leaves it in state currently.) -}
+unsetConfig :: ConfigKey -> Annex ()
+unsetConfig (ConfigKey key) = inRepo $ Git.Command.run "config"
+        [Param "--unset", Param key]
+
+{- Looks up a setting in git config. -}
 getConfig :: ConfigKey -> String -> Annex String
-getConfig key def = fromRepo $ Git.Config.get key def
+getConfig (ConfigKey key) def = fromRepo $ Git.Config.get key def
 
 {- Looks up a per-remote config setting in git config.
  - Failing that, tries looking for a global config option. -}
-getRemoteConfig :: Git.Repo -> ConfigKey -> String -> Annex String
-getRemoteConfig r key def =
-	getConfig (remoteConfig r key) =<< getConfig key def
+getRemoteConfig :: Git.Repo -> UnqualifiedConfigKey -> String -> Annex String
+getRemoteConfig r key def = 
+	getConfig (remoteConfig r key) =<< getConfig (annexConfig key) def
 
 {- A per-remote config setting in git config. -}
-remoteConfig :: Git.Repo -> ConfigKey -> String
-remoteConfig r key = "remote." ++ fromMaybe "" (Git.remoteName r) ++ ".annex-" ++ key
+remoteConfig :: Git.Repo -> UnqualifiedConfigKey -> ConfigKey
+remoteConfig r key = ConfigKey $
+	"remote." ++ fromMaybe "" (Git.remoteName r) ++ ".annex-" ++ key
+
+{- A global annex setting in git config. -}
+annexConfig :: UnqualifiedConfigKey -> ConfigKey
+annexConfig key = ConfigKey $ "annex." ++ key
 
 {- Calculates cost for a remote. Either the default, or as configured 
  - by remote.<name>.annex-cost, or if remote.<name>.annex-cost-command
@@ -73,7 +83,7 @@ prop_cost_sane = False `notElem`
 
 {- Checks if a repo should be ignored. -}
 repoNotIgnored :: Git.Repo -> Annex Bool
-repoNotIgnored r = not . fromMaybe False . Git.configTrue
+repoNotIgnored r = not . fromMaybe False . Git.Config.isTrue
 	<$> getRemoteConfig r "ignore" ""
 
 {- If a value is specified, it is used; otherwise the default is looked up
@@ -83,16 +93,27 @@ getNumCopies v = perhaps (use v) =<< Annex.getState Annex.forcenumcopies
 	where
 		use (Just n) = return n
 		use Nothing = perhaps (return 1) =<< 
-			readish <$> getConfig "annex.numcopies" "1"
+			readish <$> getConfig (annexConfig "numcopies") "1"
 		perhaps fallback = maybe fallback (return . id)
 
 {- Gets the trust level set for a remote in git config. -}
 getTrustLevel :: Git.Repo -> Annex (Maybe String)
-getTrustLevel r = fromRepo $ Git.Config.getMaybe $ remoteConfig r "trustlevel"
+getTrustLevel r = fromRepo $ Git.Config.getMaybe key
+	where
+		(ConfigKey key) = remoteConfig r "trustlevel"
 
 {- Gets annex.diskreserve setting. -}
 getDiskReserve :: Annex Integer
 getDiskReserve = fromMaybe megabyte . readSize dataUnits
-	<$> getConfig "diskreserve" ""
+	<$> getConfig (annexConfig "diskreserve") ""
 	where
 		megabyte = 1000000
+
+{- Gets annex.httpheaders or annex.httpheaders-command setting,
+ - splitting it into lines. -}
+getHttpHeaders :: Annex [String]
+getHttpHeaders = do
+	cmd <- getConfig (annexConfig "http-headers-command") ""
+	if (null cmd)
+		then fromRepo $ Git.Config.getList "annex.http-headers"
+		else lines . snd <$> liftIO (pipeFrom "sh" ["-c", cmd])

Crypto.hs

@@ -3,19 +3,19 @@
  - Currently using gpg; could later be modified to support different
  - crypto backends if neccessary.
  -
- - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
 module Crypto (
 	Cipher,
-	EncryptedCipher,
-	genCipher,
-	updateCipher,
+	KeyIds(..),
+	StorableCipher(..),
+	genEncryptedCipher,
+	genSharedCipher,
+	updateEncryptedCipher,
 	describeCipher,
-	storeCipher,
-	extractCipher,
 	decryptCipher,		
 	encryptKey,
 	withEncryptedHandle,
@@ -27,7 +27,6 @@ module Crypto (
 ) 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
@@ -35,8 +34,6 @@ 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
@@ -60,59 +57,37 @@ 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
+{- Creates a new Cipher, encrypted to the specificed key id. -}
+genEncryptedCipher :: String -> IO StorableCipher
+genEncryptedCipher keyid = do
+	ks <- Gpg.findPubKeys keyid
+	random <- Gpg.genRandom cipherSize
 	encryptCipher (Cipher random) ks
-	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
+{- Creates a new, shared Cipher. -}
+genSharedCipher :: IO StorableCipher
+genSharedCipher = SharedCipher <$> Gpg.genRandom cipherSize
+
+{- Updates an existing Cipher, re-encrypting it to add a keyid. -}
+updateEncryptedCipher :: String -> StorableCipher -> IO StorableCipher
+updateEncryptedCipher _ (SharedCipher _) = undefined
+updateEncryptedCipher keyid encipher@(EncryptedCipher _ ks) = do
+	ks' <- Gpg.findPubKeys keyid
+	cipher <- decryptCipher encipher
 	encryptCipher cipher (merge ks ks')
 	where
 		merge (KeyIds a) (KeyIds b) = KeyIds $ a ++ b
 
-describeCipher :: EncryptedCipher -> String
+describeCipher :: StorableCipher -> String
+describeCipher (SharedCipher _) = "shared cipher"
 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 -> KeyIds -> IO StorableCipher
 encryptCipher (Cipher c) (KeyIds ks) = do
 	let ks' = nub $ sort ks -- gpg complains about duplicate recipient keyids
 	encipher <- Gpg.pipeStrict (encrypt++recipients ks') c
@@ -126,9 +101,9 @@ encryptCipher (Cipher c) (KeyIds ks) = do
 		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
+decryptCipher :: StorableCipher -> IO Cipher
+decryptCipher (SharedCipher t) = return $ Cipher t
+decryptCipher (EncryptedCipher t _) = Cipher <$> Gpg.pipeStrict decrypt t
 	where
 		decrypt = [ Param "--decrypt" ]
 
@@ -163,15 +138,7 @@ 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"
+pass to n s a = to n s $ \h -> a =<< L.hGetContents h
 
 hmacWithCipher :: Cipher -> String -> String
 hmacWithCipher c = hmacWithCipher' (cipherHmac c) 

Git.hs

@@ -3,7 +3,7 @@
  - 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>
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -17,19 +17,17 @@ module Git (
 	repoIsUrl,
 	repoIsSsh,
 	repoIsHttp,
+	repoIsLocal,
 	repoIsLocalBare,
 	repoDescribe,
 	repoLocation,
-	workTree,
-	gitDir,
-	configTrue,
+	repoPath,
+	localGitDir,
 	attributes,
 	hookPath,
 	assertLocal,
 ) where
 
-import qualified Data.Map as M
-import Data.Char
 import Network.URI (uriPath, uriScheme, unEscapeString)
 import System.Posix.Files
 
@@ -41,15 +39,34 @@ import Utility.FileMode
 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 = Local { worktree = Just dir } } = dir
+repoDescribe Repo { location = Local { gitdir = dir } } = dir
+repoDescribe Repo { location = LocalUnknown dir } = dir
 repoDescribe Repo { location = Unknown } = "UNKNOWN"
 
 {- Location of the repo, either as a path or url. -}
 repoLocation :: Repo -> String
 repoLocation Repo { location = Url url } = show url
-repoLocation Repo { location = Dir dir } = dir
+repoLocation Repo { location = Local { worktree = Just dir } } = dir
+repoLocation Repo { location = Local { gitdir = dir } } = dir
+repoLocation Repo { location = LocalUnknown dir } = dir
 repoLocation Repo { location = Unknown } = undefined
 
+{- Path to a repository. For non-bare, this is the worktree, for bare, 
+ - it's the gitdir, and for URL repositories, is the path on the remote
+ - host. -}
+repoPath :: Repo -> FilePath
+repoPath Repo { location = Url u } = unEscapeString $ uriPath u
+repoPath Repo { location = Local { worktree = Just d } } = d
+repoPath Repo { location = Local { gitdir = d } } = d
+repoPath Repo { location = LocalUnknown dir } = dir
+repoPath Repo { location = Unknown } = undefined
+
+{- Path to a local repository's .git directory. -}
+localGitDir :: Repo -> FilePath
+localGitDir Repo { location = Local { gitdir = d } } = d
+localGitDir _ = undefined
+
 {- Some code needs to vary between URL and normal repos,
  - or bare and non-bare, these functions help with that. -}
 repoIsUrl :: Repo -> Bool
@@ -74,11 +91,12 @@ repoIsHttp Repo { location = Url url }
 	| otherwise = False
 repoIsHttp _ = False
 
-configAvail ::Repo -> Bool
-configAvail Repo { config = c } = c /= M.empty
+repoIsLocal :: Repo -> Bool
+repoIsLocal Repo { location = Local { } } = True
+repoIsLocal _ = False
 
 repoIsLocalBare :: Repo -> Bool
-repoIsLocalBare r@(Repo { location = Dir _ }) = configAvail r && configBare r
+repoIsLocalBare Repo { location = Local { worktree = Nothing } } = True
 repoIsLocalBare _ = False
 
 assertLocal :: Repo -> a -> a
@@ -90,49 +108,18 @@ assertLocal repo action
 		]
 	| otherwise = action
 
-configBare :: Repo -> Bool
-configBare repo = maybe unknown (fromMaybe False . 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 -> FilePath
 attributes repo
-	| configBare repo = workTree repo ++ "/info/.gitattributes"
-	| otherwise = workTree repo ++ "/.gitattributes"
-
-{- Path to a repository's .git directory. -}
-gitDir :: Repo -> FilePath
-gitDir repo
-	| configBare repo = workTree repo
-	| otherwise = workTree repo </> ".git"
+	| repoIsLocalBare repo = repoPath repo ++ "/info/.gitattributes"
+	| otherwise = repoPath repo ++ "/.gitattributes"
 
 {- Path to a given hook script in a repository, only if the hook exists
  - and is executable. -}
 hookPath :: String -> Repo -> IO (Maybe FilePath)
 hookPath script repo = do
-	let hook = gitDir repo </> "hooks" </> script
+	let hook = localGitDir repo </> "hooks" </> script
 	ifM (catchBoolIO $ isexecutable hook)
 		( return $ Just hook , return Nothing )
 	where
 		isexecutable f = isExecutable . fileMode <$> getFileStatus f
-
-{- 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 } = unEscapeString $ 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 -> Maybe Bool
-configTrue s
-	| s' == "true" = Just True
-	| s' == "false" = Just False
-	| otherwise = Nothing
-	where
-		s' = map toLower s

Git/AutoCorrect.hs

@@ -34,7 +34,7 @@ fuzzymatches :: String -> (c -> String) -> [c] -> [c]
 fuzzymatches input showchoice choices = fst $ unzip $
 	sortBy comparecost $ filter similarEnough $ zip choices costs
         where
-                distance v = restrictedDamerauLevenshteinDistance gitEditCosts v input
+                distance = restrictedDamerauLevenshteinDistance gitEditCosts input
                 costs = map (distance . showchoice) choices
                 comparecost a b = compare (snd a) (snd b)
                 similarEnough (_, cst) = cst < similarityFloor

Git/Command.hs

@@ -1,6 +1,6 @@
 {- running git commands
  -
- - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -18,11 +18,12 @@ 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 params Repo { location = l@(Local _ _ ) } = setdir : settree ++ params
+	where
+		setdir = Param $ "--git-dir=" ++ gitdir l
+		settree = case worktree l of
+			Nothing -> []
+			Just t -> [Param $ "--work-tree=" ++ t]
 gitCommandLine _ repo = assertLocal repo $ error "internal"
 
 {- Runs git in the specified repo. -}
@@ -79,5 +80,5 @@ pipeNullSplit params repo =
 reap :: IO ()
 reap = do
 	-- throws an exception when there are no child processes
-	r <- catchDefaultIO (getAnyProcessStatus False True) Nothing
-	maybe (return ()) (const reap) r
+	catchDefaultIO (getAnyProcessStatus False True) Nothing
+		>>= maybe noop (const reap)

Git/Config.hs

@@ -1,15 +1,14 @@
 {- git repository configuration handling
  -
- - Copyright 2010,2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 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 Data.Char
 
 import Common
 import Git
@@ -20,23 +19,37 @@ import qualified Git.Construct
 get :: String -> String -> Repo -> String
 get key defaultValue repo = M.findWithDefault defaultValue key (config repo)
 
+{- Returns a list with each line of a multiline config setting. -}
+getList :: String -> Repo -> [String]
+getList key repo = M.findWithDefault [] key (fullconfig repo)
+
 {- Returns a single git config setting, if set. -}
 getMaybe :: String -> Repo -> Maybe String
 getMaybe key repo = M.lookup key (config repo)
 
-{- Runs git config and populates a repo with its config. -}
+{- Runs git config and populates a repo with its config.
+ - Avoids re-reading config when run repeatedly. -}
 read :: Repo -> IO Repo
-read repo@(Repo { location = Dir d }) = bracketcd d $
-	{- Cannot use pipeRead because it relies on the config having
-	   been already read. Instead, chdir to the repo. -}
-	pOpen ReadFromPipe "git" ["config", "--null", "--list"] $ hRead repo
+read repo@(Repo { config = c })
+	| c == M.empty = read' repo
+	| otherwise = return repo
+
+{- Reads config even if it was read before. -}
+reRead :: Repo -> IO Repo
+reRead = read'
+
+{- Cannot use pipeRead because it relies on the config having been already
+ - read. Instead, chdir to the repo.
+ -}
+read' :: Repo -> IO Repo
+read' repo = go repo
 	where
-		bracketcd to a = bracketcd' to a =<< getCurrentDirectory
-		bracketcd' to a cwd 
-			| dirContains to cwd = a
-			| otherwise = bracket_ (changeWorkingDirectory to) (changeWorkingDirectory cwd) a
-read r = assertLocal r $
-	error $ "internal error; trying to read config of " ++ show r
+		go Repo { location = Local { gitdir = d } } = git_config d
+		go Repo { location = LocalUnknown d } = git_config d
+		go _ = assertLocal repo $ error "internal"
+		git_config d = bracketCd d $
+			pOpen ReadFromPipe "git" ["config", "--null", "--list"] $
+				hRead repo
 
 {- Reads git config from a handle and populates a repo with it. -}
 hRead :: Repo -> Handle -> IO Repo
@@ -44,19 +57,37 @@ 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. -}
+{- Stores a git config into a Repo, returning the new version of the Repo.
+ - The git config may be multiple lines, or a single line.
+ - Config settings can be updated incrementally.
+ -}
 store :: String -> Repo -> IO Repo
 store s repo = do
 	let c = parse s
-	let repo' = repo
+	let repo' = updateLocation $ repo
 		{ config = (M.map Prelude.head c) `M.union` config repo
 		, fullconfig = M.unionWith (++) c (fullconfig repo)
 		}
 	rs <- Git.Construct.fromRemotes repo'
 	return $ repo' { remotes = rs }
 
+{- Updates the location of a repo, based on its configuration.
+ -
+ - Git.Construct makes LocalUknown repos, of which only a directory is
+ - known. Once the config is read, this can be fixed up to a Local repo, 
+ - based on the core.bare and core.worktree settings.
+ -}
+updateLocation :: Repo -> Repo
+updateLocation r@(Repo { location = LocalUnknown d })
+	| isBare r = newloc $ Local d Nothing
+	| otherwise = newloc $ Local (d </> ".git") (Just d)
+	where
+		newloc l = r { location = getworktree l }
+		getworktree l = case workTree r of
+			Nothing -> l
+			wt -> l { worktree = wt }
+updateLocation r = r
+
 {- Parses git config --list or git config --null --list output into a
  - config map. -}
 parse :: String -> M.Map String [String]
@@ -70,3 +101,18 @@ parse s
 		ls = lines s
 		sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .
 			map (separate (== c))
+
+{- Checks if a string from git config is a true value. -}
+isTrue :: String -> Maybe Bool
+isTrue s
+	| s' == "true" = Just True
+	| s' == "false" = Just False
+	| otherwise = Nothing
+	where
+		s' = map toLower s
+
+isBare :: Repo -> Bool
+isBare r = fromMaybe False $ isTrue =<< getMaybe "core.bare" r
+
+workTree :: Repo -> Maybe FilePath
+workTree = getMaybe "core.worktree"

Git/Construct.hs

@@ -1,12 +1,11 @@
 {- Construction of Git Repo objects
  -
- - Copyright 2010,2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
 module Git.Construct (
-	fromCurrent,
 	fromCwd,
 	fromAbsPath,
 	fromPath,
@@ -21,8 +20,6 @@ module Git.Construct (
 ) where
 
 import System.Posix.User
-import System.Posix.Env (getEnv, unsetEnv)
-import System.Posix.Directory (changeWorkingDirectory)
 import qualified Data.Map as M hiding (map, split)
 import Network.URI
 
@@ -31,34 +28,12 @@ import Git.Types
 import Git
 import qualified Git.Url as Url
 
-{- Finds the current git repository.
- -
- - GIT_DIR can override the location of the .git directory.
- -
- - When GIT_WORK_TREE is set, chdir to it, so that anything using
- - this repository runs in the right location. However, this chdir is
- - done after determining GIT_DIR; git does not let GIT_WORK_TREE
- - influence the git directory.
- -
- - Both environment variables are unset, to avoid confusing other git
- - commands that also look at them. This would particularly be a problem
- - when GIT_DIR is relative and we chdir for GIT_WORK_TREE. Instead,
- - the Git module passes --work-tree and --git-dir to git commands it runs.
- -}
-fromCurrent :: IO Repo
-fromCurrent = do
-	r <- maybe fromCwd fromPath =<< getEnv "GIT_DIR"
-	maybe (return ()) changeWorkingDirectory =<< getEnv "GIT_WORK_TREE"
-	unsetEnv "GIT_DIR"
-	unsetEnv "GIT_WORK_TREE"
-	return r
-
 {- Finds the git repository used for the Cwd, which may be in a parent
  - directory. -}
 fromCwd :: IO Repo
 fromCwd = getCurrentDirectory >>= seekUp isRepoTop >>= maybe norepo makerepo
 	where
-		makerepo = newFrom . Dir
+		makerepo = newFrom . LocalUnknown
 		norepo = error "Not in a git repository."
 
 {- Local Repo constructor, accepts a relative or absolute path. -}
@@ -74,7 +49,7 @@ fromAbsPath dir
 	| otherwise =
 		error $ "internal error, " ++ dir ++ " is not absolute"
 	where
-		ret = newFrom . Dir
+		ret = newFrom . LocalUnknown
  		{- Git always looks for "dir.git" in preference to
 		 - to "dir", even if dir ends in a "/". -}
 		canondir = dropTrailingPathSeparator dir
@@ -122,7 +97,7 @@ localToUrl reference r
 		absurl =
 			Url.scheme reference ++ "//" ++
 			Url.authority reference ++
-			workTree r
+			repoPath r
 
 {- Calculates a list of a repo's configured remotes, by parsing its config. -}
 fromRemotes :: Repo -> IO [Repo]
@@ -191,7 +166,7 @@ fromRemoteLocation s repo = gen $ calcloc s
 fromRemotePath :: FilePath -> Repo -> IO Repo
 fromRemotePath dir repo = do
 	dir' <- expandTilde dir
-	fromAbsPath $ workTree repo </> dir'
+	fromAbsPath $ repoPath repo </> dir'
 
 {- Git remotes can have a directory that is specified relative
  - to the user's home directory, or that contains tilde expansions.
@@ -251,3 +226,5 @@ newFrom l = return Repo
 	, remotes = []
 	, remoteName = Nothing
 	}
+
+

Git/CurrentRepo.hs

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

Git/LsFiles.hs

@@ -69,7 +69,7 @@ typeChanged' ps l repo = do
 	fs <- pipeNullSplit (prefix ++ ps ++ suffix) repo
 	-- git diff returns filenames relative to the top of the git repo;
 	-- convert to filenames relative to the cwd, like git ls-files.
-	let top = workTree repo
+	let top = repoPath repo
 	cwd <- getCurrentDirectory
 	return $ map (\f -> relPathDirToFile cwd $ top </> f) fs
 	where

Git/SharedRepository.hs

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

Git/Types.hs

@@ -1,6 +1,6 @@
 {- git data types
  -
- - Copyright 2010,2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -10,9 +10,21 @@ 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
+{- Support repositories on local disk, and repositories accessed via an URL.
+ -
+ - Repos on local disk have a git directory, and unless bare, a worktree.
+ -
+ - A local repo may not have had its config read yet, in which case all
+ - that's known about it is its path.
+ -
+ - Finally, an Unknown repository may be known to exist, but nothing
+ - else known about it.
+ -}
+data RepoLocation
+	= Local { gitdir :: FilePath, worktree :: Maybe FilePath }
+	| LocalUnknown FilePath
+	| Url URI
+	| Unknown
 	deriving (Show, Eq)
 
 data Repo = Repo {

Git/UnionMerge.hs

@@ -97,7 +97,7 @@ calc_merge :: CatFileHandle -> [String] -> Repo -> Streamer
 calc_merge ch differ repo streamer = gendiff >>= go
 	where
 		gendiff = pipeNullSplit (map Param differ) repo
-		go [] = return ()
+		go [] = noop
 		go (info:file:rest) = mergeFile info file ch repo >>=
 			maybe (go rest) (\l -> streamer l >> go rest)
 		go (_:[]) = error "calc_merge parse error"

GitAnnex.hs

@@ -11,7 +11,7 @@ import System.Console.GetOpt
 
 import Common.Annex
 import qualified Git.Config
-import qualified Git.Construct
+import qualified Git.CurrentRepo
 import CmdLine
 import Command
 import Types.TrustLevel
@@ -37,6 +37,7 @@ import qualified Command.InitRemote
 import qualified Command.Fsck
 import qualified Command.Unused
 import qualified Command.DropUnused
+import qualified Command.AddUnused
 import qualified Command.Unlock
 import qualified Command.Lock
 import qualified Command.PreCommit
@@ -53,6 +54,7 @@ import qualified Command.Semitrust
 import qualified Command.Dead
 import qualified Command.Sync
 import qualified Command.AddUrl
+import qualified Command.Import
 import qualified Command.Map
 import qualified Command.Upgrade
 import qualified Command.Version
@@ -69,6 +71,7 @@ cmds = concat
 	, Command.Lock.def
 	, Command.Sync.def
 	, Command.AddUrl.def
+	, Command.Import.def
 	, Command.Init.def
 	, Command.Describe.def
 	, Command.InitRemote.def
@@ -87,6 +90,7 @@ cmds = concat
 	, Command.Fsck.def
 	, Command.Unused.def
 	, Command.DropUnused.def
+	, Command.AddUnused.def
 	, Command.Find.def
 	, Command.Whereis.def
 	, Command.Log.def
@@ -133,4 +137,4 @@ header :: String
 header = "Usage: git-annex command [option ..]"
 
 run :: [String] -> IO ()
-run args = dispatch True args cmds options header Git.Construct.fromCurrent
+run args = dispatch True args cmds options header Git.CurrentRepo.get

GitAnnexShell.hs

@@ -52,7 +52,7 @@ options = Option.common ++
 	where
 		checkuuid expected = getUUID >>= check
 			where
-				check u | u == toUUID expected = return ()
+				check u | u == toUUID expected = noop
 				check NoUUID = unexpected "uninitialized repository"
 				check u = unexpected $ "UUID " ++ fromUUID u
 				unexpected s = error $
@@ -107,7 +107,7 @@ checkNotLimited = checkEnv "GIT_ANNEX_SHELL_LIMITED"
 
 checkNotReadOnly :: String -> IO ()
 checkNotReadOnly cmd
-	| cmd `elem` map cmdname cmds_readonly = return ()
+	| cmd `elem` map cmdname cmds_readonly = noop
 	| otherwise = checkEnv "GIT_ANNEX_SHELL_READONLY"
 
 checkEnv :: String -> IO ()

Init.hs

@@ -29,7 +29,9 @@ initialize mdescription = do
 	maybe (recordUUID u) (describeUUID u) mdescription
 
 uninitialize :: Annex ()
-uninitialize = gitPreCommitHookUnWrite
+uninitialize = do
+	gitPreCommitHookUnWrite
+	removeRepoUUID
 
 {- Will automatically initialize if there is already a git-annex
    branch from somewhere. Otherwise, require a manual init
@@ -70,7 +72,7 @@ unlessBare :: Annex () -> Annex ()
 unlessBare = unlessM $ fromRepo Git.repoIsLocalBare
 
 preCommitHook :: Annex FilePath
-preCommitHook = (</>) <$> fromRepo Git.gitDir <*> pure "hooks/pre-commit"
+preCommitHook = (</>) <$> fromRepo Git.localGitDir <*> pure "hooks/pre-commit"
 
 preCommitScript :: String
 preCommitScript = 

Locations.hs

@@ -85,28 +85,24 @@ gitAnnexLocation key r
 	| Git.repoIsLocalBare r =
 		{- Bare repositories default to hashDirLower for new
 		 - content, as it's more portable. -}
-		check (map inrepo $ annexLocations key)
+		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
+		return $ inrepo $ annexLocation key hashDirMixed
 	where
-		inrepo d = Git.workTree r </> d
+		inrepo d = Git.localGitDir 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
+gitAnnexDir r = addTrailingPathSeparator $ Git.localGitDir r </> 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
+gitAnnexObjectDir r = addTrailingPathSeparator $ Git.localGitDir r </> objectDir
 
 {- .git/annex/tmp/ is used for temp files -}
 gitAnnexTmpDir :: Git.Repo -> FilePath
@@ -124,7 +120,7 @@ gitAnnexBadDir r = addTrailingPathSeparator $ gitAnnexDir r </> "bad"
 gitAnnexBadLocation :: Key -> Git.Repo -> FilePath
 gitAnnexBadLocation key r = gitAnnexBadDir r </> keyFile key
 
-{- .git/annex/*unused is used to number possibly unused keys -}
+{- .git/annex/foounused is used to number possibly unused keys -}
 gitAnnexUnusedLog :: FilePath -> Git.Repo -> FilePath
 gitAnnexUnusedLog prefix r = gitAnnexDir r </> (prefix ++ "unused")
 
@@ -159,7 +155,9 @@ gitAnnexRemotesDir r = addTrailingPathSeparator $ gitAnnexDir r </> "remotes"
 
 {- Checks a symlink target to see if it appears to point to annexed content. -}
 isLinkToAnnex :: FilePath -> Bool
-isLinkToAnnex s = ("/.git/" ++ objectDir) `isInfixOf` s
+isLinkToAnnex s = ("/" ++ d) `isInfixOf` s || d `isPrefixOf` s
+	where
+		d = ".git" </> objectDir
 
 {- Converts a key into a filename fragment without any directory.
  -

Logs/Location.hs

@@ -30,7 +30,7 @@ import Logs.Presence
 {- 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 ()
+logChange _ NoUUID _ = noop
 
 {- Returns a list of repository UUIDs that, according to the log, have
  - the value of a key.

Logs/Remote.hs

@@ -36,7 +36,7 @@ configSet u c = do
 
 {- Map of remotes by uuid containing key/value config maps. -}
 readRemoteLog :: Annex (M.Map UUID RemoteConfig)
-readRemoteLog = (simpleMap . parseLog parseConfig) <$> Annex.Branch.get remoteLog
+readRemoteLog = simpleMap . parseLog parseConfig <$> Annex.Branch.get remoteLog
 
 parseConfig :: String -> Maybe RemoteConfig
 parseConfig = Just . keyValToConfig . words
@@ -59,7 +59,7 @@ configToKeyVal m = map toword $ sort $ M.toList m
 		toword (k, v) = k ++ "=" ++ configEscape v
 
 configEscape :: String -> String
-configEscape = (>>= escape)
+configEscape = concatMap escape
 	where
 		escape c
 			| isSpace c || c `elem` "&" = "&" ++ show (ord c) ++ ";"

Logs/UUID.hs

@@ -73,7 +73,7 @@ recordUUID u = go . M.lookup u =<< uuidMap
 	where
 		go (Just "") = set
 		go Nothing = set
-		go _ = return ()
+		go _ = noop
 		set = describeUUID u ""
 
 {- Read the uuidLog into a simple Map.

Logs/UUIDBased.hs

@@ -83,7 +83,7 @@ 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
+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

Logs/Unused.hs

@@ -0,0 +1,91 @@
+{- git-annex unused log file
+ -
+ - Copyright 2010,2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Logs.Unused (
+	UnusedMap,
+	UnusedMaps(..),
+	writeUnusedLog,
+	readUnusedLog,
+	withUnusedMaps,
+	startUnused,
+) where
+
+import qualified Data.Map as M
+
+import Common.Annex
+import Command
+import Types.Key
+import Utility.TempFile
+
+writeUnusedLog :: FilePath -> [(Int, Key)] -> Annex ()
+writeUnusedLog prefix l = do
+	logfile <- fromRepo $ gitAnnexUnusedLog prefix
+	liftIO $ viaTmp writeFile logfile $
+		unlines $ map (\(n, k) -> show n ++ " " ++ show k) l
+
+readUnusedLog :: FilePath -> Annex UnusedMap
+readUnusedLog prefix = do
+	f <- fromRepo $ gitAnnexUnusedLog prefix
+	ifM (liftIO $ doesFileExist f)
+		( M.fromList . catMaybes . map parse . lines
+			<$> liftIO (readFile f)
+		, return M.empty
+		)
+	where
+		parse line =
+			case (readish tag, readKey rest) of
+				(Just num, Just key) -> Just (num, key)
+				_ -> Nothing
+			where
+				(tag, rest) = separate (== ' ') line
+
+type UnusedMap = M.Map Int Key
+
+data UnusedMaps = UnusedMaps
+	{ unusedMap :: UnusedMap
+	, unusedBadMap :: UnusedMap
+	, unusedTmpMap :: UnusedMap
+	}
+
+{- Read unused logs once, and pass the maps to each start action. -}
+withUnusedMaps :: (UnusedMaps -> Int -> CommandStart) -> CommandSeek
+withUnusedMaps a params = do
+	unused <- readUnusedLog ""
+	unusedbad <- readUnusedLog "bad"
+	unusedtmp <- readUnusedLog "tmp"
+	return $ map (a $ UnusedMaps unused unusedbad unusedtmp) $
+		concatMap unusedSpec params
+
+unusedSpec :: String -> [Int]
+unusedSpec spec
+	| "-" `isInfixOf` spec = range $ separate (== '-') spec
+	| otherwise = catMaybes [readish spec]
+	where
+		range (a, b) = case (readish a, readish b) of
+			(Just x, Just y) -> [x..y]
+			_ -> []
+
+{- Start action for unused content. Finds the number in the maps, and
+ - calls either of 3 actions, depending on the type of unused file. -}
+startUnused :: String
+	-> (Key -> CommandPerform)
+	-> (Key -> CommandPerform) 
+	-> (Key -> CommandPerform)
+	-> UnusedMaps -> Int -> CommandStart
+startUnused message unused badunused tmpunused maps n = search
+	[ (unusedMap maps, unused)
+	, (unusedBadMap maps, badunused)
+	, (unusedTmpMap maps, tmpunused)
+	]
+	where
+		search [] = stop
+		search ((m, a):rest) =
+			case M.lookup n m of
+				Nothing -> search rest
+				Just key -> do
+					showStart message (show n)
+					next $ a key

Makefile

@@ -1,6 +1,6 @@
 PREFIX=/usr
 IGNORE=-ignore-package monads-fd
-BASEFLAGS=-Wall $(IGNORE) -outputdir tmp -IUtility
+BASEFLAGS=-Wall $(IGNORE) -outputdir tmp -IUtility -DWITH_S3
 GHCFLAGS=-O2 $(BASEFLAGS)
 
 ifdef PROFILE
@@ -12,7 +12,7 @@ GHCMAKE=ghc $(GHCFLAGS) --make
 bins=git-annex
 mans=git-annex.1 git-annex-shell.1
 sources=Build/SysConfig.hs Utility/Touch.hs
-clibs=Utility/diskfree.o
+clibs=Utility/libdiskfree.o
 
 all=$(bins) $(mans) docs
 

Messages.hs

@@ -13,6 +13,9 @@ module Messages (
 	metered,
 	MeterUpdate,
 	showSideAction,
+	doSideAction,
+	doQuietSideAction,
+	showStoringStateAction,
 	showOutput,
 	showLongNote,
 	showEndOk,
@@ -37,6 +40,7 @@ import Data.Quantity
 
 import Common
 import Types
+import Types.Messages
 import Types.Key
 import qualified Annex
 import qualified Messages.JSON as JSON
@@ -61,9 +65,9 @@ showProgress = handle q $
  - The action is passed a callback to use to update the meter. -}
 type MeterUpdate = Integer -> IO ()
 metered :: Key -> (MeterUpdate -> Annex a) -> Annex a
-metered key a = Annex.getState Annex.output >>= go (keySize key)
+metered key a = withOutputType $ go (keySize key)
 	where
-		go (Just size) Annex.NormalOutput = do
+		go (Just size) NormalOutput = do
 			progress <- liftIO $ newProgress "" size
 			meter <- liftIO $ newMeter progress "B" 25 (renderNums binaryOpts 1)
 			showOutput
@@ -72,12 +76,38 @@ metered key a = Annex.getState Annex.output >>= go (keySize key)
 				incrP progress n
 				displayMeter stdout meter
 			liftIO $ clearMeter stdout meter
-			return r	
-                go _ _ = a (const $ return ())
+			return r
+                go _ _ = a (const noop)
 
 showSideAction :: String -> Annex ()
-showSideAction s = handle q $
-	putStrLn $ "(" ++ s ++ "...)"
+showSideAction m = Annex.getState Annex.output >>= go
+	where
+		go (MessageState v StartBlock) = do
+			p
+	 		Annex.changeState $ \s -> s { Annex.output = MessageState v InBlock }
+		go (MessageState _ InBlock) = return ()
+		go _ = p
+		p = handle q $ putStrLn $ "(" ++ m ++ "...)"
+			
+showStoringStateAction :: Annex ()
+showStoringStateAction = showSideAction "Recording state in git"
+
+{- Performs an action, supressing showSideAction messages. -}
+doQuietSideAction :: Annex a -> Annex a
+doQuietSideAction = doSideAction' InBlock
+
+{- Performs an action, that may call showSideAction multiple times.
+ - Only the first will be displayed. -}
+doSideAction :: Annex a -> Annex a
+doSideAction = doSideAction' StartBlock
+
+doSideAction' :: SideActionBlock -> Annex a -> Annex a
+doSideAction' b a = do
+	o <- Annex.getState Annex.output
+	set $ o { sideActionBlock = b }
+	set o `after` a
+	where
+		set o = Annex.changeState $ \s -> s {  Annex.output = o }
 
 showOutput :: Annex ()
 showOutput = handle q $
@@ -122,9 +152,9 @@ maybeShowJSON v = handle (JSON.add v) q
 
 {- Shows a complete JSON value, only when in json mode. -}
 showFullJSON :: JSON a => [(String, a)] -> Annex Bool
-showFullJSON v = Annex.getState Annex.output >>= liftIO . go
+showFullJSON v = withOutputType $ liftIO . go
 	where
-		go Annex.JSONOutput = JSON.complete v >> return True
+		go JSONOutput = JSON.complete v >> return True
 		go _ = return False
 
 {- Performs an action that outputs nonstandard/customized output, and
@@ -153,14 +183,17 @@ setupConsole = do
 	fileEncoding stderr
 
 handle :: IO () -> IO () -> Annex ()
-handle json normal = Annex.getState Annex.output >>= go
+handle json normal = withOutputType $ go
 	where
-		go Annex.NormalOutput = liftIO normal
-		go Annex.QuietOutput = q
-		go Annex.JSONOutput = liftIO $ flushed json
+		go NormalOutput = liftIO normal
+		go QuietOutput = q
+		go JSONOutput = liftIO $ flushed json
 
 q :: Monad m => m ()
-q = return ()
+q = noop
 
 flushed :: IO () -> IO ()
 flushed a = a >> hFlush stdout
+
+withOutputType :: (OutputType -> Annex a) -> Annex a
+withOutputType a = outputType <$> Annex.getState Annex.output >>= a

Option.hs

@@ -20,6 +20,7 @@ import System.Log.Logger
 
 import Common.Annex
 import qualified Annex
+import Types.Messages
 import Limit
 import Usage
 
@@ -31,11 +32,11 @@ common =
 		"avoid slow operations"
 	, Option ['a'] ["auto"] (NoArg (setauto True))
 		"automatic mode"
-	, Option ['q'] ["quiet"] (NoArg (setoutput Annex.QuietOutput))
+	, Option ['q'] ["quiet"] (NoArg (Annex.setOutput QuietOutput))
 		"avoid verbose output"
-	, Option ['v'] ["verbose"] (NoArg (setoutput Annex.NormalOutput))
+	, Option ['v'] ["verbose"] (NoArg (Annex.setOutput NormalOutput))
 		"allow verbose output (default)"
-	, Option ['j'] ["json"] (NoArg (setoutput Annex.JSONOutput))
+	, Option ['j'] ["json"] (NoArg (Annex.setOutput JSONOutput))
 		"enable JSON output"
 	, Option ['d'] ["debug"] (NoArg setdebug)
 		"show debug messages"
@@ -46,7 +47,6 @@ common =
 		setforce v = Annex.changeState $ \s -> s { Annex.force = v }
 		setfast v = Annex.changeState $ \s -> s { Annex.fast = v }
 		setauto v = Annex.changeState $ \s -> s { Annex.auto = v }
-		setoutput v = Annex.changeState $ \s -> s { Annex.output = v }
 		setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v }
 		setdebug = liftIO $ updateGlobalLogger rootLoggerName $
 			setLevel DEBUG

Remote.hs

@@ -194,7 +194,7 @@ showLocations key exclude = do
 		message rs us = message rs [] ++ message [] us
 
 showTriedRemotes :: [Remote] -> Annex ()
-showTriedRemotes [] = return ()	
+showTriedRemotes [] = noop
 showTriedRemotes remotes =
 	showLongNote $ "Unable to access these remotes: " ++
 		join ", " (map name remotes)

Remote/Bup.hs

@@ -184,7 +184,7 @@ storeBupUUID u buprepo = do
 
 onBupRemote :: Git.Repo -> (FilePath -> [CommandParam] -> IO a) -> FilePath -> [CommandParam] -> Annex a
 onBupRemote r a command params = do
-	let dir = shellEscape (Git.workTree r)
+	let dir = shellEscape (Git.repoPath r)
 	sshparams <- sshToRepo r [Param $
 			"cd " ++ dir ++ " && " ++ unwords (command : toCommand params)]
 	liftIO $ a "ssh" sshparams

Remote/Directory.hs

@@ -10,7 +10,7 @@ module Remote.Directory (remote) where
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified Data.ByteString.Char8 as S
 import qualified Data.Map as M
-import Control.Exception (bracket)
+import qualified Control.Exception as E
 
 import Common.Annex
 import Types.Remote
@@ -22,6 +22,7 @@ import Remote.Helper.Encryptable
 import Crypto
 import Utility.DataUnits
 import Data.Int
+import Annex.Content
 
 remote :: RemoteType
 remote = RemoteType {
@@ -125,7 +126,7 @@ store :: FilePath -> ChunkSize -> Key -> Annex Bool
 store d chunksize k = do
 	src <- inRepo $ gitAnnexLocation k
 	metered k $ \meterupdate -> 
-		liftIO $ catchBoolIO $ storeHelper d chunksize k $ \dests ->
+		storeHelper d chunksize k $ \dests ->
 			case chunksize of
 				Nothing -> do
 					let dest = Prelude.head dests
@@ -140,7 +141,7 @@ storeEncrypted :: FilePath -> ChunkSize -> (Cipher, Key) -> Key -> Annex Bool
 storeEncrypted d chunksize (cipher, enck) k = do
 	src <- inRepo $ gitAnnexLocation k
 	metered k $ \meterupdate ->
-		liftIO $ catchBoolIO $ storeHelper d chunksize enck $ \dests ->
+		storeHelper d chunksize enck $ \dests ->
 			withEncryptedContent cipher (L.readFile src) $ \s ->
 				case chunksize of
 					Nothing -> do
@@ -165,7 +166,7 @@ storeSplit' :: MeterUpdate -> Int64 -> [FilePath] -> [S.ByteString] -> [FilePath
 storeSplit' _ _ [] _ _ = error "ran out of dests"
 storeSplit' _ _  _ [] c = return $ reverse c
 storeSplit' meterupdate chunksize (d:dests) bs c = do
-	bs' <- bracket (openFile d WriteMode) hClose (feed chunksize bs)
+	bs' <- E.bracket (openFile d WriteMode) hClose (feed chunksize bs)
 	storeSplit' meterupdate chunksize dests bs' (d:c)
 	where
 		feed _ [] _ = return []
@@ -190,11 +191,12 @@ meteredWriteFile meterupdate dest b =
  - meter after each chunk. The feeder is called to get more chunks. -}
 meteredWriteFile' :: MeterUpdate -> FilePath -> s -> (s -> IO (s, [S.ByteString])) -> IO ()
 meteredWriteFile' meterupdate dest startstate feeder =
-	bracket (openFile dest WriteMode) hClose (feed startstate [])
+	E.bracket (openFile dest WriteMode) hClose (feed startstate [])
 	where
 		feed state [] h = do
 			(state', cs) <- feeder state
-			if null cs then return () else feed state' cs h
+			unless (null cs) $
+				feed state' cs h
 		feed state (c:cs) h = do
 			S.hPut h c
 			meterupdate $ toInteger $ S.length c
@@ -207,31 +209,38 @@ meteredWriteFile' meterupdate dest startstate feeder =
  - The stored files are only put into their final place once storage is
  - complete.
  -}
-storeHelper :: FilePath -> ChunkSize -> Key -> ([FilePath] -> IO [FilePath]) -> IO Bool
-storeHelper d chunksize key a = do
-	let dir = parentDir desttemplate
-	createDirectoryIfMissing True dir
-	allowWrite dir
-	stored <- a tmpdests
-	forM_ stored $ \f -> do
-		let dest = detmpprefix f
-		renameFile f dest
-		preventWrite dest
-	when (chunksize /= Nothing) $ do
-		let chunkcount = chunkCount desttemplate
-		_ <- tryIO $ allowWrite chunkcount
-		writeFile chunkcount (show $ length stored)
-		preventWrite chunkcount
-	preventWrite dir
-	return (not $ null stored)
+storeHelper :: FilePath -> ChunkSize -> Key -> ([FilePath] -> IO [FilePath]) -> Annex Bool
+storeHelper d chunksize key a = prep <&&> check <&&> go
 	where
 		desttemplate = Prelude.head $ locations d key
+		dir = parentDir desttemplate
 		tmpdests = case chunksize of
 			Nothing -> [desttemplate ++ tmpprefix]
 			Just _ -> map (++ tmpprefix) (chunkStream desttemplate)
 		tmpprefix = ".tmp"
 		detmpprefix f = take (length f - tmpprefixlen) f
 		tmpprefixlen = length tmpprefix
+		prep = liftIO $ catchBoolIO $ do
+			createDirectoryIfMissing True dir
+			allowWrite dir
+			return True
+		{- The size is not exactly known when encrypting the key;
+		 - this assumes that at least the size of the key is
+		 - needed as free space. -}
+		check = checkDiskSpace (Just dir) key 0
+		go = liftIO $ catchBoolIO $ do
+			stored <- a tmpdests
+			forM_ stored $ \f -> do
+				let dest = detmpprefix f
+				renameFile f dest
+				preventWrite dest
+			when (chunksize /= Nothing) $ do
+				let chunkcount = chunkCount desttemplate
+				_ <- tryIO $ allowWrite chunkcount
+				writeFile chunkcount (show $ length stored)
+				preventWrite chunkcount
+			preventWrite dir
+			return (not $ null stored)
 
 retrieve :: FilePath -> ChunkSize -> Key -> FilePath -> Annex Bool
 retrieve d chunksize k f = metered k $ \meterupdate ->

Remote/Git.hs

@@ -94,7 +94,9 @@ tryGitConfigRead :: Git.Repo -> Annex Git.Repo
 tryGitConfigRead r 
 	| not $ M.null $ Git.config r = return r -- already read
 	| Git.repoIsSsh r = store $ onRemote r (pipedconfig, r) "configlist" []
-	| Git.repoIsHttp r = store $ safely geturlconfig
+	| Git.repoIsHttp r = do
+		headers <- getHttpHeaders
+		store $ safely $ geturlconfig headers
 	| Git.repoIsUrl r = return r
 	| otherwise = store $ safely $ onLocal r $ do 
 		ensureInitialized
@@ -109,8 +111,8 @@ tryGitConfigRead r
 			pOpen ReadFromPipe cmd (toCommand params) $
 				Git.Config.hRead r
 
-		geturlconfig = do
-			s <- Url.get (Git.repoLocation r ++ "/config")
+		geturlconfig headers = do
+			s <- Url.get (Git.repoLocation r ++ "/config") headers
 			withTempFile "git-annex.tmp" $ \tmpfile h -> do
 				hPutStr h s
 				hClose h
@@ -136,16 +138,16 @@ tryGitConfigRead r
  -}
 inAnnex :: Git.Repo -> Key -> Annex (Either String Bool)
 inAnnex r key
-	| Git.repoIsHttp r = checkhttp
+	| Git.repoIsHttp r = checkhttp =<< getHttpHeaders
 	| Git.repoIsUrl r = checkremote
 	| otherwise = checklocal
 	where
-		checkhttp = liftIO $ go undefined $ keyUrls r key
+		checkhttp headers = liftIO $ go undefined $ keyUrls r key
 			where
 				go e [] = return $ Left e
 				go _ (u:us) = do
 					res <- catchMsgIO $
-						Url.check u (keySize key)
+						Url.check u headers (keySize key)
 					case res of
 						Left e -> go e us
 						v -> return v
@@ -177,12 +179,8 @@ repoAvail r
  - monad using that repository. -}
 onLocal :: Git.Repo -> Annex a -> IO a
 onLocal r a = do
-	-- Avoid re-reading the repository's configuration if it was
-	-- already read.
-	state <- if M.null $ Git.config r
-		then Annex.new r
-		else return $ Annex.newState r
-	Annex.eval state $ do
+	s <- Annex.new r
+	Annex.eval s $ do
 		-- No need to update the branch; its data is not used
 		-- for anything onLocal is used to do.
 		Annex.BranchState.disableUpdate
@@ -312,8 +310,9 @@ commitOnCleanup r a = go `after` a
 		go = Annex.addCleanup (Git.repoLocation r) cleanup
 		cleanup
 			| not $ Git.repoIsUrl r = liftIO $ onLocal r $
-				Annex.Branch.commit "update"
-			| otherwise = do
+				doQuietSideAction $
+					Annex.Branch.commit "update"
+			| otherwise = void $ do
 				Just (shellcmd, shellparams) <-
 					git_annex_shell r "commit" []
 				-- Throw away stderr, since the remote may not
@@ -322,6 +321,4 @@ commitOnCleanup r a = go `after` a
 				let cmd = shellcmd ++ " "
 					++ unwords (map shellEscape $ toCommand shellparams)
 					++ ">/dev/null 2>/dev/null"
-				_ <- liftIO $
-					boolSystem "sh" [Param "-c", Param cmd]
-				return ()
+				liftIO $ boolSystem "sh" [Param "-c", Param cmd]

Remote/Helper/Encryptable.hs

@@ -14,20 +14,26 @@ import Types.Remote
 import Crypto
 import qualified Annex
 import Config
+import Utility.Base64
 
 {- Encryption setup for a remote. The user must specify whether to use
  - an encryption key, or not encrypt. An encrypted cipher is created, or is
- - updated to be accessible to an additional encryption key. -}
+ - updated to be accessible to an additional encryption key. Or the user
+ - could opt to use a shared cipher, which is stored unencrypted. -}
 encryptionSetup :: RemoteConfig -> Annex RemoteConfig
-encryptionSetup c =
-	case (M.lookup "encryption" c, extractCipher c) of
-		(Nothing, Nothing) -> error "Specify encryption=key or encryption=none"
-		(Just "none", Nothing) -> return c
-		(Just "none", Just _) -> error "Cannot change encryption type of existing remote."
-		(Nothing, Just _) -> return c
-		(Just _, Nothing) -> use "encryption setup" $ genCipher c
-		(Just _, Just v) -> use "encryption updated" $ updateCipher c v
+encryptionSetup c = case (M.lookup "encryption" c, extractCipher c) of
+	(Nothing, Nothing) -> error "Specify encryption=key or encryption=none or encryption=shared"
+	(Just "none", Nothing) -> return c
+	(Nothing, Just _) -> return c
+	(Just "shared", Just (SharedCipher _)) -> return c
+	(Just "none", Just _) -> cannotchange
+	(Just "shared", Just (EncryptedCipher _ _)) -> cannotchange
+	(Just _, Just (SharedCipher _)) -> cannotchange
+	(Just "shared", Nothing) -> use "encryption setup" $ genSharedCipher
+	(Just keyid, Nothing) -> use "encryption setup" $ genEncryptedCipher keyid
+	(Just keyid, Just v) -> use "encryption updated" $ updateEncryptedCipher keyid v
 	where
+		cannotchange = error "Cannot change encryption type of existing remote."
 		use m a = do
 			cipher <- liftIO a
 			showNote $ m ++ " " ++ describeCipher cipher
@@ -78,7 +84,7 @@ remoteCipher c = go $ extractCipher c
 				Nothing -> decrypt encipher cache
 		decrypt encipher cache = do
 			showNote "gpg"
-			cipher <- liftIO $ decryptCipher c encipher
+			cipher <- liftIO $ decryptCipher encipher
 			Annex.changeState (\s -> s { Annex.ciphers = M.insert encipher cipher cache })
 			return $ Just cipher
 
@@ -88,3 +94,21 @@ cipherKey Nothing _ = return Nothing
 cipherKey (Just c) k = maybe Nothing encrypt <$> remoteCipher c
 	where
 		encrypt ciphertext = Just (ciphertext, encryptKey ciphertext k)
+
+{- Stores an StorableCipher in a remote's configuration. -}
+storeCipher :: RemoteConfig -> StorableCipher -> RemoteConfig
+storeCipher c (SharedCipher t) = M.insert "cipher" (toB64 t) c
+storeCipher c (EncryptedCipher t ks) = 
+	M.insert "cipher" (toB64 t) $ M.insert "cipherkeys" (showkeys ks) c
+	where
+		showkeys (KeyIds l) = join "," l
+
+{- Extracts an StorableCipher from a remote's configuration. -}
+extractCipher :: RemoteConfig -> Maybe StorableCipher
+extractCipher c = 
+	case (M.lookup "cipher" c, M.lookup "cipherkeys" c) of
+		(Just t, Just ks) -> Just $ EncryptedCipher (fromB64 t) (readkeys ks)
+		(Just t, Nothing) -> Just $ SharedCipher (fromB64 t)
+		_ -> Nothing
+	where
+		readkeys = KeyIds . split ","

Remote/Helper/Hooks.hs

@@ -14,6 +14,7 @@ import Types.Remote
 import qualified Annex
 import Annex.LockPool
 import Config
+import Annex.Perms
 
 {- Modifies a remote's access functions to first run the
  - annex-start-command hook, and trigger annex-stop-command on shutdown.
@@ -45,10 +46,9 @@ runHooks r starthook stophook a = do
 	a
 	where
 		remoteid = show (uuid r)
-		run Nothing = return ()
-		run (Just command) = liftIO $ do
-			_ <- boolSystem "sh" [Param "-c", Param command]
-			return ()
+		run Nothing = noop
+		run (Just command) = void $ liftIO $
+			boolSystem "sh" [Param "-c", Param command]
 		firstrun lck = do
 			-- Take a shared lock; This indicates that git-annex
 			-- is using the remote, and prevents other instances
@@ -75,11 +75,13 @@ runHooks r starthook stophook a = do
 			-- succeeds, we're the only process using this remote,
 			-- so can stop it.
 			unlockFile lck
-			fd <- liftIO $ openFd lck ReadWrite (Just stdFileMode) defaultFileFlags
+			mode <- annexFileMode
+			fd <- liftIO $ noUmask mode $
+				openFd lck ReadWrite (Just mode) defaultFileFlags
 			v <- liftIO $ tryIO $
 				setLock fd (WriteLock, AbsoluteSeek, 0, 0)
 			case v of
-				Left _ -> return ()
+				Left _ -> noop
 				Right _ -> run stophook
 			liftIO $ closeFd fd
 

Remote/Helper/Ssh.hs

@@ -34,7 +34,7 @@ git_annex_shell r command params
 		return $ Just ("ssh", sshparams)
 	| otherwise = return Nothing
 	where
-		dir = Git.workTree r
+		dir = Git.repoPath r
 		shellcmd = "git-annex-shell"
 		shellopts = Param command : File dir : params
 		sshcmd uuid = unwords $

Remote/Hook.hs

@@ -74,14 +74,14 @@ hookEnv k f = Just $ fileenv f ++ keyenv
 
 lookupHook :: String -> String -> Annex (Maybe String)
 lookupHook hooktype hook =do
-	command <- getConfig hookname ""
+	command <- getConfig (annexConfig hookname) ""
 	if null command
 		then do
 			warning $ "missing configuration for " ++ hookname
 			return Nothing
 		else return $ Just command
 	where
-		hookname =  "annex." ++ hooktype ++ "-" ++ hook ++ "-hook"
+		hookname = hooktype ++ "-" ++ hook ++ "-hook"
 
 runHook :: String -> String -> Key -> Maybe FilePath -> Annex Bool -> Annex Bool
 runHook hooktype hook k f a = maybe (return False) run =<< lookupHook hooktype hook

Remote/List.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 {- git-annex remote list
  -
  - Copyright 2011 Joey Hess <joey@kitenet.net>
@@ -18,7 +20,9 @@ import Config
 import Remote.Helper.Hooks
 
 import qualified Remote.Git
+#ifdef WITH_S3
 import qualified Remote.S3
+#endif
 import qualified Remote.Bup
 import qualified Remote.Directory
 import qualified Remote.Rsync
@@ -28,7 +32,9 @@ import qualified Remote.Hook
 remoteTypes :: [RemoteType]
 remoteTypes =
 	[ Remote.Git.remote
+#ifdef WITH_S3
 	, Remote.S3.remote
+#endif
 	, Remote.Bup.remote
 	, Remote.Directory.remote
 	, Remote.Rsync.remote

Remote/Rsync.hs

@@ -22,9 +22,10 @@ import Utility.RsyncFile
 
 type RsyncUrl = String
 
-data RsyncOpts = RsyncOpts {
-	rsyncUrl :: RsyncUrl,
-	rsyncOptions :: [CommandParam]
+data RsyncOpts = RsyncOpts
+	{ rsyncUrl :: RsyncUrl
+	, rsyncOptions :: [CommandParam]
+	, rsyncShellEscape :: Bool
 }
 
 remote :: RemoteType
@@ -37,7 +38,7 @@ remote = RemoteType {
 
 gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote
 gen r u c = do
-	o <- genRsyncOpts r
+	o <- genRsyncOpts r c
 	cst <- remoteCost r expensiveRemoteCost
 	return $ encryptableRemote c
 		(storeEncrypted o)
@@ -58,11 +59,13 @@ gen r u c = do
 			remotetype = remote
 		}
 
-genRsyncOpts :: Git.Repo -> Annex RsyncOpts
-genRsyncOpts r = do
+genRsyncOpts :: Git.Repo -> Maybe RemoteConfig -> Annex RsyncOpts
+genRsyncOpts r c = do
 	url <- getRemoteConfig r "rsyncurl" (error "missing rsyncurl")
-	opts <- getRemoteConfig r "rsync-options" ""
-	return $ RsyncOpts url $ map Param $ filter safe $ words opts
+	opts <- map Param . filter safe . words
+		<$> getRemoteConfig r "rsync-options" ""
+	let escape = maybe True (\m -> M.lookup "shellescape" m /= Just "no") c
+	return $ RsyncOpts url opts escape
 	where
 		safe o
 			-- Don't allow user to pass --delete to rsync;
@@ -86,7 +89,7 @@ rsyncSetup u c = do
 
 rsyncEscape :: RsyncOpts -> String -> String
 rsyncEscape o s
-	| rsyncUrlIsShell (rsyncUrl o) = shellEscape s
+	| rsyncShellEscape o && rsyncUrlIsShell (rsyncUrl o) = shellEscape s
 	| otherwise = s
 
 rsyncUrls :: RsyncOpts -> Key -> [String]

Remote/S3.hs

@@ -93,7 +93,7 @@ s3Setup u c = handlehost $ M.lookup "host" c
 
 		archiveorg = do
 			showNote "Internet Archive mode"
-			maybe (error "specify bucket=") (const $ return ()) $
+			maybe (error "specify bucket=") (const noop) $
 				M.lookup "bucket" archiveconfig
 			use archiveconfig
 			where
@@ -237,13 +237,13 @@ genBucket c = do
 	showAction "checking bucket"
 	loc <- liftIO $ getBucketLocation conn bucket 
 	case loc of
-		Right _ -> return ()
+		Right _ -> noop
 		Left err@(NetworkError _) -> s3Error err
 		Left (AWSError _ _) -> do
 			showAction $ "creating bucket in " ++ datacenter
 			res <- liftIO $ createBucketIn conn bucket datacenter
 			case res of
-				Right _ -> return ()
+				Right _ -> noop
 				Left err -> s3Error err
 	where
 		bucket = fromJust $ M.lookup "bucket" c

Remote/Web.hs

@@ -83,4 +83,5 @@ checkKey key = do
 checkKey' :: Key -> [URLString] -> Annex Bool
 checkKey' key us = untilTrue us $ \u -> do
 	showAction $ "checking " ++ u
-	liftIO $ Url.check u (keySize key)
+	headers <- getHttpHeaders
+	liftIO $ Url.check u headers (keySize key)

Seek.hs

@@ -4,7 +4,7 @@
  - the values a user passes to a command, and prepare actions operating
  - on them.
  -
- - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -41,6 +41,14 @@ withFilesNotInGit a params = do
 			g <- gitRepo
 			liftIO $ (\p -> LsFiles.notInRepo force p g) l
 
+withPathContents :: ((FilePath, FilePath) -> CommandStart) -> CommandSeek
+withPathContents a params = map a . concat <$> liftIO (mapM get params)
+	where
+		get p = ifM (isDirectory <$> getFileStatus p)
+			( map (\f -> (f, makeRelative p f)) <$> dirContentsRecursive p
+			, return [(p, takeFileName p)]
+			)
+
 withWords :: ([String] -> CommandStart) -> CommandSeek
 withWords a params = return [a params]
 

Setup.hs

@@ -1,12 +1,27 @@
 {- cabal setup file -}
 
 import Distribution.Simple
+import Distribution.Simple.LocalBuildInfo
+import Distribution.Simple.Setup
 import System.Cmd
+import System.FilePath
 
 import qualified Build.Configure as Configure
 
-main = defaultMainWithHooks simpleUserHooks { preConf = configure }
+main = defaultMainWithHooks simpleUserHooks
+	{ preConf = configure
+	, instHook = install
+	}
 
 configure _ _ = do
 	Configure.run Configure.tests
 	return (Nothing, [])
+
+install pkg_descr lbi userhooks flags = do
+	r <- (instHook simpleUserHooks) pkg_descr lbi userhooks flags
+	_ <- rawSystem "ln" ["-sf", "git-annex", 
+		bindir installDirs </> "git-annex-shell"]
+	return r
+	where
+		installDirs = absoluteInstallDirs pkg_descr lbi $
+			fromFlag (copyDest defaultCopyFlags)

Types/Crypto.hs

@@ -1,13 +1,13 @@
 {- git-annex crypto types
  -
- - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
 module Types.Crypto (
 	Cipher(..),
-	EncryptedCipher(..),
+	StorableCipher(..),
 	KeyIds(..),
 ) where
 
@@ -16,5 +16,5 @@ import Utility.Gpg (KeyIds(..))
 -- XXX ideally, this would be a locked memory region
 newtype Cipher = Cipher String
 
-data EncryptedCipher = EncryptedCipher String KeyIds
+data StorableCipher = EncryptedCipher String KeyIds | SharedCipher String
 	deriving (Ord, Eq)

Types/Messages.hs

@@ -0,0 +1,20 @@
+{- git-annex Messages data types
+ - 
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Types.Messages where
+
+data OutputType = NormalOutput | QuietOutput | JSONOutput
+
+data SideActionBlock = NoBlock | StartBlock | InBlock
+
+data MessageState = MessageState
+	{ outputType :: OutputType
+	, sideActionBlock :: SideActionBlock
+	}
+
+defaultMessageState :: MessageState
+defaultMessageState = MessageState NormalOutput NoBlock

Upgrade/V1.hs

@@ -59,7 +59,7 @@ upgrade = do
 			updateSymlinks
 			moveLocationLogs
 	
-			Annex.Queue.flush True
+			Annex.Queue.flush
 			setVersion
 		)
 	
@@ -82,14 +82,14 @@ moveContent = do
 updateSymlinks :: Annex ()
 updateSymlinks = do
 	showAction "updating symlinks"
-	top <- fromRepo Git.workTree
+	top <- fromRepo Git.repoPath
 	files <- inRepo $ LsFiles.inRepo [top]
 	forM_ files fixlink
 	where
 		fixlink f = do
 			r <- lookupFile1 f
 			case r of
-				Nothing -> return ()
+				Nothing -> noop
 				Just (k, _) -> do
 					link <- calcGitLink f k
 					liftIO $ removeFile f
@@ -236,4 +236,4 @@ stateDir :: FilePath
 stateDir = addTrailingPathSeparator ".git-annex"
 
 gitStateDir :: Git.Repo -> FilePath
-gitStateDir repo = addTrailingPathSeparator $ Git.workTree repo </> stateDir
+gitStateDir repo = addTrailingPathSeparator $ Git.repoPath repo </> stateDir

Upgrade/V2.hs

@@ -134,4 +134,4 @@ gitAttributesUnWrite repo = do
 stateDir :: FilePath
 stateDir = addTrailingPathSeparator ".git-annex"
 gitStateDir :: Git.Repo -> FilePath
-gitStateDir repo = addTrailingPathSeparator $ Git.workTree repo </> stateDir
+gitStateDir repo = addTrailingPathSeparator $ Git.repoPath repo </> stateDir

Usage.hs

@@ -61,6 +61,8 @@ paramUrl :: String
 paramUrl = "URL"
 paramNumber :: String
 paramNumber = "NUMBER"
+paramNumRange :: String
+paramNumRange = "NUM|RANGE"
 paramRemote :: String
 paramRemote = "REMOTE"
 paramGlob :: String

Utility/CopyFile.hs

@@ -1,16 +1,13 @@
 {- git-annex file copying
  -
- - Copyright 2010 Joey Hess <joey@kitenet.net>
+ - Copyright 2010,2012 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
 module Utility.CopyFile (copyFileExternal) where
 
-import System.Directory (doesFileExist, removeFile)
-import Control.Monad.IfElse
-
-import Utility.SafeCommand
+import Common
 import qualified Build.SysConfig as SysConfig
 
 {- The cp command is used, because I hate reinventing the wheel,
@@ -19,10 +16,10 @@ copyFileExternal :: FilePath -> FilePath -> IO Bool
 copyFileExternal src dest = do
 	whenM (doesFileExist dest) $
 		removeFile dest
-	boolSystem "cp" [params, File src, File dest]
+	boolSystem "cp" $ params ++ [File src, File dest]
 	where
-		params
-			| SysConfig.cp_reflink_auto = Params "--reflink=auto"
-			| SysConfig.cp_a = Params "-a"
-			| SysConfig.cp_p = Params "-p"
-			| otherwise = Params ""
+		params = map snd $ filter fst
+			[ (SysConfig.cp_reflink_auto, Param "--reflink=auto")
+			, (SysConfig.cp_a, Param "-a")
+			, (SysConfig.cp_p && not SysConfig.cp_a, Param "-p")
+			]

Utility/Directory.hs

@@ -15,26 +15,54 @@ import Control.Monad
 import Control.Monad.IfElse
 import System.FilePath
 import Control.Applicative
+import Control.Exception (bracket_)
+import System.Posix.Directory
+import System.IO.Unsafe (unsafeInterleaveIO)
 
 import Utility.SafeCommand
 import Utility.TempFile
 import Utility.Exception
+import Utility.Monad
+import Utility.Path
+
+dirCruft :: FilePath -> Bool
+dirCruft "." = True
+dirCruft ".." = True
+dirCruft _ = False
 
 {- Lists the contents of a directory.
  - Unlike getDirectoryContents, paths are not relative to the directory. -}
 dirContents :: FilePath -> IO [FilePath]
-dirContents d = map (d </>) . filter notcruft <$> getDirectoryContents d
+dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d
+
+{- Gets contents of directory, and then its subdirectories, recursively,
+ - and lazily. -}
+dirContentsRecursive :: FilePath -> IO [FilePath]
+dirContentsRecursive topdir = dirContentsRecursive' topdir [""]
+
+dirContentsRecursive' :: FilePath -> [FilePath] -> IO [FilePath]
+dirContentsRecursive' _ [] = return []
+dirContentsRecursive' topdir (dir:dirs) = unsafeInterleaveIO $ do
+	(files, dirs') <- collect [] [] =<< dirContents (topdir </> dir)
+	files' <- dirContentsRecursive' topdir (dirs' ++ dirs)
+	return (files ++ files')
 	where
-		notcruft "." = False
-		notcruft ".." = False
-		notcruft _ = True
+		collect files dirs' [] = return (reverse files, reverse dirs')
+		collect files dirs' (entry:entries)
+			| dirCruft entry = collect files dirs' entries
+			| otherwise = do
+				let dirEntry = dir </> entry
+				ifM (doesDirectoryExist $ topdir </> dirEntry)
+					( collect files (dirEntry:dirs') entries
+					, collect (dirEntry:files) dirs' entries
+					)			
 
 {- Moves one filename to another.
  - First tries a rename, but falls back to moving across devices if needed. -}
 moveFile :: FilePath -> FilePath -> IO ()
 moveFile src dest = tryIO (rename src dest) >>= onrename
 	where
-		onrename (Right _) = return ()
+		onrename (Right _) = noop
 		onrename (Left e)
 			| isPermissionError e = rethrow
 			| isDoesNotExistError e = rethrow
@@ -59,3 +87,14 @@ moveFile src dest = tryIO (rename src dest) >>= onrename
 			case r of
 				(Left _) -> return False
 				(Right s) -> return $ isDirectory s
+
+{- Runs an action in another directory. -}
+bracketCd :: FilePath -> IO a -> IO a
+bracketCd dir a = go =<< getCurrentDirectory
+	where
+		go cwd
+			| dirContains dir cwd = a
+			| otherwise = bracket_
+				(changeWorkingDirectory dir)
+				(changeWorkingDirectory cwd)
+				a

Utility/DiskFree.hs

@@ -15,10 +15,10 @@ import Foreign.C.Types
 import Foreign.C.String
 import Foreign.C.Error
 
-foreign import ccall unsafe "diskfree.h diskfree" c_diskfree
+foreign import ccall unsafe "libdiskfree.h diskfree" c_diskfree
 	:: CString -> IO CULLong
 
-getDiskFree :: String -> IO (Maybe Integer)
+getDiskFree :: FilePath -> IO (Maybe Integer)
 getDiskFree path = withFilePath path $ \c_path -> do
 	free <- c_diskfree c_path
 	ifM (safeErrno <$> getErrno)

Utility/FileMode.hs

@@ -1,35 +1,67 @@
 {- File mode utilities.
  -
- - Copyright 2010 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
 module Utility.FileMode where
 
-import System.Posix.Files
+import Common
+
+import Control.Exception (bracket)
 import System.Posix.Types
 import Foreign (complement)
 
-{- Removes a FileMode from a file.
- - For example, call with otherWriteMode to chmod o-w -}
-unsetFileMode :: FilePath -> FileMode -> IO ()
-unsetFileMode f m = do
+{- Applies a conversion function to a file's mode. -}
+modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO ()
+modifyFileMode f convert = void $ modifyFileMode' f convert
+modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode
+modifyFileMode' f convert = do
 	s <- getFileStatus f
-	setFileMode f $ fileMode s `intersectFileModes` complement m
+	let old = fileMode s
+	let new = convert old
+	when (new /= old) $
+		setFileMode f new
+	return old
+
+{- Adds the specified FileModes to the input mode, leaving the rest
+ - unchanged. -}
+addModes :: [FileMode] -> FileMode -> FileMode
+addModes ms m = combineModes (m:ms)
+
+{- Removes the specified FileModes from the input mode. -}
+removeModes :: [FileMode] -> FileMode -> FileMode
+removeModes ms m = m `intersectFileModes` complement (combineModes ms)
+
+{- Runs an action after changing a file's mode, then restores the old mode. -}
+withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a
+withModifiedFileMode file convert a = bracket setup cleanup go
+	where
+		setup = modifyFileMode' file convert
+		cleanup oldmode = modifyFileMode file (const oldmode)
+		go _ = a
+
+writeModes :: [FileMode]
+writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode]
+
+readModes :: [FileMode]
+readModes = [ownerReadMode, groupReadMode, otherReadMode]
 
 {- Removes the write bits from a file. -}
 preventWrite :: FilePath -> IO ()
-preventWrite f = unsetFileMode f writebits
-	where
-		writebits = foldl unionFileModes ownerWriteMode
-					[groupWriteMode, otherWriteMode]
+preventWrite f = modifyFileMode f $ removeModes writeModes
 
-{- Turns a file's write bit back on. -}
+{- Turns a file's owner write bit back on. -}
 allowWrite :: FilePath -> IO ()
-allowWrite f = do
-	s <- getFileStatus f
-	setFileMode f $ fileMode s `unionFileModes` ownerWriteMode
+allowWrite f = modifyFileMode f $ addModes [ownerWriteMode]
+
+{- Allows owner and group to read and write to a file. -}
+groupWriteRead :: FilePath -> IO ()
+groupWriteRead f = modifyFileMode f $ addModes
+	[ ownerWriteMode, groupWriteMode
+	, ownerReadMode, groupReadMode
+	]
 
 {- Checks if a file mode indicates it's a symlink. -}
 isSymLink :: FileMode -> Bool
@@ -37,7 +69,22 @@ isSymLink mode = symbolicLinkMode `intersectFileModes` mode == symbolicLinkMode
 
 {- Checks if a file has any executable bits set. -}
 isExecutable :: FileMode -> Bool
-isExecutable mode = ebits `intersectFileModes` mode /= 0
+isExecutable mode = combineModes ebits `intersectFileModes` mode /= 0
 	where
-		ebits = ownerExecuteMode `unionFileModes`
-			groupExecuteMode `unionFileModes` otherExecuteMode
+		ebits = [ownerExecuteMode, groupExecuteMode, otherExecuteMode]
+
+{- Runs an action without that pesky umask influencing it, unless the
+ - passed FileMode is the standard one. -}
+noUmask :: FileMode -> IO a -> IO a
+noUmask mode a
+	| mode == stdFileMode = a
+	| otherwise = bracket setup cleanup go
+	where
+		setup = setFileCreationMask nullFileMode
+		cleanup = setFileCreationMask
+		go _ = a
+
+combineModes :: [FileMode] -> FileMode
+combineModes [] = undefined
+combineModes [m] = m
+combineModes (m:ms) = foldl unionFileModes m ms

Utility/Gpg.hs

@@ -94,7 +94,18 @@ findPubKeys for = KeyIds . parse <$> readStrict params
 		pubKey = isPrefixOf "pub:"
 		keyIdField s = split ":" s !! 4
 
-
+{- Creates a block of high-quality random data suitable to use as a cipher.
+ - It is armored, to avoid newlines, since gpg only reads ciphers up to the
+ - first newline. -}
+genRandom :: Int -> IO String
+genRandom size = readStrict
+	[ Params "--gen-random --armor"
+	, Param $ show randomquality
+	, Param $ show size
+	]
+	where
+		-- 1 is /dev/urandom; 2 is /dev/random
+		randomquality = 1 :: Int
 
 {- A test key. This is provided pre-generated since generating a new gpg
  - key is too much work (requires too much entropy) for a test suite to

Utility/Inotify.hs

@@ -53,11 +53,10 @@ watchDir i test add del dir = watchDir' False i test add del dir
 watchDir' :: Bool -> INotify -> (FilePath -> Bool) -> Maybe (FilePath -> IO ()) -> Maybe (FilePath -> IO ()) -> FilePath -> IO ()
 watchDir' scan i test add del dir = do
 	if test dir
-		then do
+		then void $ do
 			_ <- addWatch i watchevents dir go
-			_ <- mapM walk =<< dirContents dir
-			return ()
-		else return ()
+			mapM walk =<< dirContents dir
+		else noop
 	where
 		watchevents
 			| isJust add && isJust del =
@@ -69,19 +68,19 @@ watchDir' scan i test add del dir = do
 		recurse = watchDir' scan i test add del
 		walk f = ifM (catchBoolIO $ Files.isDirectory <$> getFileStatus f)
 			( recurse f
-			, if scan && isJust add then fromJust add f else return ()
+			, when (scan && isJust add) $ fromJust add f
 			)
 
-		go (Created { isDirectory = False }) = return ()
+		go (Created { isDirectory = False }) = noop
 		go (Created { filePath = subdir }) = Just recurse <@> subdir
 		go (Closed { maybeFilePath = Just f }) = add <@> f
 		go (MovedIn { isDirectory = False, filePath = f }) = add <@> f
 		go (MovedOut { isDirectory = False, filePath = f }) = del <@> f
 		go (Deleted { isDirectory = False, filePath = f }) = del <@> f
-		go _ = return ()
+		go _ = noop
 		
 		Just a <@> f = a $ dir </> f
-		Nothing <@> _ = return ()
+		Nothing <@> _ = noop
 
 {- Pauses the main thread, letting children run until program termination. -}
 waitForTermination :: IO ()
@@ -92,6 +91,5 @@ waitForTermination = do
 		check keyboardSignal mv
 	takeMVar mv
 	where
-		check sig mv = do
-			_ <- installHandler sig (CatchOnce $ putMVar mv ()) Nothing
-			return ()
+		check sig mv = void $
+			installHandler sig (CatchOnce $ putMVar mv ()) Nothing

Utility/Monad.hs

@@ -49,3 +49,7 @@ observe observer a = do
 {- b `after` a runs first a, then b, and returns the value of a -}
 after :: Monad m => m b -> m a -> m a
 after = observe . const
+
+{- do nothing -}
+noop :: Monad m => m ()
+noop = return ()

Utility/Percentage.hs

@@ -0,0 +1,38 @@
+{- percentages
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.Percentage (
+	Percentage,
+	percentage,
+	showPercentage
+) where
+
+import Data.Ratio
+
+newtype Percentage = Percentage (Ratio Integer)
+
+instance Show Percentage where
+	show = showPercentage 0
+
+{- Normally the big number comes first. But 110% is allowed if desired. :) -}
+percentage :: Integer -> Integer -> Percentage
+percentage 0 _ = Percentage 0
+percentage full have = Percentage $ have * 100 % full
+
+{- Pretty-print a Percentage, with a specified level of precision. -}
+showPercentage :: Int -> Percentage -> String
+showPercentage precision (Percentage p)
+	| precision == 0 || remainder == 0 = go $ show int
+	| otherwise = go $ show int ++ "." ++ strip0s (show remainder)
+	where
+		go v = v ++ "%"
+		int :: Integer
+		(int, frac) = properFraction (fromRational p)
+		remainder = floor (frac * multiplier) :: Integer
+		strip0s = reverse . dropWhile (== '0') . reverse
+		multiplier :: Float
+		multiplier = 10 ** (fromIntegral precision)

Utility/RsyncFile.hs

@@ -58,7 +58,7 @@ rsyncUrlIsShell s
 	| "rsync://" `isPrefixOf` s = False
 	| otherwise = go s
 	where
-		-- host:dir is rsync protocol, while host:dir is ssh/rsh
+		-- host::dir is rsync protocol, while host:dir is ssh/rsh
 		go [] = False
 		go (c:cs)
 			| c == '/' = False -- got to directory with no colon

Utility/Touch.hsc

@@ -106,9 +106,8 @@ touchBoth file atime mtime follow =
 	withFilePath file $ \f -> do
 		pokeArray ptr [atime, mtime]
 		r <- syscall f ptr
-		if (r /= 0)
-			then throwErrno "touchBoth"
-			else return ()
+		when (r /= 0) $
+			throwErrno "touchBoth"
 	where
 		syscall = if follow
 			then c_lutimes

Utility/Url.hs

@@ -17,13 +17,16 @@ import Common
 import qualified Network.Browser as Browser
 import Network.HTTP
 import Network.URI
+import Data.Either
 
 type URLString = String
 
+type Headers = [String]
+
 {- Checks that an url exists and could be successfully downloaded,
  - also checking that its size, if available, matches a specified size. -}
-check :: URLString -> Maybe Integer -> IO Bool
-check url expected_size = handle <$> exists url
+check :: URLString -> Headers -> Maybe Integer -> IO Bool
+check url headers expected_size = handle <$> exists url headers
 	where
 		handle (False, _) = False
 		handle (True, Nothing) = True
@@ -31,12 +34,12 @@ check url expected_size = handle <$> exists url
 
 {- Checks that an url exists and could be successfully downloaded,
  - also returning its size if available. -}
-exists :: URLString -> IO (Bool, Maybe Integer)
-exists url =
+exists :: URLString -> Headers -> IO (Bool, Maybe Integer)
+exists url headers =
 	case parseURI url of
 		Nothing -> return (False, Nothing)
 		Just u -> do
-			r <- request u HEAD
+			r <- request u headers HEAD
 			case rspCode r of
 				(2,_,_) -> return (True, size r)
 				_ -> return (False, Nothing)
@@ -50,26 +53,27 @@ exists url =
  - would not be appropriate to test at configure time and build support
  - for only one in.
  -}
-download :: URLString -> [CommandParam] -> FilePath -> IO Bool
-download url options file = ifM (inPath "wget") (wget , curl)
+download :: URLString -> Headers -> [CommandParam] -> FilePath -> IO Bool
+download url headers options file = ifM (inPath "wget") (wget , curl)
 	where
-		wget = go "wget" [Params "-c -O"]
+		headerparams = map (\h -> Param $ "--header=" ++ h) headers
+		wget = go "wget" $ headerparams ++ [Params "-c -O"]
 		{- Uses the -# progress display, because the normal
 		 - one is very confusing when resuming, showing
 		 - the remainder to download as the whole file,
 		 - and not indicating how much percent was
 		 - downloaded before the resume. -}
-		curl = go "curl" [Params "-L -C - -# -o"]
+		curl = go "curl" $ headerparams ++ [Params "-L -C - -# -o"]
 		go cmd opts = boolSystem cmd $
 			options++opts++[File file, File url]
 
 {- Downloads a small file. -}
-get :: URLString -> IO String
-get url =
+get :: URLString -> Headers -> IO String
+get url headers =
 	case parseURI url of
 		Nothing -> error "url parse error"
 		Just u -> do
-			r <- request u GET
+			r <- request u headers GET
 			case rspCode r of
 				(2,_,_) -> return $ rspBody r
 				_ -> error $ rspReason r
@@ -81,8 +85,8 @@ get url =
  - This does its own redirect following because Browser's is buggy for HEAD
  - requests.
  -}
-request :: URI -> RequestMethod -> IO (Response String)
-request url requesttype = go 5 url
+request :: URI -> Headers -> RequestMethod -> IO (Response String)
+request url headers requesttype = go 5 url
 	where
 		go :: Int -> URI -> IO (Response String)
 		go 0 _ = error "Too many redirects "
@@ -91,11 +95,12 @@ request url requesttype = go 5 url
 				Browser.setErrHandler ignore
 				Browser.setOutHandler ignore
 				Browser.setAllowRedirects False
-				snd <$> Browser.request (mkRequest requesttype u :: Request_String)
+				let req = mkRequest requesttype u :: Request_String
+				snd <$> Browser.request (addheaders req)
 			case rspCode rsp of
 				(3,0,x) | x /= 5 -> redir (n - 1) u rsp
 				_ -> return rsp
-		ignore = const $ return ()
+		ignore = const noop
 		redir n u rsp = case retrieveHeaders HdrLocation rsp of
 			[] -> return rsp
 			(Header _ newu:_) ->
@@ -104,3 +109,5 @@ request url requesttype = go 5 url
 					Just newURI -> go n newURI_abs
 						where
 							newURI_abs = fromMaybe newURI (newURI `relativeTo` u)
+		addheaders req = setHeaders req (rqHeaders req ++ userheaders)
+		userheaders = rights $ map parseHeader headers

Utility/libdiskfree.c

@@ -58,9 +58,10 @@ unsigned long long int diskfree(const char *path) {
 	unsigned long long int available, blocksize;
 	struct STATSTRUCT buf;
 
-	errno = 0;
 	if (STATCALL(path, &buf) != 0)
 		return 0; /* errno is set */
+	else
+		errno = 0;
 
 	available = buf.f_bavail;
 	blocksize = buf.f_bsize;

debian/changelog

@@ -1,4 +1,58 @@
-git-annex (3.20120407) UNRELEASED; urgency=low
+git-annex (3.20120523) UNRELEASED; urgency=low
+
+  * sync: Show a nicer message if a user tries to sync to a special remote.
+  * lock: Reset unlocked file to index, rather than to branch head.
+  * import: New subcommand, pulls files from a directory outside the annex
+    and adds them.
+  * Fix display of warning message when encountering a file that uses an
+    unsupported backend.
+  * Require that the SHA256 backend can be used when building, since it's the
+    default.
+
+ -- Joey Hess <joeyh@debian.org>  Sun, 27 May 2012 20:55:29 -0400
+
+git-annex (3.20120522) unstable; urgency=low
+
+  * Pass -a to cp even when it supports --reflink=auto, to preserve
+    permissions.
+  * Clean up handling of git directory and git worktree.
+  * Add support for core.worktree, and fix support for GIT_WORK_TREE and
+    GIT_DIR.
+
+ -- Joey Hess <joeyh@debian.org>  Tue, 22 May 2012 11:16:13 -0400
+
+git-annex (3.20120511) unstable; urgency=low
+
+  * Rsync special remotes can be configured with shellescape=no
+    to avoid shell quoting that is normally done when using rsync over ssh.
+    This is known to be needed for certian rsync hosting providers
+    (specificially hidrive.strato.com) that use rsync over ssh but do not
+    pass it through the shell.
+  * dropunused: Allow specifying ranges to drop.
+  * addunused: New command, the opposite of dropunused, it relinks unused
+    content into the git repository.
+  * Fix use of several config settings: annex.ssh-options,
+    annex.rsync-options, annex.bup-split-options. (And adjust types to avoid
+    the bugs that broke several config settings.)
+
+ -- Joey Hess <joeyh@debian.org>  Fri, 11 May 2012 12:29:30 -0400
+
+git-annex (3.20120430) unstable; urgency=low
+
+  * Fix use of annex.diskreserve config setting.
+  * Directory special remotes now check annex.diskreserve.
+  * Support git's core.sharedRepository configuration.
+  * Add annex.http-headers and annex.http-headers-command config
+    settings, to allow custom headers to be sent with all HTTP requests.
+    (Requested by the Internet Archive)
+  * uninit: Clear annex.uuid from .git/config. Closes: #670639
+  * Added shared cipher mode to encryptable special remotes. This option
+    avoids gpg key distribution, at the expense of flexability, and with
+    the requirement that all clones of the git repository be equally trusted.
+
+ -- Joey Hess <joeyh@debian.org>  Mon, 30 Apr 2012 13:16:10 -0400
+
+git-annex (3.20120418) unstable; urgency=low
 
   * bugfix: Adding a dotfile also caused all non-dotfiles to be added.
   * bup: Properly handle key names with spaces or other things that are
@@ -7,8 +61,11 @@ git-annex (3.20120407) UNRELEASED; urgency=low
     configuration setting, doing fuzzy matching using the restricted
     Damerau-Levenshtein edit distance, just as git does. This adds a build
     dependency on the haskell edit-distance library.
+  * Renamed diskfree.c to avoid OSX case insensativity bug.
+  * cabal now installs git-annex-shell as a symlink to git-annex.
+  * cabal file now autodetects whether S3 support is available.
 
- -- Joey Hess <joeyh@debian.org>  Sun, 08 Apr 2012 12:23:42 -0400
+ -- Joey Hess <joeyh@debian.org>  Wed, 18 Apr 2012 12:11:32 -0400
 
 git-annex (3.20120406) unstable; urgency=low
 

debian/copyright

@@ -7,3 +7,9 @@ License: GPL-3+
  The full text of version 3 of the GPL is distributed as doc/GPL in
  this package's source, or in /usr/share/common-licenses/GPL-3 on
  Debian systems.
+
+Files: doc/logo.png doc/logo_small.png doc/favicon.png
+Copyright: 2007 Henrik Nyh <http://henrik.nyh.se/>
+           2010 Joey Hess <joey@kitenet.net>
+License: other
+  Free to modify and redistribute with due credit, and obviously free to use.

doc/bare_repositories.mdwn

@@ -26,6 +26,7 @@ Here is a quick example of how to set this up, using `origin` as the remote name
 On the server:
 
     mkdir bare-annex
+    cd bare-annex
     git init --bare
     git annex init origin
 

doc/bugs/Error___39__get__39__ting_files_from_rsync_remote__44___versions_3.20120315_and_3.20120430.mdwn

@@ -0,0 +1,79 @@
+What steps will reproduce the problem?
+
+	$ git annex initremote rsyncremote type=rsync rsyncurl=myuser@rsync.hidrive.strato.com:/users/myuser/git-annex/Music/ encryption=0xC597DECC177AFD7C
+	$ git annex get --from rsyncremote "file"
+
+What is the expected output? What do you see instead?
+
+I expect that the requested file is copied as for every other remote, but instead I get this error:
+
+----------------------------------------
+	get <file> (from rsyncremote...) (gpg) 
+	rsync: change_dir "/users/myuser/git-annex/Music/0e5/a5b/'GPGHMACSHA1--3afd32ab8e70ac329262adeb770c330b0845b1e0" failed: No such file or directory (2)
+
+	sent 8 bytes  received 10 bytes  7.20 bytes/sec
+	total size is 0  speedup is 0.00
+	rsync error: some files/attrs were not transferred (see previous errors) (code 23) at main.c(1518) [Receiver=3.0.9]
+
+	  rsync failed -- run git annex again to resume file transfer
+
+	rsync: change_dir "/users/myuser/git-annex/Music/8k/QZ/'GPGHMACSHA1--3afd32ab8e70ac329262adeb770c330b0845b1e0" failed: No such file or directory (2)
+
+	sent 8 bytes  received 10 bytes  36.00 bytes/sec
+	total size is 0  speedup is 0.00
+	rsync error: some files/attrs were not transferred (see previous errors) (code 23) at main.c(1518) [Receiver=3.0.9]
+
+	  rsync failed -- run git annex again to resume file transfer
+failed
+	git-annex: get: 1 failed
+----------------------------------------
+
+I can verify that the directory /users/myuser/git-annex/Music/0e5/a5b/GPGHMACSHA1--3afd32ab8e70ac329262adeb770c330b0845b1e0 exists in the rsync remote, without the ' character.
+
+What version of git-annex are you using? On what operating system?
+
+I tried versions 3.20120315 and 3.20120430 on Gentoo linux.
+
+	$ uname -a
+	Linux odin 3.3.1-gentoo-odin #1 SMP Sat Apr 7 21:18:11 CEST 2012 x86_64 Intel(R) Core(TM) i5 CPU M 560 @ 2.67GHz GenuineIntel GNU/Linux
+
+	$ ghc --version
+	The Glorious Glasgow Haskell Compilation System, version 7.4.1
+
+Please provide any additional information below.
+
+The rsync remote config in .git/config:
+
+	[remote "rsyncremote"]
+		annex-rsyncurl = myuser@rsync.hidrive.strato.com:/users/myuser/git-annex/Music/
+		annex-uuid = "UUID"
+
+> Here's what the --debug flag shows is being run: --[[Joey]] 
+
+	Running: rsync ["--progress","--inplace","joey@localhost:/tmp/Music/d98/a3c/'GPGHMACSHA1--878c3a3f59965bd87b4738ab29562efd215b954c/GPGHMACSHA1--878c3a3f59965bd87b4738ab29562efd215b954c'","/home/joey/tmp/x/.git/annex/tmp/GPGHMACSHA1--878c3a3f59965bd87b4738ab29562efd215b954c"] 
+
+> But, this works for me, here, despite containing the quoting!
+> That's because here it's using rsync over ssh, which actually requires
+> that quoting. Are you using rsync
+> over the rsync protocol? If so, the workaround is to explicitly make
+> the rsyncurl start with `rsync://`
+> 
+> And if this is the case, I need
+> to adjust the code in git-annex that determines if it's using ssh or
+> the rsync protocol. It assumes that (and this is what the rsync man 
+> says AFAICS) that the rsync protocol is only used if the url starts
+> with `rsync://` or contains `::`.
+> 
+>> Nope, it is indeed using rsync over ssh as git-annex thought.
+> 
+> Hmm, I see that `hidrive.strato.com` is some kind of rsync provider?
+> Perhaps they do something with rsync over ssh that
+> avoids the need for shell quoting. For example, they might pass incoming
+> ssh connections directly into rsync, bypassing the shell
+> -- which avoids the need for this quoting. Any details you can provide
+> about them would probably be useful then. Ie, do they really use rsync
+> over ssh, is it really a `rsync.net` type rsync provider? 
+>  --[[Joey]]
+> 
+>> This was the case, and the shellescape=no config option has been added
+>> to rsync special remotes to deal with it. [[done]] --[[Joey]] 

doc/bugs/GIT_DIR_support_incomplete.mdwn

@@ -0,0 +1,17 @@
+`GIT_DIR` support isn't right. Git does not look for `GIT_DIR/.git`;
+git-annex does.
+
+Also, to support this scenario, support for core.worktree needs to be added
+as well:
+
+	mkdir repo workdir
+	git --work-tree=$PWD/workdir --git-dir=$PWD/repo init
+	export GIT_DIR=$PWD/repo
+	git status
+	# ok
+	git annex init "new repo"
+	# fail
+
+--[[Joey]] 
+
+> [[fixed|done]] --[[Joey]] 

doc/bugs/add_range_argument_to___34__git_annex_dropunused__34___.mdwn

@@ -16,3 +16,6 @@ I work around this lack as I want to drop all unused files anyway by something l
 
 > I don't see adding my own range operations to be an improvement worth
 > making; it'd arguably only be a complication. --[[Joey]] [[done]]
+
+>> Actually, this did get implemented, since using seq could fall afoul 
+>> of command-line length limits in extreme cases.

doc/bugs/case-insensitive.mdwn

@@ -0,0 +1,20 @@
+What steps will reproduce the problem?
+
+> Building git-annex on the ghc7.0 branch on a Mac with the default case-insensitive file system
+
+What is the expected output? What do you see instead?
+
+> Expected: build successfully; instead: 
+     
+    ld: duplicate symbol _UtilityziDiskFree_zdwa_info in dist/build/git-annex/git-annex-tmp/Utility/diskfree.o and dist/build/git-annex/git-annex-tmp/Utility/DiskFree.o for architecture x86_64
+
+What version of git-annex are you using? On what operating system?
+
+> commit `0bd5c90ef0518f75d52f0c5889422d8233df847d` on a Mac OS 10.6 and 10.7, using the Haskell Platform 2012.04
+
+Please provide any additional information below.
+
+> The problem is that since `DiskFree.hs` generates `DiskFree.o` and `diskfree.c` generates `diskfree.o`, a case-insensitive file system overwrites one object file with the other.  Renaming `diskfree.c` to `diskfreec.c` and changing the corresponding filenames in `git-annex.cabal` fixes the problem.
+
+>> Man, not this again. The 80's called, they want their 
+>> unix portability wars back. [[fixed|done]]. --[[Joey]]

doc/bugs/git_rename_detection_on_file_move/comment_10_5ec2f965c80cc5dd31ee3c4edb695664._comment

@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="https://www.google.com/accounts/o8/id?id=AItOawnpdM9F8VbtQ_H5PaPMpGSxPe_d5L1eJ6w"
+ nickname="Rafael"
+ subject="comment 10"
+ date="2012-05-15T07:36:25Z"
+ content="""
+Won't git itself be fixed on this issue? It was on my plans to look into that, however I don't know how difficult it will be.
+"""]]

doc/bugs/unlock_then_lock_of_uncommitted_file_loses_it.mdwn

@@ -0,0 +1,7 @@
+Add a file (do not commit), then unlock it, and then lock it.
+There is an error and the symlink gets deleted.
+
+The file will still be staged in the index, and the file content is still
+in the annex. --[[Joey]] 
+
+[[done]]

doc/design/assistant.mdwn

@@ -0,0 +1,20 @@
+The git-annex assistant is being
+[crowd funded on Kickstarter](http://www.kickstarter.com/projects/joeyh/git-annex-assistant-like-dropbox-but-with-your-own/).
+
+This is my design and plan for developing it.
+Still being fleshed out, still many ideas and use cases to add.
+Feel free to chip in with comments! --[[Joey]]
+
+## roadmap
+
+* Month 1 "like dropbox": [[!traillink inotify]] [[!traillink syncing]]
+* Month 2 "shiny webapp": [[!traillink webapp]] [[!traillink progressbars]]
+* Month 3 "easy setup": [[!traillink configurators]] [[!traillink pairing]]
+* Month 4 "polishing": [[!traillink cloud]] [[!traillink leftovers]]
+* Months 5-6 "9k bonus round": [[!traillink Android]] [[!traillink partial_content]]
+
+## not yet on the map:
+
+* [[desymlink]]
+* [[deltas]]
+* In my overfunded nighmares: [[Windows]]

doc/design/assistant/android.mdwn

@@ -0,0 +1,64 @@
+Porting git-annex to Android will use the Android native SDK.
+
+A hopefully small Java app will be developed, which runs the webapp
+daemon, and a web browser to display it.
+
+### programs to port
+
+These will probably need to be bundled into the Android app, unless already
+available in the App Store.
+
+* ssh (native ssh needed for scp, not a client like ConnectBot)
+* rsync
+* gpg
+* git (not all git commands are needed,
+  but core plumbing and a few like `git-add` are.)
+
+### Android specific features
+
+The app should be aware of power status, and avoid expensive background
+jobs when low on battery or run flat out when plugged in.
+
+The app should be aware of network status, and avoid expensive data
+transfers when not on wifi. This may need to be configurable.
+
+### FAT sucks
+
+The main media partition will use some awful FAT filesystem format from
+1982 that cannot support git-annex's symlinks. (Hopefully it can at least
+handle all of git's filenames.) Possible approaches to this follow.
+
+(May want to consider which of these would make a Windows port easier too.)
+
+#### bare git repo with file browser
+
+Keep only a bare git repo on Android. The app would then need to include
+a file browser to access the files in there, and adding a file would move
+it into the repo.
+
+Not ideal.
+
+Could be improved some by registering git-annex as a file handling app on
+Android, allowing you to "send to" git-annex.
+
+#### implement git smudge filters
+
+See [[todo/smudge]].
+
+Difficult. Would make git-annex generally better.
+
+#### keep files outside bare git repo
+
+Use a bare git repo but don't keep files in `annex/objects`, instead
+leave them outside the repo, and add some local mapping to find them.
+
+Problem: Would leave files unlocked to modification, which might lose a
+version git-annex dependend upon existing on the phone. (Maybe the phone
+would have to be always considered an untrusted repo, which probably
+makes sense anyway.)
+
+Problem: 
+
+#### crazy `LD_PRELOAD` wrapper
+
+Need I say more? (Also, Android's linker may not even support it.)

doc/design/assistant/android/comment_1_8be9a74e5fc4641c2bf2e1bb7673dd59._comment

@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="https://launchpad.net/~gdr-go2"
+ nickname="gdr-go2"
+ subject="FAT symlinks"
+ date="2012-05-28T18:12:10Z"
+ content="""
+It's a linux kernel so perhaps another option would be to create a big file and mount -o loop
+"""]]

doc/design/assistant/cloud.mdwn

@@ -0,0 +1,43 @@
+The [[syncing]] design assumes the network is connected. But it's often
+not in these pre-IPV6 days, so the cloud needs to be used to bridge between
+LANS.
+
+## more cloud providers
+
+Git-annex already supports storing large files in 
+several cloud providers via [[special_remotes]].
+More should be added, such as:
+
+* Google drive (attractive because it's free, only 5 gb tho)
+* OpenStack Swift (teh future)
+* Box.com (it's free, and current method is hard to set up and a sorta
+  shakey; a better method would be to use its API)
+* Dropbox? That would be ironic.. Via its API, presumably.
+
+## limited space
+
+When syncing via the cloud, space there is probably limited, so
+users with more files than cloud space will want to be able to use the
+cloud as a temporary transfer point, which files are removed from after
+they've propigated out.
+
+Other users will want to use the cloud as the canonical or backup location
+of their data, and would want a copy of all their files to be kept there.
+That's also ok.
+
+git-annex will need a way to tell the difference between these, either
+heuristically, or via configuration.
+
+Also needed for USB keys and Android gadgets.
+
+## storing git repos in the cloud
+
+Of course, one option is to just use github etc to store the git repo.
+
+Two things can store git repos in Anazon S3:
+* <http://gabrito.com/post/storing-git-repositories-in-amazon-s3-for-high-availability>
+* <http://wiki.cs.pdx.edu/oss2009/index/projects/gits3.html>
+
+Another option is to not store the git repo in the cloud, but push/pull
+peer-to-peer. When peers cannot directly talk to one-another, this could be
+bounced through something like XMPP.

doc/design/assistant/comment_1_a48fcfbf97f0a373ea375cd8f07f0fc8._comment

@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="https://www.google.com/accounts/o8/id?id=AItOawkSq2FDpK2n66QRUxtqqdbyDuwgbQmUWus"
+ nickname="Jimmy"
+ subject="comment 1"
+ date="2012-06-02T12:06:37Z"
+ content="""
+Will statically linked binaries be provided for say Linux, OSX and *BSD?  I think having some statically linked binaries will certainly help and appeal to a lot of users.
+"""]]

doc/design/assistant/configurators.mdwn

@@ -0,0 +1,18 @@
+Add to the [[webapp]] some configuration of git-annex.
+
+There are some basic settings that pass through to `git config`, things
+like how much disk space to leave free, how many copies to ensure are kept
+of files, etc.
+
+The meat of the configuration will be in configuration assistants that walk
+through setting up common use cases.
+
+* Create a repository (run when the web app is started without a configured
+  repository too).
+* Clone this repo to a USB drive.
+* Clone this repo to another host. (Needs [[pairing]])
+* Set up Amazon S3.
+* Set up rsync remote.
+* Set up encryption.
+* I lost my USB drive!
+* etc -- many more possibilities