diff options
Diffstat (limited to 'Git')
| -rw-r--r-- | Git/Command.hs | 13 | ||||
| -rw-r--r-- | Git/Config.hs | 62 | ||||
| -rw-r--r-- | Git/Construct.hs | 10 | ||||
| -rw-r--r-- | Git/LsFiles.hs | 2 | ||||
| -rw-r--r-- | Git/Types.hs | 20 |
5 files changed, 74 insertions, 33 deletions
diff --git a/Git/Command.hs b/Git/Command.hs index bb82d1339..35f0838ba 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -1,6 +1,6 @@ {- running git commands - - - Copyright 2010, 2011 Joey Hess <joey@kitenet.net> + - Copyright 2010-2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -18,11 +18,12 @@ import Git.Types {- Constructs a git command line operating on the specified repo. -} gitCommandLine :: [CommandParam] -> Repo -> [CommandParam] -gitCommandLine params repo@(Repo { location = Dir _ } ) = - -- force use of specified repo via --git-dir and --work-tree - [ Param ("--git-dir=" ++ gitDir repo) - , Param ("--work-tree=" ++ workTree repo) - ] ++ params +gitCommandLine params Repo { location = l@(Local _ _ ) } = setdir : settree ++ params + where + setdir = Param $ "--git-dir=" ++ gitdir l + settree = case worktree l of + Nothing -> [] + Just t -> [Param $ "--work-tree=" ++ t] gitCommandLine _ repo = assertLocal repo $ error "internal" {- Runs git in the specified repo. -} diff --git a/Git/Config.hs b/Git/Config.hs index 38b9ade45..e37b43707 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -1,15 +1,14 @@ {- git repository configuration handling - - - Copyright 2010,2011 Joey Hess <joey@kitenet.net> + - Copyright 2010-2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} module Git.Config where -import System.Posix.Directory -import Control.Exception (bracket_) import qualified Data.Map as M +import Data.Char import Common import Git @@ -30,17 +29,14 @@ getMaybe key repo = M.lookup key (config repo) {- Runs git config and populates a repo with its config. -} read :: Repo -> IO Repo -read repo@(Repo { location = Dir d }) = bracketcd d $ - {- Cannot use pipeRead because it relies on the config having - been already read. Instead, chdir to the repo. -} +read repo@(Repo { location = Local { gitdir = d } }) = read' repo d +read repo@(Repo { location = LocalUnknown d }) = read' repo d +read r = assertLocal r $ error "internal" +{- Cannot use pipeRead because it relies on the config having + been already read. Instead, chdir to the repo. -} +read' :: Repo -> FilePath -> IO Repo +read' repo d = bracketCd d $ pOpen ReadFromPipe "git" ["config", "--null", "--list"] $ hRead repo - where - bracketcd to a = bracketcd' to a =<< getCurrentDirectory - bracketcd' to a cwd - | dirContains to cwd = a - | otherwise = bracket_ (changeWorkingDirectory to) (changeWorkingDirectory cwd) a -read r = assertLocal r $ - error $ "internal error; trying to read config of " ++ show r {- Reads git config from a handle and populates a repo with it. -} hRead :: Repo -> Handle -> IO Repo @@ -48,19 +44,42 @@ hRead repo h = do val <- hGetContentsStrict h store val repo -{- Stores a git config into a repo, returning the new version of the repo. - - The git config may be multiple lines, or a single line. Config settings - - can be updated inrementally. -} +{- Stores a git config into a Repo, returning the new version of the Repo. + - The git config may be multiple lines, or a single line. + - Config settings can be updated incrementally. + -} store :: String -> Repo -> IO Repo store s repo = do let c = parse s - let repo' = repo + let repo' = updateLocation $ repo { config = (M.map Prelude.head c) `M.union` config repo , fullconfig = M.unionWith (++) c (fullconfig repo) } + print repo' rs <- Git.Construct.fromRemotes repo' return $ repo' { remotes = rs } +{- Updates the location of a repo, based on its configuration. + - + - Git.Construct makes LocalUknown repos, of which only a directory is + - known. Once the config is read, this can be fixed up to a Local repo, + - based on the core.bare and core.worktree settings. + -} +updateLocation :: Repo -> Repo +updateLocation r = go $ location r + where + go (LocalUnknown d) + | isbare = ret $ Local d Nothing + | otherwise = ret $ Local (d </> ".git") (Just d) + go l@(Local {}) = ret l + go _ = r + isbare = fromMaybe False $ isTrue =<< getMaybe "core.bare" r + ret l = r { location = l' } + where + l' = maybe l (setworktree l) $ + getMaybe "core.worktree" r + setworktree l t = l { worktree = Just t } + {- Parses git config --list or git config --null --list output into a - config map. -} parse :: String -> M.Map String [String] @@ -74,3 +93,12 @@ parse s ls = lines s sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) . map (separate (== c)) + +{- Checks if a string from git config is a true value. -} +isTrue :: String -> Maybe Bool +isTrue s + | s' == "true" = Just True + | s' == "false" = Just False + | otherwise = Nothing + where + s' = map toLower s diff --git a/Git/Construct.hs b/Git/Construct.hs index 3f3ea9747..45ea0f64d 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -1,6 +1,6 @@ {- Construction of Git Repo objects - - - Copyright 2010,2011 Joey Hess <joey@kitenet.net> + - Copyright 2010-2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -58,7 +58,7 @@ fromCurrent = do fromCwd :: IO Repo fromCwd = getCurrentDirectory >>= seekUp isRepoTop >>= maybe norepo makerepo where - makerepo = newFrom . Dir + makerepo = newFrom . LocalUnknown norepo = error "Not in a git repository." {- Local Repo constructor, accepts a relative or absolute path. -} @@ -74,7 +74,7 @@ fromAbsPath dir | otherwise = error $ "internal error, " ++ dir ++ " is not absolute" where - ret = newFrom . Dir + ret = newFrom . LocalUnknown {- Git always looks for "dir.git" in preference to - to "dir", even if dir ends in a "/". -} canondir = dropTrailingPathSeparator dir @@ -122,7 +122,7 @@ localToUrl reference r absurl = Url.scheme reference ++ "//" ++ Url.authority reference ++ - workTree r + repoPath r {- Calculates a list of a repo's configured remotes, by parsing its config. -} fromRemotes :: Repo -> IO [Repo] @@ -191,7 +191,7 @@ fromRemoteLocation s repo = gen $ calcloc s fromRemotePath :: FilePath -> Repo -> IO Repo fromRemotePath dir repo = do dir' <- expandTilde dir - fromAbsPath $ workTree repo </> dir' + fromAbsPath $ repoPath repo </> dir' {- Git remotes can have a directory that is specified relative - to the user's home directory, or that contains tilde expansions. diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index 201d76d1d..06d4b9f44 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -69,7 +69,7 @@ typeChanged' ps l repo = do fs <- pipeNullSplit (prefix ++ ps ++ suffix) repo -- git diff returns filenames relative to the top of the git repo; -- convert to filenames relative to the cwd, like git ls-files. - let top = workTree repo + let top = repoPath repo cwd <- getCurrentDirectory return $ map (\f -> relPathDirToFile cwd $ top </> f) fs where diff --git a/Git/Types.hs b/Git/Types.hs index 6063ad213..deb14ebd4 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -1,6 +1,6 @@ {- git data types - - - Copyright 2010,2011 Joey Hess <joey@kitenet.net> + - Copyright 2010-2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -10,9 +10,21 @@ module Git.Types where import Network.URI import qualified Data.Map as M -{- There are two types of repositories; those on local disk and those - - accessed via an URL. -} -data RepoLocation = Dir FilePath | Url URI | Unknown +{- Support repositories on local disk, and repositories accessed via an URL. + - + - Repos on local disk have a git directory, and unless bare, a worktree. + - + - A local repo may not have had its config read yet, in which case all + - that's known about it is its path. + - + - Finally, an Unknown repository may be known to exist, but nothing + - else known about it. + -} +data RepoLocation + = Local { gitdir :: FilePath, worktree :: Maybe FilePath } + | LocalUnknown FilePath + | Url URI + | Unknown deriving (Show, Eq) data Repo = Repo { |