Make git-annex enable-tor work when using the linux standalone build

Clean the standalone environment before running the su command
to run "sh". Otherwise, PATH leaked through, causing it to run
git-annex.linux/bin/sh, but GIT_ANNEX_DIR was not set,
which caused that script to not work:

[2022-10-26 15:07:02.145466106] (Utility.Process) process [938146] call: pkexec ["sh","-c","cd '/home/joey/tmp/git-annex.linux/r' && '/home/joey/tmp/git-annex.linux/git-annex' 'enable-tor' '1000'"]
/home/joey/tmp/git-annex.linux/bin/sh: 4: exec: /exe/sh: not found

Changed programPath to not use GIT_ANNEX_PROGRAMPATH,
but instead run the scripts at the top of GIT_ANNEX_DIR.
That works both when the standalone environment is set up, and when it's
not.

Sponsored-by: Kevin Mueller on Patreon

Annex/Path.hs

@@ -1,6 +1,6 @@
 {- git-annex program path
  -
- - Copyright 2013-2021 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2022 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -11,6 +11,7 @@ module Annex.Path (
 	gitAnnexChildProcess,
 	gitAnnexChildProcessParams,
 	gitAnnexDaemonizeParams,
+	cleanStandaloneEnvironment,
 ) where
 
 import Annex.Common
@@ -19,7 +20,7 @@ import Utility.Env
 import Annex.PidLock
 import qualified Annex
 
-import System.Environment (getExecutablePath, getArgs)
+import System.Environment (getExecutablePath, getArgs, getProgName)
 
 {- A fully qualified path to the currently running git-annex program.
  - 
@@ -29,13 +30,16 @@ import System.Environment (getExecutablePath, getArgs)
  - or searching for the command name in PATH.
  -
  - The standalone build runs git-annex via ld.so, and defeats
- - getExecutablePath. It sets GIT_ANNEX_PROGRAMPATH to the correct path
+ - getExecutablePath. It sets GIT_ANNEX_DIR to the location of the
- - to the wrapper script to use.
+ - standalone build directory, and there are wrapper scripts for git-annex
+ - and git-annex-shell in that directory.
  -}
 programPath :: IO FilePath
-programPath = go =<< getEnv "GIT_ANNEX_PROGRAMPATH"
+programPath = go =<< getEnv "GIT_ANNEX_DIR"
   where
-	go (Just p) = return p
+	go (Just dir) = do
+		name <- getProgName
+		return (dir </> name)
 	go Nothing = do
 		exe <- getExecutablePath
 		p <- if isAbsolute exe
@@ -97,3 +101,25 @@ gitAnnexDaemonizeParams = do
 	-- Get every parameter git-annex was run with.
 	ps <- liftIO getArgs
 	return (map Param ps ++ cps)
+
+{- Returns a cleaned up environment that lacks path and other settings
+ - used to make the standalone builds use their bundled libraries and programs.
+ - Useful when calling programs not included in the standalone builds.
+ -
+ - For a non-standalone build, returns Nothing.
+ -}
+cleanStandaloneEnvironment :: IO (Maybe [(String, String)])
+cleanStandaloneEnvironment = clean <$> getEnvironment
+  where
+	clean environ
+		| null vars = Nothing
+		| otherwise = Just $ catMaybes $ map (restoreorig environ) environ
+	  where
+		vars = words $ fromMaybe "" $
+			lookup "GIT_ANNEX_STANDLONE_ENV" environ
+		restoreorig oldenviron p@(k, _v)
+			| k `elem` vars = case lookup ("ORIG_" ++ k) oldenviron of
+				(Just v')
+					| not (null v') -> Just (k, v')
+				_ -> Nothing
+			| otherwise = Just p

Assistant/Install.hs

@@ -171,25 +171,3 @@ installFileManagerHooks program = unlessM osAndroid $ do
 #else
 installFileManagerHooks _ = noop
 #endif
-
-{- Returns a cleaned up environment that lacks settings used to make the
- - standalone builds use their bundled libraries and programs.
- - Useful when calling programs not included in the standalone builds.
- -
- - For a non-standalone build, returns Nothing.
- -}
-cleanEnvironment :: IO (Maybe [(String, String)])
-cleanEnvironment = clean <$> getEnvironment
-  where
-	clean environ
-		| null vars = Nothing
-		| otherwise = Just $ catMaybes $ map (restoreorig environ) environ
-	  where
-		vars = words $ fromMaybe "" $
-			lookup "GIT_ANNEX_STANDLONE_ENV" environ
-		restoreorig oldenviron p@(k, _v)
-			| k `elem` vars = case lookup ("ORIG_" ++ k) oldenviron of
-				(Just v')
-					| not (null v') -> Just (k, v')
-				_ -> Nothing
-			| otherwise = Just p

Build/LinuxMkLibs.hs

@@ -164,8 +164,6 @@ installLinkerShim top linker exe = do
 		createSymbolicLink (fromRawFilePath link) (top </> exelink)
 	writeFile exe $ unlines
 		[ "#!/bin/sh"
-		, "GIT_ANNEX_PROGRAMPATH=\"$0\""
-		, "export GIT_ANNEX_PROGRAMPATH"
 		, "exec \"$GIT_ANNEX_DIR/" ++ exelink ++ "\" --library-path \"$GIT_ANNEX_LD_LIBRARY_PATH\" \"$GIT_ANNEX_DIR/shimmed/" ++ base ++ "/" ++ base ++ "\" \"$@\""
 		]
 	modifyFileMode (toRawFilePath exe) $ addModes executeModes

CHANGELOG

@@ -17,6 +17,7 @@ git-annex (10.20221004) UNRELEASED; urgency=medium
     database locked.
   * Make --batch mode handle unstaged annexed files consistently
     whether the file is unlocked or not.
+  * Make git-annex enable-tor work when using the linux standalone build.
 
  -- Joey Hess <id@joeyh.name>  Mon, 03 Oct 2022 13:36:42 -0400
 

Command/EnableTor.hs

@@ -60,9 +60,10 @@ start _os = do
 			gitannex <- liftIO programPath
 			let ps = [Param (cmdname cmd), Param (show curruserid)]
 			sucommand <- liftIO $ mkSuCommand gitannex ps
+			cleanenv <- liftIO $ cleanStandaloneEnvironment
 			maybe noop showLongNote
 				(describePasswordPrompt' sucommand)
-			ifM (liftIO $ runSuCommand sucommand)
+			ifM (liftIO $ runSuCommand sucommand cleanenv)
 				( next checkHiddenService
 				, giveup $ unwords $
 					[ "Failed to run as root:" , gitannex ] ++ toCommand ps

Command/WebApp.hs

@@ -22,6 +22,7 @@ import Utility.WebApp
 import Utility.Daemon (checkDaemon)
 import Utility.UserInfo
 import Annex.Init
+import Annex.Path
 import qualified Git
 import Git.Types (fromConfigValue)
 import qualified Git.Config
@@ -222,7 +223,7 @@ openBrowser' mcmd htmlshim realurl outh errh =
 #endif
 		hPutStrLn (fromMaybe stdout outh) $ "Launching web browser on " ++ url
 		hFlush stdout
-		environ <- cleanEnvironment
+		environ <- cleanStandaloneEnvironment
 		let p' = p
 			{ env = environ
 			, std_out = maybe Inherit UseHandle outh

Utility/Su.hs

@@ -57,9 +57,9 @@ describePasswordPrompt' :: Maybe SuCommand -> Maybe String
 describePasswordPrompt' (Just (SuCommand p _ _)) = describePasswordPrompt p
 describePasswordPrompt' Nothing = Nothing
 
-runSuCommand :: (Maybe SuCommand) -> IO Bool
+runSuCommand :: (Maybe SuCommand) -> Maybe [(String, String)] -> IO Bool
-runSuCommand (Just (SuCommand _ cmd ps)) = boolSystem cmd ps
+runSuCommand (Just (SuCommand _ cmd ps)) env = boolSystemEnv cmd ps env
-runSuCommand Nothing = return False
+runSuCommand Nothing _ = return False
 
 -- Generates a SuCommand that runs a command as root, fairly portably.
 --

doc/bugs/__47__exe__47__git-annex.mdwn

@@ -48,3 +48,4 @@ local repository version: 8
 ### Have you had any luck using git-annex before? (Sometimes we get tired of reading bug reports all day and a lil' positive end note does wonders)
 
 
+> [[fixed|done]] --[[Joey]]

doc/bugs/__47__exe__47__git-annex/comment_2_381ac4e8b27343cdc470584c05edec76._comment

@@ -0,0 +1,7 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 2"""
+ date="2022-10-26T19:44:24Z"
+ content="""
+And I've fixed this problem now.
+"""]]