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
|
@ -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
|
||||
|
|
|
@ -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
|
||||
_
|
||||
|
|
|
@ -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). -}
|
||||
|
|
|
@ -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
|
||||
|
|
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.
|
||||
- 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
|
||||
|
||||
|
|
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 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
|
||||
|
|
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"
|
Loading…
Add table
Add a link
Reference in a new issue