{-# OPTIONS_GHC -funbox-strict-fields #-}
-- | Simple interprocess quantity semaphores
--
--   Based on POSIX or Win32 C semaphores
module Control.Concurrent.Process.QSem
  ( QSem, newQSem, lookupQSem, waitQSem, tryWaitQSem, signalQSem, qSemName
  ) where

import           Control.Monad                     (when)
import           Data.Data                         (Typeable)
import           Foreign.C.Error
import           Foreign.C.String
import           Foreign.C.Types
import           Foreign.ForeignPtr
import           Foreign.Ptr
import           Foreign.SharedObjectName.Internal


-- | Opaque implementation-dependent semaphore
data QSemT

-- | 'QSem' is a quantity semaphore in which the resource is aqcuired
--   and released in units of one.
data QSem = QSem !(SOName QSem) !(ForeignPtr QSemT)
  deriving (QSem -> QSem -> Bool
(QSem -> QSem -> Bool) -> (QSem -> QSem -> Bool) -> Eq QSem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QSem -> QSem -> Bool
$c/= :: QSem -> QSem -> Bool
== :: QSem -> QSem -> Bool
$c== :: QSem -> QSem -> Bool
Eq, Typeable)

-- | Build a new 'QSem' with a supplied initial quantity.
--   The initial quantity must be at least 0.
--
--   This function throws an exception
--   if an underlying platform-dependent function fails.
newQSem :: Int -> IO QSem
newQSem :: Int -> IO QSem
newQSem Int
initial
  | Int
initial Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = String -> IO QSem
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"newQSem: Initial quantity must be non-negative"
  | Bool
otherwise   = do
    Ptr QSemT
qsem <- String -> IO (Ptr QSemT) -> IO (Ptr QSemT)
forall a. String -> IO (Ptr a) -> IO (Ptr a)
checkNullPointer String
"newQSem" (IO (Ptr QSemT) -> IO (Ptr QSemT))
-> IO (Ptr QSemT) -> IO (Ptr QSemT)
forall a b. (a -> b) -> a -> b
$ Int -> IO (Ptr QSemT)
c'qsem_new Int
initial
    SOName QSem
n <- IO (SOName QSem)
forall a. IO (SOName a)
newEmptySOName
    SOName QSem -> (CString -> IO ()) -> IO ()
forall a b. SOName a -> (CString -> IO b) -> IO b
unsafeWithSOName SOName QSem
n ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr QSemT -> CString -> IO ()
c'qsem_name Ptr QSemT
qsem
    SOName QSem -> ForeignPtr QSemT -> QSem
QSem SOName QSem
n (ForeignPtr QSemT -> QSem) -> IO (ForeignPtr QSemT) -> IO QSem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FinalizerPtr QSemT -> Ptr QSemT -> IO (ForeignPtr QSemT)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr QSemT
p'qsem_close Ptr QSemT
qsem

-- | Lookup QSem by its name in the global namespace.
--   Use this function to init several entangled semaphores in different processes.
--
--   This function throws an exception if no `QSem` with this name exist,
--   or if an underlying platform-dependent function fails.
lookupQSem :: SOName QSem -> IO QSem
lookupQSem :: SOName QSem -> IO QSem
lookupQSem SOName QSem
n = do
  Ptr QSemT
qsem <- SOName QSem -> (CString -> IO (Ptr QSemT)) -> IO (Ptr QSemT)
forall a b. SOName a -> (CString -> IO b) -> IO b
unsafeWithSOName SOName QSem
n ((CString -> IO (Ptr QSemT)) -> IO (Ptr QSemT))
-> (CString -> IO (Ptr QSemT)) -> IO (Ptr QSemT)
forall a b. (a -> b) -> a -> b
$ String -> IO (Ptr QSemT) -> IO (Ptr QSemT)
forall a. String -> IO (Ptr a) -> IO (Ptr a)
checkNullPointer String
"lookupQSem" (IO (Ptr QSemT) -> IO (Ptr QSemT))
-> (CString -> IO (Ptr QSemT)) -> CString -> IO (Ptr QSemT)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> IO (Ptr QSemT)
c'qsem_lookup
  SOName QSem -> ForeignPtr QSemT -> QSem
QSem SOName QSem
n (ForeignPtr QSemT -> QSem) -> IO (ForeignPtr QSemT) -> IO QSem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FinalizerPtr QSemT -> Ptr QSemT -> IO (ForeignPtr QSemT)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr QSemT
p'qsem_close Ptr QSemT
qsem

-- | Get a global reference to the semaphore.
--   Send this reference to another process to lookup this semaphore and
--   start interprocess communication.
qSemName :: QSem -> SOName QSem
qSemName :: QSem -> SOName QSem
qSemName (QSem SOName QSem
r ForeignPtr QSemT
_) = SOName QSem
r

-- | Wait for a unit to become available
--
--   This function throws an exception
--   if an underlying platform-dependent function fails.
waitQSem :: QSem -> IO ()
waitQSem :: QSem -> IO ()
waitQSem (QSem SOName QSem
_ ForeignPtr QSemT
p) = ForeignPtr QSemT -> (Ptr QSemT -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr QSemT
p ((Ptr QSemT -> IO ()) -> IO ()) -> (Ptr QSemT -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO CInt -> IO ()
checkZeroReturn String
"waitQSem" (IO CInt -> IO ()) -> (Ptr QSemT -> IO CInt) -> Ptr QSemT -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr QSemT -> IO CInt
c'qsem_wait

-- | Try to take a unit of the `QSem`.
--
--   This function does not wait, in fact. Sorry for naming.
--
--   Returns:
--
--     * @True@ if successfully took a unit of `QSem` (it is decremented)
--     * @False@ if number of available units is less than @1@  (it is not decremented)
--
--   This function does not throw an exception.
tryWaitQSem :: QSem -> IO Bool
tryWaitQSem :: QSem -> IO Bool
tryWaitQSem (QSem SOName QSem
_ ForeignPtr QSemT
p) = ForeignPtr QSemT -> (Ptr QSemT -> IO Bool) -> IO Bool
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr QSemT
p ((Ptr QSemT -> IO Bool) -> IO Bool)
-> (Ptr QSemT -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ (CInt -> Bool) -> IO CInt -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CInt
0 CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
==) (IO CInt -> IO Bool)
-> (Ptr QSemT -> IO CInt) -> Ptr QSemT -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr QSemT -> IO CInt
c'qsem_trywait


-- | Signal that a unit of the 'QSem' is available
--
--   This function throws an exception
--   if an underlying platform-dependent function fails.
signalQSem :: QSem -> IO ()
signalQSem :: QSem -> IO ()
signalQSem (QSem SOName QSem
_ ForeignPtr QSemT
p) = ForeignPtr QSemT -> (Ptr QSemT -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr QSemT
p ((Ptr QSemT -> IO ()) -> IO ()) -> (Ptr QSemT -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO CInt -> IO ()
checkZeroReturn String
"signalQSem" (IO CInt -> IO ()) -> (Ptr QSemT -> IO CInt) -> Ptr QSemT -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr QSemT -> IO CInt
c'qsem_signal


checkNullPointer :: String -> IO (Ptr a) -> IO (Ptr a)
checkNullPointer :: String -> IO (Ptr a) -> IO (Ptr a)
checkNullPointer String
s IO (Ptr a)
k = do
  Ptr a
p <- IO (Ptr a)
k
  if Ptr a
p Ptr a -> Ptr a -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr a
forall a. Ptr a
nullPtr
  then String -> IO (Ptr a)
forall a. String -> IO a
throwErrno (String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" returned NULL pointer.")
  else Ptr a -> IO (Ptr a)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
p

checkZeroReturn :: String -> IO CInt -> IO ()
checkZeroReturn :: String -> IO CInt -> IO ()
checkZeroReturn String
s IO CInt
k = do
  CInt
p <- IO CInt
k
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
p CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
forall a. String -> IO a
throwErrno (String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" returned non-zero result.")


foreign import ccall unsafe "qsem_new"
  c'qsem_new :: Int -> IO (Ptr QSemT)

foreign import ccall unsafe "qsem_lookup"
  c'qsem_lookup :: CString -> IO (Ptr QSemT)

foreign import ccall unsafe "&qsem_close"
  p'qsem_close :: FunPtr (Ptr QSemT -> IO ())

foreign import ccall unsafe "qsem_signal"
  c'qsem_signal :: Ptr QSemT -> IO CInt

foreign import ccall unsafe "qsem_wait"
  c'qsem_wait :: Ptr QSemT -> IO CInt

foreign import ccall unsafe "qsem_trywait"
  c'qsem_trywait :: Ptr QSemT -> IO CInt

foreign import ccall unsafe "qsem_name"
  c'qsem_name :: Ptr QSemT -> CString -> IO ()