packages feed

select 0.3 → 0.4

raw patch · 22 files changed

+736/−250 lines, 22 filesdep −vector

Dependencies removed: vector

Files

− example/Example.hs 
@@ -1,40 +0,0 @@-module Main where--import System.Posix.IO-import System.Posix.IO.Select-import Control.Concurrent-import Control.Concurrent.STM.OrElseIO-import Control.Concurrent.STM-import Control.Concurrent.STM.TMVar-import Control.Concurrent.STM.TChan--flags :: OpenFileFlags-flags = OpenFileFlags { append = False, exclusive = False, noctty = False, nonBlock = True, trunc = False }---- Needs the threaded runtime!-main :: IO ()-main = -    newEmptyTMVarIO >>= \t ->-    forkIO (interruptor t) >>-    putStrLn "The interruptor has been launched." >>-    newTChanIO >>= \c ->-    forkIO (interruptor2 c) >>-    putStrLn "The TChan 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!" >>-    runOrElse (select [fd,fd2,fd3,fd4] [] [] (Time 9 0)) (readTChan c) >>= \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!")--interruptor2 :: TChan String -> IO ()-interruptor2 c = threadDelay (10 * 1000000) >>-                 atomically (writeTChan c "Bwhaha, TChan interruptor was first!")
+ example/FdSetExample.hs view
@@ -0,0 +1,40 @@+module Main where++import Prelude hiding (elem)+import System.Posix.IO+import System.Posix.IO.Select.FdSet.Unsafe+import System.Posix.IO.Select.Types++flags :: OpenFileFlags+flags = OpenFileFlags { append = False, exclusive = False, noctty = False, nonBlock = True, trunc = False }++main :: IO ()+main = 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 "Making" >>+       let+           set = fromList [fd, fd3]+           set2 = insert fd4 set+           set3 = fromList [fd, fd3]+           set4 = remove fd4 (remove fd3 (remove fd2 (remove fd set3)))+       in+         print (fd `elem` set) >> +         print (fd2 `elem` set) >> +         print (fd3 `elem` set) >>+         print (fd4 `elem` set) >> +         print [fd, fd3] >>+         print (unsafeToList set) >>+         print (fd `elem` set2) >> +         print (fd2 `elem` set2) >> +         print (fd3 `elem` set2) >>+         print (fd4 `elem` set2) >>+         print (fd `elem` set3) >> +         print (fd2 `elem` set3) >> +         print (fd3 `elem` set3) >>+         print (fd4 `elem` set3) >>+         print (fd `elem` set4) >> +         print (fd2 `elem` set4) >> +         print (fd3 `elem` set4) >>+         print (fd4 `elem` set4)
+ example/SelectExample.hs view
@@ -0,0 +1,41 @@+module Main where++import System.Posix.IO+import System.Posix.IO.Select.FdSet.Unsafe+import System.Posix.IO.Select+import System.Posix.IO.Select.Types+import System.Posix.Types+import Control.Concurrent+import Control.Concurrent.STM.OrElseIO+import Control.Concurrent.STM+import Control.Concurrent.STM.TMVar+import Control.Concurrent.STM.TChan++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." >>+    newTChanIO >>= \c ->+    forkIO (interruptor2 c) >>+    putStrLn "The TChan 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!" >>+    runOrElse (select' [fd,fd2,fd3,fd4] [] [] (finite 5 0)) (readTChan c) >>= \ret ->+        case ret of+          Left x -> putStrLn ("select() returned: " ++ show x)+          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!")++interruptor2 :: TChan String -> IO ()+interruptor2 c = threadDelay (15 * 1000000) >>+                 atomically (writeTChan c "Bwhaha, TChan interruptor was first!")
+ example/SelectExample2.hs view
@@ -0,0 +1,56 @@+module Main where++import System.IO+import System.Posix.IO+import System.Posix.IO.Select.FdSet.Unsafe+import System.Posix.IO.Select+import System.Posix.IO.Select.Types+import System.Posix.Types+import Control.Concurrent+import Control.Concurrent.STM.OrElseIO+import Control.Concurrent.STM+import Control.Concurrent.STM.TMVar+import Control.Concurrent.STM.TChan++flags :: OpenFileFlags+flags = OpenFileFlags { append = False, exclusive = False, noctty = False, nonBlock = True, trunc = False }++main :: IO ()+main =+    handleToFd stdin >>= \stdinfd  ->+    newEmptyTMVarIO >>= \t ->+    forkIO (interruptor t) >>+    putStrLn "The interruptor has been launched." >>+    newTChanIO >>= \c ->+    forkIO (interruptor2 c) >>+    putStrLn "The TChan 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 -> +    let+        readfds = [fd, fd2, fd3, stdinfd, fd4]+        writefds = []+        exceptfds = []+    in+    putStrLn "The file was opened, so let the waiting game begin!" >>+    runOrElse (select (fromList readfds) empty empty (finite 9 0)) (readTChan c) >>= \ret ->+        case ret of+          Left x -> (+                     case x of+                       Error -> putStrLn ("Select error.")+                       Timeout -> putStrLn ("Select timed out.")+                       Ready n _ _ _ -> putStrLn ("There are " ++ show n ++ " readies.")+                    ) >>+                    putStrLn ("Ready read: " ++ (show (inList readfds (readyRead x)))) >>+                    putStrLn ("Ready write: " ++ (show (inList writefds (readyWrite x)))) >>+                    putStrLn ("Ready except: " ++ (show (inList exceptfds (readyException x))))+          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!")++interruptor2 :: TChan String -> IO ()+interruptor2 c = threadDelay (15 * 1000000) >>+                 atomically (writeTChan c "Bwhaha, TChan interruptor was first!")
+ example/TestStdin.hs view
@@ -0,0 +1,17 @@+module Main where++import System.Posix.IO.Select+import System.Posix.IO.Select.Types+import System.Posix.IO+import System.Posix.Types+import System.IO++main :: IO ()+main = do+  fd <- handleToFd stdin+  n <- select'' [fd] [] [] (finite 0 500)+  case n of+    0 ->  print "timeout"+    -1 -> error "select failed"+    _ ->  print "event"+  return ()
+ example/build.sh view
@@ -0,0 +1,19 @@+#!/bin/bash++p=$(pwd)++cobjs="../src/System/Posix/IO/Select/FdSet/cbits.o ../src/System/Posix/IO/Select/cbits.o"++cd ../src/System/Posix/IO/Select/FdSet/+hsc2hs Internal.hsc+gcc -DNDEBUG -Wall -std=c99 -c cbits.c+cd ..+gcc -Wall -std=c99 -lrt -c cbits.c+hsc2hs Types.hsc+cd $p++ghc -fforce-recomp -threaded -o stdin-test --make TestStdin.hs -i../src $cobjs+ghc -fforce-recomp -threaded -o fdset-example --make FdSetExample.hs -i../src $cobjs+ghc -fforce-recomp -threaded -o select-example --make SelectExample.hs -i../src $cobjs+ghc -fforce-recomp -threaded -o select-example2 --make SelectExample2.hs -i../src $cobjs+
select.cabal view
@@ -1,5 +1,5 @@ Name:                select-Version:             0.3+Version:             0.4 Synopsis:            Wrap the select(2) POSIX function Homepage:            http://nonempty.org/software/haskell-select License:             BSD3@@ -9,35 +9,60 @@ 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+Extra-source-files:  src/System/Posix/IO/Select/cbits.c, +		     src/System/Posix/IO/Select/cbits.h,+		     src/System/Posix/IO/Select/FdSet/cbits.c,+		     src/System/Posix/IO/Select/FdSet/cbits.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 provides an interface to that system call.-		     It also used to expose an STM interface for running @select(2)@ with alternative STM actions,-		     but that functionality was split into the stm-orelse-io package from version 0.3. 		     .-		     Changes in version 0.3:+		     Changes in version 0.4: 		     .-		     * Split all STM-related functionality into a separate package, stm-orelse-io, independent-		       of select.+		     * Introduce an interface to @fd_set@. 		     .+		     * Add functions with various amounts of abstraction; in particular, 'select'''+		      matches 'select' in previous versions.+		     .+		     * Retry @select(2)@ in case of interruption by signals.+		     .+		     * Remove dependence on the vector package.+		     .+		     WARNINGS:+		     .+		     * Behavior with write and exception file descriptors is under-tested. +		       Feedback is welcome.+		     .+		     * This package is far from complete, and should be tested throughly before being relied upon.+		     . 		     TODO: 		     .-		     * Provide a type for @fd_set@ that can be passed to and from C so that we can have a version -		     of 'System.Posix.IO.select' that reports /which/ file descriptors are ready, instead of how many.- 		     Its type will be something like @[Fd] -> [Fd] -> [Fd] -> Timeout -> IO ([Fd], [Fd], [Fd])@.+		     * Return the error code specified by errno if @select@ fails. 		     .+		     * Possibly move the select retry code from C to Haskell.+		     .+		     * Reorder functions to make the documentation more logical.+		     .+		     * Use hsc2hs's #const to get preprocessor constants (removes some of FdSet's cbits.c).+		     . 		     /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+		     like select. I'll happily let myself be chased away if someone more qualified wants 		     to use this package name. Let me know.  Library   Exposed-modules:     System.Posix.IO.Select,-                       System.Posix.IO.Select.Types+                       System.Posix.IO.Select.Types,+                       System.Posix.IO.Select.FdSet,+                       System.Posix.IO.Select.FdSet.Unsafe+  Other-modules:       Misc,+                       System.Posix.IO.Select.FdSet.Internal      hs-source-dirs:      src-  Build-depends:       base >= 4 && <5, vector+  Build-depends:       base >= 4 && <5   -  c-sources:           src/System/Posix/IO/Select/select_wrapper.c+  c-sources:           src/System/Posix/IO/Select/cbits.c,+                       src/System/Posix/IO/Select/FdSet/cbits.c+  include-dirs:        src/System/Posix/IO/Select/+                       src/System/Posix/IO/Select/FdSet/   cc-options:          -std=c99 -Wall -DNDEBUG -+  extra-libraries:     rt
+ src/Misc.hs view
@@ -0,0 +1,23 @@+-- | Some internally used convenience functions.+module Misc where++import Foreign.C.Types+import Foreign.ForeignPtr+import Foreign.Storable+import Foreign.Ptr++mallocInitForeignPtr :: (Storable a) => (Ptr a -> IO ()) -> IO (ForeignPtr a)+mallocInitForeignPtr initializer = mallocForeignPtr >>= \fptr ->+                                   withForeignPtr fptr initializer >>+                                   return fptr++nullForeignPtr :: IO (ForeignPtr a)+nullForeignPtr = newForeignPtr_ nullPtr++cError :: CInt -> Bool+cError = (== -1)++cTrue :: CInt -> Bool+cTrue 0 = False+cTrue _ = True +
src/System/Posix/IO/Select.hs view
@@ -1,48 +1,102 @@ {-# LANGUAGE ForeignFunctionInterface #-} --- | Interface to the @select(2)@ POSIX function.--- --- TODO: +-- | Interface to @select(2)@. The arguments to the functions exposed+-- here must fulfill the same requirements as the arguments for+-- @select@ itself; see the man page. ----- * Make a version of @'select'@ that shows which file descriptors--- are ready. (Needs a type for fd_set that can be passed to and from--- C).-module System.Posix.IO.Select (select, Timeout(Never, Time)) where+-- If the @select@ call made by any of these functions is interrupted+-- (@select@ returning @-1@ and @errno@ being @EINTR@) before the+-- given time has elapsed, the call will be retried. If the specified+-- amount of time has passed and @select@ is still being interrupted,+-- the functions below will make one last attempt with timeout+-- zero. If that call too is interrupted, behavior will be as if+-- @select@ returned an error.+module System.Posix.IO.Select (select, select', select'') where -import System.Posix.IO.Select.Types+import System.Posix.IO.Select.Types +import qualified System.Posix.IO.Select.FdSet as FS+import qualified System.Posix.IO.Select.FdSet.Unsafe as FSUNSAFE+import qualified System.Posix.IO.Select.FdSet.Internal as FSI 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.+import Foreign.Ptr+import Foreign.ForeignPtr+import Misc -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+foreign import ccall "Select/cbits.h xselect"+        c_xselect :: Fd -> Ptr () -> Ptr () -> Ptr () -> Ptr () -> IO CInt+--                   nfds  readfds   writefds  exceptfds timeout     --- | @'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 +-- | The first 'FS.FdSet' is watched for readiness to read, the second+-- for readiness to write, and the third for exceptions. The 'Timeout'+-- argument specifies when @select@ should time out (if at all). +select :: FS.FdSet -> FS.FdSet -> FS.FdSet -> Timeout -> IO Result+select rfds wfds efds timeout =+    (+     case timeout of+       Never -> nullForeignPtr+       Time timeval -> mallocInitForeignPtr ((flip poke) timeval)+    ) >>= \timevalp ->+    FS.duplicate rfds >>= \(FSI.FdSet rfdsp brfd) ->+    FS.duplicate wfds >>= \(FSI.FdSet wfdsp bwfd) ->+    FS.duplicate efds >>= \(FSI.FdSet efdsp befd) ->+    withForeignPtr rfdsp $ \rfdsp' -> +    withForeignPtr wfdsp $ \wfdsp' -> +    withForeignPtr efdsp $ \efdsp' ->+    withForeignPtr timevalp $ \timevalp' -> +    c_xselect (1 + maximum [brfd, bwfd, befd]) rfdsp' wfdsp' efdsp' (castPtr timevalp') >>= \ret ->+    return (+            if cError ret+            then Error+            else if cTrue ret+                 then Ready ret (FSI.FdSet rfdsp brfd) (FSI.FdSet wfdsp bwfd) (FSI.FdSet efdsp befd)+                 else Timeout+           ) -timeoutToC :: Timeout -> (CChar, CLong, CLong)-timeoutToC Never = (0, 0, 0)-timeoutToC (Time s us) = (1, fromIntegral s, fromIntegral us)+-- | A simpler version of 'select' that uses file descriptor lists+-- instead of 'FS.FdSet's. 'Nothing' is returned in case @select@ gives+-- an error, otherwise @'Just' (rfds, wfds, efds)@ is returned, where+-- @rfds@, @wfds@ and @efds@ are lists of ready file descriptors (they+-- may be empty, such as in the case of @select@ timing out).+select' :: [Fd] -> [Fd] -> [Fd] -> Timeout -> IO (Maybe ([Fd], [Fd], [Fd]))+select' rfds wfds efds timeout =+    (+     case timeout of+       Never -> nullForeignPtr+       Time timeval -> mallocInitForeignPtr ((flip poke) timeval)+    ) >>= \timevalp ->+    FS.fromList rfds >>= \rset@(FSI.FdSet rfdsp brfd) ->+    FS.fromList wfds >>= \wset@(FSI.FdSet wfdsp bwfd) ->+    FS.fromList efds >>= \eset@(FSI.FdSet efdsp befd) ->+    withForeignPtr rfdsp $ \rfdsp' -> +    withForeignPtr wfdsp $ \wfdsp' -> +    withForeignPtr efdsp $ \efdsp' ->+    withForeignPtr timevalp $ \timevalp' -> +    c_xselect (1 + maximum [brfd, bwfd, befd]) rfdsp' wfdsp' efdsp' (castPtr timevalp') >>= \ret ->+    if cError ret+    then return Nothing+    else FS.inList rfds rset >>= \rfds' ->+         FS.inList wfds wset >>= \wfds' ->+         FS.inList efds eset >>= \efds' ->+         return $ Just (rfds', wfds', efds') +-- | This simpler version of 'select' takes the same arguments as+-- 'select'', but only returns the return value of @select(2)@ itself+-- (i.e. @-1@ on error, otherwise the number of ready file descriptors+-- in total).+select'' :: [Fd] -> [Fd] -> [Fd] -> Timeout -> IO CInt+select'' rfds wfds efds timeout =+    (+     case timeout of+       Never -> nullForeignPtr+       Time timeval -> mallocInitForeignPtr ((flip poke) timeval)+    ) >>= \timevalp ->+    FS.fromList rfds >>= \rset@(FSI.FdSet rfdsp brfd) ->+    FS.fromList wfds >>= \wset@(FSI.FdSet wfdsp bwfd) ->+    FS.fromList efds >>= \eset@(FSI.FdSet efdsp befd) ->+    withForeignPtr rfdsp $ \rfdsp' -> +    withForeignPtr wfdsp $ \wfdsp' -> +    withForeignPtr efdsp $ \efdsp' ->+    withForeignPtr timevalp $ \timevalp' -> +    c_xselect (1 + maximum [brfd, bwfd, befd]) rfdsp' wfdsp' efdsp' (castPtr timevalp')
+ src/System/Posix/IO/Select/FdSet.hs view
@@ -0,0 +1,100 @@+-- | Interface to @fd_set@. See @select(2)@.  +--+-- The type 'I.FdSet' is opaque, but is implemented internally as a+-- pointer to an @fd_set@. All operations on 'I.FdSet's must adhere to+-- the requirements of @FD_CLR@, @FD_ISSET@, @FD_SET@ and @FD_ZERO@+-- (see @select(2)@). This includes requiring /valid/ file descriptors+-- for all operations. Most functions in this module are kept in the+-- 'IO' monad to make it easier to guarantee validity of the file+-- descriptors, but since invalid ones seem to work fine in practice+-- (at least on Linux), the module+-- "System.Posix.IO.Select.FdSet.Unsafe" provides a non-'IO'+-- interface.+--+-- Functions that return an 'I.FdSet', such as 'insert', copy the+-- underlying @fd_set@ in order to be referentially transparent.+--+-- In the documentation that follows, a file descriptor is said to be+-- /in range/ if it is non-negative and strictly smaller than the+-- system-defined @FD_SETSIZE@. Many functions silently ignore file+-- descriptors that are not in range.+module System.Posix.IO.Select.FdSet (I.FdSet(), fromList, insert, insertList, empty, elem,+                                     remove, removeList, inList, inRange, bound, duplicate) where++import Prelude hiding (elem)+import qualified System.Posix.IO.Select.FdSet.Internal as I+import Foreign+import qualified System.IO.Unsafe as UNSAFE+import System.Posix.Types+import Misc+import Control.Monad++-- | Create an 'FdSet' from a list of file descriptors. File+-- descriptors not in range (see above) are silently ignored.+fromList :: [Fd] -> IO I.FdSet+fromList fds = I.allocate' >>= \ptr ->+               withForeignPtr ptr I.c_fd_zero_wrapper >>+               mapM_ ((flip I.insert') ptr) (filter inRange fds) >>+               return (I.FdSet ptr (maximum (0:fds)))++-- | Insert a file descriptor.+insert :: Fd -> I.FdSet -> IO I.FdSet +insert fd = insertList [fd]++-- | Insert multiple file descriptors. This is more efficient than+-- multiple 'insert's (only a single copy of the set is made).+insertList :: [Fd] -> I.FdSet -> IO I.FdSet+insertList fds (I.FdSet ptr l) = +    I.duplicate' ptr >>= \newPtr ->+    mapM_ ((flip I.insert') newPtr) (filter inRange fds) >>+    return (I.FdSet newPtr (max l (maximum (0:fds))))++-- | An empty 'FdSet'.+empty :: IO I.FdSet+empty = I.allocate' >>= \ptr ->+        withForeignPtr ptr I.c_fd_zero_wrapper >>+        return (I.FdSet ptr 0)++-- | Test for membership. Recall that POSIX allows undefined behavior+-- if the file descriptor is not valid (it does, however, seem to work+-- fine on Linux).+elem :: Fd -> I.FdSet -> IO Bool+elem fd (I.FdSet ptr _) = I.elem' fd ptr >>= (return . cTrue)++-- | Remove a file descriptor.+remove :: Fd -> I.FdSet -> IO I.FdSet+remove fd = removeList [fd]++-- | Remove multiple file descriptors. This is more efficient than+-- multiple 'remove's (only a single copy of the set is made).+removeList :: [Fd] -> I.FdSet -> IO I.FdSet+removeList fds (I.FdSet ptr l) = +    I.duplicate' ptr >>= \newPtr ->+    mapM_ ((flip I.remove') newPtr) (filter inRange fds) >>+    return (I.FdSet newPtr l) -- We don't actually shrink the maximum fd here. Should be ok!++-- | @'inList' fds fdset@ gives a list of all file descriptors in+-- @fd@ that are in @fdset@.+inList :: [Fd] -> I.FdSet -> IO [Fd]+inList fds (I.FdSet ptr l) = filterM (\fd -> I.elem' fd ptr >>= (return . cTrue)) fds'+    where+      fds' = filter (\fd -> fd <= l && inRange fd) fds++-- | Test if a file descriptor is in range (see introduction).+inRange :: Fd -> Bool+inRange fd = fd' >= 0 && fd' < limit+    where+      fd' = fromIntegral fd+      limit = UNSAFE.unsafePerformIO I.c_fd_setsize_wrapper++-- | This file descriptor is at least as large as the largest in the+-- set. If no file descriptors have ever been removed from the set,+-- the value is /the largest/ in the set, but this assumption may not+-- hold after removals or other operations.+bound :: I.FdSet -> Fd+bound (I.FdSet _ l) = l++-- | Copy an 'FdSet'.+duplicate :: I.FdSet -> IO I.FdSet+duplicate (I.FdSet ptr l) = I.duplicate' ptr >>= \newPtr ->+                            return (I.FdSet newPtr l)
+ src/System/Posix/IO/Select/FdSet/Internal.hsc view
@@ -0,0 +1,51 @@+{-# LANGUAGE ForeignFunctionInterface #-}++module System.Posix.IO.Select.FdSet.Internal where++import Foreign+import Foreign.C.Types+import System.Posix.Types+import Misc++-- NOT an instance of storable. We treat fdset as opaque, maintaing only a pointer.+data FdSet = FdSet (ForeignPtr ()) Fd++#include <sys/select.h>+#include "cbits.h"+#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)++remove' :: Fd -> ForeignPtr () -> IO ()+remove' fd ptr = withForeignPtr ptr (c_fd_clr_wrapper (fromIntegral fd))+                            +insert' :: Fd -> ForeignPtr () -> IO ()+insert' fd ptr = withForeignPtr ptr (c_fd_set_wrapper (fromIntegral fd))++elem' :: Fd -> ForeignPtr () -> IO CInt+elem' fd ptr = withForeignPtr ptr (c_fd_isset_wrapper (fromIntegral fd))++pointer :: FdSet -> ForeignPtr ()+pointer (FdSet p _) = p++allocate' :: IO (ForeignPtr ())+allocate' = mallocForeignPtrBytes #{size fd_set}+-- debugging: putStrLn ("Allocating " ++ show #{size fd_set} ++ ".") >>  -- Remove when finished testing.++duplicate' :: ForeignPtr () -> IO (ForeignPtr ())+duplicate' ptr = allocate' >>= \newPtr ->+                 withForeignPtr ptr (\ptr' -> withForeignPtr newPtr (\newPtr' -> copyBytes newPtr' ptr' #{size fd_set})) >>+                 return newPtr++foreign import ccall "cbits.h fd_zero_wrapper"+        c_fd_zero_wrapper :: Ptr () -> IO ()++foreign import ccall "cbits.h fd_set_wrapper"+        c_fd_set_wrapper :: CInt -> Ptr () -> IO ()++foreign import ccall "cbits.h fd_clr_wrapper"+        c_fd_clr_wrapper :: CInt -> Ptr () -> IO ()++foreign import ccall "cbits.h fd_isset_wrapper"+        c_fd_isset_wrapper :: CInt -> Ptr () -> IO CInt++foreign import ccall "cbits.h fd_setsize_wrapper"+        c_fd_setsize_wrapper :: IO CInt
+ src/System/Posix/IO/Select/FdSet/Unsafe.hs view
@@ -0,0 +1,56 @@+-- | Pure interface to @fd_set@.+--+-- As far as I can tell, the data structure and functions in+-- "System.Posix.IO.Select.FdSet" are referentially transparent, and+-- it should be OK to escape the 'IO' monad. However, POSIX requires+-- that all operations on @fd_set@s are done with /valid/ file+-- descriptors. This can potentially be hard to ensure with lazy+-- evaluation in a pure setting, so for now this module bears the+-- unsafe label. On Linux, invalid file descriptors /seem/ to be just+-- fine.+--+--  See "System.Posix.IO.Select.FdSet" for documentation in+--  general. All functions here essentially just add+--  'UNSAFE.unsafePerformIO'.+module System.Posix.IO.Select.FdSet.Unsafe (F.FdSet(), fromList, insert, insertList,+                                    elem, remove, removeList, inList,+                                    empty, unsafeToList) where++import Prelude hiding (elem)+import System.Posix.Types+import qualified System.Posix.IO.Select.FdSet as F+import qualified System.IO.Unsafe as UNSAFE++fromList :: [Fd] -> F.FdSet+fromList = UNSAFE.unsafePerformIO . F.fromList++empty :: F.FdSet+empty = UNSAFE.unsafePerformIO F.empty++insert :: Fd -> F.FdSet -> F.FdSet+insert fd fdset = UNSAFE.unsafePerformIO (F.insert fd fdset)++insertList :: [Fd] -> F.FdSet -> F.FdSet+insertList fds fdset = UNSAFE.unsafePerformIO (F.insertList fds fdset)++elem :: Fd -> F.FdSet -> Bool+elem fd fdset = UNSAFE.unsafePerformIO (F.elem fd fdset)++remove :: Fd -> F.FdSet -> F.FdSet+remove fd fdset = UNSAFE.unsafePerformIO (F.remove fd fdset)++removeList :: [Fd] -> F.FdSet -> F.FdSet+removeList fds fdset = UNSAFE.unsafePerformIO (F.removeList fds fdset)++inList :: [Fd] -> F.FdSet -> [Fd]+inList fds fdset = UNSAFE.unsafePerformIO (F.inList fds fdset)++-- toList :: F.FdSet -> [Fd]+-- toList = UNSAFE.unsafePerformIO . F.toList++-- | This converts an 'FdSet' to a list by testing every file+-- descriptor in range for membership, which tends to involve invalid+-- file descriptors, giving undefined behavior according to POSIX. Use+-- 'inList' if possible.+unsafeToList :: F.FdSet -> [Fd]+unsafeToList fdset = inList [(fromIntegral 0)..(F.bound fdset)] fdset
+ src/System/Posix/IO/Select/FdSet/cbits.c view
@@ -0,0 +1,27 @@+#include <sys/select.h>+#include "cbits.h"++void fd_clr_wrapper(int fd, fd_set* set)+{+  FD_CLR(fd, set);+}++int fd_isset_wrapper(int fd, fd_set* set)+{+  return FD_ISSET(fd, set);+}++void fd_set_wrapper(int fd, fd_set* set)+{+  FD_SET(fd, set);+}++void fd_zero_wrapper(fd_set* set)+{+  FD_ZERO(set);+}++int fd_setsize_wrapper()+{+  return FD_SETSIZE;+}
+ src/System/Posix/IO/Select/FdSet/cbits.h view
@@ -0,0 +1,9 @@+#pragma once++#include <sys/select.h>++void fd_clr_wrapper(int fd, fd_set* set);+int fd_isset_wrapper(int fd, fd_set* set);+void fd_set_wrapper(int fd, fd_set* set);+void fd_zero_wrapper(fd_set* set);+int fd_setsize_wrapper();
− src/System/Posix/IO/Select/MVar.hs 
@@ -1,17 +0,0 @@--- | 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)-
− src/System/Posix/IO/Select/STM.hs 
@@ -1,51 +0,0 @@--- | Treat the POSIX @select(2)@ function as a 'TMVar' 'CInt'.--module System.Posix.IO.Select.STM (select, selectOrTakeTMVar, selectOrElse, selectOrElse', selectOrReadTChan, 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.RunOrElse as ROE-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.------ See also 'selectOrReadTChan' and 'selectOrElse'. Note that--- 'selectOrTakeTMVar' and the former are special cases of the latter.------ (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 = selectOrElse readFds writeFds exceptFds timeout (takeTMVar mv)---- | Analogous to 'selectOrTakeTMVar', except with a general STM--- action in place of taking a 'TMVar'.-selectOrElse :: [Fd] -> [Fd] -> [Fd] -> Timeout -> STM a -> IO (Either CInt a)-selectOrElse readFds writeFds exceptFds timeout stm = ROE.runOrElse (S.select readFds writeFds exceptFds timeout) stm---- | A version of 'selectOrElse' that prefers the STM operation to--- 'select' when both are available.-selectOrElse' :: STM a -> [Fd] -> [Fd] -> [Fd] -> Timeout -> IO (Either a CInt)-selectOrElse' stm readFds writeFds exceptFds timeout = ROE.runOrElse' stm (S.select readFds writeFds exceptFds timeout)---- | Special case of 'selectOrElse' where the STM action is reading a--- 'TChan'.-selectOrReadTChan :: [Fd] -> [Fd] -> [Fd] -> Timeout -> TChan a -> IO (Either CInt a)-selectOrReadTChan readFds writeFds exceptFds timeout tc = selectOrElse readFds writeFds exceptFds timeout (readTChan tc)
− src/System/Posix/IO/Select/Types.hs 
@@ -1,10 +0,0 @@--- | 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
+ src/System/Posix/IO/Select/Types.hsc view
@@ -0,0 +1,65 @@+{-# LANGUAGE ForeignFunctionInterface #-}++-- | Various types.+module System.Posix.IO.Select.Types where++import Foreign.C.Types+import Foreign.Storable+import qualified System.Posix.IO.Select.FdSet.Unsafe as FSUNSAFE+import qualified System.Posix.IO.Select.FdSet as FS++-- | A timeout of @'Never'@ tells @select(2)@ to never time out, while+-- @'Time'@ sets a finite timeout.+data Timeout = Never | Time CTimeval++-- | A 'Storable' instance for @struct timeval@ (see @select(2)@). The+-- first argument corresponds to @tv_sec@, the second to @tv_usec@.+data CTimeval = CTimeval CLong CLong++-- | @'finite' s us@ tells @select@ to time out after @s@ seconds and+-- @us@ microseconds.+finite :: CLong -> CLong -> Timeout+finite s us = Time (CTimeval s us)++#include <sys/time.h>+#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)+instance Storable CTimeval where+    sizeOf _ = #{size struct timeval}+    alignment _ = #{alignment struct timeval}+    peek ptr = #{peek struct timeval, tv_sec} ptr >>= \s ->+               #{peek struct timeval, tv_usec} ptr >>= \us ->+               return (CTimeval s us)+    poke ptr (CTimeval s us) = #{poke struct timeval, tv_sec} ptr s >>+                               #{poke struct timeval, tv_usec} ptr us++-- | Abstraction for the return value of @select@. @'Error'@ means+-- that @select@ returned an error, while 'Timeout' means it+-- timed out. @'Ready' n rfds wfds efds@ specifies that it returned+-- because the file descriptors in @rfds@, @wfds@ and @efds@ are ready+-- in their respective ways (see @select(2)@), with @n@ descriptors in+-- total.+data Result = Error | Timeout | Ready CInt FS.FdSet FS.FdSet FS.FdSet++-- | The total number of ready file descriptors across all three sets.+numReady :: Result -> CInt+numReady Error = 0+numReady Timeout  = 0+numReady (Ready n _ _ _) = n++-- | The file descriptors ready for reading.+readyRead :: Result -> FS.FdSet+readyRead Error = FSUNSAFE.empty+readyRead Timeout = FSUNSAFE.empty+readyRead (Ready _ rfds _ _) = rfds++-- | The file descriptors ready for writing.+readyWrite :: Result -> FS.FdSet+readyWrite Error = FSUNSAFE.empty+readyWrite Timeout = FSUNSAFE.empty+readyWrite (Ready _ _ wfds _) = wfds++-- | The file descriptors having exceptional conditions.+readyException :: Result -> FS.FdSet+readyException Error = FSUNSAFE.empty+readyException Timeout = FSUNSAFE.empty+readyException (Ready _ _ _ efds) = efds
+ src/System/Posix/IO/Select/cbits.c view
@@ -0,0 +1,94 @@+#define _POSIX_C_SOURCE 200112L+#include <stdlib.h>+#include <sys/select.h>+#include <time.h>+#include <sys/time.h>+#include <errno.h>+#include "cbits.h"+#ifndef NDEBUG+#include <stdio.h>+#endif+++int xselect(int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, struct timeval* timeout)+{+  struct timespec remaining;+  int ret;+  struct timespec start;+  struct timespec current;+  struct timespec stop;+  if (timeout != NULL)+  {+    remaining.tv_sec = timeout->tv_sec;+    remaining.tv_nsec = timeout->tv_usec*1000;+    clock_gettime(CLOCK_MONOTONIC, &start);+    stop.tv_sec = start.tv_sec + timeout->tv_sec;+    stop.tv_nsec = start.tv_nsec + timeout->tv_usec*1000;+  }+  fd_set readfds_orig = *readfds;+  fd_set writefds_orig = *writefds;+  fd_set exceptfds_orig = *exceptfds;++  for (;;)+  {+    #ifndef NDEBUG+    if (timeout != NULL)+    {+      printf("C: Remaining time: %ld s, %ld ns\n", remaining.tv_sec, remaining.tv_nsec);+      printf("C: Will select for %ld s, %ld us\n", timeout->tv_sec, timeout->tv_usec);+    }+    else+      printf("C: Will select forever.\n");+    #endif++    ret = select(nfds, readfds, writefds, exceptfds, timeout);++    if (ret == -1 && errno == EINTR)+    {+      #ifndef NDEBUG+      printf("C: Was interrupted.\n");+      #endif+      if (timeout != NULL) // Case of finite timeouts.+      {+	clock_gettime(CLOCK_MONOTONIC, &current);+	remaining.tv_sec = stop.tv_sec - current.tv_sec;+	remaining.tv_nsec = stop.tv_nsec - current.tv_nsec;++	while (remaining.tv_nsec > 1000000000)+	{+	  remaining.tv_sec++;+	  remaining.tv_nsec -= 1000000000;+	}+	while (remaining.tv_nsec < 0)+	{+	  remaining.tv_sec--;+	  remaining.tv_nsec += 1000000000;+	}+	if (remaining.tv_sec < 0)+	{+	  remaining.tv_sec = 0;+	  remaining.tv_nsec = 0;+	}++        #ifndef NDEBUG+	printf("C: Was interrupted with %ld s, %ld ns remaining\n", remaining.tv_sec, remaining.tv_nsec);+        #endif++	// Set up for retry.+	timeout->tv_sec = remaining.tv_sec;+	timeout->tv_usec = remaining.tv_nsec/1000;+      }+      // Set up for retry (also in infinite case).+      *readfds = readfds_orig;+      *writefds = writefds_orig;+      *exceptfds = exceptfds_orig;+      #ifndef NDEBUG+      printf("C: Retrying select.\n");+      #endif+    }+    else+      return ret;+  }++  return -2;   // Cannot happen.+}
+ src/System/Posix/IO/Select/cbits.h view
@@ -0,0 +1,7 @@+#pragma once++#include <sys/select.h>+#include <sys/time.h>++void subtract(struct timespec* result, const struct timespec* x, const struct timespec* y);+int xselect(int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, struct timeval* timeout);
− src/System/Posix/IO/Select/select_wrapper.c 
@@ -1,73 +0,0 @@-#include <unistd.h>-#include <sys/time.h>-#include <sys/select.h>-#ifndef NDEBUG-#include <stdio.h>-#include <errno.h>-#include <string.h>-#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);-  if (ret == -1)-    printf("select_wrapper.c: Error code %d: %s\n", errno, strerror(errno));-  #endif--  return ret;-}
− src/System/Posix/IO/Select/select_wrapper.h 
@@ -1,7 +0,0 @@-#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);-