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)

4 files changed, 39 insertions, 13 deletions

diff --git a/libraries/libiserv/libiserv.cabal.in b/libraries/libiserv/libiserv.cabal.in
index 31eaaeb838..3721a853cc 100644
--- a/libraries/libiserv/libiserv.cabal.in
+++ b/libraries/libiserv/libiserv.cabal.in
@@ -33,7 +33,7 @@ Library
     if flag(network)
        Exposed-Modules: Remote.Message
                       , Remote.Slave
-       Build-Depends: network    >= 2.6 && < 2.7,
+       Build-Depends: network    >= 2.6 && < 3,
                       directory  >= 1.3 && < 1.4,
                       filepath   >= 1.4 && < 1.5
 
diff --git a/libraries/libiserv/proxy-src/Remote.hs b/libraries/libiserv/proxy-src/Remote.hs
index c91b2d08c6..d07220ba7f 100644
--- a/libraries/libiserv/proxy-src/Remote.hs
+++ b/libraries/libiserv/proxy-src/Remote.hs
@@ -107,7 +107,8 @@ main = do
     putStrLn ("Trying to connect to " ++ host_ip ++ ":" ++ (show port))
   out_pipe <- connectTo host_ip port >>= socketToPipe
 
-  putStrLn "Starting proxy"
+  when verbose $
+    putStrLn "Starting proxy"
   proxy verbose in_pipe out_pipe
 
 -- | A hook, to transform outgoing (proxy -> slave)
diff --git a/libraries/libiserv/src/Lib.hs b/libraries/libiserv/src/Lib.hs
index 0c478d3bf5..9145d15915 100644
--- a/libraries/libiserv/src/Lib.hs
+++ b/libraries/libiserv/src/Lib.hs
@@ -10,16 +10,24 @@ import Control.Exception
 import Control.Monad
 import Data.Binary
 
+import Text.Printf
+import System.Environment (getProgName)
+
 type MessageHook = Msg -> IO Msg
 
+trace :: String -> IO ()
+trace s = getProgName >>= \name -> printf "[%20s] %s\n" name s
+
 serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO ()
 serv verbose hook pipe restore = loop
  where
   loop = do
+    when verbose $ trace "reading pipe..."
     Msg msg <- readPipe pipe getMessage >>= hook
+
     discardCtrlC
 
-    when verbose $ putStrLn ("iserv: " ++ show msg)
+    when verbose $ trace ("msg: " ++ (show msg))
     case msg of
       Shutdown -> return ()
       RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc
@@ -28,7 +36,7 @@ serv verbose hook pipe restore = loop
 
   reply :: forall a. (Binary a, Show a) => a -> IO ()
   reply r = do
-    when verbose $ putStrLn ("iserv: return: " ++ show r)
+    when verbose $ trace ("writing pipe: " ++ show r)
     writePipe pipe (put r)
     loop
 
@@ -38,23 +46,29 @@ serv verbose hook pipe restore = loop
   -- Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.
   wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO ()
   wrapRunTH io = do
+    when verbose $ trace "wrapRunTH..."
     r <- try io
+    when verbose $ trace "wrapRunTH done."
+    when verbose $ trace "writing RunTHDone."
     writePipe pipe (putTHMessage RunTHDone)
     case r of
       Left e
-        | Just (GHCiQException _ err) <- fromException e  ->
+        | Just (GHCiQException _ err) <- fromException e  -> do
+           when verbose $ trace ("QFail " ++ show err)
            reply (QFail err :: QResult a)
         | otherwise -> do
            str <- showException e
+           when verbose $ trace ("QException " ++ str)
            reply (QException str :: QResult a)
       Right a -> do
-        when verbose $ putStrLn "iserv: QDone"
+        when verbose $ trace "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
+     when verbose $ trace "showException"
      r <- try $ evaluate (force (show (e0::SomeException)))
      case r of
        Left e -> showException e
@@ -64,6 +78,7 @@ serv verbose hook pipe restore = loop
   -- 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
+    when verbose $ trace "discardCtrlC"
     r <- try $ restore $ return ()
     case r of
       Left UserInterrupt -> return () >> discardCtrlC
diff --git a/libraries/libiserv/src/Remote/Slave.hs b/libraries/libiserv/src/Remote/Slave.hs
index b80d09592f..577161f35f 100644
--- a/libraries/libiserv/src/Remote/Slave.hs
+++ b/libraries/libiserv/src/Remote/Slave.hs
@@ -25,6 +25,11 @@ import GHC.Fingerprint (getFileHash)
 
 import qualified Data.ByteString as BS
 
+import Text.Printf
+import System.Environment (getProgName)
+
+trace :: String -> IO ()
+trace s = getProgName >>= \name -> printf "[%20s] %s\n" name s
 
 dropLeadingPathSeparator :: FilePath -> FilePath
 dropLeadingPathSeparator p | isAbsolute p = joinPath (drop 1 (splitPath p))
@@ -43,9 +48,8 @@ foreign export ccall startSlave :: Bool -> Int -> CString -> IO ()
 -- 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
+  trace $ "DocRoot: " ++ base_path
   _ <- forkIO $ startSlave' verbose base_path (toEnum port)
   return ()
 
@@ -54,16 +58,18 @@ startSlave verbose port s = do
 -- slave process.
 startSlave' :: Bool -> String -> PortNumber -> IO ()
 startSlave' verbose base_path port = do
+  hSetBuffering stdin LineBuffering
+  hSetBuffering stdout LineBuffering
 
   sock <- openSocket port
 
   forever $ do
-    when verbose $ putStrLn "Opening socket"
+    when verbose $ trace "Opening socket"
     pipe <- acceptSocket sock >>= socketToPipe
     putStrLn $ "Listening on port " ++ show port
-    when verbose $ putStrLn "Starting serv"
+    when verbose $ trace "Starting serv"
     uninterruptibleMask $ serv verbose (hook verbose base_path pipe) pipe
-    when verbose $ putStrLn "serv ended"
+    when verbose $ trace "serv ended"
     return ()
 
 -- | The iserv library may need access to files, specifically
@@ -117,9 +123,13 @@ hook verbose base_path pipe m = case m of
   -- 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.
+  -- dll from the host to the target.  On windows we assume that we don't
+  -- want to copy libraries that are referenced in C:\ these are usually
+  -- system libraries.
+  Msg (LoadDLL path@('C':':':_)) -> do
+    return m
   Msg (LoadDLL path) | isAbsolute path -> do
-    when verbose $ putStrLn ("Need DLL: " ++ (base_path <//> path))
+    when verbose $ trace ("Need DLL: " ++ (base_path <//> path))
     handleLoad pipe path (base_path <//> path)
     return $ Msg (LoadDLL (base_path <//> path))
   _other -> return m