Add support for named semaphores and shared memory objects

4 files changed, 209 insertions, 1 deletions

diff --git a/System/Posix.hs b/System/Posix.hs
index bf37938..a1736a5 100644
--- a/System/Posix.hs
+++ b/System/Posix.hs
@@ -25,7 +25,9 @@ module System.Posix (
   module System.Posix.Terminal,
   module System.Posix.Time,
   module System.Posix.User,
-  module System.Posix.Resource
+  module System.Posix.Resource,
+  module System.Posix.Semaphore,
+  module System.Posix.SharedMem
  ) where
 
 import System.Posix.Types
@@ -41,6 +43,8 @@ import System.Posix.Terminal
 import System.Posix.Time
 import System.Posix.User
 import System.Posix.Resource
+import System.Posix.Semaphore
+import System.Posix.SharedMem
 
 {- TODO
 
diff --git a/System/Posix/Semaphore.hsc b/System/Posix/Semaphore.hsc
new file mode 100644
index 0000000..52bef18
--- /dev/null
+++ b/System/Posix/Semaphore.hsc
@@ -0,0 +1,132 @@
+{-# OPTIONS -fffi #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Semaphore
+-- Copyright   :  (c) Daniel Franke 2007
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX named semaphore support.
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Semaphore
+    (OpenSemFlags(..), Semaphore(), 
+     semOpen, semUnlink, semWait, semTryWait, semThreadWait, 
+     semPost, semGetValue)
+    where
+
+#include <semaphore.h>
+#include <fcntl.h>
+
+import Foreign.C
+import Foreign.ForeignPtr
+import Foreign.Marshal
+import Foreign.Ptr
+import Foreign.Storable
+import System.Posix.Types
+import System.Posix.Error
+import Control.Concurrent
+import Data.Bits
+
+data OpenSemFlags = OpenSemFlags { semCreate :: Bool,
+                                   -- ^ If true, create the semaphore if it
+                                   --   does not yet exist.
+                                   semExclusive :: Bool
+                                   -- ^ If true, throw an exception if the
+                                   --   semaphore already exists.
+                                 }
+
+newtype Semaphore = Semaphore (ForeignPtr ())
+
+-- | Open a named semaphore with the given name, flags, mode, and initial 
+--   value.
+semOpen :: String -> OpenSemFlags -> FileMode -> Int -> IO Semaphore
+semOpen name flags mode value =
+    let cflags = (if semCreate flags then #{const O_CREAT} else 0) .|.
+                 (if semExclusive flags then #{const O_EXCL} else 0)
+        semOpen' cname =
+            do sem <- throwErrnoPathIfNull "semOpen" name $ 
+                      sem_open cname (toEnum cflags) mode (toEnum value)
+               finalizer <- mkCallback (finalize sem)
+               fptr <- newForeignPtr finalizer sem
+               return $ Semaphore fptr
+        finalize sem _ = throwErrnoPathIfMinus1_ "semOpen" name $
+                         sem_close sem in
+    withCAString name semOpen'
+
+-- | Delete the semaphore with the given name.
+semUnlink :: String -> IO ()
+semUnlink name = withCAString name semUnlink'
+    where semUnlink' cname = throwErrnoPathIfMinus1_ "semUnlink" name $
+                             sem_unlink cname
+
+-- | Lock the semaphore, blocking until it becomes available.  Since this
+--   is done through a system call, this will block the *entire runtime*,
+--   not just the current thread.  If this is not the behaviour you want,
+--   use semThreadWait instead. 
+semWait :: Semaphore -> IO ()
+semWait (Semaphore fptr) = withForeignPtr fptr semWait'
+    where semWait' sem = throwErrnoIfMinus1Retry_ "semWait" $
+                         sem_wait sem
+
+-- | Attempt to lock the semaphore without blocking.  Immediately return
+--   False if it is not available.
+semTryWait :: Semaphore -> IO Bool
+semTryWait (Semaphore fptr) = withForeignPtr fptr semTrywait'
+    where semTrywait' sem = do res <- sem_trywait sem
+                               (if res == 0 then return True
+                                else do errno <- getErrno
+                                        (if errno == eINTR 
+                                         then semTrywait' sem
+                                         else if errno == eAGAIN
+                                              then return False
+                                              else throwErrno "semTrywait"))
+
+-- | Poll the semaphore until it is available, then lock it.  Unlike 
+--   semWait, this will block only the current thread rather than the
+--   entire process.
+semThreadWait :: Semaphore -> IO ()
+semThreadWait sem = do res <- semTryWait sem
+                       (if res then return ()
+                        else ( do { yield; semThreadWait sem } ))
+
+-- | Unlock the semaphore.
+semPost :: Semaphore -> IO ()
+semPost (Semaphore fptr) = withForeignPtr fptr semPost'
+    where semPost' sem = throwErrnoIfMinus1Retry_ "semPost" $
+                         sem_post sem
+
+-- | Return the semaphore's current value.
+semGetValue :: Semaphore -> IO Int
+semGetValue (Semaphore fptr) = withForeignPtr fptr semGetValue'
+    where semGetValue' sem = alloca (semGetValue_ sem)
+
+semGetValue_ :: Ptr () -> Ptr CInt -> IO Int
+semGetValue_ sem ptr = do throwErrnoIfMinus1Retry_ "semGetValue" $
+                            sem_getvalue sem ptr
+                          cint <- peek ptr
+                          return $ fromEnum cint
+
+foreign import ccall safe "wrapper"
+        mkCallback :: (Ptr () -> IO ()) -> IO (FunPtr (Ptr () -> IO ()))
+        
+foreign import ccall safe "sem_open"
+        sem_open :: CString -> CInt -> CMode -> CUInt -> IO (Ptr ())
+foreign import ccall safe "sem_close"
+        sem_close :: Ptr () -> IO CInt
+foreign import ccall safe "sem_unlink"
+        sem_unlink :: CString -> IO CInt
+
+foreign import ccall safe "sem_wait"
+        sem_wait :: Ptr () -> IO CInt
+foreign import ccall safe "sem_trywait"
+        sem_trywait :: Ptr () -> IO CInt
+foreign import ccall safe "sem_post"
+        sem_post :: Ptr () -> IO CInt
+foreign import ccall safe "sem_getvalue"
+        sem_getvalue :: Ptr () -> Ptr CInt -> IO Int
diff --git a/System/Posix/SharedMem.hsc b/System/Posix/SharedMem.hsc
new file mode 100644
index 0000000..52d4cb1
--- /dev/null
+++ b/System/Posix/SharedMem.hsc
@@ -0,0 +1,70 @@
+{-# OPTIONS -fffi #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.SharedMem
+-- Copyright   :  (c) Daniel Franke 2007
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX shared memory support.
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.SharedMem
+    (ShmOpenFlags(..), shmOpen, shmUnlink)
+    where
+
+#include <sys/types.h>
+#include <sys/mman.h>
+#include <sys/fcntl.h>
+
+import System.Posix.Types
+import System.Posix.Error
+import Foreign.C
+import Data.Bits
+
+data ShmOpenFlags = ShmOpenFlags 
+    { shmReadWrite :: Bool,
+      -- ^ If true, open the shm object read-write rather than read-only. 
+      shmCreate :: Bool,
+      -- ^ If true, create the shm object if it does not exist. 
+      shmExclusive :: Bool,
+      -- ^ If true, throw an exception if the shm object already exists.
+      shmTrunc :: Bool
+      -- ^ If true, wipe the contents of the shm object after opening it.
+    }
+
+-- | Open a shared memory object with the given name, flags, and mode.
+shmOpen :: String -> ShmOpenFlags -> FileMode -> IO Fd
+shmOpen name flags mode =
+    do cflags <- return 0
+       cflags <- return $ cflags .|. (if shmReadWrite flags
+                                      then #{const O_RDWR}
+                                      else #{const O_RDONLY})
+       cflags <- return $ cflags .|. (if shmCreate flags then #{const O_CREAT} 
+                                      else 0)
+       cflags <- return $ cflags .|. (if shmExclusive flags 
+                                      then #{const O_EXCL} 
+                                      else 0)
+       cflags <- return $ cflags .|. (if shmTrunc flags then #{const O_TRUNC} 
+                                      else 0)
+       withCAString name (shmOpen' cflags mode)
+    where shmOpen' cflags mode cname =
+              do fd <- throwErrnoIfMinus1 "shmOpen" $ 
+                       shm_open cname cflags mode
+                 return $ Fd fd
+
+-- | Delete the shared memory object with the given name.
+shmUnlink :: String -> IO ()
+shmUnlink name = withCAString name shmUnlink'
+    where shmUnlink' cname = 
+              throwErrnoIfMinus1_ "shmUnlink" $ shm_unlink cname
+
+foreign import ccall unsafe "shm_open"
+        shm_open :: CString -> CInt -> CMode -> IO CInt
+foreign import ccall unsafe "shm_unlink"
+        shm_unlink :: CString -> IO CInt
diff --git a/unix.cabal b/unix.cabal
index 508429c..9f2267b 100644
--- a/unix.cabal
+++ b/unix.cabal
@@ -29,6 +29,8 @@ exposed-modules:
 		System.Posix.Unistd
 		System.Posix.User
 		System.Posix.Signals.Exts
+                System.Posix.Semaphore
+                System.Posix.SharedMem
 extra-source-files:
 		configure.ac configure
 		unix.buildinfo.in include/HsUnixConfig.h.in