A Haskell script that computes the transitive RPATH closure of a Nix store path.

Closure.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import           Prelude                   hiding (FilePath)

import           Control.Foldl             (list)

import           Control.Arrow

import           Control.Monad.State.Lazy

import           Data.Either
import           Data.Maybe

import           Data.Text                 (Text)
import qualified Data.Text                 as T
import qualified Data.Text.IO              as T

import           Data.Set                  (Set)
import qualified Data.Set                  as Set

import           Data.Map.Lazy             (Map)
import qualified Data.Map.Lazy             as Map

import           Turtle                    hiding (fp, s)

import qualified Filesystem.Path.CurrentOS as FP

shellList :: Shell a -> IO [a]
shellList s = fold s list

patchelf :: [Text] -> IO (Maybe Text)
patchelf args = do
  [(exitCode, so, se)] <- shellList (procStrictWithErr "patchelf" args empty)
  pure $ if (se == "") && (exitCode == ExitSuccess)
         then Just so
         else Nothing

rpath :: FilePath -> IO (Maybe [FilePath])
rpath fp = do
  isFile <- isRegularFile <$> stat fp
  if isFile
    then fmap (filter FP.valid
               . map FP.fromText
               . T.splitOn ":"
               . T.filter (/= '\n'))
         <$> patchelf ["--print-rpath", T.pack (FP.encodeString fp)]
    else pure Nothing

type ClosureM a = StateT (Map FilePath (Set FilePath)) IO a

closure' :: FilePath -> ClosureM (Set FilePath)
closure' fp = do
  alreadyDone <- Map.lookup fp <$> get
  case alreadyDone
    of Just res -> pure res
       Nothing  -> do exists <- liftIO $ testdir fp
                      if FP.valid fp && (fp /= "") && exists
                        then do modify (Map.insertWith Set.union fp mempty)
                                paths <- liftIO
                                         $ fmap (mconcat . catMaybes)
                                         $ shellList
                                         $ liftIO . rpath =<< lstree fp
                                set <- Set.union
                                       <$> pure (Set.fromList paths)
                                       <*> (mconcat <$> mapM closure' paths)
                                modify (Map.insertWith Set.union fp set)
                                fromMaybe mempty . Map.lookup fp <$> get
                        else pure mempty

runClosureM :: ClosureM (Set FilePath) -> IO (Set FilePath)
runClosureM action = do
  paths <- Set.toList . fst <$> runStateT action mempty
  cleanedUp <- Map.keys
               . Map.filter id
               . Map.fromList
               . zip paths
               <$> mapM testdir paths
  Set.fromList <$> mapM realpath cleanedUp

closure :: FilePath -> IO (Set FilePath)
closure fp = runClosureM $ closure' fp

closures :: [FilePath] -> IO (Set FilePath)
closures fps = runClosureM $ fmap mconcat $ mapM closure' fps

closureExe :: FilePath -> IO (Set FilePath)
closureExe exe = do
  exePaths <- fromMaybe mempty <$> rpath exe
  closures exePaths

main :: IO ()
main = arguments
       >>= (map FP.fromText >>> closures)
       >>= (Set.toList >>> map FP.encodeString >>> mapM_ putStrLn)

default.nix

(import <nixpkgs> {}).callPackage

({ runCommand, haskellPackages }:

let paths = p: [ p.turtle ];
    ghc = haskellPackages.ghcWithPackages paths;
in runCommand "rpath-closure" { buildInputs = [ ghc ]; } ''
    mkdir -pv $out/bin
    cp -vi ${./Closure.hs} Closure.hs
    ghc -O2 Closure.hs -o $out/bin/rpath-closure
'')

{}