Add Semaphore support

System/Win32/Semaphore.hsc

@@ -0,0 +1,146 @@
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Semaphore
+-- Copyright   :  (c) Sam Derbyshire, 2022
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  Sam Derbyshire
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- Windows Semaphore objects and operations
+--
+-----------------------------------------------------------------------------
+
+module System.Win32.Semaphore
+    ( -- * Semaphores
+      Semaphore(..)
+
+      -- * Access modes
+    , AccessMode
+    , sEMAPHORE_ALL_ACCESS
+    , sEMAPHORE_MODIFY_STATE
+
+      -- * Managing semaphores
+    , createSemaphore
+    , openSemaphore
+    , releaseSemaphore
+    ) where
+
+import System.Win32.File
+import System.Win32.Types
+
+import Data.Maybe (fromMaybe)
+import Foreign hiding (void)
+import Foreign.C (withCAString)
+
+##include "windows_cconv.h"
+
+#include <windows.h>
+
+----------------------------------------------------------------
+-- Semaphore access modes
+----------------------------------------------------------------
+
+#{enum AccessMode,
+    , sEMAPHORE_ALL_ACCESS   = SEMAPHORE_ALL_ACCESS
+    , sEMAPHORE_MODIFY_STATE = SEMAPHORE_MODIFY_STATE
+    }
+
+----------------------------------------------------------------
+-- Semaphores
+----------------------------------------------------------------
+
+-- | A Windows semaphore.
+--
+-- To obtain a 'Semaphore', use 'createSemaphore' to create a new one,
+-- or 'openSemaphore' to open an existing one.
+--
+-- To wait on a semaphore, use 'System.Win32.Event.waitForSingleObject'.
+--
+-- To release resources on a semaphore, use 'releaseSemaphore'.
+--
+-- To free a semaphore, use 'System.Win32.File.closeHandle'.
+-- The semaphore object is destroyed when its last handle has been closed.
+-- Closing the handle does not affect the semaphore count; therefore, be sure to call
+-- 'releaseSemaphore' before closing the handle or before the process terminates.
+-- Otherwise, pending wait operations will either time out or continue indefinitely,
+-- depending on whether a time-out value has been specified.
+newtype Semaphore = Semaphore { semaphoreHandle :: HANDLE }
+
+-- | Open a 'Semaphore' with the given name, or create a new semaphore
+-- if no such semaphore exists, with initial count @i@ and maximum count @m@.
+--
+-- The counts must satisfy @i >= 0@, @m > 0@ and @i <= m@.
+--
+-- The returned 'Bool' is 'True' if the function found an existing semaphore
+-- with the given name, in which case a handle to that semaphore is returned
+-- and the counts are ignored.
+--
+-- Use 'openSemaphore' if you don't want to create a new semaphore.
+createSemaphore :: Maybe SECURITY_ATTRIBUTES
+                -> LONG         -- ^ initial count @i@ with @0 <= i <= m@
+                -> LONG         -- ^ maximum count @m > 0@
+                -> Maybe String -- ^ (optional) semaphore name
+                                -- (case-sensitive, limited to MAX_PATH characters)
+                -> IO (Semaphore, Bool)
+createSemaphore mb_sec initial_count max_count mb_name =
+  maybeWith with mb_sec $ \ c_sec -> do
+  maybeWith withCAString mb_name $ \ c_name -> do
+  handle <- c_CreateSemaphore c_sec initial_count max_count c_name
+  err_code <- getLastError
+  already_exists <-
+    case err_code of
+      (# const ERROR_INVALID_HANDLE) ->
+        errorWin $ "createSemaphore: semaphore name '"
+                ++ fromMaybe "" mb_name
+                ++ "' matches non-semaphore"
+      (# const ERROR_ALREADY_EXISTS) ->
+        return True
+      _                              ->
+        return False
+  if handle == nullPtr
+  then errorWin "createSemaphore"
+  else return (Semaphore handle, already_exists)
+
+foreign import WINDOWS_CCONV unsafe "windows.h CreateSemaphoreA"
+  c_CreateSemaphore :: LPSECURITY_ATTRIBUTES -> LONG -> LONG -> LPCSTR -> IO HANDLE
+
+-- | Open an existing 'Semaphore'.
+openSemaphore :: AccessMode -- ^ desired access mode
+              -> Bool       -- ^ should child processes inherit the handle?
+              -> String     -- ^ name of the semaphore to open (case-sensitive)
+              -> IO Semaphore
+openSemaphore amode inherit name =
+  withTString name $ \c_name -> do
+    handle <- failIfNull ("openSemaphore: '" ++ name ++ "'") $
+              c_OpenSemaphore (fromIntegral amode) inherit c_name
+    return (Semaphore handle)
+
+foreign import WINDOWS_CCONV unsafe "windows.h OpenSemaphoreW"
+  c_OpenSemaphore :: DWORD -> BOOL -> LPCWSTR -> IO HANDLE
+
+-- | Increase the count of the 'Semaphore' by the specified amount.
+--
+-- Returns the count of the semaphore before the increase.
+--
+-- Throws an error if the count would exceeded the maximum count
+-- of the semaphore.
+releaseSemaphore :: Semaphore -> LONG -> IO LONG
+releaseSemaphore (Semaphore handle) count =
+  with 0 $ \ ptr_prevCount -> do
+  failIfFalse_ "releaseSemaphore" $ c_ReleaseSemaphore handle count ptr_prevCount
+  peek ptr_prevCount
+
+foreign import WINDOWS_CCONV unsafe "windows.h ReleaseSemaphore"
+  c_ReleaseSemaphore :: HANDLE -> LONG -> Ptr LONG -> IO BOOL
+
+----------------------------------------------------------------
+-- End
+----------------------------------------------------------------

Win32.cabal

@@ -83,6 +83,7 @@ Library
         System.Win32.Time
         System.Win32.Console
         System.Win32.Security
+        System.Win32.Semaphore
         System.Win32.Types
         System.Win32.Shell
         System.Win32.Automation

changelog.md

@@ -4,6 +4,7 @@
 
 * Set maximum string size for getComputerName. (See #190)
 * Update withHandleToHANDLENative to handle duplex and console handles (See #191)
+* Add support for semaphores with `System.Win32.Semaphore`.
 
 ## 2.13.1.0 November 2021
 

tests/Semaphores.hs

@@ -0,0 +1,60 @@
+module Main where
+
+import Control.Concurrent
+  ( forkIO, threadDelay )
+import Control.Monad
+  ( void )
+import Data.Foldable
+  ( for_ )
+
+import System.Win32.Event
+  ( waitForSingleObject )
+import System.Win32.File
+  ( closeHandle )
+import System.Win32.Semaphore
+  ( Semaphore(..), createSemaphore, releaseSemaphore )
+
+main :: IO ()
+main = do
+
+  (test_sem, ex1) <- mk_test_sem
+  (_, ex2) <- mk_test_sem
+
+  let sem_name = "win32-test-semaphore"
+  (sem, ex3) <- createSemaphore Nothing 2 3 (Just sem_name)
+
+  putStrLn (show ex1 ++ " " ++ show ex2 ++ " " ++ show ex3)
+  -- False True False
+
+  putStrLn "=========="
+  for_ [1,2,3] (run_thread sem)
+  -- finish: 1, 2
+
+  putStrLn "=========="
+  void $ releaseSemaphore sem 3
+  -- finish: 3
+
+  threadDelay 5000   -- 5 ms
+  for_ [4,5,6,7] (run_thread sem)
+  -- finish: 4, 5
+
+  threadDelay 1000   -- 1 ms
+  putStrLn "=========="
+  void $ releaseSemaphore sem 1
+  -- finish: 6
+
+  threadDelay 100000 -- 100 ms
+  putStrLn "=========="
+  closeHandle (semaphoreHandle test_sem)
+  closeHandle (semaphoreHandle sem)
+
+run_thread :: Semaphore -> Int -> IO ()
+run_thread sem i = do
+  threadDelay 1000 -- 1 ms
+  putStrLn ("start " ++ show i)
+  void $ forkIO $ do
+    res <- waitForSingleObject (semaphoreHandle sem) 50 -- 50 ms
+    putStrLn ("finish " ++ show i ++ ": " ++ show res)
+
+mk_test_sem :: IO (Semaphore, Bool)
+mk_test_sem = createSemaphore Nothing 1 1 (Just "test-sem")

tests/Semaphores.stdout

@@ -0,0 +1,19 @@
+False True False
+==========
+start 1
+finish 1: 0
+start 2
+finish 2: 0
+start 3
+==========
+finish 3: 0
+start 4
+finish 4: 0
+start 5
+finish 5: 0
+start 6
+start 7
+==========
+finish 6: 0
+finish 7: 258
+==========

tests/all.T

@@ -8,3 +8,5 @@ test('lasterror', normal, compile_and_run, ['-package Win32'])
 test('T4452', normal, compile_and_run, ['-package Win32'])
 test('PokeTZI', ignore_stdout, compile_and_run, ['-package Win32'])
 test('HandleConversion', normal, compile_and_run, ['-package Win32'])
+
+test('Semaphores', normal, compile_and_run, ['-threaded -package Win32'])