diff options
Diffstat (limited to 'iserv')
| -rw-r--r-- | iserv/iserv-bin.cabal | 2 | ||||
| -rw-r--r-- | iserv/proxy-src/Remote.hs | 8 | ||||
| -rw-r--r-- | 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 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 -------------------------------------------------------------------------------- |