diff options
Diffstat (limited to 'Git')
| -rw-r--r-- | Git/CatFile.hs | 2 | ||||
| -rw-r--r-- | Git/Command.hs | 4 | ||||
| -rw-r--r-- | Git/Config.hs | 3 | ||||
| -rw-r--r-- | Git/LsTree.hs | 2 | ||||
| -rw-r--r-- | Git/Objects.hs | 14 | ||||
| -rw-r--r-- | Git/Remote.hs | 10 | ||||
| -rw-r--r-- | Git/Repair.hs | 19 | ||||
| -rw-r--r-- | Git/UpdateIndex.hs | 2 | ||||
| -rw-r--r-- | Git/Version.hs | 2 |
9 files changed, 40 insertions, 18 deletions
diff --git a/Git/CatFile.hs b/Git/CatFile.hs index 8e64fc5..d0bcef4 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -94,7 +94,7 @@ catTree :: CatFileHandle -> Ref -> IO [(FilePath, FileMode)] catTree h treeref = go <$> catObjectDetails h treeref where go (Just (b, _, TreeObject)) = parsetree [] b - go _ = [] + go _ = [] parsetree c b = case L.break (== 0) b of (modefile, rest) diff --git a/Git/Command.hs b/Git/Command.hs index 30d2dcb..c61cc9f 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -79,7 +79,7 @@ pipeWriteRead params writer repo = assertLocal repo $ writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo) (gitEnv repo) writer (Just adjusthandle) where - adjusthandle h = do + adjusthandle h = do fileEncoding h hSetNewlineMode h noNewlineTranslation @@ -117,7 +117,7 @@ gitCoProcessStart restartable params repo = CoProcess.start numrestarts "git" (toCommand $ gitCommandLine params repo) (gitEnv repo) where - {- If a long-running git command like cat-file --batch + {- If a long-running git command like cat-file --batch - crashes, it will likely start up again ok. If it keeps crashing - 10 times, something is badly wrong. -} numrestarts = if restartable then 10 else 0 diff --git a/Git/Config.hs b/Git/Config.hs index d998fd1..32c0dd1 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -9,7 +9,6 @@ module Git.Config where import qualified Data.Map as M import Data.Char -import Control.Exception.Extensible import Common import Git @@ -168,7 +167,7 @@ coreBare = "core.bare" fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, String)) fromPipe r cmd params = try $ withHandle StdoutHandle createProcessSuccess p $ \h -> do - fileEncoding h + fileEncoding h val <- hGetContentsStrict h r' <- store val r return (r', val) diff --git a/Git/LsTree.hs b/Git/LsTree.hs index 6d3ca48..ca5e323 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -44,7 +44,7 @@ lsTreeParams t = [ Params "ls-tree --full-tree -z -r --", File $ fromRef t ] lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem] lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo where - ps = [Params "ls-tree --full-tree -z --", File $ fromRef t] ++ map File fs + ps = [Params "ls-tree --full-tree -z --", File $ fromRef t] ++ map File fs {- Parses a line of ls-tree output. - (The --long format is not currently supported.) -} diff --git a/Git/Objects.hs b/Git/Objects.hs index 516aa6d..dadd4f5 100644 --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -33,3 +33,17 @@ looseObjectFile :: Repo -> Sha -> FilePath looseObjectFile r sha = objectsDir r </> prefix </> rest where (prefix, rest) = splitAt 2 (fromRef sha) + +listAlternates :: Repo -> IO [FilePath] +listAlternates r = catchDefaultIO [] (lines <$> readFile alternatesfile) + where + alternatesfile = objectsDir r </> "info" </> "alternates" + +{- A repository recently cloned with --shared will have one or more + - alternates listed, and contain no loose objects or packs. -} +isSharedClone :: Repo -> IO Bool +isSharedClone r = allM id + [ not . null <$> listAlternates r + , null <$> listLooseObjectShas r + , null <$> listPackFiles r + ] diff --git a/Git/Remote.hs b/Git/Remote.hs index 9d969c4..7e8e5f8 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -70,7 +70,7 @@ remoteLocationIsSshUrl _ = False parseRemoteLocation :: String -> Repo -> RemoteLocation parseRemoteLocation s repo = ret $ calcloc s where - ret v + ret v #ifdef mingw32_HOST_OS | dosstyle v = RemotePath (dospath v) #endif @@ -102,7 +102,13 @@ parseRemoteLocation s repo = ret $ calcloc s && not ("::" `isInfixOf` v) scptourl v = "ssh://" ++ host ++ slash dir where - (host, dir) = separate (== ':') v + (host, dir) + -- handle ipv6 address inside [] + | "[" `isPrefixOf` v = case break (== ']') v of + (h, ']':':':d) -> (h ++ "]", d) + (h, ']':d) -> (h ++ "]", d) + (h, d) -> (h, d) + | otherwise = separate (== ':') v slash d | d == "" = "/~/" ++ d | "/" `isPrefixOf` d = d | "~" `isPrefixOf` d = '/':d diff --git a/Git/Repair.hs b/Git/Repair.hs index 43f0a56..77a592b 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -135,11 +135,16 @@ retrieveMissingObjects missing referencerepo r pullremotes tmpr rmts fetchrefs (FsckFoundMissing stillmissing t) , pullremotes tmpr rmts fetchrefs ms ) - fetchfrom fetchurl ps = runBool $ - [ Param "fetch" - , Param fetchurl - , Params "--force --update-head-ok --quiet" - ] ++ ps + fetchfrom fetchurl ps fetchr = runBool ps' fetchr' + where + ps' = + [ Param "fetch" + , Param fetchurl + , Params "--force --update-head-ok --quiet" + ] ++ ps + fetchr' = fetchr { gitGlobalOpts = gitGlobalOpts fetchr ++ nogc } + nogc = [ Param "-c", Param "gc.auto=0" ] + -- fetch refs and tags fetchrefstags = [ Param "+refs/heads/*:refs/heads/*", Param "--tags"] -- Fetch all available refs (more likely to fail, @@ -222,7 +227,7 @@ badBranches missing r = filterM isbad =<< getAllRefs r getAllRefs :: Repo -> IO [Ref] getAllRefs r = map toref <$> dirContentsRecursive refdir where - refdir = localGitDir r </> "refs" + refdir = localGitDir r </> "refs" toref = Ref . relPathDirToFile (localGitDir r) explodePackedRefsFile :: Repo -> IO () @@ -411,7 +416,7 @@ displayList items header putStrLn header putStr $ unlines $ map (\i -> "\t" ++ i) truncateditems where - numitems = length items + numitems = length items truncateditems | numitems > 10 = take 10 items ++ ["(and " ++ show (numitems - 10) ++ " more)"] | otherwise = items diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 7de2f1b..ecd154a 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -29,8 +29,6 @@ import Git.Command import Git.FilePath import Git.Sha -import Control.Exception (bracket) - {- Streamers are passed a callback and should feed it lines in the form - read by update-index, and generated by ls-tree. -} type Streamer = (String -> IO ()) -> IO () diff --git a/Git/Version.hs b/Git/Version.hs index 5ad1d59..5c61f85 100644 --- a/Git/Version.hs +++ b/Git/Version.hs @@ -21,7 +21,7 @@ instance Show GitVersion where installed :: IO GitVersion installed = normalize . extract <$> readProcess "git" ["--version"] where - extract s = case lines s of + extract s = case lines s of [] -> "" (l:_) -> unwords $ drop 2 $ words l |