aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Annex/Branch.hs3
-rw-r--r--Annex/Ssh.hs5
-rw-r--r--Backend.hs1
-rw-r--r--Command/Map.hs13
-rw-r--r--Config.hs2
-rw-r--r--Git.hs148
-rw-r--r--Git/Branch.hs5
-rw-r--r--Git/CatFile.hs5
-rw-r--r--Git/Construct.hs27
-rw-r--r--Git/HashObject.hs4
-rw-r--r--Git/Index.hs24
-rw-r--r--Git/Ref.hs6
-rw-r--r--Git/Sha.hs27
-rw-r--r--Git/UnionMerge.hs5
-rw-r--r--Git/Url.hs70
-rw-r--r--Remote/Git.hs17
-rw-r--r--Remote/Helper/Special.hs6
-rw-r--r--Remote/Web.hs4
-rw-r--r--git-union-merge.hs3
-rw-r--r--test.hs1
20 files changed, 197 insertions, 179 deletions
diff --git a/Annex/Branch.hs b/Annex/Branch.hs
index a2ecd50a7..a22a4adcf 100644
--- a/Annex/Branch.hs
+++ b/Annex/Branch.hs
@@ -28,6 +28,7 @@ import qualified Git.Ref
import qualified Git.Branch
import qualified Git.UnionMerge
import qualified Git.HashObject
+import qualified Git.Index
import Annex.CatFile
{- Name of the branch that is used to store git-annex's information. -}
@@ -249,7 +250,7 @@ withIndex = withIndex' False
withIndex' :: Bool -> Annex a -> Annex a
withIndex' bootstrapping a = do
f <- fromRepo gitAnnexIndex
- bracketIO (Git.useIndex f) id $ do
+ bracketIO (Git.Index.override f) id $ do
unlessM (liftIO $ doesFileExist f) $ do
unless bootstrapping create
liftIO $ createDirectoryIfMissing True $ takeDirectory f
diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs
index 6893f94ef..fe83aad00 100644
--- a/Annex/Ssh.hs
+++ b/Annex/Ssh.hs
@@ -10,6 +10,7 @@ module Annex.Ssh where
import Control.Monad.State (liftIO)
import qualified Git
+import qualified Git.Url
import Utility.SafeCommand
import Types
import Config
@@ -22,10 +23,10 @@ sshToRepo :: Git.Repo -> [CommandParam] -> Annex [CommandParam]
sshToRepo repo sshcmd = do
s <- getConfig repo "ssh-options" ""
let sshoptions = map Param (words s)
- let sshport = case Git.urlPort repo of
+ let sshport = case Git.Url.port repo of
Nothing -> []
Just p -> [Param "-p", Param (show p)]
- let sshhost = Param $ Git.urlHostUser repo
+ let sshhost = Param $ Git.Url.hostuser repo
return $ sshoptions ++ sshport ++ [sshhost] ++ sshcmd
{- Generates parameters to run a git-annex-shell command on a remote
diff --git a/Backend.hs b/Backend.hs
index 38f0629f4..4743bb202 100644
--- a/Backend.hs
+++ b/Backend.hs
@@ -20,7 +20,6 @@ import System.IO.Error (try)
import System.Posix.Files
import Common.Annex
-import qualified Git
import qualified Git.Config
import qualified Git.CheckAttr
import qualified Annex
diff --git a/Command/Map.hs b/Command/Map.hs
index 815b142e7..ae8a69404 100644
--- a/Command/Map.hs
+++ b/Command/Map.hs
@@ -13,6 +13,7 @@ import qualified Data.Map as M
import Common.Annex
import Command
import qualified Git
+import qualified Git.Url
import qualified Git.Config
import qualified Git.Construct
import Annex.UUID
@@ -68,7 +69,7 @@ drawMap rs umap ts = Dot.graph $ repos ++ trusted ++ others
hostname :: Git.Repo -> String
hostname r
- | Git.repoIsUrl r = Git.urlHost r
+ | Git.repoIsUrl r = Git.Url.host r
| otherwise = "localhost"
basehostname :: Git.Repo -> String
@@ -82,7 +83,7 @@ repoName umap r
| otherwise = M.findWithDefault fallback repouuid umap
where
repouuid = getUncachedUUID r
- fallback = fromMaybe "unknown" $ Git.repoRemoteName r
+ fallback = fromMaybe "unknown" $ Git.remoteName r
{- A unique id for the node for a repo. Uses the annex.uuid if available. -}
nodeId :: Git.Repo -> String
@@ -99,7 +100,7 @@ node umap fullinfo r = unlines $ n:edges
decorate $ Dot.graphNode (nodeId r) (repoName umap r)
edges = map (edge umap fullinfo r) (Git.remotes r)
decorate
- | Git.configMap r == M.empty = unreachable
+ | Git.config r == M.empty = unreachable
| otherwise = reachable
{- An edge between two repos. The second repo is a remote of the first. -}
@@ -116,7 +117,7 @@ edge umap fullinfo from to =
{- Only name an edge if the name is different than the name
- that will be used for the destination node, and is
- different from its hostname. (This reduces visual clutter.) -}
- edgename = maybe Nothing calcname $ Git.repoRemoteName to
+ edgename = maybe Nothing calcname $ Git.remoteName to
calcname n
| n `elem` [repoName umap fullto, hostname fullto] = Nothing
| otherwise = Just n
@@ -141,7 +142,7 @@ spider' (r:rs) known
-- The remotes will be relative to r', and need to be
-- made absolute for later use.
remotes <- mapM (absRepo r') (Git.remotes r')
- let r'' = Git.remotesAdd r' remotes
+ let r'' = r' { Git.remotes = remotes }
spider' (rs ++ remotes) (r'':known)
@@ -154,7 +155,7 @@ absRepo reference r
{- Checks if two repos are the same. -}
same :: Git.Repo -> Git.Repo -> Bool
same a b
- | both Git.repoIsSsh = matching Git.urlAuthority && matching Git.workTree
+ | both Git.repoIsSsh = matching Git.Url.authority && matching Git.workTree
| both Git.repoIsUrl && neither Git.repoIsSsh = matching show
| neither Git.repoIsSsh = matching Git.workTree
| otherwise = False
diff --git a/Config.hs b/Config.hs
index 322dc8af8..07c9eedad 100644
--- a/Config.hs
+++ b/Config.hs
@@ -31,7 +31,7 @@ getConfig r key def = do
{- Looks up a per-remote config setting in git config. -}
remoteConfig :: Git.Repo -> ConfigKey -> String
-remoteConfig r key = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-" ++ key
+remoteConfig r key = "remote." ++ fromMaybe "" (Git.remoteName r) ++ ".annex-" ++ key
{- Calculates cost for a remote. Either the default, or as configured
- by remote.<name>.annex-cost, or if remote.<name>.annex-cost-command
diff --git a/Git.hs b/Git.hs
index b4cbd91aa..a3f2ad74c 100644
--- a/Git.hs
+++ b/Git.hs
@@ -9,7 +9,7 @@
-}
module Git (
- Repo,
+ Repo(..),
Ref(..),
Branch,
Sha,
@@ -22,13 +22,6 @@ module Git (
repoLocation,
workTree,
gitDir,
- urlPath,
- urlHost,
- urlPort,
- urlHostUser,
- urlAuthority,
- urlScheme,
- configMap,
configTrue,
gitCommandLine,
run,
@@ -39,23 +32,14 @@ module Git (
pipeNullSplit,
pipeNullSplitB,
attributes,
- remotes,
- remotesAdd,
- repoRemoteName,
- repoRemoteNameSet,
- repoRemoteNameFromKey,
reap,
- useIndex,
- getSha,
- shaSize,
assertLocal,
) where
import qualified Data.Map as M
-import Network.URI
import Data.Char
-import System.Posix.Env (setEnv, unsetEnv, getEnv)
import qualified Data.ByteString.Lazy.Char8 as L
+import Network.URI (uriPath, uriScheme)
import Common
import Git.Types
@@ -73,29 +57,6 @@ repoLocation Repo { location = Url url } = show url
repoLocation Repo { location = Dir dir } = dir
repoLocation Repo { location = Unknown } = undefined
-{- Constructs and returns an updated version of a repo with
- - different remotes list. -}
-remotesAdd :: Repo -> [Repo] -> Repo
-remotesAdd repo rs = repo { remotes = rs }
-
-{- Returns the name of the remote that corresponds to the repo, if
- - it is a remote. -}
-repoRemoteName :: Repo -> Maybe String
-repoRemoteName Repo { remoteName = Just name } = Just name
-repoRemoteName _ = Nothing
-
-{- Sets the name of a remote. -}
-repoRemoteNameSet :: String -> Repo -> Repo
-repoRemoteNameSet n r = r { remoteName = Just n }
-
-{- Sets the name of a remote based on the git config key, such as
- "remote.foo.url". -}
-repoRemoteNameFromKey :: String -> Repo -> Repo
-repoRemoteNameFromKey k = repoRemoteNameSet basename
- where
- basename = join "." $ reverse $ drop 1 $
- reverse $ drop 1 $ split "." k
-
{- Some code needs to vary between URL and normal repos,
- or bare and non-bare, these functions help with that. -}
repoIsUrl :: Repo -> Bool
@@ -104,11 +65,13 @@ repoIsUrl _ = False
repoIsSsh :: Repo -> Bool
repoIsSsh Repo { location = Url url }
- | uriScheme url == "ssh:" = True
+ | scheme == "ssh:" = True
-- git treats these the same as ssh
- | uriScheme url == "git+ssh:" = True
- | uriScheme url == "ssh+git:" = True
+ | scheme == "git+ssh:" = True
+ | scheme == "ssh+git:" = True
| otherwise = False
+ where
+ scheme = uriScheme url
repoIsSsh _ = False
repoIsHttp :: Repo -> Bool
@@ -129,15 +92,8 @@ assertLocal :: Repo -> a -> a
assertLocal repo action =
if not $ repoIsUrl repo
then action
- else error $ "acting on URL git repo " ++ repoDescribe repo ++
+ else error $ "acting on non-local git repo " ++ repoDescribe repo ++
" not supported"
-assertUrl :: Repo -> a -> a
-assertUrl repo action =
- if repoIsUrl repo
- then action
- else error $ "acting on local git repo " ++ repoDescribe repo ++
- " not supported"
-
configBare :: Repo -> Bool
configBare repo = maybe unknown configTrue $ M.lookup "core.bare" $ config repo
where
@@ -161,61 +117,10 @@ gitDir repo
-
- Note that for URL repositories, this is the path on the remote host. -}
workTree :: Repo -> FilePath
-workTree r@(Repo { location = Url _ }) = urlPath r
-workTree (Repo { location = Dir d }) = d
+workTree Repo { location = Url u } = uriPath u
+workTree Repo { location = Dir d } = d
workTree Repo { location = Unknown } = undefined
-{- Path of an URL repo. -}
-urlPath :: Repo -> String
-urlPath Repo { location = Url u } = uriPath u
-urlPath repo = assertUrl repo $ error "internal"
-
-{- Scheme of an URL repo. -}
-urlScheme :: Repo -> String
-urlScheme Repo { location = Url u } = uriScheme u
-urlScheme repo = assertUrl repo $ error "internal"
-
-{- Work around a bug in the real uriRegName
- - <http://trac.haskell.org/network/ticket/40> -}
-uriRegName' :: URIAuth -> String
-uriRegName' a = fixup $ uriRegName a
- where
- fixup x@('[':rest)
- | rest !! len == ']' = take len rest
- | otherwise = x
- where
- len = length rest - 1
- fixup x = x
-
-{- Hostname of an URL repo. -}
-urlHost :: Repo -> String
-urlHost = urlAuthPart uriRegName'
-
-{- Port of an URL repo, if it has a nonstandard one. -}
-urlPort :: Repo -> Maybe Integer
-urlPort r =
- case urlAuthPart uriPort r of
- ":" -> Nothing
- (':':p) -> readMaybe p
- _ -> Nothing
-
-{- Hostname of an URL repo, including any username (ie, "user@host") -}
-urlHostUser :: Repo -> String
-urlHostUser r = urlAuthPart uriUserInfo r ++ urlAuthPart uriRegName' r
-
-{- The full authority portion an URL repo. (ie, "user@host:port") -}
-urlAuthority :: Repo -> String
-urlAuthority = urlAuthPart assemble
- where
- assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a
-
-{- Applies a function to extract part of the uriAuthority of an URL repo. -}
-urlAuthPart :: (URIAuth -> a) -> Repo -> a
-urlAuthPart a Repo { location = Url u } = a auth
- where
- auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
-urlAuthPart _ repo = assertUrl repo $ error "internal"
-
{- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
gitCommandLine params repo@(Repo { location = Dir _ } ) =
@@ -284,39 +189,6 @@ reap = do
r <- catchDefaultIO (getAnyProcessStatus False True) Nothing
maybe (return ()) (const reap) r
-{- Forces git to use the specified index file.
- - Returns an action that will reset back to the default
- - index file. -}
-useIndex :: FilePath -> IO (IO ())
-useIndex index = do
- res <- getEnv var
- setEnv var index True
- return $ reset res
- where
- var = "GIT_INDEX_FILE"
- reset (Just v) = setEnv var v True
- reset _ = unsetEnv var
-
-{- Runs an action that causes a git subcommand to emit a sha, and strips
- any trailing newline, returning the sha. -}
-getSha :: String -> IO String -> IO Sha
-getSha subcommand a = do
- t <- a
- let t' = if last t == '\n'
- then init t
- else t
- when (length t' /= shaSize) $
- error $ "failed to read sha from git " ++ subcommand ++ " (" ++ t' ++ ")"
- return $ Ref t'
-
-{- Size of a git sha. -}
-shaSize :: Int
-shaSize = 40
-
{- Checks if a string from git config is a true value. -}
configTrue :: String -> Bool
configTrue s = map toLower s == "true"
-
-{- Access to raw config Map -}
-configMap :: Repo -> M.Map String String
-configMap = config
diff --git a/Git/Branch.hs b/Git/Branch.hs
index 8b0d1e5af..3e08e19c2 100644
--- a/Git/Branch.hs
+++ b/Git/Branch.hs
@@ -11,6 +11,7 @@ import qualified Data.ByteString.Lazy.Char8 as L
import Common
import Git
+import Git.Sha
{- Checks if the second branch has any commits not present on the first
- branch. -}
@@ -19,7 +20,7 @@ changed origbranch newbranch repo
| origbranch == newbranch = return False
| otherwise = not . L.null <$> diffs
where
- diffs = Git.pipeRead
+ diffs = pipeRead
[ Param "log"
, Param (show origbranch ++ ".." ++ show newbranch)
, Params "--oneline -n1"
@@ -44,7 +45,7 @@ fastForward branch (first:rest) repo = do
where
no_ff = return False
do_ff to = do
- Git.run "update-ref"
+ run "update-ref"
[Param $ show branch, Param $ show to] repo
return True
findbest c [] = return $ Just c
diff --git a/Git/CatFile.hs b/Git/CatFile.hs
index c1cafb8ba..44c2a9f5e 100644
--- a/Git/CatFile.hs
+++ b/Git/CatFile.hs
@@ -20,6 +20,7 @@ import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import Git
+import Git.Sha
import Utility.SafeCommand
type CatFileHandle = (PipeHandle, Handle, Handle)
@@ -27,7 +28,7 @@ type CatFileHandle = (PipeHandle, Handle, Handle)
{- Starts git cat-file running in batch mode in a repo and returns a handle. -}
catFileStart :: Repo -> IO CatFileHandle
catFileStart repo = hPipeBoth "git" $ toCommand $
- Git.gitCommandLine [Param "cat-file", Param "--batch"] repo
+ gitCommandLine [Param "cat-file", Param "--batch"] repo
{- Stops git cat-file. -}
catFileStop :: CatFileHandle -> IO ()
@@ -49,7 +50,7 @@ catObject (_, from, to) object = do
header <- hGetLine from
case words header of
[sha, objtype, size]
- | length sha == Git.shaSize &&
+ | length sha == shaSize &&
validobjtype objtype -> handle size
| otherwise -> empty
_
diff --git a/Git/Construct.hs b/Git/Construct.hs
index 9149ab9ec..a35a87cc7 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -11,6 +11,8 @@ module Git.Construct (
fromUrl,
fromUnknown,
localToUrl,
+ remoteNamed,
+ remoteNamedFromKey,
fromRemotes,
fromRemoteLocation,
repoAbsPath,
@@ -23,6 +25,7 @@ import Network.URI
import Common
import Git.Types
import Git
+import qualified Git.Url as Url
{- Finds the current git repository, which may be in a parent directory. -}
fromCwd :: IO Repo
@@ -67,8 +70,8 @@ fromUrl url
bad = error $ "bad url " ++ url
{- Creates a repo that has an unknown location. -}
-fromUnknown :: Repo
-fromUnknown = newFrom Unknown
+fromUnknown :: IO Repo
+fromUnknown = return $ newFrom Unknown
{- Converts a local Repo into a remote repo, using the reference repo
- which is assumed to be on the same host. -}
@@ -79,8 +82,8 @@ localToUrl reference r
| otherwise = r { location = Url $ fromJust $ parseURI absurl }
where
absurl =
- urlScheme reference ++ "//" ++
- urlAuthority reference ++
+ Url.scheme reference ++ "//" ++
+ Url.authority reference ++
workTree r
{- Calculates a list of a repo's configured remotes, by parsing its config. -}
@@ -91,7 +94,21 @@ fromRemotes repo = mapM construct remotepairs
filterkeys f = filterconfig (\(k,_) -> f k)
remotepairs = filterkeys isremote
isremote k = startswith "remote." k && endswith ".url" k
- construct (k,v) = repoRemoteNameFromKey k <$> fromRemoteLocation v repo
+ construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo
+
+{- Sets the name of a remote when constructing the Repo to represent it. -}
+remoteNamed :: String -> IO Repo -> IO Repo
+remoteNamed n constructor = do
+ r <- constructor
+ return $ r { remoteName = Just n }
+
+{- Sets the name of a remote based on the git config key, such as
+ "remote.foo.url". -}
+remoteNamedFromKey :: String -> IO Repo -> IO Repo
+remoteNamedFromKey k = remoteNamed basename
+ where
+ basename = join "." $ reverse $ drop 1 $
+ reverse $ drop 1 $ split "." k
{- Constructs a new Repo for one of a Repo's remotes using a given
- location (ie, an url). -}
diff --git a/Git/HashObject.hs b/Git/HashObject.hs
index 99b96afcb..60822f3f0 100644
--- a/Git/HashObject.hs
+++ b/Git/HashObject.hs
@@ -17,10 +17,10 @@ hashFiles paths repo = do
(pid, fromh, toh) <- hPipeBoth "git" $ toCommand $ git_hash_object repo
_ <- forkProcess (feeder toh)
hClose toh
- shas <- map Git.Ref . lines <$> hGetContentsStrict fromh
+ shas <- map Ref . lines <$> hGetContentsStrict fromh
return (shas, ender fromh pid)
where
- git_hash_object = Git.gitCommandLine
+ git_hash_object = gitCommandLine
[Param "hash-object", Param "-w", Param "--stdin-paths"]
feeder toh = do
hPutStr toh $ unlines paths
diff --git a/Git/Index.hs b/Git/Index.hs
new file mode 100644
index 000000000..aaf54e032
--- /dev/null
+++ b/Git/Index.hs
@@ -0,0 +1,24 @@
+{- git index file stuff
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Index where
+
+import System.Posix.Env (setEnv, unsetEnv, getEnv)
+
+{- Forces git to use the specified index file.
+ -
+ - Returns an action that will reset back to the default
+ - index file. -}
+override :: FilePath -> IO (IO ())
+override index = do
+ res <- getEnv var
+ setEnv var index True
+ return $ reset res
+ where
+ var = "GIT_INDEX_FILE"
+ reset (Just v) = setEnv var v True
+ reset _ = unsetEnv var
diff --git a/Git/Ref.hs b/Git/Ref.hs
index 723bea681..3b550cf5b 100644
--- a/Git/Ref.hs
+++ b/Git/Ref.hs
@@ -37,11 +37,11 @@ sha branch repo = process . L.unpack <$> showref repo
{- List of (refs, branches) matching a given ref spec.
- Duplicate refs are filtered out. -}
-matching :: Ref -> Repo -> IO [(Git.Ref, Git.Branch)]
+matching :: Ref -> Repo -> IO [(Ref, Branch)]
matching ref repo = do
- r <- Git.pipeRead [Param "show-ref", Param $ show ref] repo
+ r <- pipeRead [Param "show-ref", Param $ show ref] repo
return $ nubBy uref $ map (gen . words . L.unpack) (L.lines r)
where
- gen l = (Git.Ref $ head l, Git.Ref $ last l)
+ gen l = (Ref $ head l, Ref $ last l)
uref (a, _) (b, _) = a == b
diff --git a/Git/Sha.hs b/Git/Sha.hs
new file mode 100644
index 000000000..475c2ba5f
--- /dev/null
+++ b/Git/Sha.hs
@@ -0,0 +1,27 @@
+{- git SHA stuff
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Sha where
+
+import Common
+import Git.Types
+
+{- Runs an action that causes a git subcommand to emit a sha, and strips
+ any trailing newline, returning the sha. -}
+getSha :: String -> IO String -> IO Sha
+getSha subcommand a = do
+ t <- a
+ let t' = if last t == '\n'
+ then init t
+ else t
+ when (length t' /= shaSize) $
+ error $ "failed to read sha from git " ++ subcommand ++ " (" ++ t' ++ ")"
+ return $ Ref t'
+
+{- Size of a git sha. -}
+shaSize :: Int
+shaSize = 40
diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs
index 0345af399..a623e1ceb 100644
--- a/Git/UnionMerge.hs
+++ b/Git/UnionMerge.hs
@@ -20,6 +20,7 @@ import qualified Data.Set as S
import Common
import Git
+import Git.Sha
import Git.CatFile
type Streamer = (String -> IO ()) -> IO ()
@@ -27,7 +28,7 @@ type Streamer = (String -> IO ()) -> IO ()
{- Performs a union merge between two branches, staging it in the index.
- Any previously staged changes in the index will be lost.
-
- - Should be run with a temporary index file configured by Git.useIndex.
+ - Should be run with a temporary index file configured by useIndex.
-}
merge :: Ref -> Ref -> Repo -> IO ()
merge x y repo = do
@@ -53,7 +54,7 @@ update_index repo ls = stream_update_index repo [(`mapM_` ls)]
{- Streams content into update-index. -}
stream_update_index :: Repo -> [Streamer] -> IO ()
stream_update_index repo as = do
- (p, h) <- hPipeTo "git" (toCommand $ Git.gitCommandLine params repo)
+ (p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo)
forM_ as (stream h)
hClose h
forceSuccess p
diff --git a/Git/Url.hs b/Git/Url.hs
new file mode 100644
index 000000000..6a893d92f
--- /dev/null
+++ b/Git/Url.hs
@@ -0,0 +1,70 @@
+{- git repository urls
+ -
+ - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Url (
+ scheme,
+ host,
+ port,
+ hostuser,
+ authority,
+) where
+
+import Network.URI hiding (scheme, authority)
+
+import Common
+import Git.Types
+import Git
+
+{- Scheme of an URL repo. -}
+scheme :: Repo -> String
+scheme Repo { location = Url u } = uriScheme u
+scheme repo = notUrl repo
+
+{- Work around a bug in the real uriRegName
+ - <http://trac.haskell.org/network/ticket/40> -}
+uriRegName' :: URIAuth -> String
+uriRegName' a = fixup $ uriRegName a
+ where
+ fixup x@('[':rest)
+ | rest !! len == ']' = take len rest
+ | otherwise = x
+ where
+ len = length rest - 1
+ fixup x = x
+
+{- Hostname of an URL repo. -}
+host :: Repo -> String
+host = authpart uriRegName'
+
+{- Port of an URL repo, if it has a nonstandard one. -}
+port :: Repo -> Maybe Integer
+port r =
+ case authpart uriPort r of
+ ":" -> Nothing
+ (':':p) -> readMaybe p
+ _ -> Nothing
+
+{- Hostname of an URL repo, including any username (ie, "user@host") -}
+hostuser :: Repo -> String
+hostuser r = authpart uriUserInfo r ++ authpart uriRegName' r
+
+{- The full authority portion an URL repo. (ie, "user@host:port") -}
+authority :: Repo -> String
+authority = authpart assemble
+ where
+ assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a
+
+{- Applies a function to extract part of the uriAuthority of an URL repo. -}
+authpart :: (URIAuth -> a) -> Repo -> a
+authpart a Repo { location = Url u } = a auth
+ where
+ auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
+authpart _ repo = notUrl repo
+
+notUrl :: Repo -> a
+notUrl repo = error $
+ "acting on local git repo " ++ repoDescribe repo ++ " not supported"
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 9d80f4c1c..d848a21b3 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -37,16 +37,17 @@ remote = RemoteType {
list :: Annex [Git.Repo]
list = do
- c <- fromRepo Git.configMap
+ c <- fromRepo Git.config
mapM (tweakurl c) =<< fromRepo Git.remotes
where
annexurl n = "remote." ++ n ++ ".annexurl"
tweakurl c r = do
- let n = fromJust $ Git.repoRemoteName r
+ let n = fromJust $ Git.remoteName r
case M.lookup (annexurl n) c of
Nothing -> return r
- Just url -> Git.repoRemoteNameSet n <$>
- inRepo (Git.Construct.fromRemoteLocation url)
+ Just url -> inRepo $ \g ->
+ Git.Construct.remoteNamed n $
+ Git.Construct.fromRemoteLocation url g
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
gen r u _ = do
@@ -84,7 +85,7 @@ gen r u _ = do
- returns the updated repo. -}
tryGitConfigRead :: Git.Repo -> Annex Git.Repo
tryGitConfigRead r
- | not $ M.null $ Git.configMap r = return r -- already read
+ | not $ M.null $ Git.config r = return r -- already read
| Git.repoIsSsh r = store $ onRemote r (pipedconfig, r) "configlist" []
| Git.repoIsHttp r = store $ safely geturlconfig
| Git.repoIsUrl r = return r
@@ -116,13 +117,13 @@ tryGitConfigRead r
r' <- a
g <- gitRepo
let l = Git.remotes g
- let g' = Git.remotesAdd g $ exchange l r'
+ let g' = g { Git.remotes = exchange l r' }
Annex.changeState $ \s -> s { Annex.repo = g' }
return r'
exchange [] _ = []
exchange (old:ls) new =
- if Git.repoRemoteName old == Git.repoRemoteName new
+ if Git.remoteName old == Git.remoteName new
then new : exchange ls new
else old : exchange ls new
@@ -167,7 +168,7 @@ onLocal :: Git.Repo -> Annex a -> IO a
onLocal r a = do
-- Avoid re-reading the repository's configuration if it was
-- already read.
- state <- if M.null $ Git.configMap r
+ state <- if M.null $ Git.config r
then Annex.new r
else return $ Annex.newState r
Annex.eval state $ do
diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs
index 72c4842d8..c374a16aa 100644
--- a/Remote/Helper/Special.hs
+++ b/Remote/Helper/Special.hs
@@ -20,11 +20,11 @@ import qualified Git.Construct
-}
findSpecialRemotes :: String -> Annex [Git.Repo]
findSpecialRemotes s = do
- m <- fromRepo Git.configMap
- return $ map construct $ remotepairs m
+ m <- fromRepo Git.config
+ liftIO $ mapM construct $ remotepairs m
where
remotepairs = M.toList . M.filterWithKey match
- construct (k,_) = Git.repoRemoteNameFromKey k Git.Construct.fromUnknown
+ construct (k,_) = Git.Construct.remoteNamedFromKey k Git.Construct.fromUnknown
match k _ = startswith "remote." k && endswith (".annex-"++s) k
{- Sets up configuration for a special remote in .git/config. -}
diff --git a/Remote/Web.hs b/Remote/Web.hs
index c4e9f8bd6..e31539f88 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -27,7 +27,9 @@ remote = RemoteType {
-- (If the web should cease to exist, remove this module and redistribute
-- a new release to the survivors by carrier pigeon.)
list :: Annex [Git.Repo]
-list = return [Git.repoRemoteNameSet "web" Git.Construct.fromUnknown]
+list = do
+ r <- liftIO $ Git.Construct.remoteNamed "web" Git.Construct.fromUnknown
+ return [r]
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
gen r _ _ =
diff --git a/git-union-merge.hs b/git-union-merge.hs
index f67414bdd..6fd19c8da 100644
--- a/git-union-merge.hs
+++ b/git-union-merge.hs
@@ -12,6 +12,7 @@ import qualified Git.UnionMerge
import qualified Git.Config
import qualified Git.Construct
import qualified Git.Branch
+import qualified Git.Index
import qualified Git
header :: String
@@ -42,7 +43,7 @@ main :: IO ()
main = do
[aref, bref, newref] <- map Git.Ref <$> parseArgs
g <- Git.Config.read =<< Git.Construct.fromCwd
- _ <- Git.useIndex (tmpIndex g)
+ _ <- Git.Index.override (tmpIndex g)
setup g
Git.UnionMerge.merge aref bref g
_ <- Git.Branch.commit "union merge" newref [aref, bref] g
diff --git a/test.hs b/test.hs
index 1ce9d103d..daa2661b6 100644
--- a/test.hs
+++ b/test.hs
@@ -24,7 +24,6 @@ import qualified Utility.SafeCommand
import qualified Annex
import qualified Annex.UUID
import qualified Backend
-import qualified Git
import qualified Git.Config
import qualified Git.Construct
import qualified Git.Filename
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-11 02:06:39 +0000