Merge branch 'view'

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
@@ -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.

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

@@ -5,61 +5,48 @@
  - 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.Types as Git
+import qualified Git
-import qualified Git.Ref
 import qualified Git.DiffTree
 import qualified Git.Branch
-import Git.Sha (nullSha)
+import qualified Git.LsFiles
+import Git.UpdateIndex
+import Git.Sha
+import Git.HashObject
+import Git.Types
+import qualified Backend
+import Annex.Index
+import Annex.Link
+import Logs.MetaData
+import Logs.View
+import Utility.FileMode
 
 import qualified Data.Set as S
-import Data.Char
 import System.Path.WildMatch
 import "mtl" Control.Monad.Writer
 
-#ifdef WITH_TDFA
-import Text.Regex.TDFA
-import Text.Regex.TDFA.String
-#else
-#endif
-
-matchGlob :: Glob -> String -> Bool
-#ifdef WITH_TDFA
-matchGlob (Glob _ r) s = case execute r s of
-	Right (Just _) -> True
-	_ -> False
-#else
-matchGlob (Glob g) = wildCheckCase g
-#endif
-
 data ViewChange = Unchanged | Narrowing | Widening
 	deriving (Ord, Eq, Show)
 
+matchGlob :: String -> String -> Bool
+matchGlob glob val = wildCheckCase glob val
+
 {- Updates a view, adding a new field to filter on (Narrowing), 
- - or allowing a new value in an existing field (Widening).
+ - or allowing a new value in an existing field (Widening). -}
- -}
 refineView :: View -> MetaField -> String -> (View, ViewChange)
 refineView view field wanted
