module System.Linux.Epoll.Buffer (
Runtime,
createRuntime,
shutdownRuntime,
BufElem (..),
IBuffer,
createIBuffer,
closeIBuffer,
withIBuffer,
OBuffer,
createOBuffer,
closeOBuffer,
withOBuffer,
readBuffer,
readAvail,
readChunk,
writeBuffer,
flushBuffer
) where
import BChan
import Prelude
import Data.Maybe
import Control.Monad
import Control.Exception (bracket)
import System.Posix.Types (Fd)
import System.IO (hPrint, stderr)
import System.Posix.IO (fdRead, fdWrite)
import System.Linux.Epoll.Base
import System.Linux.Epoll.EventLoop
class BufElem a where
beZero :: a
beConcat :: [a] -> a
beLength :: a -> Int
beDrop :: Int -> a -> a
beWrite :: Fd -> a -> IO Int
beRead :: Fd -> Int -> IO (a, Int)
instance BufElem String where
beZero = ""
beConcat = concat
beLength = length
beDrop = drop
beWrite fd = liftM fromIntegral . fdWrite fd
beRead fd n = do
(s, k) <- fdRead fd (fromIntegral n)
return (s, fromIntegral k)
data Buffer a = Buffer {
bufferChan :: BChan (Maybe a),
bufferCBack :: Callback
}
newtype IBuffer a = IBuffer (Buffer a)
newtype OBuffer a = OBuffer (Buffer a)
data Runtime = Runtime {
rtILoop :: EventLoop,
rtOLoop :: EventLoop
}
createRuntime :: Size -> IO Runtime
createRuntime s = do
iloop <- createEventLoop s
oloop <- createEventLoop s
return $ Runtime iloop oloop
shutdownRuntime :: Runtime -> IO ()
shutdownRuntime rt = do
stopEventLoop (rtILoop rt)
stopEventLoop (rtOLoop rt)
createIBuffer :: BufElem a => Runtime -> Fd -> IO (IBuffer a)
createIBuffer rt fd = do
chan <- newBChan
let emap = [(inEvents, handleRead chan), (closeEvents, handleClose chan)]
cb <- addCallback (rtILoop rt) fd emap
return $ IBuffer (Buffer chan cb)
createOBuffer :: BufElem a => Runtime -> Fd -> IO (OBuffer a)
createOBuffer rt fd = do
chan <- newBChan
let emap = [(outEvents, handleWrite chan), (closeEvents, handleClose chan)]
cb <- addCallback (rtOLoop rt) fd emap
return $ OBuffer (Buffer chan cb)
closeIBuffer :: BufElem a => Runtime -> IBuffer a -> IO ()
closeIBuffer rt (IBuffer b) = do
writeBChan (bufferChan b) Nothing
removeCallback (rtILoop rt) (bufferCBack b)
closeOBuffer :: BufElem a => Runtime -> OBuffer a -> IO ()
closeOBuffer rt (OBuffer b) = do
writeBChan (bufferChan b) Nothing
removeCallback (rtOLoop rt) (bufferCBack b)
withIBuffer :: BufElem a => Runtime -> Fd -> (IBuffer a -> IO b) -> IO b
withIBuffer r fd = bracket (createIBuffer r fd) (closeIBuffer r)
withOBuffer :: BufElem a => Runtime -> Fd -> (OBuffer a -> IO b) -> IO b
withOBuffer r fd f = bracket (createOBuffer r fd) (closeOBuffer r) $ \b ->
f b >>= \v -> flushBuffer b >> return v
readBuffer :: BufElem a => IBuffer a -> IO a
readBuffer (IBuffer b) = liftM (beConcat . map fromJust . takeWhile isJust) $
getBChanContents (bufferChan b)
readChunk :: BufElem a => IBuffer a -> IO a
readChunk (IBuffer b) = liftM (fromMaybe beZero) $ readBChan (bufferChan b)
readAvail :: BufElem a => IBuffer a -> IO (Maybe a)
readAvail (IBuffer b) = do
let ch = bufferChan b
empty <- isEmptyBChan ch
if empty then readBChan ch else return Nothing
writeBuffer :: BufElem a => OBuffer a -> a -> IO ()
writeBuffer (OBuffer b) = writeBChan (bufferChan b) . Just
flushBuffer :: OBuffer a -> IO ()
flushBuffer (OBuffer b) = waitBChan (bufferChan b)
handleClose :: BufElem a => BChan (Maybe a) -> Device -> Event Data -> IO ()
handleClose ch _ _ = writeBChan ch Nothing
handleRead :: BufElem a => BChan (Maybe a) -> Device -> Event Data -> IO ()
handleRead cha dev e = do
doRead cha (eventFd e)
reEnableCallback dev (eventRef e) (eventDesc e)
where
doRead :: BufElem a => BChan (Maybe a) -> Fd -> IO ()
doRead ch fd = do
(s, k) <- beRead fd defaultBlockSize `catch` \er ->
logErr er >> return (beZero, 0)
unless (k == 0) $
writeBChan ch (Just s)
when (k == defaultBlockSize) $
doRead ch fd
handleWrite :: BufElem a => BChan (Maybe a) -> Device -> Event Data -> IO ()
handleWrite cha dev e = doWrite cha (eventFd e)
where
doWrite :: BufElem a => BChan (Maybe a) -> Fd -> IO ()
doWrite ch fd = do
s <- peekBChan ch
case s of
Just s' -> do
k <- beWrite fd s' `catch` \er -> logErr er >> return 0
if k == beLength s'
then do dropBChan ch
doWrite ch fd
else do unGetBChan ch (Just (beDrop k s'))
reEnableCallback dev (eventRef e) (eventDesc e)
Nothing -> return ()
defaultBlockSize :: Int
defaultBlockSize = 8192
logErr :: (Show a) => a -> IO ()
logErr = hPrint stderr
inEvents :: EventType
inEvents = combineEvents [inEvent, edgeTriggeredEvent, oneShotEvent]
outEvents :: EventType
outEvents = combineEvents [outEvent, edgeTriggeredEvent, oneShotEvent]