@@ -24,22 +24,11 @@ import System.IO (IOMode(ReadMode,AppendMode,WriteMode,ReadWriteMode),
24 openFile, hClose, hPutStrLn, hPutStr, stderr, stdout)
24 openFile, hClose, hPutStrLn, hPutStr, stderr, stdout)
25import System.Posix.Files (createNamedPipe, unionFileModes, ownerReadMode, ownerWriteMode)
25import System.Posix.Files (createNamedPipe, unionFileModes, ownerReadMode, ownerWriteMode)
27−-- Option 1: low level unix routines:
27+-- Basing this on low level unix routines:
28−-- Option 2: ByteString-provided IO routines
31−-- Added in unix-2.5.1.0. Let's not depend on this yet:
32−-- import qualified System.Posix.IO.ByteString as PIO
33import qualified System.Posix.IO as PIO
28import qualified System.Posix.IO as PIO
29+-- Bytestring-version added in unix-2.5.1.0. Let's not depend on this yet:
30+-- import qualified System.Posix.IO.ByteString as PIO
34import System.Posix.Types (Fd)
31import System.Posix.Types (Fd)
40−-- An address is just a filename -- the named pipe.
41−data Addr = Addr String
44-- The msg header consists of just a length field represented as a Word32
33-- The msg header consists of just a length field represented as a Word32
45sizeof_header = 4
34sizeof_header = 4
@@ -70,16 +59,12 @@ mkTransport = do
71 mkSourceEnd :: String -> IO SourceEnd
60 mkSourceEnd :: String -> IO SourceEnd
72 mkSourceEnd filename = do
61 mkSourceEnd filename = do
73−# ifndef KEEP_CLOSED
62+ -- Initiate but do not block on file opening:
74−-- fd <- openFile filename AppendMode
63+ -- Note: Linux fifo semantics are NOT to block on open until
75−-- _ <- openFile filename WriteMode
76−-- mv <- onOSThread$ openFile filename WriteMode
77− mv <- onOSThread$ PIO.openFd filename PIO.ReadWrite Nothing PIO.defaultFileFlags
64+-- mv <- onOSThread$ PIO.openFd filename PIO.ReadWrite Nothing PIO.defaultFileFlags
78−
65+-- fd <- PIO.openFd filename PIO.ReadWrite Nothing PIO.defaultFileFlags
79− -- [2012.02.19] Still getting indefinite MVar block errors even
66+ fd <- PIO.openFd filename PIO.WriteOnly Nothing PIO.defaultFileFlags
80− -- using IORefs here:
67+
81−-- fdref <- newIORef Nothing
84 -- Write to the named pipe. If the message is less than
69 -- Write to the named pipe. If the message is less than
85 -- PIPE_BUF (4KB on linux) then this should be atomic, otherwise
70 -- PIPE_BUF (4KB on linux) then this should be atomic, otherwise
@@ -94,61 +79,34 @@ mkTransport = do
94 error "Message larger than blocksize written atomically to a named pipe. Unimplemented."
79 error "Message larger than blocksize written atomically to a named pipe. Unimplemented."
95 -- Otherwise it's just a simple write:
80 -- Otherwise it's just a simple write:
96 -- We append the length as a header. TODO - REMOVE EXTRA COPY HERE:
81 -- We append the length as a header. TODO - REMOVE EXTRA COPY HERE:
99−-- fd <- openFile filename AppendMode
100− fd <- openFile filename WriteMode
102− -- OPTION 1: Lazy opening:
103− -- r <- readIORef fdref
106− -- dbgprint1$ " (No FD for sending yet... opening) "
107− -- fd <- openFile filename AppendMode
108− -- writeIORef fdref (Just fd)
110− -- Just fd -> return fd
112− -- OPTION 2: Speculative file opening, plus this synchronnization:
114− dbgprint1$ " (sending... got file descriptor) "
117−-- TODO: Consider nonblocking opening of file to make things simpler.
119 let finalmsg = BS.concat (encode msgsize : bss)
82 let finalmsg = BS.concat (encode msgsize : bss)
120 dbgprint1$ " Final send msg: " ++ show finalmsg
83 dbgprint1$ " Final send msg: " ++ show finalmsg
85+ -- OPTION 2: Speculative file opening, plus this synchronnization:
87+-- dbgprint1$ " (sending... got file descriptor) "
121 ----------------------------------------
89 ----------------------------------------
122− -- BS.hPut fd finalmsg -- The actual send!
123 cnt <- PIO.fdWrite fd (BS.unpack finalmsg) -- inefficient!
90 cnt <- PIO.fdWrite fd (BS.unpack finalmsg) -- inefficient!
124 unless (fromIntegral cnt == BS.length finalmsg) $
91 unless (fromIntegral cnt == BS.length finalmsg) $
125 error$ "Failed to write message in one go, length: "++ show (BS.length finalmsg)
92 error$ "Failed to write message in one go, length: "++ show (BS.length finalmsg)
126 ----------------------------------------
93 ----------------------------------------
127−# ifdef KEEP_CLOSED
94+
128− hClose fd -- TEMP -- opening and closing on each send!
130 return ()
95 return ()
134−-- mkTargetEnd :: Fd -> MVar () -> TargetEnd
98+ mkTargetEnd :: String -> MVar () -> TargetEnd
135 mkTargetEnd filename lock = TargetEnd
99 mkTargetEnd filename lock = TargetEnd
136 { receive = do
100 { receive = do
137 dbgprint2$ "Begin receive action..."
101 dbgprint2$ "Begin receive action..."
138 -- This should only happen on a single process. But it may
102 -- This should only happen on a single process. But it may
139 -- happen on multiple threads so we grab a lock.
103 -- happen on multiple threads so we grab a lock.
140 takeMVar lock
104 takeMVar lock
142−-- fd <- PIO.openFd filename PIO.ReadOnly Nothing PIO.defaultFileFlags
143 mv <- onOSThread$ PIO.openFd filename PIO.ReadWrite Nothing PIO.defaultFileFlags
106 mv <- onOSThread$ PIO.openFd filename PIO.ReadWrite Nothing PIO.defaultFileFlags
144 fd <- takeMVar mv
107 fd <- takeMVar mv
145 let oneread n = do (s,cnt) <- PIO.fdRead fd (fromIntegral n)
108 let oneread n = do (s,cnt) <- PIO.fdRead fd (fromIntegral n)
146 return (BS.pack s, fromIntegral cnt)
109 return (BS.pack s, fromIntegral cnt)
148− fd <- openFile filename ReadMode
149− let oneread n = do bs <- BS.hGet fd n;
150− return (bs, BS.length bs)
152 dbgprint2$ " Attempt read header..."
110 dbgprint2$ " Attempt read header..."
154 let spinread :: Int -> IO BS.ByteString
112 let spinread :: Int -> IO BS.ByteString