-	| field `elem` (map viewField view) = 
+	| field `elem` (map viewField components) = 
-		let (view', viewchanges) = runWriter $ mapM updatefield view
+		let (components', viewchanges) = runWriter $ mapM updatefield components
-		in (view', maximum viewchanges)
+		in (view { viewComponents = components' }, maximum viewchanges)
-	| otherwise = (ViewComponent field viewfilter : view, Narrowing)
+	| otherwise = (view { viewComponents = ViewComponent field viewfilter : components }, Narrowing)
   where
+  	components = viewComponents view
 	viewfilter
-		| any (`elem` wanted) "*?" = 
+		| any (`elem` wanted) "*?" = FilterGlob wanted
-#ifdef WITH_TDFA
-			case compile defaultCompOpt defaultExecOpt ('^':wildToRegex wanted) of
-				Right r -> FilterGlob (Glob wanted r)
-				Left _ -> FilterValues $ S.singleton $ toMetaValue wanted
-#else
-			FilterGlob (Glob wanted)
-#endif
 		| otherwise = FilterValues $ S.singleton $ toMetaValue wanted
 	updatefield :: ViewComponent -> Writer [ViewChange] ViewComponent
 	updatefield v
@@ -96,14 +83,9 @@ combineViewFilter (FilterGlob oldglob) new@(FilterValues s)
 	| otherwise = (new, Widening)
 combineViewFilter (FilterGlob old) newglob@(FilterGlob new)
 	| old == new = (newglob, Unchanged)
-	| matchGlob old (getGlob new) = (newglob, Narrowing)
+	| matchGlob old new = (newglob, Narrowing)
 	| otherwise = (newglob, Widening)
 
-{- Can a ViewFilter match multiple different MetaValues? -}
-multiValue :: ViewFilter -> Bool
-multiValue (FilterValues s) = S.size s > 1
-multiValue (FilterGlob _) = True
-
 {- Each multivalued 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
@@ -113,7 +95,7 @@ multiValue (FilterGlob _) = True
  - through 5+ levels of subdirectories to find anything?
  -}
 viewTooLarge :: View -> Bool
-viewTooLarge view = length (filter (multiValue . viewFilter) view) > 5
+viewTooLarge view = length (filter (multiValue . viewFilter) (viewComponents view)) > 5
 
 {- Checks if metadata matches a filter, and if so returns the value,
  - or values that match. -}
@@ -136,7 +118,7 @@ nonEmptyList s
  - 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
+ - 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}}.)
@@ -144,7 +126,7 @@ nonEmptyList s
 fileViewFromReference :: MkFileView
 fileViewFromReference f = concat
 	[ double base
-	, concatMap (\d -> "{" ++ double d ++ "}") dirs
+	, if null dirs then "" else "_{" ++ double (intercalate ";" dirs) ++ "}"
 	, double $ concat extensions
 	]
   where
@@ -154,6 +136,9 @@ fileViewFromReference f = concat
 
 	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.
  -
@@ -166,15 +151,19 @@ fileViewFromReference f = concat
 fileViews :: View -> MkFileView -> FilePath -> MetaData -> [FileView]
 fileViews view mkfileview file metadata
 	| any isNothing matches = []
-	| otherwise = map (</> mkfileview file) $ pathProduct $ 
+	| otherwise =
-		map (map toViewPath) (visible matches)
+		let paths = pathProduct $
+			map (map toViewPath) (visible matches)
+		in if null paths
+			then [mkfileview file]
+			else map (</> mkfileview file) paths
   where
   	matches :: [Maybe [MetaValue]]
-	matches = map (matchFilter metadata) view
+	matches = map (matchFilter metadata) (viewComponents view)
 	visible :: [Maybe [MetaValue]] -> [[MetaValue]]
 	visible = map (fromJust . snd) .
 		filter (multiValue . fst) .
-		zip (map viewFilter view)
+		zip (map viewFilter (viewComponents view))
 
 toViewPath :: MetaValue -> FilePath
 toViewPath = concatMap escapeslash . fromMetaValue
@@ -218,7 +207,7 @@ pathProduct (l:ls) = foldl combinel l ls
 fromView :: View -> FileView -> MetaData
 fromView view f = foldr (uncurry updateMetaData) newMetaData (zip fields values)
   where
-	visible = filter (multiValue . viewFilter) view
+	visible = filter (multiValue . viewFilter) (viewComponents view)
 	fields = map viewField visible
 	paths = splitDirectories $ dropFileName f
 	values = map fromViewPath paths
@@ -231,63 +220,69 @@ prop_view_roundtrips :: FilePath -> MetaData -> Bool
 prop_view_roundtrips f metadata = null f || viewTooLarge view ||
 	all hasfields (fileViews view fileViewFromReference f metadata)
   where
-	view = map (\(mf, mv) -> ViewComponent mf (FilterValues $ S.filter (not . null . fromMetaValue) mv))
+	view = View (Git.Ref "master") $
-		(fromMetaData metadata)
+		map (\(mf, mv) -> ViewComponent mf (FilterValues $ S.filter (not . null . fromMetaValue) mv))
-	visiblefields = sort (map viewField $ filter (multiValue . viewFilter) view)
+			(fromMetaData metadata)
+	visiblefields = sort (map viewField $ filter (multiValue . viewFilter) (viewComponents view))
 	hasfields fv = sort (map fst (fromMetaData (fromView view fv))) == visiblefields
 
-{- 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 "refs/views"
-	| otherwise = Git.Ref $ "refs/views/" ++ name
-  where
-	name = intercalate "/" $ map branchcomp view
-	branchcomp c
-		| multiValue (viewFilter c) = branchcomp' c
-		| otherwise = "(" ++ branchcomp' c ++ ")"
-	branchcomp' (ViewComponent metafield viewfilter)
-		| metafield == tagMetaField = branchvals viewfilter
-		| otherwise = concat
-			[ forcelegal (fromMetaField metafield)
-			, "="
-			, branchvals viewfilter
-			]
-	branchvals (FilterValues set) = forcelegal $
-		intercalate "," $ map fromMetaValue $ S.toList set
-	branchvals (FilterGlob glob) = forcelegal $ getGlob 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 . show . branchView
-
 {- Applies a view to the currently checked out branch, generating a new
  - branch for the view.
  -}
 applyView :: View -> Annex Git.Branch
-applyView = applyView' fileViewFromReference
+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.
  -}
 narrowView :: View -> Annex Git.Branch
-narrowView = applyView' id
+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 into the (temporary) index.
+ - 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 = genViewBranch view $ do
+applyView' mkfileview view = do
-	error "TODO"
+	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
+	go uh hasher f (Just (k, _)) = do
+		metadata <- getCurrentMetaData k
+		forM_ (fileViews view mkfileview 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.
@@ -307,18 +302,21 @@ updateView view ref oldref = genViewBranch view $ do
 		| Git.DiffTree.dstsha diff == nullSha = error "TODO delete file"
 		| otherwise = error "TODO add file"
 
-{- Generates a branch for a view. This is done by creating a temporary
+{- Generates a branch for a view. This is done using a different index
- - index file, which starts off empty. An action is run to stage the files
+ - file. An action is run to stage the files that will be in the branch.
- - that will be in the branch. Then a commit is made, to the view branch.
+ - Then a commit is made, to the view branch. The view branch is not
- - The view branch is not checked out, but entering it will display the
+ - checked out, but entering it will display the view. -}
- - view. -}
 genViewBranch :: View -> Annex () -> Annex Git.Branch
-genViewBranch view a = withTempIndex $ do
+genViewBranch view a = withIndex $ do
 	a
 	let branch = branchView view
 	void $ inRepo $ Git.Branch.commit True (show branch) branch []
 	return branch
 
-{- -}
+{- Runs an action using the view index file.
-withTempIndex :: Annex a -> Annex a
+ - Note that the file does not necessarily exist, or can contain
-withTempIndex a = error "TODO"
+ - info staged for an old view. -}
+withIndex :: Annex a -> Annex a
+withIndex a = do
+	f <- fromRepo gitAnnexViewIndex
+	withIndexFile f a

CmdLine/GitAnnex.hs

@@ -27,6 +27,10 @@ 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.VPop
+import qualified Command.VCycle
 import qualified Command.Reinject
 import qualified Command.Fix
 import qualified Command.Init
@@ -136,6 +140,10 @@ cmds = concat
 	, Command.TransferKeys.def
 	, Command.ReKey.def
 	, Command.MetaData.def
+	, Command.View.def
+	, Command.VAdd.def
+	, Command.VPop.def
+	, Command.VCycle.def
 	, Command.Fix.def
 	, Command.Fsck.def
 	, Command.Repair.def

Command/VAdd.hs

@@ -0,0 +1,42 @@
+{- 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 Logs.View
+import Command.View (paramView, parseViewParam, checkoutViewBranch)
+
+def :: [Command]
+def = [notBareRepo $ notDirect $
+	command "vadd" paramView seek SectionUtility "refine current view"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start params = do
+	showStart "vadd" ""
+	go =<< currentView
+  where
+	go Nothing = error "Not in a view."
+	go (Just view) = do
+		let (view', change) = calc view Unchanged (reverse params)
+		case change of
+			Unchanged -> do
+				showNote "unchanged"
+				next $ next $ return True
+			Narrowing -> next $ next $
+				checkoutViewBranch view' narrowView
+			Widening -> error "Widening view to match more files is not currently supported."
+
+	calc v c [] = (v, c)
+	calc v c (p:ps) =
+		let (v', c') = uncurry (refineView v) (parseViewParam p)
+		in calc v' (max c c') ps

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

@@ -0,0 +1,43 @@
+{- 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.Command
+import qualified Git.Ref
+import Types.View
+import Logs.View
+import Command.View (checkoutViewBranch)
+
+def :: [Command]
+def = [notBareRepo $ notDirect $
+	command "vpop" paramNothing seek SectionUtility
+	"switch back to previous view"]
+
+seek :: CommandSeek
+seek = withNothing start
+
+start ::CommandStart
+start = go =<< currentView
+  where
+	go Nothing = error "Not in a view."
+	go (Just v) = do
+		showStart "vpop" ""
+		removeView v
+		vs <- filter (sameparentbranch v) <$> recentViews
+		case vs of
+			(oldv:_) -> next $ next $ do
+				checkoutViewBranch oldv (return . branchView)
+			_ -> next $ next $
+				inRepo $ Git.Command.runBool
+					[ Param "checkout"
+					, Param $ show $ Git.Ref.base $
+						viewParentBranch v
+					]
+	sameparentbranch a b = viewParentBranch a == viewParentBranch b

Command/View.hs

@@ -0,0 +1,92 @@
+{- 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 SectionUtility "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 $ calc v $ reverse params
+  where
+	calc v [] = v
+	calc v (p:ps) =
+		let (v', _) = uncurry (refineView v) (parseViewParam p)
+		in calc v' ps
+	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
+	
+	ok <- inRepo $ Git.Command.runBool
+		[ Param "checkout"
+		, Param (show $ 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
+		]

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/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,16 +41,29 @@ 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 $
+	(\h -> forM_ as $ streamUpdateIndex' h)
+
+data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle
+
+streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO ()
+streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \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
-	forM_ as (stream h)
+	return $ UpdateIndexHandle p h
-	hClose h
   where
 	params = map Param ["update-index", "-z", "--index-info"]
-	stream h a = a (streamer h)
+
-	streamer h s = do
+stopUpdateIndex :: UpdateIndexHandle -> IO Bool
-		hPutStr h s
+stopUpdateIndex (UpdateIndexHandle p h) = do
-		hPutStr h "\0"
+	hClose h
+	checkSuccessProcess p
 
 {- A streamer that adds the current tree for a ref. Useful for eg, copying
  - and modifying branches. -}

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"

Logs/View.hs

@@ -0,0 +1,100 @@
+{- 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 Utility.Tmp
+
+import qualified Data.Set as S
+import Data.Char
+
+showLog :: View -> String
+showLog (View branch components) = show branch ++ " " ++ show components
+
+parseLog :: String -> Maybe View
+parseLog s = 
+	let (branch, components) = separate (== ' ') s
+	in View
+		<$> pure (Git.Ref branch)
+		<*> readish components
+
+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 showLog l
+
+removeView :: View -> Annex ()
+removeView v = writeViews =<< filter (/= v) <$> recentViews
+
+recentViews :: Annex [View]
+recentViews = do
+	f <- fromRepo gitAnnexViewLog
+	liftIO $ mapMaybe parseLog . lines <$> catchDefaultIO [] (readFile f)
+
+{- Gets the currently checked out view, if there is one. -}
+currentView :: Annex (Maybe View)
+currentView = do
+	vs <- recentViews
+	maybe Nothing (go vs) <$> inRepo Git.Branch.current
+  where
+  	go [] _ = Nothing
+	go (v:vs) b
+		| branchView v == b = Just v
+		| otherwise = go vs b
+
+{- 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 "refs/heads/views"
+	| otherwise = Git.Ref $ "refs/heads/views/" ++ name
+  where
+	name = intercalate ";" $ map branchcomp (viewComponents view)
+	branchcomp c
+		| multiValue (viewFilter c) = branchcomp' c
+		| otherwise = "(" ++ branchcomp' c ++ ")"
+	branchcomp' (ViewComponent metafield viewfilter)
+		| metafield == tagMetaField = branchvals viewfilter
+		| otherwise = concat
+			[ forcelegal (fromMetaField metafield)
+			, "="
+			, branchvals viewfilter
+			]
+	branchvals (FilterValues set) = forcelegal $
+		intercalate "," $ map 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 . show . branchView

Test.hs

@@ -55,6 +55,7 @@ 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
@@ -148,7 +149,7 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck"
 	, 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" Annex.View.prop_branchView_legal
+	, testProperty "prop_branchView_legal" Logs.View.prop_branchView_legal
 	, testProperty "prop_view_roundtrips" Annex.View.prop_view_roundtrips
 	]
 

Types/MetaData.hs

@@ -53,13 +53,13 @@ newtype MetaData = MetaData (M.Map MetaField (S.Set MetaValue))
 {- 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 (Show, Eq, Ord, Arbitrary)
+	deriving (Read, Show, Eq, Ord, Arbitrary)
 
 newtype MetaField = MetaField String
-	deriving (Show, Eq, Ord)
+	deriving (Read, Show, Eq, Ord)
 
 data MetaValue = MetaValue CurrentlySet String
-	deriving (Show)
+	deriving (Read, Show)
 
 {- Metadata values compare and order the same whether currently set or not. -}
 instance Eq MetaValue where

Types/View.hs

@@ -5,29 +5,31 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP #-}
-
 module Types.View where
 
 import Common.Annex
 import Types.MetaData
 import Utility.QuickCheck
+import qualified Git
 
 import qualified Data.Set as S
 
-#ifdef WITH_TDFA
+{- A view is a list of fields with filters on their allowed values,
-import Text.Regex.TDFA
+ - which are applied to files in a parent git branch. -}
-#else
+data View = View
-#endif
+	{ viewParentBranch :: Git.Branch
+	, viewComponents :: [ViewComponent]
+	}
+	deriving (Eq, Show)
 
-{- A view is a list of fields with filters on their allowed values. -}
+instance Arbitrary View where
-type View = [ViewComponent]
+	arbitrary = View <$> pure (Git.Ref "master") <*> arbitrary
 
 data ViewComponent = ViewComponent
 	{ viewField :: MetaField
 	, viewFilter :: ViewFilter
 	}
-	deriving (Show, Eq)
+	deriving (Eq, Show, Read)
 
 instance Arbitrary ViewComponent where
 	arbitrary = ViewComponent <$> arbitrary <*> arbitrary
@@ -38,34 +40,15 @@ type MkFileView = FilePath -> FileView
 
 data ViewFilter
 	= FilterValues (S.Set MetaValue)
-	| FilterGlob Glob
+	| FilterGlob String
-
+	deriving (Eq, Show, Read)
-instance Show ViewFilter where
-	show (FilterValues s) = show s
-	show (FilterGlob g) = getGlob g
-
-instance Eq ViewFilter where
-	FilterValues x == FilterValues y = x == y
-	FilterGlob x == FilterGlob y = x == y
-	_ == _ = False
 
 instance Arbitrary ViewFilter where
 	arbitrary = do
 		size <- arbitrarySizedBoundedIntegral `suchThat` (< 100)
 		FilterValues . S.fromList <$> vector size
 
-#ifdef WITH_TDFA
+{- Can a ViewFilter match multiple different MetaValues? -}
-data Glob = Glob String Regex
+multiValue :: ViewFilter -> Bool
-#else
+multiValue (FilterValues s) = S.size s > 1
-data Glob = Glob String
+multiValue (FilterGlob _) = True
-#endif
-
-instance Eq Glob where
-	a == b = getGlob a == getGlob b
-
-getGlob :: Glob -> String
-#ifdef WITH_TDFA
-getGlob (Glob g _) = g
-#else
-getGlob (Glob g) = g
-#endif

Utility/Directory.hs

@@ -1,6 +1,6 @@
 {- directory manipulation
  -
- - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -23,6 +23,7 @@ import Utility.SafeCommand
 import Utility.Tmp
 import Utility.Exception
 import Utility.Monad
+import Utility.Applicative
 
 dirCruft :: FilePath -> Bool
 dirCruft "." = True
@@ -73,6 +74,21 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir]
 							)
 				_ -> skip
 
+{- Gets the directory tree from a point, recursively and lazily,
+ - with leaf directories **first**, skipping any whose basenames
+ - match the skipdir. Does not follow symlinks. -}
+dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
+dirTreeRecursiveSkipping skipdir topdir = go [] [topdir]
+  where
+  	go c [] = return c
+	go c (dir:dirs)
+		| skipdir (takeFileName dir) = go c dirs
+		| otherwise = unsafeInterleaveIO $ do
+			subdirs <- go c
+				=<< filterM (isDirectory <$$> getSymbolicLinkStatus)
+				=<< catchDefaultIO [] (dirContents dir)
+			go (subdirs++[dir]) dirs
+
 {- Moves one filename to another.
  - First tries a rename, but falls back to moving across devices if needed. -}
 moveFile :: FilePath -> FilePath -> IO ()

debian/changelog

@@ -5,6 +5,9 @@ git-annex (5.20140211) UNRELEASED; urgency=medium
     that have particular metadata.
   * Preferred content expressions can use metadata=field=value
     to limit them to acting on files that have particular metadata.
+  * view: New command that creates and checks out a branch that provides
+    a structured view of selected metadata.
+  * vadd, vpop, vcycle: New commands for operating within views.
   * Add progress display for transfers to/from external special remotes.
   * Windows webapp: Can set up box.com, Amazon S3, and rsync.net remotes
   * Windows webapp: Can create repos on removable drives.

doc/design/metadata.mdwn

@@ -36,37 +36,37 @@ sql queries if we want to go that far.)
 
 # filtered branches
 
-`git annex filter year=2014 talk` should create a new branch
+`git annex view year=2014 talk` should create a new branch
-filtered/year=2014/talk containing only files tagged with that, and
+view/year=2014/talk containing only files tagged with that, and
 have git check it out. In this example, all files appear in top level
 directory of repo; no subdirs.
 
-`git annex fadd haskell` switches to branch
+`git annex vadd haskell` switches to branch
-filtered/year=2014/talk/haskell with only the haskell talks.
+view/year=2014/talk/haskell with only the haskell talks.
 
-`git annex fadd year=2013 year=2012` switches to branch
+`git annex vadd year=2013 year=2012` switches to branch
-filtered/year=2012,2013,2014/talk/haskell. This has subdirectories 2012,
+view/year=2012,2013,2014/talk/haskell. This has subdirectories 2012,
 2013 and 2014 with the matching talks.
 
 Patterns can be used in both the values of fields, and in matching tags.
 So, `year=20*` could be used to match years, and `foo/*` matches any
 tag in the foo namespace. Or even `*` to match *all* tags.
 
-`git annex frm haskell` switches to
+`git annex vrm haskell` switches to
-filtered/year=2012,2013,2014/talk, which has all available talks in it.
+view/year=2012,2013,2014/talk, which has all available talks in it.
 
-`git annex fadd conference=fosdem conference=icfp` switches to branch
+`git annex vadd conference=fosdem conference=icfp` switches to branch
-filtered/year=2012,2013,2014/talk/conference=fosdem,icfp. Now there
+view/year=2012,2013,2014/talk/conference=fosdem,icfp. Now there
 are nested subdirectories. They follow the format of the branch,
 so 2013/icfp, 2014/fosdem, etc.
 
-`git annex filter tag=haskell,debian` yields a branch with haskell
+`git annex view tag=haskell,debian` yields a branch with haskell
 and debian subdirectories.
 
-To see all tags, `git annex filter tag=*` !
+To see all tags, as subdirectories, `git annex view tag=*` !
 
-Files not matching the filter can be included, by using 
+Files not matching the view can be included, by using 
-`git annex filter --unmatched=other`. That puts all such files into
+`git annex view --unmatched=other`. That puts all such files into
 the subdirectory other.
 
 Note that old filter branches can be deleted when switching to a new one.

doc/git-annex.mdwn

@@ -313,6 +313,35 @@ subdirectories).
   from a remote computer.
   Note that this does not yet use HTTPS for security, so use with caution!
 
+* `view [field=value ...] [tag ...]`
+
+  Uses metadata to build a view branch of the files in the current branch,
+  and checks out the view branch. Only files in the current branch whose
+  metadata matches all the specified field values and tags will be
+  shown in the view.
+  
+  Multiple values for a metadata field can be specified, either by using
+  a glob (field="\*") or by listing each wanted value. 
+  
+  When multiple field values match, the view branch will have a
+  subdirectory for each value.
+
+* `vpop`
+
+  Switches from the currently active view back to the previous view.
+  Or, from the first view back to original branch.
+
+* `vadd [field=value ...] [tag ...]`
+
+  Refines the currently checked out view branch, adding additional fields
+  or tags.
+
+* `vcycle`
+
+  When a view involves nested subdirectories, this cycles the order.
+  For example, when the view has date/author/tag, vcycle will switch
+  it to author/tag/date.
+
 # REPOSITORY SETUP COMMANDS
 
 * `init [description]`