split more stuff out of Git.hs

This commit is contained in:
Joey Hess 2011-12-14 15:30:14 -04:00
parent 2b24e16a63
commit 02f1bd2bf4
20 changed files with 197 additions and 179 deletions

View file

@ -28,6 +28,7 @@ import qualified Git.Ref
import qualified Git.Branch import qualified Git.Branch
import qualified Git.UnionMerge import qualified Git.UnionMerge
import qualified Git.HashObject import qualified Git.HashObject
import qualified Git.Index
import Annex.CatFile import Annex.CatFile
{- Name of the branch that is used to store git-annex's information. -} {- 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' :: Bool -> Annex a -> Annex a
withIndex' bootstrapping a = do withIndex' bootstrapping a = do
f <- fromRepo gitAnnexIndex f <- fromRepo gitAnnexIndex
bracketIO (Git.useIndex f) id $ do bracketIO (Git.Index.override f) id $ do
unlessM (liftIO $ doesFileExist f) $ do unlessM (liftIO $ doesFileExist f) $ do
unless bootstrapping create unless bootstrapping create
liftIO $ createDirectoryIfMissing True $ takeDirectory f liftIO $ createDirectoryIfMissing True $ takeDirectory f

View file

@ -10,6 +10,7 @@ module Annex.Ssh where
import Control.Monad.State (liftIO) import Control.Monad.State (liftIO)
import qualified Git import qualified Git
import qualified Git.Url
import Utility.SafeCommand import Utility.SafeCommand
import Types import Types
import Config import Config
@ -22,10 +23,10 @@ sshToRepo :: Git.Repo -> [CommandParam] -> Annex [CommandParam]
sshToRepo repo sshcmd = do sshToRepo repo sshcmd = do
s <- getConfig repo "ssh-options" "" s <- getConfig repo "ssh-options" ""
let sshoptions = map Param (words s) let sshoptions = map Param (words s)
let sshport = case Git.urlPort repo of let sshport = case Git.Url.port repo of
Nothing -> [] Nothing -> []
Just p -> [Param "-p", Param (show p)] 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 return $ sshoptions ++ sshport ++ [sshhost] ++ sshcmd
{- Generates parameters to run a git-annex-shell command on a remote {- Generates parameters to run a git-annex-shell command on a remote

View file

@ -20,7 +20,6 @@ import System.IO.Error (try)
import System.Posix.Files import System.Posix.Files
import Common.Annex import Common.Annex
import qualified Git
import qualified Git.Config import qualified Git.Config
import qualified Git.CheckAttr import qualified Git.CheckAttr
import qualified Annex import qualified Annex

View file

@ -13,6 +13,7 @@ import qualified Data.Map as M
import Common.Annex import Common.Annex
import Command import Command
import qualified Git import qualified Git
import qualified Git.Url
import qualified Git.Config import qualified Git.Config
import qualified Git.Construct import qualified Git.Construct
import Annex.UUID import Annex.UUID
@ -68,7 +69,7 @@ drawMap rs umap ts = Dot.graph $ repos ++ trusted ++ others
hostname :: Git.Repo -> String hostname :: Git.Repo -> String
hostname r hostname r
| Git.repoIsUrl r = Git.urlHost r | Git.repoIsUrl r = Git.Url.host r
| otherwise = "localhost" | otherwise = "localhost"
basehostname :: Git.Repo -> String basehostname :: Git.Repo -> String
@ -82,7 +83,7 @@ repoName umap r
| otherwise = M.findWithDefault fallback repouuid umap | otherwise = M.findWithDefault fallback repouuid umap
where where
repouuid = getUncachedUUID r 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. -} {- A unique id for the node for a repo. Uses the annex.uuid if available. -}
nodeId :: Git.Repo -> String nodeId :: Git.Repo -> String
@ -99,7 +100,7 @@ node umap fullinfo r = unlines $ n:edges
decorate $ Dot.graphNode (nodeId r) (repoName umap r) decorate $ Dot.graphNode (nodeId r) (repoName umap r)
edges = map (edge umap fullinfo r) (Git.remotes r) edges = map (edge umap fullinfo r) (Git.remotes r)
decorate decorate
| Git.configMap r == M.empty = unreachable | Git.config r == M.empty = unreachable
| otherwise = reachable | otherwise = reachable
{- An edge between two repos. The second repo is a remote of the first. -} {- 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 {- Only name an edge if the name is different than the name
- that will be used for the destination node, and is - that will be used for the destination node, and is
- different from its hostname. (This reduces visual clutter.) -} - different from its hostname. (This reduces visual clutter.) -}
edgename = maybe Nothing calcname $ Git.repoRemoteName to edgename = maybe Nothing calcname $ Git.remoteName to
calcname n calcname n
| n `elem` [repoName umap fullto, hostname fullto] = Nothing | n `elem` [repoName umap fullto, hostname fullto] = Nothing
| otherwise = Just n | otherwise = Just n
@ -141,7 +142,7 @@ spider' (r:rs) known
-- The remotes will be relative to r', and need to be -- The remotes will be relative to r', and need to be
-- made absolute for later use. -- made absolute for later use.
remotes <- mapM (absRepo r') (Git.remotes r') remotes <- mapM (absRepo r') (Git.remotes r')
let r'' = Git.remotesAdd r' remotes let r'' = r' { Git.remotes = remotes }
spider' (rs ++ remotes) (r'':known) spider' (rs ++ remotes) (r'':known)
@ -154,7 +155,7 @@ absRepo reference r
{- Checks if two repos are the same. -} {- Checks if two repos are the same. -}
same :: Git.Repo -> Git.Repo -> Bool same :: Git.Repo -> Git.Repo -> Bool
same a b 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 | both Git.repoIsUrl && neither Git.repoIsSsh = matching show
| neither Git.repoIsSsh = matching Git.workTree | neither Git.repoIsSsh = matching Git.workTree
| otherwise = False | otherwise = False

View file

@ -31,7 +31,7 @@ getConfig r key def = do
{- Looks up a per-remote config setting in git config. -} {- Looks up a per-remote config setting in git config. -}
remoteConfig :: Git.Repo -> ConfigKey -> String 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 {- Calculates cost for a remote. Either the 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

148
Git.hs
View file

@ -9,7 +9,7 @@
-} -}
module Git ( module Git (
Repo, Repo(..),
Ref(..), Ref(..),
Branch, Branch,
Sha, Sha,
@ -22,13 +22,6 @@ module Git (
repoLocation, repoLocation,
workTree, workTree,
gitDir, gitDir,
urlPath,
urlHost,
urlPort,
urlHostUser,
urlAuthority,
urlScheme,
configMap,
configTrue, configTrue,
gitCommandLine, gitCommandLine,
run, run,
@ -39,23 +32,14 @@ module Git (
pipeNullSplit, pipeNullSplit,
pipeNullSplitB, pipeNullSplitB,
attributes, attributes,
remotes,
remotesAdd,
repoRemoteName,
repoRemoteNameSet,
repoRemoteNameFromKey,
reap, reap,
useIndex,
getSha,
shaSize,
assertLocal, assertLocal,
) where ) where
import qualified Data.Map as M import qualified Data.Map as M
import Network.URI
import Data.Char import Data.Char
import System.Posix.Env (setEnv, unsetEnv, getEnv)
import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Lazy.Char8 as L
import Network.URI (uriPath, uriScheme)
import Common import Common
import Git.Types import Git.Types
@ -73,29 +57,6 @@ repoLocation Repo { location = Url url } = show url
repoLocation Repo { location = Dir dir } = dir repoLocation Repo { location = Dir dir } = dir
repoLocation Repo { location = Unknown } = undefined 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, {- Some code needs to vary between URL and normal repos,
- or bare and non-bare, these functions help with that. -} - or bare and non-bare, these functions help with that. -}
repoIsUrl :: Repo -> Bool repoIsUrl :: Repo -> Bool
@ -104,11 +65,13 @@ repoIsUrl _ = False
repoIsSsh :: Repo -> Bool repoIsSsh :: Repo -> Bool
repoIsSsh Repo { location = Url url } repoIsSsh Repo { location = Url url }
| uriScheme url == "ssh:" = True | scheme == "ssh:" = True
-- git treats these the same as ssh -- git treats these the same as ssh
| uriScheme url == "git+ssh:" = True | scheme == "git+ssh:" = True
| uriScheme url == "ssh+git:" = True | scheme == "ssh+git:" = True
| otherwise = False | otherwise = False
where
scheme = uriScheme url
repoIsSsh _ = False repoIsSsh _ = False
repoIsHttp :: Repo -> Bool repoIsHttp :: Repo -> Bool
@ -129,15 +92,8 @@ assertLocal :: Repo -> a -> a
assertLocal repo action = assertLocal repo action =
if not $ repoIsUrl repo if not $ repoIsUrl repo
then action then action
else error $ "acting on URL git repo " ++ repoDescribe repo ++ else error $ "acting on non-local git repo " ++ repoDescribe repo ++
" not supported" " 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 -> Bool
configBare repo = maybe unknown configTrue $ M.lookup "core.bare" $ config repo configBare repo = maybe unknown configTrue $ M.lookup "core.bare" $ config repo
where where
@ -161,61 +117,10 @@ gitDir repo
- -
- Note that for URL repositories, this is the path on the remote host. -} - Note that for URL repositories, this is the path on the remote host. -}
workTree :: Repo -> FilePath workTree :: Repo -> FilePath
workTree r@(Repo { location = Url _ }) = urlPath r workTree Repo { location = Url u } = uriPath u
workTree (Repo { location = Dir d }) = d workTree Repo { location = Dir d } = d
workTree Repo { location = Unknown } = undefined 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. -} {- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: [CommandParam] -> Repo -> [CommandParam] gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
gitCommandLine params repo@(Repo { location = Dir _ } ) = gitCommandLine params repo@(Repo { location = Dir _ } ) =
@ -284,39 +189,6 @@ reap = do
r <- catchDefaultIO (getAnyProcessStatus False True) Nothing r <- catchDefaultIO (getAnyProcessStatus False True) Nothing
maybe (return ()) (const reap) r 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. -} {- Checks if a string from git config is a true value. -}
configTrue :: String -> Bool configTrue :: String -> Bool
configTrue s = map toLower s == "true" configTrue s = map toLower s == "true"
{- Access to raw config Map -}
configMap :: Repo -> M.Map String String
configMap = config

