diff options
Diffstat (limited to 'iserv')
| -rw-r--r-- | iserv/Makefile | 15 | ||||
| -rw-r--r-- | iserv/cbits/iservmain.c | 17 | ||||
| -rw-r--r-- | iserv/ghc.mk | 113 | ||||
| -rw-r--r-- | iserv/iserv-bin.cabal | 140 | ||||
| -rw-r--r-- | iserv/proxy-src/Remote.hs | 262 | ||||
| -rw-r--r-- | iserv/src/GHCi/Utils.hsc | 25 | ||||
| -rw-r--r-- | iserv/src/Lib.hs | 71 | ||||
| -rw-r--r-- | iserv/src/Main.hs | 63 | ||||
| -rw-r--r-- | iserv/src/Remote/Message.hs | 38 | ||||
| -rw-r--r-- | iserv/src/Remote/Slave.hs | 146 |
10 files changed, 890 insertions, 0 deletions
diff --git a/iserv/Makefile b/iserv/Makefile new file mode 100644 index 0000000000..f160978c19 --- /dev/null +++ b/iserv/Makefile @@ -0,0 +1,15 @@ +# ----------------------------------------------------------------------------- +# +# (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 +# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture +# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +dir = iserv +TOP = .. +include $(TOP)/mk/sub-makefile.mk diff --git a/iserv/cbits/iservmain.c b/iserv/cbits/iservmain.c new file mode 100644 index 0000000000..daefd35251 --- /dev/null +++ b/iserv/cbits/iservmain.c @@ -0,0 +1,17 @@ +#include "../rts/PosixSource.h" +#include "Rts.h" + +#include "HsFFI.h" + +int main (int argc, char *argv[]) +{ + RtsConfig conf = defaultRtsConfig; + + // We never know what symbols GHC will look up in the future, so + // we must retain CAFs for running interpreted code. + conf.keep_cafs = 1; + + conf.rts_opts_enabled = RtsOptsAll; + extern StgClosure ZCMain_main_closure; + hs_main(argc, argv, &ZCMain_main_closure, conf); +} diff --git a/iserv/ghc.mk b/iserv/ghc.mk new file mode 100644 index 0000000000..c5ca6a524e --- /dev/null +++ b/iserv/ghc.mk @@ -0,0 +1,113 @@ +# ----------------------------------------------------------------------------- +# +# (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 +# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture +# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +iserv_USES_CABAL = YES +iserv_PACKAGE = iserv-bin +iserv_EXECUTABLE = iserv + +ifeq "$(GhcDebugged)" "YES" +iserv_stage2_MORE_HC_OPTS += -debug +iserv_stage2_p_MORE_HC_OPTS += -debug +iserv_stage2_dyn_MORE_HC_OPTS += -debug +endif + +ifeq "$(GhcThreaded)" "YES" +iserv_stage2_MORE_HC_OPTS += -threaded +iserv_stage2_p_MORE_HC_OPTS += -threaded +iserv_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 +iserv_stage2_MORE_HC_OPTS += -optl-Wl,--export-dynamic +iserv_stage2_p_MORE_HC_OPTS += -optl-Wl,--export-dynamic +iserv_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. +iserv_stage2_PROGRAM_WAY = v +iserv_stage2_p_PROGRAM_WAY = p +iserv_stage2_dyn_PROGRAM_WAY = dyn + +iserv_stage2_PROGNAME = ghc-iserv +iserv_stage2_p_PROGNAME = ghc-iserv-prof +iserv_stage2_dyn_PROGNAME = ghc-iserv-dyn + +iserv_stage2_MORE_HC_OPTS += -no-hs-main +iserv_stage2_p_MORE_HC_OPTS += -no-hs-main +iserv_stage2_dyn_MORE_HC_OPTS += -no-hs-main + +iserv_stage2_INSTALL = YES +iserv_stage2_p_INSTALL = YES +iserv_stage2_dyn_INSTALL = YES + +# Install in $(libexec), not in $(bindir) +iserv_stage2_TOPDIR = YES +iserv_stage2_p_TOPDIR = YES +iserv_stage2_dyn_TOPDIR = YES + +iserv_stage2_INSTALL_INPLACE = YES +iserv_stage2_p_INSTALL_INPLACE = YES +iserv_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,iserv,stage2,1)) +endif + +ifeq "$(NEED_iserv_p)" "YES" +$(eval $(call build-prog,iserv,stage2_p,1)) +endif + +ifeq "$(NEED_iserv_dyn)" "YES" +$(eval $(call build-prog,iserv,stage2_dyn,1)) +endif + +all_ghc_stage2 : $(iserv-stage2_INPLACE) +all_ghc_stage2 : $(iserv-stage2_p_INPLACE) +all_ghc_stage2 : $(iserv-stage2_dyn_INPLACE) diff --git a/iserv/iserv-bin.cabal b/iserv/iserv-bin.cabal new file mode 100644 index 0000000000..a713e6fbdb --- /dev/null +++ b/iserv/iserv-bin.cabal @@ -0,0 +1,140 @@ +Name: iserv-bin +Version: 0.0 +Copyright: XXX +License: BSD3 +-- XXX License-File: LICENSE +Author: XXX +Maintainer: XXX +Synopsis: iserv allows GHC to delegate Tempalte 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 + +Flag library + Description: Build iserv library + Default: False + +Flag proxy + Description: Build iserv-proxy + Default: False + +Library + If flag(library) + Buildable: True + Else + Buildable: False + Default-Language: Haskell2010 + Hs-Source-Dirs: src + Exposed-Modules: Lib + , Remote.Message + , Remote.Slave + , GHCi.Utils + Build-Depends: base >= 4 && < 5, + binary >= 0.7 && < 0.9, + bytestring >= 0.10 && < 0.11, + containers >= 0.5 && < 0.6, + deepseq >= 1.4 && < 1.5, + ghci == 8.5, + network >= 2.6 && < 2.7, + directory >= 1.3 && < 1.4, + filepath >= 1.4 && < 1.5 + if os(windows) + Cpp-Options: -DWINDOWS + else + Build-Depends: unix >= 2.7 && < 2.8 + +Executable iserv + Default-Language: Haskell2010 + ghc-options: -no-hs-main + Main-Is: Main.hs + C-Sources: cbits/iservmain.c + Hs-Source-Dirs: src + include-dirs: . + If flag(library) + Other-Modules: GHCi.Utils + Else + Other-Modules: GHCi.Utils + , Lib + Build-Depends: array >= 0.5 && < 0.6, + base >= 4 && < 5, + binary >= 0.7 && < 0.9, + bytestring >= 0.10 && < 0.11, + containers >= 0.5 && < 0.6, + deepseq >= 1.4 && < 1.5, + ghci == 8.5 + + if os(windows) + Cpp-Options: -DWINDOWS + else + Build-Depends: unix >= 2.7 && < 2.8 + +Executable iserv-proxy + If flag(proxy) + Buildable: True + Else + Buildable: False + Default-Language: Haskell2010 + Main-Is: Remote.hs + Hs-Source-Dirs: proxy-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.6, + deepseq >= 1.4 && < 1.5, + ghci == 8.5, + 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 new file mode 100644 index 0000000000..c91b2d08c6 --- /dev/null +++ b/iserv/proxy-src/Remote.hs @@ -0,0 +1,262 @@ +{-# 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 + + 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/iserv/src/GHCi/Utils.hsc b/iserv/src/GHCi/Utils.hsc new file mode 100644 index 0000000000..b90cfacb5f --- /dev/null +++ b/iserv/src/GHCi/Utils.hsc @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} +module GHCi.Utils + ( getGhcHandle + ) where + +import Foreign.C +import GHC.IO.Handle (Handle()) +#ifdef mingw32_HOST_OS +import GHC.IO.Handle.FD (fdToHandle) +#else +import System.Posix +#endif + +#include <fcntl.h> /* for _O_BINARY */ + +-- | Gets a GHC Handle File description from the given OS Handle or POSIX fd. +getGhcHandle :: CInt -> IO Handle +#ifdef mingw32_HOST_OS +getGhcHandle handle = _open_osfhandle handle (#const _O_BINARY) >>= fdToHandle + +foreign import ccall "io.h _open_osfhandle" _open_osfhandle :: + CInt -> CInt -> IO CInt +#else +getGhcHandle fd = fdToHandle $ Fd fd +#endif diff --git a/iserv/src/Lib.hs b/iserv/src/Lib.hs new file mode 100644 index 0000000000..57e65706c3 --- /dev/null +++ b/iserv/src/Lib.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE RankNTypes, RecordWildCards, GADTs, ScopedTypeVariables #-} +module Lib (serv) where + +import GHCi.Run +import GHCi.TH +import GHCi.Message + +import Control.DeepSeq +import Control.Exception +import Control.Monad +import Data.Binary + +type MessageHook = Msg -> IO Msg + +serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO () +serv verbose hook pipe@Pipe{..} restore = loop + where + loop = do + Msg msg <- readPipe pipe getMessage >>= hook + discardCtrlC + + when verbose $ putStrLn ("iserv: " ++ show msg) + case msg of + Shutdown -> return () + RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc + RunModFinalizers st qrefs -> wrapRunTH $ runModFinalizerRefs pipe st qrefs + _other -> run msg >>= reply + + reply :: forall a. (Binary a, Show a) => a -> IO () + reply r = do + when verbose $ putStrLn ("iserv: return: " ++ show r) + writePipe pipe (put r) + loop + + -- Run some TH code, which may interact with GHC by sending + -- THMessage requests, and then finally send RunTHDone followed by a + -- QResult. For an overview of how TH works with Remote GHCi, see + -- Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. + wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO () + wrapRunTH io = do + r <- try io + writePipe pipe (putTHMessage RunTHDone) + case r of + Left e + | Just (GHCiQException _ err) <- fromException e -> + reply (QFail err :: QResult a) + | otherwise -> do + str <- showException e + reply (QException str :: QResult a) + Right a -> do + when verbose $ putStrLn "iserv: QDone" + reply (QDone a) + + -- carefully when showing an exception, there might be other exceptions + -- lurking inside it. If so, we return the inner exception instead. + showException :: SomeException -> IO String + showException e0 = do + r <- try $ evaluate (force (show (e0::SomeException))) + case r of + Left e -> showException e + Right str -> return str + + -- throw away any pending ^C exceptions while we're not running + -- interpreted code. GHC will also get the ^C, and either ignore it + -- (if this is GHCi), or tell us to quit with a Shutdown message. + discardCtrlC = do + r <- try $ restore $ return () + case r of + Left UserInterrupt -> return () >> discardCtrlC + Left e -> throwIO e + _ -> return () diff --git a/iserv/src/Main.hs b/iserv/src/Main.hs new file mode 100644 index 0000000000..858cee8e94 --- /dev/null +++ b/iserv/src/Main.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE CPP, GADTs #-} + +-- | +-- The Remote GHCi server. +-- +-- For details on Remote GHCi, see Note [Remote GHCi] in +-- compiler/ghci/GHCi.hs. +-- +module Main (main) where + +import Lib (serv) + +import GHCi.Message +import GHCi.Signals +import GHCi.Utils + +import Control.Exception +import Control.Monad +import Data.IORef +import System.Environment +import System.Exit +import Text.Printf + +dieWithUsage :: IO a +dieWithUsage = do + prog <- getProgName + die $ prog ++ ": " ++ msg + where +#ifdef WINDOWS + msg = "usage: iserv <write-handle> <read-handle> [-v]" +#else + msg = "usage: iserv <write-fd> <read-fd> [-v]" +#endif + +main :: IO () +main = do + args <- getArgs + (wfd1, rfd2, rest) <- + case args of + arg0:arg1:rest -> do + let wfd1 = read arg0 + rfd2 = read arg1 + return (wfd1, rfd2, 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 pipe = Pipe{pipeRead = inh, pipeWrite = outh, pipeLeftovers = lo_ref} + uninterruptibleMask $ serv verbose hook pipe + + where hook = return -- empty hook + -- we cannot allow any async exceptions while communicating, because + -- we will lose sync in the protocol, hence uninterruptibleMask. + diff --git a/iserv/src/Remote/Message.hs b/iserv/src/Remote/Message.hs new file mode 100644 index 0000000000..f1745301ba --- /dev/null +++ b/iserv/src/Remote/Message.hs @@ -0,0 +1,38 @@ +{-# 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/iserv/src/Remote/Slave.hs b/iserv/src/Remote/Slave.hs new file mode 100644 index 0000000000..b80d09592f --- /dev/null +++ b/iserv/src/Remote/Slave.hs @@ -0,0 +1,146 @@ +{-# 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 + + +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 + putStr "DocRoot: " + base_path <- peekCString s + putStrLn 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 + + sock <- openSocket port + + forever $ do + when verbose $ putStrLn "Opening socket" + pipe <- acceptSocket sock >>= socketToPipe + putStrLn $ "Listening on port " ++ show port + when verbose $ putStrLn "Starting serv" + uninterruptibleMask $ serv verbose (hook verbose base_path pipe) pipe + when verbose $ putStrLn "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. + 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 + +-------------------------------------------------------------------------------- +-- 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 |