Merge branch 'master' of git://git-annex.branchable.com

Annex.hs

@@ -58,6 +58,7 @@ import Types.UUID
 import Types.FileMatcher
 import Types.NumCopies
 import Types.LockPool
+import Types.MetaData
 import qualified Utility.Matcher
 import qualified Data.Map as M
 import qualified Data.Set as S
@@ -109,6 +110,7 @@ data AnnexState = AnnexState
 	, lockpool :: LockPool
 	, flags :: M.Map String Bool
 	, fields :: M.Map String String
+	, modmeta :: [ModMeta]
 	, cleanup :: M.Map String (Annex ())
 	, inodeschanged :: Maybe Bool
 	, useragent :: Maybe String
@@ -146,6 +148,7 @@ newState c r = AnnexState
 	, lockpool = M.empty
 	, flags = M.empty
 	, fields = M.empty
+	, modmeta = []
 	, cleanup = M.empty
 	, inodeschanged = Nothing
 	, useragent = Nothing

Annex/Branch.hs

@@ -5,8 +5,6 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP #-}
-
 module Annex.Branch (
 	fullname,
 	name,
@@ -30,11 +28,11 @@ module Annex.Branch (
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified Data.Set as S
 import qualified Data.Map as M
-import qualified Control.Exception as E
 
 import Common.Annex
 import Annex.BranchState
 import Annex.Journal
+import Annex.Index
 import qualified Git
 import qualified Git.Command
 import qualified Git.Ref
@@ -47,15 +45,12 @@ import Git.Types
 import Git.FilePath
 import Annex.CatFile
 import Annex.Perms
-import qualified Annex
-import Utility.Env
 import Logs
 import Logs.Transitions
 import Logs.Trust.Pure
 import Annex.ReplaceFile
 import qualified Annex.Queue
 import Annex.Branch.Transitions
-import Annex.Exception
 
 {- Name of the branch that is used to store git-annex's information. -}
 name :: Git.Ref
@@ -63,11 +58,11 @@ name = Git.Ref "git-annex"
 
 {- Fully qualified name of the branch. -}
 fullname :: Git.Ref
-fullname = Git.Ref $ "refs/heads/" ++ show name
+fullname = Git.Ref $ "refs/heads/" ++ fromRef name
 
 {- Branch's name in origin. -}
 originname :: Git.Ref
-originname = Git.Ref $ "origin/" ++ show name
+originname = Git.Ref $ "origin/" ++ fromRef name
 
 {- Does origin/git-annex exist? -}
 hasOrigin :: Annex Bool
@@ -92,8 +87,8 @@ getBranch = maybe (hasOrigin >>= go >>= use) return =<< branchsha
   where
 	go True = do
 		inRepo $ Git.Command.run
-			[Param "branch", Param $ show name, Param $ show originname]
+			[Param "branch", Param $ fromRef name, Param $ fromRef originname]
-		fromMaybe (error $ "failed to create " ++ show name)
+		fromMaybe (error $ "failed to create " ++ fromRef name)
 			<$> branchsha
 	go False = withIndex' True $
 		inRepo $ Git.Branch.commitAlways "branch created" fullname []
@@ -159,7 +154,7 @@ updateTo pairs = do
 			then "update"
 			else "merging " ++
 				unwords (map Git.Ref.describe branches) ++ 
-				" into " ++ show name
+				" into " ++ fromRef name
 		localtransitions <- parseTransitionsStrictly "local"
 			<$> getLocal transitionsLog
 		unless (null branches) $ do
@@ -296,7 +291,7 @@ files = do
 branchFiles :: Annex [FilePath]
 branchFiles = withIndex $ inRepo $ Git.Command.pipeNullSplitZombie
 	[ Params "ls-tree --name-only -r -z"
-	, Param $ show fullname
+	, Param $ fromRef fullname
 	]
 
 {- Populates the branch's index file with the current branch contents.
@@ -338,32 +333,12 @@ withIndex = withIndex' False
 withIndex' :: Bool -> Annex a -> Annex a
 withIndex' bootstrapping a = do
 	f <- fromRepo gitAnnexIndex
-	g <- gitRepo
+	withIndexFile f $ do
-#ifdef __ANDROID__
-	{- This should not be necessary on Android, but there is some
-	 - weird getEnvironment breakage. See
-	 - https://github.com/neurocyte/ghc-android/issues/7
-	 - Use getEnv to get some key environment variables that
-	 - git expects to have. -}
-	let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME"
-	let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k
-	e <- liftIO $ catMaybes <$> forM keyenv getEnvPair
-	let e' = ("GIT_INDEX_FILE", f):e
-#else
-	e <- liftIO getEnvironment
-	let e' = addEntry "GIT_INDEX_FILE" f e
-#endif
-	let g' = g { gitEnv = Just e' }
-
-	r <- tryAnnex $ do
-		Annex.changeState $ \s -> s { Annex.repo = g' }
 		checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do
 			unless bootstrapping create
 			createAnnexDirectory $ takeDirectory f
 			unless bootstrapping $ inRepo genIndex
 		a
-	Annex.changeState $ \s -> s { Annex.repo = (Annex.repo s) { gitEnv = gitEnv g} }
-	either E.throw return r
 
 {- Updates the branch's index to reflect the current contents of the branch.
  - Any changes staged in the index will be preserved.
@@ -393,7 +368,7 @@ needUpdateIndex branchref = do
 setIndexSha :: Git.Ref -> Annex ()
 setIndexSha ref = do
 	f <- fromRepo gitAnnexIndexStatus
-	liftIO $ writeFile f $ show ref ++ "\n"
+	liftIO $ writeFile f $ fromRef ref ++ "\n"
 	setAnnexFilePerm f
 
 {- Stages the journal into the index and returns an action that will
@@ -467,7 +442,7 @@ ignoreRefs rs = do
 	let s = S.unions [old, S.fromList rs]
 	f <- fromRepo gitAnnexIgnoredRefs
 	replaceFile f $ \tmp -> liftIO $ writeFile tmp $
-		unlines $ map show $ S.elems s
+		unlines $ map fromRef $ S.elems s
 
 getIgnoredRefs :: Annex (S.Set Git.Ref)
 getIgnoredRefs = S.fromList . mapMaybe Git.Sha.extractSha . lines <$> content

Annex/Branch/Transitions.hs

@@ -41,7 +41,7 @@ dropDead f content trustmap = case getLogVariety f of
 		in if null newlog
 			then RemoveFile
 			else ChangeFile $ Presence.showLog newlog
-	Just SingleValueLog -> PreserveFile
+	Just OtherLog -> PreserveFile
 	Nothing -> PreserveFile
 
 dropDeadFromUUIDBasedLog :: TrustMap -> UUIDBased.Log String -> UUIDBased.Log String

Annex/Content.hs

@@ -243,10 +243,9 @@ finishGetViaTmp check key action = do
 			moveAnnex key tmpfile
 			logStatus key InfoPresent
 			return True
-		, do
 		-- the tmp file is left behind, in case caller wants
 		-- to resume its transfer
-			return False
+		, return False
 		)
 
 prepTmp :: Key -> Annex FilePath
@@ -492,9 +491,11 @@ getKeysPresent = do
 
 	{- In indirect mode, look for the key. In direct mode,
 	 - the inode cache file is only present when a key's content
-	 - is present. -}
+	 - is present, so can be used as a surrogate if the content
+	 - is not located in the annex directory. -}
 	present False d = doesFileExist $ contentfile d
-	present True d = doesFileExist $ contentfile d ++ ".cache"
+	present True d = doesFileExist (contentfile d ++ ".cache")
+		<||> present False d
 	contentfile d = d </> takeFileName d
 
 {- Things to do to record changes to content when shutting down.

Annex/Content/Direct.hs

@@ -66,7 +66,7 @@ changeAssociatedFiles key transform = do
 	mapping <- calcRepo $ gitAnnexMapping key
 	files <- associatedFilesRelative key
 	let files' = transform files
-	when (files /= files') $ do
+	when (files /= files') $
 		modifyContent mapping $
 			liftIO $ viaTmp writeFileAnyEncoding mapping $
 				unlines files'

Annex/Direct.hs

@@ -184,7 +184,7 @@ mergeDirectCleanup d oldsha newsha = do
 			tryAnnex . maybe (araw f item) (\k -> void $ a k f)
 				=<< catKey (getsha item) (getmode item)
 
-	moveout k f = removeDirect k f
+	moveout = removeDirect
 
 	{- Files deleted by the merge are removed from the work tree.
 	 - Empty work tree directories are removed, per git behavior. -}
@@ -286,18 +286,18 @@ setDirect wantdirect = do
  - this way things that show HEAD (eg shell prompts) will
  - hopefully show just "master". -}
 directBranch :: Ref -> Ref
-directBranch orighead = case split "/" $ show orighead of
+directBranch orighead = case split "/" $ fromRef orighead of
 	("refs":"heads":"annex":"direct":_) -> orighead
 	("refs":"heads":rest) ->
 		Ref $ "refs/heads/annex/direct/" ++ intercalate "/" rest
-	_ -> Ref $ "refs/heads/" ++ show (Git.Ref.base orighead)
+	_ -> Ref $ "refs/heads/" ++ fromRef (Git.Ref.base orighead)
 
 {- Converts a directBranch back to the original branch.
  -
  - Any other ref is left unchanged.
  -}
 fromDirectBranch :: Ref -> Ref
-fromDirectBranch directhead = case split "/" $ show directhead of
+fromDirectBranch directhead = case split "/" $ fromRef directhead of
 	("refs":"heads":"annex":"direct":rest) -> 
 		Ref $ "refs/heads/" ++ intercalate "/" rest
 	_ -> directhead

Annex/FileMatcher.hs

@@ -43,7 +43,7 @@ checkMatcher matcher mkey afile notpresent def
 fileMatchInfo :: FilePath -> Annex MatchInfo
 fileMatchInfo file = do
 	matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)
-	return $ MatchingFile $ FileInfo
+	return $ MatchingFile FileInfo
 		{ matchFile = matchfile
 		, relFile = file
 		}
@@ -83,6 +83,7 @@ parseToken checkpresent checkpreferreddir groupmap t
 			, ("inbackend", limitInBackend)
 			, ("largerthan", limitSize (>))
 			, ("smallerthan", limitSize (<))
+			, ("metadata", limitMetaData)
 			, ("inallgroup", limitInAllGroup groupmap)
 			]
   where

Annex/Index.hs

@@ -0,0 +1,46 @@
+{- Using other git index files
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Index (
+	withIndexFile,
+) where
+
+import qualified Control.Exception as E
+
+import Common.Annex
+import Git.Types
+import qualified Annex
+import Utility.Env
+import Annex.Exception
+
+{- Runs an action using a different git index file. -}
+withIndexFile :: FilePath -> Annex a -> Annex a
+withIndexFile f a = do
+	g <- gitRepo
+#ifdef __ANDROID__
+	{- This should not be necessary on Android, but there is some
+	 - weird getEnvironment breakage. See
+	 - https://github.com/neurocyte/ghc-android/issues/7
+	 - Use getEnv to get some key environment variables that
+	 - git expects to have. -}
+	let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME"
+	let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k
+	e <- liftIO $ catMaybes <$> forM keyenv getEnvPair
+	let e' = ("GIT_INDEX_FILE", f):e
+#else
+	e <- liftIO getEnvironment
+	let e' = addEntry "GIT_INDEX_FILE" f e
+#endif
+	let g' = g { gitEnv = Just e' }
+
+	r <- tryAnnex $ do
+		Annex.changeState $ \s -> s { Annex.repo = g' }
+		a
+	Annex.changeState $ \s -> s { Annex.repo = (Annex.repo s) { gitEnv = gitEnv g} }
+	either E.throw return r

Annex/Init.hs

@@ -70,10 +70,9 @@ initialize mdescription = do
 		( do
 			enableDirectMode
 			setDirect True
-		, do
 		-- Handle case where this repo was cloned from a
-			-- direct mode repo.
+		-- direct mode repo
-			unlessM isBare
+		, unlessM isBare
 			switchHEADBack
 		)
 	createInodeSentinalFile
@@ -227,7 +226,7 @@ fixBadBare = whenM checkBadBare $ do
 		logStatus k InfoPresent
 	let dotgit = d </> ".git"
 	liftIO $ removeDirectoryRecursive dotgit
-		`catchIO` (const $ renameDirectory dotgit (d </> "removeme"))
+		`catchIO` const (renameDirectory dotgit (d </> "removeme"))
 
 {- A repostory with the problem won't know it's a bare repository, but will
  - have no pre-commit hook (which is not set up in a bare repository),

Annex/Link.hs

@@ -94,6 +94,10 @@ hashSymlink :: LinkTarget -> Annex Sha
 hashSymlink linktarget = inRepo $ Git.HashObject.hashObject BlobObject $ 
 	toInternalGitPath linktarget
 
+hashSymlink' :: Git.HashObject.HashObjectHandle -> LinkTarget -> Annex Sha
+hashSymlink' h linktarget = liftIO $ Git.HashObject.hashBlob h $
+	toInternalGitPath linktarget
+
 {- Stages a symlink to the annex, using a Sha of its target. -}
 stageSymlink :: FilePath -> Sha -> Annex ()
 stageSymlink file sha =

Annex/Ssh.hs

@@ -76,7 +76,7 @@ bestSocketPath abssocketfile = do
   	-- ssh appends a 16 char extension to the socket when setting it
 	-- up, which needs to be taken into account when checking
 	-- that a valid socket was constructed.
-  	sshgarbage = take (1+16) $ repeat 'X'
+  	sshgarbage = replicate (1+16) 'X'
 
 sshConnectionCachingParams :: FilePath -> [CommandParam]
 sshConnectionCachingParams socketfile = 

Annex/TaggedPush.hs

@@ -35,11 +35,11 @@ toTaggedBranch u info b = Git.Ref $ intercalate "/" $ catMaybes
 	[ Just "refs/synced"
 	, Just $ fromUUID u
 	, toB64 <$> info
-	, Just $ show $ Git.Ref.base b
+	, Just $ Git.fromRef $ Git.Ref.base b
 	]
 
 fromTaggedBranch :: Git.Branch -> Maybe (UUID, Maybe String)
-fromTaggedBranch b = case split "/" $ show b of
+fromTaggedBranch b = case split "/" $ Git.fromRef b of
 	("refs":"synced":u:info:_base) ->
 		Just (toUUID u, fromB64Maybe info)
 	("refs":"synced":u:_base) ->
@@ -58,4 +58,4 @@ taggedPush u info branch remote = Git.Command.runBool
         , Param $ refspec branch
         ]
   where
-	refspec b = show b ++ ":" ++ show (toTaggedBranch u info b)
+	refspec b = Git.fromRef b ++ ":" ++ Git.fromRef (toTaggedBranch u info b)

Annex/View.hs

@@ -0,0 +1,429 @@
+{- metadata based branch views
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.View where
+
+import Common.Annex
+import Types.View
+import Types.MetaData
+import qualified Git
+import qualified Git.DiffTree as DiffTree
+import qualified Git.Branch
+import qualified Git.LsFiles
+import qualified Git.Ref
+import Git.UpdateIndex
+import Git.Sha
+import Git.HashObject
+import Git.Types
+import Git.FilePath
+import qualified Backend
+import Annex.Index
+import Annex.Link
+import Annex.CatFile
+import Logs.MetaData
+import Logs.View
+import Utility.FileMode
+import Types.Command
+import Config
+import CmdLine.Action
+
+import qualified Data.Set as S
+import System.Path.WildMatch
+import "mtl" Control.Monad.Writer
+
+#ifdef WITH_TDFA
+import Text.Regex.TDFA
+import Text.Regex.TDFA.String
+#else
+import Text.Regex
+#endif
+
+{- Each visible ViewFilter in a view results in another level of
+ - subdirectory nesting. When a file matches multiple ways, it will appear
+ - in multiple subdirectories. This means there is a bit of an exponential
+ - blowup with a single file appearing in a crazy number of places!
+ -
+ - Capping the view size to 5 is reasonable; why wants to dig
+ - through 5+ levels of subdirectories to find anything?
+ -}
+viewTooLarge :: View -> Bool
+viewTooLarge view = visibleViewSize view > 5
+
+visibleViewSize :: View -> Int
+visibleViewSize = length . filter viewVisible . viewComponents
+
+data ViewChange = Unchanged | Narrowing | Widening
+	deriving (Ord, Eq, Show)
+
+{- Updates a view, adding new fields to filter on (Narrowing), 
+ - or allowing new values in an existing field (Widening). -}
+refineView :: View -> [(MetaField, String)] -> (View, ViewChange)
+refineView = go Unchanged
+  where
+  	go c v [] = (v, c)
+	go c v ((f, s):rest) =
+		let (v', c') = refineView' v f s
+		in go (max c c') v' rest
+
+{- Adds an additional filter to a view. This can only result in narrowing
+ - the view. Multivalued filters are added in non-visible form. -}
+filterView :: View -> [(MetaField, String)] -> View
+filterView v vs = v { viewComponents = viewComponents f' ++ viewComponents v}
+  where
+	f = fst $ refineView (v {viewComponents = []}) vs
+	f' = f { viewComponents = map toinvisible (viewComponents f) }
+	toinvisible c = c { viewVisible = False }
+
+refineView' :: View -> MetaField -> String -> (View, ViewChange)
+refineView' view field wanted
+	| field `elem` (map viewField components) = 
+		let (components', viewchanges) = runWriter $ mapM updatefield components
+		in (view { viewComponents = components' }, maximum viewchanges)
+	| otherwise = 
+		let component = ViewComponent field viewfilter (multiValue viewfilter)
+		    view' = view { viewComponents = component : components }
+		in if viewTooLarge view'
+			then error $ "View is too large (" ++ show (visibleViewSize view') ++ " levels of subdirectories)"
+			else (view', Narrowing)
+  where
+  	components = viewComponents view
+	viewfilter
+		| any (`elem` wanted) "*?" = FilterGlob wanted
+		| otherwise = FilterValues $ S.singleton $ toMetaValue wanted
+	updatefield :: ViewComponent -> Writer [ViewChange] ViewComponent
+	updatefield v
+		| viewField v == field = do
+			let (newvf, viewchange) = combineViewFilter (viewFilter v) viewfilter
+			tell [viewchange]
+			return $ v { viewFilter = newvf }
+		| otherwise = return v
+
+{- Combine old and new ViewFilters, yielding a result that matches
+ - either old+new, or only new.
+ -
+ - If we have FilterValues and change to a FilterGlob,
+ - it's always a widening change, because the glob could match other
+ - values. OTOH, going the other way, it's a Narrowing change if the old
+ - glob matches all the new FilterValues.
+ -
+ - With two globs, the old one is discarded, and the new one is used.
+ - We can tell if that's a narrowing change by checking if the old
+ - glob matches the new glob. For example, "*" matches "foo*",
+ - so that's narrowing. While "f?o" does not match "f??", so that's
+ - widening.
+ -}
+combineViewFilter :: ViewFilter -> ViewFilter -> (ViewFilter, ViewChange)
+combineViewFilter old@(FilterValues olds) (FilterValues news)
+	| combined == old = (combined, Unchanged)
+	| otherwise = (combined, Widening)
+  where
+	combined = FilterValues (S.union olds news)
+combineViewFilter (FilterValues _) newglob@(FilterGlob _) =
+	(newglob, Widening)
+combineViewFilter (FilterGlob oldglob) new@(FilterValues s)
+	| all (matchGlob (compileGlob oldglob) . fromMetaValue) (S.toList s) = (new, Narrowing)
+	| otherwise = (new, Widening)
+combineViewFilter (FilterGlob old) newglob@(FilterGlob new)
+	| old == new = (newglob, Unchanged)
+	| matchGlob (compileGlob old) new = (newglob, Narrowing)
+	| otherwise = (newglob, Widening)
+
+{- Converts a filepath used in a reference branch to the
+ - filename that will be used in the view.
+ -
+ - No two filepaths from the same branch should yeild the same result,
+ - so all directory structure needs to be included in the output file
+ - in some way. However, the branch's directory structure is not relevant
+ - in the view.
+ -
+ - So, from dir/subdir/file.foo, generate file_{dir;subdir}.foo
+ -
+ - (To avoid collisions with a filename that already contains {foo},
+ - that is doubled to {{foo}}.)
+ -}
+fileViewFromReference :: MkFileView
+fileViewFromReference f = concat
+	[ double base
+	, if null dirs then "" else "_{" ++ double (intercalate ";" dirs) ++ "}"
+	, double $ concat extensions
+	]
+  where
+	(path, basefile) = splitFileName f
+	dirs = filter (/= ".") $ map dropTrailingPathSeparator (splitPath path)
+	(base, extensions) = splitShortExtensions basefile
+
+	double = replace "{" "{{" . replace "}" "}}"
+
+fileViewReuse :: MkFileView
+fileViewReuse = takeFileName
+
+{- Generates views for a file from a branch, based on its metadata
+ - and the filename used in the branch.
+ -
+ - Note that a file may appear multiple times in a view, when it
+ - has multiple matching values for a MetaField used in the View.
+ -
+ - Of course if its MetaData does not match the View, it won't appear at
+ - all.
+ -
+ - Note that for efficiency, it's useful to partially
+ - evaluate this function with the view parameter and reuse
+ - the result. The globs in the view will then be compiled and memoized.
+ -}
+fileViews :: View -> MkFileView -> FilePath -> MetaData -> [FileView]
+fileViews view = 
+	let matchers = map viewComponentMatcher (viewComponents view)
+	in \mkfileview file metadata ->
+		let matches = map (\m -> m metadata) matchers
+		in if any isNothing matches
+			then []
+			else 
+				let paths = pathProduct $
+					map (map toViewPath) (visible matches)
+				in if null paths
+					then [mkfileview file]
+					else map (</> mkfileview file) paths
+  where
+	visible = map (fromJust . snd) .
+		filter (viewVisible . fst) .
+		zip (viewComponents view)
+
+{- Checks if metadata matches a ViewComponent filter, and if so
+ - returns the value, or values that match. Self-memoizing on ViewComponent. -}
+viewComponentMatcher :: ViewComponent -> (MetaData -> Maybe [MetaValue])
+viewComponentMatcher viewcomponent = \metadata -> 
+	let s = matcher (currentMetaDataValues metafield metadata)
+	in if S.null s then Nothing else Just (S.toList s)
+  where
+  	metafield = viewField viewcomponent
+	matcher = case viewFilter viewcomponent of
+		FilterValues s -> \values -> S.intersection s values
+		FilterGlob glob ->
+			let regex = compileGlob glob
+			in \values -> 
+				S.filter (matchGlob regex . fromMetaValue) values
+
+compileGlob :: String -> Regex
+compileGlob glob = 
+#ifdef WITH_TDFA
+	case compile (defaultCompOpt {caseSensitive = False}) defaultExecOpt regex of
+		Right r -> r
+		Left _ -> error $ "failed to compile regex: " ++ regex
+#else
+	mkRegexWithOpts regex False True
+#endif
+  where
+	regex = '^':wildToRegex glob
+
+matchGlob :: Regex -> String -> Bool
+matchGlob regex val = 
+#ifdef WITH_TDFA
+	case execute regex val of
+		Right (Just _) -> True
+		_ -> False
+#else
+	isJust $ matchRegex regex val
+#endif
+
+toViewPath :: MetaValue -> FilePath
+toViewPath = concatMap escapeslash . fromMetaValue
+  where
+	escapeslash c
+		| c == '/' = [pseudoSlash]
+		| c == '\\' = [pseudoBackslash]
+		| c == pseudoSlash = [pseudoSlash, pseudoSlash]
+		| c == pseudoBackslash = [pseudoBackslash, pseudoBackslash]
+		| otherwise = [c]
+
+fromViewPath :: FilePath -> MetaValue
+fromViewPath = toMetaValue . deescapeslash []
+  where
+  	deescapeslash s [] = reverse s
+  	deescapeslash s (c:cs)
+		| c == pseudoSlash = case cs of
+			(c':cs')
+				| c' == pseudoSlash -> deescapeslash (pseudoSlash:s) cs'
+			_ -> deescapeslash ('/':s) cs
+		| c == pseudoBackslash = case cs of
+			(c':cs')
+				| c' == pseudoBackslash -> deescapeslash (pseudoBackslash:s) cs'
+			_ -> deescapeslash ('/':s) cs
+		| otherwise = deescapeslash (c:s) cs
+
+pseudoSlash :: Char
+pseudoSlash = '\8725' -- '∕' /= '/'
+
+pseudoBackslash :: Char
+pseudoBackslash = '\9586' -- '╲' /= '\'
+
+pathProduct :: [[FilePath]] -> [FilePath]
+pathProduct [] = []
+pathProduct (l:ls) = foldl combinel l ls
+  where
+	combinel xs ys = [combine x y | x <- xs, y <- ys]
+
+{- Extracts the metadata from a fileview, based on the view that was used
+ - to construct it. -}
+fromView :: View -> FileView -> MetaData
+fromView view f = foldr (uncurry updateMetaData) newMetaData (zip fields values)
+  where
+	visible = filter viewVisible (viewComponents view)
+	fields = map viewField visible
+	paths = splitDirectories $ dropFileName f
+	values = map fromViewPath paths
+
+{- Constructing a view that will match arbitrary metadata, and applying
+ - it to a file yields a set of FileViews which all contain the same
+ - MetaFields that were present in the input metadata
+ - (excluding fields that are not visible). -}
+prop_view_roundtrips :: FilePath -> MetaData -> Bool -> Bool
+prop_view_roundtrips f metadata visible = null f || viewTooLarge view ||
+	all hasfields (fileViews view fileViewFromReference f metadata)
+  where
+	view = View (Git.Ref "master") $
+		map (\(mf, mv) -> ViewComponent mf (FilterValues $ S.filter (not . null . fromMetaValue) mv) visible)
+			(fromMetaData metadata)
+	visiblefields = sort (map viewField $ filter viewVisible (viewComponents view))
+	hasfields fv = sort (map fst (fromMetaData (fromView view fv))) == visiblefields
+
+{- Applies a view to the currently checked out branch, generating a new
+ - branch for the view.
+ -}
+applyView :: View -> Annex Git.Branch
+applyView view = applyView' fileViewFromReference view
+
+{- Generates a new branch for a View, which must be a more narrow
+ - version of the View originally used to generate the currently
+ - checked out branch. That is, it must match a subset of the files
+ - in view, not any others.
+ -}
+narrowView :: View -> Annex Git.Branch
+narrowView = applyView' fileViewReuse
+
+{- Go through each file in the currently checked out branch.
+ - If the file is not annexed, skip it, unless it's a dotfile in the top.
+ - Look up the metadata of annexed files, and generate any FileViews,
+ - and stage them.
+ -
+ - Currently only works in indirect mode. Must be run from top of
+ - repository.
+ -}
+applyView' :: MkFileView -> View -> Annex Git.Branch
+applyView' mkfileview view = do
+	top <- fromRepo Git.repoPath
+	(l, clean) <- inRepo $ Git.LsFiles.inRepo [top]
+	liftIO . nukeFile =<< fromRepo gitAnnexViewIndex
+	genViewBranch view $ do
+		uh <- inRepo Git.UpdateIndex.startUpdateIndex
+		hasher <- inRepo hashObjectStart
+		forM_ l $ \f ->
+			go uh hasher f =<< Backend.lookupFile f
+		liftIO $ do
+			hashObjectStop hasher
+			void $ stopUpdateIndex uh
+			void clean
+  where
+	genfileviews = fileViews view mkfileview -- enables memoization
+	go uh hasher f (Just (k, _)) = do
+		metadata <- getCurrentMetaData k
+		forM_ (genfileviews f metadata) $ \fv -> do
+			stagesymlink uh hasher fv =<< inRepo (gitAnnexLink fv k)
+	go uh hasher f Nothing
+		| "." `isPrefixOf` f = do
+			s <- liftIO $ getSymbolicLinkStatus f
+			if isSymbolicLink s
+				then stagesymlink uh hasher f =<< liftIO (readSymbolicLink f)
+				else do
+					sha <- liftIO $ Git.HashObject.hashFile hasher f
+					let blobtype = if isExecutable (fileMode s)
+						then ExecutableBlob
+						else FileBlob
+					liftIO . Git.UpdateIndex.streamUpdateIndex' uh
+						=<< inRepo (Git.UpdateIndex.stageFile sha blobtype f)
+		| otherwise = noop
+	stagesymlink uh hasher f linktarget = do
+		sha <- hashSymlink' hasher linktarget
+		liftIO . Git.UpdateIndex.streamUpdateIndex' uh
+			=<< inRepo (Git.UpdateIndex.stageSymlink f sha)
+
+{- Applies a view to the reference branch, generating a new branch
+ - for the View.
+ -
+ - This needs to work incrementally, to quickly update the view branch
+ - when the reference branch is changed. So, it works based on an
+ - old version of the reference branch, uses diffTree to find the
+ - changes, and applies those changes to the view branch.
+ -}
+updateView :: View -> Git.Ref -> Git.Ref -> Annex Git.Branch
+updateView view ref oldref = genViewBranch view $ do
+	(diffs, cleanup) <- inRepo $ DiffTree.diffTree oldref ref
+	forM_ diffs go
+	void $ liftIO cleanup
+  where
+	go diff
+		| DiffTree.dstsha diff == nullSha = error "TODO delete file"
+		| otherwise = error "TODO add file"
+
+{- Diff between currently checked out branch and staged changes, and
+ - update metadata to reflect the changes that are being committed to the
+ - view.
+ -
+ - Adding a file to a directory adds the metadata represented by
+ - that directory to the file, and removing a file from a directory
+ - removes the metadata.
+ -
+ - Note that removes must be handled before adds. This is so
+ - that moving a file from x/foo/ to x/bar/ adds back the metadata for x.
+ -}
+withViewChanges :: (FileView -> Key -> CommandStart) -> (FileView -> Key -> CommandStart) -> Annex ()
+withViewChanges addmeta removemeta = do
+	makeabs <- flip fromTopFilePath <$> gitRepo
+	(diffs, cleanup) <- inRepo $ DiffTree.diffIndex Git.Ref.headRef
+	forM_ diffs handleremovals
+	forM_ diffs (handleadds makeabs)
+	void $ liftIO cleanup
+  where
+	handleremovals item
+		| DiffTree.srcsha item /= nullSha =
+			handle item removemeta
+				=<< catKey (DiffTree.srcsha item) (DiffTree.srcmode item)
+		| otherwise = noop
+	handleadds makeabs item
+		| DiffTree.dstsha item /= nullSha = 
+			handle item addmeta
+				=<< ifM isDirect
+					( catKey (DiffTree.dstsha item) (DiffTree.dstmode item)
+					-- optimisation
+					, isAnnexLink $ makeabs $ DiffTree.file item
+					)
+		| otherwise = noop
+	handle item a = maybe noop
+		(void . commandAction . a (getTopFilePath $ DiffTree.file item))
+
+{- Generates a branch for a view. This is done using a different index
+ - file. An action is run to stage the files that will be in the branch.
+ - Then a commit is made, to the view branch. The view branch is not
+ - checked out, but entering it will display the view. -}
+genViewBranch :: View -> Annex () -> Annex Git.Branch
+genViewBranch view a = withIndex $ do
+	a
+	let branch = branchView view
+	void $ inRepo $ Git.Branch.commit True (fromRef branch) branch []
+	return branch
+
+{- Runs an action using the view index file.
+ - Note that the file does not necessarily exist, or can contain
+ - info staged for an old view. -}
+withIndex :: Annex a -> Annex a
+withIndex a = do
+	f <- fromRepo gitAnnexViewIndex
+	withIndexFile f a
+
+withCurrentView :: (View -> Annex a) -> Annex a
+withCurrentView a = maybe (error "Not in a view.") a =<< currentView

Assistant.hs

@@ -93,7 +93,8 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
 			start (Utility.Daemon.daemonize logfd (Just pidfile) False) Nothing
 #else
 	-- Windows is always foreground, and has no log file.
-	start id $
+	liftIO $ Utility.Daemon.lockPidFile pidfile
+	start id $ do
 		case startbrowser of
 			Nothing -> Nothing
 			Just a -> Just $ a Nothing Nothing

Assistant/MakeRemote.hs

@@ -48,9 +48,10 @@ makeRsyncRemote :: RemoteName -> String -> Annex String
 makeRsyncRemote name location = makeRemote name location $ const $ void $
 	go =<< Command.InitRemote.findExisting name
   where
-  	go Nothing = setupSpecialRemote name Rsync.remote config
+  	go Nothing = setupSpecialRemote name Rsync.remote config Nothing
 		(Nothing, Command.InitRemote.newConfig name)
-	go (Just (u, c)) = setupSpecialRemote name Rsync.remote config (Just u, c)
+	go (Just (u, c)) = setupSpecialRemote name Rsync.remote config Nothing
+		(Just u, c)
 	config = M.fromList
 		[ ("encryption", "shared")
 		, ("rsyncurl", location)
@@ -60,44 +61,44 @@ makeRsyncRemote name location = makeRemote name location $ const $ void $
 {- Inits a gcrypt special remote, and returns its name. -}
 makeGCryptRemote :: RemoteName -> String -> KeyId -> Annex RemoteName
 makeGCryptRemote remotename location keyid = 
-	initSpecialRemote remotename GCrypt.remote $ M.fromList
+	initSpecialRemote remotename GCrypt.remote Nothing $ M.fromList
 		[ ("type", "gcrypt")
 		, ("gitrepo", location)
 		, configureEncryption HybridEncryption
 		, ("keyid", keyid)
 		]
 
-type SpecialRemoteMaker = RemoteName -> RemoteType -> R.RemoteConfig -> Annex RemoteName
+type SpecialRemoteMaker = RemoteName -> RemoteType -> Maybe CredPair -> R.RemoteConfig -> Annex RemoteName
 
 {- Inits a new special remote. The name is used as a suggestion, but
  - will be changed if there is already a special remote with that name. -}
 initSpecialRemote :: SpecialRemoteMaker
-initSpecialRemote name remotetype config = go 0
+initSpecialRemote name remotetype mcreds config = go 0
   where
 	go :: Int -> Annex RemoteName
 	go n = do
 		let fullname = if n == 0  then name else name ++ show n
 		r <- Command.InitRemote.findExisting fullname
 		case r of
-			Nothing -> setupSpecialRemote fullname remotetype config
+			Nothing -> setupSpecialRemote fullname remotetype config mcreds
 				(Nothing, Command.InitRemote.newConfig fullname)
 			Just _ -> go (n + 1)
 
 {- Enables an existing special remote. -}
 enableSpecialRemote :: SpecialRemoteMaker
-enableSpecialRemote name remotetype config = do
+enableSpecialRemote name remotetype mcreds config = do
 	r <- Command.InitRemote.findExisting name
 	case r of
 		Nothing -> error $ "Cannot find a special remote named " ++ name
-		Just (u, c) -> setupSpecialRemote name remotetype config (Just u, c)
+		Just (u, c) -> setupSpecialRemote name remotetype config mcreds (Just u, c)
 
-setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName
+setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName
-setupSpecialRemote name remotetype config (mu, c) = do
+setupSpecialRemote name remotetype config mcreds (mu, c) = do
 	{- Currently, only 'weak' ciphers can be generated from the
 	 - assistant, because otherwise GnuPG may block once the entropy
 	 - pool is drained, and as of now there's no way to tell the user
 	 - to perform IO actions to refill the pool. -}
-	(c', u) <- R.setup remotetype mu $
+	(c', u) <- R.setup remotetype mu mcreds $
 		M.insert "highRandomQuality" "false" $ M.union config c
 	describeUUID u name
 	configSet u c'

Assistant/Restart.hs

@@ -16,6 +16,7 @@ import Assistant.NamedThread
 import Utility.ThreadScheduler
 import Utility.NotificationBroadcaster
 import Utility.Url
+import Utility.PID
 import qualified Git.Construct
 import qualified Git.Config
 import Config.Files
@@ -25,10 +26,9 @@ import qualified Git
 import Control.Concurrent
 import System.Process (cwd)
 #ifndef mingw32_HOST_OS
-import System.Posix (getProcessID, signalProcess, sigTERM)
+import System.Posix (signalProcess, sigTERM)
 #else
-import System.Win32.Process.Current (getCurrentProcessId)
+import Utility.WinProcess
-import System.Win32.Console (generateConsoleCtrlEvent, cTRL_C_EVENT)
 #endif
 
 {- Before the assistant can be restarted, have to remove our 
@@ -53,9 +53,9 @@ postRestart url = do
 	void $ liftIO $ forkIO $ do
 		threadDelaySeconds (Seconds 120)
 #ifndef mingw32_HOST_OS
-		signalProcess sigTERM =<< getProcessID
+		signalProcess sigTERM =<< getPID
 #else
-		generateConsoleCtrlEvent cTRL_C_EVENT =<< getCurrentProcessId
+		terminatePID =<< getPID
 #endif
 
 runRestart :: Assistant URLString
@@ -86,10 +86,13 @@ newAssistantUrl repo = do
 		threadDelay 100000 -- 1/10th of a second
 		a
 
-{- Returns once the assistant has daemonized, but possibly before it's
+{- Does not wait for assistant to be listening for web connections. 
- - listening for web connections. -}
+ -
+ - On windows, the assistant does not daemonize, which is why the forkIO is
+ - done.
+ -}
 startAssistant :: FilePath -> IO ()
-startAssistant repo = do
+startAssistant repo = void $ forkIO $ do
 	program <- readProgramFile
 	(_, _, _, pid) <- 
 		createProcess $

Assistant/Threads/Merger.hs

@@ -80,8 +80,8 @@ onChange file
 	mergecurrent (Just current)
 		| equivBranches changedbranch current = do
 			debug
-				[ "merging", show changedbranch
+				[ "merging", Git.fromRef changedbranch
-				, "into", show current
+				, "into", Git.fromRef current
 				]
 			void $ liftAnnex  $ Command.Sync.mergeFrom changedbranch
 	mergecurrent _ = noop
@@ -105,12 +105,12 @@ onChange file
 equivBranches :: Git.Ref -> Git.Ref -> Bool
 equivBranches x y = base x == base y
   where
-	base = takeFileName . show
+	base = takeFileName . Git.fromRef
 
 isAnnexBranch :: FilePath -> Bool
 isAnnexBranch f = n `isSuffixOf` f
   where
-	n = '/' : show Annex.Branch.name
+	n = '/' : Git.fromRef Annex.Branch.name
 
 fileToBranch :: FilePath -> Git.Ref
 fileToBranch f = Git.Ref $ "refs" </> base

Assistant/Threads/SanityChecker.hs

@@ -194,8 +194,13 @@ dailyCheck urlrenderer = do
 
 hourlyCheck :: Assistant ()
 hourlyCheck = do
+#ifndef mingw32_HOST_OS
 	checkLogSize 0
+#else
+	noop
+#endif
 
+#ifndef mingw32_HOST_OS
 {- Rotate logs until log file size is < 1 mb. -}
 checkLogSize :: Int -> Assistant ()
 checkLogSize n = do
@@ -209,6 +214,7 @@ checkLogSize n = do
 			checkLogSize $ n + 1
   where
 	filesize f = fromIntegral . fileSize <$> liftIO (getFileStatus f)
+#endif
 
 oneMegabyte :: Int
 oneMegabyte = 1000000
@@ -237,5 +243,5 @@ checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGit
 			button <- mkAlertButton True (T.pack "Configure") urlrenderer ConfigUnusedR
 			void $ addAlert $ unusedFilesAlert [button] $ T.unpack $ renderTense Present msg
 #else
-		debug [msg]
+		debug [show $ renderTense Past msg]
 #endif

Assistant/TransferSlots.hs

@@ -39,7 +39,7 @@ import qualified Control.Concurrent.MSemN as MSemN
 import System.Posix.Process (getProcessGroupIDOf)
 import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
 #else
-import System.Win32.Console (generateConsoleCtrlEvent, cTRL_C_EVENT, cTRL_BREAK_EVENT)
+import Utility.WinProcess
 #endif
 
 type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()))
@@ -256,23 +256,19 @@ cancelTransfer pause t = do
 	signalthread tid
 		| pause = throwTo tid PauseTransfer
 		| otherwise = killThread tid
+	killproc pid = void $ tryIO $ do
+#ifndef mingw32_HOST_OS
 		{- In order to stop helper processes like rsync,
 		 - kill the whole process group of the process
 		 - running the transfer. -}
-	killproc pid = void $ tryIO $ do
-#ifndef mingw32_HOST_OS
 		g <- getProcessGroupIDOf pid
 		let signal sig = void $ tryIO $ signalProcessGroup sig g
 		signal sigTERM
-		graceperiod
+		threadDelay 50000 -- 0.05 second grace period
 		signal sigKILL
 #else
-		let signal sig = void $ tryIO $ generateConsoleCtrlEvent sig pid
+		terminatePID pid
-		signal cTRL_C_EVENT
-		graceperiod
-		signal cTRL_BREAK_EVENT
 #endif
-	graceperiod = threadDelay 50000 -- 0.05 second
 
 {- Start or resume a transfer. -}
 startTransfer :: Transfer -> Assistant ()

Assistant/Types/NetMessager.hs

@@ -32,7 +32,7 @@ data NetMessage
 	| PairingNotification PairStage ClientID UUID
 	-- used for git push over the network messager
 	| Pushing ClientID PushStage
-	deriving (Show, Eq, Ord)
+	deriving (Eq, Ord, Show)
 
 {- Something used to identify the client, or clients to send the message to. -}
 type ClientID = Text
@@ -50,7 +50,7 @@ data PushStage
 	| SendPackOutput SequenceNum ByteString
 	-- sent when git receive-pack exits, with its exit code
 	| ReceivePackDone ExitCode
-	deriving (Show, Eq, Ord)
+	deriving (Eq, Ord, Show)
 
 {- A sequence number. Incremented by one per packet in a sequence,
  - starting with 1 for the first packet. 0 means sequence numbers are

Assistant/WebApp/Configurators/AWS.hs

@@ -202,11 +202,11 @@ enableAWSRemote _ _ = error "S3 not supported by this build"
 #endif
 
 makeAWSRemote :: SpecialRemoteMaker -> RemoteType -> StandardGroup -> AWSCreds -> RemoteName -> RemoteConfig -> Handler ()
-makeAWSRemote maker remotetype defaultgroup (AWSCreds ak sk) name config = do
+makeAWSRemote maker remotetype defaultgroup (AWSCreds ak sk) name config = 
-	liftIO $ AWS.setCredsEnv (T.unpack ak, T.unpack sk)
 	setupCloudRemote defaultgroup Nothing $
-		maker hostname remotetype config
+		maker hostname remotetype (Just creds) config
   where
+  	creds = (T.unpack ak, T.unpack sk)
 	{- AWS services use the remote name as the basis for a host
 	 - name, so filter it to contain valid characters. -}
 	hostname = case filter isAlphaNum name of

Assistant/WebApp/Configurators/Local.hs

@@ -300,7 +300,6 @@ getGenKeyForDriveR drive = withNewSecretKey $ \keyid ->
 getFinishAddDriveR :: RemovableDrive -> RepoKey -> Handler Html
 getFinishAddDriveR drive = go
   where
-  	{- Set up new gcrypt special remote. -}
 	go (RepoKey keyid) = whenGcryptInstalled $ makewith $ const $ do
 		r <- liftAnnex $ addRemote $
 			makeGCryptRemote remotename dir keyid
@@ -314,7 +313,7 @@ getFinishAddDriveR drive = go
 		remotename' <- liftAnnex $ getGCryptRemoteName u dir
 		makewith $ const $ do
 			r <- liftAnnex $ addRemote $
-				enableSpecialRemote remotename' GCrypt.remote $ M.fromList
+				enableSpecialRemote remotename' GCrypt.remote Nothing $ M.fromList
 					[("gitrepo", dir)]
 			return (u, r)
 	{- Making a new unencrypted repo, or combining with an existing one. -}

Assistant/WebApp/Configurators/Ssh.hs

@@ -25,6 +25,11 @@ import qualified Remote.GCrypt as GCrypt
 import Annex.UUID
 import Logs.UUID
 
+#ifdef mingw32_HOST_OS
+import Utility.Tmp
+import Utility.Rsync
+#endif
+
 import qualified Data.Text as T
 import qualified Data.Map as M
 import Network.Socket
@@ -354,7 +359,7 @@ checkExistingGCrypt sshdata nope = checkGCryptRepoEncryption repourl nope nope $
 enableGCrypt :: SshData -> RemoteName -> Handler Html
 enableGCrypt sshdata reponame = 
 	setupCloudRemote TransferGroup Nothing $ 
-		enableSpecialRemote reponame GCrypt.remote $ M.fromList
+		enableSpecialRemote reponame GCrypt.remote Nothing $ M.fromList
 			[("gitrepo", genSshUrl sshdata)]
 
 {- Combining with a gcrypt repository that may not be
@@ -468,8 +473,18 @@ enableRsyncNetGCrypt sshinput reponame =
 	notencrypted = error "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository."
 	notinstalled = error "internal"
 
-{- Prepares rsync.net ssh key, and if successful, runs an action with
+{- Prepares rsync.net ssh key and creates the directory that will be 
- - its SshData. -}
+ - used on rsync.net. If successful, runs an action with its SshData.
+ -
+ - To append the ssh key to rsync.net's authorized_keys, their
+ - documentation recommends a dd methodd, where the line is fed
+ - in to ssh over stdin.
+ -
+ - On Windows, ssh password prompting happens on stdin, so cannot
+ - feed the key in that way. Instead, first rsync down any current
+ - authorized_keys file, then modifiy it, and then rsync it back up.
+ - This means 2 password prompts rather than one for Windows.
+ -}
 prepRsyncNet :: SshInput -> String -> (SshData -> Handler Html) -> Handler Html
 prepRsyncNet sshinput reponame a = do
 	knownhost <- liftIO $ maybe (return False) knownHost (inputHostname sshinput)
@@ -480,25 +495,37 @@ prepRsyncNet sshinput reponame a = do
 			, needsPubKey = True
 			, sshCapabilities = [RsyncCapable]
 			}
+	let sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
+	let torsyncnet cmd = filter (not . null)
+		[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
+		, sshhost
+		, cmd
+		]
+#ifndef mingw32_HOST_OS
 	{- I'd prefer to separate commands with && , but
-	 - rsync.net's shell does not support that.
+	 - rsync.net's shell does not support that. -}
-	 -
-	 - The dd method of appending to the authorized_keys file is the
-	 - one recommended by rsync.net documentation. I touch the file first
-	 - to not need to use a different method to create it.
-	 -}
 	let remotecommand = intercalate ";"
 		[ "mkdir -p .ssh"
 		, "touch .ssh/authorized_keys"
 		, "dd of=.ssh/authorized_keys oflag=append conv=notrunc"
 		, "mkdir -p " ++ T.unpack (sshDirectory sshdata)
 		]
-	let sshopts = filter (not . null)
+	sshSetup (torsyncnet remotecommand) (Just $ sshPubKey keypair) (a sshdata)
-		[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
+#else
-		, genSshHost (sshHostName sshdata) (sshUserName sshdata)
+	liftIO $ withTmpDir "rsyncnet" $ \tmpdir -> do
-		, remotecommand
+		createDirectory $ tmpdir </> ".ssh"
+		(oldkeys, _) <- sshTranscript (torsyncnet "cat .ssh/authorized_keys") Nothing
+		writeFile (tmpdir </> ".ssh" </> "authorized_keys")
+			(sshPubKey keypair ++ "\n" ++ oldkeys)
+		liftIO $ putStrLn "May need to prompt for your rsync.net password one more time..."
+		void $ rsync
+			[ Param "-r"
+			, File $ tmpdir </> ".ssh/"
+			, Param $ sshhost ++ ":.ssh/"
 			]
-	sshSetup sshopts (Just $ sshPubKey keypair) $ a sshdata
+	let remotecommand = "mkdir -p " ++ T.unpack (sshDirectory sshdata)
+	sshSetup (torsyncnet remotecommand) Nothing (a sshdata)
+#endif
 
 isRsyncNet :: Maybe Text -> Bool
 isRsyncNet Nothing = False

Assistant/WebApp/Configurators/WebDAV.hs

@@ -123,10 +123,9 @@ postEnableWebDAVR _ = error "WebDAV not supported by this build"
 
 #ifdef WITH_WEBDAV
 makeWebDavRemote :: SpecialRemoteMaker -> RemoteName -> CredPair -> RemoteConfig -> Handler ()
-makeWebDavRemote maker name creds config = do
+makeWebDavRemote maker name creds config = 
-	liftIO $ WebDAV.setCredsEnv creds
 	setupCloudRemote TransferGroup Nothing $
-		maker name WebDAV.remote config
+		maker name WebDAV.remote (Just creds) config
 
 {- Only returns creds previously used for the same hostname. -}
 previouslyUsedWebDAVCreds :: String -> Annex (Maybe CredPair)

Assistant/WebApp/Control.hs

@@ -16,15 +16,15 @@ import Assistant.TransferSlots
 import Assistant.Restart
 import Utility.LogFile
 import Utility.NotificationBroadcaster
+import Utility.PID
 
 import Control.Concurrent
 import qualified Data.Map as M
 import qualified Data.Text as T
 #ifndef mingw32_HOST_OS
-import System.Posix (getProcessID, signalProcess, sigTERM)
+import System.Posix (signalProcess, sigTERM)
 #else
-import System.Win32.Process.Current (getCurrentProcessId)
+import Utility.WinProcess
-import System.Win32.Console (generateConsoleCtrlEvent, cTRL_C_EVENT)
 #endif
 
 getShutdownR :: Handler Html
@@ -54,9 +54,9 @@ getShutdownConfirmedR = do
 	void $ liftIO $ forkIO $ do
 		threadDelay 2000000
 #ifndef mingw32_HOST_OS
-		signalProcess sigTERM =<< getProcessID
+		signalProcess sigTERM =<< getPID
 #else
-		generateConsoleCtrlEvent cTRL_C_EVENT =<< getCurrentProcessId
+		terminatePID =<< getPID
 #endif
 	redirect NotRunningR
 

Assistant/WebApp/DashBoard.hs

@@ -130,8 +130,23 @@ openFileBrowser = do
 #endif
 	ifM (liftIO $ inPath cmd)
 		( do
-			void $ liftIO $ forkIO $ void $
+			let run = void $ liftIO $ forkIO $ void $
 				boolSystem cmd params
+			run
+#ifdef mingw32_HOST_OS
+			{- On windows, if the file browser is not
+			 - already open, it comes up below the
+			 - web browser when started. 
+			 -
+			 - Running it a second time brings it
+			 - to the foreground.
+			 -
+			 - Seems to need a delay long enough for the file
+			 - browser to be open in order to work. Here 1
+			 - second. -}
+			liftIO $ threadDelay 1000000
+			run
+#endif
 			return True
 		, do
 			void $ redirect $ "file://" ++ path

Assistant/WebApp/MakeRemote.hs

@@ -28,8 +28,8 @@ import Utility.Yesod
  - and finishes setting it up, then starts syncing with it,
  - and finishes by displaying the page to edit it. -}
 setupCloudRemote :: StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
-setupCloudRemote defaultgroup mcost maker = do
+setupCloudRemote defaultgroup mcost name = do
-	r <- liftAnnex $ addRemote maker
+	r <- liftAnnex $ addRemote name
 	liftAnnex $ do
 		setStandardGroup (Remote.uuid r) defaultgroup
 		maybe noop (Config.setRemoteCost (Remote.repo r)) mcost

Assistant/XMPP.hs

@@ -13,6 +13,7 @@ import Assistant.Common
 import Assistant.Types.NetMessager
 import Assistant.Pairing
 import Git.Sha (extractSha)
+import Git
 
 import Network.Protocol.XMPP hiding (Node)
 import Data.Text (Text)
@@ -152,7 +153,7 @@ pushMessage = gitAnnexMessage . encode
   where
 	encode (CanPush u shas) =
 		gitAnnexTag canPushAttr $ T.pack $ unwords $
-			fromUUID u : map show shas
+			fromUUID u : map fromRef shas
 	encode (PushRequest u) =
 		gitAnnexTag pushRequestAttr $ T.pack $ fromUUID u
 	encode (StartingPush u) =

Backend/Hash.hs

@@ -101,6 +101,7 @@ checkKeyChecksum hash key file = do
 	case (mstat, fast) of
 		(Just stat, False) -> do
 			let filesize = fromIntegral $ fileSize stat
+			showSideAction "checksum"
 			check <$> hashFile hash file filesize
 		_ -> return True
   where

Build/DistributionUpdate.hs

@@ -21,11 +21,16 @@ main = do
 
 makeinfos :: Annex ()
 makeinfos = do
+	void $ inRepo $ runBool 
+		[ Param "commit"
+		, Param "-m"
+		, Param $ "publishing git-annex " ++ version
+		]
 	basedir <- liftIO getRepoDir
 	version <- liftIO getChangelogVersion
 	now <- liftIO getCurrentTime
 	liftIO $ putStrLn $ "building info files for version " ++ version ++ " in " ++ basedir
-	fs <- liftIO $ dirContentsRecursiveSkipping (== "info") True (basedir </> "git-annex")
+	fs <- liftIO $ dirContentsRecursiveSkipping (const False) True (basedir </> "git-annex")
 	forM_ fs $ \f -> do
 		v <- lookupFile f
 		case v of
@@ -44,7 +49,7 @@ makeinfos = do
 	void $ inRepo $ runBool 
 		[ Param "commit"
 		, Param "-m"
-		, Param $ "publishing git-annex " ++ version
+		, Param $ "updated info files for git-annex " ++ version
 		]
 	void $ inRepo $ runBool
 		[ Param "annex"
@@ -55,6 +60,19 @@ makeinfos = do
 		, Params "sync"
 		]
 	
+	{- Check for out of date info files. -}
+	infos <- liftIO $ filter (".info" `isSuffixOf`)
+		<$> dirContentsRecursive (basedir </> "git-annex")
+	ds <- liftIO $ forM infos (readish <$$> readFile)
+	let dis = zip infos ds
+	let ood = filter (outofdate version) dis
+	unless (null ood) $
+		error $ "Some info files are out of date: " ++ show (map fst ood)
+  where
+	outofdate version (_, md) = case md of
+		Nothing -> True
+		Just d -> distributionVersion d /= version
+
 getRepoDir :: IO FilePath
 getRepoDir = do
 	home <- liftIO myHomeDir

Build/EvilLinker.hs

@@ -17,6 +17,7 @@ import Control.Applicative ((<$>))
 import Control.Monad
 import System.Directory
 import Data.Maybe
+import Data.List
 
 import Utility.Monad
 import Utility.Process
@@ -94,13 +95,19 @@ parseCollect2 = do
 	path <- manyTill anyChar (try $ string ldcmd)
 	void $ char ' '
 	params <- restOfLine
-	return $ CmdParams (path ++ ldcmd) (escapeDosPaths params) Nothing
+	return $ CmdParams (path ++ ldcmd) (skipHack $ escapeDosPaths params) Nothing
   where
 	ldcmd = "ld.exe"
 	versionline = do
 		void $ string "collect2 version"
 		restOfLine
 
+{- For unknown reasons, asking the linker to link this in fails,
+ - with error about multiple definitions of a symbol from the library.
+ - This is a horrible hack. -}
+skipHack :: String -> String
+skipHack = replace "dist/build/git-annex/git-annex-tmp/Utility/winprocess.o" ""
+
 {- Input contains something like 
  - c:/program files/haskell platform/foo -LC:/Program Files/Haskell Platform/ -L...
  - and the *right* spaces must be escaped with \

CmdLine/GitAnnex.hs

@@ -26,6 +26,12 @@ import qualified Command.DropKey
 import qualified Command.TransferKey
 import qualified Command.TransferKeys
 import qualified Command.ReKey
+import qualified Command.MetaData
+import qualified Command.View
+import qualified Command.VAdd
+import qualified Command.VFilter
+import qualified Command.VPop
+import qualified Command.VCycle
 import qualified Command.Reinject
 import qualified Command.Fix
 import qualified Command.Init
@@ -134,6 +140,12 @@ cmds = concat
 	, Command.TransferKey.def
 	, Command.TransferKeys.def
 	, Command.ReKey.def
+	, Command.MetaData.def
+	, Command.View.def
+	, Command.VAdd.def
+	, Command.VFilter.def
+	, Command.VPop.def
+	, Command.VCycle.def
 	, Command.Fix.def
 	, Command.Fsck.def
 	, Command.Repair.def

CmdLine/GitAnnex/Options.hs

@@ -54,6 +54,8 @@ gitAnnexOptions = commonOptions ++
 		"match files larger than a size"
 	, Option [] ["smallerthan"] (ReqArg Limit.addSmallerThan paramSize)
 		"match files smaller than a size"
+	, Option [] ["metadata"] (ReqArg Limit.addMetaData "FIELD=VALUE")
+		"match files with attached metadata"
 	, Option [] ["want-get"] (NoArg Limit.Wanted.addWantGet)
 		"match files the repository wants to get"
 	, Option [] ["want-drop"] (NoArg Limit.Wanted.addWantDrop)

CmdLine/GitAnnexShell/Fields.hs

@@ -9,6 +9,7 @@ module CmdLine.GitAnnexShell.Fields where
 
 import Common.Annex
 import qualified Annex
+import Git.FilePath
 
 import Data.Char
 
@@ -29,7 +30,7 @@ remoteUUID = Field "remoteuuid" $
 associatedFile :: Field
 associatedFile = Field "associatedfile" $ \f ->
 	-- is the file a safe relative filename?
-	not (isAbsolute f) && not ("../" `isPrefixOf` f)
+	not (absoluteGitPath f) && not ("../" `isPrefixOf` f)
 
 direct :: Field
 direct = Field "direct" $ \f -> f == "1"

Command.hs

@@ -5,8 +5,6 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE BangPatterns #-}
-
 module Command (
 	command,
 	noRepo,

Command/Dead.hs

@@ -7,34 +7,13 @@
 
 module Command.Dead where
 
-import Common.Annex
 import Command
-import qualified Remote
+import Types.TrustLevel
-import Logs.Trust
+import Command.Trust (trustCommand)
-import Logs.Group
-
-import qualified Data.Set as S
 
 def :: [Command]
 def = [command "dead" (paramRepeating paramRemote) seek
 	SectionSetup "hide a lost repository"]
 
 seek :: CommandSeek
-seek = withWords start
+seek = trustCommand "dead" DeadTrusted
-
-start :: [String] -> CommandStart
-start ws = do
-	let name = unwords ws
-	showStart "dead" name
-	u <- Remote.nameToUUID name
-	next $ perform u
-
-perform :: UUID -> CommandPerform
-perform uuid = do
-	markDead uuid
-	next $ return True
-
-markDead :: UUID -> Annex ()
-markDead uuid = do
-	trustSet uuid DeadTrusted
-	groupSet uuid S.empty

Command/EnableRemote.hs

@@ -47,7 +47,7 @@ unknownNameError prefix = do
 
 perform :: RemoteType -> UUID -> R.RemoteConfig -> CommandPerform
 perform t u c = do
-	(c', u') <- R.setup t (Just u) c
+	(c', u') <- R.setup t (Just u) Nothing c
 	next $ cleanup u' c'
 
 cleanup :: UUID -> R.RemoteConfig -> CommandCleanup

Command/Fsck.hs

@@ -31,12 +31,8 @@ import Config
 import Types.Key
 import Utility.HumanTime
 import Git.FilePath
+import Utility.PID
 
-#ifndef mingw32_HOST_OS
-import System.Posix.Process (getProcessID)
-#else
-import System.Win32.Process.Current (getCurrentProcessId)
-#endif
 import Data.Time.Clock.POSIX
 import Data.Time
 import System.Posix.Types (EpochTime)
@@ -72,7 +68,7 @@ seek ps = do
 	from <- getOptionField fsckFromOption Remote.byNameWithUUID
 	i <- getIncremental
 	withKeyOptions
-		(startKey i)
+		(\k -> startKey i k =<< getNumCopies)
 		(withFilesInGit $ whenAnnexed $ start from i)
 		ps
 
@@ -84,11 +80,12 @@ getIncremental = do
 	morei <- Annex.getFlag (optionName moreIncrementalOption)
 	case (i, starti, morei) of
 		(False, False, False) -> return NonIncremental
-		(False, True, _) -> startIncremental
+		(False, True, False) -> startIncremental
 		(False ,False, True) -> ContIncremental <$> getStartTime
-		(True, _, _) ->
+		(True, False, False) ->
 			maybe startIncremental (return . ContIncremental . Just)
 				=<< getStartTime
+		_ -> error "Specify only one of --incremental, --more, or --incremental-schedule"
   where
 	startIncremental = do
 		recordStartTime
@@ -149,14 +146,10 @@ performRemote key file backend numcopies remote =
 		, checkKeyNumCopies key file numcopies
 		]
 	withtmp a = do
-#ifndef mingw32_HOST_OS
+		pid <- liftIO getPID
-		v <- liftIO getProcessID
-#else
-		v <- liftIO getCurrentProcessId
-#endif
 		t <- fromRepo gitAnnexTmpDir
 		createAnnexDirectory t
-		let tmp = t </> "fsck" ++ show v ++ "." ++ keyFile key
+		let tmp = t </> "fsck" ++ show pid ++ "." ++ keyFile key
 		let cleanup = liftIO $ catchIO (removeFile tmp) (const noop)
 		cleanup
 		cleanup `after` a tmp
@@ -170,18 +163,19 @@ performRemote key file backend numcopies remote =
 			)
 	dummymeter _ = noop
 
-startKey :: Incremental -> Key -> CommandStart
+startKey :: Incremental -> Key -> NumCopies -> CommandStart
-startKey inc key = case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of
+startKey inc key numcopies =
+	case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of
 		Nothing -> stop
-	Just backend -> runFsck inc (key2file key) key $ performAll key backend
+		Just backend -> runFsck inc (key2file key) key $
+			performKey key backend numcopies
 
-{- Note that numcopies cannot be checked in --all mode, since we do not
+performKey :: Key -> Backend -> NumCopies -> Annex Bool
- - have associated filenames to look up in the .gitattributes file. -}
+performKey key backend numcopies = check
-performAll :: Key -> Backend -> Annex Bool
-performAll key backend = check
 	[ verifyLocationLog key (key2file key)
 	, checkKeySize key
 	, checkBackend backend key Nothing
+	, checkKeyNumCopies key (key2file key) numcopies
 	]
 
 check :: [Annex Bool] -> Annex Bool
@@ -365,7 +359,7 @@ checkBackendOr' bad backend key file postcheck =
 				, return True
 				)
 
-checkKeyNumCopies :: Key -> FilePath -> NumCopies -> Annex Bool
+checkKeyNumCopies :: Key -> String -> NumCopies -> Annex Bool
 checkKeyNumCopies key file numcopies = do
 	(untrustedlocations, safelocations) <- trustPartition UnTrusted =<< Remote.keyLocations key
 	let present = NumCopies (length safelocations)
@@ -415,7 +409,7 @@ badContentRemote remote key = do
 		++ Remote.name remote
 
 data Incremental = StartIncremental | ContIncremental (Maybe EpochTime) | NonIncremental
-	deriving (Eq)
+	deriving (Eq, Show)
 
 runFsck :: Incremental -> FilePath -> Key -> Annex Bool -> CommandStart
 runFsck inc file key a = ifM (needFsck inc key)
@@ -471,7 +465,9 @@ getFsckTime key = do
  -
  - To guard against time stamp damange (for example, if an annex directory
  - is copied without -a), the fsckstate file contains a time that should
- - be identical to its modification time. -}
+ - be identical to its modification time.
+ - (This is not possible to do on Windows.)
+ -}
 recordStartTime :: Annex ()
 recordStartTime = do
 	f <- fromRepo gitAnnexFsckState
@@ -479,8 +475,12 @@ recordStartTime = do
 	liftIO $ do
 		nukeFile f
 		withFile f WriteMode $ \h -> do
+#ifndef mingw32_HOST_OS
 			t <- modificationTime <$> getFileStatus f
 			hPutStr h $ showTime $ realToFrac t
+#else
+			noop
+#endif
   where
 	showTime :: POSIXTime -> String
 	showTime = show
@@ -494,10 +494,14 @@ getStartTime = do
 	f <- fromRepo gitAnnexFsckState
 	liftIO $ catchDefaultIO Nothing $ do
 		timestamp <- modificationTime <$> getFileStatus f
+#ifndef mingw32_HOST_OS
 		t <- readishTime <$> readFile f
 		return $ if Just (realToFrac timestamp) == t
 			then Just timestamp
 			else Nothing
+#else
+		return $ Just timestamp
+#endif
   where
 	readishTime :: String -> Maybe POSIXTime
 	readishTime s = utcTimeToPOSIXSeconds <$>

Command/FuzzTest.hs

@@ -146,13 +146,6 @@ genFuzzFile = do
 genFuzzDir :: IO FuzzDir
 genFuzzDir = mkFuzzDir <$> (getStdRandom (randomR (1,16)) :: IO Int)
 
-localFile :: FilePath -> Bool
-localFile f
-	| isAbsolute f = False
-	| ".." `isInfixOf` f = False
-	| ".git" `isPrefixOf` f = False
-	| otherwise = True
-
 data TimeStampedFuzzAction 
 	= Started UTCTime FuzzAction
 	| Finished UTCTime Bool

Command/InitRemote.hs

@@ -44,7 +44,7 @@ start (name:ws) = ifM (isJust <$> findExisting name)
 
 perform :: RemoteType -> String -> R.RemoteConfig -> CommandPerform
 perform t name c = do
-	(c', u) <- R.setup t Nothing c
+	(c', u) <- R.setup t Nothing Nothing c
 	next $ cleanup u name c'
 
 cleanup :: UUID -> String -> R.RemoteConfig -> CommandCleanup

Command/Log.hs

@@ -140,7 +140,7 @@ getLog key os = do
 		[ Params "log -z --pretty=format:%ct --raw --abbrev=40"
 		, Param "--remove-empty"
 		] ++ os ++
-		[ Param $ show Annex.Branch.fullname
+		[ Param $ Git.fromRef Annex.Branch.fullname
 		, Param "--"
 		, Param logfile
 		]

Command/MetaData.hs

@@ -0,0 +1,68 @@
+{- git-annex command
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.MetaData where
+
+import Common.Annex
+import qualified Annex
+import Command
+import Logs.MetaData
+import Types.MetaData
+
+import qualified Data.Set as S
+import Data.Time.Clock.POSIX
+
+def :: [Command]
+def = [withOptions [setOption, tagOption, untagOption] $
+	command "metadata" paramPaths seek
+	SectionMetaData "sets metadata of a file"]
+
+storeModMeta :: ModMeta -> Annex ()
+storeModMeta modmeta = Annex.changeState $
+	\s -> s { Annex.modmeta = modmeta:Annex.modmeta s }
+
+setOption :: Option
+setOption = Option ['s'] ["set"] (ReqArg mkmod "FIELD[+-]=VALUE") "set metadata"
+  where
+	mkmod = either error storeModMeta . parseModMeta
+
+tagOption :: Option
+tagOption = Option ['t'] ["tag"] (ReqArg mkmod "TAG") "set a tag"
+  where
+	mkmod = storeModMeta . AddMeta tagMetaField . toMetaValue
+
+untagOption :: Option
+untagOption = Option ['u'] ["untag"] (ReqArg mkmod "TAG") "remove a tag"
+  where
+	mkmod = storeModMeta . AddMeta tagMetaField . mkMetaValue (CurrentlySet False)
+
+seek :: CommandSeek
+seek ps = do
+	modmeta <- Annex.getState Annex.modmeta
+	now <- liftIO getPOSIXTime
+	withFilesInGit (whenAnnexed $ start now modmeta) ps
+
+start :: POSIXTime -> [ModMeta] -> FilePath -> (Key, Backend) -> CommandStart
+start now ms file (k, _) = do
+	showStart "metadata" file
+	next $ perform now ms k
+
+perform :: POSIXTime -> [ModMeta] -> Key -> CommandPerform
+perform _ [] k = next $ cleanup k
+perform now ms k = do
+	oldm <- getCurrentMetaData k
+	let m = foldl' unionMetaData newMetaData $ map (modMeta oldm) ms
+	addMetaData' k m now
+	next $ cleanup k
+	
+cleanup :: Key -> CommandCleanup
+cleanup k = do
+	m <- getCurrentMetaData k
+	showLongNote $ unlines $ concatMap showmeta $ fromMetaData $ currentMetaData m
+	return True
+  where
+	showmeta (f, vs) = map (\v -> fromMetaField f ++ "=" ++ fromMetaValue v) $ S.toList vs

Command/PreCommit.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2010, 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -13,6 +13,13 @@ import Config
 import qualified Command.Add
 import qualified Command.Fix
 import Annex.Direct
+import Annex.View
+import Logs.View
+import Logs.MetaData
+import Types.View
+import Types.MetaData
+
+import qualified Data.Set as S
 
 def :: [Command]
 def = [command "pre-commit" paramPaths seek SectionPlumbing
@@ -27,13 +34,45 @@ seek ps = ifM isDirect
 		withFilesToBeCommitted (whenAnnexed Command.Fix.start) ps
 		-- inject unlocked files into the annex
 		withFilesUnlockedToBeCommitted startIndirect ps
+		-- committing changes to a view updates metadata
+		mv <- currentView
+		case mv of
+			Nothing -> noop
+			Just v -> withViewChanges
+				(addViewMetaData v)
+				(removeViewMetaData v)
 	)
 
 startIndirect :: FilePath -> CommandStart
-startIndirect file = next $ do
+startIndirect f = next $ do
-	unlessM (callCommandAction $ Command.Add.start file) $
+	unlessM (callCommandAction $ Command.Add.start f) $
-		error $ "failed to add " ++ file ++ "; canceling commit"
+		error $ "failed to add " ++ f ++ "; canceling commit"
 	next $ return True
 
 startDirect :: [String] -> CommandStart
 startDirect _ = next $ next $ preCommitDirect
+
+addViewMetaData :: View -> FileView -> Key -> CommandStart
+addViewMetaData v f k = do
+	showStart "metadata" f
+	next $ next $ changeMetaData k $ fromView v f
+
+removeViewMetaData :: View -> FileView -> Key -> CommandStart
+removeViewMetaData v f k = do
+	showStart "metadata" f
+	next $ next $ changeMetaData k $ unsetMetaData $ fromView v f
+
+changeMetaData :: Key -> MetaData -> CommandCleanup
+changeMetaData k metadata = do
+	showMetaDataChange metadata
+	addMetaData k metadata
+	return True
+
+showMetaDataChange :: MetaData -> Annex ()
+showMetaDataChange = showLongNote . unlines . concatMap showmeta . fromMetaData
+  where
+	showmeta (f, vs) = map (showmetavalue f) $ S.toList vs
+	showmetavalue f v = fromMetaField f ++ showset v ++ "=" ++ fromMetaValue v
+	showset v
+		| isSet v = "+"
+		| otherwise = "-"

Command/Repair.hs

@@ -81,4 +81,4 @@ trackingOrSyncBranch :: Ref -> Bool
 trackingOrSyncBranch b = Git.Repair.isTrackingBranch b || isAnnexSyncBranch b
 
 isAnnexSyncBranch :: Ref -> Bool
-isAnnexSyncBranch b = "refs/synced/" `isPrefixOf` show b
+isAnnexSyncBranch b = "refs/synced/" `isPrefixOf` fromRef b

Command/Semitrust.hs

@@ -7,26 +7,13 @@
 
 module Command.Semitrust where
 
-import Common.Annex
 import Command
-import qualified Remote
+import Types.TrustLevel
-import Logs.Trust
+import Command.Trust (trustCommand)
 
 def :: [Command]
 def = [command "semitrust" (paramRepeating paramRemote) seek
 	SectionSetup "return repository to default trust level"]
 
 seek :: CommandSeek
-seek = withWords start
+seek = trustCommand "semitrust" SemiTrusted
-
-start :: [String] -> CommandStart
-start ws = do
-	let name = unwords ws
-	showStart "semitrust" name
-	u <- Remote.nameToUUID name
-	next $ perform u
-
-perform :: UUID -> CommandPerform
-perform uuid = do
-	trustSet uuid SemiTrusted
-	next $ return True

Command/Sync.hs

@@ -86,7 +86,7 @@ seek rs = do
 		,  [ mergeAnnex ]
 		]
 	whenM (Annex.getFlag $ optionName contentOption) $
-		whenM (seekSyncContent dataremotes) $ do
+		whenM (seekSyncContent dataremotes) $
 			-- Transferring content can take a while,
 			-- and other changes can be pushed to the git-annex
 			-- branch on the remotes in the meantime, so pull
@@ -192,12 +192,12 @@ pushLocal (Just branch) = do
 
 updateBranch :: Git.Ref -> Git.Repo -> IO ()
 updateBranch syncbranch g = 
-	unlessM go $ error $ "failed to update " ++ show syncbranch
+	unlessM go $ error $ "failed to update " ++ Git.fromRef syncbranch
   where
 	go = Git.Command.runBool
 		[ Param "branch"
 		, Param "-f"
-		, Param $ show $ Git.Ref.base syncbranch
+		, Param $ Git.fromRef $ Git.Ref.base syncbranch
 		] g
 
 pullRemote :: Remote -> Maybe Git.Ref -> CommandStart
@@ -224,7 +224,7 @@ mergeRemote remote b = case b of
 	Just _ -> and <$> (mapM merge =<< tomerge (branchlist b))
   where
 	merge = mergeFrom . remoteBranch remote
-	tomerge branches = filterM (changed remote) branches
+	tomerge = filterM (changed remote)
 	branchlist Nothing = []
 	branchlist (Just branch) = [branch, syncBranch branch]
 
@@ -283,15 +283,15 @@ pushBranch remote branch g = tryIO (directpush g) `after` syncpush g
 		, refspec branch
 		]
 	directpush = Git.Command.runQuiet $ pushparams
-		[show $ Git.Ref.base $ fromDirectBranch branch]
+		[Git.fromRef $ Git.Ref.base $ fromDirectBranch branch]
 	pushparams branches =
 		[ Param "push"
 		, Param $ Remote.name remote
 		] ++ map Param branches
 	refspec b = concat 
-		[ show $ Git.Ref.base b
+		[ Git.fromRef $ Git.Ref.base b
 		,  ":"
-		, show $ Git.Ref.base $ syncBranch b
+		, Git.fromRef $ Git.Ref.base $ syncBranch b
 		]
 
 commitAnnex :: CommandStart
@@ -452,7 +452,7 @@ resolveMerge' u
 			Just target -> do
 				unlessM (coreSymlinks <$> Annex.getGitConfig) $
 					addAnnexLink target f
-				maybe noop (flip toDirect f) 
+				maybe noop (`toDirect` f) 
 					(fileKey (takeFileName target))
 
 {- git-merge moves conflicting files away to files
@@ -535,7 +535,7 @@ newer remote b = do
  -}
 seekSyncContent :: [Remote] -> Annex Bool
 seekSyncContent rs = do
-	mvar <- liftIO $ newEmptyMVar
+	mvar <- liftIO newEmptyMVar
 	mapM_ (go mvar) =<< seekHelper LsFiles.inRepo []
 	liftIO $ not <$> isEmptyMVar mvar
   where
@@ -552,7 +552,7 @@ syncFile rs f (k, _) = do
 	putrs <- catMaybes . snd . unzip <$> (sequence =<< handleput lack)
 
 	u <- getUUID
-	let locs' = concat [if got then [u] else [], putrs, locs]
+	let locs' = concat [[u | got], putrs, locs]
 
 	-- Using callCommandAction rather than commandAction for drops,
 	-- because a failure to drop does not mean the sync failed.
@@ -576,7 +576,7 @@ syncFile rs f (k, _) = do
 		| Remote.readonly r || remoteAnnexReadOnly (Types.Remote.gitconfig r) = return False
 		| otherwise = wantSend True (Just k) (Just f) (Remote.uuid r)
 	handleput lack = ifM (inAnnex k)
-		( map put <$> (filterM wantput lack)
+		( map put <$> filterM wantput lack
 		, return []
 		)
 	put dest = do

Command/Trust.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2010 Joey Hess <joey@kitenet.net>
+ - Copyright 2010, 2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -10,23 +10,32 @@ module Command.Trust where
 import Common.Annex
 import Command
 import qualified Remote
+import Types.TrustLevel
 import Logs.Trust
+import Logs.Group
+
+import qualified Data.Set as S
 
 def :: [Command]
 def = [command "trust" (paramRepeating paramRemote) seek
 	SectionSetup "trust a repository"]
 
 seek :: CommandSeek
-seek = withWords start
+seek = trustCommand "trust" Trusted
 
-start :: [String] -> CommandStart
+trustCommand :: String -> TrustLevel -> CommandSeek
-start ws = do
+trustCommand cmd level = withWords start
+  where
+	start ws = do
 		let name = unwords ws
-	showStart "trust" name
+		showStart cmd name
 		u <- Remote.nameToUUID name
 		next $ perform u
-
+	perform uuid = do
-perform :: UUID -> CommandPerform
+		trustSet uuid level
-perform uuid = do
+		when (level == DeadTrusted) $
-	trustSet uuid Trusted
+			groupSet uuid S.empty
+		l <- lookupTrust uuid
+		when (l /= level) $
+			warning $ "This remote's trust level is locally overridden to " ++ showTrustLevel l ++ " via git config."
 		next $ return True

Command/Uninit.hs

@@ -24,7 +24,7 @@ check :: Annex ()
 check = do
 	b <- current_branch
 	when (b == Annex.Branch.name) $ error $
-		"cannot uninit when the " ++ show b ++ " branch is checked out"
+		"cannot uninit when the " ++ Git.fromRef b ++ " branch is checked out"
 	top <- fromRepo Git.repoPath
 	cwd <- liftIO getCurrentDirectory
 	whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath cwd)) $
@@ -77,7 +77,7 @@ finish = do
 	-- avoid normal shutdown
 	saveState False
 	inRepo $ Git.Command.run
-		[Param "branch", Param "-D", Param $ show Annex.Branch.name]
+		[Param "branch", Param "-D", Param $ Git.fromRef Annex.Branch.name]
 	liftIO exitSuccess
 
 {- Keys that were moved out of the annex have a hard link still in the

Command/Untrust.hs

@@ -7,26 +7,13 @@
 
 module Command.Untrust where
 
-import Common.Annex
 import Command
-import qualified Remote
+import Types.TrustLevel
-import Logs.Trust
+import Command.Trust (trustCommand)
 
 def :: [Command]
 def = [command "untrust" (paramRepeating paramRemote) seek
 	SectionSetup "do not trust a repository"]
 
 seek :: CommandSeek
-seek = withWords start
+seek = trustCommand "untrust" UnTrusted
-
-start :: [String] -> CommandStart
-start ws = do
-	let name = unwords ws
-	showStart "untrust" name
-	u <- Remote.nameToUUID name
-	next $ perform u
-
-perform :: UUID -> CommandPerform
-perform uuid = do
-	trustSet uuid UnTrusted
-	next $ return True

Command/Unused.hs

@@ -266,7 +266,7 @@ withKeysReferencedInGit a = do
 		map (separate (== ' ')) .
 		lines
 	nubRefs = map (Git.Ref . snd) . nubBy (\(x, _) (y, _) -> x == y)
-	ourbranchend = '/' : show Annex.Branch.name
+	ourbranchend = '/' : Git.fromRef Annex.Branch.name
 	ourbranches (_, b) = not (ourbranchend `isSuffixOf` b)
 		&& not ("refs/synced/" `isPrefixOf` b)
 	addHead headRef refs = case headRef of

Command/VAdd.hs

@@ -0,0 +1,36 @@
+{- git-annex command
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.VAdd where
+
+import Common.Annex
+import Command
+import Annex.View
+import Command.View (paramView, parseViewParam, checkoutViewBranch)
+
+def :: [Command]
+def = [notBareRepo $ notDirect $
+	command "vadd" paramView seek SectionMetaData "add subdirs to current view"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start params = do
+	showStart "vadd" ""
+	withCurrentView $ \view -> do
+		let (view', change) = refineView view $
+			map parseViewParam $ reverse params
+		case change of
+			Unchanged -> do
+				showNote "unchanged"
+				next $ next $ return True
+			Narrowing -> next $ next $ do
+				if visibleViewSize view' == visibleViewSize view
+					then error "That would not add an additional level of directory structure to the view. To filter the view, use vfilter instead of vadd."
+					else checkoutViewBranch view' narrowView
+			Widening -> error "Widening view to match more files is not currently supported."

Command/VCycle.hs

@@ -0,0 +1,41 @@
+{- git-annex command
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.VCycle where
+
+import Common.Annex
+import Command
+import Annex.View
+import Types.View
+import Logs.View
+import Command.View (checkoutViewBranch)
+
+def :: [Command]
+def = [notBareRepo $ notDirect $
+	command "vcycle" paramNothing seek SectionUtility
+	"switch view to next layout"]
+
+seek :: CommandSeek
+seek = withNothing start
+
+start ::CommandStart
+start = go =<< currentView
+  where
+	go Nothing = error "Not in a view."
+	go (Just v) = do
+		showStart "vcycle" ""
+		let v' = v { viewComponents = vcycle [] (viewComponents v) }
+		if v == v'
+			then do
+				showNote "unchanged"
+				next $ next $ return True
+			else next $ next $ checkoutViewBranch v' narrowView
+
+	vcycle rest (c:cs)
+		| multiValue (viewFilter c) = rest ++ cs ++ [c]
+		| otherwise = vcycle (c:rest) cs
+	vcycle rest c = rest ++ c

Command/VFilter.hs

@@ -0,0 +1,30 @@
+{- git-annex command
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.VFilter where
+
+import Common.Annex
+import Command
+import Annex.View
+import Command.View (paramView, parseViewParam, checkoutViewBranch)
+
+def :: [Command]
+def = [notBareRepo $ notDirect $
+	command "vfilter" paramView seek SectionMetaData "filter current view"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start params = do
+	showStart "vfilter" ""
+	withCurrentView $ \view -> do
+		let view' = filterView view $
+			map parseViewParam $ reverse params
+		next $ next $ if visibleViewSize view' > visibleViewSize view
+			then error "That would add an additional level of directory structure to the view, rather than filtering it. If you want to do that, use vadd instead of vfilter."
+			else checkoutViewBranch view' narrowView

Command/VPop.hs

@@ -0,0 +1,50 @@
+{- git-annex command
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.VPop where
+
+import Common.Annex
+import Command
+import qualified Git
+import qualified Git.Command
+import qualified Git.Ref
+import Types.View
+import Logs.View
+import Command.View (checkoutViewBranch)
+
+def :: [Command]
+def = [notBareRepo $ notDirect $
+	command "vpop" (paramOptional paramNumber) seek SectionMetaData
+	"switch back to previous view"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start ps = go =<< currentView
+  where
+	go Nothing = error "Not in a view."
+	go (Just v) = do
+		showStart "vpop" (show num)
+		removeView v
+		(oldvs, vs) <- splitAt (num - 1) . filter (sameparentbranch v)
+			<$> recentViews
+		mapM_ removeView oldvs
+		case vs of
+			(oldv:_) -> next $ next $ do
+				showOutput
+				checkoutViewBranch oldv (return . branchView)
+			_ -> next $ next $ do
+				showOutput
+				inRepo $ Git.Command.runBool
+					[ Param "checkout"
+					, Param $ Git.fromRef $ Git.Ref.base $
+						viewParentBranch v
+					]
+	sameparentbranch a b = viewParentBranch a == viewParentBranch b
+
+	num = fromMaybe 1 $ readish =<< headMaybe ps 

Command/View.hs

@@ -0,0 +1,90 @@
+{- git-annex command
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.View where
+
+import Common.Annex
+import Command
+import qualified Git
+import qualified Git.Command
+import qualified Git.Ref
+import qualified Git.Branch
+import Types.MetaData
+import Types.View
+import Annex.View
+import Logs.View
+
+def :: [Command]
+def = [notBareRepo $ notDirect $
+	command "view" paramView seek SectionMetaData "enter a view branch"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start [] = error "Specify metadata to include in view"
+start params = do
+	showStart "view" ""
+	view <- mkView params
+	go view  =<< currentView
+  where
+	go view Nothing = next $ perform view
+	go view (Just v)
+		| v == view = stop
+		| otherwise = error "Already in a view. Use 'git annex vadd' to further refine this view."
+
+perform :: View -> CommandPerform
+perform view = do
+	showSideAction "searching"
+	next $ checkoutViewBranch view applyView
+
+paramView :: String
+paramView = paramPair (paramRepeating "FIELD=VALUE") (paramRepeating "TAG")
+
+parseViewParam :: String -> (MetaField, String)
+parseViewParam s = case separate (== '=') s of
+	(tag, []) -> (tagMetaField, tag)
+	(field, wanted) -> either error (\f -> (f, wanted)) (mkMetaField field)
+
+mkView :: [String] -> Annex View
+mkView params = do
+	v <- View <$> viewbranch <*> pure []
+	return $ fst $ refineView v $
+		map parseViewParam $ reverse params
+  where
+	viewbranch = fromMaybe (error "not on any branch!")
+		<$> inRepo Git.Branch.current
+
+checkoutViewBranch :: View -> (View -> Annex Git.Branch) -> CommandCleanup
+checkoutViewBranch view mkbranch = do
+	oldcwd <- liftIO getCurrentDirectory
+
+	{- Change to top of repository before creating view branch. -}
+	liftIO . setCurrentDirectory =<< fromRepo Git.repoPath
+	branch <- mkbranch view
+	
+	showOutput
+	ok <- inRepo $ Git.Command.runBool
+		[ Param "checkout"
+		, Param (Git.fromRef $ Git.Ref.base branch)
+		]
+	when ok $ do
+		setView view
+		{- A git repo can easily have empty directories in it,
+		 - and this pollutes the view, so remove them. -}
+		liftIO $ removeemptydirs "."
+		unlessM (liftIO $ doesDirectoryExist oldcwd) $ do
+			top <- fromRepo Git.repoPath
+			showLongNote (cwdmissing top)
+	return ok
+  where
+	removeemptydirs top = mapM_ (tryIO . removeDirectory)
+		=<< dirTreeRecursiveSkipping (".git" `isSuffixOf`) top
+	cwdmissing top = unlines
+		[ "This view does not include the subdirectory you are currently in."
+		, "Perhaps you should:  cd " ++ top
+		]

Creds.hs

@@ -1,29 +1,34 @@
 {- Credentials storage
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP #-}
+module Creds (
-
+	module Types.Creds,
-module Creds where
+	CredPairStorage(..),
+	setRemoteCredPair,
+	getRemoteCredPairFor,
+	getRemoteCredPair,
+	getEnvCredPair,
+	writeCacheCreds,
+	readCacheCreds,
+) where
 
 import Common.Annex
+import Types.Creds
 import Annex.Perms
 import Utility.FileMode
 import Crypto
 import Types.Remote (RemoteConfig, RemoteConfigKey)
 import Remote.Helper.Encryptable (remoteCipher, embedCreds)
-import Utility.Env (setEnv, getEnv)
+import Utility.Env (getEnv)
 
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified Data.Map as M
 import Utility.Base64
 
-type Creds = String -- can be any data
-type CredPair = (String, String) -- login, password
-
 {- A CredPair can be stored in a file, or in the environment, or perhaps
  - in a remote's configuration. -}
 data CredPairStorage = CredPairStorage
@@ -33,14 +38,13 @@ data CredPairStorage = CredPairStorage
 	}
 
 {- Stores creds in a remote's configuration, if the remote allows
- - that. Otherwise, caches them locally. -}
+ - that. Otherwise, caches them locally.
-setRemoteCredPair :: RemoteConfig -> CredPairStorage -> Annex RemoteConfig
+ - The creds are found in storage if not provided. -}
-setRemoteCredPair c storage = 
+setRemoteCredPair :: RemoteConfig -> CredPairStorage -> Maybe CredPair -> Annex RemoteConfig
-	maybe (return c) (setRemoteCredPair' c storage)
+setRemoteCredPair c storage Nothing = 
+	maybe (return c) (setRemoteCredPair c storage . Just)
 		=<< getRemoteCredPair c storage
-
+setRemoteCredPair c storage (Just creds)
-setRemoteCredPair' :: RemoteConfig -> CredPairStorage -> CredPair -> Annex RemoteConfig
-setRemoteCredPair' c storage creds
 	| embedCreds c = case credPairRemoteKey storage of
 		Nothing -> localcache
 		Just key -> storeconfig key =<< remoteCipher c
@@ -105,19 +109,6 @@ getEnvCredPair storage = liftM2 (,)
   where
 	(uenv, penv) = credPairEnvironment storage
 
-{- Stores a CredPair in the environment. -}
-setEnvCredPair :: CredPair -> CredPairStorage -> IO ()
-#ifndef mingw32_HOST_OS
-setEnvCredPair (l, p) storage = do
-	set uenv l
-	set penv p
-  where
-	(uenv, penv) = credPairEnvironment storage
-	set var val = void $ setEnv var val True
-#else
-setEnvCredPair _ _ = error "setEnvCredPair TODO"
-#endif
-
 writeCacheCredPair :: CredPair -> CredPairStorage -> Annex ()
 writeCacheCredPair credpair storage =
 	writeCacheCreds (encodeCredPair credpair) (credPairFile storage)

Git.hs

@@ -13,6 +13,7 @@
 module Git (
 	Repo(..),
 	Ref(..),
+	fromRef,
 	Branch,
 	Sha,
 	Tag,

Git/Branch.hs

@@ -28,7 +28,7 @@ current r = do
 	case v of
 		Nothing -> return Nothing
 		Just branch -> 
-			ifM (null <$> pipeReadStrict [Param "show-ref", Param $ show branch] r)
+			ifM (null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r)
 				( return Nothing
 				, return v
 				)
@@ -36,7 +36,7 @@ current r = do
 {- The current branch, which may not really exist yet. -}
 currentUnsafe :: Repo -> IO (Maybe Git.Ref)
 currentUnsafe r = parse . firstLine
-	<$> pipeReadStrict [Param "symbolic-ref", Param $ show Git.Ref.headRef] r
+	<$> pipeReadStrict [Param "symbolic-ref", Param $ fromRef Git.Ref.headRef] r
   where
 	parse l
 		| null l = Nothing
@@ -51,7 +51,7 @@ changed origbranch newbranch repo
   where
 	diffs = pipeReadStrict
 		[ Param "log"
-		, Param (show origbranch ++ ".." ++ show newbranch)
+		, Param (fromRef origbranch ++ ".." ++ fromRef newbranch)
 		, Params "--oneline -n1"
 		] repo
 
@@ -74,7 +74,7 @@ fastForward branch (first:rest) repo =
   where
 	no_ff = return False
 	do_ff to = do
-		run [Param "update-ref", Param $ show branch, Param $ show to] repo
+		run [Param "update-ref", Param $ fromRef branch, Param $ fromRef to] repo
 		return True
 	findbest c [] = return $ Just c
 	findbest c (r:rs)
@@ -104,14 +104,14 @@ commit allowempty message branch parentrefs repo = do
 	ifM (cancommit tree)
 		( do
 			sha <- getSha "commit-tree" $ pipeWriteRead
-				(map Param $ ["commit-tree", show tree] ++ ps)
+				(map Param $ ["commit-tree", fromRef tree] ++ ps)
 				(Just $ flip hPutStr message) repo
 			update branch sha repo
 			return $ Just sha
 		, return Nothing
 		)
   where
-	ps = concatMap (\r -> ["-p", show r]) parentrefs
+	ps = concatMap (\r -> ["-p", fromRef r]) parentrefs
 	cancommit tree
 		| allowempty = return True
 		| otherwise = case parentrefs of
@@ -130,8 +130,8 @@ forcePush b = "+" ++ b
 update :: Branch -> Sha -> Repo -> IO ()
 update branch sha = run 
 	[ Param "update-ref"
-	, Param $ show branch
+	, Param $ fromRef branch
-	, Param $ show sha
+	, Param $ fromRef sha
 	]
 
 {- Checks out a branch, creating it if necessary. -}
@@ -140,7 +140,7 @@ checkout branch = run
 	[ Param "checkout"
 	, Param "-q"
 	, Param "-B"
-	, Param $ show $ Git.Ref.base branch
+	, Param $ fromRef $ Git.Ref.base branch
 	]
 
 {- Removes a branch. -}
@@ -149,5 +149,5 @@ delete branch = run
 	[ Param "branch"
 	, Param "-q"
 	, Param "-D"
-	, Param $ show $ Git.Ref.base branch
+	, Param $ fromRef $ Git.Ref.base branch
 	]

Git/CatFile.hs

@@ -50,7 +50,7 @@ catFileStop (CatFileHandle p _) = CoProcess.stop p
 {- Reads a file from a specified branch. -}
 catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString
 catFile h branch file = catObject h $ Ref $
-	show branch ++ ":" ++ toInternalGitPath file
+	fromRef branch ++ ":" ++ toInternalGitPath file
 
 {- Uses a running git cat-file read the content of an object.
  - Objects that do not exist will have "" returned. -}
@@ -60,7 +60,7 @@ catObject h object = maybe L.empty fst3 <$> catObjectDetails h object
 catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType))
 catObjectDetails (CatFileHandle hdl _) object = CoProcess.query hdl send receive
   where
-	query = show object
+	query = fromRef object
 	send to = hPutStrLn to query
 	receive from = do
 		header <- hGetLine from
@@ -72,8 +72,8 @@ catObjectDetails (CatFileHandle hdl _) object = CoProcess.query hdl send receive
 						_ -> dne
 				| otherwise -> dne
 			_
-				| header == show object ++ " missing" -> dne
+				| header == fromRef object ++ " missing" -> dne
-				| otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)
+				| otherwise -> error $ "unknown response from git cat-file " ++ show (header, query)
 	readcontent objtype bytes from sha = do
 		content <- S.hGet from bytes
 		eatchar '\n' from

Git/Command.hs

@@ -25,18 +25,10 @@ gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
 gitCommandLine params r@(Repo { location = l@(Local _ _ ) }) =
 	setdir : settree ++ gitGlobalOpts r ++ params
   where
-	setdir = Param $ "--git-dir=" ++ gitpath (gitdir l)
+	setdir = Param $ "--git-dir=" ++ gitdir l
 	settree = case worktree l of
 		Nothing -> []
-		Just t -> [Param $ "--work-tree=" ++ gitpath t]
+		Just t -> [Param $ "--work-tree=" ++ t]
-#ifdef mingw32_HOST_OS
-	-- despite running on windows, msysgit wants a unix-formatted path
-	gitpath s
-		| isAbsolute s = "/" ++ dropDrive (toInternalGitPath s)
-		| otherwise = s
-#else
-	gitpath = id
-#endif
 gitCommandLine _ repo = assertLocal repo $ error "internal"
 
 {- Runs git in the specified repo. -}

Git/Construct.hs

@@ -33,6 +33,7 @@ import Common
 import Git.Types
 import Git
 import Git.Remote
+import Git.FilePath
 import qualified Git.Url as Url
 import Utility.UserInfo
 
@@ -57,7 +58,7 @@ fromPath dir = fromAbsPath =<< absPath dir
  - specified. -}
 fromAbsPath :: FilePath -> IO Repo
 fromAbsPath dir
-	| isAbsolute dir = ifM (doesDirectoryExist dir') ( ret dir' , hunt )
+	| absoluteGitPath dir = ifM (doesDirectoryExist dir') ( ret dir' , hunt )
 	| otherwise =
 		error $ "internal error, " ++ dir ++ " is not absolute"
   where

Git/DiffTree.hs

@@ -36,12 +36,12 @@ data DiffTreeItem = DiffTreeItem
 {- Diffs two tree Refs. -}
 diffTree :: Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool)
 diffTree src dst = getdiff (Param "diff-tree")
-	[Param (show src), Param (show dst)]
+	[Param (fromRef src), Param (fromRef dst)]
 
 {- Diffs two tree Refs, recursing into sub-trees -}
 diffTreeRecursive :: Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool)
 diffTreeRecursive src dst = getdiff (Param "diff-tree")
-	[Param "-r", Param (show src), Param (show dst)]
+	[Param "-r", Param (fromRef src), Param (fromRef dst)]
 
 {- Diffs between a tree and the index. Does nothing if there is not yet a
  - commit in the repository. -}
@@ -61,7 +61,7 @@ diffIndex' :: Ref -> [CommandParam] -> Repo -> IO ([DiffTreeItem], IO Bool)
 diffIndex' ref params repo =
 	ifM (Git.Ref.headExists repo)
 		( getdiff (Param "diff-index")
-			( params ++ [Param $ show ref] )
+			( params ++ [Param $ fromRef ref] )
 			repo
 		, return ([], return True)
 		)

Git/FilePath.hs

@@ -20,12 +20,15 @@ module Git.FilePath (
 	asTopFilePath,
 	InternalGitPath,
 	toInternalGitPath,
-	fromInternalGitPath
+	fromInternalGitPath,
+	absoluteGitPath
 ) where
 
 import Common
 import Git
 
+import qualified System.FilePath.Posix
+
 {- A FilePath, relative to the top of the git repository. -}
 newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }
 	deriving (Show)
@@ -48,8 +51,7 @@ asTopFilePath file = TopFilePath file
  - it internally. 
  -
  - On Windows, git uses '/' to separate paths stored in the repository,
- - despite Windows using '\'. Also, git on windows dislikes paths starting
+ - despite Windows using '\'.
- - with "./" or ".\".
  -
  -}
 type InternalGitPath = String
@@ -58,11 +60,7 @@ toInternalGitPath :: FilePath -> InternalGitPath
 #ifndef mingw32_HOST_OS
 toInternalGitPath = id
 #else
-toInternalGitPath p =
+toInternalGitPath = replace "\\" "/"
-	let p' = replace "\\" "/" p
-	in if "./" `isPrefixOf` p'
-		then dropWhile (== '/') (drop 1 p')
-		else p'
 #endif
 
 fromInternalGitPath :: InternalGitPath -> FilePath
@@ -71,3 +69,10 @@ fromInternalGitPath = id
 #else
 fromInternalGitPath = replace "/" "\\"
 #endif
+
+{- isAbsolute on Windows does not think "/foo" or "\foo" is absolute,
+ - so try posix paths.
+ -}
+absoluteGitPath :: FilePath -> Bool
+absoluteGitPath p = isAbsolute p ||
+	System.FilePath.Posix.isAbsolute (toInternalGitPath p)

Git/Fsck.hs

@@ -74,7 +74,7 @@ isMissing s r = either (const True) (const False) <$> tryIO dump
   where
 	dump = runQuiet
 		[ Param "show"
-		, Param (show s)
+		, Param (fromRef s)
 		] r
 
 findShas :: Bool -> String -> [Sha]

Git/HashObject.hs

@@ -1,6 +1,6 @@
 {- git hash-object interface
  -
- - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -13,6 +13,7 @@ import Git.Sha
 import Git.Command
 import Git.Types
 import qualified Utility.CoProcess as CoProcess
+import Utility.Tmp
 
 type HashObjectHandle = CoProcess.CoProcessHandle
 
@@ -34,7 +35,18 @@ hashFile h file = CoProcess.query h send receive
 	send to = hPutStrLn to file
 	receive from = getSha "hash-object" $ hGetLine from
 
-{- Injects some content into git, returning its Sha. -}
+{- Injects a blob into git. Unfortunately, the current git-hash-object
+ - interface does not allow batch hashing without using temp files. -}
+hashBlob :: HashObjectHandle -> String -> IO Sha
+hashBlob h s = withTmpFile "hash" $ \tmp tmph -> do
+	hPutStr tmph s
+	hClose tmph
+	hashFile h tmp
+
+{- Injects some content into git, returning its Sha.
+ - 
+ - Avoids using a tmp file, but runs a new hash-object command each
+ - time called. -}
 hashObject :: ObjectType -> String -> Repo -> IO Sha
 hashObject objtype content = hashObject' objtype (flip hPutStr content)
 

Git/LsTree.hs

@@ -38,13 +38,13 @@ lsTree t repo = map parseLsTree
 	<$> pipeNullSplitZombie (lsTreeParams t) repo
 
 lsTreeParams :: Ref -> [CommandParam]
-lsTreeParams t = [ Params "ls-tree --full-tree -z -r --", File $ show t ]
+lsTreeParams t = [ Params "ls-tree --full-tree -z -r --", File $ fromRef t ]
 
 {- Lists specified files in a tree. -}
 lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem]
 lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo
   where
-  	ps = [Params "ls-tree --full-tree -z --", File $ show t] ++ map File fs
+  	ps = [Params "ls-tree --full-tree -z --", File $ fromRef t] ++ map File fs
 
 {- Parses a line of ls-tree output.
  - (The --long format is not currently supported.) -}

Git/Merge.hs

@@ -15,7 +15,7 @@ import Git.BuildVersion
 {- Avoids recent git's interactive merge. -}
 mergeNonInteractive :: Ref -> Repo -> IO Bool
 mergeNonInteractive branch
-	| older "1.7.7.6" = merge [Param $ show branch]
+	| older "1.7.7.6" = merge [Param $ fromRef branch]
-	| otherwise = merge [Param "--no-edit", Param $ show branch]
+	| otherwise = merge [Param "--no-edit", Param $ fromRef branch]
   where
 	merge ps = runBool $ Param "merge" : ps

Git/Objects.hs

@@ -32,4 +32,4 @@ listLooseObjectShas r = catchDefaultIO [] $
 looseObjectFile :: Repo -> Sha -> FilePath
 looseObjectFile r sha = objectsDir r </> prefix </> rest
   where
-	(prefix, rest) = splitAt 2 (show sha)
+	(prefix, rest) = splitAt 2 (fromRef sha)

Git/Ref.hs

@@ -20,12 +20,12 @@ headRef = Ref "HEAD"
 
 {- Converts a fully qualified git ref into a user-visible string. -}
 describe :: Ref -> String
-describe = show . base
+describe = fromRef . base
 
 {- Often git refs are fully qualified (eg: refs/heads/master).
  - Converts such a fully qualified ref into a base ref (eg: master). -}
 base :: Ref -> Ref
-base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show
+base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef
   where
 	remove prefix s
 		| prefix `isPrefixOf` s = drop (length prefix) s
@@ -35,13 +35,13 @@ base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show
  - it under the directory. -}
 under :: String -> Ref -> Ref
 under dir r = Ref $ dir ++ "/" ++
-	(reverse $ takeWhile (/= '/') $ reverse $ show r)
+	(reverse $ takeWhile (/= '/') $ reverse $ fromRef r)
 
 {- Given a directory such as "refs/remotes/origin", and a ref such as
  - refs/heads/master, yields a version of that ref under the directory,
  - such as refs/remotes/origin/master. -}
 underBase :: String -> Ref -> Ref
-underBase dir r = Ref $ dir ++ "/" ++ show (base r)
+underBase dir r = Ref $ dir ++ "/" ++ fromRef (base r)
 
 {- A Ref that can be used to refer to a file in the repository, as staged
  - in the index.
@@ -64,12 +64,12 @@ fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr)
 {- Checks if a ref exists. -}
 exists :: Ref -> Repo -> IO Bool
 exists ref = runBool
-	[Param "show-ref", Param "--verify", Param "-q", Param $ show ref]
+	[Param "show-ref", Param "--verify", Param "-q", Param $ fromRef ref]
 
 {- The file used to record a ref. (Git also stores some refs in a
  - packed-refs file.) -}
 file :: Ref -> Repo -> FilePath
-file ref repo = localGitDir repo </> show ref
+file ref repo = localGitDir repo </> fromRef ref
 
 {- Checks if HEAD exists. It generally will, except for in a repository
  - that was just created. -}
@@ -84,17 +84,17 @@ sha branch repo = process <$> showref repo
   where
 	showref = pipeReadStrict [Param "show-ref",
 		Param "--hash", -- get the hash
-		Param $ show branch]
+		Param $ fromRef branch]
 	process [] = Nothing
 	process s = Just $ Ref $ firstLine s
 
 {- List of (shas, branches) matching a given ref or refs. -}
 matching :: [Ref] -> Repo -> IO [(Sha, Branch)]
-matching refs repo =  matching' (map show refs) repo
+matching refs repo =  matching' (map fromRef refs) repo
 
 {- Includes HEAD in the output, if asked for it. -}
 matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)]
-matchingWithHEAD refs repo = matching' ("--head" : map show refs) repo
+matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo
 
 {- List of (shas, branches) matching a given ref or refs. -}
 matching' :: [String] -> Repo -> IO [(Sha, Branch)]
@@ -114,7 +114,7 @@ matchingUniq refs repo = nubBy uniqref <$> matching refs repo
 {- Gets the sha of the tree a ref uses. -}
 tree :: Ref -> Repo -> IO (Maybe Sha)
 tree ref = extractSha <$$> pipeReadStrict
-	[ Param "rev-parse", Param (show ref ++ ":") ]
+	[ Param "rev-parse", Param (fromRef ref ++ ":") ]
 
 {- Checks if a String is a legal git ref name.
  -

Git/RefLog.hs

@@ -18,5 +18,5 @@ get b = mapMaybe extractSha . lines <$$> pipeReadStrict
 	[ Param "log"
 	, Param "-g"
 	, Param "--format=%H"
-	, Param (show b)
+	, Param (fromRef b)
 	]

Git/Repair.hs

@@ -168,7 +168,7 @@ resetLocalBranches :: MissingObjects -> GoodCommits -> Repo -> IO ([Branch], [Br
 resetLocalBranches missing goodcommits r =
 	go [] [] goodcommits =<< filter islocalbranch <$> getAllRefs r
   where
-	islocalbranch b = "refs/heads/" `isPrefixOf` show b
+	islocalbranch b = "refs/heads/" `isPrefixOf` fromRef b
 	go changed deleted gcs [] = return (changed, deleted, gcs)
 	go changed deleted gcs (b:bs) = do
 		(mc, gcs') <- findUncorruptedCommit missing gcs b r
@@ -185,12 +185,12 @@ resetLocalBranches missing goodcommits r =
 		nukeBranchRef b	r
 		void $ runBool
 			[ Param "branch"
-			, Param (show $ Ref.base b)
+			, Param (fromRef $ Ref.base b)
-			, Param (show c)
+			, Param (fromRef c)
 			] r
 
 isTrackingBranch :: Ref -> Bool
-isTrackingBranch b = "refs/remotes/" `isPrefixOf` show b
+isTrackingBranch b = "refs/remotes/" `isPrefixOf` fromRef b
 
 {- To deal with missing objects that cannot be recovered, removes
  - any branches (filtered by a predicate) that reference them
@@ -231,10 +231,10 @@ explodePackedRefsFile r = do
 		nukeFile f
   where
 	makeref (sha, ref) = do
-		let dest = localGitDir r </> show ref
+		let dest = localGitDir r </> fromRef ref
 		createDirectoryIfMissing True (parentDir dest)
 		unlessM (doesFileExist dest) $
-			writeFile dest (show sha)
+			writeFile dest (fromRef sha)
 
 packedRefsFile :: Repo -> FilePath
 packedRefsFile r = localGitDir r </> "packed-refs"
@@ -249,7 +249,7 @@ parsePacked l = case words l of
 {- git-branch -d cannot be used to remove a branch that is directly
  - pointing to a corrupt commit. -}
 nukeBranchRef :: Branch -> Repo -> IO ()
-nukeBranchRef b r = nukeFile $ localGitDir r </> show b
+nukeBranchRef b r = nukeFile $ localGitDir r </> fromRef b
 
 {- Finds the most recent commit to a branch that does not need any
  - of the missing objects. If the input branch is good as-is, returns it.
@@ -268,7 +268,7 @@ findUncorruptedCommit missing goodcommits branch r = do
 				[ Param "log"
 				, Param "-z"
 				, Param "--format=%H"
-				, Param (show branch)
+				, Param (fromRef branch)
 				] r
 			let branchshas = catMaybes $ map extractSha ls
 			reflogshas <- RefLog.get branch r
@@ -297,7 +297,7 @@ verifyCommit missing goodcommits commit r
 			[ Param "log"
 			, Param "-z"
 			, Param "--format=%H %T"
-			, Param (show commit)
+			, Param (fromRef commit)
 			] r
 		let committrees = map parse ls
 		if any isNothing committrees || null committrees
@@ -501,9 +501,9 @@ runRepair' removablebranch fsckresult forced referencerepo g = do
 				, "remote tracking branches that referred to missing objects."
 				]
 		(resetbranches, deletedbranches, _) <- resetLocalBranches stillmissing goodcommits g
-		displayList (map show resetbranches)
+		displayList (map fromRef resetbranches)
 			"Reset these local branches to old versions before the missing objects were committed:"
-		displayList (map show deletedbranches)
+		displayList (map fromRef deletedbranches)
 			"Deleted these local branches, which could not be recovered due to missing objects:"
 		deindexedfiles <- rewriteIndex g
 		displayList deindexedfiles
@@ -519,7 +519,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do
 						Just curr -> when (any (== curr) modifiedbranches) $ do
 							putStrLn $ unwords
 								[ "You currently have"
-								, show curr
+								, fromRef curr
 								, "checked out. You may have staged changes in the index that can be committed to recover the lost state of this branch!"
 								]
 				putStrLn "Successfully recovered repository!"

Git/Sha.hs

@@ -37,3 +37,7 @@ shaSize = 40
 
 nullSha :: Ref		
 nullSha = Ref $ replicate shaSize '0'
+
+{- Git's magic empty tree. -}
+emptyTree :: Ref
+emptyTree = Ref "4b825dc642cb6eb9a060e54bf8d69288fbee4904"

Git/Types.hs

@@ -47,10 +47,10 @@ type RemoteName = String
 
 {- A git ref. Can be a sha1, or a branch or tag name. -}
 newtype Ref = Ref String
-	deriving (Eq, Ord)
+	deriving (Eq, Ord, Read, Show)
 
-instance Show Ref where
+fromRef :: Ref -> String
-	show (Ref v) = v
+fromRef (Ref s) = s
 
 {- Aliases for Ref. -}
 type Branch = Ref

Git/UpdateIndex.hs

@@ -11,6 +11,9 @@ module Git.UpdateIndex (
 	Streamer,
 	pureStreamer,
 	streamUpdateIndex,
+	streamUpdateIndex',
+	startUpdateIndex,
+	stopUpdateIndex,
 	lsTree,
 	updateIndexLine,
 	stageFile,
@@ -25,6 +28,9 @@ import Git.Command
 import Git.FilePath
 import Git.Sha
 
+import Control.Exception (bracket)
+import System.Process (std_in)
+
 {- Streamers are passed a callback and should feed it lines in the form
  - read by update-index, and generated by ls-tree. -}
 type Streamer = (String -> IO ()) -> IO ()
@@ -35,17 +41,30 @@ pureStreamer !s = \streamer -> streamer s
 
 {- Streams content into update-index from a list of Streamers. -}
 streamUpdateIndex :: Repo -> [Streamer] -> IO ()
-streamUpdateIndex repo as = pipeWrite params repo $ \h -> do
+streamUpdateIndex repo as = bracket (startUpdateIndex repo) stopUpdateIndex $
-	fileEncoding h
+	(\h -> forM_ as $ streamUpdateIndex' h)
-	forM_ as (stream h)
+
-	hClose h
+data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle
-  where
+
-	params = map Param ["update-index", "-z", "--index-info"]
+streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO ()
-	stream h a = a (streamer h)
+streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do
-	streamer h s = do
 	hPutStr h s
 	hPutStr h "\0"
 
+startUpdateIndex :: Repo -> IO UpdateIndexHandle
+startUpdateIndex repo = do
+	(Just h, _, _, p) <- createProcess (gitCreateProcess params repo)
+		{ std_in = CreatePipe }
+	fileEncoding h
+	return $ UpdateIndexHandle p h
+  where
+	params = map Param ["update-index", "-z", "--index-info"]
+
+stopUpdateIndex :: UpdateIndexHandle -> IO Bool
+stopUpdateIndex (UpdateIndexHandle p h) = do
+	hClose h
+	checkSuccessProcess p
+
 {- A streamer that adds the current tree for a ref. Useful for eg, copying
  - and modifying branches. -}
 lsTree :: Ref -> Repo -> Streamer
@@ -60,7 +79,7 @@ lsTree (Ref x) repo streamer = do
  - a given file with a given sha. -}
 updateIndexLine :: Sha -> BlobType -> TopFilePath -> String
 updateIndexLine sha filetype file =
-	show filetype ++ " blob " ++ show sha ++ "\t" ++ indexPath file
+	show filetype ++ " blob " ++ fromRef sha ++ "\t" ++ indexPath file
 
 stageFile :: Sha -> BlobType -> FilePath -> Repo -> IO Streamer
 stageFile sha filetype file repo = do
@@ -71,7 +90,7 @@ stageFile sha filetype file repo = do
 unstageFile :: FilePath -> Repo -> IO Streamer
 unstageFile file repo = do
 	p <- toTopFilePath file repo
-	return $ pureStreamer $ "0 " ++ show nullSha ++ "\t" ++ indexPath p
+	return $ pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p
 
 {- A streamer that adds a symlink to the index. -}
 stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer

Limit.hs

@@ -9,11 +9,6 @@
 
 module Limit where
 
-import Data.Time.Clock.POSIX
-import qualified Data.Set as S
-import qualified Data.Map as M
-import System.Path.WildMatch
-
 import Common.Annex
 import qualified Annex
 import qualified Utility.Matcher
@@ -28,6 +23,8 @@ import Types.Key
 import Types.Group
 import Types.FileMatcher
 import Types.Limit
+import Types.MetaData
+import Logs.MetaData
 import Logs.Group
 import Logs.Unused
 import Logs.Location
@@ -35,14 +32,14 @@ import Git.Types (RefDate(..))
 import Utility.HumanTime
 import Utility.DataUnits
 
+import Data.Time.Clock.POSIX
+import qualified Data.Set as S
+import qualified Data.Map as M
+import System.Path.WildMatch
+
 #ifdef WITH_TDFA
 import Text.Regex.TDFA
 import Text.Regex.TDFA.String
-#else
-#ifndef mingw32_HOST_OS
-import System.Path.WildMatch
-import Types.FileMatcher
-#endif
 #endif
 
 {- Checks if there are user-specified limits. -}
@@ -156,7 +153,7 @@ limitPresent u _ = Right $ const $ checkKey $ \key -> do
 limitInDir :: FilePath -> MkLimit
 limitInDir dir = const $ Right $ const go
   where
-	go (MatchingFile fi) = return $ any (== dir) $ splitPath $ takeDirectory $ matchFile fi
+	go (MatchingFile fi) = return $ elem dir $ splitPath $ takeDirectory $ matchFile fi
 	go (MatchingKey _) = return False
 
 {- Adds a limit to skip files not believed to have the specified number
@@ -267,6 +264,16 @@ limitSize vs s = case readSize dataUnits s of
 				<$> getFileStatus (relFile fi)
 		return $ filesize `vs` Just sz
 
+addMetaData :: String -> Annex ()
+addMetaData = addLimit . limitMetaData
+
+limitMetaData :: MkLimit
+limitMetaData s = case parseMetaData s of
+	Left e -> Left e
+	Right (f, v) -> Right $ const $ checkKey (check f v)
+  where
+  	check f v k = S.member v . metaDataValues f <$> getCurrentMetaData k
+
 addTimeLimit :: String -> Annex ()
 addTimeLimit s = do
 	let seconds = maybe (error "bad time-limit") durationToPOSIXTime $

Locations.hs

@@ -40,6 +40,8 @@ module Locations (
 	gitAnnexJournalLock,
 	gitAnnexIndex,
 	gitAnnexIndexStatus,
+	gitAnnexViewIndex,
+	gitAnnexViewLog,
 	gitAnnexIgnoredRefs,
 	gitAnnexPidFile,
 	gitAnnexDaemonStatusFile,
@@ -252,6 +254,14 @@ gitAnnexIndex r = gitAnnexDir r </> "index"
 gitAnnexIndexStatus :: Git.Repo -> FilePath
 gitAnnexIndexStatus r = gitAnnexDir r </> "index.lck"
 
+{- The index file used to generate a filtered branch view._-}
+gitAnnexViewIndex :: Git.Repo -> FilePath
+gitAnnexViewIndex r = gitAnnexDir r </> "viewindex"
+
+{- File containing a log of recently accessed views. -}
+gitAnnexViewLog :: Git.Repo -> FilePath
+gitAnnexViewLog r = gitAnnexDir r </> "viewlog"
+
 {- List of refs that should not be merged into the git-annex branch. -}
 gitAnnexIgnoredRefs :: Git.Repo -> FilePath
 gitAnnexIgnoredRefs r = gitAnnexDir r </> "ignoredrefs"
@@ -330,7 +340,7 @@ preSanitizeKeyName = concatMap escape
 		-- other characters. By itself, it is escaped to 
 		-- doubled form.
 		| c == ',' = ",,"
-		| otherwise = ',' : show(ord(c))
+		| otherwise = ',' : show (ord c)
 
 {- Converts a key into a filename fragment without any directory.
  -

Logs.hs

@@ -1,6 +1,6 @@
 {- git-annex log file names
  -
- - Copyright 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2013-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -15,7 +15,7 @@ data LogVariety
 	= UUIDBasedLog
 	| NewUUIDBasedLog
 	| PresenceLog Key
-	| SingleValueLog
+	| OtherLog
 	deriving (Show)
 
 {- Converts a path from the git-annex branch into one of the varieties
@@ -24,7 +24,7 @@ getLogVariety :: FilePath -> Maybe LogVariety
 getLogVariety f
 	| f `elem` topLevelUUIDBasedLogs = Just UUIDBasedLog
 	| isRemoteStateLog f = Just NewUUIDBasedLog
-	| f == numcopiesLog = Just SingleValueLog
+	| isMetaDataLog f || f == numcopiesLog = Just OtherLog
 	| otherwise = PresenceLog <$> firstJust (presenceLogs f)
 
 {- All the uuid-based logs stored in the top of the git-annex branch. -}
@@ -119,14 +119,25 @@ remoteStateLogExt = ".log.rmt"
 isRemoteStateLog :: FilePath -> Bool
 isRemoteStateLog path = remoteStateLogExt `isSuffixOf` path
 
+{- The filename of the metadata log for a given key. -}
+metaDataLogFile :: Key -> FilePath
+metaDataLogFile key = hashDirLower key </> keyFile key ++ metaDataLogExt
+
+metaDataLogExt :: String
+metaDataLogExt = ".log.met"
+
+isMetaDataLog :: FilePath -> Bool
+isMetaDataLog path = metaDataLogExt `isSuffixOf` path
+
 prop_logs_sane :: Key -> Bool
-prop_logs_sane dummykey = all id
+prop_logs_sane dummykey = and
 	[ isNothing (getLogVariety "unknown")
 	, expect isUUIDBasedLog (getLogVariety uuidLog)
 	, expect isPresenceLog (getLogVariety $ locationLogFile dummykey)
 	, expect isPresenceLog (getLogVariety $ urlLogFile dummykey)
 	, expect isNewUUIDBasedLog (getLogVariety $ remoteStateLogFile dummykey)
-	, expect isSingleValueLog (getLogVariety $ numcopiesLog)
+	, expect isOtherLog (getLogVariety $ metaDataLogFile dummykey)
+	, expect isOtherLog (getLogVariety $ numcopiesLog)
 	]
   where
   	expect = maybe False
@@ -136,5 +147,5 @@ prop_logs_sane dummykey = all id
 	isNewUUIDBasedLog _ = False
 	isPresenceLog (PresenceLog k) = k == dummykey
 	isPresenceLog _ = False
-	isSingleValueLog SingleValueLog = True
+	isOtherLog OtherLog = True
-	isSingleValueLog _ = False
+	isOtherLog _ = False

Logs/FsckResults.hs

@@ -31,7 +31,7 @@ writeFsckResults u fsckresults = do
   	store s logfile = do 
 		createDirectoryIfMissing True (parentDir logfile)
 		liftIO $ viaTmp writeFile logfile $ serialize s
-	serialize = unlines . map show . S.toList
+	serialize = unlines . map fromRef . S.toList
 
 readFsckResults :: UUID -> Annex FsckResults
 readFsckResults u = do

Logs/MetaData.hs

@@ -0,0 +1,137 @@
+{- git-annex general metadata storage log
+ -
+ - A line of the log will look like "timestamp field [+-]value [...]"
+ -
+ - Note that unset values are preserved. Consider this case:
+ -
+ - We have:
+ -
+ - 100 foo +x
+ - 200 foo -x
+ -
+ - An unmerged remote has:
+ -
+ - 150 foo +x
+ - 
+ - After union merge, because the foo -x was preserved, we know that
+ - after the other remote redundantly set foo +x, it was unset,
+ - and so foo currently has no value.
+ -
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE CPP #-}
+
+module Logs.MetaData (
+	getCurrentMetaData,
+	getMetaData,
+	addMetaData,
+	addMetaData',
+	currentMetaData,
+) where
+
+import Common.Annex
+import Types.MetaData
+import qualified Annex.Branch
+import Logs
+import Logs.SingleValue
+
+import qualified Data.Set as S
+import Data.Time.Clock.POSIX
+
+instance SingleValueSerializable MetaData where
+	serialize = Types.MetaData.serialize
+	deserialize = Types.MetaData.deserialize
+
+getMetaData :: Key -> Annex (Log MetaData)
+getMetaData = readLog . metaDataLogFile
+
+{- Go through the log from oldest to newest, and combine it all
+ - into a single MetaData representing the current state. -}
+getCurrentMetaData :: Key -> Annex MetaData
+getCurrentMetaData = currentMetaData . collect <$$> getMetaData
+  where
+	collect = foldl' unionMetaData newMetaData . map value . S.toAscList
+
+{- Adds in some metadata, which can override existing values, or unset
+ - them, but otherwise leaves any existing metadata as-is. -}
+addMetaData :: Key -> MetaData -> Annex ()
+addMetaData k metadata = addMetaData' k metadata =<< liftIO getPOSIXTime
+
+{- Reusing the same timestamp when making changes to the metadata
+ - of multiple keys is a nice optimisation. The same metadata lines
+ - will tend to be generated across the different log files, and so
+ - git will be able to pack the data more efficiently. -}
+addMetaData' :: Key -> MetaData -> POSIXTime -> Annex ()
+addMetaData' k metadata now = Annex.Branch.change (metaDataLogFile k) $
+	showLog . simplifyLog 
+		. S.insert (LogEntry now metadata) 
+		. parseLog
+
+{- Simplify a log, removing historical values that are no longer
+ - needed. 
+ -
+ - This is not as simple as just making a single log line with the newest
+ - state of all metadata. Consider this case:
+ -
+ - We have:
+ -
+ - 100 foo +x bar +y
+ - 200 foo -x
+ -
+ - An unmerged remote has:
+ -
+ - 150 bar -y baz +w
+ -
+ - If what we have were simplified to "200 foo -x bar +y" then when the line
+ - from the remote became available, it would be older than the simplified
+ - line, and its change to bar would not take effect. That is wrong.
+ -
+ - Instead, simplify it to:
+ -
+ - 100 bar +y
+ - 200 foo -x
+ -
+ - (Note that this ends up with the same number of lines as the
+ - unsimplified version, so there's really no point in updating
+ - the log to this version. Doing so would only add data to git,
+ - with little benefit.)
+ -
+ - Now merging with the remote yields:
+ -
+ - 100 bar +y
+ - 150 bar -y baz +w
+ - 200 foo -x
+ -
+ - Simplifying again:
+ -
+ - 150 bar +z baz +w
+ - 200 foo -x
+ -}
+simplifyLog :: Log MetaData -> Log MetaData
+simplifyLog s = case sl of
+	(newest:rest) -> 
+		let sl' = go [newest] (value newest) rest
+		in if length sl' < length sl
+			then S.fromList sl'
+			else s
+	_ -> s
+  where
+#if MIN_VERSION_containers(0,5,0)
+	sl = S.toDescList s
+#else
+	sl = reverse (S.toAscList s)
+#endif
+
+	go c _ [] = c
+	go c newer (l:ls)
+		| unique == newMetaData = go c newer ls
+		| otherwise = go (l { value = unique } : c)
+			(unionMetaData unique newer) ls
+	  where
+		older = value l
+		unique = older `differenceMetaData` newer

Logs/Transfer.hs

@@ -17,6 +17,10 @@ import Types.Key
 import Utility.Metered
 import Utility.Percentage
 import Utility.QuickCheck
+import Utility.PID
+#ifdef mingw32_HOST_OS
+import Utility.WinLock
+#endif
 
 import Data.Time.Clock
 import Data.Time.Clock.POSIX
@@ -24,20 +28,6 @@ import Data.Time
 import System.Locale
 import Control.Concurrent
 
-#ifndef mingw32_HOST_OS
-import System.Posix.Types (ProcessID)
-#else
-import System.Win32.Process (ProcessId)
-import System.Win32.Process.Current (getCurrentProcessId)
-import Utility.WinLock
-#endif
-
-#ifndef mingw32_HOST_OS
-type PID = ProcessID
-#else
-type PID = ProcessId
-#endif
-
 {- Enough information to uniquely identify a transfer, used as the filename
  - of the transfer information file. -}
 data Transfer = Transfer
@@ -231,7 +221,7 @@ startTransferInfo file = TransferInfo
 #ifndef mingw32_HOST_OS
 	<*> pure Nothing -- pid not stored in file, so omitted for speed
 #else
-	<*> (Just <$> getCurrentProcessId)
+	<*> (Just <$> getPID)
 #endif
 	<*> pure Nothing -- tid ditto
 	<*> pure Nothing -- not 0; transfer may be resuming

Logs/Unused.hs

@@ -86,7 +86,9 @@ readUnusedLog prefix = do
 		_ -> Nothing
 	  where
 		(sint, rest) = separate (== ' ') line
-		(skey, ts) = separate (== ' ') rest
+		(rts, rskey) = separate (== ' ') (reverse rest)
+		skey = reverse rskey
+		ts = reverse rts
 
 readUnusedMap :: FilePath -> Annex UnusedMap
 readUnusedMap = log2map <$$> readUnusedLog

Logs/View.hs

@@ -0,0 +1,89 @@
+{- git-annex recent views log
+ -
+ - The most recently accessed view comes first.
+ -
+ - This file is stored locally in .git/annex/, not in the git-annex branch.
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Logs.View (
+	currentView,
+	setView,
+	removeView,
+	recentViews,
+	branchView,
+	prop_branchView_legal,
+) where
+
+import Common.Annex
+import Types.View
+import Types.MetaData
+import qualified Git
+import qualified Git.Branch
+import qualified Git.Ref
+import Git.Types
+import Utility.Tmp
+
+import qualified Data.Set as S
+import Data.Char
+
+setView :: View -> Annex ()
+setView v = do
+	old <- take 99 . filter (/= v) <$> recentViews
+	writeViews (v : old)
+
+writeViews :: [View] -> Annex ()
+writeViews l = do
+	f <- fromRepo gitAnnexViewLog
+	liftIO $ viaTmp writeFile f $ unlines $ map show l
+
+removeView :: View -> Annex ()
+removeView v = writeViews =<< filter (/= v) <$> recentViews
+
+recentViews :: Annex [View]
+recentViews = do
+	f <- fromRepo gitAnnexViewLog
+	liftIO $ mapMaybe readish . lines <$> catchDefaultIO [] (readFile f)
+
+{- Gets the currently checked out view, if there is one. -}
+currentView :: Annex (Maybe View)
+currentView = go =<< inRepo Git.Branch.current
+  where
+	go (Just b) | branchViewPrefix `isPrefixOf` fromRef b =
+		headMaybe . filter (\v -> branchView v == b) <$> recentViews
+	go _ = return Nothing
+
+branchViewPrefix :: String
+branchViewPrefix = "refs/heads/views"
+
+{- Generates a git branch name for a View.
+ - 
+ - There is no guarantee that each view gets a unique branch name,
+ - but the branch name is used to express the view as well as possible.
+ -}
+branchView :: View -> Git.Branch
+branchView view
+	| null name = Git.Ref branchViewPrefix
+	| otherwise = Git.Ref $ branchViewPrefix ++ "/" ++ name
+  where
+	name = intercalate ";" $ map branchcomp (viewComponents view)
+	branchcomp c
+		| viewVisible c = branchcomp' c
+		| otherwise = "(" ++ branchcomp' c ++ ")"
+	branchcomp' (ViewComponent metafield viewfilter _) =concat
+		[ forcelegal (fromMetaField metafield)
+		, "="
+		, branchvals viewfilter
+		]
+	branchvals (FilterValues set) = intercalate "," $
+		map (forcelegal . fromMetaValue) $ S.toList set
+	branchvals (FilterGlob glob) = forcelegal glob
+	forcelegal s
+		| Git.Ref.legal True s = s
+		| otherwise = map (\c -> if isAlphaNum c then c else '_') s
+
+prop_branchView_legal :: View -> Bool
+prop_branchView_legal = Git.Ref.legal False . fromRef . branchView

Makefile

@@ -252,7 +252,8 @@ hdevtools:
 
 distributionupdate:
 	git pull
-	ghc --make Build/DistributionUpdate
+	cabal configure
+	ghc --make Build/DistributionUpdate -XPackageImports
 	./Build/DistributionUpdate
 
 .PHONY: git-annex git-union-merge git-recover-repository tags build-stamp

Remote.hs

@@ -189,8 +189,7 @@ prettyUUID u = concat <$> prettyListUUIDs [u]
 remoteFromUUID :: UUID -> Annex (Maybe Remote)
 remoteFromUUID u = ifM ((==) u <$> getUUID)
 	( return Nothing
-	, do
+	, maybe tryharder (return . Just) =<< findinmap
-		maybe tryharder (return . Just) =<< findinmap
 	)
   where
 	findinmap = M.lookup u <$> remoteMap id

Remote/Bup.hs

@@ -15,6 +15,7 @@ import Data.ByteString.Lazy.UTF8 (fromString)
 import Common.Annex
 import Types.Remote
 import Types.Key
+import Types.Creds
 import qualified Git
 import qualified Git.Command
 import qualified Git.Config
@@ -82,8 +83,8 @@ gen r u c gc = do
   where
 	buprepo = fromMaybe (error "missing buprepo") $ remoteAnnexBupRepo gc
 
-bupSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+bupSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-bupSetup mu c = do
+bupSetup mu _ c = do
 	u <- maybe (liftIO genUUID) return mu
 
 	-- verify configuration is sane

Remote/Directory.hs

@@ -16,6 +16,7 @@ import Data.Int
 
 import Common.Annex
 import Types.Remote
+import Types.Creds
 import qualified Git
 import Config.Cost
 import Config
@@ -67,8 +68,8 @@ gen r u c gc = do
   where
 	dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc
 
-directorySetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+directorySetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-directorySetup mu c = do
+directorySetup mu _ c = do
 	u <- maybe (liftIO genUUID) return mu
 	-- verify configuration is sane
 	let dir = fromMaybe (error "Specify directory=") $

Remote/External.hs

@@ -73,8 +73,8 @@ gen r u c gc = do
   where
 	externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc)
 
-externalSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+externalSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-externalSetup mu c = do
+externalSetup mu _ c = do
 	u <- maybe (liftIO genUUID) return mu
 	let externaltype = fromMaybe (error "Specify externaltype=") $
 		M.lookup "externaltype" c
@@ -92,16 +92,18 @@ externalSetup mu c = do
 
 store :: External -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
 store external k _f p = sendAnnex k rollback $ \f ->
-	storeHelper external k f p
+	metered (Just p) k $
+		storeHelper external k f
   where
 	rollback = void $ remove external k
 
 storeEncrypted :: External -> [CommandParam] -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
 storeEncrypted external gpgOpts (cipher, enck) k p = withTmp enck $ \tmp ->
 	sendAnnex k rollback $ \src -> do
+		metered (Just p) k $ \meterupdate -> do
 			liftIO $ encrypt gpgOpts cipher (feedFile src) $
 				readBytes $ L.writeFile tmp
-		storeHelper external enck tmp p
+			storeHelper external enck tmp meterupdate
   where
 	rollback = void $ remove external enck
 
@@ -118,11 +120,13 @@ storeHelper external k f p = safely $
 			_ -> Nothing
 
 retrieve :: External -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
-retrieve external k _f d p = retrieveHelper external k d p
+retrieve external k _f d p = metered (Just p) k $
+	retrieveHelper external k d
 
 retrieveEncrypted :: External -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
-retrieveEncrypted external (cipher, enck) _ f p = withTmp enck $ \tmp ->
+retrieveEncrypted external (cipher, enck) k f p = withTmp enck $ \tmp ->
-	ifM (retrieveHelper external enck tmp p)
+	metered (Just p) k $ \meterupdate -> 
+		ifM (retrieveHelper external enck tmp meterupdate)
 			( liftIO $ catchBoolIO $ do
 				decrypt cipher (feedFile tmp) $
 					readBytes $ L.writeFile f
@@ -221,8 +225,8 @@ handleRequest' lck external req mp responsehandler
 		send $ VALUE value
 	handleRemoteRequest (SETCREDS setting login password) = do
 		c <- liftIO $ atomically $ readTMVar $ externalConfig external
-		c' <- setRemoteCredPair' c (credstorage setting)
+		c' <- setRemoteCredPair c (credstorage setting) $
-			(login, password)
+			Just (login, password)
 		void $ liftIO $ atomically $ swapTMVar (externalConfig external) c'
 	handleRemoteRequest (GETCREDS setting) = do
 		c <- liftIO $ atomically $ readTMVar $ externalConfig external

Remote/GCrypt.hs

@@ -21,6 +21,7 @@ import Common.Annex
 import Types.Remote
 import Types.GitConfig
 import Types.Crypto
+import Types.Creds
 import qualified Git
 import qualified Git.Command
 import qualified Git.Config
@@ -149,8 +150,8 @@ noCrypto = error "cannot use gcrypt remote without encryption enabled"
 unsupportedUrl :: Annex a
 unsupportedUrl = error "using non-ssh remote repo url with gcrypt is not supported"
 
-gCryptSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+gCryptSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-gCryptSetup mu c = go $ M.lookup "gitrepo" c
+gCryptSetup mu _ c = go $ M.lookup "gitrepo" c
   where
 	remotename = fromJust (M.lookup "name" c)
   	go Nothing = error "Specify gitrepo="
@@ -176,7 +177,7 @@ gCryptSetup mu c = go $ M.lookup "gitrepo" c
 		void $ inRepo $ Git.Command.runBool
 			[ Param "push"
 			, Param remotename
-			, Param $ show Annex.Branch.fullname
+			, Param $ Git.fromRef Annex.Branch.fullname
 			]
 		g <- inRepo Git.Config.reRead
 		case Git.GCrypt.remoteRepoId g (Just remotename) of

Remote/Glacier.hs

@@ -70,17 +70,18 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
 			remotetype = remote
 		}
 
-glacierSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+glacierSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-glacierSetup mu c = do
+glacierSetup mu mcreds c = do
 	u <- maybe (liftIO genUUID) return mu
-	glacierSetup' u c
+	glacierSetup' (isJust mu) u mcreds c
-glacierSetup' :: UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+glacierSetup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-glacierSetup' u c = do
+glacierSetup' enabling u mcreds c = do
 	c' <- encryptionSetup c
 	let fullconfig = c' `M.union` defaults
+	unless enabling $
 		genVault fullconfig u
 	gitConfigSpecialRemote u fullconfig "glacier" "true"
-	c'' <- setRemoteCredPair fullconfig (AWS.creds u)
+	c'' <- setRemoteCredPair fullconfig (AWS.creds u) mcreds
 	return (c'', u)
   where
 	remotename = fromJust (M.lookup "name" c)
@@ -245,7 +246,6 @@ archive r k = fileprefix ++ key2file k
   where
 	fileprefix = M.findWithDefault "" "fileprefix" $ config r
 
--- glacier vault create will succeed even if the vault already exists.
 genVault :: RemoteConfig -> UUID -> Annex ()
 genVault c u = unlessM (runGlacier c u params) $
 	error "Failed creating glacier vault."

Remote/Helper/AWS.hs

@@ -22,9 +22,6 @@ creds u = CredPairStorage
 	, credPairRemoteKey = Just "s3creds"
 	}
 
-setCredsEnv :: CredPair -> IO ()
-setCredsEnv p = setEnvCredPair p $ creds undefined
-
 data Service = S3 | Glacier
 	deriving (Eq)
 

Remote/Hook.hs

@@ -13,6 +13,7 @@ import qualified Data.Map as M
 import Common.Annex
 import Types.Remote
 import Types.Key
+import Types.Creds
 import qualified Git
 import Config
 import Config.Cost
@@ -65,8 +66,8 @@ gen r u c gc = do
   where
 	hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc
 
-hookSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+hookSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-hookSetup mu c = do
+hookSetup mu _ c = do
 	u <- maybe (liftIO genUUID) return mu
 	let hooktype = fromMaybe (error "Specify hooktype=") $
 		M.lookup "hooktype" c

Remote/Rsync.hs

@@ -18,14 +18,6 @@ module Remote.Rsync (
 	RsyncOpts
 ) where
 
-import qualified Data.ByteString.Lazy as L
-import qualified Data.Map as M
-#ifndef mingw32_HOST_OS
-import System.Posix.Process (getProcessID)
-#else
-import System.Win32.Process.Current (getCurrentProcessId)
-#endif
-
 import Common.Annex
 import Types.Remote
 import qualified Git
@@ -40,8 +32,13 @@ import Crypto
 import Utility.Rsync
 import Utility.CopyFile
 import Utility.Metered
+import Utility.PID
 import Annex.Perms
 import Logs.Transfer
+import Types.Creds
+
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Map as M
 
 type RsyncUrl = String
 
@@ -115,31 +112,31 @@ genRsyncOpts c gc transport url = RsyncOpts
 		| otherwise = True
 
 rsyncTransport :: RemoteGitConfig -> RsyncUrl -> Annex ([CommandParam], RsyncUrl)
-rsyncTransport gc rawurl
+rsyncTransport gc url
-	| rsyncUrlIsShell rawurl =
+	| rsyncUrlIsShell url =
-		(\rsh -> return (rsyncShell rsh, resturl)) =<<
+		(\rsh -> return (rsyncShell rsh, url)) =<<
 		case fromNull ["ssh"] (remoteAnnexRsyncTransport gc) of
 			"ssh":sshopts -> do
 				let (port, sshopts') = sshReadPort sshopts
-				    host = takeWhile (/=':') resturl
+				    userhost = takeWhile (/=':') url
 				-- Connection caching
 				(Param "ssh":) <$> sshCachingOptions
-					(host, port)
+					(userhost, port)
 					(map Param $ loginopt ++ sshopts')
 			"rsh":rshopts -> return $ map Param $ "rsh" :
 				loginopt ++ rshopts
 			rsh -> error $ "Unknown Rsync transport: "
 				++ unwords rsh
-	| otherwise = return ([], rawurl)
+	| otherwise = return ([], url)
   where
-	(login,resturl) = case separate (=='@') rawurl of
+	login = case separate (=='@') url of
-		(h, "") -> (Nothing, h)
+		(_h, "") -> Nothing
-		(l, h)  -> (Just l, h)
+		(l, _)  -> Just l
 	loginopt = maybe [] (\l -> ["-l",l]) login
 	fromNull as xs = if null xs then as else xs
 
-rsyncSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+rsyncSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-rsyncSetup mu c = do
+rsyncSetup mu _ c = do
 	u <- maybe (liftIO genUUID) return mu
 	-- verify configuration is sane
 	let url = fromMaybe (error "Specify rsyncurl=") $
@@ -249,14 +246,10 @@ sendParams = ifM crippledFileSystem
  - up trees for rsync. -}
 withRsyncScratchDir :: (FilePath -> Annex a) -> Annex a
 withRsyncScratchDir a = do
-#ifndef mingw32_HOST_OS
+	p <- liftIO getPID
-	v <- liftIO getProcessID
-#else
-	v <- liftIO getCurrentProcessId
-#endif
 	t <- fromRepo gitAnnexTmpDir
 	createAnnexDirectory t
-	let tmp = t </> "rsynctmp" </> show v
+	let tmp = t </> "rsynctmp" </> show p
 	nuke tmp
 	liftIO $ createDirectoryIfMissing True tmp
 	nuke tmp `after` a tmp

Remote/S3.hs

@@ -73,12 +73,12 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 			remotetype = remote
 		}
 
-s3Setup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-s3Setup mu c = do
+s3Setup mu mcreds c = do
 	u <- maybe (liftIO genUUID) return mu
-	s3Setup' u c
+	s3Setup' u mcreds c
-s3Setup' :: UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+s3Setup' :: UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-s3Setup' u c = if isIA c then archiveorg else defaulthost
+s3Setup' u mcreds c = if isIA c then archiveorg else defaulthost
   where
 	remotename = fromJust (M.lookup "name" c)
 	defbucket = remotename ++ "-" ++ fromUUID u
@@ -92,7 +92,7 @@ s3Setup' u c = if isIA c then archiveorg else defaulthost
 		
 	use fullconfig = do
 		gitConfigSpecialRemote u fullconfig "s3" "true"
-		c' <- setRemoteCredPair fullconfig (AWS.creds u)
+		c' <- setRemoteCredPair fullconfig (AWS.creds u) mcreds
 		return (c', u)
 
 	defaulthost = do

Remote/Tahoe.hs

@@ -29,6 +29,7 @@ import Control.Concurrent.STM
 
 import Common.Annex
 import Types.Remote
+import Types.Creds
 import qualified Git
 import Config
 import Config.Cost
@@ -85,8 +86,8 @@ gen r u c gc = do
 		remotetype = remote
 	}
 
-tahoeSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+tahoeSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-tahoeSetup mu c = do
+tahoeSetup mu _ c = do
 	furl <- fromMaybe (fromMaybe missingfurl $ M.lookup furlk c)
 		<$> liftIO (getEnv "TAHOE_FURL")
 	u <- maybe (liftIO genUUID) return mu

Remote/WebDAV.hs

@@ -1,13 +1,13 @@
 {- WebDAV remotes.
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
 {-# LANGUAGE ScopedTypeVariables, CPP #-}
 
-module Remote.WebDAV (remote, davCreds, setCredsEnv, configUrl) where
+module Remote.WebDAV (remote, davCreds, configUrl) where
 
 import Network.Protocol.HTTP.DAV
 import qualified Data.Map as M
@@ -76,8 +76,8 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 			remotetype = remote
 		}
 
-webdavSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
+webdavSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-webdavSetup mu c = do
+webdavSetup mu mcreds c = do
 	u <- maybe (liftIO genUUID) return mu
 	let url = fromMaybe (error "Specify url=") $
 		M.lookup "url" c
@@ -85,7 +85,7 @@ webdavSetup mu c = do
 	creds <- getCreds c' u
 	testDav url creds
 	gitConfigSpecialRemote u c' "webdav" "true"
-	c'' <- setRemoteCredPair c' (davCreds u)
+	c'' <- setRemoteCredPair c' (davCreds u) mcreds
 	return (c'', u)
 
 store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
@@ -354,6 +354,3 @@ davCreds u = CredPairStorage
 	, credPairEnvironment = ("WEBDAV_USERNAME", "WEBDAV_PASSWORD")
 	, credPairRemoteKey = Just "davcreds"
 	}
-
-setCredsEnv :: (String, String) -> IO ()
-setCredsEnv creds = setEnvCredPair creds $ davCreds undefined

Test.hs

@@ -45,6 +45,7 @@ import qualified Logs.Remote
 import qualified Logs.Unused
 import qualified Logs.Transfer
 import qualified Logs.Presence
+import qualified Types.MetaData
 import qualified Remote
 import qualified Types.Key
 import qualified Types.Messages
@@ -53,6 +54,8 @@ import qualified Config.Cost
 import qualified Crypto
 import qualified Annex.Init
 import qualified Annex.CatFile
+import qualified Annex.View
+import qualified Logs.View
 import qualified Utility.Path
 import qualified Utility.FileMode
 import qualified Build.SysConfig
@@ -144,12 +147,16 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck"
 	, testProperty "prop_hashes_stable" Utility.Hash.prop_hashes_stable
 	, testProperty "prop_schedule_roundtrips" Utility.Scheduled.prop_schedule_roundtrips
 	, testProperty "prop_duration_roundtrips" Utility.HumanTime.prop_duration_roundtrips
+	, testProperty "prop_metadata_sane" Types.MetaData.prop_metadata_sane
+	, testProperty "prop_metadata_serialize" Types.MetaData.prop_metadata_serialize
+	, testProperty "prop_branchView_legal" Logs.View.prop_branchView_legal
+	, testProperty "prop_view_roundtrips" Annex.View.prop_view_roundtrips
 	]
 
 {- These tests set up the test environment, but also test some basic parts
  - of git-annex. They are always run before the unitTests. -}
 initTests :: TestEnv -> TestTree
-initTests env = testGroup ("Init Tests")
+initTests env = testGroup "Init Tests"
 	[ check "init" test_init
 	, check "add" test_add
 	]
@@ -230,7 +237,7 @@ test_add env = inmainrepo env $ do
 		( do
 			writeFile ingitfile $ content ingitfile
 			not <$> boolSystem "git" [Param "add", File ingitfile] @? "git add failed to fail in direct mode"
-			boolSystem "rm" [Params "-f", File ingitfile] @? "rm failed"
+			nukeFile ingitfile
 			git_annex env "sync" [] @? "sync failed"
 		, do
 			writeFile ingitfile $ content ingitfile
@@ -258,7 +265,7 @@ test_reinject :: TestEnv -> Assertion
 test_reinject env = intmpclonerepoInDirect env $ do
 	git_annex env "drop" ["--force", sha1annexedfile] @? "drop failed"
 	writeFile tmp $ content sha1annexedfile
-	r <- annexeval $ Types.Backend.getKey backendSHA1 $
+	r <- annexeval $ Types.Backend.getKey backendSHA1
 		Types.KeySource.KeySource { Types.KeySource.keyFilename = tmp, Types.KeySource.contentLocation = tmp, Types.KeySource.inodeCache = Nothing }
 	let key = Types.Key.key2file $ fromJust r
 	git_annex env "reinject" [tmp, sha1annexedfile] @? "reinject failed"
@@ -542,7 +549,7 @@ test_fsck_basic env = intmpclonerepo env $ do
 		git_annex env "fsck" [] @? "fsck unexpectedly failed again; previous one did not fix problem with " ++ f
 
 test_fsck_bare :: TestEnv -> Assertion
-test_fsck_bare env = intmpbareclonerepo env $ do
+test_fsck_bare env = intmpbareclonerepo env $
 	git_annex env "fsck" [] @? "fsck failed"
 
 test_fsck_localuntrusted :: TestEnv -> Assertion
@@ -585,7 +592,7 @@ test_migrate' usegitattributes env = intmpclonerepoInDirect env $ do
 	annexed_present sha1annexedfile
 	if usegitattributes
 		then do
-			writeFile ".gitattributes" $ "* annex.backend=SHA1"
+			writeFile ".gitattributes" "* annex.backend=SHA1"
 			git_annex env "migrate" [sha1annexedfile]
 				@? "migrate sha1annexedfile failed"
 			git_annex env "migrate" [annexedfile]
@@ -601,7 +608,7 @@ test_migrate' usegitattributes env = intmpclonerepoInDirect env $ do
 	checkbackend sha1annexedfile backendSHA1
 
 	-- check that reversing a migration works
-	writeFile ".gitattributes" $ "* annex.backend=SHA256"
+	writeFile ".gitattributes" "* annex.backend=SHA256"
 	git_annex env "migrate" [sha1annexedfile]
 		@? "migrate sha1annexedfile failed"
 	git_annex env "migrate" [annexedfile]
@@ -712,7 +719,7 @@ test_find env = intmpclonerepo env $ do
 	git_annex_expectoutput env "find" ["--exclude", "*"] []
 
 test_merge :: TestEnv -> Assertion
-test_merge env = intmpclonerepo env $ do
+test_merge env = intmpclonerepo env $
 	git_annex env "merge" [] @? "merge failed"
 
 test_info :: TestEnv -> Assertion
@@ -723,7 +730,7 @@ test_info env = intmpclonerepo env $ do
 		Text.JSON.Error e -> assertFailure e
 
 test_version :: TestEnv -> Assertion
-test_version env = intmpclonerepo env $ do
+test_version env = intmpclonerepo env $
 	git_annex env "version" [] @? "version failed"
 
 test_sync :: TestEnv -> Assertion
@@ -739,8 +746,8 @@ test_sync env = intmpclonerepo env $ do
 test_union_merge_regression :: TestEnv -> Assertion
 test_union_merge_regression env =
 	{- We need 3 repos to see this bug. -}
-	withtmpclonerepo env False $ \r1 -> do
+	withtmpclonerepo env False $ \r1 ->
-		withtmpclonerepo env False $ \r2 -> do
+		withtmpclonerepo env False $ \r2 ->
 			withtmpclonerepo env False $ \r3 -> do
 				forM_ [r1, r2, r3] $ \r -> indir env r $ do
 					when (r /= r1) $
@@ -766,7 +773,7 @@ test_union_merge_regression env =
 {- Regression test for the automatic conflict resolution bug fixed
  - in f4ba19f2b8a76a1676da7bb5850baa40d9c388e2. -}
 test_conflict_resolution_movein_bug :: TestEnv -> Assertion
-test_conflict_resolution_movein_bug env = withtmpclonerepo env False $ \r1 -> do
+test_conflict_resolution_movein_bug env = withtmpclonerepo env False $ \r1 -> 
 	withtmpclonerepo env False $ \r2 -> do
 		let rname r = if r == r1 then "r1" else "r2"
 		forM_ [r1, r2] $ \r -> indir env r $ do
@@ -785,7 +792,7 @@ test_conflict_resolution_movein_bug env = withtmpclonerepo env False $ \r1 -> do
 				)
 		{- Sync twice in r1 so it gets the conflict resolution
 		 - update from r2 -}
-		forM_ [r1, r2, r1] $ \r -> indir env r $ do
+		forM_ [r1, r2, r1] $ \r -> indir env r $
 			git_annex env "sync" ["--force"] @? "sync failed in " ++ rname r
 		{- After the sync, it should be possible to get all
 		 - files. This includes both sides of the conflict,
@@ -935,7 +942,7 @@ test_hook_remote env = intmpclonerepo env $ do
 test_directory_remote :: TestEnv -> Assertion
 test_directory_remote env = intmpclonerepo env $ do
 	createDirectory "dir"
-	git_annex env "initremote" (words $ "foo type=directory encryption=none directory=dir") @? "initremote failed"
+	git_annex env "initremote" (words "foo type=directory encryption=none directory=dir") @? "initremote failed"
 	git_annex env "get" [annexedfile] @? "get of file failed"
 	annexed_present annexedfile
 	git_annex env "copy" [annexedfile, "--to", "foo"] @? "copy --to directory remote failed"
@@ -951,7 +958,7 @@ test_rsync_remote :: TestEnv -> Assertion
 test_rsync_remote env = intmpclonerepo env $ do
 #ifndef mingw32_HOST_OS
 	createDirectory "dir"
-	git_annex env "initremote" (words $ "foo type=rsync encryption=none rsyncurl=dir") @? "initremote failed"
+	git_annex env "initremote" (words "foo type=rsync encryption=none rsyncurl=dir") @? "initremote failed"
 	git_annex env "get" [annexedfile] @? "get of file failed"
 	annexed_present annexedfile
 	git_annex env "copy" [annexedfile, "--to", "foo"] @? "copy --to rsync remote failed"
@@ -1085,7 +1092,7 @@ git_annex env command params = do
 		Utility.Env.setEnv var val True
 
 	-- catch all errors, including normally fatal errors
-	r <- try (run)::IO (Either SomeException ())
+	r <- try run::IO (Either SomeException ())
 	case r of
 		Right _ -> return True
 		Left _ -> return False
@@ -1126,7 +1133,7 @@ innewrepo :: TestEnv -> Assertion -> Assertion
 innewrepo env a = withgitrepo env $ \r -> indir env r a
 
 inmainrepo :: TestEnv -> Assertion -> Assertion
-inmainrepo env a = indir env mainrepodir a
+inmainrepo env = indir env mainrepodir
 
 intmpclonerepo :: TestEnv -> Assertion -> Assertion
 intmpclonerepo env a = withtmpclonerepo env False $ \r -> indir env r a
@@ -1163,7 +1170,7 @@ indir env dir a = do
 	-- any type of error and change back to cwd before
 	-- rethrowing.
 	r <- bracket_ (changeToTmpDir env dir) (setCurrentDirectory cwd)
-		(try (a)::IO (Either SomeException ()))
+		(try a::IO (Either SomeException ()))
 	case r of
 		Right () -> return ()
 		Left e -> throw e
@@ -1186,7 +1193,7 @@ clonerepo env old new bare = do
 	indir env new $
 		git_annex env "init" ["-q", new] @? "git annex init failed"
 	configrepo env new
-	when (not bare) $
+	unless bare $
 		indir env new $
 			handleforcedirect env
 	return new
@@ -1218,12 +1225,12 @@ cleanup' final dir = whenM (doesDirectoryExist dir) $ do
 		mapM_ (void . tryIO . Utility.FileMode.allowWrite)
 	-- This sometimes fails on Windows, due to some files
 	-- being still opened by a subprocess.
-	catchIO (removeDirectoryRecursive dir) $ \e -> do
+	catchIO (removeDirectoryRecursive dir) $ \e ->
 		when final $ do
 			print e
 			putStrLn "sleeping 10 seconds and will retry directory cleanup"
 			Utility.ThreadScheduler.threadDelaySeconds (Utility.ThreadScheduler.Seconds 10)
-			whenM (doesDirectoryExist dir) $ do
+			whenM (doesDirectoryExist dir) $
 				removeDirectoryRecursive dir
 	
 checklink :: FilePath -> Assertion
@@ -1252,9 +1259,8 @@ checkunwritable f = unlessM (annexeval Config.isDirect) $ do
 	-- modified despite permissions.
 	s <- getFileStatus f
 	let mode = fileMode s
-	if (mode == mode `unionFileModes` ownerWriteMode)
+	when (mode == mode `unionFileModes` ownerWriteMode) $
-		then assertFailure $ "able to modify annexed file's " ++ f ++ " content"
+		assertFailure $ "able to modify annexed file's " ++ f ++ " content"
-		else return ()
 
 checkwritable :: FilePath -> Assertion
 checkwritable f = do
@@ -1280,7 +1286,7 @@ checklocationlog f expected = do
 	case r of
 		Just (k, _) -> do
 			uuids <- annexeval $ Remote.keyLocations k
-			assertEqual ("bad content in location log for " ++ f ++ " key " ++ (Types.Key.key2file k) ++ " uuid " ++ show thisuuid)
+			assertEqual ("bad content in location log for " ++ f ++ " key " ++ Types.Key.key2file k ++ " uuid " ++ show thisuuid)
 				expected (thisuuid `elem` uuids)
 		_ -> assertFailure $ f ++ " failed to look up key"
 
@@ -1326,8 +1332,7 @@ withTestEnv forcedirect = withResource prepare release
 	release = releaseTestEnv
 
 releaseTestEnv :: TestEnv -> IO ()
-releaseTestEnv _env = do
+releaseTestEnv _env = cleanup' True tmpdir
-	cleanup' True tmpdir
 
 prepareTestEnv :: Bool -> IO TestEnv
 prepareTestEnv forcedirect = do
@@ -1404,7 +1409,7 @@ changecontent :: FilePath -> IO ()
 changecontent f = writeFile f $ changedcontent f
 
 changedcontent :: FilePath -> String
-changedcontent f = (content f) ++ " (modified)"
+changedcontent f = content f ++ " (modified)"
 
 backendSHA1 :: Types.Backend
 backendSHA1 = backend_ "SHA1"
@@ -1416,4 +1421,4 @@ backendWORM :: Types.Backend
 backendWORM = backend_ "WORM"
 
 backend_ :: String -> Types.Backend
-backend_ name = Backend.lookupBackendName name
+backend_ = Backend.lookupBackendName

Types/Command.hs

@@ -66,6 +66,7 @@ data CommandSection
 	| SectionSetup
 	| SectionMaintenance
 	| SectionQuery
+	| SectionMetaData
 	| SectionUtility
 	| SectionPlumbing
 	deriving (Eq, Ord, Enum, Bounded)
@@ -75,5 +76,6 @@ descSection SectionCommon = "Commonly used commands"
 descSection SectionSetup = "Repository setup commands"
 descSection SectionMaintenance = "Repository maintenance commands"
 descSection SectionQuery = "Query commands"
+descSection SectionMetaData = "Metadata commands"
 descSection SectionUtility = "Utility commands"
 descSection SectionPlumbing = "Plumbing commands"

Types/Creds.hs

@@ -0,0 +1,12 @@
+{- credentials
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Types.Creds where
+
+type Creds = String -- can be any data that contains credentials
+
+type CredPair = (String, String) -- login, password

Types/MetaData.hs

@@ -0,0 +1,269 @@
+{- git-annex general metadata
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Types.MetaData (
+	MetaData(..),
+	MetaField(..),
+	MetaValue(..),
+	CurrentlySet(..),
+	serialize,
+	deserialize,
+	MetaSerializable,
+	toMetaField,
+	mkMetaField,
+	tagMetaField,
+	fromMetaField,
+	toMetaValue,
+	mkMetaValue,
+	unsetMetaValue,
+	unsetMetaData,
+	fromMetaValue,
+	fromMetaData,
+	newMetaData,
+	updateMetaData,
+	unionMetaData,
+	differenceMetaData,
+	isSet,
+	currentMetaData,
+	currentMetaDataValues,
+	metaDataValues,
+	ModMeta(..),
+	modMeta,
+	parseModMeta,
+	parseMetaData,
+	prop_metadata_sane,
+	prop_metadata_serialize
+) where
+
+import Common
+import Utility.Base64
+import Utility.QuickCheck
+
+import qualified Data.Set as S
+import qualified Data.Map as M
+import Data.Char
+
+newtype MetaData = MetaData (M.Map MetaField (S.Set MetaValue))
+	deriving (Show, Eq, Ord)
+
+{- A metadata value can be currently be set (True), or may have been
+ - set before and we're remembering it no longer is (False). -}
+newtype CurrentlySet = CurrentlySet Bool
+	deriving (Read, Show, Eq, Ord, Arbitrary)
+
+newtype MetaField = MetaField String
+	deriving (Read, Show, Eq, Ord)
+
+data MetaValue = MetaValue CurrentlySet String
+	deriving (Read, Show)
+
+{- Metadata values compare and order the same whether currently set or not. -}
+instance Eq MetaValue where
+	MetaValue _ a == MetaValue _ b = a == b
+instance Ord MetaValue where
+	compare (MetaValue _ x) (MetaValue _ y) = compare x y
+
+{- MetaData is serialized to a format like:
+ -
+ - field1 +val1 +val2 -val3 field2 +val4 +val5
+ -}
+class MetaSerializable v where
+	serialize :: v -> String
+	deserialize :: String -> Maybe v
+
+instance MetaSerializable MetaData where
+	serialize (MetaData m) = unwords $ concatMap go $ M.toList m
+	  where
+		go (f, vs) = serialize f : map serialize (S.toList vs)
+	deserialize = Just . getfield newMetaData . words
+	  where
+		getfield m [] = m
+		getfield m (w:ws) = maybe m (getvalues m ws) (deserialize w)
+		getvalues m [] _ = m
+		getvalues m l@(w:ws) f = case deserialize w of
+			Just v -> getvalues (updateMetaData f v m) ws f
+			Nothing -> getfield m l
+
+instance MetaSerializable MetaField where
+	serialize (MetaField f) = f
+	deserialize = Just . MetaField
+
+{- Base64 problimatic values. -}
+instance MetaSerializable MetaValue where
+	serialize (MetaValue isset v) =
+		serialize isset ++
+		if any isSpace v || "!" `isPrefixOf` v
+			then '!' : toB64 v
+			else v
+	deserialize (isset:'!':v) = MetaValue
+		<$> deserialize [isset]
+		<*> fromB64Maybe v
+	deserialize (isset:v) = MetaValue 
+		<$> deserialize [isset]
+		<*> pure v
+	deserialize [] = Nothing
+
+instance MetaSerializable CurrentlySet where
+	serialize (CurrentlySet True) = "+"
+	serialize (CurrentlySet False) = "-"
+	deserialize "+" = Just (CurrentlySet True)
+	deserialize "-" = Just (CurrentlySet False)
+	deserialize _ = Nothing
+
+{- Fields cannot be empty, contain whitespace, or start with "+-" as
+ - that would break the serialization. -}
+toMetaField :: String -> Maybe MetaField
+toMetaField f
+	| legalField f = Just $ MetaField f
+	| otherwise = Nothing
+
+legalField :: String -> Bool
+legalField f
+	| null f = False
+	| any isSpace f = False
+	| any (`isPrefixOf` f) ["+", "-"] = False
+	| otherwise = True
+
+toMetaValue :: String -> MetaValue
+toMetaValue = MetaValue (CurrentlySet True)
+
+mkMetaValue :: CurrentlySet -> String -> MetaValue
+mkMetaValue = MetaValue
+
+unsetMetaValue :: MetaValue -> MetaValue
+unsetMetaValue (MetaValue _ s) = MetaValue (CurrentlySet False) s
+
+{- Marks all MetaValues as no longer currently set. -}
+unsetMetaData :: MetaData -> MetaData
+unsetMetaData (MetaData m) = MetaData $ M.map (S.map unsetMetaValue) m
+
+fromMetaField :: MetaField -> String
+fromMetaField (MetaField f) = f
+
+fromMetaValue :: MetaValue -> String
+fromMetaValue (MetaValue _ f) = f
+
+fromMetaData :: MetaData -> [(MetaField, S.Set MetaValue)]
+fromMetaData (MetaData m) = M.toList m
+
+newMetaData :: MetaData
+newMetaData = MetaData M.empty
+
+{- Can be used to set a value, or to unset it, depending on whether
+ - the MetaValue has CurrentlySet or not. -}
+updateMetaData :: MetaField -> MetaValue -> MetaData -> MetaData
+updateMetaData f v (MetaData m) = MetaData $
+	M.insertWith' S.union f (S.singleton v) m
+
+{- New metadata overrides old._-}
+unionMetaData :: MetaData -> MetaData -> MetaData
+unionMetaData (MetaData old) (MetaData new) = MetaData $
+	M.unionWith S.union new old
+
+differenceMetaData :: MetaData -> MetaData -> MetaData
+differenceMetaData (MetaData m) (MetaData excludem) = MetaData $
+	M.differenceWith diff m excludem
+  where
+	diff sl sr =
+		let s = S.difference sl sr
+		in if S.null s then Nothing else Just s
+
+isSet :: MetaValue -> Bool
+isSet (MetaValue (CurrentlySet isset) _) = isset
+
+{- Gets only currently set values -}
+currentMetaDataValues :: MetaField -> MetaData -> S.Set MetaValue
+currentMetaDataValues f m = S.filter isSet (metaDataValues f m)
+
+currentMetaData :: MetaData -> MetaData
+currentMetaData (MetaData m) = removeEmptyFields $ MetaData $
+	M.map (S.filter isSet) m
+
+removeEmptyFields :: MetaData -> MetaData
+removeEmptyFields (MetaData m) = MetaData $ M.filter (not . S.null) m
+
+{- Gets currently set values, but also values that have been unset. -}
+metaDataValues :: MetaField -> MetaData -> S.Set MetaValue
+metaDataValues f (MetaData m) = fromMaybe S.empty (M.lookup f m)
+
+{- Ways that existing metadata can be modified -}
+data ModMeta
+	= AddMeta MetaField MetaValue
+	| DelMeta MetaField MetaValue
+	| SetMeta MetaField MetaValue -- removes any existing values
+
+{- Applies a ModMeta, generating the new MetaData.
+ - Note that the new MetaData does not include all the 
+ - values set in the input metadata. It only contains changed values. -}
+modMeta :: MetaData -> ModMeta -> MetaData
+modMeta _ (AddMeta f v) = updateMetaData f v newMetaData
+modMeta _ (DelMeta f oldv) = updateMetaData f (unsetMetaValue oldv) newMetaData
+modMeta m (SetMeta f v) = updateMetaData f v $
+	foldr (updateMetaData f) newMetaData $
+		map unsetMetaValue $ S.toList $ currentMetaDataValues f m
+
+{- Parses field=value, field+=value, field-=value -}
+parseModMeta :: String -> Either String ModMeta
+parseModMeta p = case lastMaybe f of
+	Just '+' -> AddMeta <$> mkMetaField f' <*> v
+	Just '-' -> DelMeta <$> mkMetaField f' <*> v
+	_ -> SetMeta <$> mkMetaField f <*> v
+  where
+	(f, sv) = separate (== '=') p
+	f' = beginning f
+	v = pure (toMetaValue sv)
+
+{- Parses field=value -}
+parseMetaData :: String -> Either String (MetaField, MetaValue)
+parseMetaData p = (,)
+	<$> mkMetaField f
+	<*> pure (toMetaValue v)
+  where
+	(f, v) = separate (== '=') p
+
+mkMetaField :: String -> Either String MetaField
+mkMetaField f = maybe (Left $ badField f) Right (toMetaField f)
+
+badField :: String -> String
+badField f = "Illegal metadata field name, \"" ++ f ++ "\""
+
+tagMetaField :: MetaField
+tagMetaField = MetaField "tag"
+
+{- Avoid putting too many fields in the map; extremely large maps make
+ - the seriaization test slow due to the sheer amount of data.
+ - It's unlikely that more than 100 fields of metadata will be used. -}
+instance Arbitrary MetaData where
+	arbitrary = do
+		size <- arbitrarySizedBoundedIntegral `suchThat` (< 500)
+		MetaData . M.fromList <$> vector size
+
+instance Arbitrary MetaValue where
+	arbitrary = MetaValue <$> arbitrary <*> arbitrary
+
+instance Arbitrary MetaField where
+	arbitrary = MetaField <$> arbitrary `suchThat` legalField 
+
+prop_metadata_sane :: MetaData -> MetaField -> MetaValue -> Bool
+prop_metadata_sane m f v = and
+	[ S.member v $ metaDataValues f m'
+	, not (isSet v) || S.member v (currentMetaDataValues f m')
+	, differenceMetaData m' newMetaData == m'
+	]
+  where
+	m' = updateMetaData f v m
+
+prop_metadata_serialize :: MetaField -> MetaValue -> MetaData -> Bool
+prop_metadata_serialize f v m = and
+	[ deserialize (serialize f) == Just f
+	, deserialize (serialize v) == Just v
+	, deserialize (serialize m') == Just m'
+	]
+  where
+  	m' = removeEmptyFields m

Types/Remote.hs

@@ -24,6 +24,7 @@ import Types.Key
 import Types.UUID
 import Types.GitConfig
 import Types.Availability
+import Types.Creds
 import Config.Cost
 import Utility.Metered
 import Git.Types
@@ -41,7 +42,7 @@ data RemoteTypeA a = RemoteType {
 	-- generates a remote of this type
 	generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> a (Maybe (RemoteA a)),
 	-- initializes or changes a remote
-	setup :: Maybe UUID -> RemoteConfig -> a (RemoteConfig, UUID)
+	setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> a (RemoteConfig, UUID)
 }
 
 instance Eq (RemoteTypeA a) where