1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
|
{- git-annex program path
-
- Copyright 2013-2022 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module Annex.Path (
programPath,
readProgramFile,
gitAnnexChildProcess,
gitAnnexChildProcessParams,
gitAnnexDaemonizeParams,
cleanStandaloneEnvironment,
) where
import Annex.Common
import Config.Files
import Utility.Env
import Annex.PidLock
import qualified Annex
import System.Environment (getExecutablePath, getArgs, getProgName)
{- A fully qualified path to the currently running git-annex program.
-
- getExecutablePath is used when possible. On OSs it supports
- well, it returns the complete path to the program. But, on other OSs,
- it might return just the basename. Fall back to reading the programFile,
- or searching for the command name in PATH.
-
- The standalone build runs git-annex via ld.so, and defeats
- getExecutablePath. It sets GIT_ANNEX_DIR to the location of the
- 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_DIR"
where
go (Just dir) = do
name <- getProgName
return (dir </> name)
go Nothing = do
exe <- getExecutablePath
p <- if isAbsolute exe
then return exe
else fromMaybe exe <$> readProgramFile
maybe cannotFindProgram return =<< searchPath p
{- Returns the path for git-annex that is recorded in the programFile. -}
readProgramFile :: IO (Maybe FilePath)
readProgramFile = do
programfile <- programFile
headMaybe . lines <$> readFile programfile
cannotFindProgram :: IO a
cannotFindProgram = do
f <- programFile
giveup $ "cannot find git-annex program in PATH or in " ++ f
{- Runs a git-annex child process.
-
- Like runsGitAnnexChildProcessViaGit, when pid locking is in use,
- this takes the pid lock, while running it, and sets an env var
- that prevents the child process trying to take the pid lock,
- to avoid it deadlocking.
-}
gitAnnexChildProcess
:: String
-> [CommandParam]
-> (CreateProcess -> CreateProcess)
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> Annex a
gitAnnexChildProcess subcmd ps f a = do
cmd <- liftIO programPath
ps' <- gitAnnexChildProcessParams subcmd ps
pidLockChildProcess cmd ps' f a
{- Parameters to pass to a git-annex child process to run a subcommand
- with some parameters.
-
- Includes -c values that were passed on the git-annex command line
- or due to options like --debug being enabled.
-}
gitAnnexChildProcessParams :: String -> [CommandParam] -> Annex [CommandParam]
gitAnnexChildProcessParams subcmd ps = do
cps <- gitAnnexGitConfigOverrides
return (Param subcmd : cps ++ ps)
gitAnnexGitConfigOverrides :: Annex [CommandParam]
gitAnnexGitConfigOverrides = concatMap (\c -> [Param "-c", Param c])
<$> Annex.getGitConfigOverrides
{- Parameters to pass to git-annex when re-running the current command
- to daemonize it. Used with Utility.Daemon.daemonize. -}
gitAnnexDaemonizeParams :: Annex [CommandParam]
gitAnnexDaemonizeParams = do
-- This includes -c parameters passed to git, as well as ones
-- passed to git-annex.
cps <- gitAnnexGitConfigOverrides
-- 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
|
