Move `iserv` into `utils` and change package name from `iserv-bin` to `iserv`

This is done for consistency. We usually call the package file the same name the
folder has.  The move into `utils` is done so that we can move the library into
`libraries/iserv` and the proxy into `utils/iserv-proxy` and then break the
`iserv.cabal` apart.  This will make building the cross compiler with TH
simpler, because we can build the library and proxy as separate packages.

Reviewers: bgamari, simonmar, goldfire, erikd

Reviewed By: simonmar

Subscribers: tdammers, rwbarton, thomie, carter

Differential Revision: https://phabricator.haskell.org/D4377

10 files changed, 681 insertions, 0 deletions

diff --git a/libraries/libiserv/Makefile b/libraries/libiserv/Makefile
new file mode 100644
index 0000000000..f160978c19
--- /dev/null
+++ b/libraries/libiserv/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/libraries/libiserv/cbits/iservmain.c b/libraries/libiserv/cbits/iservmain.c
new file mode 100644
index 0000000000..daefd35251
--- /dev/null
+++ b/libraries/libiserv/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/libraries/libiserv/ghc.mk b/libraries/libiserv/ghc.mk
new file mode 100644
index 0000000000..6dc323b336
--- /dev/null
+++ b/libraries/libiserv/ghc.mk
@@ -0,0 +1,5 @@
+libraries/libiserv_PACKAGE = libiserv
+libraries/libiserv_dist-install_GROUP = libraries
+$(if $(filter libiserv,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/libiserv,dist-boot,0)))
+$(if $(filter libiserv,$(PACKAGES_STAGE1)),$(eval $(call build-package,libraries/libiserv,dist-install,1)))
+$(if $(filter libiserv,$(PACKAGES_STAGE2)),$(eval $(call build-package,libraries/libiserv,dist-install,2)))
diff --git a/libraries/libiserv/libiserv.cabal b/libraries/libiserv/libiserv.cabal
new file mode 100644
index 0000000000..224a670395
--- /dev/null
+++ b/libraries/libiserv/libiserv.cabal
@@ -0,0 +1,39 @@
+Name: libiserv
+Version: 8.5
+Copyright: XXX
+License: BSD3
+-- XXX License-File: LICENSE
+Author: XXX
+Maintainer: XXX
+Synopsis: Provides shared functionality between iserv and iserv-proxy
+Description:
+Category: Development
+build-type: Simple
+cabal-version: >=1.10
+
+Flag network
+    Description:   Build libiserv with over-the-network support
+    Default:       False
+
+Library
+    Default-Language: Haskell2010
+    Hs-Source-Dirs: src
+    Exposed-Modules: Lib
+                   , 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.*
+    if flag(network)
+       Exposed-Modules: Remote.Message
+                      , Remote.Slave
+       Build-Depends: 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
diff --git a/libraries/libiserv/proxy-src/Remote.hs b/libraries/libiserv/proxy-src/Remote.hs
new file mode 100644
index 0000000000..c91b2d08c6
--- /dev/null
+++ b/libraries/libiserv/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/libraries/libiserv/src/GHCi/Utils.hsc b/libraries/libiserv/src/GHCi/Utils.hsc
new file mode 100644
index 0000000000..b90cfacb5f
--- /dev/null
+++ b/libraries/libiserv/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/libraries/libiserv/src/Lib.hs b/libraries/libiserv/src/Lib.hs
new file mode 100644
index 0000000000..57e65706c3
--- /dev/null
+++ b/libraries/libiserv/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/libraries/libiserv/src/Main.hs b/libraries/libiserv/src/Main.hs
new file mode 100644
index 0000000000..858cee8e94
--- /dev/null
+++ b/libraries/libiserv/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/libraries/libiserv/src/Remote/Message.hs b/libraries/libiserv/src/Remote/Message.hs
new file mode 100644
index 0000000000..f1745301ba
--- /dev/null
+++ b/libraries/libiserv/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/libraries/libiserv/src/Remote/Slave.hs b/libraries/libiserv/src/Remote/Slave.hs
new file mode 100644
index 0000000000..b80d09592f
--- /dev/null
+++ b/libraries/libiserv/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