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
|
{- Linux library copier and binary shimmer
-
- Copyright 2013-2023 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# Language LambdaCase #-}
module Utility.LinuxMkLibs (
installLib,
parseLdd,
runLdd,
glibcLibs,
gconvLibs,
inTop,
) where
import Utility.PartialPrelude
import Utility.Directory
import Utility.SystemDirectory
import Utility.Process
import Utility.Monad
import Utility.Path
import Utility.Path.AbsRel
import Utility.Split
import Utility.Env
import Utility.Exception
import Utility.OsPath
import Utility.RawFilePath
import Data.Maybe
import System.Posix.Files (isSymbolicLink)
import Data.Char
import Control.Monad.IfElse
import Control.Applicative
import Prelude
{- Installs a library. If the library is a symlink to another file,
- install the file it links to, and update the symlink to be relative. -}
installLib :: (OsPath -> OsPath -> IO ()) -> OsPath -> OsPath -> IO (Maybe OsPath)
installLib installfile top lib = ifM (doesFileExist lib)
( do
installfile top lib
checksymlink lib
return $ Just $ parentDir lib
, return Nothing
)
where
checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (fromOsPath (inTop top f))) $ do
l <- readSymbolicLink (fromOsPath (inTop top f))
let absl = absPathFrom (parentDir f) (toOsPath l)
target <- relPathDirToFile (takeDirectory f) absl
installfile top absl
removeWhenExistsWith removeFile (inTop top f)
createSymbolicLink (fromOsPath target) (fromOsPath (inTop top f))
checksymlink absl
-- Note that f is not relative, so cannot use </>
inTop :: OsPath -> OsPath -> OsPath
inTop top f = top <> f
{- Parse ldd output, getting all the libraries that the input files
- link to. Note that some of the libraries may not exist
- (eg, linux-vdso.so) -}
parseLdd :: String -> [OsPath]
parseLdd = map toOsPath
. mapMaybe (getlib . dropWhile isSpace)
. lines
where
getlib l = headMaybe . words =<< lastMaybe (split " => " l)
runLdd :: [OsPath] -> IO [OsPath]
runLdd exes = concat <$> mapM go exes
where
go exe = tryNonAsync (readProcess "ldd" [fromOsPath exe]) >>= \case
Right o -> return (parseLdd o)
-- ldd for some reason segfaults when run in an arm64
-- chroot on an amd64 host, on a binary produced by ghc.
-- But asking ldd to trace loaded objects works.
Left _e -> do
environ <- getEnvironment
let environ' =("LD_TRACE_LOADED_OBJECTS","1"):environ
parseLdd <$> readProcessEnv (fromOsPath exe) [] (Just environ')
{- Get all glibc libs, and also libgcc_s
-
- XXX Debian specific. -}
glibcLibs :: IO [OsPath]
glibcLibs = do
ls <- lines <$> readProcess "sh"
["-c", "dpkg -L libc6:$(dpkg --print-architecture) | egrep '\\.so' | grep -v /gconv/ | grep -v ld.so.conf | grep -v sotruss-lib"]
ls2 <- lines <$> readProcess "sh"
["-c", "(dpkg -L libgcc-s1:$(dpkg --print-architecture 2>/dev/null) || dpkg -L libgcc1:$(dpkg --print-architecture)) | egrep '\\.so'"]
return (map toOsPath (ls++ls2))
{- Get gblibc's gconv libs, which are handled specially.. -}
gconvLibs :: IO [OsPath]
gconvLibs = map toOsPath . lines <$> readProcess "sh"
["-c", "dpkg -L libc6:$(dpkg --print-architecture) | grep /gconv/"]
|
