module System.Miniplex.Source (
Source,
attach,
attachWait,
read,
getMsgs,
detach,
withSource,
withSourceWait
) where
import System.Miniplex.Sekrit
import Prelude hiding (read, catch)
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Reader ()
import Data.Typeable
import Network.Socket
import System.IO.Lock
import System.IO.Unsafe
import System.Posix.Files
import System.Posix.IO
newtype Source = Source {
sock :: Socket
} deriving (Typeable)
attach :: String -> IO Source
attach what = do
(n, _, _) <- pathFromTag "System.Miniplex.Source.attach" what
bracketOnError (socket AF_UNIX Stream 0) sClose $ \s -> do
closeOnExec s
connect s (SockAddrUnix n)
shutdown s ShutdownSend
return $ Source s
attachWait :: String -> IO Source
attachWait what = do
(com, lck, ret) <- pathFromTag "System.Miniplex.Source.attachWait" what
bracketOnError (socket AF_UNIX Stream 0) sClose $ \s -> do
closeOnExec s
block . fix $ \retry -> do
ld <- do
bracket (openFd lck ReadOnly (Just mode644) defaultFileFlags) closeFd $ \lf -> do
setLockAll lf LockRead
x <- tryJust ioErrors (unblock $ connect s (SockAddrUnix com)) `catch` \e -> do
unLock ld
throwIO e
case x of
Right () -> unLock ld
Left _ -> do
wf <- flip finally (unLock ld) $ unblock $ do
handleJust eexists (const $ return ()) $ createNamedPipe ret mode644
openFd ret ReadOnly Nothing defaultFileFlags{ nonBlock = True }
unblock (threadWaitRead wf) `finally` closeFd wf
retry
shutdown s ShutdownSend
return $ Source s
read :: Source -> IO String
read so = do
n <- liftM intFromBytes $ reallyRecv s 4
reallyRecv s n
where
s = sock so
getMsgs :: Source -> IO [String]
getMsgs so = unsafeInterleaveIO . handle (\_ -> detach so >> return []) $
liftM2 (liftM2 (:)) read getMsgs so
detach :: Source -> IO ()
detach so = do
sClose (sock so)
withSource :: String -> (Source -> IO a) -> IO a
withSource tag f = block $ do
so <- attach tag
unblock (f so) `finally` detach so
withSourceWait :: String -> (Source -> IO a) -> IO a
withSourceWait tag f = block $ do
so <- unblock $ attachWait tag
unblock (f so) `finally` detach so