@@ -4,12 +4,13 @@ module Network.Transport.Pipes
44 ( mkTransport
55 ) where
66
7−import Control.Monad (when)
7+import Control.Monad (when, unless)
88import Control.Concurrent.MVar
99import Control.Concurrent (threadDelay, forkOS)
1010import Data.IntMap (IntMap)
1111-- import Data.ByteString.Char8 (ByteString)
1212import Data.Word
13+import Data.IORef
1314import qualified Data.IntMap as IntMap
1415import qualified Data.ByteString.Char8 as BS
1516-- import qualified Data.ByteString.Lazy.Char8 as BS
@@ -69,8 +70,16 @@ mkTransport = do
6970
7071 mkSourceEnd :: String -> IO SourceEnd
7172 mkSourceEnd filename = do
73+# ifndef KEEP_CLOSED
7274-- fd <- openFile filename AppendMode
75+-- _ <- openFile filename WriteMode
7376-- mv <- onOSThread$ openFile filename WriteMode
77+ mv <- onOSThread$ PIO.openFd filename PIO.ReadWrite Nothing PIO.defaultFileFlags
78+
79+ -- [2012.02.19] Still getting indefinite MVar block errors even
80+ -- using IORefs here:
81+-- fdref <- newIORef Nothing
82+# endif
7483 return $
7584 -- Write to the named pipe. If the message is less than
7685 -- PIPE_BUF (4KB on linux) then this should be atomic, otherwise
@@ -85,20 +94,43 @@ mkTransport = do
8594 error "Message larger than blocksize written atomically to a named pipe. Unimplemented."
8695 -- Otherwise it's just a simple write:
8796 -- We append the length as a header. TODO - REMOVE EXTRA COPY HERE:
88−
89−-- fd <- readMVar mv
90− dbgprint1$ " (sending... got file descriptor) "
97+
98+# ifdef KEEP_CLOSED
9199-- fd <- openFile filename AppendMode
92100 fd <- openFile filename WriteMode
101+# else
102+ -- OPTION 1: Lazy opening:
103+ -- r <- readIORef fdref
104+ -- fd <- case r of
105+ -- Nothing -> do
106+ -- dbgprint1$ " (No FD for sending yet... opening) "
107+ -- fd <- openFile filename AppendMode
108+ -- writeIORef fdref (Just fd)
109+ -- return fd
110+ -- Just fd -> return fd
111+
112+ -- OPTION 2: Speculative file opening, plus this synchronnization:
113+ fd <- readMVar mv
114+ dbgprint1$ " (sending... got file descriptor) "
115+# endif
93116
94117-- TODO: Consider nonblocking opening of file to make things simpler.
95118
96119 let finalmsg = BS.concat (encode msgsize : bss)
97120 dbgprint1$ " Final send msg: " ++ show finalmsg
98− BS.hPut fd finalmsg
121+ ----------------------------------------
122+ -- BS.hPut fd finalmsg -- The actual send!
123+ cnt <- PIO.fdWrite fd (BS.unpack finalmsg) -- inefficient!
124+ unless (fromIntegral cnt == BS.length finalmsg) $
125+ error$ "Failed to write message in one go, length: "++ show (BS.length finalmsg)
126+ ----------------------------------------
127+# ifdef KEEP_CLOSED
99128 hClose fd -- TEMP -- opening and closing on each send!
129+# endif
130+ return ()
100131 }
101132
133+
102134-- mkTargetEnd :: Fd -> MVar () -> TargetEnd
103135 mkTargetEnd filename lock = TargetEnd
104136 { receive = do
@@ -108,7 +140,8 @@ mkTransport = do
108140 takeMVar lock
109141#ifdef UNIXIO
110142-- fd <- PIO.openFd filename PIO.ReadOnly Nothing PIO.defaultFileFlags
111− fd <- PIO.openFd filename PIO.ReadWrite Nothing PIO.defaultFileFlags
143+ mv <- onOSThread$ PIO.openFd filename PIO.ReadWrite Nothing PIO.defaultFileFlags
144+ fd <- takeMVar mv
112145 let oneread n = do (s,cnt) <- PIO.fdRead fd (fromIntegral n)
113146 return (BS.pack s, fromIntegral cnt)
114147#else
@@ -117,7 +150,7 @@ mkTransport = do
117150 return (bs, BS.length bs)
118151#endif
119152 dbgprint2$ " Attempt read header..."
120−
153+
121154 let spinread :: Int -> IO BS.ByteString
122155 spinread desired = do
123156-- hPutStr stderr "."
@@ -140,10 +173,13 @@ mkTransport = do
140173 return [payload]
141174 }
142175
143−-- dbgprint2 = hPutStrLn stdout
144−-- dbgprint1 = hPutStrLn stderr
176+#ifdef DEBUG
177+dbgprint2 = hPutStrLn stdout
178+dbgprint1 = hPutStrLn stderr
179+#else
145180dbgprint1 _ = return ()
146181dbgprint2 _ = return ()
182+#endif
147183
148184
149185-- Execute an action on its own OS thread. Return an MVar to synchronize on.
@@ -152,3 +188,4 @@ onOSThread action = do
152188 mv <- newEmptyMVar
153189 forkOS (action >>= putMVar mv )
154190 return mv
191+-- [2012.02.19] This didn't seem to help.