diff options
author | Ben Gamari <ben@smart-cactus.org> | 2018-02-20 00:26:45 -0500 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2018-02-20 13:15:40 -0500 |
commit | abfe10487d2dba49bf511297f14575f9089cc5b1 (patch) | |
tree | 7416a6fcd2091f9d92fc6740af07d5e37ee9e03d /libraries/libiserv/src | |
parent | f4336593a390e6317ac2852d8defb54bfa633d3e (diff) | |
download | haskell-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.hsc | 25 | ||||
-rw-r--r-- | libraries/libiserv/src/Lib.hs | 71 | ||||
-rw-r--r-- | libraries/libiserv/src/Main.hs | 63 | ||||
-rw-r--r-- | libraries/libiserv/src/Remote/Message.hs | 38 | ||||
-rw-r--r-- | libraries/libiserv/src/Remote/Slave.hs | 146 |
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 |