[commit: ghc] master: [iserv] fix loadDLL (83dcaa8)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/83dcaa8c1e25e5d73c0010029ade30713c0e1696/ghc

>---------------------------------------------------------------

commit 83dcaa8c1e25e5d73c0010029ade30713c0e1696
Author: Moritz Angermann <moritz.angermann at gmail.com>
Date:   Thu May 11 18:13:28 2017 +0800

    [iserv] fix loadDLL
    
    When we load non absolute pathed .so's this usually implies that we expect the
    system to have them in place already, and hence we should not need to ship them.
    Without the absolute path to the library, we are also unable to open and send
    said library.  Thus we'll do library shipping only for libraries with absolute
    paths.
    
    Reviewers: austin, bgamari, simonmar
    
    Reviewed By: simonmar
    
    Subscribers: simonmar, rwbarton, thomie
    
    Differential Revision: https://phabricator.haskell.org/D3469


>---------------------------------------------------------------

83dcaa8c1e25e5d73c0010029ade30713c0e1696
 iserv/iserv-bin.cabal     |  2 ++
 iserv/proxy-src/Remote.hs |  8 +++++++-
 iserv/src/Remote/Slave.hs | 41 ++++++++++++++++++++++++++++++-----------
 3 files changed, 39 insertions(+), 12 deletions(-)

diff --git a/iserv/iserv-bin.cabal b/iserv/iserv-bin.cabal
index 8da0c28..846a111 100644
--- a/iserv/iserv-bin.cabal
+++ b/iserv/iserv-bin.cabal
@@ -134,5 +134,7 @@ Executable iserv-proxy
                   containers >= 0.5 && < 0.6,
                   deepseq    >= 1.4 && < 1.5,
                   ghci       == 8.3,
+                  directory  >= 1.3 && < 1.4,
                   network    >= 2.6,
+                  filepath   >= 1.4 && < 1.5,
                   iserv-bin
diff --git a/iserv/proxy-src/Remote.hs b/iserv/proxy-src/Remote.hs
index 481d6ac..c91b2d0 100644
--- a/iserv/proxy-src/Remote.hs
+++ b/iserv/proxy-src/Remote.hs
@@ -59,6 +59,8 @@ import System.Environment
 import System.Exit
 import Text.Printf
 import GHC.Fingerprint (getFileHash)
+import System.Directory
+import System.FilePath (isAbsolute)
 
 import Data.Binary
 import qualified Data.ByteString as BS
@@ -68,7 +70,7 @@ dieWithUsage = do
     prog <- getProgName
     die $ prog ++ ": " ++ msg
   where
-#ifdef WINDOWS
+#if defined(WINDOWS)
     msg = "usage: iserv <write-handle> <read-handle> <slave ip> [-v]"
 #else
     msg = "usage: iserv <write-fd> <read-fd> <slave ip> [-v]"
@@ -231,6 +233,10 @@ proxy verbose local remote = loop
           resp <- fwdLoadCall verbose local remote msg'
           reply resp
           loop
+        LoadDLL path | isAbsolute path -> do
+          resp <- fwdLoadCall verbose local remote msg'
+          reply resp
+          loop
         Shutdown{}    -> fwdCall msg' >> return ()
         _other        -> fwdCall msg' >>= reply >> loop
 
diff --git a/iserv/src/Remote/Slave.hs b/iserv/src/Remote/Slave.hs
index e7ff3f2..c7210dc 100644
--- a/iserv/src/Remote/Slave.hs
+++ b/iserv/src/Remote/Slave.hs
@@ -11,7 +11,9 @@ import Control.Exception
 import Control.Concurrent
 import Control.Monad (when, forever)
 import System.Directory
-import System.FilePath (takeDirectory)
+import System.FilePath (takeDirectory, (</>), dropTrailingPathSeparator,
+                        isAbsolute, joinPath, splitPath)
+import GHCi.ResolvedBCO
 
 import Data.IORef
 import GHCi.Message (Pipe(..), Msg(..), Message(..), readPipe, writePipe)
@@ -23,6 +25,17 @@ import GHC.Fingerprint (getFileHash)
 
 import qualified Data.ByteString as BS
 
+
+dropLeadingPathSeparator :: FilePath -> FilePath
+dropLeadingPathSeparator p | isAbsolute p = joinPath (drop 1 (splitPath p))
+                           | otherwise    = p
+
+-- | Path concatication that prevents a double path separator to appear in the
+-- final path. "/foo/bar/" <//> "/baz/quux" == "/foo/bar/baz/quux"
+(<//>) :: FilePath -> FilePath -> FilePath
+lhs <//> rhs = dropTrailingPathSeparator lhs </> dropLeadingPathSeparator rhs
+infixr 5 <//>
+
 foreign export ccall startSlave :: Bool -> Int -> CString -> IO ()
 
 -- | @startSlave@ is the exported slave function, that the
@@ -89,18 +102,24 @@ handleLoad pipe path localPath = do
 hook :: Bool -> String -> Pipe -> Msg -> IO Msg
 hook verbose base_path pipe m = case m of
   Msg (AddLibrarySearchPath p) -> do
-    when verbose $ putStrLn ("Need Path: " ++ base_path ++ p)
-    createDirectoryIfMissing True (base_path ++ p)
-    return $ Msg (AddLibrarySearchPath (base_path ++ p))
+    when verbose $ putStrLn ("Need Path: " ++ (base_path <//> p))
+    createDirectoryIfMissing True (base_path <//> p)
+    return $ Msg (AddLibrarySearchPath (base_path <//> p))
   Msg (LoadObj path) -> do
-    handleLoad pipe path (base_path ++ path)
-    return $ Msg (LoadObj (base_path ++ path))
+    when verbose $ putStrLn ("Need Obj: " ++ (base_path <//> path))
+    handleLoad pipe path (base_path <//> path)
+    return $ Msg (LoadObj (base_path <//> path))
   Msg (LoadArchive path) -> do
-    handleLoad pipe path (base_path ++ path)
-    return $ Msg (LoadArchive (base_path ++ path))
-  -- Msg (LoadDLL path) -> do
-  --   handleLoad ctl_pipe path (base_path ++ path)
-  --   return $ Msg (LoadDLL (base_path ++ path))
+    handleLoad pipe path (base_path <//> path)
+    return $ Msg (LoadArchive (base_path <//> path))
+  -- when loading DLLs (.so, .dylib, .dll, ...) and these are provided
+  -- as relative paths, the intention is to load a pre-existing system library,
+  -- therefore we hook the LoadDLL call only for absolute paths to ship the
+  -- dll from the host to the target.
+  Msg (LoadDLL path) | isAbsolute path -> do
+    when verbose $ putStrLn ("Need DLL: " ++ (base_path <//> path))
+    handleLoad pipe path (base_path <//> path)
+    return $ Msg (LoadDLL (base_path <//> path))
   _other -> return m
 
 --------------------------------------------------------------------------------