diff options
-rw-r--r-- | iserv/iserv-bin.cabal | 113 | ||||
-rw-r--r-- | iserv/proxy-src/Remote.hs | 255 | ||||
-rw-r--r-- | iserv/src/Lib.hs | 71 | ||||
-rw-r--r-- | iserv/src/Main.hs | 70 | ||||
-rw-r--r-- | iserv/src/Remote/Message.hs | 48 | ||||
-rw-r--r-- | iserv/src/Remote/Slave.hs | 124 |
6 files changed, 615 insertions, 66 deletions
diff --git a/iserv/iserv-bin.cabal b/iserv/iserv-bin.cabal index 5307e7fc0e..f0abf54901 100644 --- a/iserv/iserv-bin.cabal +++ b/iserv/iserv-bin.cabal @@ -5,19 +5,108 @@ License: BSD3 -- XXX License-File: LICENSE Author: XXX Maintainer: XXX -Synopsis: XXX +Synopsis: iserv allows GHC to delegate Tempalte Haskell computations Description: - XXX + GHC can be provided with a path to the iserv binary with + @-pgmi=/path/to/iserv-bin@, and will in combination with + @-fexternal-interpreter@, compile Template Haskell though the + @iserv-bin@ delegate. This is very similar to how ghcjs has been + compiling Template Haskell, by spawning a separate delegate (so + called runner on the javascript vm) and evaluating the splices + there. + . + iserv can also be used in combination with cross compilation. For + this, the @iserv-proxy@ needs to be built on the host, targeting the + host (as it is running on the host). @cabal install -flibrary + -fproxy@ will yield the proxy. + . + Using the cabal for the target @arch-platform-target-cabal install + -flibrary@ will build the required library that contains the ffi + @startSlave@ function, which needs to be invoked on the target + (e.g. in an iOS application) to start the remote iserv slave. + . + calling the GHC cross compiler with @-fexternal-interpreter + -pgmi=$HOME/.cabal/bin/iserv-proxy -opti\<ip address\> -opti\<port\>@ + will cause it to compile Template Haskell via the remote at \<ip address\>. + . + Thus to get cross compilation with Template Haskell follow the + following receipt: + . + * compile the iserv library for your target + . + > iserv $ arch-platform-target-cabal install -flibrary + . + * setup an application for your target that calls the + * startSlave function. This could be either haskell or your + * targets ffi capable language, if needed. + . + > void startSlave(false /* verbose */, 5000 /* port */, + > "/path/to/storagelocation/on/target"); + . + * build the iserv-proxy + . + > iserv $ cabal install -flibrary -fproxy + * Start your iserv-slave app on your target running on say @10.0.0.1:5000@ + * compiler your sources with -fexternal-interpreter and the proxy + . + > project $ arch-platform-target-ghc ModuleContainingTH.hs \ + > -fexternal-interpreter \ + > -pgmi=$HOME/.cabal/bin/iserv-proxy \ + > -opti10.0.0.1 -opti5000 + . + Should something not work as expected, provide @-opti-v@ for verbose + logging of the @iserv-proxy@. + Category: Development build-type: Simple cabal-version: >=1.10 +Flag library + Description: Build iserv library + Default: False + +Flag proxy + Description: Build iserv-proxy + Default: False + +Library + If flag(library) + Buildable: True + Else + Buildable: False + Default-Language: Haskell2010 + Hs-Source-Dirs: src + Exposed-Modules: Lib + , Remote.Message + , Remote.Slave + , GHCi.Utils + Build-Depends: base >= 4 && < 5, + binary >= 0.7 && < 0.9, + bytestring >= 0.10 && < 0.11, + containers >= 0.5 && < 0.6, + deepseq >= 1.4 && < 1.5, + cryptonite >= 0.22, + ghci == 8.1, + network >= 2.6 && < 2.7, + directory >= 1.3 && < 1.4, + filepath >= 1.4 && < 1.5 + if os(windows) + Cpp-Options: -DWINDOWS + else + Build-Depends: unix >= 2.7 && < 2.8 + Executable iserv Default-Language: Haskell2010 + ghc-options: -no-hs-main Main-Is: Main.hs C-Sources: cbits/iservmain.c Hs-Source-Dirs: src - Other-Modules: GHCi.Utils + include-dirs: . + If flag(library) + Other-Modules: GHCi.Utils + Else + Other-Modules: GHCi.Utils + , Lib Build-Depends: array >= 0.5 && < 0.6, base >= 4 && < 5, binary >= 0.7 && < 0.9, @@ -30,3 +119,21 @@ Executable iserv Cpp-Options: -DWINDOWS else Build-Depends: unix >= 2.7 && < 2.8 + +Executable iserv-proxy + If flag(proxy) + Buildable: True + Else + Buildable: False + Default-Language: Haskell2010 + Main-Is: Remote.hs + Hs-Source-Dirs: proxy-src + Build-Depends: array >= 0.5 && < 0.6, + base >= 4 && < 5, + binary >= 0.7 && < 0.9, + bytestring >= 0.10 && < 0.11, + containers >= 0.5 && < 0.6, + deepseq >= 1.4 && < 1.5, + ghci == 8.1, + network >= 2.6, + iserv-bin diff --git a/iserv/proxy-src/Remote.hs b/iserv/proxy-src/Remote.hs new file mode 100644 index 0000000000..6b1d528e18 --- /dev/null +++ b/iserv/proxy-src/Remote.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE CPP, GADTs, OverloadedStrings #-} + +{- +This is the proxy portion of iserv. + +It acts as local bridge for GHC to call +a remote slave. This all might sound +confusing, so let's try to get some +naming down. + +GHC is the actual Haskell compiler, that +acts as frontend to the code to be compiled. + +iserv is the slave, that GHC delegates compilation +of TH to. As such it needs to be compiled for +and run on the Target. In the special case +where the Host and the Target are the same, +no proxy is needed. GHC and iserv communicate +via pipes. + +iserv-proxy is the proxy instance to iserv. +The following illustration should make this +somewhat clear: + + .----- Host -----. .- Target -. + | GHC <--> proxy<+-----+> iserv | + '----------------' ^ '----------' + ^ | + | '-- communication via sockets + '--- communication via pipes + +For now, we won't support multiple concurrent +invocations of the proxy instance, and that +behavior will be undefined, as this largely +depends on the capability of the iserv on the +target to spawn multiple process. Spawning +multiple threads won't be sufficient, as the +GHC runtime has global state. + +Also the GHC runtime needs to be able to +use the linker on the Target to link archives +and object files. + +-} + +module Main (main) where + +import System.IO +import GHCi.Message +import GHCi.Utils +import GHCi.Signals + +import Remote.Message + +import Network.Socket +import Data.IORef +import Control.Monad +import System.Environment +import System.Exit +import Text.Printf + +import Data.Binary +import qualified Data.ByteString as BS + +dieWithUsage :: IO a +dieWithUsage = do + prog <- getProgName + die $ prog ++ ": " ++ msg + where +#ifdef WINDOWS + msg = "usage: iserv <write-handle> <read-handle> <slave ip> [-v]" +#else + msg = "usage: iserv <write-fd> <read-fd> <slave ip> [-v]" +#endif + +main :: IO () +main = do + args <- getArgs + (wfd1, rfd2, host_ip, port, rest) <- + case args of + arg0:arg1:arg2:arg3:rest -> do + let wfd1 = read arg0 + rfd2 = read arg1 + ip = arg2 + port = read arg3 + return (wfd1, rfd2, ip, port, 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 in_pipe = Pipe{pipeRead = inh, pipeWrite = outh, pipeLeftovers = lo_ref} + + when verbose $ + putStrLn ("Trying to connect to " ++ host_ip ++ ":" ++ (show port)) + out_pipe <- connectTo host_ip port >>= socketToPipe + + putStrLn "Starting proxy" + proxy verbose in_pipe out_pipe + +-- | A hook, to transform outgoing (proxy -> slave) +-- messages prior to sending them to the slave. +hook :: Msg -> IO Msg +hook = return + +-- | Forward a single @THMessage@ from the slave +-- to ghc, and read back the result from GHC. +-- +-- @Message@s go from ghc to the slave. +-- ghc --- proxy --> slave (@Message@) +-- @THMessage@s go from the slave to ghc +-- ghc <-- proxy --- slave (@THMessage@) +-- +fwdTHMsg :: (Binary a) => Pipe -> THMessage a -> IO a +fwdTHMsg local msg = do + writePipe local (putTHMessage msg) + readPipe local get + +-- | Fowarard a @Message@ call and handle @THMessages@. +fwdTHCall :: (Binary a) => Bool -> Pipe -> Pipe -> Message a -> IO a +fwdTHCall verbose local remote msg = do + writePipe remote (putMessage msg) + -- wait for control instructions + loopTH + readPipe remote get + where + loopTH :: IO () + loopTH = do + THMsg msg' <- readPipe remote getTHMessage + when verbose $ + putStrLn ("| TH Msg: ghc <- proxy -- slave: " ++ show msg') + res <- fwdTHMsg local msg' + when verbose $ + putStrLn ("| Resp.: ghc -- proxy -> slave: " ++ show res) + writePipe remote (put res) + case msg' of + RunTHDone -> return () + _ -> loopTH + +-- | Forwards a @Message@ call, and handle @SlaveMessage@. +-- Similar to @THMessages@, but @SlaveMessage@ are between +-- the slave and the proxy, and are not forwarded to ghc. +-- These message allow the Slave to query the proxy for +-- files. +-- +-- ghc --- proxy --> slave (@Message@) +-- +-- proxy <-- slave (@SlaveMessage@) +-- +fwdLoadCall :: (Binary a, Show a) => Bool -> Pipe -> Pipe -> Message a -> IO a +fwdLoadCall verbose _ remote msg = do + writePipe remote (putMessage msg) + loopLoad + readPipe remote get + where + truncateMsg :: Int -> String -> String + truncateMsg n s | length s > n = take n s ++ "..." + | otherwise = s + reply :: (Binary a, Show a) => a -> IO () + reply m = do + when verbose $ + putStrLn ("| Resp.: proxy -> slave: " + ++ truncateMsg 80 (show m)) + writePipe remote (put m) + loopLoad :: IO () + loopLoad = do + SlaveMsg msg' <- readPipe remote getSlaveMessage + when verbose $ + putStrLn ("| Sl Msg: proxy <- slave: " ++ show msg') + case msg' of + Done -> return () + Missing path -> do + reply =<< BS.readFile path + loopLoad + Have path remoteHash -> do + localHash <- sha256sum path + reply =<< if localHash == remoteHash + then return Nothing + else Just <$> BS.readFile path + loopLoad + +-- | The actual proxy. Conntect local and remote pipe, +-- and does some message handling. +proxy :: Bool -> Pipe -> Pipe -> IO () +proxy verbose local remote = loop + where + fwdCall :: (Binary a, Show a) => Message a -> IO a + fwdCall msg = do + writePipe remote (putMessage msg) + readPipe remote get + + -- reply to ghc. + reply :: (Show a, Binary a) => a -> IO () + reply msg = do + when verbose $ + putStrLn ("Resp.: ghc <- proxy -- slave: " ++ show msg) + writePipe local (put msg) + + loop = do + (Msg msg) <- readPipe local getMessage + when verbose $ + putStrLn ("Msg: ghc -- proxy -> slave: " ++ show msg) + (Msg msg') <- hook (Msg msg) + case msg' of + -- TH might send some message back to ghc. + RunTH{} -> do + resp <- fwdTHCall verbose local remote msg' + reply resp + loop + RunModFinalizers{} -> do + resp <- fwdTHCall verbose local remote msg' + reply resp + loop + -- Load messages might send some messages back to the proxy, to + -- requrest files that are not present on the device. + LoadArchive{} -> do + resp <- fwdLoadCall verbose local remote msg' + reply resp + loop + LoadObj{} -> do + resp <- fwdLoadCall verbose local remote msg' + reply resp + loop + Shutdown{} -> fwdCall msg' >> return () + _other -> fwdCall msg' >>= reply >> loop + + +connectTo :: String -> PortNumber -> IO Socket +connectTo host port = do + let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV] + , addrSocketType = Stream } + addr:_ <- getAddrInfo (Just hints) (Just host) (Just (show port)) + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + putStrLn $ "Created socket for " ++ host ++ ":" ++ show port + connect sock (addrAddress addr) + putStrLn "connected" + return sock + +-- | Turn a socket into an unbuffered pipe. +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 } diff --git a/iserv/src/Lib.hs b/iserv/src/Lib.hs new file mode 100644 index 0000000000..57e65706c3 --- /dev/null +++ b/iserv/src/Lib.hs @@ -0,0 +1,71 @@ +{-# 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/iserv/src/Main.hs b/iserv/src/Main.hs index 8c76e1fe71..858cee8e94 100644 --- a/iserv/src/Main.hs +++ b/iserv/src/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, RecordWildCards, GADTs, ScopedTypeVariables, RankNTypes #-} +{-# LANGUAGE CPP, GADTs #-} -- | -- The Remote GHCi server. @@ -8,16 +8,14 @@ -- module Main (main) where -import GHCi.Run -import GHCi.TH +import Lib (serv) + import GHCi.Message import GHCi.Signals import GHCi.Utils -import Control.DeepSeq import Control.Exception import Control.Monad -import Data.Binary import Data.IORef import System.Environment import System.Exit @@ -49,7 +47,7 @@ main = do ["-v"] -> return True [] -> return False _ -> dieWithUsage - when verbose $ do + when verbose $ printf "GHC iserv starting (in: %d; out: %d)\n" (fromIntegral rfd2 :: Int) (fromIntegral wfd1 :: Int) inh <- getGhcHandle rfd2 @@ -57,63 +55,9 @@ main = do installSignalHandlers lo_ref <- newIORef Nothing let pipe = Pipe{pipeRead = inh, pipeWrite = outh, pipeLeftovers = lo_ref} - uninterruptibleMask $ serv verbose pipe + 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. -serv :: Bool -> Pipe -> (forall a .IO a -> IO a) -> IO () -serv verbose pipe@Pipe{..} restore = loop - where - loop = do - Msg msg <- readPipe pipe getMessage - 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 -> do - 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/iserv/src/Remote/Message.hs b/iserv/src/Remote/Message.hs new file mode 100644 index 0000000000..faef45dcab --- /dev/null +++ b/iserv/src/Remote/Message.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE GADTs, StandaloneDeriving, ExistentialQuantification #-} + +module Remote.Message + ( SlaveMessage(..) + , SlaveMsg(..) + , sha256sum + , putSlaveMessage + , getSlaveMessage ) +where + +import Data.Binary +import Data.ByteString as BS (ByteString, readFile) + +import Crypto.Hash + +type Sha256Hash = String + +sha256 :: ByteString -> Digest SHA256 +sha256 = hash + +sha256sum :: FilePath -> IO Sha256Hash +sha256sum path = (show . sha256) <$> BS.readFile path + +-- | 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 -> Sha256Hash -> 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/iserv/src/Remote/Slave.hs b/iserv/src/Remote/Slave.hs new file mode 100644 index 0000000000..2d47a346c6 --- /dev/null +++ b/iserv/src/Remote/Slave.hs @@ -0,0 +1,124 @@ +{-# 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) + +import Data.IORef +import GHCi.Message (Pipe(..), Msg(..), Message(..), readPipe, writePipe) + +import Foreign.C.String + +import Data.Binary + +import qualified Data.ByteString as BS + +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 + startSlave' verbose base_path (toEnum port) + +startSlave' :: Bool -> String -> PortNumber -> IO () +startSlave' verbose base_path port = do + + sock <- openSocket port + + _ <- forkIO $ forever $ do + when verbose $ putStrLn "Opening socket" + pipe <- acceptSocket sock >>= socketToPipe + putStrLn $ "Listening on port " ++ show port + when verbose $ putStrLn "Staring serv" + uninterruptibleMask $ serv verbose (hook verbose base_path pipe) pipe + when verbose $ putStrLn "serv ended" + return () + + 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 sha256sum 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 sha256sum, 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 sha256sum 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 + 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)) + -- Msg (LoadDLL path) -> do + -- handleLoad ctl_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 |