From 83dcaa8c1e25e5d73c0010029ade30713c0e1696 Mon Sep 17 00:00:00 2001
From: Moritz Angermann <moritz.angermann@gmail.com>
Date: Thu, 11 May 2017 18:13:28 +0800
Subject: [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
---
 iserv/iserv-bin.cabal     |  2 ++
 iserv/proxy-src/Remote.hs |  8 +++++++-
 iserv/src/Remote/Slave.hs | 41 ++++++++++++++++++++++++++++++-----------
 3 files changed, 39 insertions(+), 12 deletions(-)

(limited to 'iserv')

diff --git a/iserv/iserv-bin.cabal b/iserv/iserv-bin.cabal
index 8da0c283b9..846a111fd1 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 481d6acf7d..c91b2d08c6 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 e7ff3f2874..c7210dcb1b 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
 
 --------------------------------------------------------------------------------
-- 
cgit v1.2.1