Cleanup iserv/iserv-proxy

This adds trace messages that include the processes name and as such
make debugging and following the communication easier.

It also adds a note regarding the fwd*Call proxy-communication logic
between the proxy and the slave.

The proxy will now also poll for 60s to wait for the remote iserv
to come up. (Alternatively you can start the remote process
beforehand; and just have iserv-proxy connect to it)

8 files changed, 259 insertions, 23 deletions

diff --git a/utils/iserv-proxy/Makefile b/utils/iserv-proxy/Makefile
index f160978c19..dec92996f7 100644
--- a/utils/iserv-proxy/Makefile
+++ b/utils/iserv-proxy/Makefile
@@ -10,6 +10,6 @@
 #
 # -----------------------------------------------------------------------------
 
-dir = iserv
-TOP = ..
+dir = iserv-proxy
+TOP = ../..
 include $(TOP)/mk/sub-makefile.mk
diff --git a/utils/iserv-proxy/iserv-proxy.cabal.in b/utils/iserv-proxy/iserv-proxy.cabal.in
index 0819064601..cd36426f81 100644
--- a/utils/iserv-proxy/iserv-proxy.cabal.in
+++ b/utils/iserv-proxy/iserv-proxy.cabal.in
@@ -73,7 +73,7 @@ Executable iserv-proxy
                   base       >= 4   && < 5,
                   binary     >= 0.7 && < 0.9,
                   bytestring >= 0.10 && < 0.11,
-                  containers >= 0.5 && < 0.6,
+                  containers >= 0.5 && < 0.8,
                   deepseq    >= 1.4 && < 1.5,
                   directory  >= 1.3 && < 1.4,
                   network    >= 2.6,
