packages feed

libiserv (empty) → 9.0.1

raw patch · 6 files changed

+410/−0 lines, 6 filesdep +basedep +binarydep +bytestring

Dependencies added: base, binary, bytestring, containers, deepseq, directory, filepath, ghci, network, unix

Files

+ LICENSE view
@@ -0,0 +1,62 @@+This library (libraries/ghc-prim) is derived from code from several+sources: ++  * Code from the GHC project which is largely (c) The University of+    Glasgow, and distributable under a BSD-style license (see below),++  * Code from the Haskell 98 Report which is (c) Simon Peyton Jones+    and freely redistributable (but see the full license for+    restrictions).++The full text of these licenses is reproduced below.  All of the+licenses are BSD-style or compatible.++-----------------------------------------------------------------------------++The Glasgow Haskell Compiler License++Copyright 2004, The University Court of the University of Glasgow. +All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.++-----------------------------------------------------------------------------++Code derived from the document "Report on the Programming Language+Haskell 98", is distributed under the following license:++  Copyright (c) 2002 Simon Peyton Jones++  The authors intend this Report to belong to the entire Haskell+  community, and so we grant permission to copy and distribute it for+  any purpose, provided that it is reproduced in its entirety,+  including this Notice.  Modified versions of this Report may also be+  copied and distributed for any purpose, provided that the modified+  version is clearly presented as such, and that it does not claim to+  be a definition of the Haskell 98 Language.+
+ libiserv.cabal view
@@ -0,0 +1,43 @@+-- WARNING: libiserv.cabal is automatically generated from libiserv.cabal.in by+-- ../../configure.  Make sure you are editing libiserv.cabal.in, not+-- libiserv.cabal.++Name: libiserv+Version: 9.0.1+Copyright: XXX+License: BSD3+License-File: LICENSE+Author: XXX+Maintainer: XXX+Synopsis: Provides shared functionality between iserv and iserv-proxy+Description:+Category: Development+build-type: Simple+cabal-version: >=1.10++Flag network+    Description:   Build libiserv with over-the-network support+    Default:       False++Library+    Default-Language: Haskell2010+    Hs-Source-Dirs: src+    Exposed-Modules: Lib+                   , GHCi.Utils+    Build-Depends: base       >= 4   && < 5,+                   binary     >= 0.7 && < 0.11,+                   bytestring >= 0.10 && < 0.11,+                   containers >= 0.5 && < 0.7,+                   deepseq    >= 1.4 && < 1.5,+                   ghci       == 9.0.1+    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++    if os(windows)+       Cpp-Options: -DWINDOWS+   else+       Build-Depends: unix   >= 2.7 && < 2.9
+ src/GHCi/Utils.hsc view
@@ -0,0 +1,25 @@+{-# LANGUAGE CPP #-}+module GHCi.Utils+    ( getGhcHandle+    ) where++import Foreign.C+import GHC.IO.Handle (Handle())+#if defined(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+#if defined(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
+ src/Lib.hs view
@@ -0,0 +1,86 @@+{-# 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 view
@@ -0,0 +1,38 @@+{-# 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 view
@@ -0,0 +1,156 @@+{-# 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++  forever $ do+    when verbose $ trace "Opening socket"+    pipe <- acceptSocket sock >>= socketToPipe+    putStrLn $ "Listening on port " ++ show port+    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