packages feed

select (empty) → 0.1

raw patch · 12 files changed

+351/−0 lines, 12 filesdep +basedep +stmdep +vectorsetup-changed

Dependencies added: base, stm, vector

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/Example.hs view
@@ -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!")
+ select.cabal view
@@ -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 <gspreemann@gmail.com>+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 +
+ src/Control/Concurrent/MVarIO.hs view
@@ -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 ()
+ src/Control/Concurrent/STM/TMVarIO.hs view
@@ -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 ()
+ src/System/Posix/IO/Select.hs view
@@ -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)+
+ src/System/Posix/IO/Select/MVar.hs view
@@ -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)+
+ src/System/Posix/IO/Select/STM.hs view
@@ -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))
+ src/System/Posix/IO/Select/Types.hs view
@@ -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
+ src/System/Posix/IO/Select/select_wrapper.c view
@@ -0,0 +1,69 @@+#include <unistd.h>+#include <sys/time.h>+#include <sys/select.h>+#ifndef NDEBUG+#include <stdio.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);+  #endif++  return ret;+}
+ src/System/Posix/IO/Select/select_wrapper.h view
@@ -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);