git-annex/Annex/Environment.hs

{- git-annex environment
 -
 - Copyright 2012-2023 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE OverloadedStrings #-}

module Annex.Environment (
	checkEnvironment,
	checkEnvironmentIO,
	ensureCommit,
) where

import Annex.Common
import Utility.UserInfo
import qualified Git.Config
import Config
import Utility.Env.Set

import Control.Exception

{- Checks that the system's environment allows git to function.
 - Git requires a GECOS username, or suitable git configuration, or
 - environment variables. When none of those are set, this will set the
 - environment variables.
 -
 - Git also requires the system have a hostname containing a dot.
 - Otherwise, it tries various methods to find a FQDN, and will fail if it
 - does not. To avoid replicating that code here, which would break if its
 - methods change, this function does not check the hostname is valid.
 - Instead, git-annex init calls ensureCommit, which makes sure that git
 - gets set up to allow committing.
 -}
checkEnvironment :: Annex ()
checkEnvironment = do
	gitusername <- fromRepo $ Git.Config.getMaybe "user.name"
	when (isNothing gitusername || gitusername == Just "") $
		unlessM userConfigOnly $
			liftIO checkEnvironmentIO

checkEnvironmentIO :: IO ()
checkEnvironmentIO = whenM (isNothing <$> myUserGecos) $ do
	username <- either (const "unknown") id <$> myUserName
	ensureEnv "GIT_AUTHOR_NAME" username
	ensureEnv "GIT_COMMITTER_NAME" username
  where
	-- existing environment is not overwritten
	ensureEnv var val = setEnv var val False

{- Runs an action that commits to the repository, and if it fails, 
 - sets user.email and user.name to a dummy value and tries the action again.
 -
 - Note that user.email and user.name are left set afterwards, so this only
 - needs to be used once to make sure that future commits will succeed.
 -}
ensureCommit :: Annex a -> Annex a
ensureCommit a = either retry return =<< tryNonAsync a 
  where
	retry e = ifM userConfigOnly
		( liftIO (throwIO e)
		, do
			name <- liftIO $ either (const "unknown") id <$> myUserName
			setConfig "user.name" name
			setConfig "user.email" name
			a
		)

userConfigOnly :: Annex Bool
userConfigOnly = do
	v <- fromRepo $ Git.Config.getMaybe "user.useconfigonly"
	return (fromMaybe False (Git.Config.isTrueFalse' =<< v))