1 files changed, 69 insertions, 20 deletions

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