packages feed

libiserv 9.2.2 → 9.6.1

raw patch · 6 files changed

+116/−292 lines, 6 filesdep −directorydep −filepathdep −networkdep ~ghciPVP ok

version bump matches the API change (PVP)

Dependencies removed: directory, filepath, network

Dependency ranges changed: ghci

API changes (from Hackage documentation)

- Lib: serv :: Bool -> MessageHook -> Pipe -> (forall a. IO a -> IO a) -> IO ()
+ IServ: serv :: Bool -> MessageHook -> Pipe -> (forall a. IO a -> IO a) -> IO ()

Files

libiserv.cabal view
@@ -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
src/GHCi/Utils.hsc view
@@ -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 <fcntl.h>     /* 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
+ src/IServ.hs view
@@ -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 ()
− src/Lib.hs 
@@ -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 ()
− src/Remote/Message.hs 
@@ -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)
− src/Remote/Slave.hs 
@@ -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