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.
This commit is contained in:
Joey Hess
parent
e640d768ed
commit
67fd06af76
18 changed files with 485 additions and 183 deletions
|
|
@ -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.
|
||||
|
|
|
|||
46
Annex/Index.hs
Normal file
46
Annex/Index.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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 =
|
||||
|
|
|
|||
168
Annex/View.hs
168
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
|
||||
|
|
|
|||
|
|
@ -27,6 +27,8 @@ import qualified Command.TransferKey
|
|||
import qualified Command.TransferKeys
|
||||
import qualified Command.ReKey
|
||||
import qualified Command.MetaData
|
||||
import qualified Command.View
|
||||
import qualified Command.VPop
|
||||
import qualified Command.Reinject
|
||||
import qualified Command.Fix
|
||||
import qualified Command.Init
|
||||
|
|
@ -136,6 +138,8 @@ cmds = concat
|
|||
, Command.TransferKeys.def
|
||||
, Command.ReKey.def
|
||||
, Command.MetaData.def
|
||||
, Command.View.def
|
||||
, Command.VPop.def
|
||||
, Command.Fix.def
|
||||
, Command.Fsck.def
|
||||
, Command.Repair.def
|
||||
|
|
|
|||
42
Command/VPop.hs
Normal file
42
Command/VPop.hs
Normal file
|
|
@ -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.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
|
||||
vs <- dropWhile (/= v) . filter (sameparentbranch v)
|
||||
<$> recentViews
|
||||
case vs of
|
||||
(_v:oldv:_) -> next $ next $
|
||||
checkoutViewBranch oldv (branchView oldv)
|
||||
_ -> next $ next $
|
||||
inRepo $ Git.Command.runBool
|
||||
[ Param "checkout"
|
||||
, Param $ show $ Git.Ref.base $
|
||||
viewParentBranch v
|
||||
]
|
||||
sameparentbranch a b = viewParentBranch a == viewParentBranch b
|
||||
88
Command/View.hs
Normal file
88
Command/View.hs
Normal file
|
|
@ -0,0 +1,88 @@
|
|||
{- 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 "calculating"
|
||||
branch <- applyView view
|
||||
next $ checkoutViewBranch view branch
|
||||
|
||||
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 -> Git.Branch -> CommandCleanup
|
||||
checkoutViewBranch view branch = do
|
||||
ok <- inRepo $ Git.Command.runBool
|
||||
[ Param "checkout"
|
||||
, Param (show $ Git.Ref.base branch)
|
||||
]
|
||||
when ok $ do
|
||||
setView view
|
||||
top <- fromRepo Git.repoPath
|
||||
cwd <- liftIO getCurrentDirectory
|
||||
{- A git repo can easily have empty directories in it,
|
||||
- and this pollutes the view, so remove them. -}
|
||||
liftIO $ removeemptydirs top
|
||||
unlessM (liftIO $ doesDirectoryExist cwd) $
|
||||
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
|
||||
]
|
||||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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. -}
|
||||
|
|
|
|||
10
Locations.hs
10
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"
|
||||
|
|
|
|||
92
Logs/View.hs
Normal file
92
Logs/View.hs
Normal file
|
|
@ -0,0 +1,92 @@
|
|||
{- 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,
|
||||
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
|
||||
l <- take 99 . filter (/= v) <$> recentViews
|
||||
f <- fromRepo gitAnnexViewLog
|
||||
liftIO $ viaTmp writeFile f $ unlines $ map showLog (v : l)
|
||||
|
||||
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
|
||||
3
Test.hs
3
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
|
||||
]
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
3
debian/changelog
vendored
3
debian/changelog
vendored
|
|
@ -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, vrm, vpop: 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.
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -313,6 +313,33 @@ 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.
|
||||
|
||||
* `vadd [field=value ...] [tag ...]`
|
||||
|
||||
Can be used when already in a view to add additional fields or tags
|
||||
to the view.
|
||||
|
||||
* `vrm [field=value ...] [tag ...]`
|
||||
|
||||
Can be used when already in a view to remove fields or tags from the
|
||||
view.
|
||||
|
||||
* `vpop`
|
||||
|
||||
Switches from the currently active view back to the previous view.
|
||||
|
||||
# REPOSITORY SETUP COMMANDS
|
||||
|
||||
* `init [description]`
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue