use ByteString for git config
The parser and looking up config keys in the map should both be faster due to using ByteString. I had hoped this would speed up startup time, but any improvement to that was too small to measure. Seems worth keeping though. Note that the parser breaks up the ByteString, but a config map ends up pointing to the config as read, which is retained in memory until every value from it is no longer used. This can change memory usage patterns marginally, but won't affect git-annex.
This commit is contained in:
parent
37d0f73e66
commit
d7833def66
27 changed files with 176 additions and 105 deletions
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Annex.Environment where
|
module Annex.Environment where
|
||||||
|
|
||||||
import Annex.Common
|
import Annex.Common
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Annex.Fixup where
|
module Annex.Fixup where
|
||||||
|
|
||||||
import Git.Types
|
import Git.Types
|
||||||
|
@ -17,6 +19,7 @@ import Utility.SafeCommand
|
||||||
import Utility.Directory
|
import Utility.Directory
|
||||||
import Utility.Exception
|
import Utility.Exception
|
||||||
import Utility.Monad
|
import Utility.Monad
|
||||||
|
import Utility.FileSystemEncoding
|
||||||
import Utility.PartialPrelude
|
import Utility.PartialPrelude
|
||||||
|
|
||||||
import System.IO
|
import System.IO
|
||||||
|
@ -53,7 +56,7 @@ fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) })
|
||||||
{ location = l { worktree = Just (parentDir d) }
|
{ location = l { worktree = Just (parentDir d) }
|
||||||
, gitGlobalOpts = gitGlobalOpts r ++
|
, gitGlobalOpts = gitGlobalOpts r ++
|
||||||
[ Param "-c"
|
[ Param "-c"
|
||||||
, Param $ coreBare ++ "=" ++ boolConfig False
|
, Param $ decodeBS' coreBare ++ "=" ++ boolConfig False
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
fixupDirect r = r
|
fixupDirect r = r
|
||||||
|
|
|
@ -6,6 +6,7 @@
|
||||||
-}
|
-}
|
||||||
|
|
||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Annex.Init (
|
module Annex.Init (
|
||||||
ensureInitialized,
|
ensureInitialized,
|
||||||
|
|
|
@ -11,6 +11,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Annex.UUID (
|
module Annex.UUID (
|
||||||
getUUID,
|
getUUID,
|
||||||
getRepoUUID,
|
getRepoUUID,
|
||||||
|
@ -112,7 +114,7 @@ storeUUIDIn configfield = setConfig configfield . fromUUID
|
||||||
{- Only sets the configkey in the Repo; does not change .git/config -}
|
{- Only sets the configkey in the Repo; does not change .git/config -}
|
||||||
setUUID :: Git.Repo -> UUID -> IO Git.Repo
|
setUUID :: Git.Repo -> UUID -> IO Git.Repo
|
||||||
setUUID r u = do
|
setUUID r u = do
|
||||||
let s = show configkey ++ "=" ++ fromUUID u
|
let s = encodeBS' $ show configkey ++ "=" ++ fromUUID u
|
||||||
Git.Config.store s r
|
Git.Config.store s r
|
||||||
|
|
||||||
-- Dummy uuid for the whole web. Do not alter.
|
-- Dummy uuid for the whole web. Do not alter.
|
||||||
|
|
|
@ -6,6 +6,7 @@
|
||||||
-}
|
-}
|
||||||
|
|
||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Annex.Version where
|
module Annex.Version where
|
||||||
|
|
||||||
|
|
|
@ -124,8 +124,8 @@ import qualified Command.WebApp
|
||||||
import qualified Command.Test
|
import qualified Command.Test
|
||||||
import qualified Command.FuzzTest
|
import qualified Command.FuzzTest
|
||||||
import qualified Command.TestRemote
|
import qualified Command.TestRemote
|
||||||
import qualified Command.Benchmark
|
|
||||||
-}
|
-}
|
||||||
|
import qualified Command.Benchmark
|
||||||
|
|
||||||
cmds :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [Command]
|
cmds :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [Command]
|
||||||
cmds testoptparser testrunner mkbenchmarkgenerator =
|
cmds testoptparser testrunner mkbenchmarkgenerator =
|
||||||
|
@ -235,9 +235,9 @@ cmds testoptparser testrunner mkbenchmarkgenerator =
|
||||||
, Command.Test.cmd testoptparser testrunner
|
, Command.Test.cmd testoptparser testrunner
|
||||||
, Command.FuzzTest.cmd
|
, Command.FuzzTest.cmd
|
||||||
, Command.TestRemote.cmd
|
, Command.TestRemote.cmd
|
||||||
|
-}
|
||||||
, Command.Benchmark.cmd $
|
, Command.Benchmark.cmd $
|
||||||
mkbenchmarkgenerator $ cmds testoptparser testrunner (\_ _ -> return noop)
|
mkbenchmarkgenerator $ cmds testoptparser testrunner (\_ _ -> return noop)
|
||||||
-}
|
|
||||||
]
|
]
|
||||||
|
|
||||||
run :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [String] -> IO ()
|
run :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [String] -> IO ()
|
||||||
|
|
|
@ -92,7 +92,7 @@ gitAnnexGlobalOptions = commonGlobalOptions ++
|
||||||
where
|
where
|
||||||
setnumcopies n = Annex.changeState $ \s -> s { Annex.forcenumcopies = Just $ NumCopies n }
|
setnumcopies n = Annex.changeState $ \s -> s { Annex.forcenumcopies = Just $ NumCopies n }
|
||||||
setuseragent v = Annex.changeState $ \s -> s { Annex.useragent = Just v }
|
setuseragent v = Annex.changeState $ \s -> s { Annex.useragent = Just v }
|
||||||
setgitconfig v = Annex.adjustGitRepo $ \r -> Git.Config.store v $
|
setgitconfig v = Annex.adjustGitRepo $ \r -> Git.Config.store (encodeBS' v) $
|
||||||
r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] }
|
r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] }
|
||||||
setdesktopnotify v = Annex.changeState $ \s -> s { Annex.desktopnotify = Annex.desktopnotify s <> v }
|
setdesktopnotify v = Annex.changeState $ \s -> s { Annex.desktopnotify = Annex.desktopnotify s <> v }
|
||||||
|
|
||||||
|
|
23
Config.hs
23
Config.hs
|
@ -6,6 +6,7 @@
|
||||||
-}
|
-}
|
||||||
|
|
||||||
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
|
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Config where
|
module Config where
|
||||||
|
|
||||||
|
@ -22,25 +23,31 @@ import qualified Types.Remote as Remote
|
||||||
import qualified Annex.SpecialRemote.Config as SpecialRemote
|
import qualified Annex.SpecialRemote.Config as SpecialRemote
|
||||||
|
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
|
import qualified Data.ByteString as S
|
||||||
|
|
||||||
type UnqualifiedConfigKey = String
|
type UnqualifiedConfigKey = S.ByteString
|
||||||
data ConfigKey = ConfigKey String
|
|
||||||
|
newtype ConfigKey = ConfigKey S.ByteString
|
||||||
|
|
||||||
instance Show ConfigKey where
|
instance Show ConfigKey where
|
||||||
show (ConfigKey s) = s
|
show (ConfigKey s) = decodeBS' s
|
||||||
|
|
||||||
{- Looks up a setting in git config. This is not as efficient as using the
|
{- Looks up a setting in git config. This is not as efficient as using the
|
||||||
- GitConfig type. -}
|
- GitConfig type. -}
|
||||||
getConfig :: ConfigKey -> String -> Annex String
|
getConfig :: ConfigKey -> S.ByteString -> Annex S.ByteString
|
||||||
getConfig (ConfigKey key) d = fromRepo $ Git.Config.get key d
|
getConfig (ConfigKey key) d = fromRepo $ Git.Config.get key d
|
||||||
|
|
||||||
getConfigMaybe :: ConfigKey -> Annex (Maybe String)
|
getConfigMaybe :: ConfigKey -> Annex (Maybe S.ByteString)
|
||||||
getConfigMaybe (ConfigKey key) = fromRepo $ Git.Config.getMaybe key
|
getConfigMaybe (ConfigKey key) = fromRepo $ Git.Config.getMaybe key
|
||||||
|
|
||||||
{- Changes a git config setting in both internal state and .git/config -}
|
{- Changes a git config setting in both internal state and .git/config -}
|
||||||
setConfig :: ConfigKey -> String -> Annex ()
|
setConfig :: ConfigKey -> String -> Annex ()
|
||||||
setConfig (ConfigKey key) value = do
|
setConfig (ConfigKey key) value = do
|
||||||
inRepo $ Git.Command.run [Param "config", Param key, Param value]
|
inRepo $ Git.Command.run
|
||||||
|
[ Param "config"
|
||||||
|
, Param (decodeBS' key)
|
||||||
|
, Param value
|
||||||
|
]
|
||||||
reloadConfig
|
reloadConfig
|
||||||
|
|
||||||
reloadConfig :: Annex ()
|
reloadConfig :: Annex ()
|
||||||
|
@ -68,11 +75,11 @@ instance RemoteNameable Remote.RemoteConfig where
|
||||||
{- A per-remote config setting in git config. -}
|
{- A per-remote config setting in git config. -}
|
||||||
remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey
|
remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey
|
||||||
remoteConfig r key = ConfigKey $
|
remoteConfig r key = ConfigKey $
|
||||||
"remote." ++ getRemoteName r ++ ".annex-" ++ key
|
"remote." <> encodeBS' (getRemoteName r) <> ".annex-" <> key
|
||||||
|
|
||||||
{- A global annex setting in git config. -}
|
{- A global annex setting in git config. -}
|
||||||
annexConfig :: UnqualifiedConfigKey -> ConfigKey
|
annexConfig :: UnqualifiedConfigKey -> ConfigKey
|
||||||
annexConfig key = ConfigKey $ "annex." ++ key
|
annexConfig key = ConfigKey ("annex." <> key)
|
||||||
|
|
||||||
{- Calculates cost for a remote. Either the specific default, or as configured
|
{- Calculates cost for a remote. Either the specific default, or as configured
|
||||||
- by remote.<name>.annex-cost, or if remote.<name>.annex-cost-command
|
- by remote.<name>.annex-cost, or if remote.<name>.annex-cost-command
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Config.Smudge where
|
module Config.Smudge where
|
||||||
|
|
||||||
import Annex.Common
|
import Annex.Common
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Git.AutoCorrect where
|
module Git.AutoCorrect where
|
||||||
|
|
||||||
import Common
|
import Common
|
||||||
|
@ -44,7 +46,7 @@ fuzzymatches input showchoice choices = fst $ unzip $
|
||||||
-}
|
-}
|
||||||
prepare :: String -> (c -> String) -> [c] -> Maybe Repo -> IO ()
|
prepare :: String -> (c -> String) -> [c] -> Maybe Repo -> IO ()
|
||||||
prepare input showmatch matches r =
|
prepare input showmatch matches r =
|
||||||
case readish . Git.Config.get "help.autocorrect" "0" =<< r of
|
case readish . decodeBS' . Git.Config.get "help.autocorrect" "0" =<< r of
|
||||||
Just n
|
Just n
|
||||||
| n == 0 -> list
|
| n == 0 -> list
|
||||||
| n < 0 -> warn Nothing
|
| n < 0 -> warn Nothing
|
||||||
|
|
|
@ -6,6 +6,7 @@
|
||||||
-}
|
-}
|
||||||
|
|
||||||
{-# LANGUAGE BangPatterns #-}
|
{-# LANGUAGE BangPatterns #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Git.Branch where
|
module Git.Branch where
|
||||||
|
|
||||||
|
@ -135,8 +136,8 @@ applyCommitMode commitmode ps
|
||||||
applyCommitModeForCommitTree :: CommitMode -> [CommandParam] -> Repo -> [CommandParam]
|
applyCommitModeForCommitTree :: CommitMode -> [CommandParam] -> Repo -> [CommandParam]
|
||||||
applyCommitModeForCommitTree commitmode ps r
|
applyCommitModeForCommitTree commitmode ps r
|
||||||
| commitmode == ManualCommit =
|
| commitmode == ManualCommit =
|
||||||
case (Git.Config.getMaybe "commit.gpgsign" r) of
|
case Git.Config.getMaybe "commit.gpgsign" r of
|
||||||
Just s | Git.Config.isTrue s == Just True ->
|
Just s | Git.Config.isTrue' s == Just True ->
|
||||||
Param "-S":ps
|
Param "-S":ps
|
||||||
_ -> ps'
|
_ -> ps'
|
||||||
| otherwise = ps'
|
| otherwise = ps'
|
||||||
|
|
|
@ -1,13 +1,17 @@
|
||||||
{- git repository configuration handling
|
{- git repository configuration handling
|
||||||
-
|
-
|
||||||
- Copyright 2010-2012 Joey Hess <id@joeyh.name>
|
- Copyright 2010-2019 Joey Hess <id@joeyh.name>
|
||||||
-
|
-
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Git.Config where
|
module Git.Config where
|
||||||
|
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
|
import qualified Data.ByteString as S
|
||||||
|
import qualified Data.ByteString.Char8 as S8
|
||||||
import Data.Char
|
import Data.Char
|
||||||
|
|
||||||
import Common
|
import Common
|
||||||
|
@ -18,15 +22,15 @@ import qualified Git.Construct
|
||||||
import Utility.UserInfo
|
import Utility.UserInfo
|
||||||
|
|
||||||
{- Returns a single git config setting, or a default value if not set. -}
|
{- Returns a single git config setting, or a default value if not set. -}
|
||||||
get :: String -> String -> Repo -> String
|
get :: S.ByteString -> S.ByteString -> Repo -> S.ByteString
|
||||||
get key defaultValue repo = M.findWithDefault defaultValue key (config repo)
|
get key defaultValue repo = M.findWithDefault defaultValue key (config repo)
|
||||||
|
|
||||||
{- Returns a list with each line of a multiline config setting. -}
|
{- Returns a list with each line of a multiline config setting. -}
|
||||||
getList :: String -> Repo -> [String]
|
getList :: S.ByteString -> Repo -> [S.ByteString]
|
||||||
getList key repo = M.findWithDefault [] key (fullconfig repo)
|
getList key repo = M.findWithDefault [] key (fullconfig repo)
|
||||||
|
|
||||||
{- Returns a single git config setting, if set. -}
|
{- Returns a single git config setting, if set. -}
|
||||||
getMaybe :: String -> Repo -> Maybe String
|
getMaybe :: S.ByteString -> Repo -> Maybe S.ByteString
|
||||||
getMaybe key repo = M.lookup key (config repo)
|
getMaybe key repo = M.lookup key (config repo)
|
||||||
|
|
||||||
{- Runs git config and populates a repo with its config.
|
{- Runs git config and populates a repo with its config.
|
||||||
|
@ -79,14 +83,14 @@ global = do
|
||||||
{- Reads git config from a handle and populates a repo with it. -}
|
{- Reads git config from a handle and populates a repo with it. -}
|
||||||
hRead :: Repo -> Handle -> IO Repo
|
hRead :: Repo -> Handle -> IO Repo
|
||||||
hRead repo h = do
|
hRead repo h = do
|
||||||
val <- hGetContentsStrict h
|
val <- S.hGetContents h
|
||||||
store val repo
|
store val repo
|
||||||
|
|
||||||
{- Stores a git config into a Repo, returning the new version of the Repo.
|
{- Stores a git config into a Repo, returning the new version of the Repo.
|
||||||
- The git config may be multiple lines, or a single line.
|
- The git config may be multiple lines, or a single line.
|
||||||
- Config settings can be updated incrementally.
|
- Config settings can be updated incrementally.
|
||||||
-}
|
-}
|
||||||
store :: String -> Repo -> IO Repo
|
store :: S.ByteString -> Repo -> IO Repo
|
||||||
store s repo = do
|
store s repo = do
|
||||||
let c = parse s
|
let c = parse s
|
||||||
updateLocation $ repo
|
updateLocation $ repo
|
||||||
|
@ -96,7 +100,7 @@ store s repo = do
|
||||||
|
|
||||||
{- Stores a single config setting in a Repo, returning the new version of
|
{- Stores a single config setting in a Repo, returning the new version of
|
||||||
- the Repo. Config settings can be updated incrementally. -}
|
- the Repo. Config settings can be updated incrementally. -}
|
||||||
store' :: String -> String -> Repo -> Repo
|
store' :: S.ByteString -> S.ByteString -> Repo -> Repo
|
||||||
store' k v repo = repo
|
store' k v repo = repo
|
||||||
{ config = M.singleton k v `M.union` config repo
|
{ config = M.singleton k v `M.union` config repo
|
||||||
, fullconfig = M.unionWith (++) (M.singleton k [v]) (fullconfig repo)
|
, fullconfig = M.unionWith (++) (M.singleton k [v]) (fullconfig repo)
|
||||||
|
@ -127,49 +131,63 @@ updateLocation' r l = do
|
||||||
Just d -> do
|
Just d -> do
|
||||||
{- core.worktree is relative to the gitdir -}
|
{- core.worktree is relative to the gitdir -}
|
||||||
top <- absPath $ gitdir l
|
top <- absPath $ gitdir l
|
||||||
return $ l { worktree = Just $ absPathFrom top d }
|
let p = absPathFrom top (fromRawFilePath d)
|
||||||
|
return $ l { worktree = Just p }
|
||||||
return $ r { location = l' }
|
return $ r { location = l' }
|
||||||
|
|
||||||
{- Parses git config --list or git config --null --list output into a
|
{- Parses git config --list or git config --null --list output into a
|
||||||
- config map. -}
|
- config map. -}
|
||||||
parse :: String -> M.Map String [String]
|
parse :: S.ByteString -> M.Map S.ByteString [S.ByteString]
|
||||||
parse [] = M.empty
|
|
||||||
parse s
|
parse s
|
||||||
-- --list output will have an = in the first line
|
| S.null s = M.empty
|
||||||
| all ('=' `elem`) (take 1 ls) = sep '=' ls
|
-- --list output will have a '=' in the first line
|
||||||
|
-- (The first line of --null --list output is the name of a key,
|
||||||
|
-- which is assumed to never contain '='.)
|
||||||
|
| S.elem eq firstline = sep eq $ S.split nl s
|
||||||
-- --null --list output separates keys from values with newlines
|
-- --null --list output separates keys from values with newlines
|
||||||
| otherwise = sep '\n' $ splitc '\0' s
|
| otherwise = sep nl $ S.split 0 s
|
||||||
where
|
where
|
||||||
ls = lines s
|
nl = fromIntegral (ord '\n')
|
||||||
sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .
|
eq = fromIntegral (ord '=')
|
||||||
map (separate (== c))
|
firstline = S.takeWhile (/= nl) s
|
||||||
|
|
||||||
|
sep c = M.fromListWith (++)
|
||||||
|
. map (\(k,v) -> (k, [S.drop 1 v]))
|
||||||
|
. map (S.break (== c))
|
||||||
|
|
||||||
{- Checks if a string from git config is a true value. -}
|
{- Checks if a string from git config is a true value. -}
|
||||||
isTrue :: String -> Maybe Bool
|
isTrue :: String -> Maybe Bool
|
||||||
isTrue s
|
isTrue = isTrue' . encodeBS'
|
||||||
|
|
||||||
|
isTrue' :: S.ByteString -> Maybe Bool
|
||||||
|
isTrue' s
|
||||||
| s' == "true" = Just True
|
| s' == "true" = Just True
|
||||||
| s' == "false" = Just False
|
| s' == "false" = Just False
|
||||||
| otherwise = Nothing
|
| otherwise = Nothing
|
||||||
where
|
where
|
||||||
s' = map toLower s
|
s' = S8.map toLower s
|
||||||
|
|
||||||
boolConfig :: Bool -> String
|
boolConfig :: Bool -> String
|
||||||
boolConfig True = "true"
|
boolConfig True = "true"
|
||||||
boolConfig False = "false"
|
boolConfig False = "false"
|
||||||
|
|
||||||
isBare :: Repo -> Bool
|
boolConfig' :: Bool -> S.ByteString
|
||||||
isBare r = fromMaybe False $ isTrue =<< getMaybe coreBare r
|
boolConfig' True = "true"
|
||||||
|
boolConfig' False = "false"
|
||||||
|
|
||||||
coreBare :: String
|
isBare :: Repo -> Bool
|
||||||
|
isBare r = fromMaybe False $ isTrue' =<< getMaybe coreBare r
|
||||||
|
|
||||||
|
coreBare :: S.ByteString
|
||||||
coreBare = "core.bare"
|
coreBare = "core.bare"
|
||||||
|
|
||||||
{- Runs a command to get the configuration of a repo,
|
{- Runs a command to get the configuration of a repo,
|
||||||
- and returns a repo populated with the configuration, as well as the raw
|
- and returns a repo populated with the configuration, as well as the raw
|
||||||
- output of the command. -}
|
- output of the command. -}
|
||||||
fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, String))
|
fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, S.ByteString))
|
||||||
fromPipe r cmd params = try $
|
fromPipe r cmd params = try $
|
||||||
withHandle StdoutHandle createProcessSuccess p $ \h -> do
|
withHandle StdoutHandle createProcessSuccess p $ \h -> do
|
||||||
val <- hGetContentsStrict h
|
val <- S.hGetContents h
|
||||||
r' <- store val r
|
r' <- store val r
|
||||||
return (r', val)
|
return (r', val)
|
||||||
where
|
where
|
||||||
|
@ -177,7 +195,7 @@ fromPipe r cmd params = try $
|
||||||
|
|
||||||
{- Reads git config from a specified file and returns the repo populated
|
{- Reads git config from a specified file and returns the repo populated
|
||||||
- with the configuration. -}
|
- with the configuration. -}
|
||||||
fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, String))
|
fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString))
|
||||||
fromFile r f = fromPipe r "git"
|
fromFile r f = fromPipe r "git"
|
||||||
[ Param "config"
|
[ Param "config"
|
||||||
, Param "--file"
|
, Param "--file"
|
||||||
|
@ -187,13 +205,13 @@ fromFile r f = fromPipe r "git"
|
||||||
|
|
||||||
{- Changes a git config setting in the specified config file.
|
{- Changes a git config setting in the specified config file.
|
||||||
- (Creates the file if it does not already exist.) -}
|
- (Creates the file if it does not already exist.) -}
|
||||||
changeFile :: FilePath -> String -> String -> IO Bool
|
changeFile :: FilePath -> S.ByteString -> S.ByteString -> IO Bool
|
||||||
changeFile f k v = boolSystem "git"
|
changeFile f k v = boolSystem "git"
|
||||||
[ Param "config"
|
[ Param "config"
|
||||||
, Param "--file"
|
, Param "--file"
|
||||||
, File f
|
, File f
|
||||||
, Param k
|
, Param (decodeBS' k)
|
||||||
, Param v
|
, Param (decodeBS' v)
|
||||||
]
|
]
|
||||||
|
|
||||||
{- Unsets a git config setting, in both the git repo,
|
{- Unsets a git config setting, in both the git repo,
|
||||||
|
@ -202,10 +220,10 @@ changeFile f k v = boolSystem "git"
|
||||||
- If unsetting the config fails, including in a read-only repo, or
|
- If unsetting the config fails, including in a read-only repo, or
|
||||||
- when the config is not set, returns Nothing.
|
- when the config is not set, returns Nothing.
|
||||||
-}
|
-}
|
||||||
unset :: String -> Repo -> IO (Maybe Repo)
|
unset :: S.ByteString -> Repo -> IO (Maybe Repo)
|
||||||
unset k r = ifM (Git.Command.runBool ps r)
|
unset k r = ifM (Git.Command.runBool ps r)
|
||||||
( return $ Just $ r { config = M.delete k (config r) }
|
( return $ Just $ r { config = M.delete k (config r) }
|
||||||
, return Nothing
|
, return Nothing
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
ps = [Param "config", Param "--unset-all", Param k]
|
ps = [Param "config", Param "--unset-all", Param (decodeBS' k)]
|
||||||
|
|
|
@ -5,9 +5,12 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Git.ConfigTypes where
|
module Git.ConfigTypes where
|
||||||
|
|
||||||
import Data.Char
|
import Data.Char
|
||||||
|
import qualified Data.ByteString.Char8 as S8
|
||||||
|
|
||||||
import Common
|
import Common
|
||||||
import Git
|
import Git
|
||||||
|
@ -18,7 +21,7 @@ data SharedRepository = UnShared | GroupShared | AllShared | UmaskShared Int
|
||||||
|
|
||||||
getSharedRepository :: Repo -> SharedRepository
|
getSharedRepository :: Repo -> SharedRepository
|
||||||
getSharedRepository r =
|
getSharedRepository r =
|
||||||
case map toLower $ Git.Config.get "core.sharedrepository" "" r of
|
case S8.map toLower $ Git.Config.get "core.sharedrepository" "" r of
|
||||||
"1" -> GroupShared
|
"1" -> GroupShared
|
||||||
"2" -> AllShared
|
"2" -> AllShared
|
||||||
"group" -> GroupShared
|
"group" -> GroupShared
|
||||||
|
@ -26,14 +29,14 @@ getSharedRepository r =
|
||||||
"all" -> AllShared
|
"all" -> AllShared
|
||||||
"world" -> AllShared
|
"world" -> AllShared
|
||||||
"everybody" -> AllShared
|
"everybody" -> AllShared
|
||||||
v -> maybe UnShared UmaskShared (readish v)
|
v -> maybe UnShared UmaskShared (readish (decodeBS' v))
|
||||||
|
|
||||||
data DenyCurrentBranch = UpdateInstead | RefusePush | WarnPush | IgnorePush
|
data DenyCurrentBranch = UpdateInstead | RefusePush | WarnPush | IgnorePush
|
||||||
deriving (Eq)
|
deriving (Eq)
|
||||||
|
|
||||||
getDenyCurrentBranch :: Repo -> DenyCurrentBranch
|
getDenyCurrentBranch :: Repo -> DenyCurrentBranch
|
||||||
getDenyCurrentBranch r =
|
getDenyCurrentBranch r =
|
||||||
case map toLower $ Git.Config.get "receive.denycurrentbranch" "" r of
|
case S8.map toLower $ Git.Config.get "receive.denycurrentbranch" "" r of
|
||||||
"updateinstead" -> UpdateInstead
|
"updateinstead" -> UpdateInstead
|
||||||
"warn" -> WarnPush
|
"warn" -> WarnPush
|
||||||
"ignore" -> IgnorePush
|
"ignore" -> IgnorePush
|
||||||
|
|
|
@ -28,6 +28,7 @@ import System.Posix.User
|
||||||
#endif
|
#endif
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
import Network.URI
|
import Network.URI
|
||||||
|
import qualified Data.ByteString as S
|
||||||
|
|
||||||
import Common
|
import Common
|
||||||
import Git.Types
|
import Git.Types
|
||||||
|
@ -128,7 +129,7 @@ fromRemotes repo = mapM construct remotepairs
|
||||||
filterconfig f = filter f $ M.toList $ config repo
|
filterconfig f = filter f $ M.toList $ config repo
|
||||||
filterkeys f = filterconfig (\(k,_) -> f k)
|
filterkeys f = filterconfig (\(k,_) -> f k)
|
||||||
remotepairs = filterkeys isRemoteKey
|
remotepairs = filterkeys isRemoteKey
|
||||||
construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo
|
construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (decodeBS' v) repo)
|
||||||
|
|
||||||
{- Sets the name of a remote when constructing the Repo to represent it. -}
|
{- Sets the name of a remote when constructing the Repo to represent it. -}
|
||||||
remoteNamed :: String -> IO Repo -> IO Repo
|
remoteNamed :: String -> IO Repo -> IO Repo
|
||||||
|
@ -138,7 +139,7 @@ remoteNamed n constructor = do
|
||||||
|
|
||||||
{- Sets the name of a remote based on the git config key, such as
|
{- Sets the name of a remote based on the git config key, such as
|
||||||
- "remote.foo.url". -}
|
- "remote.foo.url". -}
|
||||||
remoteNamedFromKey :: String -> IO Repo -> IO Repo
|
remoteNamedFromKey :: S.ByteString -> IO Repo -> IO Repo
|
||||||
remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName
|
remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName
|
||||||
|
|
||||||
{- Constructs a new Repo for one of a Repo's remotes using a given
|
{- Constructs a new Repo for one of a Repo's remotes using a given
|
||||||
|
|
|
@ -7,6 +7,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Git.GCrypt where
|
module Git.GCrypt where
|
||||||
|
|
||||||
import Common
|
import Common
|
||||||
|
@ -16,6 +18,8 @@ import qualified Git.Config as Config
|
||||||
import qualified Git.Command as Command
|
import qualified Git.Command as Command
|
||||||
import Utility.Gpg
|
import Utility.Gpg
|
||||||
|
|
||||||
|
import qualified Data.ByteString as S
|
||||||
|
|
||||||
urlScheme :: String
|
urlScheme :: String
|
||||||
urlScheme = "gcrypt:"
|
urlScheme = "gcrypt:"
|
||||||
|
|
||||||
|
@ -75,9 +79,9 @@ type GCryptId = String
|
||||||
- which is stored in the repository (in encrypted form)
|
- which is stored in the repository (in encrypted form)
|
||||||
- and cached in a per-remote gcrypt-id configuration setting. -}
|
- and cached in a per-remote gcrypt-id configuration setting. -}
|
||||||
remoteRepoId :: Repo -> Maybe RemoteName -> Maybe GCryptId
|
remoteRepoId :: Repo -> Maybe RemoteName -> Maybe GCryptId
|
||||||
remoteRepoId = getRemoteConfig "gcrypt-id"
|
remoteRepoId r n = decodeBS' <$> getRemoteConfig "gcrypt-id" r n
|
||||||
|
|
||||||
getRemoteConfig :: String -> Repo -> Maybe RemoteName -> Maybe String
|
getRemoteConfig :: S.ByteString -> Repo -> Maybe RemoteName -> Maybe S.ByteString
|
||||||
getRemoteConfig field repo remotename = do
|
getRemoteConfig field repo remotename = do
|
||||||
n <- remotename
|
n <- remotename
|
||||||
Config.getMaybe (remoteConfigKey field n) repo
|
Config.getMaybe (remoteConfigKey field n) repo
|
||||||
|
@ -93,17 +97,17 @@ getParticiantList globalconfigrepo repo remotename = KeyIds $ parse $ firstJust
|
||||||
where
|
where
|
||||||
defaultkey = "gcrypt.participants"
|
defaultkey = "gcrypt.participants"
|
||||||
parse (Just "simple") = []
|
parse (Just "simple") = []
|
||||||
parse (Just l) = words l
|
parse (Just b) = words (decodeBS' b)
|
||||||
parse Nothing = []
|
parse Nothing = []
|
||||||
|
|
||||||
remoteParticipantConfigKey :: RemoteName -> String
|
remoteParticipantConfigKey :: RemoteName -> S.ByteString
|
||||||
remoteParticipantConfigKey = remoteConfigKey "gcrypt-participants"
|
remoteParticipantConfigKey = remoteConfigKey "gcrypt-participants"
|
||||||
|
|
||||||
remotePublishParticipantConfigKey :: RemoteName -> String
|
remotePublishParticipantConfigKey :: RemoteName -> S.ByteString
|
||||||
remotePublishParticipantConfigKey = remoteConfigKey "gcrypt-publish-participants"
|
remotePublishParticipantConfigKey = remoteConfigKey "gcrypt-publish-participants"
|
||||||
|
|
||||||
remoteSigningKey :: RemoteName -> String
|
remoteSigningKey :: RemoteName -> S.ByteString
|
||||||
remoteSigningKey = remoteConfigKey "gcrypt-signingkey"
|
remoteSigningKey = remoteConfigKey "gcrypt-signingkey"
|
||||||
|
|
||||||
remoteConfigKey :: String -> RemoteName -> String
|
remoteConfigKey :: S.ByteString -> RemoteName -> S.ByteString
|
||||||
remoteConfigKey key remotename = "remote." ++ remotename ++ "." ++ key
|
remoteConfigKey key remotename = "remote." <> encodeBS' remotename <> "." <> key
|
||||||
|
|
|
@ -6,6 +6,7 @@
|
||||||
-}
|
-}
|
||||||
|
|
||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Git.Remote where
|
module Git.Remote where
|
||||||
|
|
||||||
|
@ -15,18 +16,20 @@ import Git.Types
|
||||||
|
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
|
import qualified Data.ByteString as S
|
||||||
|
import qualified Data.ByteString.Char8 as S8
|
||||||
import Network.URI
|
import Network.URI
|
||||||
#ifdef mingw32_HOST_OS
|
#ifdef mingw32_HOST_OS
|
||||||
import Git.FilePath
|
import Git.FilePath
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
{- Is a git config key one that specifies the location of a remote? -}
|
{- Is a git config key one that specifies the location of a remote? -}
|
||||||
isRemoteKey :: String -> Bool
|
isRemoteKey :: S.ByteString -> Bool
|
||||||
isRemoteKey k = "remote." `isPrefixOf` k && ".url" `isSuffixOf` k
|
isRemoteKey k = "remote." `S.isPrefixOf` k && ".url" `S.isSuffixOf` k
|
||||||
|
|
||||||
{- Get a remote's name from the config key that specifies its location. -}
|
{- Get a remote's name from the config key that specifies its location. -}
|
||||||
remoteKeyToRemoteName :: String -> RemoteName
|
remoteKeyToRemoteName :: S.ByteString -> RemoteName
|
||||||
remoteKeyToRemoteName k = intercalate "." $ dropFromEnd 1 $ drop 1 $ splitc '.' k
|
remoteKeyToRemoteName = decodeBS' . S.intercalate "." . dropFromEnd 1 . drop 1 . S8.split '.'
|
||||||
|
|
||||||
{- Construct a legal git remote name out of an arbitrary input string.
|
{- Construct a legal git remote name out of an arbitrary input string.
|
||||||
-
|
-
|
||||||
|
@ -76,16 +79,16 @@ parseRemoteLocation s repo = ret $ calcloc s
|
||||||
-- insteadof config can rewrite remote location
|
-- insteadof config can rewrite remote location
|
||||||
calcloc l
|
calcloc l
|
||||||
| null insteadofs = l
|
| null insteadofs = l
|
||||||
| otherwise = replacement ++ drop (length bestvalue) l
|
| otherwise = replacement ++ drop (S.length bestvalue) l
|
||||||
where
|
where
|
||||||
replacement = drop (length prefix) $
|
replacement = decodeBS' $ S.drop (S.length prefix) $
|
||||||
take (length bestkey - length suffix) bestkey
|
S.take (S.length bestkey - S.length suffix) bestkey
|
||||||
(bestkey, bestvalue) = maximumBy longestvalue insteadofs
|
(bestkey, bestvalue) = maximumBy longestvalue insteadofs
|
||||||
longestvalue (_, a) (_, b) = compare b a
|
longestvalue (_, a) (_, b) = compare b a
|
||||||
insteadofs = filterconfig $ \(k, v) ->
|
insteadofs = filterconfig $ \(k, v) ->
|
||||||
prefix `isPrefixOf` k &&
|
prefix `S.isPrefixOf` k &&
|
||||||
suffix `isSuffixOf` k &&
|
suffix `S.isSuffixOf` k &&
|
||||||
v `isPrefixOf` l
|
v `S.isPrefixOf` encodeBS l
|
||||||
filterconfig f = filter f $
|
filterconfig f = filter f $
|
||||||
concatMap splitconfigs $ M.toList $ fullconfig repo
|
concatMap splitconfigs $ M.toList $ fullconfig repo
|
||||||
splitconfigs (k, vs) = map (\v -> (k, v)) vs
|
splitconfigs (k, vs) = map (\v -> (k, v)) vs
|
||||||
|
|
|
@ -35,9 +35,9 @@ data RepoLocation
|
||||||
|
|
||||||
data Repo = Repo
|
data Repo = Repo
|
||||||
{ location :: RepoLocation
|
{ location :: RepoLocation
|
||||||
, config :: M.Map String String
|
, config :: M.Map S.ByteString S.ByteString
|
||||||
-- a given git config key can actually have multiple values
|
-- a given git config key can actually have multiple values
|
||||||
, fullconfig :: M.Map String [String]
|
, fullconfig :: M.Map S.ByteString [S.ByteString]
|
||||||
-- remoteName holds the name used for this repo in some other
|
-- remoteName holds the name used for this repo in some other
|
||||||
-- repo's list of remotes, when this repo is such a remote
|
-- repo's list of remotes, when this repo is such a remote
|
||||||
, remoteName :: Maybe RemoteName
|
, remoteName :: Maybe RemoteName
|
||||||
|
|
|
@ -147,10 +147,12 @@ byName' n = go . filter matching <$> remoteList
|
||||||
|
|
||||||
{- Finds the remote or remote group matching the name. -}
|
{- Finds the remote or remote group matching the name. -}
|
||||||
byNameOrGroup :: RemoteName -> Annex [Remote]
|
byNameOrGroup :: RemoteName -> Annex [Remote]
|
||||||
byNameOrGroup n = go =<< getConfigMaybe (ConfigKey ("remotes." ++ n))
|
byNameOrGroup n = go =<< getConfigMaybe (ConfigKey ("remotes." <> encodeBS' n))
|
||||||
where
|
where
|
||||||
go (Just l) = catMaybes <$> mapM (byName . Just) (splitc ' ' l)
|
go (Just l) = catMaybes
|
||||||
go Nothing = maybeToList <$> byName (Just n)
|
<$> mapM (byName . Just) (splitc ' ' (decodeBS' l))
|
||||||
|
go Nothing = maybeToList
|
||||||
|
<$> byName (Just n)
|
||||||
|
|
||||||
{- Only matches remote name, not UUID -}
|
{- Only matches remote name, not UUID -}
|
||||||
byNameOnly :: RemoteName -> Annex (Maybe Remote)
|
byNameOnly :: RemoteName -> Annex (Maybe Remote)
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Remote.GCrypt (
|
module Remote.GCrypt (
|
||||||
remote,
|
remote,
|
||||||
chainGen,
|
chainGen,
|
||||||
|
@ -16,6 +18,7 @@ module Remote.GCrypt (
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
|
import qualified Data.ByteString as S
|
||||||
import qualified Data.ByteString.Lazy as L
|
import qualified Data.ByteString.Lazy as L
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
import Data.Default
|
import Data.Default
|
||||||
|
@ -159,11 +162,12 @@ rsyncTransportToObjects r gc = do
|
||||||
|
|
||||||
rsyncTransport :: Git.Repo -> RemoteGitConfig -> Annex (Annex [CommandParam], String, AccessMethod)
|
rsyncTransport :: Git.Repo -> RemoteGitConfig -> Annex (Annex [CommandParam], String, AccessMethod)
|
||||||
rsyncTransport r gc
|
rsyncTransport r gc
|
||||||
| "ssh://" `isPrefixOf` loc = sshtransport $ break (== '/') $ drop (length "ssh://") loc
|
| sshprefix `isPrefixOf` loc = sshtransport $ break (== '/') $ drop (length sshprefix) loc
|
||||||
| "//:" `isInfixOf` loc = othertransport
|
| "//:" `isInfixOf` loc = othertransport
|
||||||
| ":" `isInfixOf` loc = sshtransport $ separate (== ':') loc
|
| ":" `isInfixOf` loc = sshtransport $ separate (== ':') loc
|
||||||
| otherwise = othertransport
|
| otherwise = othertransport
|
||||||
where
|
where
|
||||||
|
sshprefix = "ssh://" :: String
|
||||||
loc = Git.repoLocation r
|
loc = Git.repoLocation r
|
||||||
sshtransport (host, path) = do
|
sshtransport (host, path) = do
|
||||||
let rsyncpath = if "/~/" `isPrefixOf` path
|
let rsyncpath = if "/~/" `isPrefixOf` path
|
||||||
|
@ -252,7 +256,7 @@ setupRepo gcryptid r
|
||||||
| otherwise = localsetup r
|
| otherwise = localsetup r
|
||||||
where
|
where
|
||||||
localsetup r' = do
|
localsetup r' = do
|
||||||
let setconfig k v = liftIO $ Git.Command.run [Param "config", Param k, Param v] r'
|
let setconfig k v = liftIO $ Git.Command.run [Param "config", Param (decodeBS' k), Param v] r'
|
||||||
setconfig coreGCryptId gcryptid
|
setconfig coreGCryptId gcryptid
|
||||||
setconfig denyNonFastForwards (Git.Config.boolConfig False)
|
setconfig denyNonFastForwards (Git.Config.boolConfig False)
|
||||||
return AccessDirect
|
return AccessDirect
|
||||||
|
@ -272,8 +276,8 @@ setupRepo gcryptid r
|
||||||
, Param tmpconfig
|
, Param tmpconfig
|
||||||
]
|
]
|
||||||
liftIO $ do
|
liftIO $ do
|
||||||
void $ Git.Config.changeFile tmpconfig coreGCryptId gcryptid
|
void $ Git.Config.changeFile tmpconfig coreGCryptId (encodeBS' gcryptid)
|
||||||
void $ Git.Config.changeFile tmpconfig denyNonFastForwards (Git.Config.boolConfig False)
|
void $ Git.Config.changeFile tmpconfig denyNonFastForwards (Git.Config.boolConfig' False)
|
||||||
ok <- liftIO $ rsync $ opts ++
|
ok <- liftIO $ rsync $ opts ++
|
||||||
[ Param "--recursive"
|
[ Param "--recursive"
|
||||||
, Param $ tmp ++ "/"
|
, Param $ tmp ++ "/"
|
||||||
|
@ -435,7 +439,7 @@ getGCryptUUID fast r = do
|
||||||
(genUUIDInNameSpace gCryptNameSpace <$>) . fst
|
(genUUIDInNameSpace gCryptNameSpace <$>) . fst
|
||||||
<$> getGCryptId fast r dummycfg
|
<$> getGCryptId fast r dummycfg
|
||||||
|
|
||||||
coreGCryptId :: String
|
coreGCryptId :: S.ByteString
|
||||||
coreGCryptId = "core.gcrypt-id"
|
coreGCryptId = "core.gcrypt-id"
|
||||||
|
|
||||||
{- gcrypt repos set up by git-annex as special remotes have a
|
{- gcrypt repos set up by git-annex as special remotes have a
|
||||||
|
@ -457,9 +461,9 @@ getGCryptId fast r gc
|
||||||
| otherwise = return (Nothing, r)
|
| otherwise = return (Nothing, r)
|
||||||
where
|
where
|
||||||
extract Nothing = (Nothing, r)
|
extract Nothing = (Nothing, r)
|
||||||
extract (Just r') = (Git.Config.getMaybe coreGCryptId r', r')
|
extract (Just r') = (decodeBS' <$> Git.Config.getMaybe coreGCryptId r', r')
|
||||||
|
|
||||||
getConfigViaRsync :: Git.Repo -> RemoteGitConfig -> Annex (Either SomeException (Git.Repo, String))
|
getConfigViaRsync :: Git.Repo -> RemoteGitConfig -> Annex (Either SomeException (Git.Repo, S.ByteString))
|
||||||
getConfigViaRsync r gc = do
|
getConfigViaRsync r gc = do
|
||||||
(rsynctransport, rsyncurl, _) <- rsyncTransport r gc
|
(rsynctransport, rsyncurl, _) <- rsyncTransport r gc
|
||||||
opts <- rsynctransport
|
opts <- rsynctransport
|
||||||
|
|
|
@ -6,6 +6,7 @@
|
||||||
-}
|
-}
|
||||||
|
|
||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Remote.Git (
|
module Remote.Git (
|
||||||
remote,
|
remote,
|
||||||
|
@ -68,6 +69,7 @@ import Utility.FileMode
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import Control.Concurrent.MSampleVar
|
import Control.Concurrent.MSampleVar
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
|
import qualified Data.ByteString as S
|
||||||
import Network.URI
|
import Network.URI
|
||||||
|
|
||||||
remote :: RemoteType
|
remote :: RemoteType
|
||||||
|
@ -86,14 +88,14 @@ list autoinit = do
|
||||||
rs <- mapM (tweakurl c) =<< Annex.getGitRemotes
|
rs <- mapM (tweakurl c) =<< Annex.getGitRemotes
|
||||||
mapM (configRead autoinit) rs
|
mapM (configRead autoinit) rs
|
||||||
where
|
where
|
||||||
annexurl n = "remote." ++ n ++ ".annexurl"
|
annexurl n = "remote." <> encodeBS' n <> ".annexurl"
|
||||||
tweakurl c r = do
|
tweakurl c r = do
|
||||||
let n = fromJust $ Git.remoteName r
|
let n = fromJust $ Git.remoteName r
|
||||||
case M.lookup (annexurl n) c of
|
case M.lookup (annexurl n) c of
|
||||||
Nothing -> return r
|
Nothing -> return r
|
||||||
Just url -> inRepo $ \g ->
|
Just url -> inRepo $ \g ->
|
||||||
Git.Construct.remoteNamed n $
|
Git.Construct.remoteNamed n $
|
||||||
Git.Construct.fromRemoteLocation url g
|
Git.Construct.fromRemoteLocation (decodeBS' url) g
|
||||||
|
|
||||||
{- Git remotes are normally set up using standard git command, not
|
{- Git remotes are normally set up using standard git command, not
|
||||||
- git-annex initremote and enableremote.
|
- git-annex initremote and enableremote.
|
||||||
|
@ -254,7 +256,7 @@ tryGitConfigRead autoinit r
|
||||||
v <- liftIO $ Git.Config.fromPipe r cmd params
|
v <- liftIO $ Git.Config.fromPipe r cmd params
|
||||||
case v of
|
case v of
|
||||||
Right (r', val) -> do
|
Right (r', val) -> do
|
||||||
unless (isUUIDConfigured r' || null val) $ do
|
unless (isUUIDConfigured r' || S.null val) $ do
|
||||||
warning $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r
|
warning $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r
|
||||||
warning $ "Instead, got: " ++ show val
|
warning $ "Instead, got: " ++ show val
|
||||||
warning $ "This is unexpected; please check the network transport!"
|
warning $ "This is unexpected; please check the network transport!"
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Remote.GitLFS (remote, gen, configKnownUrl) where
|
module Remote.GitLFS (remote, gen, configKnownUrl) where
|
||||||
|
|
||||||
import Annex.Common
|
import Annex.Common
|
||||||
|
@ -153,7 +155,7 @@ mySetup _ mu _ c gc = do
|
||||||
-- (so it's also usable by git as a non-special remote),
|
-- (so it's also usable by git as a non-special remote),
|
||||||
-- and set remote.name.annex-git-lfs = true
|
-- and set remote.name.annex-git-lfs = true
|
||||||
gitConfigSpecialRemote u c' [("git-lfs", "true")]
|
gitConfigSpecialRemote u c' [("git-lfs", "true")]
|
||||||
setConfig (ConfigKey ("remote." ++ getRemoteName c ++ ".url")) url
|
setConfig (ConfigKey ("remote." <> encodeBS' (getRemoteName c) <> ".url")) url
|
||||||
return (c', u)
|
return (c', u)
|
||||||
where
|
where
|
||||||
url = fromMaybe (giveup "Specify url=") (M.lookup "url" c)
|
url = fromMaybe (giveup "Specify url=") (M.lookup "url" c)
|
||||||
|
@ -187,7 +189,7 @@ configKnownUrl r
|
||||||
set k v r' = do
|
set k v r' = do
|
||||||
let ck@(ConfigKey k') = remoteConfig r' k
|
let ck@(ConfigKey k') = remoteConfig r' k
|
||||||
setConfig ck v
|
setConfig ck v
|
||||||
return $ Git.Config.store' k' v r'
|
return $ Git.Config.store' k' (encodeBS' v) r'
|
||||||
|
|
||||||
data LFSHandle = LFSHandle
|
data LFSHandle = LFSHandle
|
||||||
{ downloadEndpoint :: Maybe LFS.Endpoint
|
{ downloadEndpoint :: Maybe LFS.Endpoint
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Remote.Helper.Special (
|
module Remote.Helper.Special (
|
||||||
findSpecialRemotes,
|
findSpecialRemotes,
|
||||||
gitConfigSpecialRemote,
|
gitConfigSpecialRemote,
|
||||||
|
@ -52,6 +54,7 @@ import Messages.Progress
|
||||||
import qualified Git
|
import qualified Git
|
||||||
import qualified Git.Construct
|
import qualified Git.Construct
|
||||||
|
|
||||||
|
import qualified Data.ByteString as S
|
||||||
import qualified Data.ByteString.Lazy as L
|
import qualified Data.ByteString.Lazy as L
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
|
|
||||||
|
@ -65,14 +68,15 @@ findSpecialRemotes s = do
|
||||||
liftIO $ mapM construct $ remotepairs m
|
liftIO $ mapM construct $ remotepairs m
|
||||||
where
|
where
|
||||||
remotepairs = M.toList . M.filterWithKey match
|
remotepairs = M.toList . M.filterWithKey match
|
||||||
construct (k,_) = Git.Construct.remoteNamedFromKey k (pure Git.Construct.fromUnknown)
|
construct (k,_) = Git.Construct.remoteNamedFromKey k
|
||||||
match k _ = "remote." `isPrefixOf` k && (".annex-"++s) `isSuffixOf` k
|
(pure Git.Construct.fromUnknown)
|
||||||
|
match k _ = "remote." `S.isPrefixOf` k && (".annex-" <> encodeBS' s) `S.isSuffixOf` k
|
||||||
|
|
||||||
{- Sets up configuration for a special remote in .git/config. -}
|
{- Sets up configuration for a special remote in .git/config. -}
|
||||||
gitConfigSpecialRemote :: UUID -> RemoteConfig -> [(String, String)] -> Annex ()
|
gitConfigSpecialRemote :: UUID -> RemoteConfig -> [(String, String)] -> Annex ()
|
||||||
gitConfigSpecialRemote u c cfgs = do
|
gitConfigSpecialRemote u c cfgs = do
|
||||||
forM_ cfgs $ \(k, v) ->
|
forM_ cfgs $ \(k, v) ->
|
||||||
setConfig (remoteConfig c k) v
|
setConfig (remoteConfig c (encodeBS' k)) v
|
||||||
storeUUIDIn (remoteConfig c "uuid") u
|
storeUUIDIn (remoteConfig c "uuid") u
|
||||||
|
|
||||||
-- RetrievalVerifiableKeysSecure unless overridden by git config.
|
-- RetrievalVerifiableKeysSecure unless overridden by git config.
|
||||||
|
|
|
@ -88,8 +88,8 @@ inmainrepo a = do
|
||||||
|
|
||||||
with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion)
|
with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion)
|
||||||
with_ssh_origin cloner a = cloner $ do
|
with_ssh_origin cloner a = cloner $ do
|
||||||
origindir <- absPath
|
origindir <- absPath . decodeBS'
|
||||||
=<< annexeval (Config.getConfig (Config.ConfigKey config) "/dev/null")
|
=<< annexeval (Config.getConfig (Config.ConfigKey (encodeBS' config)) (toRawFilePath "/dev/null"))
|
||||||
let originurl = "localhost:" ++ origindir
|
let originurl = "localhost:" ++ origindir
|
||||||
boolSystem "git" [Param "config", Param config, Param originurl] @? "git config failed"
|
boolSystem "git" [Param "config", Param config, Param originurl] @? "git config failed"
|
||||||
a
|
a
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Types.Difference (
|
module Types.Difference (
|
||||||
Difference(..),
|
Difference(..),
|
||||||
Differences(..),
|
Differences(..),
|
||||||
|
@ -23,6 +25,7 @@ import qualified Git.Config
|
||||||
|
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
|
import qualified Data.ByteString as B
|
||||||
import qualified Data.Set as S
|
import qualified Data.Set as S
|
||||||
import qualified Data.Semigroup as Sem
|
import qualified Data.Semigroup as Sem
|
||||||
import Prelude
|
import Prelude
|
||||||
|
@ -92,11 +95,11 @@ getDifferences :: Git.Repo -> Differences
|
||||||
getDifferences r = mkDifferences $ S.fromList $
|
getDifferences r = mkDifferences $ S.fromList $
|
||||||
mapMaybe getmaybe [minBound .. maxBound]
|
mapMaybe getmaybe [minBound .. maxBound]
|
||||||
where
|
where
|
||||||
getmaybe d = case Git.Config.isTrue =<< Git.Config.getMaybe (differenceConfigKey d) r of
|
getmaybe d = case Git.Config.isTrue' =<< Git.Config.getMaybe (differenceConfigKey d) r of
|
||||||
Just True -> Just d
|
Just True -> Just d
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
differenceConfigKey :: Difference -> String
|
differenceConfigKey :: Difference -> B.ByteString
|
||||||
differenceConfigKey ObjectHashLower = tunable "objecthashlower"
|
differenceConfigKey ObjectHashLower = tunable "objecthashlower"
|
||||||
differenceConfigKey OneLevelObjectHash = tunable "objecthash1"
|
differenceConfigKey OneLevelObjectHash = tunable "objecthash1"
|
||||||
differenceConfigKey OneLevelBranchHash = tunable "branchhash1"
|
differenceConfigKey OneLevelBranchHash = tunable "branchhash1"
|
||||||
|
@ -104,8 +107,8 @@ differenceConfigKey OneLevelBranchHash = tunable "branchhash1"
|
||||||
differenceConfigVal :: Difference -> String
|
differenceConfigVal :: Difference -> String
|
||||||
differenceConfigVal _ = Git.Config.boolConfig True
|
differenceConfigVal _ = Git.Config.boolConfig True
|
||||||
|
|
||||||
tunable :: String -> String
|
tunable :: B.ByteString -> B.ByteString
|
||||||
tunable k = "annex.tune." ++ k
|
tunable k = "annex.tune." <> k
|
||||||
|
|
||||||
hasDifference :: Difference -> Differences -> Bool
|
hasDifference :: Difference -> Differences -> Bool
|
||||||
hasDifference _ UnknownDifferences = False
|
hasDifference _ UnknownDifferences = False
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Types.GitConfig (
|
module Types.GitConfig (
|
||||||
Configurable(..),
|
Configurable(..),
|
||||||
GitConfig(..),
|
GitConfig(..),
|
||||||
|
@ -199,16 +201,17 @@ extractGitConfig r = GitConfig
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
getbool k d = fromMaybe d $ getmaybebool k
|
getbool k d = fromMaybe d $ getmaybebool k
|
||||||
getmaybebool k = Git.Config.isTrue =<< getmaybe k
|
getmaybebool k = Git.Config.isTrue' =<< getmaybe' k
|
||||||
getmayberead k = readish =<< getmaybe k
|
getmayberead k = readish =<< getmaybe k
|
||||||
getmaybe k = Git.Config.getMaybe k r
|
getmaybe = fmap decodeBS' . getmaybe'
|
||||||
getlist k = Git.Config.getList k r
|
getmaybe' k = Git.Config.getMaybe k r
|
||||||
|
getlist k = map decodeBS' $ Git.Config.getList k r
|
||||||
getwords k = fromMaybe [] $ words <$> getmaybe k
|
getwords k = fromMaybe [] $ words <$> getmaybe k
|
||||||
|
|
||||||
configurable d Nothing = DefaultConfig d
|
configurable d Nothing = DefaultConfig d
|
||||||
configurable _ (Just v) = HasConfig v
|
configurable _ (Just v) = HasConfig v
|
||||||
|
|
||||||
annex k = "annex." ++ k
|
annex k = "annex." <> k
|
||||||
|
|
||||||
onemegabyte = 1000000
|
onemegabyte = 1000000
|
||||||
|
|
||||||
|
@ -340,14 +343,15 @@ extractRemoteGitConfig r remotename = do
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
getbool k d = fromMaybe d $ getmaybebool k
|
getbool k d = fromMaybe d $ getmaybebool k
|
||||||
getmaybebool k = Git.Config.isTrue =<< getmaybe k
|
getmaybebool k = Git.Config.isTrue' =<< getmaybe' k
|
||||||
getmayberead k = readish =<< getmaybe k
|
getmayberead k = readish =<< getmaybe k
|
||||||
getmaybe k = mplus (Git.Config.getMaybe (key k) r)
|
getmaybe = fmap decodeBS' . getmaybe'
|
||||||
|
getmaybe' k = mplus (Git.Config.getMaybe (key k) r)
|
||||||
(Git.Config.getMaybe (remotekey k) r)
|
(Git.Config.getMaybe (remotekey k) r)
|
||||||
getoptions k = fromMaybe [] $ words <$> getmaybe k
|
getoptions k = fromMaybe [] $ words <$> getmaybe k
|
||||||
|
|
||||||
key k = "annex." ++ k
|
key k = "annex." <> k
|
||||||
remotekey k = "remote." ++ remotename ++ ".annex-" ++ k
|
remotekey k = "remote." <> encodeBS' remotename <> ".annex-" <> k
|
||||||
|
|
||||||
notempty :: Maybe String -> Maybe String
|
notempty :: Maybe String -> Maybe String
|
||||||
notempty Nothing = Nothing
|
notempty Nothing = Nothing
|
||||||
|
|
|
@ -7,6 +7,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Upgrade.V5.Direct (
|
module Upgrade.V5.Direct (
|
||||||
switchHEADBack,
|
switchHEADBack,
|
||||||
setIndirect,
|
setIndirect,
|
||||||
|
@ -49,7 +51,7 @@ setIndirect = do
|
||||||
Nothing -> noop
|
Nothing -> noop
|
||||||
Just wt -> do
|
Just wt -> do
|
||||||
unsetConfig src
|
unsetConfig src
|
||||||
setConfig dest wt
|
setConfig dest (decodeBS' wt)
|
||||||
reloadConfig
|
reloadConfig
|
||||||
|
|
||||||
{- Converts a directBranch back to the original branch.
|
{- Converts a directBranch back to the original branch.
|
||||||
|
|
|
@ -29,5 +29,3 @@ the `bs` branch has quite a lot of things still needing work, including:
|
||||||
avoiding a conversion. Note that these are only available on unix, not
|
avoiding a conversion. Note that these are only available on unix, not
|
||||||
windows, so a compatability shim will be needed.
|
windows, so a compatability shim will be needed.
|
||||||
(I can't seem to find any library that provides one.)
|
(I can't seem to find any library that provides one.)
|
||||||
|
|
||||||
* Use ByteString for parsing git config to speed up startup.
|
|
||||||
|
|
Loading…
Reference in a new issue