2 files changed, 184 insertions, 0 deletions
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