diff --git a/utils/iserv-proxy/src/Main.hs b/utils/iserv-proxy/src/Main.hs
index c91b2d08c6..5901ffe562 100644
--- a/utils/iserv-proxy/src/Main.hs
+++ b/utils/iserv-proxy/src/Main.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, GADTs, OverloadedStrings #-}
+{-# LANGUAGE CPP, GADTs, OverloadedStrings, LambdaCase #-}
 
 {-
 This is the proxy portion of iserv.
@@ -65,6 +65,12 @@ 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
@@ -78,6 +84,9 @@ dieWithUsage = do
 
 main :: IO ()
 main = do
+  hSetBuffering stdin LineBuffering
+  hSetBuffering stdout LineBuffering
+
   args <- getArgs
   (wfd1, rfd2, host_ip, port, rest) <-
       case args of
@@ -104,10 +113,17 @@ main = do
   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
+    trace ("Trying to connect to " ++ host_ip ++ ":" ++ (show port))
 
-  putStrLn "Starting proxy"
+  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)
@@ -131,19 +147,24 @@ fwdTHMsg local msg = do
 -- | 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 $
-          putStrLn ("| TH Msg: ghc <- proxy -- slave: " ++ show msg')
+          trace ("| TH Msg: ghc <- proxy -- slave: " ++ show msg')
         res <- fwdTHMsg local msg'
         when verbose $
-          putStrLn ("| Resp.:  ghc -- proxy -> slave: " ++ show res)
+          trace ("| Resp.:  ghc -- proxy -> slave: " ++ show res)
         writePipe remote (put res)
         case msg' of
           RunTHDone -> return ()
@@ -161,8 +182,10 @@ fwdTHCall verbose local remote msg = do
 --
 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
@@ -171,17 +194,20 @@ fwdLoadCall verbose _ remote msg = do
     reply :: (Binary a, Show a) => a -> IO ()
     reply m = do
       when verbose $
-        putStrLn ("| Resp.:         proxy -> slave: "
+        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 $
-        putStrLn ("| Sl Msg:        proxy <- slave: " ++ show msg')
+        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
@@ -198,21 +224,33 @@ 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 $
-        putStrLn ("Resp.:    ghc <- proxy -- slave: " ++ show msg)
+        trace ("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)
+        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
@@ -233,6 +271,10 @@ proxy verbose local remote = loop
           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
@@ -241,16 +283,23 @@ proxy verbose local remote = loop
         _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
+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
diff --git a/utils/remote-iserv/Makefile b/utils/remote-iserv/Makefile
new file mode 100644
index 0000000000..c659a21a20
--- /dev/null
+++ b/utils/remote-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 = remote-iserv
+TOP = ../..
+include $(TOP)/mk/sub-makefile.mk
diff --git a/utils/remote-iserv/Setup.hs b/utils/remote-iserv/Setup.hs
new file mode 100644
index 0000000000..44671092b2
--- /dev/null
+++ b/utils/remote-iserv/Setup.hs
@@ -0,0 +1,2 @@
+import           Distribution.Simple
+main = defaultMain
diff --git a/utils/remote-iserv/ghc.mk b/utils/remote-iserv/ghc.mk
new file mode 100644
index 0000000000..db8f32fc22
--- /dev/null
+++ b/utils/remote-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
+#
+# -----------------------------------------------------------------------------
+
+utils/remote-iserv_USES_CABAL = YES
+utils/remote-iserv_PACKAGE = remote-iserv
+utils/remote-iserv_EXECUTABLE = remote-iserv
+
+ifeq "$(GhcDebugged)" "YES"
+utils/remote-iserv_stage2_MORE_HC_OPTS += -debug
+utils/remote-iserv_stage2_p_MORE_HC_OPTS += -debug
+utils/remote-iserv_stage2_dyn_MORE_HC_OPTS += -debug
+endif
+
+ifeq "$(GhcThreaded)" "YES"
+utils/remote-iserv_stage2_MORE_HC_OPTS += -threaded
+utils/remote-iserv_stage2_p_MORE_HC_OPTS += -threaded
+utils/remote-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
+utils/remote-iserv_stage2_MORE_HC_OPTS += -optl-Wl,--export-dynamic
+utils/remote-iserv_stage2_p_MORE_HC_OPTS += -optl-Wl,--export-dynamic
+utils/remote-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.
+utils/remote-iserv_stage2_PROGRAM_WAY = v
+utils/remote-iserv_stage2_p_PROGRAM_WAY = p
+utils/remote-iserv_stage2_dyn_PROGRAM_WAY = dyn
+
+utils/remote-iserv_stage2_PROGNAME = ghc-iserv
+utils/remote-iserv_stage2_p_PROGNAME = ghc-iserv-prof
+utils/remote-iserv_stage2_dyn_PROGNAME = ghc-iserv-dyn
+
+utils/remote-iserv_stage2_MORE_HC_OPTS += -no-hs-main
+utils/remote-iserv_stage2_p_MORE_HC_OPTS += -no-hs-main
+utils/remote-iserv_stage2_dyn_MORE_HC_OPTS += -no-hs-main
+
+utils/remote-iserv_stage2_INSTALL = YES
+utils/remote-iserv_stage2_p_INSTALL = YES
+utils/remote-iserv_stage2_dyn_INSTALL = YES
+
+# Install in $(libexec), not in $(bindir)
+utils/remote-iserv_stage2_TOPDIR = YES
+utils/remote-iserv_stage2_p_TOPDIR = YES
+utils/remote-iserv_stage2_dyn_TOPDIR = YES
+
+utils/remote-iserv_stage2_INSTALL_INPLACE = YES
+utils/remote-iserv_stage2_p_INSTALL_INPLACE = YES
+utils/remote-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,utils/remote-iserv,stage2,1))
+endif
+
+ifeq "$(NEED_iserv_p)" "YES"
+$(eval $(call build-prog,utils/remote-iserv,stage2_p,1))
+endif
+
+ifeq "$(NEED_iserv_dyn)" "YES"
+$(eval $(call build-prog,utils/remote-iserv,stage2_dyn,1))
+endif
+
+all_ghc_stage2 : $(remote-iserv-stage2_INPLACE)
+all_ghc_stage2 : $(remote-iserv-stage2_p_INPLACE)
+all_ghc_stage2 : $(remote-iserv-stage2_dyn_INPLACE)
diff --git a/utils/remote-iserv/remote-iserv.cabal.in b/utils/remote-iserv/remote-iserv.cabal.in
new file mode 100644
index 0000000000..a1cba01301
--- /dev/null
+++ b/utils/remote-iserv/remote-iserv.cabal.in
@@ -0,0 +1,27 @@
+-- WARNING: iserv-proxy.cabal is automatically generated from remote-iserv.cabal.in by
+-- ../../configure.  Make sure you are editing remote-iserv.cabal.in, not
+-- remote-iserv.cabal.
+
+Name: remote-iserv
+Version: @ProjectVersion@
+Copyright: XXX
+License: BSD3
+-- XXX License-File: LICENSE
+Author: Moritz Angermann <moritz.angermann@gmail.com>
+Maintainer: Moritz Angermann <moritz.angermann@gmail.com>
+Synopsis: iserv allows GHC to delegate Tempalte Haskell computations
+Description:
+  This is a very simple remote runner for iserv, to be used together
+  with iserv-proxy.  The foundamental idea is that this this wrapper
+  starts running libiserv on a given port to which iserv-proxy will
+  then connect.
+Category: Development
+build-type: Simple
+cabal-version: >=1.10
+
+Executable remote-iserv
+   Default-Language: Haskell2010
+   Main-Is: Cli.hs
+   Hs-Source-Dirs: src
+   Build-Depends: base       >= 4   && < 5,
+                  libiserv   == @ProjectVersionMunged@
diff --git a/utils/remote-iserv/src/Cli.hs b/utils/remote-iserv/src/Cli.hs
new file mode 100644
index 0000000000..eb8f92c39c
--- /dev/null
+++ b/utils/remote-iserv/src/Cli.hs
@@ -0,0 +1,30 @@
+module Main where
+
+import           Remote.Slave (startSlave')
+import           System.Environment (getArgs, getProgName)
+import           System.Exit (die)
+
+main :: IO ()
+main = getArgs >>= startSlave
+
+dieWithUsage :: IO a
+dieWithUsage = do
+  prog <- getProgName
+  die $ msg prog
+ where
+  msg name = "usage: " ++ name ++ " /path/to/storage PORT [-v]"
+
+startSlave :: [String] -> IO ()
+startSlave args0
+  | "--help" `elem` args0 = dieWithUsage
+  | otherwise = do
+      (path, port, rest) <- case args0 of
+        arg0:arg1:rest -> return (arg0, read arg1, rest)
+        _              -> dieWithUsage
+
+      verbose <- case rest of
+        ["-v"] -> return True
+        []     -> return False
+        _      -> dieWithUsage
+
+      startSlave' verbose path port