summaryrefslogtreecommitdiff
path: root/Annex
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2014-02-18 17:38:23 -0400
committerGravatar Joey Hess <joey@kitenet.net>2014-02-18 18:22:20 -0400
commit2fb1cfc4ae0cfb3f012e074f2f855c592f866b05 (patch)
tree7416b03c25e431898042fef6ad2e5ab27e6882d0 /Annex
parent6f7ff00cb67546008918ed735f8be66b65cf9ce8 (diff)
add git annex view command
(And a vpop command, which is still a bit buggy.) Still need to do vadd and vrm, though this also adds their documentation. Currently not very happy with the view log data serialization. I had to lose the TDFA regexps temporarily, so I can have Read/Show instances of View. I expect the view log format will change in some incompatable way later, probably adding last known refs for the parent branch to View or something like that. Anyway, it basically works, although it's a bit slow looking up the metadata. The actual git branch construction is about as fast as it can be using the current git plumbing. This commit was sponsored by Peter Hogg.
Diffstat (limited to 'Annex')
-rw-r--r--Annex/Branch.hs29
-rw-r--r--Annex/Index.hs46
-rw-r--r--Annex/Link.hs4
-rw-r--r--Annex/View.hs168
4 files changed, 126 insertions, 121 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..0af46680b 100644
--- a/Annex/View.hs
+++ b/Annex/View.hs
@@ -5,61 +5,46 @@
- 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 qualified Backend
+import Annex.Index
+import Annex.Link
+import Logs.MetaData
+import Logs.View
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 +81,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 +93,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. -}
@@ -166,15 +146,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 +202,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,47 +215,19 @@ 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 = do
+ liftIO . nukeFile =<< fromRepo gitAnnexViewIndex
+ 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
@@ -283,11 +239,32 @@ narrowView = applyView' id
{- 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.
-}
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]
+ 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 Nothing = noop -- TODO dotfiles
+ go uh hasher f (Just (k, _)) = do
+ metadata <- getCurrentMetaData k
+ forM_ (fileViews view mkfileview f metadata) $ \fv -> do
+ linktarget <- inRepo $ gitAnnexLink fv k
+ sha <- hashSymlink' hasher linktarget
+ liftIO . Git.UpdateIndex.streamUpdateIndex' uh
+ =<< inRepo (Git.UpdateIndex.stageSymlink fv sha)
{- Applies a view to the reference branch, generating a new branch
- for the View.
@@ -307,18 +284,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