Merge branch 'directguard'
This commit is contained in:
Joey Hess
commit
d99bdbbb84
34 changed files with 963 additions and 531 deletions
25
Annex.hs
25
Annex.hs
|
|
@ -12,7 +12,6 @@ module Annex (
|
|||
AnnexState(..),
|
||||
PreferredContentMap,
|
||||
new,
|
||||
newState,
|
||||
run,
|
||||
eval,
|
||||
getState,
|
||||
|
|
@ -41,10 +40,12 @@ import Control.Concurrent
|
|||
import Common
|
||||
import qualified Git
|
||||
import qualified Git.Config
|
||||
import Git.Types hiding (remotes)
|
||||
import Git.CatFile
|
||||
import Git.CheckAttr
|
||||
import Git.CheckIgnore
|
||||
import Git.SharedRepository
|
||||
import Git.Config
|
||||
import qualified Git.Queue
|
||||
import Types.Backend
|
||||
import Types.GitConfig
|
||||
|
|
@ -112,9 +113,9 @@ data AnnexState = AnnexState
|
|||
}
|
||||
|
||||
newState :: Git.Repo -> AnnexState
|
||||
newState gitrepo = AnnexState
|
||||
{ repo = gitrepo
|
||||
, gitconfig = extractGitConfig gitrepo
|
||||
newState r = AnnexState
|
||||
{ repo = if annexDirect c then fixupDirect r else r
|
||||
, gitconfig = c
|
||||
, backends = []
|
||||
, remotes = []
|
||||
, output = defaultMessageState
|
||||
|
|
@ -144,6 +145,8 @@ newState gitrepo = AnnexState
|
|||
, inodeschanged = Nothing
|
||||
, useragent = Nothing
|
||||
}
|
||||
where
|
||||
c = extractGitConfig r
|
||||
|
||||
{- Makes an Annex state object for the specified git repo.
|
||||
- Ensures the config is read, if it was not already. -}
|
||||
|
|
@ -247,3 +250,17 @@ withCurrentState :: Annex a -> Annex (IO a)
|
|||
withCurrentState a = do
|
||||
s <- getState id
|
||||
return $ eval s a
|
||||
|
||||
{- Direct mode repos have core.bare=true, but are not really bare.
|
||||
- Fix up the Repo to be a non-bare repo, and arrange for git commands
|
||||
- run by git-annex to be passed parameters that override this setting. -}
|
||||
fixupDirect :: Git.Repo -> Git.Repo
|
||||
fixupDirect r@(Repo { location = Local { gitdir = d, worktree = Nothing } }) =
|
||||
r
|
||||
{ location = Local { gitdir = d </> ".git", worktree = Just d }
|
||||
, gitGlobalOpts = gitGlobalOpts r ++
|
||||
[ Param "-c"
|
||||
, Param $ coreBare ++ "=" ++ boolConfig False
|
||||
]
|
||||
}
|
||||
fixupDirect r = r
|
||||
|
|
|
|||
|
|
@ -27,6 +27,7 @@ import qualified Annex
|
|||
import Git.Types
|
||||
import Git.FilePath
|
||||
import Git.FileMode
|
||||
import qualified Git.Ref
|
||||
|
||||
catFile :: Git.Branch -> FilePath -> Annex L.ByteString
|
||||
catFile branch file = do
|
||||
|
|
@ -108,9 +109,6 @@ catKeyChecked needhead ref@(Ref r) =
|
|||
map snd . filter (\p -> fst p == file)
|
||||
|
||||
{- From a file in the repository back to the key.
|
||||
-
|
||||
- Prefixing the file with ./ makes this work even if in a subdirectory
|
||||
- of a repo.
|
||||
-
|
||||
- Ideally, this should reflect the key that's staged in the index,
|
||||
- not the key that's committed to HEAD. Unfortunately, git cat-file
|
||||
|
|
@ -134,8 +132,8 @@ catKeyChecked needhead ref@(Ref r) =
|
|||
catKeyFile :: FilePath -> Annex (Maybe Key)
|
||||
catKeyFile f = ifM (Annex.getState Annex.daemon)
|
||||
( catKeyFileHEAD f
|
||||
, catKeyChecked True (Ref $ ":./" ++ f)
|
||||
, catKeyChecked True $ Git.Ref.fileRef f
|
||||
)
|
||||
|
||||
catKeyFileHEAD :: FilePath -> Annex (Maybe Key)
|
||||
catKeyFileHEAD f = catKeyChecked False (Ref $ "HEAD:./" ++ f)
|
||||
catKeyFileHEAD f = catKeyChecked False $ Git.Ref.fileFromRef Git.Ref.headRef f
|
||||
|
|
|
|||
|
|
@ -8,13 +8,18 @@
|
|||
module Annex.Direct where
|
||||
|
||||
import Common.Annex
|
||||
import qualified Annex
|
||||
import qualified Git
|
||||
import qualified Git.LsFiles
|
||||
import qualified Git.Merge
|
||||
import qualified Git.DiffTree as DiffTree
|
||||
import qualified Git.Config
|
||||
import qualified Git.Ref
|
||||
import qualified Git.Branch
|
||||
import Git.Sha
|
||||
import Git.FilePath
|
||||
import Git.Types
|
||||
import Config
|
||||
import Annex.CatFile
|
||||
import qualified Annex.Queue
|
||||
import Logs.Location
|
||||
|
|
@ -231,3 +236,66 @@ changedDirect oldk f = do
|
|||
locs <- removeAssociatedFile oldk f
|
||||
whenM (pure (null locs) <&&> not <$> inAnnex oldk) $
|
||||
logStatus oldk InfoMissing
|
||||
|
||||
{- Enable/disable direct mode. -}
|
||||
setDirect :: Bool -> Annex ()
|
||||
setDirect wantdirect = do
|
||||
if wantdirect
|
||||
then do
|
||||
switchHEAD
|
||||
setbare
|
||||
else do
|
||||
setbare
|
||||
switchHEADBack
|
||||
setConfig (annexConfig "direct") val
|
||||
Annex.changeGitConfig $ \c -> c { annexDirect = wantdirect }
|
||||
where
|
||||
val = Git.Config.boolConfig wantdirect
|
||||
setbare = setConfig (ConfigKey Git.Config.coreBare) val
|
||||
|
||||
{- Since direct mode sets core.bare=true, incoming pushes could change
|
||||
- the currently checked out branch. To avoid this problem, HEAD
|
||||
- is changed to a internal ref that nothing is going to push to.
|
||||
-
|
||||
- For refs/heads/master, use refs/heads/annex/direct/master;
|
||||
- this way things that show HEAD (eg shell prompts) will
|
||||
- hopefully show just "master". -}
|
||||
directBranch :: Ref -> Ref
|
||||
directBranch orighead = case split "/" $ show 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)
|
||||
|
||||
{- Converts a directBranch back to the original branch.
|
||||
-
|
||||
- Any other ref is left unchanged.
|
||||
-}
|
||||
fromDirectBranch :: Ref -> Ref
|
||||
fromDirectBranch directhead = case split "/" $ show directhead of
|
||||
("refs":"heads":"annex":"direct":rest) ->
|
||||
Ref $ "refs/heads/" ++ intercalate "/" rest
|
||||
_ -> directhead
|
||||
|
||||
switchHEAD :: Annex ()
|
||||
switchHEAD = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
|
||||
where
|
||||
switch orighead = do
|
||||
let newhead = directBranch orighead
|
||||
maybe noop (inRepo . Git.Branch.update newhead)
|
||||
=<< inRepo (Git.Ref.sha orighead)
|
||||
inRepo $ Git.Branch.checkout newhead
|
||||
|
||||
switchHEADBack :: Annex ()
|
||||
switchHEADBack = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
|
||||
where
|
||||
switch currhead = do
|
||||
let orighead = fromDirectBranch currhead
|
||||
v <- inRepo $ Git.Ref.sha currhead
|
||||
case v of
|
||||
Just headsha
|
||||
| orighead /= currhead -> do
|
||||
inRepo $ Git.Branch.update orighead headsha
|
||||
inRepo $ Git.Branch.checkout orighead
|
||||
inRepo $ Git.Branch.delete currhead
|
||||
_ -> inRepo $ Git.Branch.checkout orighead
|
||||
|
|
|
|||
42
Annex/Hook.hs
Normal file
42
Annex/Hook.hs
Normal file
|
|
@ -0,0 +1,42 @@
|
|||
{- git-annex git hooks
|
||||
-
|
||||
- Note that it's important that the scripts not change, otherwise
|
||||
- removing old hooks using an old version of the script would fail.
|
||||
-
|
||||
- Copyright 2013 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Annex.Hook where
|
||||
|
||||
import Common.Annex
|
||||
import qualified Git.Hook as Git
|
||||
import Utility.Shell
|
||||
import Config
|
||||
|
||||
preCommitHook :: Git.Hook
|
||||
preCommitHook = Git.Hook "pre-commit" (mkHookScript "git annex pre-commit .")
|
||||
|
||||
mkHookScript :: String -> String
|
||||
mkHookScript s = unlines
|
||||
[ shebang_local
|
||||
, "# automatically configured by git-annex"
|
||||
, s
|
||||
]
|
||||
|
||||
hookWrite :: Git.Hook -> Annex ()
|
||||
hookWrite h =
|
||||
-- cannot have git hooks in a crippled filesystem (no execute bit)
|
||||
unlessM crippledFileSystem $
|
||||
unlessM (inRepo $ Git.hookWrite h) $
|
||||
hookWarning h "already exists, not configuring"
|
||||
|
||||
hookUnWrite :: Git.Hook -> Annex ()
|
||||
hookUnWrite h = unlessM (inRepo $ Git.hookUnWrite h) $
|
||||
hookWarning h "contents modified; not deleting. Edit it to remove call to git annex."
|
||||
|
||||
hookWarning :: Git.Hook -> String -> Annex ()
|
||||
hookWarning h msg = do
|
||||
r <- gitRepo
|
||||
warning $ Git.hookName h ++ " hook (" ++ Git.hookFile h r ++ ") " ++ msg
|
||||
|
|
@ -19,18 +19,21 @@ defaultVersion :: Version
|
|||
defaultVersion = "3"
|
||||
|
||||
directModeVersion :: Version
|
||||
directModeVersion = "4"
|
||||
directModeVersion = "5"
|
||||
|
||||
supportedVersions :: [Version]
|
||||
supportedVersions = [defaultVersion, directModeVersion]
|
||||
|
||||
upgradableVersions :: [Version]
|
||||
#ifndef mingw32_HOST_OS
|
||||
upgradableVersions = ["0", "1", "2"]
|
||||
upgradableVersions = ["0", "1", "2", "4"]
|
||||
#else
|
||||
upgradableVersions = ["2"]
|
||||
upgradableVersions = ["2", "4"]
|
||||
#endif
|
||||
|
||||
autoUpgradeableVersions :: [Version]
|
||||
autoUpgradeableVersions = ["4"]
|
||||
|
||||
versionField :: ConfigKey
|
||||
versionField = annexConfig "version"
|
||||
|
||||
|
|
@ -42,12 +45,3 @@ setVersion = setConfig versionField
|
|||
|
||||
removeVersion :: Annex ()
|
||||
removeVersion = unsetConfig versionField
|
||||
|
||||
checkVersion :: Version -> Annex ()
|
||||
checkVersion v
|
||||
| v `elem` supportedVersions = noop
|
||||
| v `elem` upgradableVersions = err "Upgrade this repository: git-annex upgrade"
|
||||
| otherwise = err "Upgrade git-annex."
|
||||
where
|
||||
err msg = error $ "Repository version " ++ v ++
|
||||
" is not supported. " ++ msg
|
||||
|
|
|
|||
|
|
@ -30,6 +30,7 @@ import Utility.DataUnits
|
|||
import Utility.Network
|
||||
import Remote (prettyUUID)
|
||||
import Annex.UUID
|
||||
import Annex.Direct
|
||||
import Types.StandardGroups
|
||||
import Logs.PreferredContent
|
||||
import Logs.UUID
|
||||
|
|
|
|||
384
Command/Info.hs
Normal file
384
Command/Info.hs
Normal file
|
|
@ -0,0 +1,384 @@
|
|||
{- git-annex command
|
||||
-
|
||||
- Copyright 2011 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
|
||||
module Command.Info where
|
||||
|
||||
import "mtl" Control.Monad.State.Strict
|
||||
import qualified Data.Map as M
|
||||
import Text.JSON
|
||||
import Data.Tuple
|
||||
import Data.Ord
|
||||
import System.PosixCompat.Files
|
||||
|
||||
import Common.Annex
|
||||
import qualified Remote
|
||||
import qualified Command.Unused
|
||||
import qualified Git
|
||||
import qualified Annex
|
||||
import Command
|
||||
import Utility.DataUnits
|
||||
import Utility.DiskFree
|
||||
import Annex.Content
|
||||
import Types.Key
|
||||
import Logs.UUID
|
||||
import Logs.Trust
|
||||
import Remote
|
||||
import Config
|
||||
import Utility.Percentage
|
||||
import Logs.Transfer
|
||||
import Types.TrustLevel
|
||||
import Types.FileMatcher
|
||||
import qualified Limit
|
||||
|
||||
-- a named computation that produces a statistic
|
||||
type Stat = StatState (Maybe (String, StatState String))
|
||||
|
||||
-- data about a set of keys
|
||||
data KeyData = KeyData
|
||||
{ countKeys :: Integer
|
||||
, sizeKeys :: Integer
|
||||
, unknownSizeKeys :: Integer
|
||||
, backendsKeys :: M.Map String Integer
|
||||
}
|
||||
|
||||
data NumCopiesStats = NumCopiesStats
|
||||
{ numCopiesVarianceMap :: M.Map Variance Integer
|
||||
}
|
||||
|
||||
newtype Variance = Variance Int
|
||||
deriving (Eq, Ord)
|
||||
|
||||
instance Show Variance where
|
||||
show (Variance n)
|
||||
| n >= 0 = "numcopies +" ++ show n
|
||||
| otherwise = "numcopies " ++ show n
|
||||
|
||||
-- cached info that multiple Stats use
|
||||
data StatInfo = StatInfo
|
||||
{ presentData :: Maybe KeyData
|
||||
, referencedData :: Maybe KeyData
|
||||
, numCopiesStats :: Maybe NumCopiesStats
|
||||
}
|
||||
|
||||
-- a state monad for running Stats in
|
||||
type StatState = StateT StatInfo Annex
|
||||
|
||||
def :: [Command]
|
||||
def = [noCommit $ command "info" paramPaths seek
|
||||
SectionQuery "shows general information about the annex"]
|
||||
|
||||
seek :: [CommandSeek]
|
||||
seek = [withWords start]
|
||||
|
||||
start :: [FilePath] -> CommandStart
|
||||
start [] = do
|
||||
globalInfo
|
||||
stop
|
||||
start ps = do
|
||||
mapM_ localInfo =<< filterM isdir ps
|
||||
stop
|
||||
where
|
||||
isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus)
|
||||
|
||||
globalInfo :: Annex ()
|
||||
globalInfo = do
|
||||
stats <- selStats global_fast_stats global_slow_stats
|
||||
showCustom "info" $ do
|
||||
evalStateT (mapM_ showStat stats) (StatInfo Nothing Nothing Nothing)
|
||||
return True
|
||||
|
||||
localInfo :: FilePath -> Annex ()
|
||||
localInfo dir = showCustom (unwords ["info", dir]) $ do
|
||||
stats <- selStats (tostats local_fast_stats) (tostats local_slow_stats)
|
||||
evalStateT (mapM_ showStat stats) =<< getLocalStatInfo dir
|
||||
return True
|
||||
where
|
||||
tostats = map (\s -> s dir)
|
||||
|
||||
selStats :: [Stat] -> [Stat] -> Annex [Stat]
|
||||
selStats fast_stats slow_stats = do
|
||||
fast <- Annex.getState Annex.fast
|
||||
return $ if fast
|
||||
then fast_stats
|
||||
else fast_stats ++ slow_stats
|
||||
|
||||
{- Order is significant. Less expensive operations, and operations
|
||||
- that share data go together.
|
||||
-}
|
||||
global_fast_stats :: [Stat]
|
||||
global_fast_stats =
|
||||
[ repository_mode
|
||||
, remote_list Trusted
|
||||
, remote_list SemiTrusted
|
||||
, remote_list UnTrusted
|
||||
, transfer_list
|
||||
, disk_size
|
||||
]
|
||||
global_slow_stats :: [Stat]
|
||||
global_slow_stats =
|
||||
[ tmp_size
|
||||
, bad_data_size
|
||||
, local_annex_keys
|
||||
, local_annex_size
|
||||
, known_annex_files
|
||||
, known_annex_size
|
||||
, bloom_info
|
||||
, backend_usage
|
||||
]
|
||||
local_fast_stats :: [FilePath -> Stat]
|
||||
local_fast_stats =
|
||||
[ local_dir
|
||||
, const local_annex_keys
|
||||
, const local_annex_size
|
||||
, const known_annex_files
|
||||
, const known_annex_size
|
||||
]
|
||||
local_slow_stats :: [FilePath -> Stat]
|
||||
local_slow_stats =
|
||||
[ const numcopies_stats
|
||||
]
|
||||
|
||||
stat :: String -> (String -> StatState String) -> Stat
|
||||
stat desc a = return $ Just (desc, a desc)
|
||||
|
||||
nostat :: Stat
|
||||
nostat = return Nothing
|
||||
|
||||
json :: JSON j => (j -> String) -> StatState j -> String -> StatState String
|
||||
json serialize a desc = do
|
||||
j <- a
|
||||
lift $ maybeShowJSON [(desc, j)]
|
||||
return $ serialize j
|
||||
|
||||
nojson :: StatState String -> String -> StatState String
|
||||
nojson a _ = a
|
||||
|
||||
showStat :: Stat -> StatState ()
|
||||
showStat s = maybe noop calc =<< s
|
||||
where
|
||||
calc (desc, a) = do
|
||||
(lift . showHeader) desc
|
||||
lift . showRaw =<< a
|
||||
|
||||
repository_mode :: Stat
|
||||
repository_mode = stat "repository mode" $ json id $ lift $
|
||||
ifM isDirect
|
||||
( return "direct", return "indirect" )
|
||||
|
||||
remote_list :: TrustLevel -> Stat
|
||||
remote_list level = stat n $ nojson $ lift $ do
|
||||
us <- M.keys <$> (M.union <$> uuidMap <*> remoteMap Remote.name)
|
||||
rs <- fst <$> trustPartition level us
|
||||
s <- prettyPrintUUIDs n rs
|
||||
return $ if null s then "0" else show (length rs) ++ "\n" ++ beginning s
|
||||
where
|
||||
n = showTrustLevel level ++ " repositories"
|
||||
|
||||
local_dir :: FilePath -> Stat
|
||||
local_dir dir = stat "directory" $ json id $ return dir
|
||||
|
||||
local_annex_keys :: Stat
|
||||
local_annex_keys = stat "local annex keys" $ json show $
|
||||
countKeys <$> cachedPresentData
|
||||
|
||||
local_annex_size :: Stat
|
||||
local_annex_size = stat "local annex size" $ json id $
|
||||
showSizeKeys <$> cachedPresentData
|
||||
|
||||
known_annex_files :: Stat
|
||||
known_annex_files = stat "annexed files in working tree" $ json show $
|
||||
countKeys <$> cachedReferencedData
|
||||
|
||||
known_annex_size :: Stat
|
||||
known_annex_size = stat "size of annexed files in working tree" $ json id $
|
||||
showSizeKeys <$> cachedReferencedData
|
||||
|
||||
tmp_size :: Stat
|
||||
tmp_size = staleSize "temporary directory size" gitAnnexTmpDir
|
||||
|
||||
bad_data_size :: Stat
|
||||
bad_data_size = staleSize "bad keys size" gitAnnexBadDir
|
||||
|
||||
bloom_info :: Stat
|
||||
bloom_info = stat "bloom filter size" $ json id $ do
|
||||
localkeys <- countKeys <$> cachedPresentData
|
||||
capacity <- fromIntegral <$> lift Command.Unused.bloomCapacity
|
||||
let note = aside $
|
||||
if localkeys >= capacity
|
||||
then "appears too small for this repository; adjust annex.bloomcapacity"
|
||||
else showPercentage 1 (percentage capacity localkeys) ++ " full"
|
||||
|
||||
-- Two bloom filters are used at the same time, so double the size
|
||||
-- of one.
|
||||
size <- roughSize memoryUnits False . (* 2) . fromIntegral . fst <$>
|
||||
lift Command.Unused.bloomBitsHashes
|
||||
|
||||
return $ size ++ note
|
||||
|
||||
transfer_list :: Stat
|
||||
transfer_list = stat "transfers in progress" $ nojson $ lift $ do
|
||||
uuidmap <- Remote.remoteMap id
|
||||
ts <- getTransfers
|
||||
return $ if null ts
|
||||
then "none"
|
||||
else multiLine $
|
||||
map (uncurry $ line uuidmap) $ sort ts
|
||||
where
|
||||
line uuidmap t i = unwords
|
||||
[ showLcDirection (transferDirection t) ++ "ing"
|
||||
, fromMaybe (key2file $ transferKey t) (associatedFile i)
|
||||
, if transferDirection t == Upload then "to" else "from"
|
||||
, maybe (fromUUID $ transferUUID t) Remote.name $
|
||||
M.lookup (transferUUID t) uuidmap
|
||||
]
|
||||
|
||||
disk_size :: Stat
|
||||
disk_size = stat "available local disk space" $ json id $ lift $
|
||||
calcfree
|
||||
<$> (annexDiskReserve <$> Annex.getGitConfig)
|
||||
<*> inRepo (getDiskFree . gitAnnexDir)
|
||||
where
|
||||
calcfree reserve (Just have) = unwords
|
||||
[ roughSize storageUnits False $ nonneg $ have - reserve
|
||||
, "(+" ++ roughSize storageUnits False reserve
|
||||
, "reserved)"
|
||||
]
|
||||
calcfree _ _ = "unknown"
|
||||
|
||||
nonneg x
|
||||
| x >= 0 = x
|
||||
| otherwise = 0
|
||||
|
||||
backend_usage :: Stat
|
||||
backend_usage = stat "backend usage" $ nojson $
|
||||
calc
|
||||
<$> (backendsKeys <$> cachedReferencedData)
|
||||
<*> (backendsKeys <$> cachedPresentData)
|
||||
where
|
||||
calc x y = multiLine $
|
||||
map (\(n, b) -> b ++ ": " ++ show n) $
|
||||
reverse $ sort $ map swap $ M.toList $
|
||||
M.unionWith (+) x y
|
||||
|
||||
numcopies_stats :: Stat
|
||||
numcopies_stats = stat "numcopies stats" $ nojson $
|
||||
calc <$> (maybe M.empty numCopiesVarianceMap <$> cachedNumCopiesStats)
|
||||
where
|
||||
calc = multiLine
|
||||
. map (\(variance, count) -> show variance ++ ": " ++ show count)
|
||||
. reverse . sortBy (comparing snd) . M.toList
|
||||
|
||||
cachedPresentData :: StatState KeyData
|
||||
cachedPresentData = do
|
||||
s <- get
|
||||
case presentData s of
|
||||
Just v -> return v
|
||||
Nothing -> do
|
||||
v <- foldKeys <$> lift getKeysPresent
|
||||
put s { presentData = Just v }
|
||||
return v
|
||||
|
||||
cachedReferencedData :: StatState KeyData
|
||||
cachedReferencedData = do
|
||||
s <- get
|
||||
case referencedData s of
|
||||
Just v -> return v
|
||||
Nothing -> do
|
||||
!v <- lift $ Command.Unused.withKeysReferenced
|
||||
emptyKeyData addKey
|
||||
put s { referencedData = Just v }
|
||||
return v
|
||||
|
||||
-- currently only available for local info
|
||||
cachedNumCopiesStats :: StatState (Maybe NumCopiesStats)
|
||||
cachedNumCopiesStats = numCopiesStats <$> get
|
||||
|
||||
getLocalStatInfo :: FilePath -> Annex StatInfo
|
||||
getLocalStatInfo dir = do
|
||||
fast <- Annex.getState Annex.fast
|
||||
matcher <- Limit.getMatcher
|
||||
(presentdata, referenceddata, numcopiesstats) <-
|
||||
Command.Unused.withKeysFilesReferencedIn dir initial
|
||||
(update matcher fast)
|
||||
return $ StatInfo (Just presentdata) (Just referenceddata) (Just numcopiesstats)
|
||||
where
|
||||
initial = (emptyKeyData, emptyKeyData, emptyNumCopiesStats)
|
||||
update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats) =
|
||||
ifM (matcher $ FileInfo file file)
|
||||
( do
|
||||
!presentdata' <- ifM (inAnnex key)
|
||||
( return $ addKey key presentdata
|
||||
, return presentdata
|
||||
)
|
||||
let !referenceddata' = addKey key referenceddata
|
||||
!numcopiesstats' <- if fast
|
||||
then return numcopiesstats
|
||||
else updateNumCopiesStats key file numcopiesstats
|
||||
return $! (presentdata', referenceddata', numcopiesstats')
|
||||
, return vs
|
||||
)
|
||||
|
||||
emptyKeyData :: KeyData
|
||||
emptyKeyData = KeyData 0 0 0 M.empty
|
||||
|
||||
emptyNumCopiesStats :: NumCopiesStats
|
||||
emptyNumCopiesStats = NumCopiesStats M.empty
|
||||
|
||||
foldKeys :: [Key] -> KeyData
|
||||
foldKeys = foldl' (flip addKey) emptyKeyData
|
||||
|
||||
addKey :: Key -> KeyData -> KeyData
|
||||
addKey key (KeyData count size unknownsize backends) =
|
||||
KeyData count' size' unknownsize' backends'
|
||||
where
|
||||
{- All calculations strict to avoid thunks when repeatedly
|
||||
- applied to many keys. -}
|
||||
!count' = count + 1
|
||||
!backends' = M.insertWith' (+) (keyBackendName key) 1 backends
|
||||
!size' = maybe size (+ size) ks
|
||||
!unknownsize' = maybe (unknownsize + 1) (const unknownsize) ks
|
||||
ks = keySize key
|
||||
|
||||
updateNumCopiesStats :: Key -> FilePath -> NumCopiesStats -> Annex NumCopiesStats
|
||||
updateNumCopiesStats key file (NumCopiesStats m) = do
|
||||
!variance <- Variance <$> numCopiesCheck file key (-)
|
||||
let !m' = M.insertWith' (+) variance 1 m
|
||||
let !ret = NumCopiesStats m'
|
||||
return ret
|
||||
|
||||
showSizeKeys :: KeyData -> String
|
||||
showSizeKeys d = total ++ missingnote
|
||||
where
|
||||
total = roughSize storageUnits False $ sizeKeys d
|
||||
missingnote
|
||||
| unknownSizeKeys d == 0 = ""
|
||||
| otherwise = aside $
|
||||
"+ " ++ show (unknownSizeKeys d) ++
|
||||
" unknown size"
|
||||
|
||||
staleSize :: String -> (Git.Repo -> FilePath) -> Stat
|
||||
staleSize label dirspec = go =<< lift (dirKeys dirspec)
|
||||
where
|
||||
go [] = nostat
|
||||
go keys = onsize =<< sum <$> keysizes keys
|
||||
onsize 0 = nostat
|
||||
onsize size = stat label $
|
||||
json (++ aside "clean up with git-annex unused") $
|
||||
return $ roughSize storageUnits False size
|
||||
keysizes keys = do
|
||||
dir <- lift $ fromRepo dirspec
|
||||
liftIO $ forM keys $ \k -> catchDefaultIO 0 $
|
||||
fromIntegral . fileSize
|
||||
<$> getFileStatus (dir </> keyFile k)
|
||||
|
||||
aside :: String -> String
|
||||
aside s = " (" ++ s ++ ")"
|
||||
|
||||
multiLine :: [String] -> String
|
||||
multiLine = concatMap (\l -> "\n\t" ++ l)
|
||||
|
|
@ -1,384 +1,89 @@
|
|||
{- git-annex command
|
||||
-
|
||||
- Copyright 2011 Joey Hess <joey@kitenet.net>
|
||||
- Copyright 2013 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
|
||||
module Command.Status where
|
||||
|
||||
import "mtl" Control.Monad.State.Strict
|
||||
import qualified Data.Map as M
|
||||
import Text.JSON
|
||||
import Data.Tuple
|
||||
import Data.Ord
|
||||
import System.PosixCompat.Files
|
||||
|
||||
import Common.Annex
|
||||
import qualified Remote
|
||||
import qualified Command.Unused
|
||||
import qualified Git
|
||||
import qualified Annex
|
||||
import Command
|
||||
import Utility.DataUnits
|
||||
import Utility.DiskFree
|
||||
import Annex.Content
|
||||
import Types.Key
|
||||
import Logs.UUID
|
||||
import Logs.Trust
|
||||
import Remote
|
||||
import Annex.CatFile
|
||||
import Annex.Content.Direct
|
||||
import Config
|
||||
import Utility.Percentage
|
||||
import Logs.Transfer
|
||||
import Types.TrustLevel
|
||||
import Types.FileMatcher
|
||||
import qualified Limit
|
||||
|
||||
-- a named computation that produces a statistic
|
||||
type Stat = StatState (Maybe (String, StatState String))
|
||||
|
||||
-- data about a set of keys
|
||||
data KeyData = KeyData
|
||||
{ countKeys :: Integer
|
||||
, sizeKeys :: Integer
|
||||
, unknownSizeKeys :: Integer
|
||||
, backendsKeys :: M.Map String Integer
|
||||
}
|
||||
|
||||
data NumCopiesStats = NumCopiesStats
|
||||
{ numCopiesVarianceMap :: M.Map Variance Integer
|
||||
}
|
||||
|
||||
newtype Variance = Variance Int
|
||||
deriving (Eq, Ord)
|
||||
|
||||
instance Show Variance where
|
||||
show (Variance n)
|
||||
| n >= 0 = "numcopies +" ++ show n
|
||||
| otherwise = "numcopies " ++ show n
|
||||
|
||||
-- cached info that multiple Stats use
|
||||
data StatInfo = StatInfo
|
||||
{ presentData :: Maybe KeyData
|
||||
, referencedData :: Maybe KeyData
|
||||
, numCopiesStats :: Maybe NumCopiesStats
|
||||
}
|
||||
|
||||
-- a state monad for running Stats in
|
||||
type StatState = StateT StatInfo Annex
|
||||
import qualified Git.LsFiles as LsFiles
|
||||
import qualified Git.Ref
|
||||
import qualified Git
|
||||
|
||||
def :: [Command]
|
||||
def = [noCommit $ command "status" paramPaths seek
|
||||
SectionQuery "shows status information about the annex"]
|
||||
def = [noCommit $ noMessages $
|
||||
command "status" paramPaths seek SectionCommon
|
||||
"show the working tree status"]
|
||||
|
||||
seek :: [CommandSeek]
|
||||
seek = [withWords start]
|
||||
seek =
|
||||
[ withWords start
|
||||
]
|
||||
|
||||
start :: [FilePath] -> CommandStart
|
||||
start [] = do
|
||||
globalStatus
|
||||
stop
|
||||
start ps = do
|
||||
mapM_ localStatus =<< filterM isdir ps
|
||||
stop
|
||||
where
|
||||
isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus)
|
||||
|
||||
globalStatus :: Annex ()
|
||||
globalStatus = do
|
||||
stats <- selStats global_fast_stats global_slow_stats
|
||||
showCustom "status" $ do
|
||||
evalStateT (mapM_ showStat stats) (StatInfo Nothing Nothing Nothing)
|
||||
return True
|
||||
|
||||
localStatus :: FilePath -> Annex ()
|
||||
localStatus dir = showCustom (unwords ["status", dir]) $ do
|
||||
stats <- selStats (tostats local_fast_stats) (tostats local_slow_stats)
|
||||
evalStateT (mapM_ showStat stats) =<< getLocalStatInfo dir
|
||||
return True
|
||||
where
|
||||
tostats = map (\s -> s dir)
|
||||
|
||||
selStats :: [Stat] -> [Stat] -> Annex [Stat]
|
||||
selStats fast_stats slow_stats = do
|
||||
fast <- Annex.getState Annex.fast
|
||||
return $ if fast
|
||||
then fast_stats
|
||||
else fast_stats ++ slow_stats
|
||||
|
||||
{- Order is significant. Less expensive operations, and operations
|
||||
- that share data go together.
|
||||
-}
|
||||
global_fast_stats :: [Stat]
|
||||
global_fast_stats =
|
||||
[ repository_mode
|
||||
, remote_list Trusted
|
||||
, remote_list SemiTrusted
|
||||
, remote_list UnTrusted
|
||||
, transfer_list
|
||||
, disk_size
|
||||
]
|
||||
global_slow_stats :: [Stat]
|
||||
global_slow_stats =
|
||||
[ tmp_size
|
||||
, bad_data_size
|
||||
, local_annex_keys
|
||||
, local_annex_size
|
||||
, known_annex_files
|
||||
, known_annex_size
|
||||
, bloom_info
|
||||
, backend_usage
|
||||
]
|
||||
local_fast_stats :: [FilePath -> Stat]
|
||||
local_fast_stats =
|
||||
[ local_dir
|
||||
, const local_annex_keys
|
||||
, const local_annex_size
|
||||
, const known_annex_files
|
||||
, const known_annex_size
|
||||
]
|
||||
local_slow_stats :: [FilePath -> Stat]
|
||||
local_slow_stats =
|
||||
[ const numcopies_stats
|
||||
]
|
||||
|
||||
stat :: String -> (String -> StatState String) -> Stat
|
||||
stat desc a = return $ Just (desc, a desc)
|
||||
|
||||
nostat :: Stat
|
||||
nostat = return Nothing
|
||||
|
||||
json :: JSON j => (j -> String) -> StatState j -> String -> StatState String
|
||||
json serialize a desc = do
|
||||
j <- a
|
||||
lift $ maybeShowJSON [(desc, j)]
|
||||
return $ serialize j
|
||||
|
||||
nojson :: StatState String -> String -> StatState String
|
||||
nojson a _ = a
|
||||
|
||||
showStat :: Stat -> StatState ()
|
||||
showStat s = maybe noop calc =<< s
|
||||
where
|
||||
calc (desc, a) = do
|
||||
(lift . showHeader) desc
|
||||
lift . showRaw =<< a
|
||||
|
||||
repository_mode :: Stat
|
||||
repository_mode = stat "repository mode" $ json id $ lift $
|
||||
ifM isDirect
|
||||
( return "direct", return "indirect" )
|
||||
|
||||
remote_list :: TrustLevel -> Stat
|
||||
remote_list level = stat n $ nojson $ lift $ do
|
||||
us <- M.keys <$> (M.union <$> uuidMap <*> remoteMap Remote.name)
|
||||
rs <- fst <$> trustPartition level us
|
||||
s <- prettyPrintUUIDs n rs
|
||||
return $ if null s then "0" else show (length rs) ++ "\n" ++ beginning s
|
||||
where
|
||||
n = showTrustLevel level ++ " repositories"
|
||||
-- Like git status, when run without a directory, behave as if
|
||||
-- given the path to the top of the repository.
|
||||
cwd <- liftIO getCurrentDirectory
|
||||
top <- fromRepo Git.repoPath
|
||||
next $ perform [relPathDirToFile cwd top]
|
||||
start locs = next $ perform locs
|
||||
|
||||
local_dir :: FilePath -> Stat
|
||||
local_dir dir = stat "directory" $ json id $ return dir
|
||||
perform :: [FilePath] -> CommandPerform
|
||||
perform locs = do
|
||||
(l, cleanup) <- inRepo $ LsFiles.modifiedOthers locs
|
||||
getstatus <- ifM isDirect
|
||||
( return statusDirect
|
||||
, return $ Just <$$> statusIndirect
|
||||
)
|
||||
forM_ l $ \f -> maybe noop (showFileStatus f) =<< getstatus f
|
||||
void $ liftIO cleanup
|
||||
next $ return True
|
||||
|
||||
local_annex_keys :: Stat
|
||||
local_annex_keys = stat "local annex keys" $ json show $
|
||||
countKeys <$> cachedPresentData
|
||||
data Status
|
||||
= NewFile
|
||||
| DeletedFile
|
||||
| ModifiedFile
|
||||
|
||||
local_annex_size :: Stat
|
||||
local_annex_size = stat "local annex size" $ json id $
|
||||
showSizeKeys <$> cachedPresentData
|
||||
showStatus :: Status -> String
|
||||
showStatus NewFile = "?"
|
||||
showStatus DeletedFile = "D"
|
||||
showStatus ModifiedFile = "M"
|
||||
|
||||
known_annex_files :: Stat
|
||||
known_annex_files = stat "annexed files in working tree" $ json show $
|
||||
countKeys <$> cachedReferencedData
|
||||
showFileStatus :: FilePath -> Status -> Annex ()
|
||||
showFileStatus f s = liftIO $ putStrLn $ showStatus s ++ " " ++ f
|
||||
|
||||
known_annex_size :: Stat
|
||||
known_annex_size = stat "size of annexed files in working tree" $ json id $
|
||||
showSizeKeys <$> cachedReferencedData
|
||||
|
||||
tmp_size :: Stat
|
||||
tmp_size = staleSize "temporary directory size" gitAnnexTmpDir
|
||||
|
||||
bad_data_size :: Stat
|
||||
bad_data_size = staleSize "bad keys size" gitAnnexBadDir
|
||||
|
||||
bloom_info :: Stat
|
||||
bloom_info = stat "bloom filter size" $ json id $ do
|
||||
localkeys <- countKeys <$> cachedPresentData
|
||||
capacity <- fromIntegral <$> lift Command.Unused.bloomCapacity
|
||||
let note = aside $
|
||||
if localkeys >= capacity
|
||||
then "appears too small for this repository; adjust annex.bloomcapacity"
|
||||
else showPercentage 1 (percentage capacity localkeys) ++ " full"
|
||||
|
||||
-- Two bloom filters are used at the same time, so double the size
|
||||
-- of one.
|
||||
size <- roughSize memoryUnits False . (* 2) . fromIntegral . fst <$>
|
||||
lift Command.Unused.bloomBitsHashes
|
||||
|
||||
return $ size ++ note
|
||||
|
||||
transfer_list :: Stat
|
||||
transfer_list = stat "transfers in progress" $ nojson $ lift $ do
|
||||
uuidmap <- Remote.remoteMap id
|
||||
ts <- getTransfers
|
||||
return $ if null ts
|
||||
then "none"
|
||||
else multiLine $
|
||||
map (uncurry $ line uuidmap) $ sort ts
|
||||
statusDirect :: FilePath -> Annex (Maybe Status)
|
||||
statusDirect f = checkstatus =<< liftIO (catchMaybeIO $ getFileStatus f)
|
||||
where
|
||||
line uuidmap t i = unwords
|
||||
[ showLcDirection (transferDirection t) ++ "ing"
|
||||
, fromMaybe (key2file $ transferKey t) (associatedFile i)
|
||||
, if transferDirection t == Upload then "to" else "from"
|
||||
, maybe (fromUUID $ transferUUID t) Remote.name $
|
||||
M.lookup (transferUUID t) uuidmap
|
||||
]
|
||||
checkstatus Nothing = return $ Just DeletedFile
|
||||
checkstatus (Just s)
|
||||
-- Git thinks that present direct mode files modifed,
|
||||
-- so have to check.
|
||||
| not (isSymbolicLink s) = checkkey s =<< catKeyFile f
|
||||
| otherwise = Just <$> checkNew f
|
||||
|
||||
checkkey s (Just k) = ifM (sameFileStatus k s)
|
||||
( return Nothing
|
||||
, return $ Just ModifiedFile
|
||||
)
|
||||
checkkey _ Nothing = Just <$> checkNew f
|
||||
|
||||
disk_size :: Stat
|
||||
disk_size = stat "available local disk space" $ json id $ lift $
|
||||
calcfree
|
||||
<$> (annexDiskReserve <$> Annex.getGitConfig)
|
||||
<*> inRepo (getDiskFree . gitAnnexDir)
|
||||
statusIndirect :: FilePath -> Annex Status
|
||||
statusIndirect f = ifM (liftIO $ isJust <$> catchMaybeIO (getFileStatus f))
|
||||
( checkNew f
|
||||
, return DeletedFile
|
||||
)
|
||||
where
|
||||
calcfree reserve (Just have) = unwords
|
||||
[ roughSize storageUnits False $ nonneg $ have - reserve
|
||||
, "(+" ++ roughSize storageUnits False reserve
|
||||
, "reserved)"
|
||||
]
|
||||
calcfree _ _ = "unknown"
|
||||
|
||||
nonneg x
|
||||
| x >= 0 = x
|
||||
| otherwise = 0
|
||||
|
||||
backend_usage :: Stat
|
||||
backend_usage = stat "backend usage" $ nojson $
|
||||
calc
|
||||
<$> (backendsKeys <$> cachedReferencedData)
|
||||
<*> (backendsKeys <$> cachedPresentData)
|
||||
where
|
||||
calc x y = multiLine $
|
||||
map (\(n, b) -> b ++ ": " ++ show n) $
|
||||
reverse $ sort $ map swap $ M.toList $
|
||||
M.unionWith (+) x y
|
||||
|
||||
numcopies_stats :: Stat
|
||||
numcopies_stats = stat "numcopies stats" $ nojson $
|
||||
calc <$> (maybe M.empty numCopiesVarianceMap <$> cachedNumCopiesStats)
|
||||
where
|
||||
calc = multiLine
|
||||
. map (\(variance, count) -> show variance ++ ": " ++ show count)
|
||||
. reverse . sortBy (comparing snd) . M.toList
|
||||
|
||||
cachedPresentData :: StatState KeyData
|
||||
cachedPresentData = do
|
||||
s <- get
|
||||
case presentData s of
|
||||
Just v -> return v
|
||||
Nothing -> do
|
||||
v <- foldKeys <$> lift getKeysPresent
|
||||
put s { presentData = Just v }
|
||||
return v
|
||||
|
||||
cachedReferencedData :: StatState KeyData
|
||||
cachedReferencedData = do
|
||||
s <- get
|
||||
case referencedData s of
|
||||
Just v -> return v
|
||||
Nothing -> do
|
||||
!v <- lift $ Command.Unused.withKeysReferenced
|
||||
emptyKeyData addKey
|
||||
put s { referencedData = Just v }
|
||||
return v
|
||||
|
||||
-- currently only available for local status
|
||||
cachedNumCopiesStats :: StatState (Maybe NumCopiesStats)
|
||||
cachedNumCopiesStats = numCopiesStats <$> get
|
||||
|
||||
getLocalStatInfo :: FilePath -> Annex StatInfo
|
||||
getLocalStatInfo dir = do
|
||||
fast <- Annex.getState Annex.fast
|
||||
matcher <- Limit.getMatcher
|
||||
(presentdata, referenceddata, numcopiesstats) <-
|
||||
Command.Unused.withKeysFilesReferencedIn dir initial
|
||||
(update matcher fast)
|
||||
return $ StatInfo (Just presentdata) (Just referenceddata) (Just numcopiesstats)
|
||||
where
|
||||
initial = (emptyKeyData, emptyKeyData, emptyNumCopiesStats)
|
||||
update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats) =
|
||||
ifM (matcher $ FileInfo file file)
|
||||
( do
|
||||
!presentdata' <- ifM (inAnnex key)
|
||||
( return $ addKey key presentdata
|
||||
, return presentdata
|
||||
)
|
||||
let !referenceddata' = addKey key referenceddata
|
||||
!numcopiesstats' <- if fast
|
||||
then return numcopiesstats
|
||||
else updateNumCopiesStats key file numcopiesstats
|
||||
return $! (presentdata', referenceddata', numcopiesstats')
|
||||
, return vs
|
||||
)
|
||||
|
||||
emptyKeyData :: KeyData
|
||||
emptyKeyData = KeyData 0 0 0 M.empty
|
||||
|
||||
emptyNumCopiesStats :: NumCopiesStats
|
||||
emptyNumCopiesStats = NumCopiesStats M.empty
|
||||
|
||||
foldKeys :: [Key] -> KeyData
|
||||
foldKeys = foldl' (flip addKey) emptyKeyData
|
||||
|
||||
addKey :: Key -> KeyData -> KeyData
|
||||
addKey key (KeyData count size unknownsize backends) =
|
||||
KeyData count' size' unknownsize' backends'
|
||||
where
|
||||
{- All calculations strict to avoid thunks when repeatedly
|
||||
- applied to many keys. -}
|
||||
!count' = count + 1
|
||||
!backends' = M.insertWith' (+) (keyBackendName key) 1 backends
|
||||
!size' = maybe size (+ size) ks
|
||||
!unknownsize' = maybe (unknownsize + 1) (const unknownsize) ks
|
||||
ks = keySize key
|
||||
|
||||
updateNumCopiesStats :: Key -> FilePath -> NumCopiesStats -> Annex NumCopiesStats
|
||||
updateNumCopiesStats key file (NumCopiesStats m) = do
|
||||
!variance <- Variance <$> numCopiesCheck file key (-)
|
||||
let !m' = M.insertWith' (+) variance 1 m
|
||||
let !ret = NumCopiesStats m'
|
||||
return ret
|
||||
|
||||
showSizeKeys :: KeyData -> String
|
||||
showSizeKeys d = total ++ missingnote
|
||||
where
|
||||
total = roughSize storageUnits False $ sizeKeys d
|
||||
missingnote
|
||||
| unknownSizeKeys d == 0 = ""
|
||||
| otherwise = aside $
|
||||
"+ " ++ show (unknownSizeKeys d) ++
|
||||
" unknown size"
|
||||
|
||||
staleSize :: String -> (Git.Repo -> FilePath) -> Stat
|
||||
staleSize label dirspec = go =<< lift (dirKeys dirspec)
|
||||
where
|
||||
go [] = nostat
|
||||
go keys = onsize =<< sum <$> keysizes keys
|
||||
onsize 0 = nostat
|
||||
onsize size = stat label $
|
||||
json (++ aside "clean up with git-annex unused") $
|
||||
return $ roughSize storageUnits False size
|
||||
keysizes keys = do
|
||||
dir <- lift $ fromRepo dirspec
|
||||
liftIO $ forM keys $ \k -> catchDefaultIO 0 $
|
||||
fromIntegral . fileSize
|
||||
<$> getFileStatus (dir </> keyFile k)
|
||||
|
||||
aside :: String -> String
|
||||
aside s = " (" ++ s ++ ")"
|
||||
|
||||
multiLine :: [String] -> String
|
||||
multiLine = concatMap (\l -> "\n\t" ++ l)
|
||||
checkNew :: FilePath -> Annex Status
|
||||
checkNew f = ifM (isJust <$> catObjectDetails (Git.Ref.fileRef f))
|
||||
( return ModifiedFile
|
||||
, return NewFile
|
||||
)
|
||||
|
|
|
|||
|
|
@ -75,10 +75,10 @@ prepMerge :: Annex ()
|
|||
prepMerge = liftIO . setCurrentDirectory =<< fromRepo Git.repoPath
|
||||
|
||||
syncBranch :: Git.Ref -> Git.Ref
|
||||
syncBranch = Git.Ref.under "refs/heads/synced/"
|
||||
syncBranch = Git.Ref.under "refs/heads/synced" . fromDirectBranch
|
||||
|
||||
remoteBranch :: Remote -> Git.Ref -> Git.Ref
|
||||
remoteBranch remote = Git.Ref.under $ "refs/remotes/" ++ Remote.name remote
|
||||
remoteBranch remote = Git.Ref.underBase $ "refs/remotes/" ++ Remote.name remote
|
||||
|
||||
syncRemotes :: [String] -> Annex [Remote]
|
||||
syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted )
|
||||
|
|
@ -138,7 +138,13 @@ mergeLocal (Just branch) = go =<< needmerge
|
|||
pushLocal :: Maybe Git.Ref -> CommandStart
|
||||
pushLocal Nothing = stop
|
||||
pushLocal (Just branch) = do
|
||||
-- Update the sync branch to match the new state of the branch
|
||||
inRepo $ updateBranch $ syncBranch branch
|
||||
-- In direct mode, we're operating on some special direct mode
|
||||
-- branch, rather than the intended branch, so update the indended
|
||||
-- branch.
|
||||
whenM isDirect $
|
||||
inRepo $ updateBranch $ fromDirectBranch branch
|
||||
stop
|
||||
|
||||
updateBranch :: Git.Ref -> Git.Repo -> IO ()
|
||||
|
|
@ -232,7 +238,7 @@ pushBranch remote branch g = tryIO (directpush g) `after` syncpush g
|
|||
, refspec branch
|
||||
]
|
||||
directpush = Git.Command.runQuiet $ pushparams
|
||||
[show $ Git.Ref.base branch]
|
||||
[show $ Git.Ref.base $ fromDirectBranch branch]
|
||||
pushparams branches =
|
||||
[ Param "push"
|
||||
, Param $ Remote.name remote
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@ import Common.Annex
|
|||
import Command
|
||||
import Upgrade
|
||||
import Annex.Version
|
||||
import Config
|
||||
|
||||
def :: [Command]
|
||||
def = [dontCheck repoExists $ -- because an old version may not seem to exist
|
||||
|
|
@ -23,6 +24,9 @@ seek = [withNothing start]
|
|||
start :: CommandStart
|
||||
start = do
|
||||
showStart "upgrade" "."
|
||||
r <- upgrade
|
||||
setVersion defaultVersion
|
||||
r <- upgrade False
|
||||
ifM isDirect
|
||||
( setVersion directModeVersion
|
||||
, setVersion defaultVersion
|
||||
)
|
||||
next $ next $ return r
|
||||
|
|
|
|||
|
|
@ -71,11 +71,6 @@ getNumCopies Nothing = annexNumCopies <$> Annex.getGitConfig
|
|||
isDirect :: Annex Bool
|
||||
isDirect = annexDirect <$> Annex.getGitConfig
|
||||
|
||||
setDirect :: Bool -> Annex ()
|
||||
setDirect b = do
|
||||
setConfig (annexConfig "direct") (Git.Config.boolConfig b)
|
||||
Annex.changeGitConfig $ \c -> c { annexDirect = b }
|
||||
|
||||
crippledFileSystem :: Annex Bool
|
||||
crippledFileSystem = annexCrippledFileSystem <$> Annex.getGitConfig
|
||||
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ import Common
|
|||
import Git
|
||||
import Git.Sha
|
||||
import Git.Command
|
||||
import Git.Ref (headRef)
|
||||
import qualified Git.Ref
|
||||
|
||||
{- The currently checked out branch.
|
||||
-
|
||||
|
|
@ -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 headRef] r
|
||||
<$> pipeReadStrict [Param "symbolic-ref", Param $ show Git.Ref.headRef] r
|
||||
where
|
||||
parse l
|
||||
| null l = Nothing
|
||||
|
|
@ -97,7 +97,7 @@ commit message branch parentrefs repo = do
|
|||
sha <- getSha "commit-tree" $ pipeWriteRead
|
||||
(map Param $ ["commit-tree", show tree] ++ ps)
|
||||
(Just $ flip hPutStr message) repo
|
||||
run [Param "update-ref", Param $ show branch, Param $ show sha] repo
|
||||
update branch sha repo
|
||||
return sha
|
||||
where
|
||||
ps = concatMap (\r -> ["-p", show r]) parentrefs
|
||||
|
|
@ -105,3 +105,29 @@ commit message branch parentrefs repo = do
|
|||
{- A leading + makes git-push force pushing a branch. -}
|
||||
forcePush :: String -> String
|
||||
forcePush b = "+" ++ b
|
||||
|
||||
{- Updates a branch (or other ref) to a new Sha. -}
|
||||
update :: Branch -> Sha -> Repo -> IO ()
|
||||
update branch sha = run
|
||||
[ Param "update-ref"
|
||||
, Param $ show branch
|
||||
, Param $ show sha
|
||||
]
|
||||
|
||||
{- Checks out a branch, creating it if necessary. -}
|
||||
checkout :: Branch -> Repo -> IO ()
|
||||
checkout branch = run
|
||||
[ Param "checkout"
|
||||
, Param "-q"
|
||||
, Param "-B"
|
||||
, Param $ show $ Git.Ref.base branch
|
||||
]
|
||||
|
||||
{- Removes a branch. -}
|
||||
delete :: Branch -> Repo -> IO ()
|
||||
delete branch = run
|
||||
[ Param "branch"
|
||||
, Param "-q"
|
||||
, Param "-D"
|
||||
, Param $ show $ Git.Ref.base branch
|
||||
]
|
||||
|
|
|
|||
|
|
@ -21,7 +21,8 @@ import Git.FilePath
|
|||
|
||||
{- Constructs a git command line operating on the specified repo. -}
|
||||
gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
|
||||
gitCommandLine params Repo { location = l@(Local _ _ ) } = setdir : settree ++ params
|
||||
gitCommandLine params r@(Repo { location = l@(Local _ _ ) }) =
|
||||
setdir : settree ++ gitGlobalOpts r ++ params
|
||||
where
|
||||
setdir = Param $ "--git-dir=" ++ gitpath (gitdir l)
|
||||
settree = case worktree l of
|
||||
|
|
|
|||
|
|
@ -153,7 +153,10 @@ boolConfig True = "true"
|
|||
boolConfig False = "false"
|
||||
|
||||
isBare :: Repo -> Bool
|
||||
isBare r = fromMaybe False $ isTrue =<< getMaybe "core.bare" r
|
||||
isBare r = fromMaybe False $ isTrue =<< getMaybe coreBare r
|
||||
|
||||
coreBare :: String
|
||||
coreBare = "core.bare"
|
||||
|
||||
{- Runs a command to get the configuration of a repo,
|
||||
- and returns a repo populated with the configuration, as well as the raw
|
||||
|
|
|
|||
|
|
@ -230,6 +230,7 @@ newFrom l = return Repo
|
|||
, remotes = []
|
||||
, remoteName = Nothing
|
||||
, gitEnv = Nothing
|
||||
, gitGlobalOpts = []
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
54
Git/Hook.hs
Normal file
54
Git/Hook.hs
Normal file
|
|
@ -0,0 +1,54 @@
|
|||
{- git hooks
|
||||
-
|
||||
- Copyright 2013 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Git.Hook where
|
||||
|
||||
import Common
|
||||
import Git
|
||||
import Utility.Tmp
|
||||
|
||||
data Hook = Hook
|
||||
{ hookName :: FilePath
|
||||
, hookScript :: String
|
||||
}
|
||||
|
||||
hookFile :: Hook -> Repo -> FilePath
|
||||
hookFile h r = localGitDir r </> "hooks" </> hookName h
|
||||
|
||||
{- Writes a hook. Returns False if the hook already exists with a different
|
||||
- content. -}
|
||||
hookWrite :: Hook -> Repo -> IO Bool
|
||||
hookWrite h r = do
|
||||
let f = hookFile h r
|
||||
ifM (doesFileExist f)
|
||||
( expectedContent h r
|
||||
, do
|
||||
viaTmp writeFile f (hookScript h)
|
||||
p <- getPermissions f
|
||||
setPermissions f $ p {executable = True}
|
||||
return True
|
||||
)
|
||||
|
||||
{- Removes a hook. Returns False if the hook contained something else, and
|
||||
- could not be removed. -}
|
||||
hookUnWrite :: Hook -> Repo -> IO Bool
|
||||
hookUnWrite h r = do
|
||||
let f = hookFile h r
|
||||
ifM (doesFileExist f)
|
||||
( ifM (expectedContent h r)
|
||||
( do
|
||||
removeFile f
|
||||
return True
|
||||
, return False
|
||||
)
|
||||
, return True
|
||||
)
|
||||
|
||||
expectedContent :: Hook -> Repo -> IO Bool
|
||||
expectedContent h r = do
|
||||
content <- readFile $ hookFile h r
|
||||
return $ content == hookScript h
|
||||
|
|
@ -11,6 +11,7 @@ module Git.LsFiles (
|
|||
allFiles,
|
||||
deleted,
|
||||
modified,
|
||||
modifiedOthers,
|
||||
staged,
|
||||
stagedNotDeleted,
|
||||
stagedOthersDetails,
|
||||
|
|
@ -65,6 +66,12 @@ modified l repo = pipeNullSplit params repo
|
|||
where
|
||||
params = [Params "ls-files --modified -z --"] ++ map File l
|
||||
|
||||
{- Files that have been modified or are not checked into git. -}
|
||||
modifiedOthers :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
|
||||
modifiedOthers l repo = pipeNullSplit params repo
|
||||
where
|
||||
params = [Params "ls-files --modified --others -z --"] ++ map File l
|
||||
|
||||
{- Returns a list of all files that are staged for commit. -}
|
||||
staged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
|
||||
staged = staged' []
|
||||
|
|
|
|||
29
Git/Ref.hs
29
Git/Ref.hs
|
|
@ -29,17 +29,42 @@ base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show
|
|||
| prefix `isPrefixOf` s = drop (length prefix) s
|
||||
| otherwise = s
|
||||
|
||||
{- Given a directory and any ref, takes the basename of the ref and puts
|
||||
- it under the directory. -}
|
||||
under :: String -> Ref -> Ref
|
||||
under dir r = Ref $ dir ++ "/" ++
|
||||
(reverse $ takeWhile (/= '/') $ reverse $ show 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. -}
|
||||
under :: String -> Ref -> Ref
|
||||
under dir r = Ref $ dir </> show (base r)
|
||||
underBase :: String -> Ref -> Ref
|
||||
underBase dir r = Ref $ dir ++ "/" ++ show (base r)
|
||||
|
||||
{- A Ref that can be used to refer to a file in the repository, as staged
|
||||
- in the index.
|
||||
-
|
||||
- Prefixing the file with ./ makes this work even if in a subdirectory
|
||||
- of a repo.
|
||||
-}
|
||||
fileRef :: FilePath -> Ref
|
||||
fileRef f = Ref $ ":./" ++ f
|
||||
|
||||
{- A Ref that can be used to refer to a file in the repository as it
|
||||
- appears in a given Ref. -}
|
||||
fileFromRef :: Ref -> FilePath -> Ref
|
||||
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]
|
||||
|
||||
{- 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
|
||||
|
||||
{- Checks if HEAD exists. It generally will, except for in a repository
|
||||
- that was just created. -}
|
||||
headExists :: Repo -> IO Bool
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@ module Git.Types where
|
|||
import Network.URI
|
||||
import qualified Data.Map as M
|
||||
import System.Posix.Types
|
||||
import Utility.SafeCommand
|
||||
|
||||
{- Support repositories on local disk, and repositories accessed via an URL.
|
||||
-
|
||||
|
|
@ -38,6 +39,8 @@ data Repo = Repo
|
|||
, remoteName :: Maybe String
|
||||
-- alternate environment to use when running git commands
|
||||
, gitEnv :: Maybe [(String, String)]
|
||||
-- global options to pass to git when running git commands
|
||||
, gitGlobalOpts :: [CommandParam]
|
||||
} deriving (Show, Eq)
|
||||
|
||||
{- A git ref. Can be a sha1, or a branch or tag name. -}
|
||||
|
|
|
|||
|
|
@ -46,6 +46,7 @@ import qualified Command.Whereis
|
|||
import qualified Command.List
|
||||
import qualified Command.Log
|
||||
import qualified Command.Merge
|
||||
import qualified Command.Info
|
||||
import qualified Command.Status
|
||||
import qualified Command.Migrate
|
||||
import qualified Command.Uninit
|
||||
|
|
@ -143,6 +144,7 @@ cmds = concat
|
|||
, Command.List.def
|
||||
, Command.Log.def
|
||||
, Command.Merge.def
|
||||
, Command.Info.def
|
||||
, Command.Status.def
|
||||
, Command.Migrate.def
|
||||
, Command.Map.def
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@ import System.Console.GetOpt
|
|||
|
||||
import Common.Annex
|
||||
import qualified Git.Config
|
||||
import Git.Types
|
||||
import Command
|
||||
import Types.TrustLevel
|
||||
import qualified Annex
|
||||
|
|
@ -59,12 +60,14 @@ options = Option.common ++
|
|||
"Trust Amazon Glacier inventory"
|
||||
] ++ Option.matcher
|
||||
where
|
||||
trustArg t = ReqArg (Remote.forceTrust t) paramRemote
|
||||
setnumcopies v = maybe noop
|
||||
(\n -> Annex.changeState $ \s -> s { Annex.forcenumcopies = Just n })
|
||||
(readish v)
|
||||
setuseragent v = Annex.changeState $ \s -> s { Annex.useragent = Just v }
|
||||
setgitconfig v = Annex.changeGitRepo =<< inRepo (Git.Config.store v)
|
||||
trustArg t = ReqArg (Remote.forceTrust t) paramRemote
|
||||
setgitconfig v = inRepo (Git.Config.store v)
|
||||
>>= pure . (\r -> r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] })
|
||||
>>= Annex.changeGitRepo
|
||||
|
||||
keyOptions :: [Option]
|
||||
keyOptions =
|
||||
|
|
|
|||
98
Init.hs
98
Init.hs
|
|
@ -12,11 +12,10 @@ module Init (
|
|||
isInitialized,
|
||||
initialize,
|
||||
uninitialize,
|
||||
probeCrippledFileSystem
|
||||
probeCrippledFileSystem,
|
||||
) where
|
||||
|
||||
import Common.Annex
|
||||
import Utility.Tmp
|
||||
import Utility.Network
|
||||
import qualified Annex
|
||||
import qualified Git
|
||||
|
|
@ -26,7 +25,6 @@ import qualified Annex.Branch
|
|||
import Logs.UUID
|
||||
import Annex.Version
|
||||
import Annex.UUID
|
||||
import Utility.Shell
|
||||
import Config
|
||||
import Annex.Direct
|
||||
import Annex.Content.Direct
|
||||
|
|
@ -36,6 +34,8 @@ import Backend
|
|||
import Utility.UserInfo
|
||||
import Utility.FileMode
|
||||
#endif
|
||||
import Annex.Hook
|
||||
import Upgrade
|
||||
|
||||
genDescription :: Maybe String -> Annex String
|
||||
genDescription (Just d) = return d
|
||||
|
|
@ -53,10 +53,19 @@ genDescription Nothing = do
|
|||
initialize :: Maybe String -> Annex ()
|
||||
initialize mdescription = do
|
||||
prepUUID
|
||||
setVersion defaultVersion
|
||||
checkCrippledFileSystem
|
||||
checkFifoSupport
|
||||
gitPreCommitHookWrite
|
||||
checkCrippledFileSystem
|
||||
unlessM isBare $
|
||||
hookWrite preCommitHook
|
||||
ifM (crippledFileSystem <&&> not <$> isBare)
|
||||
( do
|
||||
enableDirectMode
|
||||
setDirect True
|
||||
setVersion directModeVersion
|
||||
, do
|
||||
setVersion defaultVersion
|
||||
setDirect False
|
||||
)
|
||||
createInodeSentinalFile
|
||||
u <- getUUID
|
||||
{- This will make the first commit to git, so ensure git is set up
|
||||
|
|
@ -67,16 +76,19 @@ initialize mdescription = do
|
|||
|
||||
uninitialize :: Annex ()
|
||||
uninitialize = do
|
||||
gitPreCommitHookUnWrite
|
||||
hookUnWrite preCommitHook
|
||||
removeRepoUUID
|
||||
removeVersion
|
||||
|
||||
{- Will automatically initialize if there is already a git-annex
|
||||
- branch from somewhere. Otherwise, require a manual init
|
||||
- to avoid git-annex accidentially being run in git
|
||||
- repos that did not intend to use it. -}
|
||||
- repos that did not intend to use it.
|
||||
-
|
||||
- Checks repository version and handles upgrades too.
|
||||
-}
|
||||
ensureInitialized :: Annex ()
|
||||
ensureInitialized = getVersion >>= maybe needsinit checkVersion
|
||||
ensureInitialized = getVersion >>= maybe needsinit checkUpgrade
|
||||
where
|
||||
needsinit = ifM Annex.Branch.hasSibling
|
||||
( initialize Nothing
|
||||
|
|
@ -87,45 +99,8 @@ ensureInitialized = getVersion >>= maybe needsinit checkVersion
|
|||
isInitialized :: Annex Bool
|
||||
isInitialized = maybe Annex.Branch.hasSibling (const $ return True) =<< getVersion
|
||||
|
||||
{- set up a git pre-commit hook, if one is not already present -}
|
||||
gitPreCommitHookWrite :: Annex ()
|
||||
gitPreCommitHookWrite = unlessBare $ do
|
||||
hook <- preCommitHook
|
||||
ifM (liftIO $ doesFileExist hook)
|
||||
( do
|
||||
content <- liftIO $ readFile hook
|
||||
when (content /= preCommitScript) $
|
||||
warning $ "pre-commit hook (" ++ hook ++ ") already exists, not configuring"
|
||||
, unlessM crippledFileSystem $
|
||||
liftIO $ do
|
||||
viaTmp writeFile hook preCommitScript
|
||||
p <- getPermissions hook
|
||||
setPermissions hook $ p {executable = True}
|
||||
)
|
||||
|
||||
gitPreCommitHookUnWrite :: Annex ()
|
||||
gitPreCommitHookUnWrite = unlessBare $ do
|
||||
hook <- preCommitHook
|
||||
whenM (liftIO $ doesFileExist hook) $
|
||||
ifM (liftIO $ (==) preCommitScript <$> readFile hook)
|
||||
( liftIO $ removeFile hook
|
||||
, warning $ "pre-commit hook (" ++ hook ++
|
||||
") contents modified; not deleting." ++
|
||||
" Edit it to remove call to git annex."
|
||||
)
|
||||
|
||||
unlessBare :: Annex () -> Annex ()
|
||||
unlessBare = unlessM $ fromRepo Git.repoIsLocalBare
|
||||
|
||||
preCommitHook :: Annex FilePath
|
||||
preCommitHook = (</>) <$> fromRepo Git.localGitDir <*> pure "hooks/pre-commit"
|
||||
|
||||
preCommitScript :: String
|
||||
preCommitScript = unlines
|
||||
[ shebang_local
|
||||
, "# automatically configured by git-annex"
|
||||
, "git annex pre-commit ."
|
||||
]
|
||||
isBare :: Annex Bool
|
||||
isBare = fromRepo Git.repoIsLocalBare
|
||||
|
||||
{- A crippled filesystem is one that does not allow making symlinks,
|
||||
- or removing write access from files. -}
|
||||
|
|
@ -158,25 +133,15 @@ checkCrippledFileSystem = whenM probeCrippledFileSystem $ do
|
|||
warning "Detected a crippled filesystem."
|
||||
setCrippledFileSystem True
|
||||
|
||||
{- Normally git disables core.symlinks itself when the filesystem does
|
||||
- not support them, but in Cygwin, git does support symlinks, while
|
||||
- git-annex, not linking with Cygwin, does not. -}
|
||||
{- Normally git disables core.symlinks itself when the
|
||||
- filesystem does not support them, but in Cygwin, git
|
||||
- does support symlinks, while git-annex, not linking
|
||||
- with Cygwin, does not. -}
|
||||
whenM (coreSymlinks <$> Annex.getGitConfig) $ do
|
||||
warning "Disabling core.symlinks."
|
||||
setConfig (ConfigKey "core.symlinks")
|
||||
(Git.Config.boolConfig False)
|
||||
|
||||
unlessBare $ do
|
||||
unlessM isDirect $ do
|
||||
warning "Enabling direct mode."
|
||||
top <- fromRepo Git.repoPath
|
||||
(l, clean) <- inRepo $ Git.LsFiles.inRepo [top]
|
||||
forM_ l $ \f ->
|
||||
maybe noop (`toDirect` f) =<< isAnnexLink f
|
||||
void $ liftIO clean
|
||||
setDirect True
|
||||
setVersion directModeVersion
|
||||
|
||||
probeFifoSupport :: Annex Bool
|
||||
probeFifoSupport = do
|
||||
#ifdef mingw32_HOST_OS
|
||||
|
|
@ -199,3 +164,12 @@ checkFifoSupport = unlessM probeFifoSupport $ do
|
|||
warning "Detected a filesystem without fifo support."
|
||||
warning "Disabling ssh connection caching."
|
||||
setConfig (annexConfig "sshcaching") (Git.Config.boolConfig False)
|
||||
|
||||
enableDirectMode :: Annex ()
|
||||
enableDirectMode = unlessM isDirect $ do
|
||||
warning "Enabling direct mode."
|
||||
top <- fromRepo Git.repoPath
|
||||
(l, clean) <- inRepo $ Git.LsFiles.inRepo [top]
|
||||
forM_ l $ \f ->
|
||||
maybe noop (`toDirect` f) =<< isAnnexLink f
|
||||
void $ liftIO clean
|
||||
|
|
|
|||
76
Test.hs
76
Test.hs
|
|
@ -215,12 +215,21 @@ test_add env = "git-annex add" ~: TestList [basic, sha1dup, subdirs]
|
|||
git_annex env "add" [wormannexedfile, "--backend=WORM"] @? "add with WORM failed"
|
||||
annexed_present wormannexedfile
|
||||
checkbackend wormannexedfile backendWORM
|
||||
boolSystem "git" [Params "rm --force -q", File wormannexedfile] @? "git rm failed"
|
||||
writeFile ingitfile $ content ingitfile
|
||||
boolSystem "git" [Param "add", File ingitfile] @? "git add failed"
|
||||
boolSystem "git" [Params "commit -q -m commit"] @? "git commit failed"
|
||||
git_annex env "add" [ingitfile] @? "add ingitfile should be no-op"
|
||||
unannexed ingitfile
|
||||
ifM (annexeval Config.isDirect)
|
||||
( do
|
||||
boolSystem "rm" [Params "-f", File wormannexedfile] @? "rm failed"
|
||||
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"
|
||||
git_annex env "sync" [] @? "sync failed"
|
||||
, do
|
||||
boolSystem "git" [Params "rm --force -q", File wormannexedfile] @? "git rm failed"
|
||||
writeFile ingitfile $ content ingitfile
|
||||
boolSystem "git" [Param "add", File ingitfile] @? "git add failed"
|
||||
boolSystem "git" [Params "commit -q -m commit"] @? "git commit failed"
|
||||
git_annex env "add" [ingitfile] @? "add ingitfile should be no-op"
|
||||
unannexed ingitfile
|
||||
)
|
||||
sha1dup = TestCase $ intmpclonerepo env $ do
|
||||
writeFile sha1annexedfiledup $ content sha1annexedfiledup
|
||||
git_annex env "add" [sha1annexedfiledup, "--backend=SHA1"] @? "add of second file with same SHA1 failed"
|
||||
|
|
@ -265,8 +274,9 @@ test_unannex env = "git-annex unannex" ~: TestList [nocopy, withcopy]
|
|||
unannexed annexedfile
|
||||
git_annex env "unannex" [annexedfile] @? "unannex failed on non-annexed file"
|
||||
unannexed annexedfile
|
||||
git_annex env "unannex" [ingitfile] @? "unannex ingitfile should be no-op"
|
||||
unannexed ingitfile
|
||||
unlessM (annexeval Config.isDirect) $ do
|
||||
git_annex env "unannex" [ingitfile] @? "unannex ingitfile should be no-op"
|
||||
unannexed ingitfile
|
||||
|
||||
test_drop :: TestEnv -> Test
|
||||
test_drop env = "git-annex drop" ~: TestList [noremote, withremote, untrustedremote]
|
||||
|
|
@ -280,8 +290,9 @@ test_drop env = "git-annex drop" ~: TestList [noremote, withremote, untrustedrem
|
|||
git_annex env "drop" ["--force", annexedfile] @? "drop --force failed"
|
||||
annexed_notpresent annexedfile
|
||||
git_annex env "drop" [annexedfile] @? "drop of dropped file failed"
|
||||
git_annex env "drop" [ingitfile] @? "drop ingitfile should be no-op"
|
||||
unannexed ingitfile
|
||||
unlessM (annexeval Config.isDirect) $ do
|
||||
git_annex env "drop" [ingitfile] @? "drop ingitfile should be no-op"
|
||||
unannexed ingitfile
|
||||
withremote = "with remote" ~: TestCase $ intmpclonerepo env $ do
|
||||
git_annex env "get" [annexedfile] @? "get failed"
|
||||
annexed_present annexedfile
|
||||
|
|
@ -306,11 +317,12 @@ test_get env = "git-annex get" ~: TestCase $ intmpclonerepo env $ do
|
|||
git_annex env "get" [annexedfile] @? "get of file already here failed"
|
||||
inmainrepo env $ annexed_present annexedfile
|
||||
annexed_present annexedfile
|
||||
inmainrepo env $ unannexed ingitfile
|
||||
unannexed ingitfile
|
||||
git_annex env "get" [ingitfile] @? "get ingitfile should be no-op"
|
||||
inmainrepo env $ unannexed ingitfile
|
||||
unannexed ingitfile
|
||||
unlessM (annexeval Config.isDirect) $ do
|
||||
inmainrepo env $ unannexed ingitfile
|
||||
unannexed ingitfile
|
||||
git_annex env "get" [ingitfile] @? "get ingitfile should be no-op"
|
||||
inmainrepo env $ unannexed ingitfile
|
||||
unannexed ingitfile
|
||||
|
||||
test_move :: TestEnv -> Test
|
||||
test_move env = "git-annex move" ~: TestCase $ intmpclonerepo env $ do
|
||||
|
|
@ -328,14 +340,15 @@ test_move env = "git-annex move" ~: TestCase $ intmpclonerepo env $ do
|
|||
git_annex env "move" ["--to", "origin", annexedfile] @? "move --to of file already there failed"
|
||||
inmainrepo env $ annexed_present annexedfile
|
||||
annexed_notpresent annexedfile
|
||||
unannexed ingitfile
|
||||
inmainrepo env $ unannexed ingitfile
|
||||
git_annex env "move" ["--to", "origin", ingitfile] @? "move of ingitfile should be no-op"
|
||||
unannexed ingitfile
|
||||
inmainrepo env $ unannexed ingitfile
|
||||
git_annex env "move" ["--from", "origin", ingitfile] @? "move of ingitfile should be no-op"
|
||||
unannexed ingitfile
|
||||
inmainrepo env $ unannexed ingitfile
|
||||
unlessM (annexeval Config.isDirect) $ do
|
||||
unannexed ingitfile
|
||||
inmainrepo env $ unannexed ingitfile
|
||||
git_annex env "move" ["--to", "origin", ingitfile] @? "move of ingitfile should be no-op"
|
||||
unannexed ingitfile
|
||||
inmainrepo env $ unannexed ingitfile
|
||||
git_annex env "move" ["--from", "origin", ingitfile] @? "move of ingitfile should be no-op"
|
||||
unannexed ingitfile
|
||||
inmainrepo env $ unannexed ingitfile
|
||||
|
||||
test_copy :: TestEnv -> Test
|
||||
test_copy env = "git-annex copy" ~: TestCase $ intmpclonerepo env $ do
|
||||
|
|
@ -353,14 +366,15 @@ test_copy env = "git-annex copy" ~: TestCase $ intmpclonerepo env $ do
|
|||
git_annex env "move" ["--to", "origin", annexedfile] @? "move --to of file already there failed"
|
||||
annexed_notpresent annexedfile
|
||||
inmainrepo env $ annexed_present annexedfile
|
||||
unannexed ingitfile
|
||||
inmainrepo env $ unannexed ingitfile
|
||||
git_annex env "copy" ["--to", "origin", ingitfile] @? "copy of ingitfile should be no-op"
|
||||
unannexed ingitfile
|
||||
inmainrepo env $ unannexed ingitfile
|
||||
git_annex env "copy" ["--from", "origin", ingitfile] @? "copy of ingitfile should be no-op"
|
||||
checkregularfile ingitfile
|
||||
checkcontent ingitfile
|
||||
unlessM (annexeval Config.isDirect) $ do
|
||||
unannexed ingitfile
|
||||
inmainrepo env $ unannexed ingitfile
|
||||
git_annex env "copy" ["--to", "origin", ingitfile] @? "copy of ingitfile should be no-op"
|
||||
unannexed ingitfile
|
||||
inmainrepo env $ unannexed ingitfile
|
||||
git_annex env "copy" ["--from", "origin", ingitfile] @? "copy of ingitfile should be no-op"
|
||||
checkregularfile ingitfile
|
||||
checkcontent ingitfile
|
||||
|
||||
test_preferred_content :: TestEnv -> Test
|
||||
test_preferred_content env = "git-annex preferred-content" ~: TestCase $ intmpclonerepo env $ do
|
||||
|
|
|
|||
17
Upgrade.hs
17
Upgrade.hs
|
|
@ -16,9 +16,21 @@ import qualified Upgrade.V0
|
|||
import qualified Upgrade.V1
|
||||
#endif
|
||||
import qualified Upgrade.V2
|
||||
import qualified Upgrade.V4
|
||||
|
||||
upgrade :: Annex Bool
|
||||
upgrade = go =<< getVersion
|
||||
checkUpgrade :: Version -> Annex ()
|
||||
checkUpgrade v
|
||||
| v `elem` supportedVersions = noop
|
||||
| v `elem` autoUpgradeableVersions = unlessM (upgrade True) $
|
||||
err "Automatic upgrade failed!"
|
||||
| v `elem` upgradableVersions = err "Upgrade this repository: git-annex upgrade"
|
||||
| otherwise = err "Upgrade git-annex."
|
||||
where
|
||||
err msg = error $ "Repository version " ++ v ++
|
||||
" is not supported. " ++ msg
|
||||
|
||||
upgrade :: Bool -> Annex Bool
|
||||
upgrade automatic = go =<< getVersion
|
||||
where
|
||||
#ifndef mingw32_HOST_OS
|
||||
go (Just "0") = Upgrade.V0.upgrade
|
||||
|
|
@ -28,4 +40,5 @@ upgrade = go =<< getVersion
|
|||
go (Just "1") = error "upgrade from v1 on Windows not supported"
|
||||
#endif
|
||||
go (Just "2") = Upgrade.V2.upgrade
|
||||
go (Just "4") = Upgrade.V4.upgrade automatic
|
||||
go _ = return True
|
||||
|
|
|
|||
23
Upgrade/V4.hs
Normal file
23
Upgrade/V4.hs
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
{- git-annex v4 -> v5 uppgrade support
|
||||
-
|
||||
- Copyright 2013 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Upgrade.V4 where
|
||||
|
||||
import Common.Annex
|
||||
import Config
|
||||
import Annex.Direct
|
||||
|
||||
{- Direct mode only upgrade. -}
|
||||
upgrade :: Bool -> Annex Bool
|
||||
upgrade automatic = ifM isDirect
|
||||
( do
|
||||
unless automatic $
|
||||
showAction "v4 to v5"
|
||||
setDirect True
|
||||
return True
|
||||
, return False
|
||||
)
|
||||
16
debian/changelog
vendored
16
debian/changelog
vendored
|
|
@ -1,3 +1,19 @@
|
|||
git-annex (5.20131102) UNRELEASED; urgency=low
|
||||
|
||||
* Direct mode repositories now have core.bare=true set, to prevent
|
||||
accidentally running git commands that try to operate on the work tree,
|
||||
and so do the wrong thing in direct mode.
|
||||
* annex.version is now set to 5 for direct mode repositories.
|
||||
This upgrade is handled fully automatically, no need to run
|
||||
git annex upgrade
|
||||
* The "status" command has been renamed to "info", to allow
|
||||
"git annex status" to be used in direct mode repositories, now that
|
||||
"git status" won't work in them.
|
||||
* The -c option now not only modifies the git configuration seen by
|
||||
git-annex, but it is passed along to every git command git-annex runs.
|
||||
|
||||
-- Joey Hess <joeyh@debian.org> Sat, 02 Nov 2013 14:54:36 -0400
|
||||
|
||||
git-annex (4.20131107) UNRELEASED; urgency=low
|
||||
|
||||
* Allow optionally configuring git-annex with -fEKG to enable awesome
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@ Now configure the remote and do the initial push:
|
|||
git remote add origin example.com:bare-annex.git
|
||||
git push origin master git-annex
|
||||
|
||||
Now `git annex status` should show the configured bare remote. If it does not, you may have to pull from the remote first (older versions of `git-annex`)
|
||||
Now `git annex info` should show the configured bare remote. If it does not, you may have to pull from the remote first (older versions of `git-annex`)
|
||||
|
||||
If you wish to configure git such that you can push/pull without arguments, set the upstream branch:
|
||||
|
||||
|
|
|
|||
|
|
@ -4,8 +4,7 @@ git, and in turn point at the content of large files that is stored in
|
|||
|
||||
The advantage of direct mode is that you can access files directly,
|
||||
including modifying them. The disadvantage is that most regular git
|
||||
commands cannot safely be used, and only a subset of git-annex commands
|
||||
can be used.
|
||||
commands cannot be used in a direct mode repository.
|
||||
|
||||
Normally, git-annex repositories start off in indirect mode. With some
|
||||
exceptions:
|
||||
|
|
@ -21,7 +20,7 @@ exceptions:
|
|||
Any repository can be converted to use direct mode at any time, and if you
|
||||
decide not to use it, you can convert back to indirect mode just as easily.
|
||||
Also, you can have one clone of a repository using direct mode, and another
|
||||
using indirect mode; direct mode interoperates.
|
||||
using indirect mode.
|
||||
|
||||
To start using direct mode:
|
||||
|
||||
|
|
@ -52,7 +51,6 @@ computers, and manage your files, this should not be a concern for you.
|
|||
## use a direct mode repository
|
||||
|
||||
You can use most git-annex commands as usual in a direct mode repository.
|
||||
A very few commands don't work in direct mode, and will refuse to do anything.
|
||||
|
||||
Direct mode also works well with the git-annex assistant.
|
||||
|
||||
|
|
@ -63,23 +61,32 @@ the changes to other repositories for `git annex sync` there to pick up,
|
|||
and will pull and merge any changes made on other repositories into the
|
||||
local repository.
|
||||
|
||||
While you generally will just use `git annex sync`, if you want to,
|
||||
you can use `git commit --staged`, or plain `git commit`.
|
||||
But not `git commit -a`, or `git commit <file>` ..
|
||||
that'd commit whole large files into git!
|
||||
|
||||
## what doesn't work in direct mode
|
||||
|
||||
`git annex status` shows incomplete information. A few other commands,
|
||||
like `git annex unlock` don't make sense in direct mode and will refuse to
|
||||
run.
|
||||
A very few git-annex commands don't work in direct mode, and will refuse
|
||||
to do anything. For example, `git annex unlock` doesn't make sense in
|
||||
direct mode.
|
||||
|
||||
As for git commands, you can probably use some git working tree
|
||||
manipulation commands, like `git checkout` and `git revert` in useful
|
||||
ways... But beware, these commands can replace files that are present in
|
||||
your repository with broken symlinks. If that file was the only copy you
|
||||
had of something, it'll be lost.
|
||||
As for git commands, direct mode prevents using any git command that would
|
||||
modify or access the work tree. So you cannot `git commit` or `git pull`
|
||||
(use `git annex sync` for both instead), or run `git status`.
|
||||
These git commands will complain "fatal: This operation must be run in a work tree".
|
||||
|
||||
This is one more reason it's wise to make git-annex untrust your direct mode
|
||||
repositories. Still, you can lose data using these sort of git commands, so
|
||||
use extreme caution.
|
||||
The reason for this is that git doesn't understand how git-annex uses the
|
||||
work tree in direct mode. Where git expects the symlinks that get checked
|
||||
into git to be checked out in the work tree, direct mode instead replaces
|
||||
them with the actual content of files, as managed by git-annex.
|
||||
|
||||
There are still lots of git commands you can use in direct mode. For
|
||||
example, you can run `git log` on files, run `git push`, `git config`,
|
||||
`git remote add` etc.
|
||||
|
||||
## forcing git to use the work tree in direct mode
|
||||
|
||||
This is for experts only. You can lose data doing this, or check enormous
|
||||
files directly into your git repository, and it's your fault if you do!
|
||||
Also, there should be no good reason to need to do this, ever.
|
||||
|
||||
Ok, with the warnings out of the way, all you need to do to make any
|
||||
git command access the work tree in direct mode is pass it
|
||||
`-c core.bare=false`
|
||||
|
|
|
|||
|
|
@ -103,6 +103,13 @@ subdirectories).
|
|||
|
||||
To avoid contacting the remote to check if it has every file, specify `--fast`
|
||||
|
||||
* `status` [path ...]`
|
||||
|
||||
Similar to `git status --short`, displays the status of the files in the
|
||||
working tree. Shows files that are not checked into git, files that
|
||||
have been deleted, and files that have been modified.
|
||||
Particulary useful in direct mode.
|
||||
|
||||
* `unlock [path ...]`
|
||||
|
||||
Normally, the content of annexed files is protected from being changed.
|
||||
|
|
@ -563,10 +570,6 @@ subdirectories).
|
|||
|
||||
# QUERY COMMANDS
|
||||
|
||||
* `version`
|
||||
|
||||
Shows the version of git-annex, as well as repository version information.
|
||||
|
||||
* `find [path ...]`
|
||||
|
||||
Outputs a list of annexed files in the specified path. With no path,
|
||||
|
|
@ -607,23 +610,26 @@ subdirectories).
|
|||
To generate output suitable for the gource visualisation program,
|
||||
specify `--gource`.
|
||||
|
||||
* `status [directory ...]`
|
||||
* `info [directory ...]`
|
||||
|
||||
Displays some statistics and other information, including how much data
|
||||
is in the annex and a list of all known repositories.
|
||||
|
||||
To only show the data that can be gathered quickly, use `--fast`.
|
||||
|
||||
When a directory is specified, shows a differently formatted status
|
||||
When a directory is specified, shows a differently formatted info
|
||||
display for that directory. In this mode, all of the file matching
|
||||
options can be used to filter the files that will be included in
|
||||
the status.
|
||||
the information.
|
||||
|
||||
For example, suppose you want to run "git annex get .", but
|
||||
would first like to see how much disk space that will use.
|
||||
Then run:
|
||||
|
||||
git annex status --fast . --not --in here
|
||||
git annex info --fast . --not --in here
|
||||
* `version`
|
||||
|
||||
Shows the version of git-annex, as well as repository version information.
|
||||
|
||||
* `map`
|
||||
|
||||
|
|
@ -698,12 +704,21 @@ subdirectories).
|
|||
|
||||
* `pre-commit [path ...]`
|
||||
|
||||
This is meant to be called from git's pre-commit hook. `git annex init`
|
||||
automatically creates a pre-commit hook using this.
|
||||
|
||||
Fixes up symlinks that are staged as part of a commit, to ensure they
|
||||
point to annexed content. Also handles injecting changes to unlocked
|
||||
files into the annex.
|
||||
|
||||
This is meant to be called from git's pre-commit hook. `git annex init`
|
||||
automatically creates a pre-commit hook using this.
|
||||
* `update-hook refname olvrev newrev`
|
||||
|
||||
This is meant to be called from git's update hook. `git annex init`
|
||||
automatically creates an update hook using this.
|
||||
|
||||
This denies updates being pushed for the currently checked out branch.
|
||||
While receive.denyCurrentBranch normally prevents that, it does
|
||||
not for fake bare repositories, as used by direct mode.
|
||||
|
||||
* `fromkey key file`
|
||||
|
||||
|
|
@ -788,7 +803,7 @@ subdirectories).
|
|||
Rather than the normal output, generate JSON. This is intended to be
|
||||
parsed by programs that use git-annex. Each line of output is a JSON
|
||||
object. Note that json output is only usable with some git-annex commands,
|
||||
like status and find.
|
||||
like info and find.
|
||||
|
||||
* `--debug`
|
||||
|
||||
|
|
@ -1088,7 +1103,7 @@ Here are all the supported configuration settings.
|
|||
up to 500000 keys. If your repository is larger than that,
|
||||
you can adjust this to avoid `git annex unused` not noticing some unused
|
||||
data files. Increasing this will make `git-annex unused` consume more memory;
|
||||
run `git annex status` for memory usage numbers.
|
||||
run `git annex info` for memory usage numbers.
|
||||
|
||||
* `annex.bloomaccuracy`
|
||||
|
||||
|
|
@ -1096,7 +1111,7 @@ Here are all the supported configuration settings.
|
|||
`git annex unused`. The default accuracy is 1000 --
|
||||
1 unused file out of 1000 will be missed by `git annex unused`. Increasing
|
||||
the accuracy will make `git annex unused` consume more memory;
|
||||
run `git annex status` for memory usage numbers.
|
||||
run `git annex info` for memory usage numbers.
|
||||
|
||||
* `annex.sshcaching`
|
||||
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ Now you can run normal annex operations, as long as the port forwarding shell is
|
|||
|
||||
git annex sync
|
||||
git annex get on-the-go some/big/file
|
||||
git annex status
|
||||
git annex info
|
||||
|
||||
You can add more computers by repeating with a different port, e.g. 2202 or 2203 (or any other).
|
||||
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@ On `angela`, we want to synchronise the git annex metadata with `marcos`. We nee
|
|||
git init
|
||||
git remote add marcos marcos.example.com:/srv/mp3
|
||||
git fetch marcos
|
||||
git annex status # this should display the two repos
|
||||
git annex info # this should display the two repos
|
||||
git annex add .
|
||||
|
||||
This will, again, checksum all files and add them to git annex. Once that is done, you can verify that the files are really the same as marcos with `whereis`:
|
||||
|
|
|
|||
|
|
@ -4,6 +4,6 @@
|
|||
subject="comment 1"
|
||||
date="2013-07-12T19:36:28Z"
|
||||
content="""
|
||||
Ah, I just found that git annex status can do the same :)
|
||||
Ah, I just found that git annex info can do the same :)
|
||||
Disregard this.
|
||||
"""]]
|
||||
|
|
|
|||
|
|
@ -77,6 +77,29 @@ This seems really promising. But of course, git-annex has its own set of
|
|||
behaviors in a bare repo, so will need to recognise that this repo is not
|
||||
really bare, and avoid them.
|
||||
|
||||
> [[done]]!! --[[Joey]]
|
||||
|
||||
(Git may also have some bare repo behaviors that are unwanted. One example
|
||||
is that git allows pushes to the current branch in a bare repo,
|
||||
even when `receive.denyCurrentBranch` is set.)
|
||||
|
||||
> This is indeed a problem. Indeed, `git annex sync` successfully
|
||||
> pushes changes to the master branch of a fake bare direct mode repo.
|
||||
>
|
||||
> And then, syncing in the repo that was pushed to causes the changes
|
||||
> that were pushed to the master branch to get reverted! This happens
|
||||
> because sync commits; commit sees that files are staged in index
|
||||
> differing from the (pushed) master, and commits the "changes"
|
||||
> which revert it.
|
||||
>
|
||||
> Could fix this using an update hook, to reject the updated of the master
|
||||
> branch. However, won't work on crippled filesystems! (No +x bit)
|
||||
>
|
||||
> Could make git annex sync detect this. It could reset the master
|
||||
> branch to the last one committed, before committing. Seems very racy
|
||||
> and hard to get right!
|
||||
>
|
||||
> Could make direct mode operate on a different branch, like
|
||||
> `annex/direct/master` rather than `master`. Avoid pushing to that
|
||||
> branch (`git annex sync` can map back from it to `master` and push there
|
||||
> instead). A bit clumsy, but works.
|
||||
|
|
|
|||
|
|
@ -18,10 +18,18 @@ conflicts first before upgrading git-annex.
|
|||
|
||||
## Upgrade events, so far
|
||||
|
||||
### v4 -> v5 (git-annex version 5.x)
|
||||
|
||||
v5 is only used for [[direct_mode]]. The upgrade from v4 to v5 is handled
|
||||
automatically.
|
||||
|
||||
This upgrade involves changing direct mode repositories to operate with
|
||||
core.bare=true.
|
||||
|
||||
### v3 -> v4 (git-annex version 4.x)
|
||||
|
||||
v4 is only used for [[direct_mode]], and no upgrade needs to be done from
|
||||
existing v3 repositories, they will continue to work.
|
||||
v4 was only used for [[direct_mode]], to ensure that a version of git-annex
|
||||
that understands direct mode was used with a direct mode repository.
|
||||
|
||||
### v2 -> v3 (git-annex version 3.x)
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue