summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthew Pickering <matthewtpickering@gmail.com>2021-12-08 17:10:15 +0000
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-12-12 09:10:06 -0500
commit6b2947d29c3d71599d90641bfdfb41d7fe7427ac (patch)
tree5d7d82aa2b625d8fdaba680a359f2721c07008a4
parent40a44f68362565fa9c1c062b06bc117c6b0a1cab (diff)
downloadhaskell-6b2947d29c3d71599d90641bfdfb41d7fe7427ac.tar.gz
iserv: Remove network dependent parts of libiserv
As noted in #20794 the parts of libiserv and iserv-proxy depend on network, therefore are never built nor tested during CI. Due to this iserv-proxy had bitrotted due to the bound on bytestring being out of date. Given we don't test this code it seems undesirable to distribute it. Therefore, it's removed and an external maintainer can be responsible for testing it (via head.hackage if desired). Fixes #20794
-rw-r--r--configure.ac1
-rw-r--r--libraries/libiserv/libiserv.cabal.in6
-rw-r--r--libraries/libiserv/proxy-src/Remote.hs263
-rw-r--r--libraries/libiserv/src/Remote/Message.hs38
-rw-r--r--libraries/libiserv/src/Remote/Slave.hs157
-rw-r--r--utils/iserv-proxy/Makefile15
-rw-r--r--utils/iserv-proxy/ghc.mk113
-rw-r--r--utils/iserv-proxy/iserv-proxy.cabal.in82
-rw-r--r--utils/iserv-proxy/src/Main.hs311
9 files changed, 0 insertions, 986 deletions
diff --git a/configure.ac b/configure.ac
index 7b8b747b56..a66c5c508a 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1320,7 +1320,6 @@ AC_CONFIG_FILES(
utils/runghc/runghc.cabal
driver/ghci/ghci-wrapper.cabal
utils/iserv/iserv.cabal
- utils/iserv-proxy/iserv-proxy.cabal
utils/ghc-pkg/ghc-pkg.cabal
utils/remote-iserv/remote-iserv.cabal
utils/gen-dll/gen-dll.cabal
diff --git a/libraries/libiserv/libiserv.cabal.in b/libraries/libiserv/libiserv.cabal.in
index 8e2a43fcfd..708f10c143 100644
--- a/libraries/libiserv/libiserv.cabal.in
+++ b/libraries/libiserv/libiserv.cabal.in
@@ -30,12 +30,6 @@ Library
containers >= 0.5 && < 0.7,
deepseq >= 1.4 && < 1.5,
ghci == @ProjectVersionMunged@
- if flag(network)
- Exposed-Modules: Remote.Message
- , Remote.Slave
- Build-Depends: network >= 2.6 && < 3,
- directory >= 1.3 && < 1.4,
- filepath >= 1.4 && < 1.5
if os(windows)
Cpp-Options: -DWINDOWS
diff --git a/libraries/libiserv/proxy-src/Remote.hs b/libraries/libiserv/proxy-src/Remote.hs
deleted file mode 100644
index d07220ba7f..0000000000
--- a/libraries/libiserv/proxy-src/Remote.hs
+++ /dev/null
@@ -1,263 +0,0 @@
-{-# LANGUAGE CPP, GADTs, OverloadedStrings #-}
-
-{-
-This is the proxy portion of iserv.
-
-It acts as local bridge for GHC to call
-a remote slave. This all might sound
-confusing, so let's try to get some
-naming down.
-
-GHC is the actual Haskell compiler, that
-acts as frontend to the code to be compiled.
-
-iserv is the slave, that GHC delegates compilation
-of TH to. As such it needs to be compiled for
-and run on the Target. In the special case
-where the Host and the Target are the same,
-no proxy is needed. GHC and iserv communicate
-via pipes.
-
-iserv-proxy is the proxy instance to iserv.
-The following illustration should make this
-somewhat clear:
-
- .----- Host -----. .- Target -.
- | GHC <--> proxy<+-----+> iserv |
- '----------------' ^ '----------'
- ^ |
- | '-- communication via sockets
- '--- communication via pipes
-
-For now, we won't support multiple concurrent
-invocations of the proxy instance, and that
-behavior will be undefined, as this largely
-depends on the capability of the iserv on the
-target to spawn multiple process. Spawning
-multiple threads won't be sufficient, as the
-GHC runtime has global state.
-
-Also the GHC runtime needs to be able to
-use the linker on the Target to link archives
-and object files.
-
--}
-
-module Main (main) where
-
-import System.IO
-import GHCi.Message
-import GHCi.Utils
-import GHCi.Signals
-
-import Remote.Message
-
-import Network.Socket
-import Data.IORef
-import Control.Monad
-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
-
-dieWithUsage :: IO a
-dieWithUsage = do
- prog <- getProgName
- die $ prog ++ ": " ++ msg
- where
-#if defined(WINDOWS)
- msg = "usage: iserv <write-handle> <read-handle> <slave ip> [-v]"
-#else
- msg = "usage: iserv <write-fd> <read-fd> <slave ip> [-v]"
-#endif
-
-main :: IO ()
-main = do
- args <- getArgs
- (wfd1, rfd2, host_ip, port, rest) <-
- case args of
- arg0:arg1:arg2:arg3:rest -> do
- let wfd1 = read arg0
- rfd2 = read arg1
- ip = arg2
- port = read arg3
- return (wfd1, rfd2, ip, port, rest)
- _ -> dieWithUsage
-
- verbose <- case rest of
- ["-v"] -> return True
- [] -> return False
- _ -> dieWithUsage
-
- when verbose $
- printf "GHC iserv starting (in: %d; out: %d)\n"
- (fromIntegral rfd2 :: Int) (fromIntegral wfd1 :: Int)
- inh <- getGhcHandle rfd2
- outh <- getGhcHandle wfd1
- installSignalHandlers
- lo_ref <- newIORef Nothing
- let in_pipe = Pipe{pipeRead = inh, pipeWrite = outh, pipeLeftovers = lo_ref}
-
- when verbose $
- putStrLn ("Trying to connect to " ++ host_ip ++ ":" ++ (show port))
- out_pipe <- connectTo host_ip port >>= socketToPipe
-
- when verbose $
- putStrLn "Starting proxy"
- proxy verbose in_pipe out_pipe
-
--- | A hook, to transform outgoing (proxy -> slave)
--- messages prior to sending them to the slave.
-hook :: Msg -> IO Msg
-hook = return
-
--- | Forward a single @THMessage@ from the slave
--- to ghc, and read back the result from GHC.
---
--- @Message@s go from ghc to the slave.
--- ghc --- proxy --> slave (@Message@)
--- @THMessage@s go from the slave to ghc
--- ghc <-- proxy --- slave (@THMessage@)
---
-fwdTHMsg :: (Binary a) => Pipe -> THMessage a -> IO a
-fwdTHMsg local msg = do
- writePipe local (putTHMessage msg)
- readPipe local get
-
--- | Fowarard a @Message@ call and handle @THMessages@.
-fwdTHCall :: (Binary a) => Bool -> Pipe -> Pipe -> Message a -> IO a
-fwdTHCall verbose local remote msg = do
- writePipe remote (putMessage msg)
- -- wait for control instructions
- loopTH
- readPipe remote get
- where
- loopTH :: IO ()
- loopTH = do
- THMsg msg' <- readPipe remote getTHMessage
- when verbose $
- putStrLn ("| TH Msg: ghc <- proxy -- slave: " ++ show msg')
- res <- fwdTHMsg local msg'
- when verbose $
- putStrLn ("| Resp.: ghc -- proxy -> slave: " ++ show res)
- writePipe remote (put res)
- case msg' of
- RunTHDone -> return ()
- _ -> loopTH
-
--- | Forwards a @Message@ call, and handle @SlaveMessage@.
--- Similar to @THMessages@, but @SlaveMessage@ are between
--- the slave and the proxy, and are not forwarded to ghc.
--- These message allow the Slave to query the proxy for
--- files.
---
--- ghc --- proxy --> slave (@Message@)
---
--- proxy <-- slave (@SlaveMessage@)
---
-fwdLoadCall :: (Binary a, Show a) => Bool -> Pipe -> Pipe -> Message a -> IO a
-fwdLoadCall verbose _ remote msg = do
- writePipe remote (putMessage msg)
- loopLoad
- readPipe remote get
- where
- truncateMsg :: Int -> String -> String
- truncateMsg n s | length s > n = take n s ++ "..."
- | otherwise = s
- reply :: (Binary a, Show a) => a -> IO ()
- reply m = do
- when verbose $
- putStrLn ("| Resp.: proxy -> slave: "
- ++ truncateMsg 80 (show m))
- writePipe remote (put m)
- loopLoad :: IO ()
- loopLoad = do
- SlaveMsg msg' <- readPipe remote getSlaveMessage
- when verbose $
- putStrLn ("| Sl Msg: proxy <- slave: " ++ show msg')
- case msg' of
- Done -> return ()
- Missing path -> do
- reply =<< BS.readFile path
- loopLoad
- Have path remoteHash -> do
- localHash <- getFileHash path
- reply =<< if localHash == remoteHash
- then return Nothing
- else Just <$> BS.readFile path
- loopLoad
-
--- | The actual proxy. Conntect local and remote pipe,
--- and does some message handling.
-proxy :: Bool -> Pipe -> Pipe -> IO ()
-proxy verbose local remote = loop
- where
- fwdCall :: (Binary a, Show a) => Message a -> IO a
- fwdCall msg = do
- writePipe remote (putMessage msg)
- readPipe remote get
-
- -- reply to ghc.
- reply :: (Show a, Binary a) => a -> IO ()
- reply msg = do
- when verbose $
- putStrLn ("Resp.: ghc <- proxy -- slave: " ++ show msg)
- writePipe local (put msg)
-
- loop = do
- (Msg msg) <- readPipe local getMessage
- when verbose $
- putStrLn ("Msg: ghc -- proxy -> slave: " ++ show msg)
- (Msg msg') <- hook (Msg msg)
- case msg' of
- -- TH might send some message back to ghc.
- RunTH{} -> do
- resp <- fwdTHCall verbose local remote msg'
- reply resp
- loop
- RunModFinalizers{} -> do
- resp <- fwdTHCall verbose local remote msg'
- reply resp
- loop
- -- Load messages might send some messages back to the proxy, to
- -- requrest files that are not present on the device.
- LoadArchive{} -> do
- resp <- fwdLoadCall verbose local remote msg'
- reply resp
- loop
- LoadObj{} -> do
- 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
-
-
-connectTo :: String -> PortNumber -> IO Socket
-connectTo host port = do
- let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV]
- , addrSocketType = Stream }
- addr:_ <- getAddrInfo (Just hints) (Just host) (Just (show port))
- sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
- putStrLn $ "Created socket for " ++ host ++ ":" ++ show port
- connect sock (addrAddress addr)
- putStrLn "connected"
- return sock
-
--- | Turn a socket into an unbuffered pipe.
-socketToPipe :: Socket -> IO Pipe
-socketToPipe sock = do
- hdl <- socketToHandle sock ReadWriteMode
- hSetBuffering hdl NoBuffering
-
- lo_ref <- newIORef Nothing
- pure Pipe{ pipeRead = hdl, pipeWrite = hdl, pipeLeftovers = lo_ref }
diff --git a/libraries/libiserv/src/Remote/Message.hs b/libraries/libiserv/src/Remote/Message.hs
deleted file mode 100644
index f1745301ba..0000000000
--- a/libraries/libiserv/src/Remote/Message.hs
+++ /dev/null
@@ -1,38 +0,0 @@
-{-# LANGUAGE GADTs, StandaloneDeriving, ExistentialQuantification #-}
-
-module Remote.Message
- ( SlaveMessage(..)
- , SlaveMsg(..)
- , putSlaveMessage
- , getSlaveMessage )
-where
-
-import GHC.Fingerprint (Fingerprint)
-import Data.Binary
-import Data.ByteString (ByteString)
-
--- | A @SlaveMessage a@ is message from the iserv process on the
--- target, requesting something from the Proxy of with result type @a@.
-data SlaveMessage a where
- -- sends either a new file, or nothing if the file is acceptable.
- Have :: FilePath -> Fingerprint -> SlaveMessage (Maybe ByteString)
- Missing :: FilePath -> SlaveMessage ByteString
- Done :: SlaveMessage ()
-
-deriving instance Show (SlaveMessage a)
-
-putSlaveMessage :: SlaveMessage a -> Put
-putSlaveMessage m = case m of
- Have path sha -> putWord8 0 >> put path >> put sha
- Missing path -> putWord8 1 >> put path
- Done -> putWord8 2
-
-data SlaveMsg = forall a . (Binary a, Show a) => SlaveMsg (SlaveMessage a)
-
-getSlaveMessage :: Get SlaveMsg
-getSlaveMessage = do
- b <- getWord8
- case b of
- 0 -> SlaveMsg <$> (Have <$> get <*> get)
- 1 -> SlaveMsg <$> Missing <$> get
- 2 -> return (SlaveMsg Done)
diff --git a/libraries/libiserv/src/Remote/Slave.hs b/libraries/libiserv/src/Remote/Slave.hs
deleted file mode 100644
index 4c150becfa..0000000000
--- a/libraries/libiserv/src/Remote/Slave.hs
+++ /dev/null
@@ -1,157 +0,0 @@
-{-# LANGUAGE ForeignFunctionInterface, GADTs, LambdaCase #-}
-module Remote.Slave where
-
-import Network.Socket
-
-import Lib (serv)
-import Remote.Message
-
-import System.IO
-import Control.Exception
-import Control.Concurrent
-import Control.Monad (when, forever)
-import System.Directory
-import System.FilePath (takeDirectory, (</>), dropTrailingPathSeparator,
- isAbsolute, joinPath, splitPath)
-import GHCi.ResolvedBCO
-
-import Data.IORef
-import GHCi.Message (Pipe(..), Msg(..), Message(..), readPipe, writePipe)
-
-import Foreign.C.String
-
-import Data.Binary
-import GHC.Fingerprint (getFileHash)
-
-import qualified Data.ByteString as BS
-
-import Text.Printf
-import System.Environment (getProgName)
-
-trace :: String -> IO ()
-trace s = getProgName >>= \name -> printf "[%20s] %s\n" name s
-
-dropLeadingPathSeparator :: FilePath -> FilePath
-dropLeadingPathSeparator p | isAbsolute p = joinPath (drop 1 (splitPath p))
- | otherwise = p
-
--- | Path concatenation 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
--- hosting application on the target needs to invoce to
--- start the slave process, and runs iserv.
-startSlave :: Bool -> Int -> CString -> IO ()
-startSlave verbose port s = do
- base_path <- peekCString s
- trace $ "DocRoot: " ++ base_path
- _ <- forkIO $ startSlave' verbose base_path (toEnum port)
- return ()
-
--- | @startSlave'@ provdes a blocking haskell interface, that
--- the hosting application on the target can use to start the
--- slave process.
-startSlave' :: Bool -> String -> PortNumber -> IO ()
-startSlave' verbose base_path port = do
- hSetBuffering stdin LineBuffering
- hSetBuffering stdout LineBuffering
-
- sock <- openSocket port
- actualPort <- socketPort sock
- putStrLn $ "Listening on port " ++ show actualPort
-
- forever $ do
- when verbose $ trace "Opening socket"
- pipe <- acceptSocket sock >>= socketToPipe
- when verbose $ trace "Starting serv"
- uninterruptibleMask $ serv verbose (hook verbose base_path pipe) pipe
- when verbose $ trace "serv ended"
- return ()
-
--- | The iserv library may need access to files, specifically
--- archives and object files to be linked. If ghc and the slave
--- are on the same host, this is trivial, as the underlying
--- filestorage is the same. If however the slave does not run
--- on the same host, the filestorage is not identical and we
--- need to request data from the host where ghc runs on.
---
--- If we however already have the requested file we need to make
--- sure that this file is the same one ghc sees. Hence we
--- calculate the Fingerprint of the file and send it back to the
--- host for comparison. The proxy will then send back either @Nothing@
--- indicating that the file on the host has the same Fingerprint, or
--- Maybe ByteString containing the payload to replace the existing
--- file with.
-handleLoad :: Pipe -> FilePath -> FilePath -> IO ()
-handleLoad pipe path localPath = do
- exists <- doesFileExist localPath
- if exists
- then getFileHash localPath >>= \hash -> proxyCall (Have path hash) >>= \case
- Nothing -> return ()
- Just bs -> BS.writeFile localPath bs
- else do
- createDirectoryIfMissing True (takeDirectory localPath)
- resp <- proxyCall (Missing path)
- BS.writeFile localPath resp
-
- proxyCall Done
- where
- proxyCall :: (Binary a, Show a) => SlaveMessage a -> IO a
- proxyCall msg = do
- writePipe pipe (putSlaveMessage msg)
- readPipe pipe get
-
--- | The hook we install in the @serv@ function from the
--- iserv library, to request archives over the wire.
-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))
- Msg (LoadObj path) -> do
- 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))
- -- 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. On windows we assume that we don't
- -- want to copy libraries that are referenced in C:\ these are usually
- -- system libraries.
- Msg (LoadDLL path@('C':':':_)) -> do
- return m
- Msg (LoadDLL path) | isAbsolute path -> do
- when verbose $ trace ("Need DLL: " ++ (base_path <//> path))
- handleLoad pipe path (base_path <//> path)
- return $ Msg (LoadDLL (base_path <//> path))
- _other -> return m
-
---------------------------------------------------------------------------------
--- socket to pipe briding logic.
-socketToPipe :: Socket -> IO Pipe
-socketToPipe sock = do
- hdl <- socketToHandle sock ReadWriteMode
- hSetBuffering hdl NoBuffering
-
- lo_ref <- newIORef Nothing
- pure Pipe{ pipeRead = hdl, pipeWrite = hdl, pipeLeftovers = lo_ref }
-
-openSocket :: PortNumber -> IO Socket
-openSocket port = do
- sock <- socket AF_INET Stream 0
- setSocketOption sock ReuseAddr 1
- bind sock (SockAddrInet port iNADDR_ANY)
- listen sock 1
- return sock
-
-acceptSocket :: Socket -> IO Socket
-acceptSocket = fmap fst . accept
diff --git a/utils/iserv-proxy/Makefile b/utils/iserv-proxy/Makefile
deleted file mode 100644
index 2ce8bf84d4..0000000000
--- a/utils/iserv-proxy/Makefile
+++ /dev/null
@@ -1,15 +0,0 @@
-# -----------------------------------------------------------------------------
-#
-# (c) 2009 The University of Glasgow
-#
-# This file is part of the GHC build system.
-#
-# To understand how the build system works and how to modify it, see
-# https://gitlab.haskell.org/ghc/ghc/wikis/building/architecture
-# https://gitlab.haskell.org/ghc/ghc/wikis/building/modifying
-#
-# -----------------------------------------------------------------------------
-
-dir = iserv-proxy
-TOP = ../..
-include $(TOP)/mk/sub-makefile.mk
diff --git a/utils/iserv-proxy/ghc.mk b/utils/iserv-proxy/ghc.mk
deleted file mode 100644
index 479b72e9b0..0000000000
--- a/utils/iserv-proxy/ghc.mk
+++ /dev/null
@@ -1,113 +0,0 @@
-# -----------------------------------------------------------------------------
-#
-# (c) 2009-2012 The University of Glasgow
-#
-# This file is part of the GHC build system.
-#
-# To understand how the build system works and how to modify it, see
-# https://gitlab.haskell.org/ghc/ghc/wikis/building/architecture
-# https://gitlab.haskell.org/ghc/ghc/wikis/building/modifying
-#
-# -----------------------------------------------------------------------------
-
-utils/iserv-proxy_USES_CABAL = YES
-utils/iserv-proxy_PACKAGE = iserv-proxy
-utils/iserv-proxy_EXECUTABLE = iserv-proxy
-
-ifeq "$(GhcDebugged)" "YES"
-utils/iserv-proxy_stage2_MORE_HC_OPTS += -debug
-utils/iserv-proxy_stage2_p_MORE_HC_OPTS += -debug
-utils/iserv-proxy_stage2_dyn_MORE_HC_OPTS += -debug
-endif
-
-ifeq "$(GhcThreaded)" "YES"
-utils/iserv-proxy_stage2_MORE_HC_OPTS += -threaded
-utils/iserv-proxy_stage2_p_MORE_HC_OPTS += -threaded
-utils/iserv-proxy_stage2_dyn_MORE_HC_OPTS += -threaded
-endif
-
-# Add -Wl,--export-dynamic enables GHCi to load dynamic objects that
-# refer to the RTS. This is harmless if you don't use it (adds a bit
-# of overhead to startup and increases the binary sizes) but if you
-# need it there's no alternative.
-ifeq "$(TargetElf)" "YES"
-ifneq "$(TargetOS_CPP)" "solaris2"
-# The Solaris linker does not support --export-dynamic option. It also
-# does not need it since it exports all dynamic symbols by default
-utils/iserv-proxy_stage2_MORE_HC_OPTS += -optl-Wl,--export-dynamic
-utils/iserv-proxy_stage2_p_MORE_HC_OPTS += -optl-Wl,--export-dynamic
-utils/iserv-proxy_stage2_dyn_MORE_HC_OPTS += -optl-Wl,--export-dynamic
-endif
-endif
-
-# Override the default way, because we want a specific version of this
-# program for each way. Note that it's important to do this even for
-# the vanilla version, otherwise we get a dynamic executable when
-# DYNAMIC_GHC_PROGRAMS=YES.
-utils/iserv-proxy_stage2_PROGRAM_WAY = v
-utils/iserv-proxy_stage2_p_PROGRAM_WAY = p
-utils/iserv-proxy_stage2_dyn_PROGRAM_WAY = dyn
-
-utils/iserv-proxy_stage2_PROGNAME = ghc-iserv
-utils/iserv-proxy_stage2_p_PROGNAME = ghc-iserv-prof
-utils/iserv-proxy_stage2_dyn_PROGNAME = ghc-iserv-dyn
-
-utils/iserv-proxy_stage2_MORE_HC_OPTS += -no-hs-main
-utils/iserv-proxy_stage2_p_MORE_HC_OPTS += -no-hs-main
-utils/iserv-proxy_stage2_dyn_MORE_HC_OPTS += -no-hs-main
-
-utils/iserv-proxy_stage2_INSTALL = YES
-utils/iserv-proxy_stage2_p_INSTALL = YES
-utils/iserv-proxy_stage2_dyn_INSTALL = YES
-
-# Install in $(libexec), not in $(bindir)
-utils/iserv-proxy_stage2_TOPDIR = YES
-utils/iserv-proxy_stage2_p_TOPDIR = YES
-utils/iserv-proxy_stage2_dyn_TOPDIR = YES
-
-utils/iserv-proxy_stage2_INSTALL_INPLACE = YES
-utils/iserv-proxy_stage2_p_INSTALL_INPLACE = YES
-utils/iserv-proxy_stage2_dyn_INSTALL_INPLACE = YES
-
-ifeq "$(CLEANING)" "YES"
-
-NEED_iserv = YES
-NEED_iserv_p = YES
-NEED_iserv_dyn = YES
-
-else
-
-ifneq "$(findstring v, $(GhcLibWays))" ""
-NEED_iserv = YES
-else
-NEED_iserv = NO
-endif
-
-ifneq "$(findstring p, $(GhcLibWays))" ""
-NEED_iserv_p = YES
-else
-NEED_iserv_p = NO
-endif
-
-ifneq "$(findstring dyn, $(GhcLibWays))" ""
-NEED_iserv_dyn = YES
-else
-NEED_iserv_dyn = NO
-endif
-endif
-
-ifeq "$(NEED_iserv)" "YES"
-$(eval $(call build-prog,utils/iserv-proxy,stage2,1))
-endif
-
-ifeq "$(NEED_iserv_p)" "YES"
-$(eval $(call build-prog,utils/iserv-proxy,stage2_p,1))
-endif
-
-ifeq "$(NEED_iserv_dyn)" "YES"
-$(eval $(call build-prog,utils/iserv-proxy,stage2_dyn,1))
-endif
-
-all_ghc_stage2 : $(iserv-proxy-stage2_INPLACE)
-all_ghc_stage2 : $(iserv-proxy-stage2_p_INPLACE)
-all_ghc_stage2 : $(iserv-proxy-stage2_dyn_INPLACE)
diff --git a/utils/iserv-proxy/iserv-proxy.cabal.in b/utils/iserv-proxy/iserv-proxy.cabal.in
deleted file mode 100644
index 7cfdd9ad7f..0000000000
--- a/utils/iserv-proxy/iserv-proxy.cabal.in
+++ /dev/null
@@ -1,82 +0,0 @@
--- WARNING: iserv-proxy.cabal is automatically generated from iserv-proxy.cabal.in by
--- ../../configure. Make sure you are editing iserv-proxy.cabal.in, not
--- iserv-proxy.cabal.
-
-Name: iserv-proxy
-Version: @ProjectVersion@
-Copyright: XXX
-License: BSD3
--- XXX License-File: LICENSE
-Author: XXX
-Maintainer: XXX
-Synopsis: iserv allows GHC to delegate Template Haskell computations
-Description:
- GHC can be provided with a path to the iserv binary with
- @-pgmi=/path/to/iserv-bin@, and will in combination with
- @-fexternal-interpreter@, compile Template Haskell though the
- @iserv-bin@ delegate. This is very similar to how ghcjs has been
- compiling Template Haskell, by spawning a separate delegate (so
- called runner on the javascript vm) and evaluating the splices
- there.
- .
- iserv can also be used in combination with cross compilation. For
- this, the @iserv-proxy@ needs to be built on the host, targeting the
- host (as it is running on the host). @cabal install -flibrary
- -fproxy@ will yield the proxy.
- .
- Using the cabal for the target @arch-platform-target-cabal install
- -flibrary@ will build the required library that contains the ffi
- @startSlave@ function, which needs to be invoked on the target
- (e.g. in an iOS application) to start the remote iserv slave.
- .
- calling the GHC cross compiler with @-fexternal-interpreter
- -pgmi=$HOME/.cabal/bin/iserv-proxy -opti\<ip address\> -opti\<port\>@
- will cause it to compile Template Haskell via the remote at \<ip address\>.
- .
- Thus to get cross compilation with Template Haskell follow the
- following receipt:
- .
- * compile the iserv library for your target
- .
- > iserv $ arch-platform-target-cabal install -flibrary
- .
- * setup an application for your target that calls the
- * startSlave function. This could be either haskell or your
- * targets ffi capable language, if needed.
- .
- > void startSlave(false /* verbose */, 5000 /* port */,
- > "/path/to/storagelocation/on/target");
- .
- * build the iserv-proxy
- .
- > iserv $ cabal install -flibrary -fproxy
- * Start your iserv-slave app on your target running on say @10.0.0.1:5000@
- * compiler your sources with -fexternal-interpreter and the proxy
- .
- > project $ arch-platform-target-ghc ModuleContainingTH.hs \
- > -fexternal-interpreter \
- > -pgmi=$HOME/.cabal/bin/iserv-proxy \
- > -opti10.0.0.1 -opti5000
- .
- Should something not work as expected, provide @-opti-v@ for verbose
- logging of the @iserv-proxy@.
-
-Category: Development
-build-type: Simple
-cabal-version: >=1.10
-
-Executable iserv-proxy
- Default-Language: Haskell2010
- Main-Is: Main.hs
- Hs-Source-Dirs: src
- Build-Depends: array >= 0.5 && < 0.6,
- base >= 4 && < 5,
- binary >= 0.7 && < 0.9,
- bytestring >= 0.10 && < 0.11,
- containers >= 0.5 && < 0.8,
- deepseq >= 1.4 && < 1.5,
- directory >= 1.3 && < 1.4,
- network >= 2.6,
- filepath >= 1.4 && < 1.5,
- ghci == @ProjectVersionMunged@,
- libiserv == @ProjectVersionMunged@
diff --git a/utils/iserv-proxy/src/Main.hs b/utils/iserv-proxy/src/Main.hs
deleted file mode 100644
index 46d6c65481..0000000000
--- a/utils/iserv-proxy/src/Main.hs
+++ /dev/null
@@ -1,311 +0,0 @@
-{-# LANGUAGE CPP, GADTs, OverloadedStrings, LambdaCase #-}
-
-{-
-This is the proxy portion of iserv.
-
-It acts as local bridge for GHC to call
-a remote slave. This all might sound
-confusing, so let's try to get some
-naming down.
-
-GHC is the actual Haskell compiler, that
-acts as frontend to the code to be compiled.
-
-iserv is the slave, that GHC delegates compilation
-of TH to. As such it needs to be compiled for
-and run on the Target. In the special case
-where the Host and the Target are the same,
-no proxy is needed. GHC and iserv communicate
-via pipes.
-
-iserv-proxy is the proxy instance to iserv.
-The following illustration should make this
-somewhat clear:
-
- .----- Host -----. .- Target -.
- | GHC <--> proxy<+-----+> iserv |
- '----------------' ^ '----------'
- ^ |
- | '-- communication via sockets
- '--- communication via pipes
-
-For now, we won't support multiple concurrent
-invocations of the proxy instance, and that
-behavior will be undefined, as this largely
-depends on the capability of the iserv on the
-target to spawn multiple process. Spawning
-multiple threads won't be sufficient, as the
-GHC runtime has global state.
-
-Also the GHC runtime needs to be able to
-use the linker on the Target to link archives
-and object files.
-
--}
-
-module Main (main) where
-
-import System.IO
-import GHCi.Message
-import GHCi.Utils
-import GHCi.Signals
-
-import Remote.Message
-
-import Network.Socket
-import Data.IORef
-import Control.Monad
-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
-
-import Control.Concurrent (threadDelay)
-import qualified Control.Exception as E
-
-trace :: String -> IO ()
-trace s = getProgName >>= \name -> printf "[%20s] %s\n" name s
-
-dieWithUsage :: IO a
-dieWithUsage = do
- prog <- getProgName
- die $ prog ++ ": " ++ msg
- where
-#if defined(WINDOWS)
- msg = "usage: iserv <write-handle> <read-handle> <slave ip> <slave port> [-v]"
-#else
- msg = "usage: iserv <write-fd> <read-fd> <slave ip> <slave port> [-v]"
-#endif
-
-main :: IO ()
-main = do
- hSetBuffering stdin LineBuffering
- hSetBuffering stdout LineBuffering
-
- args <- getArgs
- (wfd1, rfd2, host_ip, port, rest) <-
- case args of
- arg0:arg1:arg2:arg3:rest -> do
- let wfd1 = read arg0
- rfd2 = read arg1
- ip = arg2
- port = read arg3
- return (wfd1, rfd2, ip, port, rest)
- _ -> dieWithUsage
-
- verbose <- case rest of
- ["-v"] -> return True
- [] -> return False
- _ -> dieWithUsage
-
- when verbose $
- printf "GHC iserv starting (in: %d; out: %d)\n"
- (fromIntegral rfd2 :: Int) (fromIntegral wfd1 :: Int)
- inh <- getGhcHandle rfd2
- outh <- getGhcHandle wfd1
- installSignalHandlers
- lo_ref <- newIORef Nothing
- let in_pipe = Pipe{pipeRead = inh, pipeWrite = outh, pipeLeftovers = lo_ref}
-
- when verbose $
- trace ("Trying to connect to " ++ host_ip ++ ":" ++ (show port))
-
- out_pipe <- do
- let go n = E.try (connectTo verbose host_ip port >>= socketToPipe) >>= \case
- Left e | n == 0 -> E.throw (e :: E.SomeException)
- | n > 0 -> threadDelay 500000 >> go (n - 1)
- Right a -> return a
- in go 120 -- wait for up to 60seconds (polling every 0.5s).
-
- when verbose $
- trace "Starting proxy"
- proxy verbose in_pipe out_pipe
-
--- | A hook, to transform outgoing (proxy -> slave)
--- messages prior to sending them to the slave.
-hook :: Msg -> IO Msg
-hook = return
-
--- | Forward a single @THMessage@ from the slave
--- to ghc, and read back the result from GHC.
---
--- @Message@s go from ghc to the slave.
--- ghc --- proxy --> slave (@Message@)
--- @THMessage@s go from the slave to ghc
--- ghc <-- proxy --- slave (@THMessage@)
---
-fwdTHMsg :: (Binary a) => Pipe -> THMessage a -> IO a
-fwdTHMsg local msg = do
- writePipe local (putTHMessage msg)
- readPipe local get
-
--- | Fowarard a @Message@ call and handle @THMessages@.
-fwdTHCall :: (Binary a) => Bool -> Pipe -> Pipe -> Message a -> IO a
-fwdTHCall verbose local remote msg = do
- when verbose $ trace ("fwdTHCall: " ++ show msg)
- writePipe remote (putMessage msg)
- -- wait for control instructions
- when verbose $ trace "waiting for control instructions..."
- loopTH
- when verbose $ trace "reading remote pipe result"
- readPipe remote get
- where
- loopTH :: IO ()
- loopTH = do
- when verbose $
- trace "fwdTHCall/loopTH: reading remote pipe..."
- THMsg msg' <- readPipe remote getTHMessage
- when verbose $
- trace ("| TH Msg: ghc <- proxy -- slave: " ++ show msg')
- res <- fwdTHMsg local msg'
- when verbose $
- trace ("| Resp.: ghc -- proxy -> slave: " ++ show res)
- writePipe remote (put res)
- case msg' of
- RunTHDone -> return ()
- _ -> loopTH
-
--- | Forwards a @Message@ call, and handle @SlaveMessage@.
--- Similar to @THMessages@, but @SlaveMessage@ are between
--- the slave and the proxy, and are not forwarded to ghc.
--- These message allow the Slave to query the proxy for
--- files.
---
--- ghc --- proxy --> slave (@Message@)
---
--- proxy <-- slave (@SlaveMessage@)
---
-fwdLoadCall :: (Binary a, Show a) => Bool -> Pipe -> Pipe -> Message a -> IO a
-fwdLoadCall verbose _ remote msg = do
- when verbose $ trace "fwdLoadCall: writing remote pipe"
- writePipe remote (putMessage msg)
- loopLoad
- when verbose $ trace "fwdLoadCall: reading local pipe"
- readPipe remote get
- where
- truncateMsg :: Int -> String -> String
- truncateMsg n s | length s > n = take n s ++ "..."
- | otherwise = s
- reply :: (Binary a, Show a) => a -> IO ()
- reply m = do
- when verbose $
- trace ("| Resp.: proxy -> slave: "
- ++ truncateMsg 80 (show m))
- writePipe remote (put m)
- loopLoad :: IO ()
- loopLoad = do
- when verbose $ trace "fwdLoadCall: reading remote pipe"
- SlaveMsg msg' <- readPipe remote getSlaveMessage
- when verbose $
- trace ("| Sl Msg: proxy <- slave: " ++ show msg')
- case msg' of
- Done -> return ()
- Missing path -> do
- when verbose $
- trace $ "fwdLoadCall: missing path: " ++ path
- reply =<< BS.readFile path
- loopLoad
- Have path remoteHash -> do
- localHash <- getFileHash path
- reply =<< if localHash == remoteHash
- then return Nothing
- else Just <$> BS.readFile path
- loopLoad
-
--- | The actual proxy. Conntect local and remote pipe,
--- and does some message handling.
-proxy :: Bool -> Pipe -> Pipe -> IO ()
-proxy verbose local remote = loop
- where
- fwdCall :: (Binary a, Show a) => Message a -> IO a
- fwdCall msg = do
- when verbose $ trace "proxy/fwdCall: writing remote pipe"
- writePipe remote (putMessage msg)
- when verbose $ trace "proxy/fwdCall: reading remote pipe"
- readPipe remote get
-
- -- reply to ghc.
- reply :: (Show a, Binary a) => a -> IO ()
- reply msg = do
- when verbose $
- trace ("Resp.: ghc <- proxy -- slave: " ++ show msg)
- writePipe local (put msg)
-
- loop = do
- (Msg msg) <- readPipe local getMessage
- when verbose $
- trace ("Msg: ghc -- proxy -> slave: " ++ show msg)
- (Msg msg') <- hook (Msg msg)
- -- Note [proxy-communication]
- --
- -- The fwdTHCall/fwdLoadCall/fwdCall's have to match up
- -- with their endpoints in libiserv:Remote.Slave otherwise
- -- you will end up with hung connections.
- --
- -- We are intercepting some calls between ghc and iserv
- -- and augment the protocol here. Thus these two sides
- -- need to line up and know what request/reply to expect.
- --
- case msg' of
- -- TH might send some message back to ghc.
- RunTH{} -> do
- resp <- fwdTHCall verbose local remote msg'
- reply resp
- loop
- RunModFinalizers{} -> do
- resp <- fwdTHCall verbose local remote msg'
- reply resp
- loop
- -- Load messages might send some messages back to the proxy, to
- -- requrest files that are not present on the device.
- LoadArchive{} -> do
- resp <- fwdLoadCall verbose local remote msg'
- reply resp
- loop
- LoadObj{} -> do
- resp <- fwdLoadCall verbose local remote msg'
- reply resp
- loop
- -- On windows we assume that we don't want to copy libraries
- -- that are referenced in C:\ these are usually system libraries.
- LoadDLL path@('C':':':_) -> do
- fwdCall msg' >>= reply >> loop
- LoadDLL path | isAbsolute path -> do
- resp <- fwdLoadCall verbose local remote msg'
- reply resp
- loop
- Shutdown{} -> fwdCall msg' >> return ()
- _other -> fwdCall msg' >>= reply >> loop
-
-
-connectTo :: Bool -> String -> PortNumber -> IO Socket
-connectTo verbose host port = do
- addr <- resolve host (show port)
- open addr
- where
- resolve host port = do
- let hints = defaultHints { addrSocketType = Stream }
- addr:_ <- getAddrInfo (Just hints) (Just host) (Just port)
- return addr
- open addr = do
- sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
- when verbose $
- trace $ "Created socket for " ++ host ++ ":" ++ show port
- connect sock $ addrAddress addr
- when verbose $
- trace "connected"
- return sock
-
--- | Turn a socket into an unbuffered pipe.
-socketToPipe :: Socket -> IO Pipe
-socketToPipe sock = do
- hdl <- socketToHandle sock ReadWriteMode
- hSetBuffering hdl NoBuffering
-
- lo_ref <- newIORef Nothing
- pure Pipe{ pipeRead = hdl, pipeWrite = hdl, pipeLeftovers = lo_ref }