View file

@ -11,6 +11,7 @@ import qualified Data.ByteString.Lazy.Char8 as L
import Common import Common
import Git import Git
import Git.Sha
{- Checks if the second branch has any commits not present on the first {- Checks if the second branch has any commits not present on the first
- branch. -} - branch. -}
@ -19,7 +20,7 @@ changed origbranch newbranch repo
| origbranch == newbranch = return False | origbranch == newbranch = return False
| otherwise = not . L.null <$> diffs | otherwise = not . L.null <$> diffs
where where
diffs = Git.pipeRead diffs = pipeRead
[ Param "log" [ Param "log"
, Param (show origbranch ++ ".." ++ show newbranch) , Param (show origbranch ++ ".." ++ show newbranch)
, Params "--oneline -n1" , Params "--oneline -n1"
@ -44,7 +45,7 @@ fastForward branch (first:rest) repo = do
where where
no_ff = return False no_ff = return False
do_ff to = do do_ff to = do
Git.run "update-ref" run "update-ref"
[Param $ show branch, Param $ show to] repo [Param $ show branch, Param $ show to] repo
return True return True
findbest c [] = return $ Just c findbest c [] = return $ Just c

View file

@ -20,6 +20,7 @@ import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Lazy.Char8 as L
import Git import Git
import Git.Sha
import Utility.SafeCommand import Utility.SafeCommand
type CatFileHandle = (PipeHandle, Handle, Handle) 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. -} {- Starts git cat-file running in batch mode in a repo and returns a handle. -}
catFileStart :: Repo -> IO CatFileHandle catFileStart :: Repo -> IO CatFileHandle
catFileStart repo = hPipeBoth "git" $ toCommand $ catFileStart repo = hPipeBoth "git" $ toCommand $
Git.gitCommandLine [Param "cat-file", Param "--batch"] repo gitCommandLine [Param "cat-file", Param "--batch"] repo
{- Stops git cat-file. -} {- Stops git cat-file. -}
catFileStop :: CatFileHandle -> IO () catFileStop :: CatFileHandle -> IO ()
@ -49,7 +50,7 @@ catObject (_, from, to) object = do
header <- hGetLine from header <- hGetLine from
case words header of case words header of
[sha, objtype, size] [sha, objtype, size]
| length sha == Git.shaSize && | length sha == shaSize &&
validobjtype objtype -> handle size validobjtype objtype -> handle size
| otherwise -> empty | otherwise -> empty
_ _

View file

@ -11,6 +11,8 @@ module Git.Construct (
fromUrl, fromUrl,
fromUnknown, fromUnknown,
localToUrl, localToUrl,
remoteNamed,
remoteNamedFromKey,
fromRemotes, fromRemotes,
fromRemoteLocation, fromRemoteLocation,
repoAbsPath, repoAbsPath,
@ -23,6 +25,7 @@ import Network.URI
import Common import Common
import Git.Types import Git.Types
import Git import Git
import qualified Git.Url as Url
{- Finds the current git repository, which may be in a parent directory. -} {- Finds the current git repository, which may be in a parent directory. -}
fromCwd :: IO Repo fromCwd :: IO Repo
@ -67,8 +70,8 @@ fromUrl url
bad = error $ "bad url " ++ url bad = error $ "bad url " ++ url
{- Creates a repo that has an unknown location. -} {- Creates a repo that has an unknown location. -}
fromUnknown :: Repo fromUnknown :: IO Repo
fromUnknown = newFrom Unknown fromUnknown = return $ newFrom Unknown
{- Converts a local Repo into a remote repo, using the reference repo {- Converts a local Repo into a remote repo, using the reference repo
- which is assumed to be on the same host. -} - which is assumed to be on the same host. -}
@ -79,8 +82,8 @@ localToUrl reference r
| otherwise = r { location = Url $ fromJust $ parseURI absurl } | otherwise = r { location = Url $ fromJust $ parseURI absurl }
where where
absurl = absurl =
urlScheme reference ++ "//" ++ Url.scheme reference ++ "//" ++
urlAuthority reference ++ Url.authority reference ++
workTree r workTree r
{- Calculates a list of a repo's configured remotes, by parsing its config. -} {- 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) filterkeys f = filterconfig (\(k,_) -> f k)
remotepairs = filterkeys isremote remotepairs = filterkeys isremote
isremote k = startswith "remote." k && endswith ".url" k 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 {- Constructs a new Repo for one of a Repo's remotes using a given
- location (ie, an url). -} - location (ie, an url). -}

View file

@ -17,10 +17,10 @@ hashFiles paths repo = do
(pid, fromh, toh) <- hPipeBoth "git" $ toCommand $ git_hash_object repo (pid, fromh, toh) <- hPipeBoth "git" $ toCommand $ git_hash_object repo
_ <- forkProcess (feeder toh) _ <- forkProcess (feeder toh)
hClose toh hClose toh
shas <- map Git.Ref . lines <$> hGetContentsStrict fromh shas <- map Ref . lines <$> hGetContentsStrict fromh
return (shas, ender fromh pid) return (shas, ender fromh pid)
where where
git_hash_object = Git.gitCommandLine git_hash_object = gitCommandLine
[Param "hash-object", Param "-w", Param "--stdin-paths"] [Param "hash-object", Param "-w", Param "--stdin-paths"]
feeder toh = do feeder toh = do
hPutStr toh $ unlines paths hPutStr toh $ unlines paths

24
Git/Index.hs Normal file
View file

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

View file

@ -37,11 +37,11 @@ sha branch repo = process . L.unpack <$> showref repo
{- List of (refs, branches) matching a given ref spec. {- List of (refs, branches) matching a given ref spec.
- Duplicate refs are filtered out. -} - Duplicate refs are filtered out. -}
matching :: Ref -> Repo -> IO [(Git.Ref, Git.Branch)] matching :: Ref -> Repo -> IO [(Ref, Branch)]
matching ref repo = do 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) return $ nubBy uref $ map (gen . words . L.unpack) (L.lines r)
where where
gen l = (Git.Ref $ head l, Git.Ref $ last l) gen l = (Ref $ head l, Ref $ last l)
uref (a, _) (b, _) = a == b uref (a, _) (b, _) = a == b

27
Git/Sha.hs Normal file
View file

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

View file

@ -20,6 +20,7 @@ import qualified Data.Set as S
import Common import Common
import Git import Git
import Git.Sha
import Git.CatFile import Git.CatFile
type Streamer = (String -> IO ()) -> IO () 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. {- Performs a union merge between two branches, staging it in the index.
- Any previously staged changes in the index will be lost. - 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 :: Ref -> Ref -> Repo -> IO ()
merge x y repo = do merge x y repo = do
@ -53,7 +54,7 @@ update_index repo ls = stream_update_index repo [(`mapM_` ls)]
{- Streams content into update-index. -} {- Streams content into update-index. -}
stream_update_index :: Repo -> [Streamer] -> IO () stream_update_index :: Repo -> [Streamer] -> IO ()
stream_update_index repo as = do 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) forM_ as (stream h)
hClose h hClose h
forceSuccess p forceSuccess p

70
Git/Url.hs Normal file
View file

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

View file

@ -37,16 +37,17 @@ remote = RemoteType {
list :: Annex [Git.Repo] list :: Annex [Git.Repo]
list = do list = do
c <- fromRepo Git.configMap c <- fromRepo Git.config
mapM (tweakurl c) =<< fromRepo Git.remotes mapM (tweakurl c) =<< fromRepo Git.remotes
where where
annexurl n = "remote." ++ n ++ ".annexurl" annexurl n = "remote." ++ n ++ ".annexurl"
tweakurl c r = do tweakurl c r = do
let n = fromJust $ Git.repoRemoteName 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 -> Git.repoRemoteNameSet n <$> Just url -> inRepo $ \g ->
inRepo (Git.Construct.fromRemoteLocation url) Git.Construct.remoteNamed n $
Git.Construct.fromRemoteLocation url g
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
gen r u _ = do gen r u _ = do
@ -84,7 +85,7 @@ gen r u _ = do
- returns the updated repo. -} - returns the updated repo. -}
tryGitConfigRead :: Git.Repo -> Annex Git.Repo tryGitConfigRead :: Git.Repo -> Annex Git.Repo
tryGitConfigRead r 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.repoIsSsh r = store $ onRemote r (pipedconfig, r) "configlist" []
| Git.repoIsHttp r = store $ safely geturlconfig | Git.repoIsHttp r = store $ safely geturlconfig
| Git.repoIsUrl r = return r | Git.repoIsUrl r = return r
@ -116,13 +117,13 @@ tryGitConfigRead r
r' <- a r' <- a
g <- gitRepo g <- gitRepo
let l = Git.remotes g 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' } Annex.changeState $ \s -> s { Annex.repo = g' }
return r' return r'
exchange [] _ = [] exchange [] _ = []
exchange (old:ls) new = exchange (old:ls) new =
if Git.repoRemoteName old == Git.repoRemoteName new if Git.remoteName old == Git.remoteName new
then new : exchange ls new then new : exchange ls new
else old : exchange ls new else old : exchange ls new
@ -167,7 +168,7 @@ onLocal :: Git.Repo -> Annex a -> IO a
onLocal r a = do onLocal r a = do
-- Avoid re-reading the repository's configuration if it was -- Avoid re-reading the repository's configuration if it was
-- already read. -- already read.
state <- if M.null $ Git.configMap r state <- if M.null $ Git.config r
then Annex.new r then Annex.new r
else return $ Annex.newState r else return $ Annex.newState r
Annex.eval state $ do Annex.eval state $ do

