summaryrefslogtreecommitdiff
path: root/libraries/libiserv/src
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2018-02-20 00:26:45 -0500
committerBen Gamari <ben@smart-cactus.org>2018-02-20 13:15:40 -0500
commitabfe10487d2dba49bf511297f14575f9089cc5b1 (patch)
tree7416a6fcd2091f9d92fc6740af07d5e37ee9e03d /libraries/libiserv/src
parentf4336593a390e6317ac2852d8defb54bfa633d3e (diff)
downloadhaskell-abfe10487d2dba49bf511297f14575f9089cc5b1.tar.gz
Revert "Move `iserv` into `utils` and change package name
See Phab:D4377 for the rationale. We will try this again. This reverts commit 7c173b9043f7a9a5da46c5b0cc5fc3b38d1a7019.
Diffstat (limited to 'libraries/libiserv/src')
-rw-r--r--libraries/libiserv/src/GHCi/Utils.hsc25
-rw-r--r--libraries/libiserv/src/Lib.hs71
-rw-r--r--libraries/libiserv/src/Main.hs63
-rw-r--r--libraries/libiserv/src/Remote/Message.hs38
-rw-r--r--libraries/libiserv/src/Remote/Slave.hs146
5 files changed, 0 insertions, 343 deletions
diff --git a/libraries/libiserv/src/GHCi/Utils.hsc b/libraries/libiserv/src/GHCi/Utils.hsc
deleted file mode 100644
index b90cfacb5f..0000000000
--- a/libraries/libiserv/src/GHCi/Utils.hsc
+++ /dev/null
@@ -1,25 +0,0 @@
-{-# LANGUAGE CPP #-}
-module GHCi.Utils
- ( getGhcHandle
- ) where
-
-import Foreign.C
-import GHC.IO.Handle (Handle())
-#ifdef mingw32_HOST_OS
-import GHC.IO.Handle.FD (fdToHandle)
-#else
-import System.Posix
-#endif
-
-#include <fcntl.h> /* for _O_BINARY */
-
--- | Gets a GHC Handle File description from the given OS Handle or POSIX fd.
-getGhcHandle :: CInt -> IO Handle
-#ifdef mingw32_HOST_OS
-getGhcHandle handle = _open_osfhandle handle (#const _O_BINARY) >>= fdToHandle
-
-foreign import ccall "io.h _open_osfhandle" _open_osfhandle ::
- CInt -> CInt -> IO CInt
-#else
-getGhcHandle fd = fdToHandle $ Fd fd
-#endif
diff --git a/libraries/libiserv/src/Lib.hs b/libraries/libiserv/src/Lib.hs
deleted file mode 100644
index 57e65706c3..0000000000
--- a/libraries/libiserv/src/Lib.hs
+++ /dev/null
@@ -1,71 +0,0 @@
-{-# LANGUAGE RankNTypes, RecordWildCards, GADTs, ScopedTypeVariables #-}
-module Lib (serv) where
-
-import GHCi.Run
-import GHCi.TH
-import GHCi.Message
-
-import Control.DeepSeq
-import Control.Exception
-import Control.Monad
-import Data.Binary
-
-type MessageHook = Msg -> IO Msg
-
-serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO ()
-serv verbose hook pipe@Pipe{..} restore = loop
- where
- loop = do
- Msg msg <- readPipe pipe getMessage >>= hook
- discardCtrlC
-
- when verbose $ putStrLn ("iserv: " ++ show msg)
- case msg of
- Shutdown -> return ()
- RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc
- RunModFinalizers st qrefs -> wrapRunTH $ runModFinalizerRefs pipe st qrefs
- _other -> run msg >>= reply
-
- reply :: forall a. (Binary a, Show a) => a -> IO ()
- reply r = do
- when verbose $ putStrLn ("iserv: return: " ++ show r)
- writePipe pipe (put r)
- loop
-
- -- Run some TH code, which may interact with GHC by sending
- -- THMessage requests, and then finally send RunTHDone followed by a
- -- QResult. For an overview of how TH works with Remote GHCi, see
- -- Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.
- wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO ()
- wrapRunTH io = do
- r <- try io
- writePipe pipe (putTHMessage RunTHDone)
- case r of
- Left e
- | Just (GHCiQException _ err) <- fromException e ->
- reply (QFail err :: QResult a)
- | otherwise -> do
- str <- showException e
- reply (QException str :: QResult a)
- Right a -> do
- when verbose $ putStrLn "iserv: 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
- r <- try $ evaluate (force (show (e0::SomeException)))
- case r of
- Left e -> showException e
- Right str -> return str
-
- -- throw away any pending ^C exceptions while we're not running
- -- 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
- r <- try $ restore $ return ()
- case r of
- Left UserInterrupt -> return () >> discardCtrlC
- Left e -> throwIO e
- _ -> return ()
diff --git a/libraries/libiserv/src/Main.hs b/libraries/libiserv/src/Main.hs
deleted file mode 100644
index 858cee8e94..0000000000
--- a/libraries/libiserv/src/Main.hs
+++ /dev/null
@@ -1,63 +0,0 @@
-{-# LANGUAGE CPP, GADTs #-}
-
--- |
--- The Remote GHCi server.
---
--- For details on Remote GHCi, see Note [Remote GHCi] in
--- compiler/ghci/GHCi.hs.
---
-module Main (main) where
-
-import Lib (serv)
-
-import GHCi.Message
-import GHCi.Signals
-import GHCi.Utils
-
-import Control.Exception
-import Control.Monad
-import Data.IORef
-import System.Environment
-import System.Exit
-import Text.Printf
-
-dieWithUsage :: IO a
-dieWithUsage = do
- prog <- getProgName
- die $ prog ++ ": " ++ msg
- where
-#ifdef WINDOWS
- msg = "usage: iserv <write-handle> <read-handle> [-v]"
-#else
- msg = "usage: iserv <write-fd> <read-fd> [-v]"
-#endif
-
-main :: IO ()
-main = do
- args <- getArgs
- (wfd1, rfd2, rest) <-
- case args of
- arg0:arg1:rest -> do
- let wfd1 = read arg0
- rfd2 = read arg1
- return (wfd1, rfd2, 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 pipe = Pipe{pipeRead = inh, pipeWrite = outh, pipeLeftovers = lo_ref}
- uninterruptibleMask $ serv verbose hook pipe
-
- where hook = return -- empty hook
- -- we cannot allow any async exceptions while communicating, because
- -- we will lose sync in the protocol, hence uninterruptibleMask.
-
diff --git a/libraries/libiserv/src/Remote/Message.hs b/libraries/libiserv/src/Remote/Message.hs
deleted file mode 100644
index f1745301ba..0000000000
--- a/libraries/libiserv/src/Remote/Message.hs
+++ /dev/null
@@ -1,38 +0,0 @@
-{-# 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
deleted file mode 100644
index b80d09592f..0000000000
--- a/libraries/libiserv/src/Remote/Slave.hs
+++ /dev/null
@@ -1,146 +0,0 @@
-{-# 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