diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c33954f --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist-newstyle/ diff --git a/src/System/Which.hs b/src/System/Which.hs index 5440f3f..9feaf99 100644 --- a/src/System/Which.hs +++ b/src/System/Which.hs @@ -1,27 +1,50 @@ {-# LANGUAGE OverloadedStrings, TemplateHaskell #-} -module System.Which where +module System.Which (which, staticWhich) where -import qualified Shelly as Sh +import Control.Applicative +import Control.Monad.Trans.Maybe +import Data.Maybe (listToMaybe) +import Data.Monoid ((<>)) import qualified Data.Text as T import Language.Haskell.TH (Exp, Q, reportError, runIO) -import Data.Monoid ((<>)) -import Data.List (isPrefixOf) +import System.Directory (findExecutablesInDirectories, doesFileExist) +import System.Environment (lookupEnv) +import System.FilePath (searchPathSeparator) --- | Determine which executable would run if the given path were executed, or return Nothing if a suitable executable cannot be found +-- | Determine which executable would run if the given path were +-- executed, or return Nothing if a suitable executable cannot be +-- found which :: FilePath -> IO (Maybe FilePath) -which f = fmap (fmap (T.unpack . Sh.toTextIgnore)) $ Sh.shelly $ Sh.which $ Sh.fromText $ T.pack f +which f = do + path <- runMaybeT $ MaybeT (lookupEnv "HOST_PATH") <|> MaybeT (lookupEnv "PATH") + case path of + Just path' -> fmap listToMaybe $ + findExecutablesInDirectories (fmap T.unpack $ + T.split (== searchPathSeparator) $ T.pack path') f + Nothing -> pure Nothing -- | Run `which` at compile time, and substitute the full path to the executable. -- --- This is useful in NixOS to ensure that the resulting executable contains the dependency in its closure and that it refers to the same version at run time as at compile time +-- This is useful in NixOS to ensure that the resulting executable +-- contains the dependency in its closure and that it refers to the +-- same version at run time as at compile time staticWhich :: FilePath -> Q Exp staticWhich f = do mf' <- runIO $ which f case mf' of Nothing -> compileError $ "Could not find executable for " <> show f - Just f' - | "/nix/store/" `isPrefixOf` f' -> [| f' |] - | otherwise -> compileError $ "Path to executable " <> show f <> " was found in " <> show f' <> " which is not in /nix/store. Be sure to add the relevant package to 'backendTools' in default.nix." + Just f' -> [| do + -- Check if the file actually exists at runtime + exists <- doesFileExist f' + + -- If it does, run it, otherwise fallback to classic which. + if exists then pure f' + else do + result <- which f + case result of + Just v -> pure v + Nothing -> error $ "Could not find executable for " <> show f + |] where compileError msg' = do diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..6021c0f --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,92 @@ +import Control.Exception +import Data.List +import Data.Monoid ((<>)) +import System.Directory +import System.Environment +import System.Exit +import System.FilePath +import System.Posix.Temp +import System.Which + +shouldEqual :: Eq a => Show a => a -> a -> IO () +shouldEqual a b | a /= b = do + putStrLn $ show a <> " does not equal " <> show b + exitFailure +shouldEqual a b = putStrLn $ show a <> " == " <> show b + +makeExecutable :: FilePath -> IO () +makeExecutable f = setPermissions f . setOwnerExecutable True =<< getPermissions f + +setup :: IO (FilePath, FilePath, FilePath) +setup = do + bin <- mkdtemp "bin" + bin2 <- mkdtemp "bin2" + bin3 <- mkdtemp "bin3" + + appendFile (bin "hello") "hello" + makeExecutable $ bin "hello" + appendFile (bin2 "hello") "hello2" + makeExecutable $ bin2 "hello" + appendFile (bin2 "hello2") "hello2" + makeExecutable $ bin2 "hello2" + appendFile (bin3 "hello") "hello" + makeExecutable $ bin3 "hello" + appendFile (bin3 "hello2") "hello2" + + -- Don’t make this one executable to make sure we don’t resolve + -- non-executable exes below. + -- makeExecutable $ bin3 "hello2" + + appendFile (bin3 "hello3") "hello3" + makeExecutable $ bin3 "hello3" + + pure (bin, bin2, bin3) + +cleanup :: (FilePath, FilePath, FilePath) -> IO () +cleanup (bin, bin2, bin3) = do + removeDirectoryRecursive bin + removeDirectoryRecursive bin2 + removeDirectoryRecursive bin3 + +main :: IO () +main = bracket setup cleanup $ \(bin, bin2, bin3) -> do + unsetEnv "PATH" + unsetEnv "HOST_PATH" + + fp <- which "hello" + + shouldEqual fp Nothing + + setEnv "PATH" $ concat $ intersperse ":" [bin, bin2, bin3] + setEnv "HOST_PATH" $ concat $ intersperse ":" [bin, bin2] + + fp1 <- which "hello" + fp2 <- which "hello2" + fp3 <- which "hello3" + + shouldEqual fp1 (Just $ bin "hello") + shouldEqual fp2 (Just $ bin2 "hello2") + shouldEqual fp3 Nothing + + unsetEnv "PATH" + + fp4 <- which "hello" + fp5 <- which "hello2" + fp6 <- which "hello3" + + shouldEqual fp4 (Just $ bin "hello") + shouldEqual fp5 (Just $ bin2 "hello2") + shouldEqual fp6 Nothing + + unsetEnv "HOST_PATH" + setEnv "PATH" $ concat $ intersperse ":" [bin3, bin2, bin] + + fp7 <- which "hello" + fp8 <- which "hello2" + fp9 <- which "hello3" + + shouldEqual fp7 (Just $ bin3 "hello") + shouldEqual fp8 (Just $ bin2 "hello2") + shouldEqual fp9 (Just $ bin3 "hello3") + + pure () diff --git a/which.cabal b/which.cabal index 0058c0e..372e09e 100644 --- a/which.cabal +++ b/which.cabal @@ -1,5 +1,5 @@ name: which -version: 0.1.0.0 +version: 0.2.0.0 license: BSD3 license-file: LICENSE author: Obsidian Systems LLC @@ -18,11 +18,27 @@ library exposed-modules: System.Which build-depends: base >= 4.9.0 && < 4.13, - shelly >= 1.8.0 && < 1.10, + directory >= 1.2.4.0 && < 1.4, + filepath >= 1.0 && < 1.5, text >= 1.2.3 && < 1.3, - template-haskell >= 2.11.0 && < 2.15 + template-haskell >= 2.11.0 && < 2.15, + transformers >= 0.3.0.0 && < 0.6.0.0 hs-source-dirs: src + ghc-options: -Wall + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-depends: + base, + directory, + filepath, + unix, + which + hs-source-dirs: test + ghc-options: -Wall default-language: Haskell2010 source-repository head