View file

@ -20,11 +20,11 @@ import qualified Git.Construct
-} -}
findSpecialRemotes :: String -> Annex [Git.Repo] findSpecialRemotes :: String -> Annex [Git.Repo]
findSpecialRemotes s = do findSpecialRemotes s = do
m <- fromRepo Git.configMap m <- fromRepo Git.config
return $ map 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.repoRemoteNameFromKey k Git.Construct.fromUnknown construct (k,_) = Git.Construct.remoteNamedFromKey k Git.Construct.fromUnknown
match k _ = startswith "remote." k && endswith (".annex-"++s) k match k _ = startswith "remote." k && endswith (".annex-"++s) k
{- Sets up configuration for a special remote in .git/config. -} {- Sets up configuration for a special remote in .git/config. -}

View file

@ -27,7 +27,9 @@ remote = RemoteType {
-- (If the web should cease to exist, remove this module and redistribute -- (If the web should cease to exist, remove this module and redistribute
-- a new release to the survivors by carrier pigeon.) -- a new release to the survivors by carrier pigeon.)
list :: Annex [Git.Repo] 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 :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
gen r _ _ = gen r _ _ =

View file

@ -12,6 +12,7 @@ import qualified Git.UnionMerge
import qualified Git.Config import qualified Git.Config
import qualified Git.Construct import qualified Git.Construct
import qualified Git.Branch import qualified Git.Branch
import qualified Git.Index
import qualified Git import qualified Git
header :: String header :: String
@ -42,7 +43,7 @@ main :: IO ()
main = do main = do
[aref, bref, newref] <- map Git.Ref <$> parseArgs [aref, bref, newref] <- map Git.Ref <$> parseArgs
g <- Git.Config.read =<< Git.Construct.fromCwd g <- Git.Config.read =<< Git.Construct.fromCwd
_ <- Git.useIndex (tmpIndex g) _ <- Git.Index.override (tmpIndex g)
setup g setup g
Git.UnionMerge.merge aref bref g Git.UnionMerge.merge aref bref g
_ <- Git.Branch.commit "union merge" newref [aref, bref] g _ <- Git.Branch.commit "union merge" newref [aref, bref] g

View file

@ -24,7 +24,6 @@ import qualified Utility.SafeCommand
import qualified Annex import qualified Annex
import qualified Annex.UUID import qualified Annex.UUID
import qualified Backend import qualified Backend
import qualified Git
import qualified Git.Config import qualified Git.Config
import qualified Git.Construct import qualified Git.Construct
import qualified Git.Filename import qualified Git.Filename