summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--iserv/iserv-bin.cabal113
-rw-r--r--iserv/proxy-src/Remote.hs255
-rw-r--r--iserv/src/Lib.hs71
-rw-r--r--iserv/src/Main.hs70
-rw-r--r--iserv/src/Remote/Message.hs48
-rw-r--r--iserv/src/Remote/Slave.hs124
6 files changed, 615 insertions, 66 deletions
diff --git a/iserv/iserv-bin.cabal b/iserv/iserv-bin.cabal
index 5307e7fc0e..f0abf54901 100644
--- a/iserv/iserv-bin.cabal
+++ b/iserv/iserv-bin.cabal
@@ -5,19 +5,108 @@ License: BSD3
-- XXX License-File: LICENSE
Author: XXX
Maintainer: XXX
-Synopsis: XXX
+Synopsis: iserv allows GHC to delegate Tempalte Haskell computations
Description:
- XXX
+ 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,
+ cryptonite >= 0.22,
+ ghci == 8.1,
+ 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
- Other-Modules: GHCi.Utils
+ 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,
@@ -30,3 +119,21 @@ Executable iserv
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.1,
+ network >= 2.6,
+ iserv-bin
diff --git a/iserv/proxy-src/Remote.hs b/iserv/proxy-src/Remote.hs
new file mode 100644
index 0000000000..6b1d528e18
--- /dev/null
+++ b/iserv/proxy-src/Remote.hs
@@ -0,0 +1,255 @@
+{-# 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 Data.Binary
+import qualified Data.ByteString as BS
+
+dieWithUsage :: IO a
+dieWithUsage = do
+ prog <- getProgName
+ die $ prog ++ ": " ++ msg
+ where
+#ifdef 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 <- sha256sum 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
+ 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/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
index 8c76e1fe71..858cee8e94 100644
--- a/iserv/src/Main.hs
+++ b/iserv/src/Main.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, RecordWildCards, GADTs, ScopedTypeVariables, RankNTypes #-}
+{-# LANGUAGE CPP, GADTs #-}
-- |
-- The Remote GHCi server.
@@ -8,16 +8,14 @@
--
module Main (main) where
-import GHCi.Run
-import GHCi.TH
+import Lib (serv)
+
import GHCi.Message
import GHCi.Signals
import GHCi.Utils
-import Control.DeepSeq
import Control.Exception
import Control.Monad
-import Data.Binary
import Data.IORef
import System.Environment
import System.Exit
@@ -49,7 +47,7 @@ main = do
["-v"] -> return True
[] -> return False
_ -> dieWithUsage
- when verbose $ do
+ when verbose $
printf "GHC iserv starting (in: %d; out: %d)\n"
(fromIntegral rfd2 :: Int) (fromIntegral wfd1 :: Int)
inh <- getGhcHandle rfd2
@@ -57,63 +55,9 @@ main = do
installSignalHandlers
lo_ref <- newIORef Nothing
let pipe = Pipe{pipeRead = inh, pipeWrite = outh, pipeLeftovers = lo_ref}
- uninterruptibleMask $ serv verbose pipe
+ 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.
-serv :: Bool -> Pipe -> (forall a .IO a -> IO a) -> IO ()
-serv verbose pipe@Pipe{..} restore = loop
- where
- loop = do
- Msg msg <- readPipe pipe getMessage
- 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 -> do
- 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/Remote/Message.hs b/iserv/src/Remote/Message.hs
new file mode 100644
index 0000000000..faef45dcab
--- /dev/null
+++ b/iserv/src/Remote/Message.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE GADTs, StandaloneDeriving, ExistentialQuantification #-}
+
+module Remote.Message
+ ( SlaveMessage(..)
+ , SlaveMsg(..)
+ , sha256sum
+ , putSlaveMessage
+ , getSlaveMessage )
+where
+
+import Data.Binary
+import Data.ByteString as BS (ByteString, readFile)
+
+import Crypto.Hash
+
+type Sha256Hash = String
+
+sha256 :: ByteString -> Digest SHA256
+sha256 = hash
+
+sha256sum :: FilePath -> IO Sha256Hash
+sha256sum path = (show . sha256) <$> BS.readFile path
+
+-- | 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 -> Sha256Hash -> 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..2d47a346c6
--- /dev/null
+++ b/iserv/src/Remote/Slave.hs
@@ -0,0 +1,124 @@
+{-# 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)
+
+import Data.IORef
+import GHCi.Message (Pipe(..), Msg(..), Message(..), readPipe, writePipe)
+
+import Foreign.C.String
+
+import Data.Binary
+
+import qualified Data.ByteString as BS
+
+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
+ startSlave' verbose base_path (toEnum port)
+
+startSlave' :: Bool -> String -> PortNumber -> IO ()
+startSlave' verbose base_path port = do
+
+ sock <- openSocket port
+
+ _ <- forkIO $ forever $ do
+ when verbose $ putStrLn "Opening socket"
+ pipe <- acceptSocket sock >>= socketToPipe
+ putStrLn $ "Listening on port " ++ show port
+ when verbose $ putStrLn "Staring serv"
+ uninterruptibleMask $ serv verbose (hook verbose base_path pipe) pipe
+ when verbose $ putStrLn "serv ended"
+ return ()
+
+ 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 sha256sum 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 sha256sum, 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 sha256sum 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
+ 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))
+ _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