split more stuff out of Git.hs
This commit is contained in:
parent
2b24e16a63
commit
02f1bd2bf4
20 changed files with 197 additions and 179 deletions
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
148
Git.hs
|
@ -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
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
_
|
_
|
||||||
|
|
|
@ -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). -}
|
||||||
|
|
|
@ -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
24
Git/Index.hs
Normal 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
|
|
@ -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
27
Git/Sha.hs
Normal 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
|
|
@ -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
70
Git/Url.hs
Normal 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"
|
|
@ -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
|
||||||
|
|
|
@ -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. -}
|
||||||
|
|
|
@ -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 _ _ =
|
||||||
|
|
|
@ -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
|
||||||
|
|
1
test.hs
1
test.hs
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue