OsPath conversion of linuxstandalone builder

Sponsored-by: Joshua Antonishen
This commit is contained in:
Joey Hess 2025-02-11 12:12:27 -04:00
parent 2ff716be30
commit c85d5a0dc8
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
3 changed files with 128 additions and 130 deletions

View file

@ -24,7 +24,6 @@ import Utility.Monad
import Utility.Path
import Utility.Path.AbsRel
import Utility.Split
import Utility.FileSystemEncoding
import Utility.Env
import Utility.Exception
import Utility.OsPath
@ -39,42 +38,42 @@ 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 :: (FilePath -> FilePath -> IO ()) -> FilePath -> FilePath -> IO (Maybe FilePath)
installLib installfile top lib = ifM (doesFileExist (toOsPath lib))
installLib :: (OsPath -> OsPath -> IO ()) -> OsPath -> OsPath -> IO (Maybe OsPath)
installLib installfile top lib = ifM (doesFileExist lib)
( do
installfile top lib
checksymlink lib
return $ Just $ fromOsPath $ parentDir $ toOsPath lib
return $ Just $ parentDir lib
, return Nothing
)
where
checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do
l <- readSymbolicLink (inTop top f)
let absl = absPathFrom
(parentDir (toOsPath f))
(toOsPath l)
target <- relPathDirToFile (takeDirectory (toOsPath f)) absl
installfile top (fromOsPath absl)
removeWhenExistsWith removeLink (toRawFilePath (top ++ f))
createSymbolicLink (fromOsPath target) (inTop top f)
checksymlink (fromOsPath absl)
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 :: FilePath -> FilePath -> RawFilePath
inTop top f = toRawFilePath $ top ++ f
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 -> [FilePath]
parseLdd = mapMaybe (getlib . dropWhile isSpace) . lines
parseLdd :: String -> [OsPath]
parseLdd = map toOsPath
. mapMaybe (getlib . dropWhile isSpace)
. lines
where
getlib l = headMaybe . words =<< lastMaybe (split " => " l)
runLdd :: [String] -> IO [FilePath]
runLdd :: [OsPath] -> IO [OsPath]
runLdd exes = concat <$> mapM go exes
where
go exe = tryNonAsync (readProcess "ldd" [exe]) >>= \case
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.
@ -82,21 +81,21 @@ runLdd exes = concat <$> mapM go exes
Left _e -> do
environ <- getEnvironment
let environ' =("LD_TRACE_LOADED_OBJECTS","1"):environ
parseLdd <$> readProcessEnv exe [] (Just environ')
parseLdd <$> readProcessEnv (fromOsPath exe) [] (Just environ')
{- Get all glibc libs, and also libgcc_s
-
- XXX Debian specific. -}
glibcLibs :: IO [FilePath]
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 (ls++ls2)
return (map toOsPath (ls++ls2))
{- Get gblibc's gconv libs, which are handled specially.. -}
gconvLibs :: IO [FilePath]
gconvLibs = lines <$> readProcess "sh"
gconvLibs :: IO [OsPath]
gconvLibs = map toOsPath . lines <$> readProcess "sh"
["-c", "dpkg -L libc6:$(dpkg --print-architecture) | grep /gconv/"]