40ecf58d4b
This does not change the overall license of the git-annex program, which was already AGPL due to a number of sources files being AGPL already. Legally speaking, I'm adding a new license under which these files are now available; I already released their current contents under the GPL license. Now they're dual licensed GPL and AGPL. However, I intend for all my future changes to these files to only be released under the AGPL license, and I won't be tracking the dual licensing status, so I'm simply changing the license statement to say it's AGPL. (In some cases, others wrote parts of the code of a file and released it under the GPL; but in all cases I have contributed a significant portion of the code in each file and it's that code that is getting the AGPL license; the GPL license of other contributors allows combining with AGPL code.)
114 lines
3.4 KiB
Haskell
114 lines
3.4 KiB
Haskell
{- Linux library copier and binary shimmer
|
|
-
|
|
- Copyright 2013 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Main where
|
|
|
|
import System.Environment
|
|
import Data.Maybe
|
|
import System.FilePath
|
|
import Control.Monad
|
|
import Data.List
|
|
import System.Posix.Files
|
|
import Control.Monad.IfElse
|
|
import Control.Applicative
|
|
import Prelude
|
|
|
|
import Utility.LinuxMkLibs
|
|
import Utility.Directory
|
|
import Utility.Process
|
|
import Utility.Monad
|
|
import Utility.Path
|
|
import Utility.FileMode
|
|
import Utility.CopyFile
|
|
|
|
main :: IO ()
|
|
main = getArgs >>= go
|
|
where
|
|
go [] = error "specify LINUXSTANDALONE_DIST"
|
|
go (top:_) = mklibs top
|
|
|
|
mklibs :: FilePath -> IO ()
|
|
mklibs top = do
|
|
fs <- dirContentsRecursive top
|
|
exes <- filterM checkExe fs
|
|
libs <- parseLdd <$> readProcess "ldd" exes
|
|
glibclibs <- glibcLibs
|
|
let libs' = nub $ libs ++ glibclibs
|
|
libdirs <- nub . catMaybes <$> mapM (installLib installFile top) libs'
|
|
|
|
-- Various files used by runshell to set up env vars used by the
|
|
-- linker shims.
|
|
writeFile (top </> "libdirs") (unlines libdirs)
|
|
writeFile (top </> "gconvdir")
|
|
(parentDir $ Prelude.head $ filter ("/gconv/" `isInfixOf`) glibclibs)
|
|
|
|
let linker = Prelude.head $ filter ("ld-linux" `isInfixOf`) libs'
|
|
mapM_ (installLinkerShim top linker) exes
|
|
|
|
{- Installs a linker shim script around a binary.
|
|
-
|
|
- Note that each binary is put into its own separate directory,
|
|
- to avoid eg git looking for binaries in its directory rather
|
|
- than in PATH.
|
|
-
|
|
- The linker is symlinked to a file with the same basename as the binary,
|
|
- since that looks better in ps than "ld-linux.so".
|
|
-}
|
|
installLinkerShim :: FilePath -> FilePath -> FilePath -> IO ()
|
|
installLinkerShim top linker exe = do
|
|
createDirectoryIfMissing True (top </> shimdir)
|
|
createDirectoryIfMissing True (top </> exedir)
|
|
ifM (isSymbolicLink <$> getSymbolicLinkStatus exe)
|
|
( do
|
|
sl <- readSymbolicLink exe
|
|
nukeFile exe
|
|
nukeFile exedest
|
|
-- Assume that for a symlink, the destination
|
|
-- will also be shimmed.
|
|
let sl' = ".." </> takeFileName sl </> takeFileName sl
|
|
createSymbolicLink sl' exedest
|
|
, renameFile exe exedest
|
|
)
|
|
link <- relPathDirToFile (top </> exedir) (top ++ linker)
|
|
unlessM (doesFileExist (top </> exelink)) $
|
|
createSymbolicLink 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 exe $ addModes executeModes
|
|
where
|
|
base = takeFileName exe
|
|
shimdir = "shimmed" </> base
|
|
exedir = "exe"
|
|
exedest = top </> shimdir </> base
|
|
exelink = exedir </> base
|
|
|
|
installFile :: FilePath -> FilePath -> IO ()
|
|
installFile top f = do
|
|
createDirectoryIfMissing True destdir
|
|
void $ copyFileExternal CopyTimeStamps f destdir
|
|
where
|
|
destdir = inTop top $ parentDir f
|
|
|
|
checkExe :: FilePath -> IO Bool
|
|
checkExe f
|
|
| ".so" `isSuffixOf` f = return False
|
|
| otherwise = ifM (isExecutable . fileMode <$> getFileStatus f)
|
|
( checkFileExe <$> readProcess "file" ["-L", f]
|
|
, return False
|
|
)
|
|
|
|
{- Check that file(1) thinks it's a Linux ELF executable, or possibly
|
|
- a shared library (a few executables like ssh appear as shared libraries). -}
|
|
checkFileExe :: String -> Bool
|
|
checkFileExe s = and
|
|
[ "ELF" `isInfixOf` s
|
|
, "executable" `isInfixOf` s || "shared object" `isInfixOf` s
|
|
]
|