diff options
author | Joey Hess <joey@kitenet.net> | 2014-02-18 21:50:24 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2014-02-18 21:50:24 -0400 |
commit | b20cb8393f503ea6b12d6155f80c5be12157af49 (patch) | |
tree | cba6a8e88b6a9731911bd9e99a401a59fe09a497 | |
parent | 7ca70b4a07ae9b1f9b217c0e960001ff3147bf5a (diff) | |
parent | d8cc840cc7fd9d543486b7a86426eb4bc444b5aa (diff) |
Merge branch 'view'
-rw-r--r-- | Annex/Branch.hs | 29 | ||||
-rw-r--r-- | Annex/Index.hs | 46 | ||||
-rw-r--r-- | Annex/Link.hs | 4 | ||||
-rw-r--r-- | Annex/View.hs | 192 | ||||
-rw-r--r-- | CmdLine/GitAnnex.hs | 8 | ||||
-rw-r--r-- | Command/VAdd.hs | 42 | ||||
-rw-r--r-- | Command/VCycle.hs | 41 | ||||
-rw-r--r-- | Command/VPop.hs | 43 | ||||
-rw-r--r-- | Command/View.hs | 92 | ||||
-rw-r--r-- | Git/HashObject.hs | 16 | ||||
-rw-r--r-- | Git/UpdateIndex.hs | 33 | ||||
-rw-r--r-- | Locations.hs | 10 | ||||
-rw-r--r-- | Logs/View.hs | 100 | ||||
-rw-r--r-- | Test.hs | 3 | ||||
-rw-r--r-- | Types/MetaData.hs | 6 | ||||
-rw-r--r-- | Types/View.hs | 51 | ||||
-rw-r--r-- | Utility/Directory.hs | 18 | ||||
-rw-r--r-- | debian/changelog | 3 | ||||
-rw-r--r-- | doc/design/metadata.mdwn | 28 | ||||
-rw-r--r-- | doc/git-annex.mdwn | 29 |
20 files changed, 608 insertions, 186 deletions
diff --git a/Annex/Branch.hs b/Annex/Branch.hs index ee3cd71e2..fe505a048 100644 --- a/Annex/Branch.hs +++ b/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 -#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' } + withIndexFile f $ do 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. diff --git a/Annex/Index.hs b/Annex/Index.hs new file mode 100644 index 000000000..a1b2442fc --- /dev/null +++ b/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 diff --git a/Annex/Link.hs b/Annex/Link.hs index 234e4cb2a..26991e911 100644 --- a/Annex/Link.hs +++ b/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 = diff --git a/Annex/View.hs b/Annex/View.hs index 890f2682a..d407ce4c9 100644 --- a/Annex/View.hs +++ b/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.Ref +import qualified Git 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) = - let (view', viewchanges) = runWriter $ mapM updatefield view - in (view', maximum viewchanges) - | otherwise = (ViewComponent field viewfilter : view, Narrowing) + | field `elem` (map viewField components) = + let (components', viewchanges) = runWriter $ mapM updatefield components + in (view { viewComponents = components' }, maximum viewchanges) + | otherwise = (view { viewComponents = ViewComponent field viewfilter : components }, Narrowing) where + components = viewComponents view viewfilter - | any (`elem` 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 + | any (`elem` wanted) "*?" = FilterGlob wanted | 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 $ - map (map toViewPath) (visible matches) + | otherwise = + 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)) - (fromMetaData metadata) - visiblefields = sort (map viewField $ filter (multiValue . viewFilter) view) + view = View (Git.Ref "master") $ + map (\(mf, mv) -> ViewComponent mf (FilterValues $ S.filter (not . null . fromMetaValue) mv)) + (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 - error "TODO" +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 + 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 - - index file, which starts off empty. 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. -} +{- 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 = withTempIndex $ do +genViewBranch view a = withIndex $ do a let branch = branchView view void $ inRepo $ Git.Branch.commit True (show branch) branch [] return branch -{- -} -withTempIndex :: Annex a -> Annex a -withTempIndex a = error "TODO" +{- 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 diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index a67c6be29..c8325872d 100644 --- a/CmdLine/GitAnnex.hs +++ b/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 diff --git a/Command/VAdd.hs b/Command/VAdd.hs new file mode 100644 index 000000000..e766f3939 --- /dev/null +++ b/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 diff --git a/Command/VCycle.hs b/Command/VCycle.hs new file mode 100644 index 000000000..b41e099a4 --- /dev/null +++ b/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 diff --git a/Command/VPop.hs b/Command/VPop.hs new file mode 100644 index 000000000..e62c2414a --- /dev/null +++ b/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 diff --git a/Command/View.hs b/Command/View.hs new file mode 100644 index 000000000..9e1b981a7 --- /dev/null +++ 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 + ] diff --git a/Git/HashObject.hs b/Git/HashObject.hs index bb9b20d96..97e1befe6 100644 --- a/Git/HashObject.hs +++ b/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) diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 3b33ac846..73beaba3a 100644 --- a/Git/UpdateIndex.hs +++ b/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) - hClose h + return $ UpdateIndexHandle p h where params = map Param ["update-index", "-z", "--index-info"] - stream h a = a (streamer h) - streamer h s = do - hPutStr h s - hPutStr h "\0" + +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. -} diff --git a/Locations.hs b/Locations.hs index f1580bf24..8189b8a07 100644 --- a/Locations.hs +++ b/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" diff --git a/Logs/View.hs b/Logs/View.hs new file mode 100644 index 000000000..cb1e33125 --- /dev/null +++ b/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 @@ -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 ] diff --git a/Types/MetaData.hs b/Types/MetaData.hs index 248a96abb..601757315 100644 --- a/Types/MetaData.hs +++ b/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 diff --git a/Types/View.hs b/Types/View.hs index 2c30541fa..f1759e0e0 100644 --- a/Types/View.hs +++ b/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 -import Text.Regex.TDFA -#else -#endif +{- A view is a list of fields with filters on their allowed values, + - which are applied to files in a parent git branch. -} +data View = View + { viewParentBranch :: Git.Branch + , viewComponents :: [ViewComponent] + } + deriving (Eq, Show) -{- A view is a list of fields with filters on their allowed values. -} -type View = [ViewComponent] +instance Arbitrary View where + 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 - -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 + | FilterGlob String + deriving (Eq, Show, Read) instance Arbitrary ViewFilter where arbitrary = do size <- arbitrarySizedBoundedIntegral `suchThat` (< 100) FilterValues . S.fromList <$> vector size -#ifdef WITH_TDFA -data Glob = Glob String Regex -#else -data Glob = Glob String -#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 +{- Can a ViewFilter match multiple different MetaValues? -} +multiValue :: ViewFilter -> Bool +multiValue (FilterValues s) = S.size s > 1 +multiValue (FilterGlob _) = True diff --git a/Utility/Directory.hs b/Utility/Directory.hs index c457de6e3..f1bcfada3 100644 --- a/Utility/Directory.hs +++ b/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 () diff --git a/debian/changelog b/debian/changelog index ab0807091..f1afdb821 100644 --- a/debian/changelog +++ b/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. diff --git a/doc/design/metadata.mdwn b/doc/design/metadata.mdwn index 4edfa6d72..0e8727415 100644 --- a/doc/design/metadata.mdwn +++ b/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 -filtered/year=2014/talk containing only files tagged with that, and +`git annex view year=2014 talk` should create a new branch +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 -filtered/year=2014/talk/haskell with only the haskell talks. +`git annex vadd haskell` switches to branch +view/year=2014/talk/haskell with only the haskell talks. -`git annex fadd year=2013 year=2012` switches to branch -filtered/year=2012,2013,2014/talk/haskell. This has subdirectories 2012, +`git annex vadd year=2013 year=2012` switches to branch +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 -filtered/year=2012,2013,2014/talk, which has all available talks in it. +`git annex vrm haskell` switches to +view/year=2012,2013,2014/talk, which has all available talks in it. -`git annex fadd conference=fosdem conference=icfp` switches to branch -filtered/year=2012,2013,2014/talk/conference=fosdem,icfp. Now there +`git annex vadd conference=fosdem conference=icfp` switches to branch +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 -`git annex filter --unmatched=other`. That puts all such files into +Files not matching the view can be included, by using +`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. diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 1b7271092..3b9a227be 100644 --- a/doc/git-annex.mdwn +++ b/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]` |