Improve packaging support for staticWhich usage

.gitignore

@@ -0,0 +1 @@
+dist-newstyle/

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

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 ()

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