[iserv] fix loadDLL
authorMoritz Angermann <moritz.angermann@gmail.com>
Thu, 11 May 2017 10:13:28 +0000 (18:13 +0800)
committerMoritz Angermann <moritz.angermann@gmail.com>
Thu, 11 May 2017 10:31:43 +0000 (18:31 +0800)
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
iserv/proxy-src/Remote.hs
iserv/src/Remote/Slave.hs

index 8da0c28..846a111 100644 (file)
@@ -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
index 481d6ac..c91b2d0 100644 (file)
@@ -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
 
index e7ff3f2..c7210dc 100644 (file)
@@ -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
 
 --------------------------------------------------------------------------------