reorg

Annex/Init.hs

@@ -0,0 +1,240 @@
+{- git-annex repository initialization
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Init (
+	ensureInitialized,
+	isInitialized,
+	initialize,
+	uninitialize,
+	probeCrippledFileSystem,
+) where
+
+import Common.Annex
+import Utility.Network
+import qualified Annex
+import qualified Git
+import qualified Git.LsFiles
+import qualified Git.Config
+import qualified Git.Construct
+import qualified Git.Types as Git
+import qualified Annex.Branch
+import Logs.UUID
+import Annex.Version
+import Annex.UUID
+import Config
+import Annex.Direct
+import Annex.Content.Direct
+import Annex.Environment
+import Annex.Perms
+import Backend
+#ifndef mingw32_HOST_OS
+import Utility.UserInfo
+import Utility.FileMode
+#endif
+import Annex.Hook
+import Git.Hook (hookFile)
+import Upgrade
+import Annex.Content
+import Logs.Location
+
+import System.Log.Logger
+
+genDescription :: Maybe String -> Annex String
+genDescription (Just d) = return d
+genDescription Nothing = do
+	reldir <- liftIO . relHome =<< fromRepo Git.repoPath
+	hostname <- fromMaybe "" <$> liftIO getHostname
+#ifndef mingw32_HOST_OS
+	let at = if null hostname then "" else "@"
+	username <- liftIO myUserName
+	return $ concat [username, at, hostname, ":", reldir]
+#else
+	return $ concat [hostname, ":", reldir]
+#endif
+
+initialize :: Maybe String -> Annex ()
+initialize mdescription = do
+	prepUUID
+	checkFifoSupport
+	checkCrippledFileSystem
+	unlessM isBare $
+		hookWrite preCommitHook
+	setVersion supportedVersion
+	ifM (crippledFileSystem <&&> not <$> isBare)
+		( do
+			enableDirectMode
+			setDirect True
+		, do
+			-- Handle case where this repo was cloned from a
+			-- direct mode repo.
+			unlessM isBare
+				switchHEADBack
+		)
+	createInodeSentinalFile
+	u <- getUUID
+	{- This will make the first commit to git, so ensure git is set up
+	 - properly to allow commits when running it. -}
+	ensureCommit $ do
+		Annex.Branch.create
+		describeUUID u =<< genDescription mdescription
+
+uninitialize :: Annex ()
+uninitialize = do
+	hookUnWrite preCommitHook
+	removeRepoUUID
+	removeVersion
+
+{- Will automatically initialize if there is already a git-annex
+ - branch from somewhere. Otherwise, require a manual init
+ - to avoid git-annex accidentially being run in git
+ - repos that did not intend to use it.
+ -
+ - Checks repository version and handles upgrades too.
+ -}
+ensureInitialized :: Annex ()
+ensureInitialized = do
+	getVersion >>= maybe needsinit checkUpgrade
+	fixBadBare
+  where
+	needsinit = ifM Annex.Branch.hasSibling
+			( initialize Nothing
+			, error "First run: git-annex init"
+			)
+
+{- Checks if a repository is initialized. Does not check version for ugrade. -}
+isInitialized :: Annex Bool
+isInitialized = maybe Annex.Branch.hasSibling (const $ return True) =<< getVersion
+
+isBare :: Annex Bool
+isBare = fromRepo Git.repoIsLocalBare
+
+{- A crippled filesystem is one that does not allow making symlinks,
+ - or removing write access from files. -}
+probeCrippledFileSystem :: Annex Bool
+probeCrippledFileSystem = do
+#ifdef mingw32_HOST_OS
+	return True
+#else
+	tmp <- fromRepo gitAnnexTmpDir
+	let f = tmp </> "gaprobe"
+	createAnnexDirectory tmp
+	liftIO $ writeFile f ""
+	uncrippled <- liftIO $ probe f
+	liftIO $ removeFile f
+	return $ not uncrippled
+  where
+	probe f = catchBoolIO $ do
+		let f2 = f ++ "2"
+		nukeFile f2
+		createSymbolicLink f f2
+		nukeFile f2
+		preventWrite f
+		allowWrite f
+		return True
+#endif
+
+checkCrippledFileSystem :: Annex ()
+checkCrippledFileSystem = whenM probeCrippledFileSystem $ do
+	warning "Detected a crippled filesystem."
+	setCrippledFileSystem True
+
+	{- Normally git disables core.symlinks itself when the
+	 - filesystem does not support them, but in Cygwin, git
+	 - does support symlinks, while git-annex, not linking
+	 - with Cygwin, does not. -}
+	whenM (coreSymlinks <$> Annex.getGitConfig) $ do
+		warning "Disabling core.symlinks."
+		setConfig (ConfigKey "core.symlinks")
+			(Git.Config.boolConfig False)
+
+probeFifoSupport :: Annex Bool
+probeFifoSupport = do
+#ifdef mingw32_HOST_OS
+	return False
+#else
+	tmp <- fromRepo gitAnnexTmpDir
+	let f = tmp </> "gaprobe"
+	createAnnexDirectory tmp
+	liftIO $ do
+		nukeFile f
+		ms <- tryIO $ do
+			createNamedPipe f ownerReadMode
+			getFileStatus f
+		nukeFile f
+		return $ either (const False) isNamedPipe ms
+#endif
+
+checkFifoSupport :: Annex ()
+checkFifoSupport = unlessM probeFifoSupport $ do
+	warning "Detected a filesystem without fifo support."
+	warning "Disabling ssh connection caching."
+	setConfig (annexConfig "sshcaching") (Git.Config.boolConfig False)
+
+enableDirectMode :: Annex ()
+enableDirectMode = unlessM isDirect $ do
+	warning "Enabling direct mode."
+	top <- fromRepo Git.repoPath
+	(l, clean) <- inRepo $ Git.LsFiles.inRepo [top]
+	forM_ l $ \f ->
+		maybe noop (`toDirect` f) =<< isAnnexLink f
+	void $ liftIO clean
+
+{- Work around for git-annex version 5.20131118 - 5.20131127, which
+ - had a bug that unset core.bare when initializing a bare repository.
+ - 
+ - This resulted in objects sent to the repository being stored in 
+ - repo/.git/annex/objects, so move them to repo/annex/objects.
+ -
+ - This check slows down every git-annex run somewhat (by one file stat),
+ - so should be removed after a suitable period of time has passed.
+ - Since the bare repository may be on an offline USB drive, best to
+ - keep it for a while. However, git-annex was only buggy for a few
+ - weeks, so not too long.
+ -}
+fixBadBare :: Annex ()
+fixBadBare = whenM checkBadBare $ do
+	ks <- getKeysPresent
+	liftIO $ debugM "Init" $ unwords
+		[ "Detected bad bare repository with"
+		, show (length ks)
+		, "objects; fixing"
+		]
+	g <- Annex.gitRepo
+	gc <- Annex.getGitConfig
+	d <- Git.repoPath <$> Annex.gitRepo
+	void $ liftIO $ boolSystem "git"
+		[ Param $ "--git-dir=" ++ d
+		, Param "config"
+		, Param Git.Config.coreBare
+		, Param $ Git.Config.boolConfig True
+		]
+	g' <- liftIO $ Git.Construct.fromPath d
+	s' <- liftIO $ Annex.new $ g' { Git.location = Git.Local { Git.gitdir = d, Git.worktree = Nothing } }
+	Annex.changeState $ \s -> s
+		{ Annex.repo = Annex.repo s'
+		, Annex.gitconfig = Annex.gitconfig s'
+		}
+	forM_ ks $ \k -> do
+		oldloc <- liftIO $ gitAnnexLocation k g gc
+		thawContentDir oldloc
+		moveAnnex k oldloc
+		logStatus k InfoPresent
+	let dotgit = d </> ".git"
+	liftIO $ removeDirectoryRecursive dotgit
+		`catchIO` (const $ renameDirectory dotgit (d </> "removeme"))
+
+{- A repostory with the problem won't know it's a bare repository, but will
+ - have no pre-commit hook (which is not set up in a bare repository),
+ - and will not have a HEAD file in its .git directory. -}
+checkBadBare :: Annex Bool
+checkBadBare = allM (not <$>)
+	[isBare, hasPreCommitHook, hasDotGitHEAD]
+  where
+	hasPreCommitHook = inRepo $ doesFileExist . hookFile preCommitHook
+	hasDotGitHEAD = inRepo $ \r -> doesFileExist $ Git.localGitDir r </> "HEAD"