diff --git a/libiserv.cabal b/libiserv.cabal --- a/libiserv.cabal +++ b/libiserv.cabal @@ -3,7 +3,7 @@ -- libiserv.cabal. Name: libiserv -Version: 9.2.2 +Version: 9.6.1 Copyright: XXX License: BSD3 License-File: LICENSE @@ -22,20 +22,14 @@ Library Default-Language: Haskell2010 Hs-Source-Dirs: src - Exposed-Modules: Lib + Exposed-Modules: IServ , GHCi.Utils Build-Depends: base >= 4 && < 5, binary >= 0.7 && < 0.11, bytestring >= 0.10 && < 0.12, containers >= 0.5 && < 0.7, deepseq >= 1.4 && < 1.5, - ghci == 9.2.2 - if flag(network) - Exposed-Modules: Remote.Message - , Remote.Slave - Build-Depends: network >= 2.6 && < 3, - directory >= 1.3 && < 1.4, - filepath >= 1.4 && < 1.5 + ghci == 9.6.1 if os(windows) Cpp-Options: -DWINDOWS diff --git a/src/GHCi/Utils.hsc b/src/GHCi/Utils.hsc --- a/src/GHCi/Utils.hsc +++ b/src/GHCi/Utils.hsc @@ -6,7 +6,16 @@ import Foreign.C import GHC.IO.Handle (Handle()) #if defined(mingw32_HOST_OS) +import Foreign.Ptr (ptrToIntPtr) +import GHC.IO (onException) import GHC.IO.Handle.FD (fdToHandle) +import GHC.Windows (HANDLE) +import GHC.IO.SubSystem (()) +import GHC.IO.Handle.Windows (mkHandleFromHANDLE) +import GHC.IO.Device as IODevice +import GHC.IO.Encoding (getLocaleEncoding) +import GHC.IO.IOMode +import GHC.IO.Windows.Handle (fromHANDLE, Io(), NativeHandle()) #else import System.Posix #endif @@ -14,12 +23,28 @@ #include /* for _O_BINARY */ -- | Gets a GHC Handle File description from the given OS Handle or POSIX fd. -getGhcHandle :: CInt -> IO Handle + #if defined(mingw32_HOST_OS) -getGhcHandle handle = _open_osfhandle handle (#const _O_BINARY) >>= fdToHandle +getGhcHandle :: HANDLE -> IO Handle +getGhcHandle = getGhcHandlePOSIX getGhcHandleNative +getGhcHandlePOSIX :: HANDLE -> IO Handle +getGhcHandlePOSIX handle = do + let intptr = ptrToIntPtr handle + _open_osfhandle (fromIntegral intptr) (#const _O_BINARY) >>= fdToHandle + +getGhcHandleNative :: HANDLE -> IO Handle +getGhcHandleNative hwnd = + do mb_codec <- fmap Just getLocaleEncoding + let iomode = ReadWriteMode + native_handle = fromHANDLE hwnd :: Io NativeHandle + hw_type <- IODevice.devType $ native_handle + mkHandleFromHANDLE native_handle hw_type (show hwnd) iomode mb_codec + `onException` IODevice.close native_handle + foreign import ccall "io.h _open_osfhandle" _open_osfhandle :: CInt -> CInt -> IO CInt #else +getGhcHandle :: CInt -> IO Handle getGhcHandle fd = fdToHandle $ Fd fd #endif diff --git a/src/IServ.hs b/src/IServ.hs new file mode 100644 --- /dev/null +++ b/src/IServ.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE RankNTypes, RecordWildCards, GADTs, ScopedTypeVariables #-} +module IServ (serv) where + +import GHCi.Run +import GHCi.TH +import GHCi.Message + +import Control.DeepSeq +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 $ trace ("msg: " ++ (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 $ trace ("writing pipe: " ++ 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 + 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 -> 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 $ 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 + 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 + when verbose $ trace "discardCtrlC" + r <- try $ restore $ return () + case r of + Left UserInterrupt -> return () >> discardCtrlC + Left e -> throwIO e + _ -> return () diff --git a/src/Lib.hs b/src/Lib.hs deleted file mode 100644 --- a/src/Lib.hs +++ /dev/null @@ -1,86 +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 - -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 $ trace ("msg: " ++ (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 $ trace ("writing pipe: " ++ 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 - 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 -> 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 $ 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 - 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 - when verbose $ trace "discardCtrlC" - r <- try $ restore $ return () - case r of - Left UserInterrupt -> return () >> discardCtrlC - Left e -> throwIO e - _ -> return () diff --git a/src/Remote/Message.hs b/src/Remote/Message.hs deleted file mode 100644 --- a/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/src/Remote/Slave.hs b/src/Remote/Slave.hs deleted file mode 100644 --- a/src/Remote/Slave.hs +++ /dev/null @@ -1,157 +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 - -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)) - | 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 - base_path <- peekCString s - trace $ "DocRoot: " ++ 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 - hSetBuffering stdin LineBuffering - hSetBuffering stdout LineBuffering - - sock <- openSocket port - actualPort <- socketPort sock - putStrLn $ "Listening on port " ++ show actualPort - - forever $ do - when verbose $ trace "Opening socket" - pipe <- acceptSocket sock >>= socketToPipe - when verbose $ trace "Starting serv" - uninterruptibleMask $ serv verbose (hook verbose base_path pipe) pipe - when verbose $ trace "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. 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 $ trace ("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