mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages1 Wiki Activity Actions

Merge branch 'master' of git://git-annex.branchable.com

Browse source
This commit is contained in:
Richard Hartmann 2014-02-21 21:22:20 +01:00
commit 3ddb4bd08d
268 changed files with 5260 additions and 910 deletions

3
Annex.hs
View file

@ -58,6 +58,7 @@ import Types.UUID
import Types.FileMatcher
import Types.NumCopies
import Types.LockPool
import Types.MetaData
import qualified Utility.Matcher
import qualified Data.Map as M
import qualified Data.Set as S
@ -109,6 +110,7 @@ data AnnexState = AnnexState
, lockpool :: LockPool
, flags :: M.Map String Bool
, fields :: M.Map String String
, modmeta :: [ModMeta]
, cleanup :: M.Map String (Annex ())
, inodeschanged :: Maybe Bool
, useragent :: Maybe String
@ -146,6 +148,7 @@ newState c r = AnnexState
, lockpool = M.empty
, flags = M.empty
, fields = M.empty
, modmeta = []
, cleanup = M.empty
, inodeschanged = Nothing
, useragent = Nothing

45
Annex/Branch.hs
View file

@ -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
@ -63,11 +58,11 @@ name = Git.Ref "git-annex"
{- Fully qualified name of the branch. -}
fullname :: Git.Ref
fullname = Git.Ref $ "refs/heads/" ++ show name
fullname = Git.Ref $ "refs/heads/" ++ fromRef name
{- Branch's name in origin. -}
originname :: Git.Ref
originname = Git.Ref $ "origin/" ++ show name
originname = Git.Ref $ "origin/" ++ fromRef name
{- Does origin/git-annex exist? -}
hasOrigin :: Annex Bool
@ -92,8 +87,8 @@ getBranch = maybe (hasOrigin >>= go >>= use) return =<< branchsha
where
go True = do
inRepo $ Git.Command.run
[Param "branch", Param $ show name, Param $ show originname]
fromMaybe (error $ "failed to create " ++ show name)
[Param "branch", Param $ fromRef name, Param $ fromRef originname]
fromMaybe (error $ "failed to create " ++ fromRef name)
<$> branchsha
go False = withIndex' True $
inRepo $ Git.Branch.commitAlways "branch created" fullname []
@ -159,7 +154,7 @@ updateTo pairs = do
then "update"
else "merging " ++
unwords (map Git.Ref.describe branches) ++
" into " ++ show name
" into " ++ fromRef name
localtransitions <- parseTransitionsStrictly "local"
<$> getLocal transitionsLog
unless (null branches) $ do
@ -296,7 +291,7 @@ files = do
branchFiles :: Annex [FilePath]
branchFiles = withIndex $ inRepo $ Git.Command.pipeNullSplitZombie
[ Params "ls-tree --name-only -r -z"
, Param $ show fullname
, Param $ fromRef fullname
]
{- Populates the branch's index file with the current branch contents.
@ -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.
@ -393,7 +368,7 @@ needUpdateIndex branchref = do
setIndexSha :: Git.Ref -> Annex ()
setIndexSha ref = do
f <- fromRepo gitAnnexIndexStatus
liftIO $ writeFile f $ show ref ++ "\n"
liftIO $ writeFile f $ fromRef ref ++ "\n"
setAnnexFilePerm f
{- Stages the journal into the index and returns an action that will
@ -467,7 +442,7 @@ ignoreRefs rs = do
let s = S.unions [old, S.fromList rs]
f <- fromRepo gitAnnexIgnoredRefs
replaceFile f $ \tmp -> liftIO $ writeFile tmp $
unlines $ map show $ S.elems s
unlines $ map fromRef $ S.elems s
getIgnoredRefs :: Annex (S.Set Git.Ref)
getIgnoredRefs = S.fromList . mapMaybe Git.Sha.extractSha . lines <$> content

2
Annex/Branch/Transitions.hs
View file

@ -41,7 +41,7 @@ dropDead f content trustmap = case getLogVariety f of
in if null newlog
then RemoveFile
else ChangeFile $ Presence.showLog newlog
Just SingleValueLog -> PreserveFile
Just OtherLog -> PreserveFile
Nothing -> PreserveFile
dropDeadFromUUIDBasedLog :: TrustMap -> UUIDBased.Log String -> UUIDBased.Log String

13
Annex/Content.hs
View file

@ -243,10 +243,9 @@ finishGetViaTmp check key action = do
moveAnnex key tmpfile
logStatus key InfoPresent
return True
, do
-- the tmp file is left behind, in case caller wants
-- to resume its transfer
return False
-- the tmp file is left behind, in case caller wants
-- to resume its transfer
, return False
)
prepTmp :: Key -> Annex FilePath
@ -492,9 +491,11 @@ getKeysPresent = do
{- In indirect mode, look for the key. In direct mode,
- the inode cache file is only present when a key's content
- is present. -}
- is present, so can be used as a surrogate if the content
- is not located in the annex directory. -}
present False d = doesFileExist $ contentfile d
present True d = doesFileExist $ contentfile d ++ ".cache"
present True d = doesFileExist (contentfile d ++ ".cache")
<||> present False d
contentfile d = d </> takeFileName d
{- Things to do to record changes to content when shutting down.

2
Annex/Content/Direct.hs
View file

@ -66,7 +66,7 @@ changeAssociatedFiles key transform = do
mapping <- calcRepo $ gitAnnexMapping key
files <- associatedFilesRelative key
let files' = transform files
when (files /= files') $ do
when (files /= files') $
modifyContent mapping $
liftIO $ viaTmp writeFileAnyEncoding mapping $
unlines files'

8
Annex/Direct.hs
View file

@ -184,7 +184,7 @@ mergeDirectCleanup d oldsha newsha = do
tryAnnex . maybe (araw f item) (\k -> void $ a k f)
=<< catKey (getsha item) (getmode item)
moveout k f = removeDirect k f
moveout = removeDirect
{- Files deleted by the merge are removed from the work tree.
- Empty work tree directories are removed, per git behavior. -}
@ -286,18 +286,18 @@ setDirect wantdirect = do
- this way things that show HEAD (eg shell prompts) will
- hopefully show just "master". -}
directBranch :: Ref -> Ref
directBranch orighead = case split "/" $ show orighead of
directBranch orighead = case split "/" $ fromRef orighead of
("refs":"heads":"annex":"direct":_) -> orighead
("refs":"heads":rest) ->
Ref $ "refs/heads/annex/direct/" ++ intercalate "/" rest
_ -> Ref $ "refs/heads/" ++ show (Git.Ref.base orighead)
_ -> Ref $ "refs/heads/" ++ fromRef (Git.Ref.base orighead)
{- Converts a directBranch back to the original branch.
-
- Any other ref is left unchanged.
-}
fromDirectBranch :: Ref -> Ref
fromDirectBranch directhead = case split "/" $ show directhead of
fromDirectBranch directhead = case split "/" $ fromRef directhead of
("refs":"heads":"annex":"direct":rest) ->
Ref $ "refs/heads/" ++ intercalate "/" rest
_ -> directhead

3
Annex/FileMatcher.hs
View file

@ -43,7 +43,7 @@ checkMatcher matcher mkey afile notpresent def
fileMatchInfo :: FilePath -> Annex MatchInfo
fileMatchInfo file = do
matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)
return $ MatchingFile $ FileInfo
return $ MatchingFile FileInfo
{ matchFile = matchfile
, relFile = file
}
@ -83,6 +83,7 @@ parseToken checkpresent checkpreferreddir groupmap t
, ("inbackend", limitInBackend)
, ("largerthan", limitSize (>))
, ("smallerthan", limitSize (<))
, ("metadata", limitMetaData)
, ("inallgroup", limitInAllGroup groupmap)
]
where

46
Annex/Index.hs Normal file
View 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

11
Annex/Init.hs
View file

@ -70,11 +70,10 @@ initialize mdescription = do
( do
enableDirectMode
setDirect True
, do
-- Handle case where this repo was cloned from a
-- direct mode repo.
unlessM isBare
switchHEADBack
-- Handle case where this repo was cloned from a
-- direct mode repo
, unlessM isBare
switchHEADBack
)
createInodeSentinalFile
u <- getUUID
@ -227,7 +226,7 @@ fixBadBare = whenM checkBadBare $ do
logStatus k InfoPresent
let dotgit = d </> ".git"
liftIO $ removeDirectoryRecursive dotgit
`catchIO` (const $ renameDirectory dotgit (d </> "removeme"))
`catchIO` const (renameDirectory dotgit (d </> "removeme"))
{- A repostory with the problem won't know it's a bare repository, but will
- have no pre-commit hook (which is not set up in a bare repository),

4
Annex/Link.hs
View file

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

2
Annex/Ssh.hs
View file

@ -76,7 +76,7 @@ bestSocketPath abssocketfile = do
-- ssh appends a 16 char extension to the socket when setting it
-- up, which needs to be taken into account when checking
-- that a valid socket was constructed.
sshgarbage = take (1+16) $ repeat 'X'
sshgarbage = replicate (1+16) 'X'
sshConnectionCachingParams :: FilePath -> [CommandParam]
sshConnectionCachingParams socketfile =

6
Annex/TaggedPush.hs
View file

@ -35,11 +35,11 @@ toTaggedBranch u info b = Git.Ref $ intercalate "/" $ catMaybes
[ Just "refs/synced"
, Just $ fromUUID u
, toB64 <$> info
, Just $ show $ Git.Ref.base b
, Just $ Git.fromRef $ Git.Ref.base b
]
fromTaggedBranch :: Git.Branch -> Maybe (UUID, Maybe String)
fromTaggedBranch b = case split "/" $ show b of
fromTaggedBranch b = case split "/" $ Git.fromRef b of
("refs":"synced":u:info:_base) ->
Just (toUUID u, fromB64Maybe info)
("refs":"synced":u:_base) ->
@ -58,4 +58,4 @@ taggedPush u info branch remote = Git.Command.runBool
, Param $ refspec branch
]
where
refspec b = show b ++ ":" ++ show (toTaggedBranch u info b)
refspec b = Git.fromRef b ++ ":" ++ Git.fromRef (toTaggedBranch u info b)

429
Annex/View.hs Normal file
View file

@ -0,0 +1,429 @@
{- metadata based branch views
-
- Copyright 2014 Joey Hess <joey@kitenet.net>
-
- 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
import qualified Git.DiffTree as DiffTree
import qualified Git.Branch
import qualified Git.LsFiles
import qualified Git.Ref
import Git.UpdateIndex
import Git.Sha
import Git.HashObject
import Git.Types
import Git.FilePath
import qualified Backend
import Annex.Index
import Annex.Link
import Annex.CatFile
import Logs.MetaData
import Logs.View
import Utility.FileMode
import Types.Command
import Config
import CmdLine.Action
import qualified Data.Set as S
import System.Path.WildMatch
import "mtl" Control.Monad.Writer
#ifdef WITH_TDFA
import Text.Regex.TDFA
import Text.Regex.TDFA.String
#else
import Text.Regex
#endif
{- Each visible 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
- blowup with a single file appearing in a crazy number of places!
-
- Capping the view size to 5 is reasonable; why wants to dig
- through 5+ levels of subdirectories to find anything?
-}
viewTooLarge :: View -> Bool
viewTooLarge view = visibleViewSize view > 5
visibleViewSize :: View -> Int
visibleViewSize = length . filter viewVisible . viewComponents
data ViewChange = Unchanged | Narrowing | Widening
deriving (Ord, Eq, Show)
{- Updates a view, adding new fields to filter on (Narrowing),
- or allowing new values in an existing field (Widening). -}
refineView :: View -> [(MetaField, String)] -> (View, ViewChange)
refineView = go Unchanged
where
go c v [] = (v, c)
go c v ((f, s):rest) =
let (v', c') = refineView' v f s
in go (max c c') v' rest
{- Adds an additional filter to a view. This can only result in narrowing
- the view. Multivalued filters are added in non-visible form. -}
filterView :: View -> [(MetaField, String)] -> View
filterView v vs = v { viewComponents = viewComponents f' ++ viewComponents v}
where
f = fst $ refineView (v {viewComponents = []}) vs
f' = f { viewComponents = map toinvisible (viewComponents f) }
toinvisible c = c { viewVisible = False }
refineView' :: View -> MetaField -> String -> (View, ViewChange)
refineView' view field wanted
| field `elem` (map viewField components) =
let (components', viewchanges) = runWriter $ mapM updatefield components
in (view { viewComponents = components' }, maximum viewchanges)
| otherwise =
let component = ViewComponent field viewfilter (multiValue viewfilter)
view' = view { viewComponents = component : components }
in if viewTooLarge view'
then error $ "View is too large (" ++ show (visibleViewSize view') ++ " levels of subdirectories)"
else (view', Narrowing)
where
components = viewComponents view
viewfilter
| any (`elem` wanted) "*?" = FilterGlob wanted
| otherwise = FilterValues $ S.singleton $ toMetaValue wanted
updatefield :: ViewComponent -> Writer [ViewChange] ViewComponent
updatefield v
| viewField v == field = do
let (newvf, viewchange) = combineViewFilter (viewFilter v) viewfilter
tell [viewchange]
return $ v { viewFilter = newvf }
| otherwise = return v
{- Combine old and new ViewFilters, yielding a result that matches
- either old+new, or only new.
-
- If we have FilterValues and change to a FilterGlob,
- it's always a widening change, because the glob could match other
- values. OTOH, going the other way, it's a Narrowing change if the old
- glob matches all the new FilterValues.
-
- With two globs, the old one is discarded, and the new one is used.
- We can tell if that's a narrowing change by checking if the old
- glob matches the new glob. For example, "*" matches "foo*",
- so that's narrowing. While "f?o" does not match "f??", so that's
- widening.
-}
combineViewFilter :: ViewFilter -> ViewFilter -> (ViewFilter, ViewChange)
combineViewFilter old@(FilterValues olds) (FilterValues news)
| combined == old = (combined, Unchanged)
| otherwise = (combined, Widening)
where
combined = FilterValues (S.union olds news)
combineViewFilter (FilterValues _) newglob@(FilterGlob _) =
(newglob, Widening)
combineViewFilter (FilterGlob oldglob) new@(FilterValues s)
| all (matchGlob (compileGlob oldglob) . fromMetaValue) (S.toList s) = (new, Narrowing)
| otherwise = (new, Widening)
combineViewFilter (FilterGlob old) newglob@(FilterGlob new)
| old == new = (newglob, Unchanged)
| matchGlob (compileGlob old) new = (newglob, Narrowing)
| otherwise = (newglob, Widening)
{- Converts a filepath used in a reference branch to the
- filename that will be used in the view.
-
- No two filepaths from the same branch should yeild the same result,
- so all directory structure needs to be included in the output file
- 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
-
- (To avoid collisions with a filename that already contains {foo},
- that is doubled to {{foo}}.)
-}
fileViewFromReference :: MkFileView
fileViewFromReference f = concat
[ double base
, if null dirs then "" else "_{" ++ double (intercalate ";" dirs) ++ "}"
, double $ concat extensions
]
where
(path, basefile) = splitFileName f
dirs = filter (/= ".") $ map dropTrailingPathSeparator (splitPath path)
(base, extensions) = splitShortExtensions basefile
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.
-
- Note that a file may appear multiple times in a view, when it
- has multiple matching values for a MetaField used in the View.
-
- Of course if its MetaData does not match the View, it won't appear at
- all.
-
- Note that for efficiency, it's useful to partially
- evaluate this function with the view parameter and reuse
- the result. The globs in the view will then be compiled and memoized.
-}
fileViews :: View -> MkFileView -> FilePath -> MetaData -> [FileView]
fileViews view =
let matchers = map viewComponentMatcher (viewComponents view)
in \mkfileview file metadata ->
let matches = map (\m -> m metadata) matchers
in if any isNothing matches
then []
else
let paths = pathProduct $
map (map toViewPath) (visible matches)
in if null paths
then [mkfileview file]
else map (</> mkfileview file) paths
where
visible = map (fromJust . snd) .
filter (viewVisible . fst) .
zip (viewComponents view)
{- Checks if metadata matches a ViewComponent filter, and if so
- returns the value, or values that match. Self-memoizing on ViewComponent. -}
viewComponentMatcher :: ViewComponent -> (MetaData -> Maybe [MetaValue])
viewComponentMatcher viewcomponent = \metadata ->
let s = matcher (currentMetaDataValues metafield metadata)
in if S.null s then Nothing else Just (S.toList s)
where
metafield = viewField viewcomponent
matcher = case viewFilter viewcomponent of
FilterValues s -> \values -> S.intersection s values
FilterGlob glob ->
let regex = compileGlob glob
in \values ->
S.filter (matchGlob regex . fromMetaValue) values
compileGlob :: String -> Regex
compileGlob glob =
#ifdef WITH_TDFA
case compile (defaultCompOpt {caseSensitive = False}) defaultExecOpt regex of
Right r -> r
Left _ -> error $ "failed to compile regex: " ++ regex
#else
mkRegexWithOpts regex False True
#endif
where
regex = '^':wildToRegex glob
matchGlob :: Regex -> String -> Bool
matchGlob regex val =
#ifdef WITH_TDFA
case execute regex val of
Right (Just _) -> True
_ -> False
#else
isJust $ matchRegex regex val
#endif
toViewPath :: MetaValue -> FilePath
toViewPath = concatMap escapeslash . fromMetaValue
where
escapeslash c
| c == '/' = [pseudoSlash]
| c == '\\' = [pseudoBackslash]
| c == pseudoSlash = [pseudoSlash, pseudoSlash]
| c == pseudoBackslash = [pseudoBackslash, pseudoBackslash]
| otherwise = [c]
fromViewPath :: FilePath -> MetaValue
fromViewPath = toMetaValue . deescapeslash []
where
deescapeslash s [] = reverse s
deescapeslash s (c:cs)
| c == pseudoSlash = case cs of
(c':cs')
| c' == pseudoSlash -> deescapeslash (pseudoSlash:s) cs'
_ -> deescapeslash ('/':s) cs
| c == pseudoBackslash = case cs of
(c':cs')
| c' == pseudoBackslash -> deescapeslash (pseudoBackslash:s) cs'
_ -> deescapeslash ('/':s) cs
| otherwise = deescapeslash (c:s) cs
pseudoSlash :: Char
pseudoSlash = '\8725' -- '∕' /= '/'
pseudoBackslash :: Char
pseudoBackslash = '\9586' -- '╲' /= '\'
pathProduct :: [[FilePath]] -> [FilePath]
pathProduct [] = []
pathProduct (l:ls) = foldl combinel l ls
where
combinel xs ys = [combine x y | x <- xs, y <- ys]
{- Extracts the metadata from a fileview, based on the view that was used
- to construct it. -}
fromView :: View -> FileView -> MetaData
fromView view f = foldr (uncurry updateMetaData) newMetaData (zip fields values)
where
visible = filter viewVisible (viewComponents view)
fields = map viewField visible
paths = splitDirectories $ dropFileName f
values = map fromViewPath paths
{- Constructing a view that will match arbitrary metadata, and applying
- it to a file yields a set of FileViews which all contain the same
- MetaFields that were present in the input metadata
- (excluding fields that are not visible). -}
prop_view_roundtrips :: FilePath -> MetaData -> Bool -> Bool
prop_view_roundtrips f metadata visible = null f || viewTooLarge view ||
all hasfields (fileViews view fileViewFromReference f metadata)
where
view = View (Git.Ref "master") $
map (\(mf, mv) -> ViewComponent mf (FilterValues $ S.filter (not . null . fromMetaValue) mv) visible)
(fromMetaData metadata)
visiblefields = sort (map viewField $ filter viewVisible (viewComponents view))
hasfields fv = sort (map fst (fromMetaData (fromView view fv))) == visiblefields
{- Applies a view to the currently checked out branch, generating a new
- branch for the view.
-}
applyView :: View -> Annex Git.Branch
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. That is, it must match a subset of the files
- in view, not any others.
-}
narrowView :: View -> Annex Git.Branch
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.
-
- Currently only works in indirect mode. Must be run from top of
- repository.
-}
applyView' :: MkFileView -> View -> Annex Git.Branch
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
genfileviews = fileViews view mkfileview -- enables memoization
go uh hasher f (Just (k, _)) = do
metadata <- getCurrentMetaData k
forM_ (genfileviews 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.
-
- This needs to work incrementally, to quickly update the view branch
- when the reference branch is changed. So, it works based on an
- old version of the reference branch, uses diffTree to find the
- changes, and applies those changes to the view branch.
-}
updateView :: View -> Git.Ref -> Git.Ref -> Annex Git.Branch
updateView view ref oldref = genViewBranch view $ do
(diffs, cleanup) <- inRepo $ DiffTree.diffTree oldref ref
forM_ diffs go
void $ liftIO cleanup
where
go diff
| DiffTree.dstsha diff == nullSha = error "TODO delete file"
| otherwise = error "TODO add file"
{- Diff between currently checked out branch and staged changes, and
- update metadata to reflect the changes that are being committed to the
- view.
-
- Adding a file to a directory adds the metadata represented by
- that directory to the file, and removing a file from a directory
- removes the metadata.
-
- Note that removes must be handled before adds. This is so
- that moving a file from x/foo/ to x/bar/ adds back the metadata for x.
-}
withViewChanges :: (FileView -> Key -> CommandStart) -> (FileView -> Key -> CommandStart) -> Annex ()
withViewChanges addmeta removemeta = do
makeabs <- flip fromTopFilePath <$> gitRepo
(diffs, cleanup) <- inRepo $ DiffTree.diffIndex Git.Ref.headRef
forM_ diffs handleremovals
forM_ diffs (handleadds makeabs)
void $ liftIO cleanup
where
handleremovals item
| DiffTree.srcsha item /= nullSha =
handle item removemeta
=<< catKey (DiffTree.srcsha item) (DiffTree.srcmode item)
| otherwise = noop
handleadds makeabs item
| DiffTree.dstsha item /= nullSha =
handle item addmeta
=<< ifM isDirect
( catKey (DiffTree.dstsha item) (DiffTree.dstmode item)
-- optimisation
, isAnnexLink $ makeabs $ DiffTree.file item
)
| otherwise = noop
handle item a = maybe noop
(void . commandAction . a (getTopFilePath $ DiffTree.file item))
{- 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 = withIndex $ do
a
let branch = branchView view
void $ inRepo $ Git.Branch.commit True (fromRef branch) branch []
return branch
{- 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
withCurrentView :: (View -> Annex a) -> Annex a
withCurrentView a = maybe (error "Not in a view.") a =<< currentView

3
Assistant.hs
View file

@ -93,7 +93,8 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
start (Utility.Daemon.daemonize logfd (Just pidfile) False) Nothing
#else
-- Windows is always foreground, and has no log file.
start id $
liftIO $ Utility.Daemon.lockPidFile pidfile
start id $ do
case startbrowser of
Nothing -> Nothing
Just a -> Just $ a Nothing Nothing

23
Assistant/MakeRemote.hs
View file

@ -48,9 +48,10 @@ makeRsyncRemote :: RemoteName -> String -> Annex String
makeRsyncRemote name location = makeRemote name location $ const $ void $
go =<< Command.InitRemote.findExisting name
where
go Nothing = setupSpecialRemote name Rsync.remote config
go Nothing = setupSpecialRemote name Rsync.remote config Nothing
(Nothing, Command.InitRemote.newConfig name)
go (Just (u, c)) = setupSpecialRemote name Rsync.remote config (Just u, c)
go (Just (u, c)) = setupSpecialRemote name Rsync.remote config Nothing
(Just u, c)
config = M.fromList
[ ("encryption", "shared")
, ("rsyncurl", location)
@ -60,44 +61,44 @@ makeRsyncRemote name location = makeRemote name location $ const $ void $
{- Inits a gcrypt special remote, and returns its name. -}
makeGCryptRemote :: RemoteName -> String -> KeyId -> Annex RemoteName
makeGCryptRemote remotename location keyid =
initSpecialRemote remotename GCrypt.remote $ M.fromList
initSpecialRemote remotename GCrypt.remote Nothing $ M.fromList
[ ("type", "gcrypt")
, ("gitrepo", location)
, configureEncryption HybridEncryption
, ("keyid", keyid)
]
type SpecialRemoteMaker = RemoteName -> RemoteType -> R.RemoteConfig -> Annex RemoteName
type SpecialRemoteMaker = RemoteName -> RemoteType -> Maybe CredPair -> R.RemoteConfig -> Annex RemoteName
{- Inits a new special remote. The name is used as a suggestion, but
- will be changed if there is already a special remote with that name. -}
initSpecialRemote :: SpecialRemoteMaker
initSpecialRemote name remotetype config = go 0
initSpecialRemote name remotetype mcreds config = go 0
where
go :: Int -> Annex RemoteName
go n = do
let fullname = if n == 0 then name else name ++ show n
r <- Command.InitRemote.findExisting fullname
case r of
Nothing -> setupSpecialRemote fullname remotetype config
Nothing -> setupSpecialRemote fullname remotetype config mcreds
(Nothing, Command.InitRemote.newConfig fullname)
Just _ -> go (n + 1)
{- Enables an existing special remote. -}
enableSpecialRemote :: SpecialRemoteMaker
enableSpecialRemote name remotetype config = do
enableSpecialRemote name remotetype mcreds config = do
r <- Command.InitRemote.findExisting name
case r of
Nothing -> error $ "Cannot find a special remote named " ++ name
Just (u, c) -> setupSpecialRemote name remotetype config (Just u, c)
Just (u, c) -> setupSpecialRemote name remotetype config mcreds (Just u, c)
setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName
setupSpecialRemote name remotetype config (mu, c) = do
setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName
setupSpecialRemote name remotetype config mcreds (mu, c) = do
{- Currently, only 'weak' ciphers can be generated from the
- assistant, because otherwise GnuPG may block once the entropy
- pool is drained, and as of now there's no way to tell the user
- to perform IO actions to refill the pool. -}
(c', u) <- R.setup remotetype mu $
(c', u) <- R.setup remotetype mu mcreds $
M.insert "highRandomQuality" "false" $ M.union config c
describeUUID u name
configSet u c'

19
Assistant/Restart.hs
View file

@ -16,6 +16,7 @@ import Assistant.NamedThread
import Utility.ThreadScheduler
import Utility.NotificationBroadcaster
import Utility.Url
import Utility.PID
import qualified Git.Construct
import qualified Git.Config
import Config.Files
@ -25,10 +26,9 @@ import qualified Git
import Control.Concurrent
import System.Process (cwd)
#ifndef mingw32_HOST_OS
import System.Posix (getProcessID, signalProcess, sigTERM)
import System.Posix (signalProcess, sigTERM)
#else
import System.Win32.Process.Current (getCurrentProcessId)
import System.Win32.Console (generateConsoleCtrlEvent, cTRL_C_EVENT)
import Utility.WinProcess
#endif
{- Before the assistant can be restarted, have to remove our
@ -53,9 +53,9 @@ postRestart url = do
void $ liftIO $ forkIO $ do
threadDelaySeconds (Seconds 120)
#ifndef mingw32_HOST_OS
signalProcess sigTERM =<< getProcessID
signalProcess sigTERM =<< getPID
#else
generateConsoleCtrlEvent cTRL_C_EVENT =<< getCurrentProcessId
terminatePID =<< getPID
#endif
runRestart :: Assistant URLString
@ -86,10 +86,13 @@ newAssistantUrl repo = do
threadDelay 100000 -- 1/10th of a second
a
{- Returns once the assistant has daemonized, but possibly before it's
- listening for web connections. -}
{- Does not wait for assistant to be listening for web connections.
-
- On windows, the assistant does not daemonize, which is why the forkIO is
- done.
-}
startAssistant :: FilePath -> IO ()
startAssistant repo = do
startAssistant repo = void $ forkIO $ do
program <- readProgramFile
(_, _, _, pid) <-
createProcess $

8
Assistant/Threads/Merger.hs
View file

@ -80,8 +80,8 @@ onChange file
mergecurrent (Just current)
| equivBranches changedbranch current = do
debug
[ "merging", show changedbranch
, "into", show current
[ "merging", Git.fromRef changedbranch
, "into", Git.fromRef current
]
void $ liftAnnex $ Command.Sync.mergeFrom changedbranch
mergecurrent _ = noop
@ -105,12 +105,12 @@ onChange file
equivBranches :: Git.Ref -> Git.Ref -> Bool
equivBranches x y = base x == base y
where
base = takeFileName . show
base = takeFileName . Git.fromRef
isAnnexBranch :: FilePath -> Bool
isAnnexBranch f = n `isSuffixOf` f
where
n = '/' : show Annex.Branch.name
n = '/' : Git.fromRef Annex.Branch.name
fileToBranch :: FilePath -> Git.Ref
fileToBranch f = Git.Ref $ "refs" </> base

8
Assistant/Threads/SanityChecker.hs
View file

@ -194,8 +194,13 @@ dailyCheck urlrenderer = do
hourlyCheck :: Assistant ()
hourlyCheck = do
#ifndef mingw32_HOST_OS
checkLogSize 0
#else
noop
#endif
#ifndef mingw32_HOST_OS
{- Rotate logs until log file size is < 1 mb. -}
checkLogSize :: Int -> Assistant ()
checkLogSize n = do
@ -209,6 +214,7 @@ checkLogSize n = do
checkLogSize $ n + 1
where
filesize f = fromIntegral . fileSize <$> liftIO (getFileStatus f)
#endif
oneMegabyte :: Int
oneMegabyte = 1000000
@ -237,5 +243,5 @@ checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGit
button <- mkAlertButton True (T.pack "Configure") urlrenderer ConfigUnusedR
void $ addAlert $ unusedFilesAlert [button] $ T.unpack $ renderTense Present msg
#else
debug [msg]
debug [show $ renderTense Past msg]
#endif

16
Assistant/TransferSlots.hs
View file

@ -39,7 +39,7 @@ import qualified Control.Concurrent.MSemN as MSemN
import System.Posix.Process (getProcessGroupIDOf)
import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
#else
import System.Win32.Console (generateConsoleCtrlEvent, cTRL_C_EVENT, cTRL_BREAK_EVENT)
import Utility.WinProcess
#endif
type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()))
@ -256,23 +256,19 @@ cancelTransfer pause t = do
signalthread tid
| pause = throwTo tid PauseTransfer
| otherwise = killThread tid
{- In order to stop helper processes like rsync,
- kill the whole process group of the process
- running the transfer. -}
killproc pid = void $ tryIO $ do
#ifndef mingw32_HOST_OS
{- In order to stop helper processes like rsync,
- kill the whole process group of the process
- running the transfer. -}
g <- getProcessGroupIDOf pid
let signal sig = void $ tryIO $ signalProcessGroup sig g
signal sigTERM
graceperiod
threadDelay 50000 -- 0.05 second grace period
signal sigKILL
#else
let signal sig = void $ tryIO $ generateConsoleCtrlEvent sig pid
signal cTRL_C_EVENT
graceperiod
signal cTRL_BREAK_EVENT
terminatePID pid
#endif
graceperiod = threadDelay 50000 -- 0.05 second
{- Start or resume a transfer. -}
startTransfer :: Transfer -> Assistant ()

4
Assistant/Types/NetMessager.hs
View file

@ -32,7 +32,7 @@ data NetMessage
| PairingNotification PairStage ClientID UUID
-- used for git push over the network messager
| Pushing ClientID PushStage
deriving (Show, Eq, Ord)
deriving (Eq, Ord, Show)
{- Something used to identify the client, or clients to send the message to. -}
type ClientID = Text
@ -50,7 +50,7 @@ data PushStage
| SendPackOutput SequenceNum ByteString
-- sent when git receive-pack exits, with its exit code
| ReceivePackDone ExitCode
deriving (Show, Eq, Ord)
deriving (Eq, Ord, Show)
{- A sequence number. Incremented by one per packet in a sequence,
- starting with 1 for the first packet. 0 means sequence numbers are

6
Assistant/WebApp/Configurators/AWS.hs
View file

@ -202,11 +202,11 @@ enableAWSRemote _ _ = error "S3 not supported by this build"
#endif
makeAWSRemote :: SpecialRemoteMaker -> RemoteType -> StandardGroup -> AWSCreds -> RemoteName -> RemoteConfig -> Handler ()
makeAWSRemote maker remotetype defaultgroup (AWSCreds ak sk) name config = do
liftIO $ AWS.setCredsEnv (T.unpack ak, T.unpack sk)
makeAWSRemote maker remotetype defaultgroup (AWSCreds ak sk) name config =
setupCloudRemote defaultgroup Nothing $
maker hostname remotetype config
maker hostname remotetype (Just creds) config
where
creds = (T.unpack ak, T.unpack sk)
{- AWS services use the remote name as the basis for a host
- name, so filter it to contain valid characters. -}
hostname = case filter isAlphaNum name of

3
Assistant/WebApp/Configurators/Local.hs
View file

@ -300,7 +300,6 @@ getGenKeyForDriveR drive = withNewSecretKey $ \keyid ->
getFinishAddDriveR :: RemovableDrive -> RepoKey -> Handler Html
getFinishAddDriveR drive = go
where
{- Set up new gcrypt special remote. -}
go (RepoKey keyid) = whenGcryptInstalled $ makewith $ const $ do
r <- liftAnnex $ addRemote $
makeGCryptRemote remotename dir keyid
@ -314,7 +313,7 @@ getFinishAddDriveR drive = go
remotename' <- liftAnnex $ getGCryptRemoteName u dir
makewith $ const $ do
r <- liftAnnex $ addRemote $
enableSpecialRemote remotename' GCrypt.remote $ M.fromList
enableSpecialRemote remotename' GCrypt.remote Nothing $ M.fromList
[("gitrepo", dir)]
return (u, r)
{- Making a new unencrypted repo, or combining with an existing one. -}

57
Assistant/WebApp/Configurators/Ssh.hs
View file

@ -25,6 +25,11 @@ import qualified Remote.GCrypt as GCrypt
import Annex.UUID
import Logs.UUID
#ifdef mingw32_HOST_OS
import Utility.Tmp
import Utility.Rsync
#endif
import qualified Data.Text as T
import qualified Data.Map as M
import Network.Socket
@ -354,7 +359,7 @@ checkExistingGCrypt sshdata nope = checkGCryptRepoEncryption repourl nope nope $
enableGCrypt :: SshData -> RemoteName -> Handler Html
enableGCrypt sshdata reponame =
setupCloudRemote TransferGroup Nothing $
enableSpecialRemote reponame GCrypt.remote $ M.fromList
enableSpecialRemote reponame GCrypt.remote Nothing $ M.fromList
[("gitrepo", genSshUrl sshdata)]
{- Combining with a gcrypt repository that may not be
@ -468,8 +473,18 @@ enableRsyncNetGCrypt sshinput reponame =
notencrypted = error "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository."
notinstalled = error "internal"
{- Prepares rsync.net ssh key, and if successful, runs an action with
- its SshData. -}
{- Prepares rsync.net ssh key and creates the directory that will be
- used on rsync.net. If successful, runs an action with its SshData.
-
- To append the ssh key to rsync.net's authorized_keys, their
- documentation recommends a dd methodd, where the line is fed
- in to ssh over stdin.
-
- On Windows, ssh password prompting happens on stdin, so cannot
- feed the key in that way. Instead, first rsync down any current
- authorized_keys file, then modifiy it, and then rsync it back up.
- This means 2 password prompts rather than one for Windows.
-}
prepRsyncNet :: SshInput -> String -> (SshData -> Handler Html) -> Handler Html
prepRsyncNet sshinput reponame a = do
knownhost <- liftIO $ maybe (return False) knownHost (inputHostname sshinput)
@ -480,25 +495,37 @@ prepRsyncNet sshinput reponame a = do
, needsPubKey = True
, sshCapabilities = [RsyncCapable]
}
let sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
let torsyncnet cmd = filter (not . null)
[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
, sshhost
, cmd
]
#ifndef mingw32_HOST_OS
{- I'd prefer to separate commands with && , but
- rsync.net's shell does not support that.
-
- The dd method of appending to the authorized_keys file is the
- one recommended by rsync.net documentation. I touch the file first
- to not need to use a different method to create it.
-}
- rsync.net's shell does not support that. -}
let remotecommand = intercalate ";"
[ "mkdir -p .ssh"
, "touch .ssh/authorized_keys"
, "dd of=.ssh/authorized_keys oflag=append conv=notrunc"
, "mkdir -p " ++ T.unpack (sshDirectory sshdata)
]
let sshopts = filter (not . null)
[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
, genSshHost (sshHostName sshdata) (sshUserName sshdata)
, remotecommand
]
sshSetup sshopts (Just $ sshPubKey keypair) $ a sshdata
sshSetup (torsyncnet remotecommand) (Just $ sshPubKey keypair) (a sshdata)
#else
liftIO $ withTmpDir "rsyncnet" $ \tmpdir -> do
createDirectory $ tmpdir </> ".ssh"
(oldkeys, _) <- sshTranscript (torsyncnet "cat .ssh/authorized_keys") Nothing
writeFile (tmpdir </> ".ssh" </> "authorized_keys")
(sshPubKey keypair ++ "\n" ++ oldkeys)
liftIO $ putStrLn "May need to prompt for your rsync.net password one more time..."
void $ rsync
[ Param "-r"
, File $ tmpdir </> ".ssh/"
, Param $ sshhost ++ ":.ssh/"
]
let remotecommand = "mkdir -p " ++ T.unpack (sshDirectory sshdata)
sshSetup (torsyncnet remotecommand) Nothing (a sshdata)
#endif
isRsyncNet :: Maybe Text -> Bool
isRsyncNet Nothing = False

5
Assistant/WebApp/Configurators/WebDAV.hs
View file

@ -123,10 +123,9 @@ postEnableWebDAVR _ = error "WebDAV not supported by this build"
#ifdef WITH_WEBDAV
makeWebDavRemote :: SpecialRemoteMaker -> RemoteName -> CredPair -> RemoteConfig -> Handler ()
makeWebDavRemote maker name creds config = do
liftIO $ WebDAV.setCredsEnv creds
makeWebDavRemote maker name creds config =
setupCloudRemote TransferGroup Nothing $
maker name WebDAV.remote config
maker name WebDAV.remote (Just creds) config
{- Only returns creds previously used for the same hostname. -}
previouslyUsedWebDAVCreds :: String -> Annex (Maybe CredPair)

10
Assistant/WebApp/Control.hs
View file

@ -16,15 +16,15 @@ import Assistant.TransferSlots
import Assistant.Restart
import Utility.LogFile
import Utility.NotificationBroadcaster
import Utility.PID
import Control.Concurrent
import qualified Data.Map as M
import qualified Data.Text as T
#ifndef mingw32_HOST_OS
import System.Posix (getProcessID, signalProcess, sigTERM)
import System.Posix (signalProcess, sigTERM)
#else
import System.Win32.Process.Current (getCurrentProcessId)
import System.Win32.Console (generateConsoleCtrlEvent, cTRL_C_EVENT)
import Utility.WinProcess
#endif
getShutdownR :: Handler Html
@ -54,9 +54,9 @@ getShutdownConfirmedR = do
void $ liftIO $ forkIO $ do
threadDelay 2000000
#ifndef mingw32_HOST_OS
signalProcess sigTERM =<< getProcessID
signalProcess sigTERM =<< getPID
#else
generateConsoleCtrlEvent cTRL_C_EVENT =<< getCurrentProcessId
terminatePID =<< getPID
#endif
redirect NotRunningR

17
Assistant/WebApp/DashBoard.hs
View file

@ -130,8 +130,23 @@ openFileBrowser = do
#endif
ifM (liftIO $ inPath cmd)
( do
void $ liftIO $ forkIO $ void $
let run = void $ liftIO $ forkIO $ void $
boolSystem cmd params
run
#ifdef mingw32_HOST_OS
{- On windows, if the file browser is not
- already open, it comes up below the
- web browser when started.
-
- Running it a second time brings it
- to the foreground.
-
- Seems to need a delay long enough for the file
- browser to be open in order to work. Here 1
- second. -}
liftIO $ threadDelay 1000000
run
#endif
return True
, do
void $ redirect $ "file://" ++ path

4
Assistant/WebApp/MakeRemote.hs
View file

@ -28,8 +28,8 @@ import Utility.Yesod
- and finishes setting it up, then starts syncing with it,
- and finishes by displaying the page to edit it. -}
setupCloudRemote :: StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
setupCloudRemote defaultgroup mcost maker = do
r <- liftAnnex $ addRemote maker
setupCloudRemote defaultgroup mcost name = do
r <- liftAnnex $ addRemote name
liftAnnex $ do
setStandardGroup (Remote.uuid r) defaultgroup
maybe noop (Config.setRemoteCost (Remote.repo r)) mcost

3
Assistant/XMPP.hs
View file

@ -13,6 +13,7 @@ import Assistant.Common
import Assistant.Types.NetMessager
import Assistant.Pairing
import Git.Sha (extractSha)
import Git
import Network.Protocol.XMPP hiding (Node)
import Data.Text (Text)
@ -152,7 +153,7 @@ pushMessage = gitAnnexMessage . encode
where
encode (CanPush u shas) =
gitAnnexTag canPushAttr $ T.pack $ unwords $
fromUUID u : map show shas
fromUUID u : map fromRef shas
encode (PushRequest u) =
gitAnnexTag pushRequestAttr $ T.pack $ fromUUID u
encode (StartingPush u) =

1
Backend/Hash.hs
View file

@ -101,6 +101,7 @@ checkKeyChecksum hash key file = do
case (mstat, fast) of
(Just stat, False) -> do
let filesize = fromIntegral $ fileSize stat
showSideAction "checksum"
check <$> hashFile hash file filesize
_ -> return True
where

22
Build/DistributionUpdate.hs
View file

@ -21,11 +21,16 @@ main = do
makeinfos :: Annex ()
makeinfos = do
void $ inRepo $ runBool
[ Param "commit"
, Param "-m"
, Param $ "publishing git-annex " ++ version
]
basedir <- liftIO getRepoDir
version <- liftIO getChangelogVersion
now <- liftIO getCurrentTime
liftIO $ putStrLn $ "building info files for version " ++ version ++ " in " ++ basedir
fs <- liftIO $ dirContentsRecursiveSkipping (== "info") True (basedir </> "git-annex")
fs <- liftIO $ dirContentsRecursiveSkipping (const False) True (basedir </> "git-annex")
forM_ fs $ \f -> do
v <- lookupFile f
case v of
@ -44,7 +49,7 @@ makeinfos = do
void $ inRepo $ runBool
[ Param "commit"
, Param "-m"
, Param $ "publishing git-annex " ++ version
, Param $ "updated info files for git-annex " ++ version
]
void $ inRepo $ runBool
[ Param "annex"
@ -54,6 +59,19 @@ makeinfos = do
[ Param "annex"
, Params "sync"
]
{- Check for out of date info files. -}
infos <- liftIO $ filter (".info" `isSuffixOf`)
<$> dirContentsRecursive (basedir </> "git-annex")
ds <- liftIO $ forM infos (readish <$$> readFile)
let dis = zip infos ds
let ood = filter (outofdate version) dis
unless (null ood) $
error $ "Some info files are out of date: " ++ show (map fst ood)
where
outofdate version (_, md) = case md of
Nothing -> True
Just d -> distributionVersion d /= version
getRepoDir :: IO FilePath
getRepoDir = do

11
Build/EvilLinker.hs
View file

@ -17,6 +17,7 @@ import Control.Applicative ((<$>))
import Control.Monad
import System.Directory
import Data.Maybe
import Data.List
import Utility.Monad
import Utility.Process
@ -94,13 +95,19 @@ parseCollect2 = do
path <- manyTill anyChar (try $ string ldcmd)
void $ char ' '
params <- restOfLine
return $ CmdParams (path ++ ldcmd) (escapeDosPaths params) Nothing
return $ CmdParams (path ++ ldcmd) (skipHack $ escapeDosPaths params) Nothing
where
ldcmd = "ld.exe"
versionline = do
void $ string "collect2 version"
restOfLine
{- For unknown reasons, asking the linker to link this in fails,
- with error about multiple definitions of a symbol from the library.
- This is a horrible hack. -}
skipHack :: String -> String
skipHack = replace "dist/build/git-annex/git-annex-tmp/Utility/winprocess.o" ""
{- Input contains something like
- c:/program files/haskell platform/foo -LC:/Program Files/Haskell Platform/ -L...
- and the *right* spaces must be escaped with \

12
CmdLine/GitAnnex.hs
View file

@ -26,6 +26,12 @@ import qualified Command.DropKey
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.VFilter
import qualified Command.VPop
import qualified Command.VCycle
import qualified Command.Reinject
import qualified Command.Fix
import qualified Command.Init
@ -134,6 +140,12 @@ cmds = concat
, Command.TransferKey.def
, Command.TransferKeys.def
, Command.ReKey.def
, Command.MetaData.def
, Command.View.def
, Command.VAdd.def
, Command.VFilter.def
, Command.VPop.def
, Command.VCycle.def
, Command.Fix.def
, Command.Fsck.def
, Command.Repair.def

2
CmdLine/GitAnnex/Options.hs
View file

@ -54,6 +54,8 @@ gitAnnexOptions = commonOptions ++
"match files larger than a size"
, Option [] ["smallerthan"] (ReqArg Limit.addSmallerThan paramSize)
"match files smaller than a size"
, Option [] ["metadata"] (ReqArg Limit.addMetaData "FIELD=VALUE")
"match files with attached metadata"
, Option [] ["want-get"] (NoArg Limit.Wanted.addWantGet)
"match files the repository wants to get"
, Option [] ["want-drop"] (NoArg Limit.Wanted.addWantDrop)

3
CmdLine/GitAnnexShell/Fields.hs
View file

@ -9,6 +9,7 @@ module CmdLine.GitAnnexShell.Fields where
import Common.Annex
import qualified Annex
import Git.FilePath
import Data.Char
@ -29,7 +30,7 @@ remoteUUID = Field "remoteuuid" $
associatedFile :: Field
associatedFile = Field "associatedfile" $ \f ->
-- is the file a safe relative filename?
not (isAbsolute f) && not ("../" `isPrefixOf` f)
not (absoluteGitPath f) && not ("../" `isPrefixOf` f)
direct :: Field
direct = Field "direct" $ \f -> f == "1"

2
Command.hs
View file

@ -5,8 +5,6 @@
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE BangPatterns #-}
module Command (
command,
noRepo,

27
Command/Dead.hs
View file

@ -7,34 +7,13 @@
module Command.Dead where
import Common.Annex
import Command
import qualified Remote
import Logs.Trust
import Logs.Group
import qualified Data.Set as S
import Types.TrustLevel
import Command.Trust (trustCommand)
def :: [Command]
def = [command "dead" (paramRepeating paramRemote) seek
SectionSetup "hide a lost repository"]
seek :: CommandSeek
seek = withWords start
start :: [String] -> CommandStart
start ws = do
let name = unwords ws
showStart "dead" name
u <- Remote.nameToUUID name
next $ perform u
perform :: UUID -> CommandPerform
perform uuid = do
markDead uuid
next $ return True
markDead :: UUID -> Annex ()
markDead uuid = do
trustSet uuid DeadTrusted
groupSet uuid S.empty
seek = trustCommand "dead" DeadTrusted

2
Command/EnableRemote.hs
View file

@ -47,7 +47,7 @@ unknownNameError prefix = do
perform :: RemoteType -> UUID -> R.RemoteConfig -> CommandPerform
perform t u c = do
(c', u') <- R.setup t (Just u) c
(c', u') <- R.setup t (Just u) Nothing c
next $ cleanup u' c'
cleanup :: UUID -> R.RemoteConfig -> CommandCleanup

54
Command/Fsck.hs
View file

@ -31,12 +31,8 @@ import Config
import Types.Key
import Utility.HumanTime
import Git.FilePath
import Utility.PID
#ifndef mingw32_HOST_OS
import System.Posix.Process (getProcessID)
#else
import System.Win32.Process.Current (getCurrentProcessId)
#endif
import Data.Time.Clock.POSIX
import Data.Time
import System.Posix.Types (EpochTime)
@ -72,7 +68,7 @@ seek ps = do
from <- getOptionField fsckFromOption Remote.byNameWithUUID
i <- getIncremental
withKeyOptions
(startKey i)
(\k -> startKey i k =<< getNumCopies)
(withFilesInGit $ whenAnnexed $ start from i)
ps
@ -84,11 +80,12 @@ getIncremental = do
morei <- Annex.getFlag (optionName moreIncrementalOption)
case (i, starti, morei) of
(False, False, False) -> return NonIncremental
(False, True, _) -> startIncremental
(False, True, False) -> startIncremental
(False ,False, True) -> ContIncremental <$> getStartTime
(True, _, _) ->
(True, False, False) ->
maybe startIncremental (return . ContIncremental . Just)
=<< getStartTime
_ -> error "Specify only one of --incremental, --more, or --incremental-schedule"
where
startIncremental = do
recordStartTime
@ -149,14 +146,10 @@ performRemote key file backend numcopies remote =
, checkKeyNumCopies key file numcopies
]
withtmp a = do
#ifndef mingw32_HOST_OS
v <- liftIO getProcessID
#else
v <- liftIO getCurrentProcessId
#endif
pid <- liftIO getPID
t <- fromRepo gitAnnexTmpDir
createAnnexDirectory t
let tmp = t </> "fsck" ++ show v ++ "." ++ keyFile key
let tmp = t </> "fsck" ++ show pid ++ "." ++ keyFile key
let cleanup = liftIO $ catchIO (removeFile tmp) (const noop)
cleanup
cleanup `after` a tmp
@ -170,18 +163,19 @@ performRemote key file backend numcopies remote =
)
dummymeter _ = noop
startKey :: Incremental -> Key -> CommandStart
startKey inc key = case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of
Nothing -> stop
Just backend -> runFsck inc (key2file key) key $ performAll key backend
startKey :: Incremental -> Key -> NumCopies -> CommandStart
startKey inc key numcopies =
case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of
Nothing -> stop
Just backend -> runFsck inc (key2file key) key $
performKey key backend numcopies
{- Note that numcopies cannot be checked in --all mode, since we do not
- have associated filenames to look up in the .gitattributes file. -}
performAll :: Key -> Backend -> Annex Bool
performAll key backend = check
performKey :: Key -> Backend -> NumCopies -> Annex Bool
performKey key backend numcopies = check
[ verifyLocationLog key (key2file key)
, checkKeySize key
, checkBackend backend key Nothing
, checkKeyNumCopies key (key2file key) numcopies
]
check :: [Annex Bool] -> Annex Bool
@ -365,7 +359,7 @@ checkBackendOr' bad backend key file postcheck =
, return True
)
checkKeyNumCopies :: Key -> FilePath -> NumCopies -> Annex Bool
checkKeyNumCopies :: Key -> String -> NumCopies -> Annex Bool
checkKeyNumCopies key file numcopies = do
(untrustedlocations, safelocations) <- trustPartition UnTrusted =<< Remote.keyLocations key
let present = NumCopies (length safelocations)
@ -415,7 +409,7 @@ badContentRemote remote key = do
++ Remote.name remote
data Incremental = StartIncremental | ContIncremental (Maybe EpochTime) | NonIncremental
deriving (Eq)
deriving (Eq, Show)
runFsck :: Incremental -> FilePath -> Key -> Annex Bool -> CommandStart
runFsck inc file key a = ifM (needFsck inc key)
@ -471,7 +465,9 @@ getFsckTime key = do
-
- To guard against time stamp damange (for example, if an annex directory
- is copied without -a), the fsckstate file contains a time that should
- be identical to its modification time. -}
- be identical to its modification time.
- (This is not possible to do on Windows.)
-}
recordStartTime :: Annex ()
recordStartTime = do
f <- fromRepo gitAnnexFsckState
@ -479,8 +475,12 @@ recordStartTime = do
liftIO $ do
nukeFile f
withFile f WriteMode $ \h -> do
#ifndef mingw32_HOST_OS
t <- modificationTime <$> getFileStatus f
hPutStr h $ showTime $ realToFrac t
#else
noop
#endif
where
showTime :: POSIXTime -> String
showTime = show
@ -494,10 +494,14 @@ getStartTime = do
f <- fromRepo gitAnnexFsckState
liftIO $ catchDefaultIO Nothing $ do
timestamp <- modificationTime <$> getFileStatus f
#ifndef mingw32_HOST_OS
t <- readishTime <$> readFile f
return $ if Just (realToFrac timestamp) == t
then Just timestamp
else Nothing
#else
return $ Just timestamp
#endif
where
readishTime :: String -> Maybe POSIXTime
readishTime s = utcTimeToPOSIXSeconds <$>

7
Command/FuzzTest.hs
View file

@ -146,13 +146,6 @@ genFuzzFile = do
genFuzzDir :: IO FuzzDir
genFuzzDir = mkFuzzDir <$> (getStdRandom (randomR (1,16)) :: IO Int)
localFile :: FilePath -> Bool
localFile f
| isAbsolute f = False
| ".." `isInfixOf` f = False
| ".git" `isPrefixOf` f = False
| otherwise = True
data TimeStampedFuzzAction
= Started UTCTime FuzzAction
| Finished UTCTime Bool

2
Command/InitRemote.hs
View file

@ -44,7 +44,7 @@ start (name:ws) = ifM (isJust <$> findExisting name)
perform :: RemoteType -> String -> R.RemoteConfig -> CommandPerform
perform t name c = do
(c', u) <- R.setup t Nothing c
(c', u) <- R.setup t Nothing Nothing c
next $ cleanup u name c'
cleanup :: UUID -> String -> R.RemoteConfig -> CommandCleanup

2
Command/Log.hs
View file

@ -140,7 +140,7 @@ getLog key os = do
[ Params "log -z --pretty=format:%ct --raw --abbrev=40"
, Param "--remove-empty"
] ++ os ++
[ Param $ show Annex.Branch.fullname
[ Param $ Git.fromRef Annex.Branch.fullname
, Param "--"
, Param logfile
]

68
Command/MetaData.hs Normal file
View file

@ -0,0 +1,68 @@
{- git-annex command
-
- Copyright 2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Command.MetaData where
import Common.Annex
import qualified Annex
import Command
import Logs.MetaData
import Types.MetaData
import qualified Data.Set as S
import Data.Time.Clock.POSIX
def :: [Command]
def = [withOptions [setOption, tagOption, untagOption] $
command "metadata" paramPaths seek
SectionMetaData "sets metadata of a file"]
storeModMeta :: ModMeta -> Annex ()
storeModMeta modmeta = Annex.changeState $
\s -> s { Annex.modmeta = modmeta:Annex.modmeta s }
setOption :: Option
setOption = Option ['s'] ["set"] (ReqArg mkmod "FIELD[+-]=VALUE") "set metadata"
where
mkmod = either error storeModMeta . parseModMeta
tagOption :: Option
tagOption = Option ['t'] ["tag"] (ReqArg mkmod "TAG") "set a tag"
where
mkmod = storeModMeta . AddMeta tagMetaField . toMetaValue
untagOption :: Option
untagOption = Option ['u'] ["untag"] (ReqArg mkmod "TAG") "remove a tag"
where
mkmod = storeModMeta . AddMeta tagMetaField . mkMetaValue (CurrentlySet False)
seek :: CommandSeek
seek ps = do
modmeta <- Annex.getState Annex.modmeta
now <- liftIO getPOSIXTime
withFilesInGit (whenAnnexed $ start now modmeta) ps
start :: POSIXTime -> [ModMeta] -> FilePath -> (Key, Backend) -> CommandStart
start now ms file (k, _) = do
showStart "metadata" file
next $ perform now ms k
perform :: POSIXTime -> [ModMeta] -> Key -> CommandPerform
perform _ [] k = next $ cleanup k
perform now ms k = do
oldm <- getCurrentMetaData k
let m = foldl' unionMetaData newMetaData $ map (modMeta oldm) ms
addMetaData' k m now
next $ cleanup k
cleanup :: Key -> CommandCleanup
cleanup k = do
m <- getCurrentMetaData k
showLongNote $ unlines $ concatMap showmeta $ fromMetaData $ currentMetaData m
return True
where
showmeta (f, vs) = map (\v -> fromMetaField f ++ "=" ++ fromMetaValue v) $ S.toList vs

47
Command/PreCommit.hs
View file

@ -1,6 +1,6 @@
{- git-annex command
-
- Copyright 2010, 2013 Joey Hess <joey@kitenet.net>
- Copyright 2010-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@ -13,6 +13,13 @@ import Config
import qualified Command.Add
import qualified Command.Fix
import Annex.Direct
import Annex.View
import Logs.View
import Logs.MetaData
import Types.View
import Types.MetaData
import qualified Data.Set as S
def :: [Command]
def = [command "pre-commit" paramPaths seek SectionPlumbing
@ -27,13 +34,45 @@ seek ps = ifM isDirect
withFilesToBeCommitted (whenAnnexed Command.Fix.start) ps
-- inject unlocked files into the annex
withFilesUnlockedToBeCommitted startIndirect ps
-- committing changes to a view updates metadata
mv <- currentView
case mv of
Nothing -> noop
Just v -> withViewChanges
(addViewMetaData v)
(removeViewMetaData v)
)
startIndirect :: FilePath -> CommandStart
startIndirect file = next $ do
unlessM (callCommandAction $ Command.Add.start file) $
error $ "failed to add " ++ file ++ "; canceling commit"
startIndirect f = next $ do
unlessM (callCommandAction $ Command.Add.start f) $
error $ "failed to add " ++ f ++ "; canceling commit"
next $ return True
startDirect :: [String] -> CommandStart
startDirect _ = next $ next $ preCommitDirect
addViewMetaData :: View -> FileView -> Key -> CommandStart
addViewMetaData v f k = do
showStart "metadata" f
next $ next $ changeMetaData k $ fromView v f
removeViewMetaData :: View -> FileView -> Key -> CommandStart
removeViewMetaData v f k = do
showStart "metadata" f
next $ next $ changeMetaData k $ unsetMetaData $ fromView v f
changeMetaData :: Key -> MetaData -> CommandCleanup
changeMetaData k metadata = do
showMetaDataChange metadata
addMetaData k metadata
return True
showMetaDataChange :: MetaData -> Annex ()
showMetaDataChange = showLongNote . unlines . concatMap showmeta . fromMetaData
where
showmeta (f, vs) = map (showmetavalue f) $ S.toList vs
showmetavalue f v = fromMetaField f ++ showset v ++ "=" ++ fromMetaValue v
showset v
| isSet v = "+"
| otherwise = "-"

2
Command/Repair.hs
View file

@ -81,4 +81,4 @@ trackingOrSyncBranch :: Ref -> Bool
trackingOrSyncBranch b = Git.Repair.isTrackingBranch b || isAnnexSyncBranch b
isAnnexSyncBranch :: Ref -> Bool
isAnnexSyncBranch b = "refs/synced/" `isPrefixOf` show b
isAnnexSyncBranch b = "refs/synced/" `isPrefixOf` fromRef b

19
Command/Semitrust.hs
View file

@ -7,26 +7,13 @@
module Command.Semitrust where
import Common.Annex
import Command
import qualified Remote
import Logs.Trust
import Types.TrustLevel
import Command.Trust (trustCommand)
def :: [Command]
def = [command "semitrust" (paramRepeating paramRemote) seek
SectionSetup "return repository to default trust level"]
seek :: CommandSeek
seek = withWords start
start :: [String] -> CommandStart
start ws = do
let name = unwords ws
showStart "semitrust" name
u <- Remote.nameToUUID name
next $ perform u
perform :: UUID -> CommandPerform
perform uuid = do
trustSet uuid SemiTrusted
next $ return True
seek = trustCommand "semitrust" SemiTrusted

22
Command/Sync.hs
View file

@ -86,7 +86,7 @@ seek rs = do
, [ mergeAnnex ]
]
whenM (Annex.getFlag $ optionName contentOption) $
whenM (seekSyncContent dataremotes) $ do
whenM (seekSyncContent dataremotes) $
-- Transferring content can take a while,
-- and other changes can be pushed to the git-annex
-- branch on the remotes in the meantime, so pull
@ -192,12 +192,12 @@ pushLocal (Just branch) = do
updateBranch :: Git.Ref -> Git.Repo -> IO ()
updateBranch syncbranch g =
unlessM go $ error $ "failed to update " ++ show syncbranch
unlessM go $ error $ "failed to update " ++ Git.fromRef syncbranch
where
go = Git.Command.runBool
[ Param "branch"
, Param "-f"
, Param $ show $ Git.Ref.base syncbranch
, Param $ Git.fromRef $ Git.Ref.base syncbranch
] g
pullRemote :: Remote -> Maybe Git.Ref -> CommandStart
@ -224,7 +224,7 @@ mergeRemote remote b = case b of
Just _ -> and <$> (mapM merge =<< tomerge (branchlist b))
where
merge = mergeFrom . remoteBranch remote
tomerge branches = filterM (changed remote) branches
tomerge = filterM (changed remote)
branchlist Nothing = []
branchlist (Just branch) = [branch, syncBranch branch]
@ -283,15 +283,15 @@ pushBranch remote branch g = tryIO (directpush g) `after` syncpush g
, refspec branch
]
directpush = Git.Command.runQuiet $ pushparams
[show $ Git.Ref.base $ fromDirectBranch branch]
[Git.fromRef $ Git.Ref.base $ fromDirectBranch branch]
pushparams branches =
[ Param "push"
, Param $ Remote.name remote
] ++ map Param branches
refspec b = concat
[ show $ Git.Ref.base b
[ Git.fromRef $ Git.Ref.base b
, ":"
, show $ Git.Ref.base $ syncBranch b
, Git.fromRef $ Git.Ref.base $ syncBranch b
]
commitAnnex :: CommandStart
@ -452,7 +452,7 @@ resolveMerge' u
Just target -> do
unlessM (coreSymlinks <$> Annex.getGitConfig) $
addAnnexLink target f
maybe noop (flip toDirect f)
maybe noop (`toDirect` f)
(fileKey (takeFileName target))
{- git-merge moves conflicting files away to files
@ -535,7 +535,7 @@ newer remote b = do
-}
seekSyncContent :: [Remote] -> Annex Bool
seekSyncContent rs = do
mvar <- liftIO $ newEmptyMVar
mvar <- liftIO newEmptyMVar
mapM_ (go mvar) =<< seekHelper LsFiles.inRepo []
liftIO $ not <$> isEmptyMVar mvar
where
@ -552,7 +552,7 @@ syncFile rs f (k, _) = do
putrs <- catMaybes . snd . unzip <$> (sequence =<< handleput lack)
u <- getUUID
let locs' = concat [if got then [u] else [], putrs, locs]
let locs' = concat [[u | got], putrs, locs]
-- Using callCommandAction rather than commandAction for drops,
-- because a failure to drop does not mean the sync failed.
@ -576,7 +576,7 @@ syncFile rs f (k, _) = do
| Remote.readonly r || remoteAnnexReadOnly (Types.Remote.gitconfig r) = return False
| otherwise = wantSend True (Just k) (Just f) (Remote.uuid r)
handleput lack = ifM (inAnnex k)
( map put <$> (filterM wantput lack)
( map put <$> filterM wantput lack
, return []
)
put dest = do

35
Command/Trust.hs
View file

@ -1,6 +1,6 @@
{- git-annex command
-
- Copyright 2010 Joey Hess <joey@kitenet.net>
- Copyright 2010, 2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@ -10,23 +10,32 @@ module Command.Trust where
import Common.Annex
import Command
import qualified Remote
import Types.TrustLevel
import Logs.Trust
import Logs.Group
import qualified Data.Set as S
def :: [Command]
def = [command "trust" (paramRepeating paramRemote) seek
SectionSetup "trust a repository"]
seek :: CommandSeek
seek = withWords start
seek = trustCommand "trust" Trusted
start :: [String] -> CommandStart
start ws = do
let name = unwords ws
showStart "trust" name
u <- Remote.nameToUUID name
next $ perform u
perform :: UUID -> CommandPerform
perform uuid = do
trustSet uuid Trusted
next $ return True
trustCommand :: String -> TrustLevel -> CommandSeek
trustCommand cmd level = withWords start
where
start ws = do
let name = unwords ws
showStart cmd name
u <- Remote.nameToUUID name
next $ perform u
perform uuid = do
trustSet uuid level
when (level == DeadTrusted) $
groupSet uuid S.empty
l <- lookupTrust uuid
when (l /= level) $
warning $ "This remote's trust level is locally overridden to " ++ showTrustLevel l ++ " via git config."
next $ return True

4
Command/Uninit.hs
View file

@ -24,7 +24,7 @@ check :: Annex ()
check = do
b <- current_branch
when (b == Annex.Branch.name) $ error $
"cannot uninit when the " ++ show b ++ " branch is checked out"
"cannot uninit when the " ++ Git.fromRef b ++ " branch is checked out"
top <- fromRepo Git.repoPath
cwd <- liftIO getCurrentDirectory
whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath cwd)) $
@ -77,7 +77,7 @@ finish = do
-- avoid normal shutdown
saveState False
inRepo $ Git.Command.run
[Param "branch", Param "-D", Param $ show Annex.Branch.name]
[Param "branch", Param "-D", Param $ Git.fromRef Annex.Branch.name]
liftIO exitSuccess
{- Keys that were moved out of the annex have a hard link still in the

19
Command/Untrust.hs
View file

@ -7,26 +7,13 @@
module Command.Untrust where
import Common.Annex
import Command
import qualified Remote
import Logs.Trust
import Types.TrustLevel
import Command.Trust (trustCommand)
def :: [Command]
def = [command "untrust" (paramRepeating paramRemote) seek
SectionSetup "do not trust a repository"]
seek :: CommandSeek
seek = withWords start
start :: [String] -> CommandStart
start ws = do
let name = unwords ws
showStart "untrust" name
u <- Remote.nameToUUID name
next $ perform u
perform :: UUID -> CommandPerform
perform uuid = do
trustSet uuid UnTrusted
next $ return True
seek = trustCommand "untrust" UnTrusted

2
Command/Unused.hs
View file

@ -266,7 +266,7 @@ withKeysReferencedInGit a = do
map (separate (== ' ')) .
lines
nubRefs = map (Git.Ref . snd) . nubBy (\(x, _) (y, _) -> x == y)
ourbranchend = '/' : show Annex.Branch.name
ourbranchend = '/' : Git.fromRef Annex.Branch.name
ourbranches (_, b) = not (ourbranchend `isSuffixOf` b)
&& not ("refs/synced/" `isPrefixOf` b)
addHead headRef refs = case headRef of

36
Command/VAdd.hs Normal file
View file

@ -0,0 +1,36 @@
{- 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 Command.View (paramView, parseViewParam, checkoutViewBranch)
def :: [Command]
def = [notBareRepo $ notDirect $
command "vadd" paramView seek SectionMetaData "add subdirs to current view"]
seek :: CommandSeek
seek = withWords start
start :: [String] -> CommandStart
start params = do
showStart "vadd" ""
withCurrentView $ \view -> do
let (view', change) = refineView view $
map parseViewParam $ reverse params
case change of
Unchanged -> do
showNote "unchanged"
next $ next $ return True
Narrowing -> next $ next $ do
if visibleViewSize view' == visibleViewSize view
then error "That would not add an additional level of directory structure to the view. To filter the view, use vfilter instead of vadd."
else checkoutViewBranch view' narrowView
Widening -> error "Widening view to match more files is not currently supported."

41
Command/VCycle.hs Normal file
View file

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

30
Command/VFilter.hs Normal file
View file

@ -0,0 +1,30 @@
{- git-annex command
-
- Copyright 2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Command.VFilter where
import Common.Annex
import Command
import Annex.View
import Command.View (paramView, parseViewParam, checkoutViewBranch)
def :: [Command]
def = [notBareRepo $ notDirect $
command "vfilter" paramView seek SectionMetaData "filter current view"]
seek :: CommandSeek
seek = withWords start
start :: [String] -> CommandStart
start params = do
showStart "vfilter" ""
withCurrentView $ \view -> do
let view' = filterView view $
map parseViewParam $ reverse params
next $ next $ if visibleViewSize view' > visibleViewSize view
then error "That would add an additional level of directory structure to the view, rather than filtering it. If you want to do that, use vadd instead of vfilter."
else checkoutViewBranch view' narrowView

50
Command/VPop.hs Normal file
View file

@ -0,0 +1,50 @@
{- 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
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" (paramOptional paramNumber) seek SectionMetaData
"switch back to previous view"]
seek :: CommandSeek
seek = withWords start
start :: [String] -> CommandStart
start ps = go =<< currentView
where
go Nothing = error "Not in a view."
go (Just v) = do
showStart "vpop" (show num)
removeView v
(oldvs, vs) <- splitAt (num - 1) . filter (sameparentbranch v)
<$> recentViews
mapM_ removeView oldvs
case vs of
(oldv:_) -> next $ next $ do
showOutput
checkoutViewBranch oldv (return . branchView)
_ -> next $ next $ do
showOutput
inRepo $ Git.Command.runBool
[ Param "checkout"
, Param $ Git.fromRef $ Git.Ref.base $
viewParentBranch v
]
sameparentbranch a b = viewParentBranch a == viewParentBranch b
num = fromMaybe 1 $ readish =<< headMaybe ps

90
Command/View.hs Normal file
View file

@ -0,0 +1,90 @@
{- 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 SectionMetaData "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 $ fst $ refineView v $
map parseViewParam $ reverse params
where
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
showOutput
ok <- inRepo $ Git.Command.runBool
[ Param "checkout"
, Param (Git.fromRef $ 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
]

47
Creds.hs
View file

@ -1,29 +1,34 @@
{- Credentials storage
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
- Copyright 2012-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Creds where
module Creds (
module Types.Creds,
CredPairStorage(..),
setRemoteCredPair,
getRemoteCredPairFor,
getRemoteCredPair,
getEnvCredPair,
writeCacheCreds,
readCacheCreds,
) where
import Common.Annex
import Types.Creds
import Annex.Perms
import Utility.FileMode
import Crypto
import Types.Remote (RemoteConfig, RemoteConfigKey)
import Remote.Helper.Encryptable (remoteCipher, embedCreds)
import Utility.Env (setEnv, getEnv)
import Utility.Env (getEnv)
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map as M
import Utility.Base64
type Creds = String -- can be any data
type CredPair = (String, String) -- login, password
{- A CredPair can be stored in a file, or in the environment, or perhaps
- in a remote's configuration. -}
data CredPairStorage = CredPairStorage
@ -33,14 +38,13 @@ data CredPairStorage = CredPairStorage
}
{- Stores creds in a remote's configuration, if the remote allows
- that. Otherwise, caches them locally. -}
setRemoteCredPair :: RemoteConfig -> CredPairStorage -> Annex RemoteConfig
setRemoteCredPair c storage =
maybe (return c) (setRemoteCredPair' c storage)
- that. Otherwise, caches them locally.
- The creds are found in storage if not provided. -}
setRemoteCredPair :: RemoteConfig -> CredPairStorage -> Maybe CredPair -> Annex RemoteConfig
setRemoteCredPair c storage Nothing =
maybe (return c) (setRemoteCredPair c storage . Just)
=<< getRemoteCredPair c storage
setRemoteCredPair' :: RemoteConfig -> CredPairStorage -> CredPair -> Annex RemoteConfig
setRemoteCredPair' c storage creds
setRemoteCredPair c storage (Just creds)
| embedCreds c = case credPairRemoteKey storage of
Nothing -> localcache
Just key -> storeconfig key =<< remoteCipher c
@ -105,19 +109,6 @@ getEnvCredPair storage = liftM2 (,)
where
(uenv, penv) = credPairEnvironment storage
{- Stores a CredPair in the environment. -}
setEnvCredPair :: CredPair -> CredPairStorage -> IO ()
#ifndef mingw32_HOST_OS
setEnvCredPair (l, p) storage = do
set uenv l
set penv p
where
(uenv, penv) = credPairEnvironment storage
set var val = void $ setEnv var val True
#else
setEnvCredPair _ _ = error "setEnvCredPair TODO"
#endif
writeCacheCredPair :: CredPair -> CredPairStorage -> Annex ()
writeCacheCredPair credpair storage =
writeCacheCreds (encodeCredPair credpair) (credPairFile storage)

1
Git.hs
View file

@ -13,6 +13,7 @@
module Git (
Repo(..),
Ref(..),
fromRef,
Branch,
Sha,
Tag,

20
Git/Branch.hs
View file

@ -28,7 +28,7 @@ current r = do
case v of
Nothing -> return Nothing
Just branch ->
ifM (null <$> pipeReadStrict [Param "show-ref", Param $ show branch] r)
ifM (null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r)
( return Nothing
, return v
)
@ -36,7 +36,7 @@ current r = do
{- The current branch, which may not really exist yet. -}
currentUnsafe :: Repo -> IO (Maybe Git.Ref)
currentUnsafe r = parse . firstLine
<$> pipeReadStrict [Param "symbolic-ref", Param $ show Git.Ref.headRef] r
<$> pipeReadStrict [Param "symbolic-ref", Param $ fromRef Git.Ref.headRef] r
where
parse l
| null l = Nothing
@ -51,7 +51,7 @@ changed origbranch newbranch repo
where
diffs = pipeReadStrict
[ Param "log"
, Param (show origbranch ++ ".." ++ show newbranch)
, Param (fromRef origbranch ++ ".." ++ fromRef newbranch)
, Params "--oneline -n1"
] repo
@ -74,7 +74,7 @@ fastForward branch (first:rest) repo =
where
no_ff = return False
do_ff to = do
run [Param "update-ref", Param $ show branch, Param $ show to] repo
run [Param "update-ref", Param $ fromRef branch, Param $ fromRef to] repo
return True
findbest c [] = return $ Just c
findbest c (r:rs)
@ -104,14 +104,14 @@ commit allowempty message branch parentrefs repo = do
ifM (cancommit tree)
( do
sha <- getSha "commit-tree" $ pipeWriteRead
(map Param $ ["commit-tree", show tree] ++ ps)
(map Param $ ["commit-tree", fromRef tree] ++ ps)
(Just $ flip hPutStr message) repo
update branch sha repo
return $ Just sha
, return Nothing
)
where
ps = concatMap (\r -> ["-p", show r]) parentrefs
ps = concatMap (\r -> ["-p", fromRef r]) parentrefs
cancommit tree
| allowempty = return True
| otherwise = case parentrefs of
@ -130,8 +130,8 @@ forcePush b = "+" ++ b
update :: Branch -> Sha -> Repo -> IO ()
update branch sha = run
[ Param "update-ref"
, Param $ show branch
, Param $ show sha
, Param $ fromRef branch
, Param $ fromRef sha
]
{- Checks out a branch, creating it if necessary. -}
@ -140,7 +140,7 @@ checkout branch = run
[ Param "checkout"
, Param "-q"
, Param "-B"
, Param $ show $ Git.Ref.base branch
, Param $ fromRef $ Git.Ref.base branch
]
{- Removes a branch. -}
@ -149,5 +149,5 @@ delete branch = run
[ Param "branch"
, Param "-q"
, Param "-D"
, Param $ show $ Git.Ref.base branch
, Param $ fromRef $ Git.Ref.base branch
]

8
Git/CatFile.hs
View file

@ -50,7 +50,7 @@ catFileStop (CatFileHandle p _) = CoProcess.stop p
{- Reads a file from a specified branch. -}
catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString
catFile h branch file = catObject h $ Ref $
show branch ++ ":" ++ toInternalGitPath file
fromRef branch ++ ":" ++ toInternalGitPath file
{- Uses a running git cat-file read the content of an object.
- Objects that do not exist will have "" returned. -}
@ -60,7 +60,7 @@ catObject h object = maybe L.empty fst3 <$> catObjectDetails h object
catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType))
catObjectDetails (CatFileHandle hdl _) object = CoProcess.query hdl send receive
where
query = show object
query = fromRef object
send to = hPutStrLn to query
receive from = do
header <- hGetLine from
@ -72,8 +72,8 @@ catObjectDetails (CatFileHandle hdl _) object = CoProcess.query hdl send receive
_ -> dne
| otherwise -> dne
_
| header == show object ++ " missing" -> dne
| otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)
| header == fromRef object ++ " missing" -> dne
| otherwise -> error $ "unknown response from git cat-file " ++ show (header, query)
readcontent objtype bytes from sha = do
content <- S.hGet from bytes
eatchar '\n' from

12
Git/Command.hs
View file

@ -25,18 +25,10 @@ gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
gitCommandLine params r@(Repo { location = l@(Local _ _ ) }) =
setdir : settree ++ gitGlobalOpts r ++ params
where
setdir = Param $ "--git-dir=" ++ gitpath (gitdir l)
setdir = Param $ "--git-dir=" ++ gitdir l
settree = case worktree l of
Nothing -> []
Just t -> [Param $ "--work-tree=" ++ gitpath t]
#ifdef mingw32_HOST_OS
-- despite running on windows, msysgit wants a unix-formatted path
gitpath s
| isAbsolute s = "/" ++ dropDrive (toInternalGitPath s)
| otherwise = s
#else
gitpath = id
#endif
Just t -> [Param $ "--work-tree=" ++ t]
gitCommandLine _ repo = assertLocal repo $ error "internal"
{- Runs git in the specified repo. -}

3
Git/Construct.hs
View file

@ -33,6 +33,7 @@ import Common
import Git.Types
import Git
import Git.Remote
import Git.FilePath
import qualified Git.Url as Url
import Utility.UserInfo
@ -57,7 +58,7 @@ fromPath dir = fromAbsPath =<< absPath dir
- specified. -}
fromAbsPath :: FilePath -> IO Repo
fromAbsPath dir
| isAbsolute dir = ifM (doesDirectoryExist dir') ( ret dir' , hunt )
| absoluteGitPath dir = ifM (doesDirectoryExist dir') ( ret dir' , hunt )
| otherwise =
error $ "internal error, " ++ dir ++ " is not absolute"
where

6
Git/DiffTree.hs
View file

@ -36,12 +36,12 @@ data DiffTreeItem = DiffTreeItem
{- Diffs two tree Refs. -}
diffTree :: Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool)
diffTree src dst = getdiff (Param "diff-tree")
[Param (show src), Param (show dst)]
[Param (fromRef src), Param (fromRef dst)]
{- Diffs two tree Refs, recursing into sub-trees -}
diffTreeRecursive :: Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool)
diffTreeRecursive src dst = getdiff (Param "diff-tree")
[Param "-r", Param (show src), Param (show dst)]
[Param "-r", Param (fromRef src), Param (fromRef dst)]
{- Diffs between a tree and the index. Does nothing if there is not yet a
- commit in the repository. -}
@ -61,7 +61,7 @@ diffIndex' :: Ref -> [CommandParam] -> Repo -> IO ([DiffTreeItem], IO Bool)
diffIndex' ref params repo =
ifM (Git.Ref.headExists repo)
( getdiff (Param "diff-index")
( params ++ [Param $ show ref] )
( params ++ [Param $ fromRef ref] )
repo
, return ([], return True)
)

21
Git/FilePath.hs
View file

@ -20,12 +20,15 @@ module Git.FilePath (
asTopFilePath,
InternalGitPath,
toInternalGitPath,
fromInternalGitPath
fromInternalGitPath,
absoluteGitPath
) where
import Common
import Git
import qualified System.FilePath.Posix
{- A FilePath, relative to the top of the git repository. -}
newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }
deriving (Show)
@ -48,8 +51,7 @@ asTopFilePath file = TopFilePath file
- it internally.
-
- On Windows, git uses '/' to separate paths stored in the repository,
- despite Windows using '\'. Also, git on windows dislikes paths starting
- with "./" or ".\".
- despite Windows using '\'.
-
-}
type InternalGitPath = String
@ -58,11 +60,7 @@ toInternalGitPath :: FilePath -> InternalGitPath
#ifndef mingw32_HOST_OS
toInternalGitPath = id
#else
toInternalGitPath p =
let p' = replace "\\" "/" p
in if "./" `isPrefixOf` p'
then dropWhile (== '/') (drop 1 p')
else p'
toInternalGitPath = replace "\\" "/"
#endif
fromInternalGitPath :: InternalGitPath -> FilePath
@ -71,3 +69,10 @@ fromInternalGitPath = id
#else
fromInternalGitPath = replace "/" "\\"
#endif
{- isAbsolute on Windows does not think "/foo" or "\foo" is absolute,
- so try posix paths.
-}
absoluteGitPath :: FilePath -> Bool
absoluteGitPath p = isAbsolute p ||
System.FilePath.Posix.isAbsolute (toInternalGitPath p)

2
Git/Fsck.hs
View file

@ -74,7 +74,7 @@ isMissing s r = either (const True) (const False) <$> tryIO dump
where
dump = runQuiet
[ Param "show"
, Param (show s)
, Param (fromRef s)
] r
findShas :: Bool -> String -> [Sha]

16
Git/HashObject.hs
View file

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

4
Git/LsTree.hs
View file

@ -38,13 +38,13 @@ lsTree t repo = map parseLsTree
<$> pipeNullSplitZombie (lsTreeParams t) repo
lsTreeParams :: Ref -> [CommandParam]
lsTreeParams t = [ Params "ls-tree --full-tree -z -r --", File $ show t ]
lsTreeParams t = [ Params "ls-tree --full-tree -z -r --", File $ fromRef t ]
{- Lists specified files in a tree. -}
lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem]
lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo
where
ps = [Params "ls-tree --full-tree -z --", File $ show t] ++ map File fs
ps = [Params "ls-tree --full-tree -z --", File $ fromRef t] ++ map File fs
{- Parses a line of ls-tree output.
- (The --long format is not currently supported.) -}

4
Git/Merge.hs
View file

@ -15,7 +15,7 @@ import Git.BuildVersion
{- Avoids recent git's interactive merge. -}
mergeNonInteractive :: Ref -> Repo -> IO Bool
mergeNonInteractive branch
| older "1.7.7.6" = merge [Param $ show branch]
| otherwise = merge [Param "--no-edit", Param $ show branch]
| older "1.7.7.6" = merge [Param $ fromRef branch]
| otherwise = merge [Param "--no-edit", Param $ fromRef branch]
where
merge ps = runBool $ Param "merge" : ps

2
Git/Objects.hs
View file

@ -32,4 +32,4 @@ listLooseObjectShas r = catchDefaultIO [] $
looseObjectFile :: Repo -> Sha -> FilePath
looseObjectFile r sha = objectsDir r </> prefix </> rest
where
(prefix, rest) = splitAt 2 (show sha)
(prefix, rest) = splitAt 2 (fromRef sha)

20
Git/Ref.hs
View file

@ -20,12 +20,12 @@ headRef = Ref "HEAD"
{- Converts a fully qualified git ref into a user-visible string. -}
describe :: Ref -> String
describe = show . base
describe = fromRef . base
{- Often git refs are fully qualified (eg: refs/heads/master).
- Converts such a fully qualified ref into a base ref (eg: master). -}
base :: Ref -> Ref
base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show
base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef
where
remove prefix s
| prefix `isPrefixOf` s = drop (length prefix) s
@ -35,13 +35,13 @@ base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show
- it under the directory. -}
under :: String -> Ref -> Ref
under dir r = Ref $ dir ++ "/" ++
(reverse $ takeWhile (/= '/') $ reverse $ show r)
(reverse $ takeWhile (/= '/') $ reverse $ fromRef r)
{- Given a directory such as "refs/remotes/origin", and a ref such as
- refs/heads/master, yields a version of that ref under the directory,
- such as refs/remotes/origin/master. -}
underBase :: String -> Ref -> Ref
underBase dir r = Ref $ dir ++ "/" ++ show (base r)
underBase dir r = Ref $ dir ++ "/" ++ fromRef (base r)
{- A Ref that can be used to refer to a file in the repository, as staged
- in the index.
@ -64,12 +64,12 @@ fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr)
{- Checks if a ref exists. -}
exists :: Ref -> Repo -> IO Bool
exists ref = runBool
[Param "show-ref", Param "--verify", Param "-q", Param $ show ref]
[Param "show-ref", Param "--verify", Param "-q", Param $ fromRef ref]
{- The file used to record a ref. (Git also stores some refs in a
- packed-refs file.) -}
file :: Ref -> Repo -> FilePath
file ref repo = localGitDir repo </> show ref
file ref repo = localGitDir repo </> fromRef ref
{- Checks if HEAD exists. It generally will, except for in a repository
- that was just created. -}
@ -84,17 +84,17 @@ sha branch repo = process <$> showref repo
where
showref = pipeReadStrict [Param "show-ref",
Param "--hash", -- get the hash
Param $ show branch]
Param $ fromRef branch]
process [] = Nothing
process s = Just $ Ref $ firstLine s
{- List of (shas, branches) matching a given ref or refs. -}
matching :: [Ref] -> Repo -> IO [(Sha, Branch)]
matching refs repo = matching' (map show refs) repo
matching refs repo = matching' (map fromRef refs) repo
{- Includes HEAD in the output, if asked for it. -}
matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)]
matchingWithHEAD refs repo = matching' ("--head" : map show refs) repo
matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo
{- List of (shas, branches) matching a given ref or refs. -}
matching' :: [String] -> Repo -> IO [(Sha, Branch)]
@ -114,7 +114,7 @@ matchingUniq refs repo = nubBy uniqref <$> matching refs repo
{- Gets the sha of the tree a ref uses. -}
tree :: Ref -> Repo -> IO (Maybe Sha)
tree ref = extractSha <$$> pipeReadStrict
[ Param "rev-parse", Param (show ref ++ ":") ]
[ Param "rev-parse", Param (fromRef ref ++ ":") ]
{- Checks if a String is a legal git ref name.
-

2
Git/RefLog.hs
View file

@ -18,5 +18,5 @@ get b = mapMaybe extractSha . lines <$$> pipeReadStrict
[ Param "log"
, Param "-g"
, Param "--format=%H"
, Param (show b)
, Param (fromRef b)
]

24
Git/Repair.hs
View file

@ -168,7 +168,7 @@ resetLocalBranches :: MissingObjects -> GoodCommits -> Repo -> IO ([Branch], [Br
resetLocalBranches missing goodcommits r =
go [] [] goodcommits =<< filter islocalbranch <$> getAllRefs r
where
islocalbranch b = "refs/heads/" `isPrefixOf` show b
islocalbranch b = "refs/heads/" `isPrefixOf` fromRef b
go changed deleted gcs [] = return (changed, deleted, gcs)
go changed deleted gcs (b:bs) = do
(mc, gcs') <- findUncorruptedCommit missing gcs b r
@ -185,12 +185,12 @@ resetLocalBranches missing goodcommits r =
nukeBranchRef b r
void $ runBool
[ Param "branch"
, Param (show $ Ref.base b)
, Param (show c)
, Param (fromRef $ Ref.base b)
, Param (fromRef c)
] r
isTrackingBranch :: Ref -> Bool
isTrackingBranch b = "refs/remotes/" `isPrefixOf` show b
isTrackingBranch b = "refs/remotes/" `isPrefixOf` fromRef b
{- To deal with missing objects that cannot be recovered, removes
- any branches (filtered by a predicate) that reference them
@ -231,10 +231,10 @@ explodePackedRefsFile r = do
nukeFile f
where
makeref (sha, ref) = do
let dest = localGitDir r </> show ref
let dest = localGitDir r </> fromRef ref
createDirectoryIfMissing True (parentDir dest)
unlessM (doesFileExist dest) $
writeFile dest (show sha)
writeFile dest (fromRef sha)
packedRefsFile :: Repo -> FilePath
packedRefsFile r = localGitDir r </> "packed-refs"
@ -249,7 +249,7 @@ parsePacked l = case words l of
{- git-branch -d cannot be used to remove a branch that is directly
- pointing to a corrupt commit. -}
nukeBranchRef :: Branch -> Repo -> IO ()
nukeBranchRef b r = nukeFile $ localGitDir r </> show b
nukeBranchRef b r = nukeFile $ localGitDir r </> fromRef b
{- Finds the most recent commit to a branch that does not need any
- of the missing objects. If the input branch is good as-is, returns it.
@ -268,7 +268,7 @@ findUncorruptedCommit missing goodcommits branch r = do
[ Param "log"
, Param "-z"
, Param "--format=%H"
, Param (show branch)
, Param (fromRef branch)
] r
let branchshas = catMaybes $ map extractSha ls
reflogshas <- RefLog.get branch r
@ -297,7 +297,7 @@ verifyCommit missing goodcommits commit r
[ Param "log"
, Param "-z"
, Param "--format=%H %T"
, Param (show commit)
, Param (fromRef commit)
] r
let committrees = map parse ls
if any isNothing committrees || null committrees
@ -501,9 +501,9 @@ runRepair' removablebranch fsckresult forced referencerepo g = do
, "remote tracking branches that referred to missing objects."
]
(resetbranches, deletedbranches, _) <- resetLocalBranches stillmissing goodcommits g
displayList (map show resetbranches)
displayList (map fromRef resetbranches)
"Reset these local branches to old versions before the missing objects were committed:"
displayList (map show deletedbranches)
displayList (map fromRef deletedbranches)
"Deleted these local branches, which could not be recovered due to missing objects:"
deindexedfiles <- rewriteIndex g
displayList deindexedfiles
@ -519,7 +519,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do
Just curr -> when (any (== curr) modifiedbranches) $ do
putStrLn $ unwords
[ "You currently have"
, show curr
, fromRef curr
, "checked out. You may have staged changes in the index that can be committed to recover the lost state of this branch!"
]
putStrLn "Successfully recovered repository!"

4
Git/Sha.hs
View file

@ -37,3 +37,7 @@ shaSize = 40
nullSha :: Ref
nullSha = Ref $ replicate shaSize '0'
{- Git's magic empty tree. -}
emptyTree :: Ref
emptyTree = Ref "4b825dc642cb6eb9a060e54bf8d69288fbee4904"

6
Git/Types.hs
View file

@ -47,10 +47,10 @@ type RemoteName = String
{- A git ref. Can be a sha1, or a branch or tag name. -}
newtype Ref = Ref String
deriving (Eq, Ord)
deriving (Eq, Ord, Read, Show)
instance Show Ref where
show (Ref v) = v
fromRef :: Ref -> String
fromRef (Ref s) = s
{- Aliases for Ref. -}
type Branch = Ref

37
Git/UpdateIndex.hs
View file

@ -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. -}
@ -60,7 +79,7 @@ lsTree (Ref x) repo streamer = do
- a given file with a given sha. -}
updateIndexLine :: Sha -> BlobType -> TopFilePath -> String
updateIndexLine sha filetype file =
show filetype ++ " blob " ++ show sha ++ "\t" ++ indexPath file
show filetype ++ " blob " ++ fromRef sha ++ "\t" ++ indexPath file
stageFile :: Sha -> BlobType -> FilePath -> Repo -> IO Streamer
stageFile sha filetype file repo = do
@ -71,7 +90,7 @@ stageFile sha filetype file repo = do
unstageFile :: FilePath -> Repo -> IO Streamer
unstageFile file repo = do
p <- toTopFilePath file repo
return $ pureStreamer $ "0 " ++ show nullSha ++ "\t" ++ indexPath p
return $ pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p
{- A streamer that adds a symlink to the index. -}
stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer

29
Limit.hs
View file

@ -9,11 +9,6 @@
module Limit where
import Data.Time.Clock.POSIX
import qualified Data.Set as S
import qualified Data.Map as M
import System.Path.WildMatch
import Common.Annex
import qualified Annex
import qualified Utility.Matcher
@ -28,6 +23,8 @@ import Types.Key
import Types.Group
import Types.FileMatcher
import Types.Limit
import Types.MetaData
import Logs.MetaData
import Logs.Group
import Logs.Unused
import Logs.Location
@ -35,14 +32,14 @@ import Git.Types (RefDate(..))
import Utility.HumanTime
import Utility.DataUnits
import Data.Time.Clock.POSIX
import qualified Data.Set as S
import qualified Data.Map as M
import System.Path.WildMatch
#ifdef WITH_TDFA
import Text.Regex.TDFA
import Text.Regex.TDFA.String
#else
#ifndef mingw32_HOST_OS
import System.Path.WildMatch
import Types.FileMatcher
#endif
#endif
{- Checks if there are user-specified limits. -}
@ -156,7 +153,7 @@ limitPresent u _ = Right $ const $ checkKey $ \key -> do
limitInDir :: FilePath -> MkLimit
limitInDir dir = const $ Right $ const go
where
go (MatchingFile fi) = return $ any (== dir) $ splitPath $ takeDirectory $ matchFile fi
go (MatchingFile fi) = return $ elem dir $ splitPath $ takeDirectory $ matchFile fi
go (MatchingKey _) = return False
{- Adds a limit to skip files not believed to have the specified number
@ -267,6 +264,16 @@ limitSize vs s = case readSize dataUnits s of
<$> getFileStatus (relFile fi)
return $ filesize `vs` Just sz
addMetaData :: String -> Annex ()
addMetaData = addLimit . limitMetaData
limitMetaData :: MkLimit
limitMetaData s = case parseMetaData s of
Left e -> Left e
Right (f, v) -> Right $ const $ checkKey (check f v)
where
check f v k = S.member v . metaDataValues f <$> getCurrentMetaData k
addTimeLimit :: String -> Annex ()
addTimeLimit s = do
let seconds = maybe (error "bad time-limit") durationToPOSIXTime $

12
Locations.hs
View file

@ -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"
@ -330,7 +340,7 @@ preSanitizeKeyName = concatMap escape
-- other characters. By itself, it is escaped to
-- doubled form.
| c == ',' = ",,"
| otherwise = ',' : show(ord(c))
| otherwise = ',' : show (ord c)
{- Converts a key into a filename fragment without any directory.
-

25
Logs.hs
View file

@ -1,6 +1,6 @@
{- git-annex log file names
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
- Copyright 2013-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@ -15,7 +15,7 @@ data LogVariety
= UUIDBasedLog
| NewUUIDBasedLog
| PresenceLog Key
| SingleValueLog
| OtherLog
deriving (Show)
{- Converts a path from the git-annex branch into one of the varieties
@ -24,7 +24,7 @@ getLogVariety :: FilePath -> Maybe LogVariety
getLogVariety f
| f `elem` topLevelUUIDBasedLogs = Just UUIDBasedLog
| isRemoteStateLog f = Just NewUUIDBasedLog
| f == numcopiesLog = Just SingleValueLog
| isMetaDataLog f || f == numcopiesLog = Just OtherLog
| otherwise = PresenceLog <$> firstJust (presenceLogs f)
{- All the uuid-based logs stored in the top of the git-annex branch. -}
@ -119,14 +119,25 @@ remoteStateLogExt = ".log.rmt"
isRemoteStateLog :: FilePath -> Bool
isRemoteStateLog path = remoteStateLogExt `isSuffixOf` path
{- The filename of the metadata log for a given key. -}
metaDataLogFile :: Key -> FilePath
metaDataLogFile key = hashDirLower key </> keyFile key ++ metaDataLogExt
metaDataLogExt :: String
metaDataLogExt = ".log.met"
isMetaDataLog :: FilePath -> Bool
isMetaDataLog path = metaDataLogExt `isSuffixOf` path
prop_logs_sane :: Key -> Bool
prop_logs_sane dummykey = all id
prop_logs_sane dummykey = and
[ isNothing (getLogVariety "unknown")
, expect isUUIDBasedLog (getLogVariety uuidLog)
, expect isPresenceLog (getLogVariety $ locationLogFile dummykey)
, expect isPresenceLog (getLogVariety $ urlLogFile dummykey)
, expect isNewUUIDBasedLog (getLogVariety $ remoteStateLogFile dummykey)
, expect isSingleValueLog (getLogVariety $ numcopiesLog)
, expect isOtherLog (getLogVariety $ metaDataLogFile dummykey)
, expect isOtherLog (getLogVariety $ numcopiesLog)
]
where
expect = maybe False
@ -136,5 +147,5 @@ prop_logs_sane dummykey = all id
isNewUUIDBasedLog _ = False
isPresenceLog (PresenceLog k) = k == dummykey
isPresenceLog _ = False
isSingleValueLog SingleValueLog = True
isSingleValueLog _ = False
isOtherLog OtherLog = True
isOtherLog _ = False

2
Logs/FsckResults.hs
View file

@ -31,7 +31,7 @@ writeFsckResults u fsckresults = do
store s logfile = do
createDirectoryIfMissing True (parentDir logfile)
liftIO $ viaTmp writeFile logfile $ serialize s
serialize = unlines . map show . S.toList
serialize = unlines . map fromRef . S.toList
readFsckResults :: UUID -> Annex FsckResults
readFsckResults u = do

137
Logs/MetaData.hs Normal file
View file

@ -0,0 +1,137 @@
{- git-annex general metadata storage log
-
- A line of the log will look like "timestamp field [+-]value [...]"
-
- Note that unset values are preserved. Consider this case:
-
- We have:
-
- 100 foo +x
- 200 foo -x
-
- An unmerged remote has:
-
- 150 foo +x
-
- After union merge, because the foo -x was preserved, we know that
- after the other remote redundantly set foo +x, it was unset,
- and so foo currently has no value.
-
-
- Copyright 2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP #-}
module Logs.MetaData (
getCurrentMetaData,
getMetaData,
addMetaData,
addMetaData',
currentMetaData,
) where
import Common.Annex
import Types.MetaData
import qualified Annex.Branch
import Logs
import Logs.SingleValue
import qualified Data.Set as S
import Data.Time.Clock.POSIX
instance SingleValueSerializable MetaData where
serialize = Types.MetaData.serialize
deserialize = Types.MetaData.deserialize
getMetaData :: Key -> Annex (Log MetaData)
getMetaData = readLog . metaDataLogFile
{- Go through the log from oldest to newest, and combine it all
- into a single MetaData representing the current state. -}
getCurrentMetaData :: Key -> Annex MetaData
getCurrentMetaData = currentMetaData . collect <$$> getMetaData
where
collect = foldl' unionMetaData newMetaData . map value . S.toAscList
{- Adds in some metadata, which can override existing values, or unset
- them, but otherwise leaves any existing metadata as-is. -}
addMetaData :: Key -> MetaData -> Annex ()
addMetaData k metadata = addMetaData' k metadata =<< liftIO getPOSIXTime
{- Reusing the same timestamp when making changes to the metadata
- of multiple keys is a nice optimisation. The same metadata lines
- will tend to be generated across the different log files, and so
- git will be able to pack the data more efficiently. -}
addMetaData' :: Key -> MetaData -> POSIXTime -> Annex ()
addMetaData' k metadata now = Annex.Branch.change (metaDataLogFile k) $
showLog . simplifyLog
. S.insert (LogEntry now metadata)
. parseLog
{- Simplify a log, removing historical values that are no longer
- needed.
-
- This is not as simple as just making a single log line with the newest
- state of all metadata. Consider this case:
-
- We have:
-
- 100 foo +x bar +y
- 200 foo -x
-
- An unmerged remote has:
-
- 150 bar -y baz +w
-
- If what we have were simplified to "200 foo -x bar +y" then when the line
- from the remote became available, it would be older than the simplified
- line, and its change to bar would not take effect. That is wrong.
-
- Instead, simplify it to:
-
- 100 bar +y
- 200 foo -x
-
- (Note that this ends up with the same number of lines as the
- unsimplified version, so there's really no point in updating
- the log to this version. Doing so would only add data to git,
- with little benefit.)
-
- Now merging with the remote yields:
-
- 100 bar +y
- 150 bar -y baz +w
- 200 foo -x
-
- Simplifying again:
-
- 150 bar +z baz +w
- 200 foo -x
-}
simplifyLog :: Log MetaData -> Log MetaData
simplifyLog s = case sl of
(newest:rest) ->
let sl' = go [newest] (value newest) rest
in if length sl' < length sl
then S.fromList sl'
else s
_ -> s
where
#if MIN_VERSION_containers(0,5,0)
sl = S.toDescList s
#else
sl = reverse (S.toAscList s)
#endif
go c _ [] = c
go c newer (l:ls)
| unique == newMetaData = go c newer ls
| otherwise = go (l { value = unique } : c)
(unionMetaData unique newer) ls
where
older = value l
unique = older `differenceMetaData` newer

20
Logs/Transfer.hs
View file

@ -17,6 +17,10 @@ import Types.Key
import Utility.Metered
import Utility.Percentage
import Utility.QuickCheck
import Utility.PID
#ifdef mingw32_HOST_OS
import Utility.WinLock
#endif
import Data.Time.Clock
import Data.Time.Clock.POSIX
@ -24,20 +28,6 @@ import Data.Time
import System.Locale
import Control.Concurrent
#ifndef mingw32_HOST_OS
import System.Posix.Types (ProcessID)
#else
import System.Win32.Process (ProcessId)
import System.Win32.Process.Current (getCurrentProcessId)
import Utility.WinLock
#endif
#ifndef mingw32_HOST_OS
type PID = ProcessID
#else
type PID = ProcessId
#endif
{- Enough information to uniquely identify a transfer, used as the filename
- of the transfer information file. -}
data Transfer = Transfer
@ -231,7 +221,7 @@ startTransferInfo file = TransferInfo
#ifndef mingw32_HOST_OS
<*> pure Nothing -- pid not stored in file, so omitted for speed
#else
<*> (Just <$> getCurrentProcessId)
<*> (Just <$> getPID)
#endif
<*> pure Nothing -- tid ditto
<*> pure Nothing -- not 0; transfer may be resuming

4
Logs/Unused.hs
View file

@ -86,7 +86,9 @@ readUnusedLog prefix = do
_ -> Nothing
where
(sint, rest) = separate (== ' ') line
(skey, ts) = separate (== ' ') rest
(rts, rskey) = separate (== ' ') (reverse rest)
skey = reverse rskey
ts = reverse rts
readUnusedMap :: FilePath -> Annex UnusedMap
readUnusedMap = log2map <$$> readUnusedLog

89
Logs/View.hs Normal file
View file

@ -0,0 +1,89 @@
{- 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 Git.Types
import Utility.Tmp
import qualified Data.Set as S
import Data.Char
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 show l
removeView :: View -> Annex ()
removeView v = writeViews =<< filter (/= v) <$> recentViews
recentViews :: Annex [View]
recentViews = do
f <- fromRepo gitAnnexViewLog
liftIO $ mapMaybe readish . lines <$> catchDefaultIO [] (readFile f)
{- Gets the currently checked out view, if there is one. -}
currentView :: Annex (Maybe View)
currentView = go =<< inRepo Git.Branch.current
where
go (Just b) | branchViewPrefix `isPrefixOf` fromRef b =
headMaybe . filter (\v -> branchView v == b) <$> recentViews
go _ = return Nothing
branchViewPrefix :: String
branchViewPrefix = "refs/heads/views"
{- 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 branchViewPrefix
| otherwise = Git.Ref $ branchViewPrefix ++ "/" ++ name
where
name = intercalate ";" $ map branchcomp (viewComponents view)
branchcomp c
| viewVisible c = branchcomp' c
| otherwise = "(" ++ branchcomp' c ++ ")"
branchcomp' (ViewComponent metafield viewfilter _) =concat
[ forcelegal (fromMetaField metafield)
, "="
, branchvals viewfilter
]
branchvals (FilterValues set) = intercalate "," $
map (forcelegal . 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 . fromRef . branchView

3
Makefile
View file

@ -252,7 +252,8 @@ hdevtools:
distributionupdate:
git pull
ghc --make Build/DistributionUpdate
cabal configure
ghc --make Build/DistributionUpdate -XPackageImports
./Build/DistributionUpdate
.PHONY: git-annex git-union-merge git-recover-repository tags build-stamp

3
Remote.hs
View file

@ -189,8 +189,7 @@ prettyUUID u = concat <$> prettyListUUIDs [u]
remoteFromUUID :: UUID -> Annex (Maybe Remote)
remoteFromUUID u = ifM ((==) u <$> getUUID)
( return Nothing
, do
maybe tryharder (return . Just) =<< findinmap
, maybe tryharder (return . Just) =<< findinmap
)
where
findinmap = M.lookup u <$> remoteMap id

5
Remote/Bup.hs
View file

@ -15,6 +15,7 @@ import Data.ByteString.Lazy.UTF8 (fromString)
import Common.Annex
import Types.Remote
import Types.Key
import Types.Creds
import qualified Git
import qualified Git.Command
import qualified Git.Config
@ -82,8 +83,8 @@ gen r u c gc = do
where
buprepo = fromMaybe (error "missing buprepo") $ remoteAnnexBupRepo gc
bupSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
bupSetup mu c = do
bupSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
bupSetup mu _ c = do
u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane

5
Remote/Directory.hs
View file

@ -16,6 +16,7 @@ import Data.Int
import Common.Annex
import Types.Remote
import Types.Creds
import qualified Git
import Config.Cost
import Config
@ -67,8 +68,8 @@ gen r u c gc = do
where
dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc
directorySetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
directorySetup mu c = do
directorySetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
directorySetup mu _ c = do
u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane
let dir = fromMaybe (error "Specify directory=") $

38
Remote/External.hs
View file

@ -73,8 +73,8 @@ gen r u c gc = do
where
externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc)
externalSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
externalSetup mu c = do
externalSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
externalSetup mu _ c = do
u <- maybe (liftIO genUUID) return mu
let externaltype = fromMaybe (error "Specify externaltype=") $
M.lookup "externaltype" c
@ -92,16 +92,18 @@ externalSetup mu c = do
store :: External -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store external k _f p = sendAnnex k rollback $ \f ->
storeHelper external k f p
metered (Just p) k $
storeHelper external k f
where
rollback = void $ remove external k
storeEncrypted :: External -> [CommandParam] -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
storeEncrypted external gpgOpts (cipher, enck) k p = withTmp enck $ \tmp ->
sendAnnex k rollback $ \src -> do
liftIO $ encrypt gpgOpts cipher (feedFile src) $
readBytes $ L.writeFile tmp
storeHelper external enck tmp p
metered (Just p) k $ \meterupdate -> do
liftIO $ encrypt gpgOpts cipher (feedFile src) $
readBytes $ L.writeFile tmp
storeHelper external enck tmp meterupdate
where
rollback = void $ remove external enck
@ -118,17 +120,19 @@ storeHelper external k f p = safely $
_ -> Nothing
retrieve :: External -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
retrieve external k _f d p = retrieveHelper external k d p
retrieve external k _f d p = metered (Just p) k $
retrieveHelper external k d
retrieveEncrypted :: External -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
retrieveEncrypted external (cipher, enck) _ f p = withTmp enck $ \tmp ->
ifM (retrieveHelper external enck tmp p)
( liftIO $ catchBoolIO $ do
decrypt cipher (feedFile tmp) $
readBytes $ L.writeFile f
return True
, return False
)
retrieveEncrypted external (cipher, enck) k f p = withTmp enck $ \tmp ->
metered (Just p) k $ \meterupdate ->
ifM (retrieveHelper external enck tmp meterupdate)
( liftIO $ catchBoolIO $ do
decrypt cipher (feedFile tmp) $
readBytes $ L.writeFile f
return True
, return False
)
retrieveHelper :: External -> Key -> FilePath -> MeterUpdate -> Annex Bool
retrieveHelper external k d p = safely $
@ -221,8 +225,8 @@ handleRequest' lck external req mp responsehandler
send $ VALUE value
handleRemoteRequest (SETCREDS setting login password) = do
c <- liftIO $ atomically $ readTMVar $ externalConfig external
c' <- setRemoteCredPair' c (credstorage setting)
(login, password)
c' <- setRemoteCredPair c (credstorage setting) $
Just (login, password)
void $ liftIO $ atomically $ swapTMVar (externalConfig external) c'
handleRemoteRequest (GETCREDS setting) = do
c <- liftIO $ atomically $ readTMVar $ externalConfig external

7
Remote/GCrypt.hs
View file

@ -21,6 +21,7 @@ import Common.Annex
import Types.Remote
import Types.GitConfig
import Types.Crypto
import Types.Creds
import qualified Git
import qualified Git.Command
import qualified Git.Config
@ -149,8 +150,8 @@ noCrypto = error "cannot use gcrypt remote without encryption enabled"
unsupportedUrl :: Annex a
unsupportedUrl = error "using non-ssh remote repo url with gcrypt is not supported"
gCryptSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
gCryptSetup mu c = go $ M.lookup "gitrepo" c
gCryptSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
gCryptSetup mu _ c = go $ M.lookup "gitrepo" c
where
remotename = fromJust (M.lookup "name" c)
go Nothing = error "Specify gitrepo="
@ -176,7 +177,7 @@ gCryptSetup mu c = go $ M.lookup "gitrepo" c
void $ inRepo $ Git.Command.runBool
[ Param "push"
, Param remotename
, Param $ show Annex.Branch.fullname
, Param $ Git.fromRef Annex.Branch.fullname
]
g <- inRepo Git.Config.reRead
case Git.GCrypt.remoteRepoId g (Just remotename) of

16
Remote/Glacier.hs
View file

@ -70,17 +70,18 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
remotetype = remote
}
glacierSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
glacierSetup mu c = do
glacierSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
glacierSetup mu mcreds c = do
u <- maybe (liftIO genUUID) return mu
glacierSetup' u c
glacierSetup' :: UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
glacierSetup' u c = do
glacierSetup' (isJust mu) u mcreds c
glacierSetup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
glacierSetup' enabling u mcreds c = do
c' <- encryptionSetup c
let fullconfig = c' `M.union` defaults
genVault fullconfig u
unless enabling $
genVault fullconfig u
gitConfigSpecialRemote u fullconfig "glacier" "true"
c'' <- setRemoteCredPair fullconfig (AWS.creds u)
c'' <- setRemoteCredPair fullconfig (AWS.creds u) mcreds
return (c'', u)
where
remotename = fromJust (M.lookup "name" c)
@ -245,7 +246,6 @@ archive r k = fileprefix ++ key2file k
where
fileprefix = M.findWithDefault "" "fileprefix" $ config r
-- glacier vault create will succeed even if the vault already exists.
genVault :: RemoteConfig -> UUID -> Annex ()
genVault c u = unlessM (runGlacier c u params) $
error "Failed creating glacier vault."

3
Remote/Helper/AWS.hs
View file

@ -22,9 +22,6 @@ creds u = CredPairStorage
, credPairRemoteKey = Just "s3creds"
}
setCredsEnv :: CredPair -> IO ()
setCredsEnv p = setEnvCredPair p $ creds undefined
data Service = S3 | Glacier
deriving (Eq)

5
Remote/Hook.hs
View file

@ -13,6 +13,7 @@ import qualified Data.Map as M
import Common.Annex
import Types.Remote
import Types.Key
import Types.Creds
import qualified Git
import Config
import Config.Cost
@ -65,8 +66,8 @@ gen r u c gc = do
where
hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc
hookSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
hookSetup mu c = do
hookSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
hookSetup mu _ c = do
u <- maybe (liftIO genUUID) return mu
let hooktype = fromMaybe (error "Specify hooktype=") $
M.lookup "hooktype" c

43
Remote/Rsync.hs
View file

@ -18,14 +18,6 @@ module Remote.Rsync (
RsyncOpts
) where
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
#ifndef mingw32_HOST_OS
import System.Posix.Process (getProcessID)
#else
import System.Win32.Process.Current (getCurrentProcessId)
#endif
import Common.Annex
import Types.Remote
import qualified Git
@ -40,8 +32,13 @@ import Crypto
import Utility.Rsync
import Utility.CopyFile
import Utility.Metered
import Utility.PID
import Annex.Perms
import Logs.Transfer
import Types.Creds
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
type RsyncUrl = String
@ -115,31 +112,31 @@ genRsyncOpts c gc transport url = RsyncOpts
| otherwise = True
rsyncTransport :: RemoteGitConfig -> RsyncUrl -> Annex ([CommandParam], RsyncUrl)
rsyncTransport gc rawurl
| rsyncUrlIsShell rawurl =
(\rsh -> return (rsyncShell rsh, resturl)) =<<
rsyncTransport gc url
| rsyncUrlIsShell url =
(\rsh -> return (rsyncShell rsh, url)) =<<
case fromNull ["ssh"] (remoteAnnexRsyncTransport gc) of
"ssh":sshopts -> do
let (port, sshopts') = sshReadPort sshopts
host = takeWhile (/=':') resturl
userhost = takeWhile (/=':') url
-- Connection caching
(Param "ssh":) <$> sshCachingOptions
(host, port)
(userhost, port)
(map Param $ loginopt ++ sshopts')
"rsh":rshopts -> return $ map Param $ "rsh" :
loginopt ++ rshopts
rsh -> error $ "Unknown Rsync transport: "
++ unwords rsh
| otherwise = return ([], rawurl)
| otherwise = return ([], url)
where
(login,resturl) = case separate (=='@') rawurl of
(h, "") -> (Nothing, h)
(l, h) -> (Just l, h)
login = case separate (=='@') url of
(_h, "") -> Nothing
(l, _) -> Just l
loginopt = maybe [] (\l -> ["-l",l]) login
fromNull as xs = if null xs then as else xs
rsyncSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
rsyncSetup mu c = do
rsyncSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
rsyncSetup mu _ c = do
u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane
let url = fromMaybe (error "Specify rsyncurl=") $
@ -249,14 +246,10 @@ sendParams = ifM crippledFileSystem
- up trees for rsync. -}
withRsyncScratchDir :: (FilePath -> Annex a) -> Annex a
withRsyncScratchDir a = do
#ifndef mingw32_HOST_OS
v <- liftIO getProcessID
#else
v <- liftIO getCurrentProcessId
#endif
p <- liftIO getPID
t <- fromRepo gitAnnexTmpDir
createAnnexDirectory t
let tmp = t </> "rsynctmp" </> show v
let tmp = t </> "rsynctmp" </> show p
nuke tmp
liftIO $ createDirectoryIfMissing True tmp
nuke tmp `after` a tmp

12
Remote/S3.hs
View file

@ -73,12 +73,12 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
remotetype = remote
}
s3Setup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
s3Setup mu c = do
s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
s3Setup mu mcreds c = do
u <- maybe (liftIO genUUID) return mu
s3Setup' u c
s3Setup' :: UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
s3Setup' u c = if isIA c then archiveorg else defaulthost
s3Setup' u mcreds c
s3Setup' :: UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
s3Setup' u mcreds c = if isIA c then archiveorg else defaulthost
where
remotename = fromJust (M.lookup "name" c)
defbucket = remotename ++ "-" ++ fromUUID u
@ -92,7 +92,7 @@ s3Setup' u c = if isIA c then archiveorg else defaulthost
use fullconfig = do
gitConfigSpecialRemote u fullconfig "s3" "true"
c' <- setRemoteCredPair fullconfig (AWS.creds u)
c' <- setRemoteCredPair fullconfig (AWS.creds u) mcreds
return (c', u)
defaulthost = do

5
Remote/Tahoe.hs
View file

@ -29,6 +29,7 @@ import Control.Concurrent.STM
import Common.Annex
import Types.Remote
import Types.Creds
import qualified Git
import Config
import Config.Cost
@ -85,8 +86,8 @@ gen r u c gc = do
remotetype = remote
}
tahoeSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
tahoeSetup mu c = do
tahoeSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
tahoeSetup mu _ c = do
furl <- fromMaybe (fromMaybe missingfurl $ M.lookup furlk c)
<$> liftIO (getEnv "TAHOE_FURL")
u <- maybe (liftIO genUUID) return mu

13
Remote/WebDAV.hs
View file

@ -1,13 +1,13 @@
{- WebDAV remotes.
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
- Copyright 2012-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE ScopedTypeVariables, CPP #-}
module Remote.WebDAV (remote, davCreds, setCredsEnv, configUrl) where
module Remote.WebDAV (remote, davCreds, configUrl) where
import Network.Protocol.HTTP.DAV
import qualified Data.Map as M
@ -76,8 +76,8 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
remotetype = remote
}
webdavSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
webdavSetup mu c = do
webdavSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
webdavSetup mu mcreds c = do
u <- maybe (liftIO genUUID) return mu
let url = fromMaybe (error "Specify url=") $
M.lookup "url" c
@ -85,7 +85,7 @@ webdavSetup mu c = do
creds <- getCreds c' u
testDav url creds
gitConfigSpecialRemote u c' "webdav" "true"
c'' <- setRemoteCredPair c' (davCreds u)
c'' <- setRemoteCredPair c' (davCreds u) mcreds
return (c'', u)
store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
@ -354,6 +354,3 @@ davCreds u = CredPairStorage
, credPairEnvironment = ("WEBDAV_USERNAME", "WEBDAV_PASSWORD")
, credPairRemoteKey = Just "davcreds"
}
setCredsEnv :: (String, String) -> IO ()
setCredsEnv creds = setEnvCredPair creds $ davCreds undefined

61
Test.hs
View file

@ -45,6 +45,7 @@ import qualified Logs.Remote
import qualified Logs.Unused
import qualified Logs.Transfer
import qualified Logs.Presence
import qualified Types.MetaData
import qualified Remote
import qualified Types.Key
import qualified Types.Messages
@ -53,6 +54,8 @@ import qualified Config.Cost
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
@ -144,12 +147,16 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck"
, testProperty "prop_hashes_stable" Utility.Hash.prop_hashes_stable
, testProperty "prop_schedule_roundtrips" Utility.Scheduled.prop_schedule_roundtrips
, 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" Logs.View.prop_branchView_legal
, testProperty "prop_view_roundtrips" Annex.View.prop_view_roundtrips
]
{- These tests set up the test environment, but also test some basic parts
- of git-annex. They are always run before the unitTests. -}
initTests :: TestEnv -> TestTree
initTests env = testGroup ("Init Tests")
initTests env = testGroup "Init Tests"
[ check "init" test_init
, check "add" test_add
]
@ -230,7 +237,7 @@ test_add env = inmainrepo env $ do
( do
writeFile ingitfile $ content ingitfile
not <$> boolSystem "git" [Param "add", File ingitfile] @? "git add failed to fail in direct mode"
boolSystem "rm" [Params "-f", File ingitfile] @? "rm failed"
nukeFile ingitfile
git_annex env "sync" [] @? "sync failed"
, do
writeFile ingitfile $ content ingitfile
@ -258,7 +265,7 @@ test_reinject :: TestEnv -> Assertion
test_reinject env = intmpclonerepoInDirect env $ do
git_annex env "drop" ["--force", sha1annexedfile] @? "drop failed"
writeFile tmp $ content sha1annexedfile
r <- annexeval $ Types.Backend.getKey backendSHA1 $
r <- annexeval $ Types.Backend.getKey backendSHA1
Types.KeySource.KeySource { Types.KeySource.keyFilename = tmp, Types.KeySource.contentLocation = tmp, Types.KeySource.inodeCache = Nothing }
let key = Types.Key.key2file $ fromJust r
git_annex env "reinject" [tmp, sha1annexedfile] @? "reinject failed"
@ -542,7 +549,7 @@ test_fsck_basic env = intmpclonerepo env $ do
git_annex env "fsck" [] @? "fsck unexpectedly failed again; previous one did not fix problem with " ++ f
test_fsck_bare :: TestEnv -> Assertion
test_fsck_bare env = intmpbareclonerepo env $ do
test_fsck_bare env = intmpbareclonerepo env $
git_annex env "fsck" [] @? "fsck failed"
test_fsck_localuntrusted :: TestEnv -> Assertion
@ -585,7 +592,7 @@ test_migrate' usegitattributes env = intmpclonerepoInDirect env $ do
annexed_present sha1annexedfile
if usegitattributes
then do
writeFile ".gitattributes" $ "* annex.backend=SHA1"
writeFile ".gitattributes" "* annex.backend=SHA1"
git_annex env "migrate" [sha1annexedfile]
@? "migrate sha1annexedfile failed"
git_annex env "migrate" [annexedfile]
@ -601,7 +608,7 @@ test_migrate' usegitattributes env = intmpclonerepoInDirect env $ do
checkbackend sha1annexedfile backendSHA1
-- check that reversing a migration works
writeFile ".gitattributes" $ "* annex.backend=SHA256"
writeFile ".gitattributes" "* annex.backend=SHA256"
git_annex env "migrate" [sha1annexedfile]
@? "migrate sha1annexedfile failed"
git_annex env "migrate" [annexedfile]
@ -712,7 +719,7 @@ test_find env = intmpclonerepo env $ do
git_annex_expectoutput env "find" ["--exclude", "*"] []
test_merge :: TestEnv -> Assertion
test_merge env = intmpclonerepo env $ do
test_merge env = intmpclonerepo env $
git_annex env "merge" [] @? "merge failed"
test_info :: TestEnv -> Assertion
@ -723,7 +730,7 @@ test_info env = intmpclonerepo env $ do
Text.JSON.Error e -> assertFailure e
test_version :: TestEnv -> Assertion
test_version env = intmpclonerepo env $ do
test_version env = intmpclonerepo env $
git_annex env "version" [] @? "version failed"
test_sync :: TestEnv -> Assertion
@ -739,8 +746,8 @@ test_sync env = intmpclonerepo env $ do
test_union_merge_regression :: TestEnv -> Assertion
test_union_merge_regression env =
{- We need 3 repos to see this bug. -}
withtmpclonerepo env False $ \r1 -> do
withtmpclonerepo env False $ \r2 -> do
withtmpclonerepo env False $ \r1 ->
withtmpclonerepo env False $ \r2 ->
withtmpclonerepo env False $ \r3 -> do
forM_ [r1, r2, r3] $ \r -> indir env r $ do
when (r /= r1) $
@ -766,7 +773,7 @@ test_union_merge_regression env =
{- Regression test for the automatic conflict resolution bug fixed
- in f4ba19f2b8a76a1676da7bb5850baa40d9c388e2. -}
test_conflict_resolution_movein_bug :: TestEnv -> Assertion
test_conflict_resolution_movein_bug env = withtmpclonerepo env False $ \r1 -> do
test_conflict_resolution_movein_bug env = withtmpclonerepo env False $ \r1 ->
withtmpclonerepo env False $ \r2 -> do
let rname r = if r == r1 then "r1" else "r2"
forM_ [r1, r2] $ \r -> indir env r $ do
@ -785,7 +792,7 @@ test_conflict_resolution_movein_bug env = withtmpclonerepo env False $ \r1 -> do
)
{- Sync twice in r1 so it gets the conflict resolution
- update from r2 -}
forM_ [r1, r2, r1] $ \r -> indir env r $ do
forM_ [r1, r2, r1] $ \r -> indir env r $
git_annex env "sync" ["--force"] @? "sync failed in " ++ rname r
{- After the sync, it should be possible to get all
- files. This includes both sides of the conflict,
@ -935,7 +942,7 @@ test_hook_remote env = intmpclonerepo env $ do
test_directory_remote :: TestEnv -> Assertion
test_directory_remote env = intmpclonerepo env $ do
createDirectory "dir"
git_annex env "initremote" (words $ "foo type=directory encryption=none directory=dir") @? "initremote failed"
git_annex env "initremote" (words "foo type=directory encryption=none directory=dir") @? "initremote failed"
git_annex env "get" [annexedfile] @? "get of file failed"
annexed_present annexedfile
git_annex env "copy" [annexedfile, "--to", "foo"] @? "copy --to directory remote failed"
@ -951,7 +958,7 @@ test_rsync_remote :: TestEnv -> Assertion
test_rsync_remote env = intmpclonerepo env $ do
#ifndef mingw32_HOST_OS
createDirectory "dir"
git_annex env "initremote" (words $ "foo type=rsync encryption=none rsyncurl=dir") @? "initremote failed"
git_annex env "initremote" (words "foo type=rsync encryption=none rsyncurl=dir") @? "initremote failed"
git_annex env "get" [annexedfile] @? "get of file failed"
annexed_present annexedfile
git_annex env "copy" [annexedfile, "--to", "foo"] @? "copy --to rsync remote failed"
@ -1085,7 +1092,7 @@ git_annex env command params = do
Utility.Env.setEnv var val True
-- catch all errors, including normally fatal errors
r <- try (run)::IO (Either SomeException ())
r <- try run::IO (Either SomeException ())
case r of
Right _ -> return True
Left _ -> return False
@ -1126,7 +1133,7 @@ innewrepo :: TestEnv -> Assertion -> Assertion
innewrepo env a = withgitrepo env $ \r -> indir env r a
inmainrepo :: TestEnv -> Assertion -> Assertion
inmainrepo env a = indir env mainrepodir a
inmainrepo env = indir env mainrepodir
intmpclonerepo :: TestEnv -> Assertion -> Assertion
intmpclonerepo env a = withtmpclonerepo env False $ \r -> indir env r a
@ -1163,7 +1170,7 @@ indir env dir a = do
-- any type of error and change back to cwd before
-- rethrowing.
r <- bracket_ (changeToTmpDir env dir) (setCurrentDirectory cwd)
(try (a)::IO (Either SomeException ()))
(try a::IO (Either SomeException ()))
case r of
Right () -> return ()
Left e -> throw e
@ -1186,7 +1193,7 @@ clonerepo env old new bare = do
indir env new $
git_annex env "init" ["-q", new] @? "git annex init failed"
configrepo env new
when (not bare) $
unless bare $
indir env new $
handleforcedirect env
return new
@ -1218,12 +1225,12 @@ cleanup' final dir = whenM (doesDirectoryExist dir) $ do
mapM_ (void . tryIO . Utility.FileMode.allowWrite)
-- This sometimes fails on Windows, due to some files
-- being still opened by a subprocess.
catchIO (removeDirectoryRecursive dir) $ \e -> do
catchIO (removeDirectoryRecursive dir) $ \e ->
when final $ do
print e
putStrLn "sleeping 10 seconds and will retry directory cleanup"
Utility.ThreadScheduler.threadDelaySeconds (Utility.ThreadScheduler.Seconds 10)
whenM (doesDirectoryExist dir) $ do
whenM (doesDirectoryExist dir) $
removeDirectoryRecursive dir
checklink :: FilePath -> Assertion
@ -1252,9 +1259,8 @@ checkunwritable f = unlessM (annexeval Config.isDirect) $ do
-- modified despite permissions.
s <- getFileStatus f
let mode = fileMode s
if (mode == mode `unionFileModes` ownerWriteMode)
then assertFailure $ "able to modify annexed file's " ++ f ++ " content"
else return ()
when (mode == mode `unionFileModes` ownerWriteMode) $
assertFailure $ "able to modify annexed file's " ++ f ++ " content"
checkwritable :: FilePath -> Assertion
checkwritable f = do
@ -1280,7 +1286,7 @@ checklocationlog f expected = do
case r of
Just (k, _) -> do
uuids <- annexeval $ Remote.keyLocations k
assertEqual ("bad content in location log for " ++ f ++ " key " ++ (Types.Key.key2file k) ++ " uuid " ++ show thisuuid)
assertEqual ("bad content in location log for " ++ f ++ " key " ++ Types.Key.key2file k ++ " uuid " ++ show thisuuid)
expected (thisuuid `elem` uuids)
_ -> assertFailure $ f ++ " failed to look up key"
@ -1326,8 +1332,7 @@ withTestEnv forcedirect = withResource prepare release
release = releaseTestEnv
releaseTestEnv :: TestEnv -> IO ()
releaseTestEnv _env = do
cleanup' True tmpdir
releaseTestEnv _env = cleanup' True tmpdir
prepareTestEnv :: Bool -> IO TestEnv
prepareTestEnv forcedirect = do
@ -1404,7 +1409,7 @@ changecontent :: FilePath -> IO ()
changecontent f = writeFile f $ changedcontent f
changedcontent :: FilePath -> String
changedcontent f = (content f) ++ " (modified)"
changedcontent f = content f ++ " (modified)"
backendSHA1 :: Types.Backend
backendSHA1 = backend_ "SHA1"
@ -1416,4 +1421,4 @@ backendWORM :: Types.Backend
backendWORM = backend_ "WORM"
backend_ :: String -> Types.Backend
backend_ name = Backend.lookupBackendName name
backend_ = Backend.lookupBackendName

2
Types/Command.hs
View file

@ -66,6 +66,7 @@ data CommandSection
| SectionSetup
| SectionMaintenance
| SectionQuery
| SectionMetaData
| SectionUtility
| SectionPlumbing
deriving (Eq, Ord, Enum, Bounded)
@ -75,5 +76,6 @@ descSection SectionCommon = "Commonly used commands"
descSection SectionSetup = "Repository setup commands"
descSection SectionMaintenance = "Repository maintenance commands"
descSection SectionQuery = "Query commands"
descSection SectionMetaData = "Metadata commands"
descSection SectionUtility = "Utility commands"
descSection SectionPlumbing = "Plumbing commands"

12
Types/Creds.hs Normal file
View file

@ -0,0 +1,12 @@
{- credentials
-
- Copyright 2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Types.Creds where
type Creds = String -- can be any data that contains credentials
type CredPair = (String, String) -- login, password

269
Types/MetaData.hs Normal file
View file

@ -0,0 +1,269 @@
{- git-annex general metadata
-
- Copyright 2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Types.MetaData (
MetaData(..),
MetaField(..),
MetaValue(..),
CurrentlySet(..),
serialize,
deserialize,
MetaSerializable,
toMetaField,
mkMetaField,
tagMetaField,
fromMetaField,
toMetaValue,
mkMetaValue,
unsetMetaValue,
unsetMetaData,
fromMetaValue,
fromMetaData,
newMetaData,
updateMetaData,
unionMetaData,
differenceMetaData,
isSet,
currentMetaData,
currentMetaDataValues,
metaDataValues,
ModMeta(..),
modMeta,
parseModMeta,
parseMetaData,
prop_metadata_sane,
prop_metadata_serialize
) where
import Common
import Utility.Base64
import Utility.QuickCheck
import qualified Data.Set as S
import qualified Data.Map as M
import Data.Char
newtype MetaData = MetaData (M.Map MetaField (S.Set MetaValue))
deriving (Show, Eq, Ord)
{- 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 (Read, Show, Eq, Ord, Arbitrary)
newtype MetaField = MetaField String
deriving (Read, Show, Eq, Ord)
data MetaValue = MetaValue CurrentlySet String
deriving (Read, Show)
{- Metadata values compare and order the same whether currently set or not. -}
instance Eq MetaValue where
MetaValue _ a == MetaValue _ b = a == b
instance Ord MetaValue where
compare (MetaValue _ x) (MetaValue _ y) = compare x y
{- MetaData is serialized to a format like:
-
- field1 +val1 +val2 -val3 field2 +val4 +val5
-}
class MetaSerializable v where
serialize :: v -> String
deserialize :: String -> Maybe v
instance MetaSerializable MetaData where
serialize (MetaData m) = unwords $ concatMap go $ M.toList m
where
go (f, vs) = serialize f : map serialize (S.toList vs)
deserialize = Just . getfield newMetaData . words
where
getfield m [] = m
getfield m (w:ws) = maybe m (getvalues m ws) (deserialize w)
getvalues m [] _ = m
getvalues m l@(w:ws) f = case deserialize w of
Just v -> getvalues (updateMetaData f v m) ws f
Nothing -> getfield m l
instance MetaSerializable MetaField where
serialize (MetaField f) = f
deserialize = Just . MetaField
{- Base64 problimatic values. -}
instance MetaSerializable MetaValue where
serialize (MetaValue isset v) =
serialize isset ++
if any isSpace v || "!" `isPrefixOf` v
then '!' : toB64 v
else v
deserialize (isset:'!':v) = MetaValue
<$> deserialize [isset]
<*> fromB64Maybe v
deserialize (isset:v) = MetaValue
<$> deserialize [isset]
<*> pure v
deserialize [] = Nothing
instance MetaSerializable CurrentlySet where
serialize (CurrentlySet True) = "+"
serialize (CurrentlySet False) = "-"
deserialize "+" = Just (CurrentlySet True)
deserialize "-" = Just (CurrentlySet False)
deserialize _ = Nothing
{- Fields cannot be empty, contain whitespace, or start with "+-" as
- that would break the serialization. -}
toMetaField :: String -> Maybe MetaField
toMetaField f
| legalField f = Just $ MetaField f
| otherwise = Nothing
legalField :: String -> Bool
legalField f
| null f = False
| any isSpace f = False
| any (`isPrefixOf` f) ["+", "-"] = False
| otherwise = True
toMetaValue :: String -> MetaValue
toMetaValue = MetaValue (CurrentlySet True)
mkMetaValue :: CurrentlySet -> String -> MetaValue
mkMetaValue = MetaValue
unsetMetaValue :: MetaValue -> MetaValue
unsetMetaValue (MetaValue _ s) = MetaValue (CurrentlySet False) s
{- Marks all MetaValues as no longer currently set. -}
unsetMetaData :: MetaData -> MetaData
unsetMetaData (MetaData m) = MetaData $ M.map (S.map unsetMetaValue) m
fromMetaField :: MetaField -> String
fromMetaField (MetaField f) = f
fromMetaValue :: MetaValue -> String
fromMetaValue (MetaValue _ f) = f
fromMetaData :: MetaData -> [(MetaField, S.Set MetaValue)]
fromMetaData (MetaData m) = M.toList m
newMetaData :: MetaData
newMetaData = MetaData M.empty
{- Can be used to set a value, or to unset it, depending on whether
- the MetaValue has CurrentlySet or not. -}
updateMetaData :: MetaField -> MetaValue -> MetaData -> MetaData
updateMetaData f v (MetaData m) = MetaData $
M.insertWith' S.union f (S.singleton v) m
{- New metadata overrides old._-}
unionMetaData :: MetaData -> MetaData -> MetaData
unionMetaData (MetaData old) (MetaData new) = MetaData $
M.unionWith S.union new old
differenceMetaData :: MetaData -> MetaData -> MetaData
differenceMetaData (MetaData m) (MetaData excludem) = MetaData $
M.differenceWith diff m excludem
where
diff sl sr =
let s = S.difference sl sr
in if S.null s then Nothing else Just s
isSet :: MetaValue -> Bool
isSet (MetaValue (CurrentlySet isset) _) = isset
{- Gets only currently set values -}
currentMetaDataValues :: MetaField -> MetaData -> S.Set MetaValue
currentMetaDataValues f m = S.filter isSet (metaDataValues f m)
currentMetaData :: MetaData -> MetaData
currentMetaData (MetaData m) = removeEmptyFields $ MetaData $
M.map (S.filter isSet) m
removeEmptyFields :: MetaData -> MetaData
removeEmptyFields (MetaData m) = MetaData $ M.filter (not . S.null) m
{- Gets currently set values, but also values that have been unset. -}
metaDataValues :: MetaField -> MetaData -> S.Set MetaValue
metaDataValues f (MetaData m) = fromMaybe S.empty (M.lookup f m)
{- Ways that existing metadata can be modified -}
data ModMeta
= AddMeta MetaField MetaValue
| DelMeta MetaField MetaValue
| SetMeta MetaField MetaValue -- removes any existing values
{- Applies a ModMeta, generating the new MetaData.
- Note that the new MetaData does not include all the
- values set in the input metadata. It only contains changed values. -}
modMeta :: MetaData -> ModMeta -> MetaData
modMeta _ (AddMeta f v) = updateMetaData f v newMetaData
modMeta _ (DelMeta f oldv) = updateMetaData f (unsetMetaValue oldv) newMetaData
modMeta m (SetMeta f v) = updateMetaData f v $
foldr (updateMetaData f) newMetaData $
map unsetMetaValue $ S.toList $ currentMetaDataValues f m
{- Parses field=value, field+=value, field-=value -}
parseModMeta :: String -> Either String ModMeta
parseModMeta p = case lastMaybe f of
Just '+' -> AddMeta <$> mkMetaField f' <*> v
Just '-' -> DelMeta <$> mkMetaField f' <*> v
_ -> SetMeta <$> mkMetaField f <*> v
where
(f, sv) = separate (== '=') p
f' = beginning f
v = pure (toMetaValue sv)
{- Parses field=value -}
parseMetaData :: String -> Either String (MetaField, MetaValue)
parseMetaData p = (,)
<$> mkMetaField f
<*> pure (toMetaValue v)
where
(f, v) = separate (== '=') p
mkMetaField :: String -> Either String MetaField
mkMetaField f = maybe (Left $ badField f) Right (toMetaField f)
badField :: String -> String
badField f = "Illegal metadata field name, \"" ++ f ++ "\""
tagMetaField :: MetaField
tagMetaField = MetaField "tag"
{- Avoid putting too many fields in the map; extremely large maps make
- the seriaization test slow due to the sheer amount of data.
- It's unlikely that more than 100 fields of metadata will be used. -}
instance Arbitrary MetaData where
arbitrary = do
size <- arbitrarySizedBoundedIntegral `suchThat` (< 500)
MetaData . M.fromList <$> vector size
instance Arbitrary MetaValue where
arbitrary = MetaValue <$> arbitrary <*> arbitrary
instance Arbitrary MetaField where
arbitrary = MetaField <$> arbitrary `suchThat` legalField
prop_metadata_sane :: MetaData -> MetaField -> MetaValue -> Bool
prop_metadata_sane m f v = and
[ S.member v $ metaDataValues f m'
, not (isSet v) || S.member v (currentMetaDataValues f m')
, differenceMetaData m' newMetaData == m'
]
where
m' = updateMetaData f v m
prop_metadata_serialize :: MetaField -> MetaValue -> MetaData -> Bool
prop_metadata_serialize f v m = and
[ deserialize (serialize f) == Just f
, deserialize (serialize v) == Just v
, deserialize (serialize m') == Just m'
]
where
m' = removeEmptyFields m

3
Types/Remote.hs
View file

@ -24,6 +24,7 @@ import Types.Key
import Types.UUID
import Types.GitConfig
import Types.Availability
import Types.Creds
import Config.Cost
import Utility.Metered
import Git.Types
@ -41,7 +42,7 @@ data RemoteTypeA a = RemoteType {
-- generates a remote of this type
generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> a (Maybe (RemoteA a)),
-- initializes or changes a remote
setup :: Maybe UUID -> RemoteConfig -> a (RemoteConfig, UUID)
setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> a (RemoteConfig, UUID)
}
instance Eq (RemoteTypeA a) where

Some files were not shown because too many files have changed in this diff Show more