git-annex/GitRepo.hs

736 lines
23 KiB
Haskell
Raw Normal View History

2010-10-12 03:22:38 +00:00
{- git repository handling
-
- This is written to be completely independant of git-annex and should be
- suitable for other uses.
-
2010-10-27 20:53:54 +00:00
- Copyright 2010 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
2010-10-14 06:36:41 +00:00
-}
2010-10-10 01:06:46 +00:00
2010-10-11 21:52:46 +00:00
module GitRepo (
2010-10-14 06:36:41 +00:00
Repo,
repoFromCwd,
repoFromAbsPath,
repoFromUnknown,
2010-10-14 06:36:41 +00:00
repoFromUrl,
localToUrl,
2010-10-22 18:05:30 +00:00
repoIsUrl,
2010-10-22 17:40:19 +00:00
repoIsSsh,
repoIsLocalBare,
2010-10-14 06:36:41 +00:00
repoDescribe,
repoLocation,
2010-10-14 06:36:41 +00:00
workTree,
workTreeFile,
2010-10-31 19:38:47 +00:00
gitDir,
urlPath,
urlHost,
urlPort,
urlHostUser,
urlAuthority,
urlScheme,
2010-10-14 06:36:41 +00:00
configGet,
configMap,
configRead,
2010-12-31 19:46:33 +00:00
hConfigRead,
configStore,
2010-10-28 16:15:21 +00:00
configTrue,
gitCommandLine,
2010-10-14 06:36:41 +00:00
run,
2011-06-22 20:02:07 +00:00
runBool,
2010-10-16 18:20:43 +00:00
pipeRead,
pipeWrite,
pipeWriteRead,
pipeNullSplit,
2010-10-14 06:36:41 +00:00
attributes,
remotes,
remotesAdd,
2010-10-16 18:20:43 +00:00
repoRemoteName,
repoRemoteNameSet,
2010-10-16 18:58:14 +00:00
inRepo,
2010-10-29 21:26:26 +00:00
notInRepo,
2010-11-01 22:24:19 +00:00
stagedFiles,
2011-02-02 01:58:47 +00:00
stagedFilesNotDeleted,
changedUnstagedFiles,
checkAttr,
decodeGitFile,
encodeGitFile,
2010-11-10 18:01:41 +00:00
typeChangedFiles,
typeChangedStagedFiles,
repoAbsPath,
reap,
useIndex,
hashObject,
getSha,
shaSize,
2010-11-02 20:49:35 +00:00
prop_idempotent_deencode
2010-10-11 21:52:46 +00:00
) where
2010-10-10 01:06:46 +00:00
import Control.Monad (unless, when)
2010-11-06 21:07:11 +00:00
import System.Directory
import System.FilePath
2010-10-12 16:47:11 +00:00
import System.Posix.Directory
import System.Posix.User
import System.Posix.Process
2010-10-10 02:09:10 +00:00
import System.Path
import System.Cmd.Utils
2010-10-12 16:47:11 +00:00
import IO (bracket_)
2010-10-10 01:06:46 +00:00
import Data.String.Utils
2010-10-31 19:38:47 +00:00
import System.IO
import IO (try)
2010-10-29 21:26:26 +00:00
import qualified Data.Map as Map hiding (map, split)
2010-10-12 04:53:42 +00:00
import Network.URI
2010-11-06 21:07:11 +00:00
import Data.Maybe
import Data.Char
import Data.Word (Word8)
import Codec.Binary.UTF8.String (encode)
2010-11-06 21:07:11 +00:00
import Text.Printf
import Data.List (isInfixOf, isPrefixOf, isSuffixOf)
import System.Exit
import System.Posix.Env (setEnv, unsetEnv, getEnv)
2010-10-16 20:20:49 +00:00
2010-10-10 03:35:05 +00:00
import Utility
2010-10-11 21:19:55 +00:00
2010-10-22 18:05:30 +00:00
{- There are two types of repositories; those on local disk and those
- accessed via an URL. -}
data RepoLocation = Dir FilePath | Url URI | Unknown
deriving (Show, Eq)
2010-10-12 04:53:42 +00:00
data Repo = Repo {
location :: RepoLocation,
2010-10-29 21:26:26 +00:00
config :: Map.Map String String,
remotes :: [Repo],
-- remoteName holds the name used for this repo in remotes
remoteName :: Maybe String
} deriving (Show, Eq)
2010-10-31 19:38:47 +00:00
newFrom :: RepoLocation -> Repo
newFrom l =
2010-10-22 18:05:30 +00:00
Repo {
location = l,
2010-10-13 18:01:17 +00:00
config = Map.empty,
2010-10-14 02:59:43 +00:00
remotes = [],
2010-10-13 18:01:17 +00:00
remoteName = Nothing
2010-10-10 22:05:37 +00:00
}
2010-10-10 06:22:47 +00:00
{- Local Repo constructor, requires an absolute path to the repo be
- specified. -}
repoFromAbsPath :: FilePath -> IO Repo
repoFromAbsPath dir
| "/" `isPrefixOf` dir = do
-- Git always looks for "dir.git" in preference to
-- to "dir", even if dir ends in a "/".
let canondir = dropTrailingPathSeparator dir
let dir' = canondir ++ ".git"
e <- doesDirectoryExist dir'
if e
then ret dir'
else if "/.git" `isSuffixOf` canondir
then do
-- When dir == "foo/.git", git looks
-- for "foo/.git/.git", and failing
-- that, uses "foo" as the repository.
e' <- doesDirectoryExist $ dir </> ".git"
if e'
then ret dir
else ret $ takeDirectory canondir
else ret dir
| otherwise = error $ "internal error, " ++ dir ++ " is not absolute"
where
ret = return . newFrom . Dir
2010-10-14 06:36:41 +00:00
{- Remote Repo constructor. Throws exception on invalid url. -}
repoFromUrl :: String -> IO Repo
2010-10-28 17:47:10 +00:00
repoFromUrl url
| startswith "file://" url = repoFromAbsPath $ uriPath u
| otherwise = return $ newFrom $ Url u
where
2011-05-15 06:49:43 +00:00
u = maybe bad id $ parseURI url
bad = error $ "bad url " ++ url
2010-10-12 04:53:42 +00:00
{- Creates a repo that has an unknown location. -}
repoFromUnknown :: Repo
repoFromUnknown = newFrom Unknown
{- Converts a Local Repo into a remote repo, using the reference repo
- which is assumed to be on the same host. -}
localToUrl :: Repo -> Repo -> Repo
localToUrl reference r
| not $ repoIsUrl reference = error "internal error; reference repo not url"
| repoIsUrl r = r
| otherwise = r { location = Url $ fromJust $ parseURI absurl }
where
absurl =
urlScheme reference ++ "//" ++
urlAuthority reference ++
workTree r
{- User-visible description of a git repo. -}
2010-10-31 19:38:47 +00:00
repoDescribe :: Repo -> String
repoDescribe Repo { remoteName = Just name } = name
repoDescribe Repo { location = Url url } = show url
repoDescribe Repo { location = Dir dir } = dir
repoDescribe Repo { location = Unknown } = "UNKNOWN"
2010-10-13 18:40:56 +00:00
{- Location of the repo, either as a path or url. -}
repoLocation :: Repo -> String
repoLocation Repo { location = Url url } = show url
repoLocation Repo { location = Dir dir } = dir
repoLocation Repo { location = Unknown } = undefined
2010-10-14 02:59:43 +00:00
{- Constructs and returns an updated version of a repo with
- different remotes list. -}
2010-10-14 06:36:41 +00:00
remotesAdd :: Repo -> [Repo] -> Repo
remotesAdd repo rs = repo { remotes = rs }
2010-10-14 02:59:43 +00:00
{- 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 based on the git config key, such as
"remote.foo.url". -}
repoRemoteNameSet :: Repo -> String -> Repo
repoRemoteNameSet r k = r { remoteName = Just basename }
where
basename = join "." $ reverse $ drop 1 $
reverse $ drop 1 $ split "." k
2010-10-22 18:05:30 +00:00
{- Some code needs to vary between URL and normal repos,
2010-10-22 16:38:20 +00:00
- or bare and non-bare, these functions help with that. -}
2010-10-31 19:38:47 +00:00
repoIsUrl :: Repo -> Bool
repoIsUrl Repo { location = Url _ } = True
repoIsUrl _ = False
2010-10-31 19:38:47 +00:00
repoIsSsh :: Repo -> Bool
repoIsSsh Repo { location = Url url }
| uriScheme url == "ssh:" = True
-- git treats these the same as ssh
| uriScheme url == "git+ssh:" = True
| uriScheme url == "ssh+git:" = True
| otherwise = False
repoIsSsh _ = False
configAvail ::Repo -> Bool
configAvail Repo { config = c } = c /= Map.empty
repoIsLocalBare :: Repo -> Bool
repoIsLocalBare r@(Repo { location = Dir _ }) = configAvail r && configBare r
repoIsLocalBare _ = False
2010-10-31 19:38:47 +00:00
assertLocal :: Repo -> a -> a
2010-10-22 18:05:30 +00:00
assertLocal repo action =
if not $ repoIsUrl repo
2010-10-12 04:53:42 +00:00
then action
2010-11-06 21:07:11 +00:00
else error $ "acting on URL git repo " ++ repoDescribe repo ++
2010-10-12 06:51:44 +00:00
" not supported"
2010-10-31 19:38:47 +00:00
assertUrl :: Repo -> a -> a
2010-10-22 18:05:30 +00:00
assertUrl repo action =
if repoIsUrl repo
2010-10-22 17:40:19 +00:00
then action
2010-11-06 21:07:11 +00:00
else error $ "acting on local git repo " ++ repoDescribe repo ++
2010-10-22 17:40:19 +00:00
" not supported"
2010-12-31 19:46:33 +00:00
configBare :: Repo -> Bool
2011-05-15 16:25:58 +00:00
configBare repo = maybe unknown configTrue $ Map.lookup "core.bare" $ config repo
where
unknown = error $ "it is not known if git repo " ++
2010-11-06 21:07:11 +00:00
repoDescribe repo ++
" is a bare repository; config not read"
2010-10-11 21:52:46 +00:00
{- Path to a repository's gitattributes file. -}
2010-10-14 06:36:41 +00:00
attributes :: Repo -> String
attributes repo
| configBare repo = workTree repo ++ "/info/.gitattributes"
2010-11-06 21:07:11 +00:00
| otherwise = workTree repo ++ "/.gitattributes"
2010-10-10 06:29:58 +00:00
{- Path to a repository's .git directory, relative to its workTree. -}
2010-10-31 19:38:47 +00:00
gitDir :: Repo -> String
gitDir repo
| configBare repo = ""
| otherwise = ".git"
2010-10-10 06:29:58 +00:00
{- Path to a repository's --work-tree, that is, its top.
-
- Note that for URL repositories, this is the path on the remote host. -}
2010-10-14 06:36:41 +00:00
workTree :: Repo -> FilePath
workTree r@(Repo { location = Url _ }) = urlPath r
workTree (Repo { location = Dir d }) = d
workTree Repo { location = Unknown } = undefined
2010-10-12 04:53:42 +00:00
{- Given a relative or absolute filename inside a git repository's
- workTree, calculates the name to use to refer to that file to git.
-
- This is complicated because the best choice can vary depending on
- whether the cwd is in a subdirectory of the git repository, or not.
-
- For example, when adding a file "/tmp/repo/foo", it's best to refer
- to it as "foo" if the cwd is outside the repository entirely
- (this avoids a gotcha with using the full path name when /tmp/repo
- is itself a symlink). But, if the cwd is "/tmp/repo/subdir",
- it's best to refer to "../foo".
-}
workTreeFile :: Repo -> FilePath -> IO FilePath
workTreeFile repo@(Repo { location = Dir d }) file = do
cwd <- getCurrentDirectory
let file' = absfile cwd
unless (inrepo file') $
error $ file ++ " is not located inside git repository " ++ absrepo
if (inrepo $ addTrailingPathSeparator cwd)
then return $ relPathDirToFile cwd file'
else return $ drop (length absrepo) file'
2010-10-10 02:09:10 +00:00
where
-- normalize both repo and file, so that repo
-- will be substring of file
2011-05-15 16:25:58 +00:00
absrepo = maybe bad addTrailingPathSeparator $ absNormPath "/" d
2011-05-15 06:49:43 +00:00
absfile c = maybe file id $ secureAbsNormPath c file
inrepo f = absrepo `isPrefixOf` f
2011-05-15 16:25:58 +00:00
bad = error $ "bad repo" ++ repoDescribe repo
workTreeFile repo _ = assertLocal repo $ error "internal"
2010-10-10 02:09:10 +00:00
{- 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) -> Just (read 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 Repo { location = Url u } = uriUserInfo a ++ uriRegName' a ++ uriPort a
where
a = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
urlAuthority repo = assertUrl repo $ error "internal"
{- 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"
2010-10-12 03:22:38 +00:00
{- Constructs a git command line operating on the specified repo. -}
2011-02-28 20:25:31 +00:00
gitCommandLine :: Repo -> [CommandParam] -> [CommandParam]
gitCommandLine repo@(Repo { location = Dir d} ) params =
2010-10-12 03:22:38 +00:00
-- force use of specified repo via --git-dir and --work-tree
[ Param ("--git-dir=" ++ d ++ "/" ++ gitDir repo)
, Param ("--work-tree=" ++ d)
] ++ params
gitCommandLine repo _ = assertLocal repo $ error "internal"
2010-10-12 03:22:38 +00:00
2011-06-22 20:02:07 +00:00
{- Runs git in the specified repo. -}
runBool :: Repo -> String -> [CommandParam] -> IO Bool
runBool repo subcommand params = assertLocal repo $
boolSystem "git" (gitCommandLine repo ((Param subcommand):params))
{- Runs git in the specified repo, throwing an error if it fails. -}
2011-02-28 20:25:31 +00:00
run :: Repo -> String -> [CommandParam] -> IO ()
run repo subcommand params = assertLocal repo $
2011-06-22 20:02:07 +00:00
runBool repo subcommand params
>>! error $ "git " ++ show params ++ " failed"
2010-10-10 19:04:18 +00:00
{- Runs a git subcommand and returns its output, lazily.
-
- Note that this leaves the git process running, and so zombies will
- result unless reap is called.
-}
2011-02-28 20:25:31 +00:00
pipeRead :: Repo -> [CommandParam] -> IO String
2010-10-22 18:05:30 +00:00
pipeRead repo params = assertLocal repo $ do
2011-02-28 20:25:31 +00:00
(_, s) <- pipeFrom "git" $ toCommand $ gitCommandLine repo params
return s
{- Runs a git subcommand, feeding it input.
- You should call either getProcessStatus or forceSuccess on the PipeHandle. -}
pipeWrite :: Repo -> [CommandParam] -> String -> IO PipeHandle
pipeWrite repo params s = assertLocal repo $
pipeTo "git" (toCommand $ gitCommandLine repo params) s
{- Runs a git subcommand, feeding it input, and returning its output.
- You should call either getProcessStatus or forceSuccess on the PipeHandle. -}
pipeWriteRead :: Repo -> [CommandParam] -> String -> IO (PipeHandle, String)
pipeWriteRead repo params s = assertLocal repo $
pipeBoth "git" (toCommand $ gitCommandLine repo params) s
{- Reaps any zombie git processes. -}
reap :: IO ()
reap = do
-- throws an exception when there are no child processes
r <- catch (getAnyProcessStatus False True) (\_ -> return Nothing)
2011-05-15 06:49:43 +00:00
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 <- try $ getEnv var
setEnv var index True
return $ reset res
where
var = "GIT_INDEX_FILE"
reset (Right (Just v)) = setEnv var v True
reset _ = unsetEnv var
{- Injects some content into git, returning its hash. -}
hashObject :: Repo -> String -> IO String
hashObject repo content = getSha subcmd $ do
(h, s) <- pipeWriteRead repo (map Param params) content
length s `seq` do
forceSuccess h
reap -- XXX unsure why this is needed
return s
where
subcmd = "hash-object"
params = [subcmd, "-w", "--stdin"]
{- 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 String
getSha subcommand a = do
t <- a
let t' = if last t == '\n'
then take (length t - 1) t
else t
when (length t' /= shaSize) $
error $ "failed to read sha from git " ++ subcommand ++ " (" ++ t' ++ ")"
return t'
{- Size of a git sha. -}
shaSize :: Int
shaSize = 40
2011-06-21 20:08:09 +00:00
{- Scans for files that are checked into git at the specified locations. -}
inRepo :: Repo -> [FilePath] -> IO [FilePath]
inRepo repo l = pipeNullSplit repo $
[Params "ls-files --cached --exclude-standard -z --"] ++ map File l
{- Scans for files at the specified locations that are not checked into git,
- and not gitignored. -}
notInRepo :: Repo -> [FilePath] -> IO [FilePath]
notInRepo repo l = pipeNullSplit repo $
[Params "ls-files --others --exclude-standard -z --"] ++ map File l
2011-02-02 01:58:47 +00:00
{- Returns a list of all files that are staged for commit. -}
stagedFiles :: Repo -> [FilePath] -> IO [FilePath]
stagedFiles repo l = stagedFiles' repo l []
{- Returns a list of the files, staged for commit, that are being added,
- moved, or changed (but not deleted), from the specified locations. -}
2011-02-02 01:58:47 +00:00
stagedFilesNotDeleted :: Repo -> [FilePath] -> IO [FilePath]
stagedFilesNotDeleted repo l = stagedFiles' repo l [Param "--diff-filter=ACMRT"]
2011-02-02 01:58:47 +00:00
2011-02-28 20:25:31 +00:00
stagedFiles' :: Repo -> [FilePath] -> [CommandParam] -> IO [FilePath]
2011-02-02 01:58:47 +00:00
stagedFiles' repo l middle = pipeNullSplit repo $ start ++ middle ++ end
where
start = [Params "diff --cached --name-only -z"]
end = [Param "--"] ++ map File l
2010-11-10 18:01:41 +00:00
{- Returns a list of files that have unstaged changes. -}
changedUnstagedFiles :: Repo -> [FilePath] -> IO [FilePath]
changedUnstagedFiles repo l = pipeNullSplit repo $
[Params "diff --name-only -z --"] ++ map File l
{- Returns a list of the files in the specified locations that are staged
- for commit, and whose type has changed. -}
typeChangedStagedFiles :: Repo -> [FilePath] -> IO [FilePath]
typeChangedStagedFiles repo l = typeChangedFiles' repo l [Param "--cached"]
{- Returns a list of the files in the specified locations whose type has
- changed. Files only staged for commit will not be included. -}
typeChangedFiles :: Repo -> [FilePath] -> IO [FilePath]
typeChangedFiles repo l = typeChangedFiles' repo l []
2011-02-28 20:25:31 +00:00
typeChangedFiles' :: Repo -> [FilePath] -> [CommandParam] -> IO [FilePath]
typeChangedFiles' repo l middle = pipeNullSplit repo $ start ++ middle ++ end
2010-11-10 18:01:41 +00:00
where
start = [Params "diff --name-only --diff-filter=T -z"]
end = [Param "--"] ++ map File l
{- Reads null terminated output of a git command (as enabled by the -z
- parameter), and splits it into a list of files/lines/whatever. -}
2011-02-28 20:25:31 +00:00
pipeNullSplit :: Repo -> [CommandParam] -> IO [FilePath]
pipeNullSplit repo params = do
fs0 <- pipeRead repo params
return $ split0 fs0
where
split0 s = filter (not . null) $ split "\0" s
2010-10-29 21:26:26 +00:00
2010-12-31 19:46:33 +00:00
{- Runs git config and populates a repo with its config. -}
configRead :: Repo -> IO Repo
configRead repo@(Repo { location = Dir d }) = do
{- Cannot use pipeRead because it relies on the config having
been already read. Instead, chdir to the repo. -}
cwd <- getCurrentDirectory
bracket_ (changeWorkingDirectory d)
(\_ -> changeWorkingDirectory cwd) $
pOpen ReadFromPipe "git" ["config", "--list"] $
hConfigRead repo
2010-12-31 19:46:33 +00:00
configRead r = assertLocal r $ error "internal"
{- Reads git config from a handle and populates a repo with it. -}
2010-10-31 19:38:47 +00:00
hConfigRead :: Repo -> Handle -> IO Repo
hConfigRead repo h = do
val <- hGetContentsStrict h
configStore repo val
2010-12-31 19:46:33 +00:00
{- Parses a git config and returns a version of the repo using it. -}
configStore :: Repo -> String -> IO Repo
configStore repo s = do
rs <- configRemotes r
return $ r { remotes = rs }
where
r = repo { config = configParse s }
2010-10-14 02:59:43 +00:00
{- Calculates a list of a repo's configured remotes, by parsing its config. -}
configRemotes :: Repo -> IO [Repo]
configRemotes repo = mapM construct remotepairs
2010-10-14 02:59:43 +00:00
where
2010-10-31 19:38:47 +00:00
remotepairs = Map.toList $ filterremotes $ config repo
filterremotes = Map.filterWithKey (\k _ -> isremote k)
isremote k = startswith "remote." k && endswith ".url" k
construct (k,v) = do
r <- gen v
return $ repoRemoteNameSet r k
gen v | scpstyle v = repoFromUrl $ scptourl v
| isURI v = repoFromUrl v
| otherwise = repoFromRemotePath v repo
-- git remotes can be written scp style -- [user@]host:dir
2011-01-27 21:58:30 +00:00
scpstyle v = ":" `isInfixOf` v && (not $ "//" `isInfixOf` v)
scptourl v = "ssh://" ++ host ++ slash dir
where
bits = split ":" v
host = bits !! 0
dir = join ":" $ drop 1 bits
slash d | d == "" = "/~/" ++ dir
| d !! 0 == '/' = dir
| d !! 0 == '~' = '/':dir
| otherwise = "/~/" ++ dir
2010-10-12 03:41:12 +00:00
{- Checks if a string from git config is a true value. -}
configTrue :: String -> Bool
configTrue s = map toLower s == "true"
2010-10-12 03:41:12 +00:00
{- Parses git config --list output into a config map. -}
2010-10-14 06:36:41 +00:00
configParse :: String -> Map.Map String String
configParse s = Map.fromList $ map pair $ lines s
2010-10-12 03:41:12 +00:00
where
pair l = (key l, val l)
key l = head $ keyval l
2010-10-12 03:41:12 +00:00
val l = join sep $ drop 1 $ keyval l
keyval l = split sep l :: [String]
sep = "="
2010-10-12 03:22:38 +00:00
{- Returns a single git config setting, or a default value if not set. -}
2010-10-14 06:36:41 +00:00
configGet :: Repo -> String -> String -> String
configGet repo key defaultValue =
2010-10-12 16:31:19 +00:00
Map.findWithDefault defaultValue key (config repo)
2010-10-12 05:35:32 +00:00
2010-10-14 02:59:43 +00:00
{- Access to raw config Map -}
2010-10-29 21:26:26 +00:00
configMap :: Repo -> Map.Map String String
2010-10-14 06:36:41 +00:00
configMap repo = config repo
{- Efficiently looks up a gitattributes value for each file in a list. -}
2010-11-02 16:43:34 +00:00
checkAttr :: Repo -> String -> [FilePath] -> IO [(FilePath, String)]
checkAttr repo attr files = do
-- git check-attr wants files that are absolute (or relative to the
-- top of the repo). But we're passed files relative to the current
-- directory. Convert to absolute, and then convert the filenames
-- in its output back to relative.
cwd <- getCurrentDirectory
2011-03-23 01:00:18 +00:00
let absfiles = map (absPathFrom cwd) files
(_, fromh, toh) <- hPipeBoth "git" (toCommand params)
_ <- forkProcess $ do
hClose fromh
hPutStr toh $ join "\0" absfiles
hClose toh
exitSuccess
hClose toh
s <- hGetContents fromh
return $ map (topair $ cwd++"/") $ lines s
2010-11-02 16:43:34 +00:00
where
params = gitCommandLine repo [Param "check-attr", Param attr, Params "-z --stdin"]
topair cwd l = (relfile, value)
2010-11-02 16:43:34 +00:00
where
relfile
| startswith cwd file = drop (length cwd) file
| otherwise = file
2010-11-02 16:43:34 +00:00
file = decodeGitFile $ join sep $ take end bits
value = bits !! end
end = length bits - 1
bits = split sep l
sep = ": " ++ attr ++ ": "
2010-11-02 20:00:55 +00:00
{- Some git commands output encoded filenames. Decode that (annoyingly
- complex) encoding. -}
2010-11-02 16:43:34 +00:00
decodeGitFile :: String -> FilePath
decodeGitFile [] = []
decodeGitFile f@(c:s)
2010-11-02 20:00:55 +00:00
-- encoded strings will be inside double quotes
| c == '"' = unescape ("", middle)
2010-11-02 16:43:34 +00:00
| otherwise = f
where
2010-11-02 20:00:55 +00:00
e = '\\'
2010-11-02 16:43:34 +00:00
middle = take (length s - 1) s
unescape (b, []) = b
2010-11-02 20:00:55 +00:00
-- look for escapes starting with '\'
unescape (b, v) = b ++ beginning ++ unescape (decode rest)
2010-11-02 16:43:34 +00:00
where
2010-11-02 20:00:55 +00:00
pair = span (/= e) v
2010-11-02 16:43:34 +00:00
beginning = fst pair
rest = snd pair
2010-11-02 20:49:35 +00:00
isescape x = x == e
2010-11-02 20:00:55 +00:00
-- \NNN is an octal encoded character
2010-11-02 20:49:35 +00:00
decode (x:n1:n2:n3:rest)
| isescape x && alloctal = (fromoctal, rest)
where
alloctal = isOctDigit n1 &&
isOctDigit n2 &&
isOctDigit n3
fromoctal = [chr $ readoctal [n1, n2, n3]]
readoctal o = read $ "0o" ++ o :: Int
2010-11-02 20:00:55 +00:00
-- \C is used for a few special characters
2010-11-02 20:49:35 +00:00
decode (x:nc:rest)
| isescape x = ([echar nc], rest)
2010-11-02 16:43:34 +00:00
where
echar 'a' = '\a'
echar 'b' = '\b'
echar 'f' = '\f'
echar 'n' = '\n'
echar 'r' = '\r'
echar 't' = '\t'
echar 'v' = '\v'
2010-11-02 20:49:35 +00:00
echar a = a
decode n = ("", n)
{- Should not need to use this, except for testing decodeGitFile. -}
encodeGitFile :: FilePath -> String
encodeGitFile s = foldl (++) "\"" (map echar s) ++ "\""
where
e c = '\\' : [c]
echar '\a' = e 'a'
echar '\b' = e 'b'
echar '\f' = e 'f'
echar '\n' = e 'n'
echar '\r' = e 'r'
echar '\t' = e 't'
echar '\v' = e 'v'
echar '\\' = e '\\'
echar '"' = e '"'
echar x
| ord x < 0x20 = e_num x -- low ascii
| ord x >= 256 = e_utf x
| ord x > 0x7E = e_num x -- high ascii
| otherwise = [x] -- printable ascii
where
showoctal i = '\\' : printf "%03o" i
e_num c = showoctal $ ord c
2010-11-02 20:02:43 +00:00
-- unicode character is decomposed to
-- Word8s and each is shown in octal
2011-05-16 18:49:28 +00:00
e_utf c = showoctal =<< (encode [c] :: [Word8])
{- for quickcheck -}
2010-11-02 20:49:35 +00:00
prop_idempotent_deencode :: String -> Bool
prop_idempotent_deencode s = s == decodeGitFile (encodeGitFile s)
2010-11-02 16:43:34 +00:00
{- Constructs a Repo from the path specified in the git remotes of
- another Repo. -}
repoFromRemotePath :: FilePath -> Repo -> IO Repo
repoFromRemotePath dir repo = do
dir' <- expandTilde dir
repoFromAbsPath $ workTree repo </> dir'
{- Git remotes can have a directory that is specified relative
- to the user's home directory, or that contains tilde expansions.
- This converts such a directory to an absolute path.
- Note that it has to run on the system where the remote is.
-}
repoAbsPath :: FilePath -> IO FilePath
repoAbsPath d = do
d' <- expandTilde d
h <- myHomeDir
return $ h </> d'
expandTilde :: FilePath -> IO FilePath
expandTilde = expandt True
where
expandt _ [] = return ""
expandt _ ('/':cs) = do
v <- expandt True cs
return ('/':v)
expandt True ('~':'/':cs) = do
h <- myHomeDir
return $ h </> cs
expandt True ('~':cs) = do
let (name, rest) = findname "" cs
u <- getUserEntryForName name
return $ homeDirectory u </> rest
expandt _ (c:cs) = do
v <- expandt False cs
return (c:v)
findname n [] = (n, "")
findname n (c:cs)
| c == '/' = (n, cs)
| otherwise = findname (n++[c]) cs
{- Finds the current git repository, which may be in a parent directory. -}
2010-10-14 06:36:41 +00:00
repoFromCwd :: IO Repo
2011-05-15 16:25:58 +00:00
repoFromCwd = getCurrentDirectory >>= seekUp isRepoTop >>= maybe norepo makerepo
where
makerepo = return . newFrom . Dir
norepo = error "Not in a git repository."
seekUp :: (FilePath -> IO Bool) -> FilePath -> IO (Maybe FilePath)
seekUp want dir = do
2010-10-10 01:06:46 +00:00
ok <- want dir
if ok
then return (Just dir)
else case (parentDir dir) of
2010-10-10 03:35:05 +00:00
"" -> return Nothing
2011-05-15 16:25:58 +00:00
d -> seekUp want d
2010-10-10 01:06:46 +00:00
2010-10-31 19:38:47 +00:00
isRepoTop :: FilePath -> IO Bool
2010-10-10 01:06:46 +00:00
isRepoTop dir = do
2010-10-31 19:38:47 +00:00
r <- isRepo
b <- isBareRepo
2010-10-10 01:06:46 +00:00
return (r || b)
where
2010-10-31 19:38:47 +00:00
isRepo = gitSignature ".git" ".git/config"
isBareRepo = gitSignature "objects" "config"
gitSignature subdir file = do
s <- (doesDirectoryExist (dir ++ "/" ++ subdir))
f <- (doesFileExist (dir ++ "/" ++ file))
return (s && f)