5c32196a37
Fix process and file descriptor leak that was exposed when git-annex was built with ghc 8.2.1. Apparently ghc has changed its behavior of GC of open file handles that are pipes to running processes. That broke git-annex test on OSX due to running out of FDs. Audited for all uses of Annex.new and made stopCoProcesses be called once it's done with the state. Fixed several places that might have leaked in other situations than running the test suite. This commit was sponsored by Ewen McNeill.
89 lines
2.8 KiB
Haskell
89 lines
2.8 KiB
Haskell
{- making local repositories (used by webapp mostly)
|
|
-
|
|
- Copyright 2012-2014 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Annex.MakeRepo where
|
|
|
|
import Assistant.WebApp.Common
|
|
import Annex.Init
|
|
import qualified Git.Construct
|
|
import qualified Git.Config
|
|
import qualified Git.Command
|
|
import qualified Git.Branch
|
|
import qualified Annex
|
|
import Annex.UUID
|
|
import Annex.Direct
|
|
import Annex.Action
|
|
import Types.StandardGroups
|
|
import Logs.PreferredContent
|
|
import qualified Annex.Branch
|
|
|
|
{- Makes a new git repository. Or, if a git repository already
|
|
- exists, returns False. -}
|
|
makeRepo :: FilePath -> Bool -> IO Bool
|
|
makeRepo path bare = ifM (probeRepoExists path)
|
|
( return False
|
|
, do
|
|
(transcript, ok) <-
|
|
processTranscript "git" (toCommand params) Nothing
|
|
unless ok $
|
|
error $ "git init failed!\nOutput:\n" ++ transcript
|
|
return True
|
|
)
|
|
where
|
|
baseparams = [Param "init", Param "--quiet"]
|
|
params
|
|
| bare = baseparams ++ [Param "--bare", File path]
|
|
| otherwise = baseparams ++ [File path]
|
|
|
|
{- Runs an action in the git repository in the specified directory. -}
|
|
inDir :: FilePath -> Annex a -> IO a
|
|
inDir dir a = do
|
|
state <- Annex.new =<< Git.Config.read =<< Git.Construct.fromPath dir
|
|
Annex.eval state $ a `finally` stopCoProcesses
|
|
|
|
{- Creates a new repository, and returns its UUID. -}
|
|
initRepo :: Bool -> Bool -> FilePath -> Maybe String -> Maybe StandardGroup -> IO UUID
|
|
initRepo True primary_assistant_repo dir desc mgroup = inDir dir $ do
|
|
initRepo' desc mgroup
|
|
{- Initialize the master branch, so things that expect
|
|
- to have it will work, before any files are added. -}
|
|
unlessM (Git.Config.isBare <$> gitRepo) $
|
|
void $ inRepo $ Git.Branch.commitCommand Git.Branch.AutomaticCommit
|
|
[ Param "--quiet"
|
|
, Param "--allow-empty"
|
|
, Param "-m"
|
|
, Param "created repository"
|
|
]
|
|
{- Repositories directly managed by the assistant use direct mode.
|
|
-
|
|
- Automatic gc is disabled, as it can be slow. Insted, gc is done
|
|
- once a day.
|
|
-}
|
|
when primary_assistant_repo $ do
|
|
setDirect True
|
|
inRepo $ Git.Command.run
|
|
[Param "config", Param "gc.auto", Param "0"]
|
|
getUUID
|
|
{- Repo already exists, could be a non-git-annex repo though so
|
|
- still initialize it. -}
|
|
initRepo False _ dir desc mgroup = inDir dir $ do
|
|
initRepo' desc mgroup
|
|
getUUID
|
|
|
|
initRepo' :: Maybe String -> Maybe StandardGroup -> Annex ()
|
|
initRepo' desc mgroup = unlessM isInitialized $ do
|
|
initialize desc Nothing
|
|
u <- getUUID
|
|
maybe noop (defaultStandardGroup u) mgroup
|
|
{- Ensure branch gets committed right away so it is
|
|
- available for merging immediately. -}
|
|
Annex.Branch.commit "update"
|
|
|
|
{- Checks if a git repo exists at a location. -}
|
|
probeRepoExists :: FilePath -> IO Bool
|
|
probeRepoExists dir = isJust <$>
|
|
catchDefaultIO Nothing (Git.Construct.checkForRepo dir)
|