diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2012, Gard Spreemann + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Gard Spreemann nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/Example.hs b/example/Example.hs new file mode 100644 --- /dev/null +++ b/example/Example.hs @@ -0,0 +1,34 @@ +module Main where + +import System.Posix.IO + +import qualified System.Posix.IO.Select as S +import System.Posix.IO.Select.STM +import qualified System.Posix.IO.Select.MVar as M +import Control.Concurrent +import Control.Concurrent.STM.TMVar +import Control.Concurrent.STM + + +flags :: OpenFileFlags +flags = OpenFileFlags { append = False, exclusive = False, noctty = False, nonBlock = True, trunc = False } + +main :: IO () +main = + newEmptyTMVarIO >>= \t -> + forkIO (interruptor t) >> + putStrLn "The interruptor has been launched." >> + openFd "fifo" ReadOnly Nothing flags >>= \fd -> + openFd "fifo2" ReadOnly Nothing flags >>= \fd2 -> + openFd "fifo3" ReadOnly Nothing flags >>= \fd3 -> + openFd "fifo4" ReadOnly Nothing flags >>= \fd4 -> + putStrLn "The file was opened, so let the waiting game begin!" >> + selectOrTakeTMVar [fd,fd2,fd3,fd4] [] [] (Time 15 0) t >>= \ret -> + case ret of + Left 0 -> putStrLn "select() timed out on the files." + Left x -> putStrLn "There's data in one of the files!" + Right s -> putStrLn $ "Oh no, the interruptor is here: " ++ s + +interruptor :: TMVar String -> IO () +interruptor t = threadDelay (10 * 1000000) >> + atomically (putTMVar t "Bwahahaha, the interruptor was first!") diff --git a/select.cabal b/select.cabal new file mode 100644 --- /dev/null +++ b/select.cabal @@ -0,0 +1,51 @@ +Name: select +Version: 0.1 +Synopsis: Give the select(2) POSIX function a simple STM interface +Homepage: http://nonempty.org/software/haskell-select +License: BSD3 +License-file: LICENSE +Author: Gard Spreemann +Maintainer: Gard Spreemann +Copyright: 2012 Gard Spreemann +Category: System +Build-type: Simple +Extra-source-files: src/System/Posix/IO/Select/select_wrapper.c src/System/Posix/IO/Select/select_wrapper.h +Cabal-version: >=1.2 +Description: While tinkering on a project, I frequently found myself + having to make FFI calls to @select(2)@. This package is an attempt + reduce the boilerplate I needed to do that. While at it, I took the + opportunity to have what @select@ returns put in a 'TMVar'. + . + The package has three parts: + . + ["System.Posix.IO.Select"] just wraps @select@. + . + ["Control.Concurrent.STM.TMVarIO"] and "Control.Concurrent.MVarIO" put the + return value of IO actions into a 'TMVar' or an 'MVar', respectively. + . + ["System.Posix.IO.Select.STM"] and "System.Posix.IO.Select.MVar" do the above for + @select@. + . + /NOTE/: I feel I'm occupying prime namespace realestate with a package name + like select. I'll happily let myself be chased away if anybody else wants + to use this package name. Let me know. + . + /CAVEAT/: I'm not an experienced Haskeller, and this is my first foray into + FFI in general. + + + +Library + Exposed-modules: Control.Concurrent.MVarIO, + Control.Concurrent.STM.TMVarIO, + System.Posix.IO.Select, + System.Posix.IO.Select.STM, + System.Posix.IO.Select.Types, + System.Posix.IO.Select.MVar + + hs-source-dirs: src + Build-depends: base >= 4 && <5, vector, stm + + c-sources: src/System/Posix/IO/Select/select_wrapper.c + cc-options: -std=c99 -Wall -DNDEBUG + diff --git a/src/Control/Concurrent/MVarIO.hs b/src/Control/Concurrent/MVarIO.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/MVarIO.hs @@ -0,0 +1,19 @@ +-- | Perform an IO action, and place its result in an 'MVar'. See +-- also "Control.Concurrent.STM.TMVarIO" for a 'TMVar' version. +module Control.Concurrent.MVarIO (run) where + +import Control.Concurrent + +-- | @'run' action@ returns an 'MVar' immediately. The result of +-- @action@ will be placed in said 'MVar'. If the 'MVar' is full when +-- @action@ completes, the return value is lost (the action does not +-- wait for an empty 'MVar'). +run :: IO a -> IO (MVar a) +run action = newEmptyMVar >>= \mv -> + forkIO (run' action mv) >> + return mv + +run' :: IO a -> MVar a -> IO () +run' action mv = action >>= \ret -> + tryPutMVar mv ret >> + return () diff --git a/src/Control/Concurrent/STM/TMVarIO.hs b/src/Control/Concurrent/STM/TMVarIO.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/STM/TMVarIO.hs @@ -0,0 +1,34 @@ +-- | Perform an IO action, and place its result in a 'TMVar'. See +-- also "Control.Concurrent.MVarIO" for an 'MVar' version. +module Control.Concurrent.STM.TMVarIO (run, runOrTakeTMVar) where + +import Data.Functor +import Control.Concurrent +import Control.Concurrent.STM + +-- | @'run' action@ returns a 'TMVar' immediately. The result of +-- @action@ will be placed in said 'TMVar'. If the 'TMVar' is full +-- when @action@ completes, the return value is lost (the action does +-- not wait for an empty 'TMVar'). +run :: IO a -> IO (TMVar a) +run action = newEmptyTMVarIO >>= \tm -> + forkIO (run' action tm) >> + return tm + +-- | This version of 'run' takes an additional 'TMVar', and returns +-- its content /or/ the result of the IO action, depending on which is +-- available first. Note that the action is /not/ interrupted if the +-- 'TMVar' is the winner, so you may want to make sure it doesn't +-- stick around forever. +-- +-- The function was made to support +-- 'System.Posix.IO.Select.STM.selectOrTakeTMVar', the reason this +-- library exists, and may not be useful outside of that context. +runOrTakeTMVar :: IO a -> TMVar b -> IO (Either a b) +runOrTakeTMVar action tm1 = run action >>= \tm2 -> + atomically ((Left <$> takeTMVar tm2) `orElse` (Right <$> takeTMVar tm1)) + +run' :: IO a -> TMVar a -> IO () +run' action tm = action >>= \ret -> + atomically (tryPutTMVar tm ret) >> + return () diff --git a/src/System/Posix/IO/Select.hs b/src/System/Posix/IO/Select.hs new file mode 100644 --- /dev/null +++ b/src/System/Posix/IO/Select.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | Interface to the @select(2)@ POSIX function. +module System.Posix.IO.Select (select, Timeout(Never, Time)) where + +import System.Posix.IO.Select.Types +import Foreign +import Foreign.C.Types +import System.Posix.Types +import qualified Data.Vector.Storable as V -- For contiguous memory and passing to C. Should perhaps be an Array instead. + +foreign import ccall "select_wrapper.h select_wrapper" + c_select_wrapper :: Ptr CInt -> CInt -> + Ptr CInt -> CInt -> + Ptr CInt -> CInt -> + CChar -> CLong -> CLong -> + IO CInt + +-- | @'select' readFds writeFds exceptFds timeout@ calls the +-- @select(2)@ function with the file descriptors in @readFds@ as the +-- FD set to watch for read readiness, and similarly for @writeFds@ +-- and @exceptFds@, with @timeout@ specifying the timeout. The return +-- value is that of the call. +select :: [Fd] -> [Fd] -> [Fd] -> Timeout -> IO CInt +select readFds writeFds exceptFds timeout = + let + rfds = V.fromList (map fromIntegral readFds) :: V.Vector CInt -- Make contiguous memory. + nr = fromIntegral (V.length rfds) + wfds = V.fromList (map fromIntegral writeFds) :: V.Vector CInt + nw = fromIntegral (V.length wfds) + efds = V.fromList (map fromIntegral exceptFds) :: V.Vector CInt + ne = fromIntegral (V.length efds) + (tFlag, s, us) = timeoutToC timeout + in + -- Yikes, the next line is ugly. But stare at unsafeWith, and you'll see this is right. + V.unsafeWith rfds $ \pr -> V.unsafeWith wfds $ \pw -> V.unsafeWith efds $ \pe -> + c_select_wrapper pr nr pw nw pe ne tFlag s us + +timeoutToC :: Timeout -> (CChar, CLong, CLong) +timeoutToC Never = (0, 0, 0) +timeoutToC (Time s us) = (1, fromIntegral s, fromIntegral us) + diff --git a/src/System/Posix/IO/Select/MVar.hs b/src/System/Posix/IO/Select/MVar.hs new file mode 100644 --- /dev/null +++ b/src/System/Posix/IO/Select/MVar.hs @@ -0,0 +1,17 @@ +-- | Treat the POSIX @select(2)@ function as an 'MVar' 'CInt'. + +module System.Posix.IO.Select.MVar (select, Timeout(Never, Time)) where + +import System.Posix.IO.Select.Types +import qualified System.Posix.IO.Select as S +import Foreign.C.Types +import Control.Concurrent.MVar +import qualified Control.Concurrent.MVarIO as MIO +import System.Posix.Types + +-- | This version of 'S.select' immediately returns and makes the +-- return value of the @select(2)@ call available as an 'MVar' +-- 'CInt'. See 'S.select' for argument information. +select :: [Fd] -> [Fd] -> [Fd] -> Timeout -> IO (MVar CInt) +select readFds writeFds exceptFds timeout = MIO.run (S.select readFds writeFds exceptFds timeout) + diff --git a/src/System/Posix/IO/Select/STM.hs b/src/System/Posix/IO/Select/STM.hs new file mode 100644 --- /dev/null +++ b/src/System/Posix/IO/Select/STM.hs @@ -0,0 +1,37 @@ +-- | Treat the POSIX @select(2)@ function as a 'TMVar' 'CInt'. + +module System.Posix.IO.Select.STM (select, selectOrTakeTMVar, Timeout(Never, Time)) where + +import System.Posix.IO.Select.Types +import qualified System.Posix.IO.Select as S +import Foreign.C.Types +import Control.Concurrent.STM +import qualified Control.Concurrent.STM.TMVarIO as TIO +import System.Posix.Types + +-- | This version of 'S.select' immediately returns and makes the +-- return value of the @select(2)@ call available as a 'TMVar' +-- 'CInt'. See 'S.select' for argument information. +select :: [Fd] -> [Fd] -> [Fd] -> Timeout -> IO (TMVar CInt) +select readFds writeFds exceptFds timeout = TIO.run (S.select readFds writeFds exceptFds timeout) + +-- | The parameters are the same as for 'select', except for the +-- addition of a 'TMVar'. The function returns as soon as either the +-- @select(2)@ has completed, or the 'TMVar' is full. +-- +-- The return value is either the return value of @select(2)@, or the +-- content of the 'TMVar'. If the 'TMVar' becomes available first, +-- then the @select(2)@ call may hang around forever or until it times +-- out (as specified by the 'Timeout' parameter). If the @select(2)@ +-- returns before the 'TMVar' is available, the 'TMVar' is guaranteed +-- to be left in place. +-- +-- (Incidentally, 'selectOrTakeTMVar' is the task I really wanted to +-- accomplish, and solving it just turned into this little library). +selectOrTakeTMVar :: [Fd] -> [Fd] -> [Fd] -> Timeout -> TMVar a -> IO (Either CInt a) +selectOrTakeTMVar readFds writeFds exceptFds timeout mv = TIO.runOrTakeTMVar (S.select readFds writeFds exceptFds timeout) mv + +-- selectOrTakeTMVar :: [Fd] -> [Fd] -> [Fd] -> Timeout -> TMVar a -> IO (Either CInt a) +-- selectOrTakeTMVar readFds writeFds exceptFds timeout tMVar1 = +-- select readFds writeFds exceptFds timeout >>= \tMVar2 -> +-- atomically ((Left <$> takeTMVar tMVar2) `orElse` (Right <$> takeTMVar tMVar1)) diff --git a/src/System/Posix/IO/Select/Types.hs b/src/System/Posix/IO/Select/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Posix/IO/Select/Types.hs @@ -0,0 +1,10 @@ +-- | Some types used by the other modules in this package. +module System.Posix.IO.Select.Types where + +type Seconds = Int +type Microseconds = Int + +-- | A timeout of @'Never'@ tells @select(2)@ to never time out, while +-- @'Time' s us@ sets the timeout parameters to @s@ seconds and @us@ +-- microseconds. +data Timeout = Never | Time Seconds Microseconds diff --git a/src/System/Posix/IO/Select/select_wrapper.c b/src/System/Posix/IO/Select/select_wrapper.c new file mode 100644 --- /dev/null +++ b/src/System/Posix/IO/Select/select_wrapper.c @@ -0,0 +1,69 @@ +#include +#include +#include +#ifndef NDEBUG +#include +#endif + +#include "select_wrapper.h" + +int select_wrapper(const int* readfds, int num_readfds, + const int* writefds, int num_writefds, + const int* exceptfds, int num_exceptfds, + char timeout, long secs, long usecs) +{ + struct timeval tv; + tv.tv_sec = secs; + tv.tv_usec = usecs; + + int nfds = -1; + + fd_set rfds; + FD_ZERO(&rfds); + for (int i = 0; i < num_readfds; i++) + { + #ifndef NDEBUG + printf("select_wrapper.c: Registering read FD %d.\n", readfds[i]); + #endif + FD_SET(readfds[i], &rfds); + if (readfds[i] > nfds) + nfds = readfds[i]; + } + + fd_set wfds; + FD_ZERO(&wfds); + for (int i = 0; i < num_writefds; i++) + { + #ifndef NDEBUG + printf("select_wrapper.c: Registering write FD %d.\n", writefds[i]); + #endif + FD_SET(writefds[i], &wfds); + if (writefds[i] > nfds) + nfds = writefds[i]; + } + + fd_set efds; + FD_ZERO(&efds); + for (int i = 0; i < num_exceptfds; i++) + { + #ifndef NDEBUG + printf("select_wrapper.c: Registering exception FD %d.\n", exceptfds[i]); + #endif + FD_SET(exceptfds[i], &efds); + if (exceptfds[i] > nfds) + nfds = exceptfds[i]; + } + + nfds++; + int ret = -1; + if (timeout) + ret = select(nfds, &rfds, &wfds, &efds, &tv); + else + ret = select(nfds, &rfds, &wfds, &efds, NULL); + + #ifndef NDEBUG + printf("select_wrapper.c: Returning %d.\n", ret); + #endif + + return ret; +} diff --git a/src/System/Posix/IO/Select/select_wrapper.h b/src/System/Posix/IO/Select/select_wrapper.h new file mode 100644 --- /dev/null +++ b/src/System/Posix/IO/Select/select_wrapper.h @@ -0,0 +1,6 @@ +#pragma once + +int select_wrapper(const int* readfds, int num_readfds, + const int* writefds, int num_writefds, + const int* exceptfds, int num_exceptfds, + char timeout, long secs, long usecs);