convert hacky shell linux mklibs code to haskell ; fixing symlink bug

The shell code was nasty, and buggy. New haskell code is much nicer,
and it's easy to do complicated calculations to properly convert possibly
absolute symlinks between libraries into relative links using it.

3 files changed, 138 insertions, 42 deletions

diff --git a/Build/LinuxMkLibs.hs b/Build/LinuxMkLibs.hs
new file mode 100644
index 000000000..77e75f62a
--- /dev/null
+++ b/Build/LinuxMkLibs.hs
@@ -0,0 +1,128 @@
+{- Linux library copier and binary shimmer
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Main where
+
+import Control.Applicative
+import System.Environment
+import Data.Maybe
+import System.FilePath
+import System.Directory
+import Control.Monad
+import Data.List
+import Data.List.Utils
+import System.Posix.Files
+import Data.Char
+
+import Utility.PartialPrelude
+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 top) libs'
+	writeFile (top </> "libdirs") (unlines libdirs)
+	writeFile (top </> "linker")
+		(Prelude.head $ filter ("ld-linux" `isInfixOf`) libs')
+	writeFile (top </> "gconvdir")
+		(Prelude.head $ filter ("/gconv/" `isInfixOf`) glibclibs)
+	
+	mapM_ (installLinkerShim top) exes
+
+installLib :: FilePath -> FilePath -> IO (Maybe FilePath)
+installLib top lib = ifM (doesFileExist lib)
+	( do
+		installFile top lib
+		s <- getSymbolicLinkStatus lib
+		when (isSymbolicLink s) $ do
+			l <- readSymbolicLink (inTop top lib)
+			let absl = absPathFrom (parentDir lib) l
+			let target = relPathDirToFile (parentDir lib) absl
+			installFile top absl
+			nukeFile (top ++ lib)
+			createSymbolicLink target (inTop top lib)
+		return $ Just $ parentDir lib
+	, return Nothing
+	)
+
+{- 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.-}
+installLinkerShim :: FilePath -> FilePath -> IO ()
+installLinkerShim top exe = do
+	createDirectoryIfMissing True shimdir
+	renameFile exe exedest
+	writeFile exe $ unlines
+		[ "#!/bin/sh"
+		, "exec \"$GIT_ANNEX_LINKER\" --library-path \"$GIT_ANNEX_LD_LIBRARY_PATH\" \"$GIT_ANNEX_SHIMMED/" ++ base ++ "/" ++ base ++ "\" \"$@\""
+		]
+	modifyFileMode exe $ addModes executeModes
+  where
+	base = takeFileName exe
+	shimdir = top </> "shimmed" </> base
+	exedest = shimdir </> base
+
+installFile :: FilePath -> FilePath -> IO ()
+installFile top f = do
+	createDirectoryIfMissing True destdir
+	void $ copyFileExternal f destdir
+  where
+  	-- Note: This is an absolute, not a relative, directory.
+	dir = parentDir f
+	destdir = inTop top dir
+
+-- Note that f is not relative, so cannot use </>
+inTop :: FilePath -> FilePath -> FilePath
+inTop top f = top ++ f -- 
+
+checkExe :: FilePath -> IO Bool
+checkExe f
+	| ".so" `isSuffixOf` f = return False
+	| otherwise = ifM (isExecutable . fileMode <$> getFileStatus f)
+		( checkFileExe <$> readProcess "file" [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
+	]
+
+{- 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 = catMaybes . map (getlib . dropWhile isSpace) . lines
+  where
+	getlib l = headMaybe . words =<< lastMaybe (split " => " l)
+
+{- Get all glibc libs and other support files, including gconv files
+ -
+ - XXX Debian specific. -}
+glibcLibs :: IO [FilePath]
+glibcLibs = lines <$> readProcess "sh"
+	["-c", "dpkg -L libc6 | egrep '\\.so|gconv'"]
diff --git a/Makefile b/Makefile
index 687128867..b0535bcb1 100644
--- a/Makefile
+++ b/Makefile
@@ -79,19 +79,21 @@ clean:
 	rm -rf tmp dist git-annex $(mans) configure  *.tix .hpc \
 		doc/.ikiwiki html dist tags Build/SysConfig.hs build-stamp \
 		Setup Build/InstallDesktopFile Build/EvilSplicer \
-		Build/Standalone Build/OSXMkLibs Build/DistributionUpdate \
+		Build/Standalone Build/OSXMkLibs Build/LinuxMkLibs Build/DistributionUpdate \
 		git-union-merge
 	find . -name \*.o -exec rm {} \;
 	find . -name \*.hi -exec rm {} \;
 
 Build/InstallDesktopFile: Build/InstallDesktopFile.hs
-	$(GHC) --make $@
+	$(GHC) --make $@ -Wall
 Build/EvilSplicer: Build/EvilSplicer.hs
-	$(GHC) --make $@
+	$(GHC) --make $@ -Wall
 Build/Standalone: Build/Standalone.hs Build/SysConfig.hs
-	$(GHC) --make $@
+	$(GHC) --make $@ -Wall
 Build/OSXMkLibs: Build/OSXMkLibs.hs
-	$(GHC) --make $@
+	$(GHC) --make $@ -Wall
+Build/LinuxMkLibs: Build/LinuxMkLibs.hs
+	$(GHC) --make $@ -Wall
 
 sdist: clean $(mans)
 	./Build/make-sdist.sh
@@ -103,7 +105,7 @@ hackage: sdist
 LINUXSTANDALONE_DEST=tmp/git-annex.linux
 linuxstandalone:
 	$(MAKE) git-annex linuxstandalone-nobuild
-linuxstandalone-nobuild: Build/Standalone
+linuxstandalone-nobuild: Build/Standalone Build/LinuxMkLibs
 	rm -rf "$(LINUXSTANDALONE_DEST)"
 	mkdir -p tmp
 	cp -R standalone/linux "$(LINUXSTANDALONE_DEST)"
@@ -121,42 +123,8 @@ linuxstandalone-nobuild: Build/Standalone
 	(cd "$(shell git --exec-path)" && tar c .) | (cd "$(LINUXSTANDALONE_DEST)"/git-core && tar x)
 	install -d "$(LINUXSTANDALONE_DEST)/templates"
 	
-	touch "$(LINUXSTANDALONE_DEST)/libdirs.tmp"
-	for lib in $$(ldd "$(LINUXSTANDALONE_DEST)"/bin/* $$(find "$(LINUXSTANDALONE_DEST)"/git-core/ -type f) | grep -v "not a dynamic executable" | egrep '^	' | sed 's/^\t//' | sed 's/.*=> //' | cut -d ' ' -f 1 | sort | uniq); do \
-		dir=$$(dirname "$$lib"); \
-		install -d "$(LINUXSTANDALONE_DEST)/$$dir"; \
-		echo "$$dir" >> "$(LINUXSTANDALONE_DEST)/libdirs.tmp"; \
-		cp "$$lib" "$(LINUXSTANDALONE_DEST)/$$dir"; \
-		if [ -L "$lib" ]; then \
-			link=$$(readlink -f "$$lib"); \
-			cp "$$link" "$(LINUXSTANDALONE_DEST)/$$(dirname "$$link")"; \
-		fi; \
-	done
-	sort "$(LINUXSTANDALONE_DEST)/libdirs.tmp" | uniq > "$(LINUXSTANDALONE_DEST)/libdirs"
-	rm -f "$(LINUXSTANDALONE_DEST)/libdirs.tmp"
-
-	# Ensure bundle includes all glibc libs, and other support
-	# files it loads.
-	# XXX Debian specific.
-	cd $(LINUXSTANDALONE_DEST) && dpkg -L libc6 | egrep '\.so|gconv'|tar c --files-from=- | tar x
-
-	find $(LINUXSTANDALONE_DEST) -type d -name gconv | head -n 1 | sed 's!$(LINUXSTANDALONE_DEST)/*!!' > $(LINUXSTANDALONE_DEST)/gconvdir
-	find $(LINUXSTANDALONE_DEST) | grep ld-linux | head -n 1 | sed 's!$(LINUXSTANDALONE_DEST)/*!!' > $(LINUXSTANDALONE_DEST)/linker
+	./Build/LinuxMkLibs "$(LINUXSTANDALONE_DEST)"
 	
-	# Install linker shim for each binary. Note that each binary is put
-	# in its own separate directory, to avoid eg git looking for
-	# binaries in its directory rather than in PATH.
-	for file in $$(find "$(LINUXSTANDALONE_DEST)" -type f | grep -v \.so); do \
-		if file "$$file" | grep ELF | egrep -q 'executable|shared object' && test -x "$$file"; then \
-			base=$$(basename "$$file"); \
-			mkdir -p "$(LINUXSTANDALONE_DEST)/shimmed/$$base"; \
-			mv "$$file" "$(LINUXSTANDALONE_DEST)/shimmed/$$base/"; \
-			echo "#!/bin/sh" > "$$file"; \
-			echo "exec \"\$$GIT_ANNEX_LINKER\" --library-path \"\$$GIT_ANNEX_LD_LIBRARY_PATH\" \"\$$GIT_ANNEX_SHIMMED/$$base/$$base\" \"\$$@\"" >> "$$file"; \
-			chmod +x "$$file"; \
-		fi; \
-	done
-
 	$(MAKE) install-mans DESTDIR="$(LINUXSTANDALONE_DEST)"
 
 	cd tmp/git-annex.linux && find . -type f > git-annex.MANIFEST
diff --git a/Utility/Directory.hs b/Utility/Directory.hs
index 2e3508e8d..6caee7efa 100644
--- a/Utility/Directory.hs
+++ b/Utility/Directory.hs
@@ -37,7 +37,7 @@ dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d
 {- Gets files in a directory, and then its subdirectories, recursively,
  - and lazily.
  -
- - Follows symlinks to other subdirectories.
+ - Does not follow symlinks to other subdirectories.
  -
  - When the directory does not exist, no exception is thrown,
  - instead, [] is returned. -}