summaryrefslogtreecommitdiff
path: root/Annex
diff options
context:
space:
mode:
Diffstat (limited to 'Annex')
-rw-r--r--Annex/Init.hs240
1 files changed, 240 insertions, 0 deletions
diff --git a/Annex/Init.hs b/Annex/Init.hs
new file mode 100644
index 000000000..616bda69b
--- /dev/null
+++ b/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"