diff options
Diffstat (limited to 'Annex')
| -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 | 168 |
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 |