Main.hs 9.75 KB
Newer Older
Moritz Angermann's avatar
Moritz Angermann committed
1
{-# LANGUAGE CPP, GADTs, OverloadedStrings, LambdaCase #-}
Moritz Angermann's avatar
Moritz Angermann committed
2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60

{-
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
61
import GHC.Fingerprint (getFileHash)
Moritz Angermann's avatar
Moritz Angermann committed
62 63
import System.Directory
import System.FilePath (isAbsolute)
Moritz Angermann's avatar
Moritz Angermann committed
64 65 66 67

import Data.Binary
import qualified Data.ByteString as BS

Moritz Angermann's avatar
Moritz Angermann committed
68 69 70 71 72 73
import Control.Concurrent (threadDelay)
import qualified Control.Exception as E

trace :: String -> IO ()
trace s = getProgName >>= \name -> printf "[%20s] %s\n" name s

Moritz Angermann's avatar
Moritz Angermann committed
74 75 76 77 78
dieWithUsage :: IO a
dieWithUsage = do
    prog <- getProgName
    die $ prog ++ ": " ++ msg
  where
Moritz Angermann's avatar
Moritz Angermann committed
79
#if defined(WINDOWS)
80
    msg = "usage: iserv <write-handle> <read-handle> <slave ip> <slave port> [-v]"
Moritz Angermann's avatar
Moritz Angermann committed
81
#else
82
    msg = "usage: iserv <write-fd> <read-fd> <slave ip> <slave port> [-v]"
Moritz Angermann's avatar
Moritz Angermann committed
83 84 85 86
#endif

main :: IO ()
main = do
Moritz Angermann's avatar
Moritz Angermann committed
87 88 89
  hSetBuffering stdin LineBuffering
  hSetBuffering stdout LineBuffering

Moritz Angermann's avatar
Moritz Angermann committed
90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115
  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 $
Moritz Angermann's avatar
Moritz Angermann committed
116
    trace ("Trying to connect to " ++ host_ip ++ ":" ++ (show port))
Moritz Angermann's avatar
Moritz Angermann committed
117

Moritz Angermann's avatar
Moritz Angermann committed
118 119 120 121 122 123 124 125 126
  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"
Moritz Angermann's avatar
Moritz Angermann committed
127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149
  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
Moritz Angermann's avatar
Moritz Angermann committed
150
  when verbose $ trace ("fwdTHCall: " ++ show msg)
Moritz Angermann's avatar
Moritz Angermann committed
151 152
  writePipe remote (putMessage msg)
  -- wait for control instructions
Moritz Angermann's avatar
Moritz Angermann committed
153
  when verbose $ trace "waiting for control instructions..."
Moritz Angermann's avatar
Moritz Angermann committed
154
  loopTH
Moritz Angermann's avatar
Moritz Angermann committed
155
  when verbose $ trace "reading remote pipe result"
Moritz Angermann's avatar
Moritz Angermann committed
156 157 158 159
  readPipe remote get
    where
      loopTH :: IO ()
      loopTH = do
Moritz Angermann's avatar
Moritz Angermann committed
160 161
        when verbose $
          trace "fwdTHCall/loopTH: reading remote pipe..."
Moritz Angermann's avatar
Moritz Angermann committed
162 163
        THMsg msg' <- readPipe remote getTHMessage
        when verbose $
Moritz Angermann's avatar
Moritz Angermann committed
164
          trace ("| TH Msg: ghc <- proxy -- slave: " ++ show msg')
Moritz Angermann's avatar
Moritz Angermann committed
165 166
        res <- fwdTHMsg local msg'
        when verbose $
Moritz Angermann's avatar
Moritz Angermann committed
167
          trace ("| Resp.:  ghc -- proxy -> slave: " ++ show res)
Moritz Angermann's avatar
Moritz Angermann committed
168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184
        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
Moritz Angermann's avatar
Moritz Angermann committed
185
  when verbose $ trace "fwdLoadCall: writing remote pipe"
Moritz Angermann's avatar
Moritz Angermann committed
186 187
  writePipe remote (putMessage msg)
  loopLoad
Moritz Angermann's avatar
Moritz Angermann committed
188
  when verbose $ trace "fwdLoadCall: reading local pipe"
Moritz Angermann's avatar
Moritz Angermann committed
189 190 191 192 193 194 195 196
  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 $
Moritz Angermann's avatar
Moritz Angermann committed
197
        trace ("| Resp.:         proxy -> slave: "
Moritz Angermann's avatar
Moritz Angermann committed
198 199 200 201
                  ++ truncateMsg 80 (show m))
      writePipe remote (put m)
    loopLoad :: IO ()
    loopLoad = do
Moritz Angermann's avatar
Moritz Angermann committed
202
      when verbose $ trace "fwdLoadCall: reading remote pipe"
Moritz Angermann's avatar
Moritz Angermann committed
203 204
      SlaveMsg msg' <- readPipe remote getSlaveMessage
      when verbose $
Moritz Angermann's avatar
Moritz Angermann committed
205
        trace ("| Sl Msg:        proxy <- slave: " ++ show msg')
Moritz Angermann's avatar
Moritz Angermann committed
206 207 208
      case msg' of
        Done -> return ()
        Missing path -> do
Moritz Angermann's avatar
Moritz Angermann committed
209 210
          when verbose $
            trace $ "fwdLoadCall: missing path: " ++ path
Moritz Angermann's avatar
Moritz Angermann committed
211 212 213
          reply =<< BS.readFile path
          loopLoad
        Have path remoteHash -> do
214
          localHash <- getFileHash path
Moritz Angermann's avatar
Moritz Angermann committed
215 216 217 218 219 220 221 222 223 224 225 226
          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
Moritz Angermann's avatar
Moritz Angermann committed
227
      when verbose $ trace "proxy/fwdCall: writing remote pipe"
Moritz Angermann's avatar
Moritz Angermann committed
228
      writePipe remote (putMessage msg)
Moritz Angermann's avatar
Moritz Angermann committed
229
      when verbose $ trace "proxy/fwdCall: reading remote pipe"
Moritz Angermann's avatar
Moritz Angermann committed
230 231 232 233 234 235
      readPipe remote get

    -- reply to ghc.
    reply :: (Show a, Binary a) => a -> IO ()
    reply msg = do
      when verbose $
Moritz Angermann's avatar
Moritz Angermann committed
236
        trace ("Resp.:    ghc <- proxy -- slave: " ++ show msg)
Moritz Angermann's avatar
Moritz Angermann committed
237 238 239 240 241
      writePipe local (put msg)

    loop = do
      (Msg msg) <- readPipe local getMessage
      when verbose $
Moritz Angermann's avatar
Moritz Angermann committed
242
        trace ("Msg:      ghc -- proxy -> slave: " ++ show msg)
Moritz Angermann's avatar
Moritz Angermann committed
243
      (Msg msg') <- hook (Msg msg)
Moritz Angermann's avatar
Moritz Angermann committed
244 245 246 247 248 249 250 251 252 253
      -- 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.
      --
Moritz Angermann's avatar
Moritz Angermann committed
254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273
      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
Moritz Angermann's avatar
Moritz Angermann committed
274 275 276 277
        -- 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
Moritz Angermann's avatar
Moritz Angermann committed
278 279 280 281
        LoadDLL path | isAbsolute path -> do
          resp <- fwdLoadCall verbose local remote msg'
          reply resp
          loop
Moritz Angermann's avatar
Moritz Angermann committed
282 283 284 285
        Shutdown{}    -> fwdCall msg' >> return ()
        _other        -> fwdCall msg' >>= reply >> loop


Moritz Angermann's avatar
Moritz Angermann committed
286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302
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
Moritz Angermann's avatar
Moritz Angermann committed
303 304 305 306 307 308 309 310 311

-- | 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 }