-- | This library provides a cross-platform implementation of semaphores.
--
-- Its main role is to provide a cross-platform notion of semaphore that can be
-- used to implement the jobserver\/jobclient model of
-- [GHC proposal #540](https://ghc-proposals.readthedocs.io/en/latest/proposals/0540-jsem.html).
--
-- Typical usage:
--
--  - The jobserver creates a 'ServerSemaphore', e.g. using 'createSemaphore'/'freshSemaphore'.
--  - The jobserver retrieves the serialisable 'SemaphoreIdentifier' of this
--    'ServerSemaphore' by using 'serverClientSemaphore', 'clientSemaphoreName'
--    and 'semaphoreIdentifier'.
--  - The jobserver passes the 'SemaphoreIdentifier' to the jobclient via IPC.
--  - The jobclient uses 'openSemaphore' to obtain the 'ClientSemaphore'
--    corresponding to the 'SemaphoreIdentifier' it has been given.
--  - The jobclient can then request resources from the semaphore using
--    'waitOnSemaphore' (and return them using 'releaseSemaphoreToken'), or by
--    using the 'withAbstractSem' bracket pattern.
--  - Once the jobclient is done, it uses 'destroyClientSemaphore' to ensure
--    all resources are released (including any remaining tokens).
--  - Once the jobserver is done, it cleans up the resources underlying the
--    semaphore using 'destroyServerSemaphore'.
--
-- NB: the above usage outline deliberately omits any mention of implicit
-- semaphore tokens: such a notion does not exist in this library, as they are
-- purely an abstraction layer used by the jobserver implementation.
-- See 'destroyClientSemaphore' for more details.
module System.Semaphore
  ( -- * System semaphores

    -- $server-vs-client

    ClientSemaphore, ServerSemaphore
  , serverClientSemaphore

  , SemaphoreName(..)
  , clientSemaphoreName

  , SemaphoreIdentifier
  , semaphoreIdentifier

    -- ** Creating a semaphore
  , createSemaphore, freshSemaphore

    -- ** Opening a semaphore
  , SemaphoreToken
  , openSemaphore
  , parseSemaphoreIdentifier
  , SemaphoreProtocolVersion(..)
  , semaphoreVersion
  , versionsAreCompatible
  , SemaphoreError(..)

    -- ** Requesting a token
  , waitOnSemaphore, tryWaitOnSemaphore
  , withSemaphoreToken
  , getSemaphoreValue

    -- ** Releasing resources
  , releaseSemaphoreToken

  , destroyClientSemaphore, destroyServerSemaphore
    -- $implicit-tokens

  -- * Abstract semaphores
  , AbstractSem(..)
  , withAbstractSem
  ) where

-- base
import Control.Exception ( bracket, bracket_ )
import Data.List.NonEmpty ( NonEmpty(..) )

-- semaphore-compat
import System.Semaphore.Internal
import System.Semaphore.Internal.Version

--------------------------------------------------------------------------------

{- $server-vs-client

Since version 2 of @semaphore-compat@, the library distinguishes between two
kinds of semaphores:

  - When a jobserver creates a semaphore via 'createSemaphore', it obtains
    a 'ServerSemaphore'.
  - Jobclients, which are passed the 'SemaphoreIdentifier' of a pre-existing
    semaphore, obtain a 'ClientSemaphore' via 'openSemaphore'.

When the jobserver wants to also act as a jobclient, it can use
'serverClientSemaphore' to obtain the 'ClientSemaphore' corresponding
to its 'ServerSemaphore'.

This architecture allows the jobserver to keep full accounting of
semaphore resources held by all clients.
-}

{- $implicit-tokens

The GHC jobserver protocol described in [GHC proposal #540](https://ghc-proposals.readthedocs.io/en/latest/proposals/0540-jsem.html)
specifies the notion of __implicit semaphore tokens__.

  1. To invoke a jobclient, the jobserver must be in possession of at least one
     semaphore token. We consider that the jobserver passes on ownership of this
     token to the jobclient, even though no interaction with the semaphore takes
     place. This is the __implicit token__.
  2. Each jobclient thus starts with one available token (the implicit token),
     and can request more tokens by waiting on the semaphore.

A jobclient calling 'destroyClientSemaphore' signals to the jobserver that the
client is done doing work. The jobserver thus regains control of the implicit
token, which it can now use to spawn other jobclients.

Implicit tokens are purely an accounting abstraction that we superimpose on top
of semaphore token ownership for the purposes of implementing the jobserver
protocol. They are not part of this library.
-}

---------------------------------------
-- Version compatibility

-- | Check whether two semaphore protocol versions are compatible.
versionsAreCompatible :: SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool
versionsAreCompatible :: SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool
versionsAreCompatible SemaphoreProtocolVersion
a SemaphoreProtocolVersion
b =
  -- For now, only identical versions are compatible, but keeping this
  -- check abstract (via 'versionsAreCompatible') gives us more flexibility
  -- when evolving the library.
  SemaphoreProtocolVersion
a SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool
forall a. Eq a => a -> a -> Bool
== SemaphoreProtocolVersion
b

---------------------------------------
-- System-specific semaphores

-- | Create a new semaphore with the given label and initial token count.
createSemaphore :: String -- ^ label
                -> Int    -- ^ number of tokens on the semaphore
                -> IO (Either SemaphoreError ServerSemaphore)
createSemaphore :: String -> Int -> IO (Either SemaphoreError ServerSemaphore)
createSemaphore String
label Int
init_toks = do
  let sem_nm :: SemaphoreName
sem_nm = SemaphoreName
        { semaphoreProtocolVersion :: SemaphoreProtocolVersion
semaphoreProtocolVersion = SemaphoreProtocolVersion
semaphoreVersion
        , unversionedSemaphoreNameString :: String
unversionedSemaphoreNameString = String
label
        }
  SemaphoreName -> Int -> IO (Either SemaphoreError ServerSemaphore)
create_sem SemaphoreName
sem_nm Int
init_toks

-- | Create a fresh semaphore with a unique name and the given token count.
--
-- The name is derived from the given prefix with a random suffix.
freshSemaphore :: String -- ^ label prefix
               -> Int    -- ^ number of tokens on the semaphore
               -> IO (Either SemaphoreError ServerSemaphore)
freshSemaphore :: String -> Int -> IO (Either SemaphoreError ServerSemaphore)
freshSemaphore String
prefix Int
init_toks = do
  Int
seed <- IO Int
get_time_seed
  Int
-> NonEmpty String -> IO (Either SemaphoreError ServerSemaphore)
go Int
0 (Int -> NonEmpty String
seedStrings Int
seed)
  where
    go :: Int -> NonEmpty String -> IO (Either SemaphoreError ServerSemaphore)
    go :: Int
-> NonEmpty String -> IO (Either SemaphoreError ServerSemaphore)
go Int
i (String
suffix :| [String]
suffs) = do
      let sem_str :: String
sem_str = String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suffix
          sem_nm :: SemaphoreName
sem_nm  = SemaphoreName
            { semaphoreProtocolVersion :: SemaphoreProtocolVersion
semaphoreProtocolVersion = SemaphoreProtocolVersion
semaphoreVersion
            , unversionedSemaphoreNameString :: String
unversionedSemaphoreNameString = String
sem_str
            }
      Either SemaphoreError ServerSemaphore
mb_sem <- SemaphoreName -> Int -> IO (Either SemaphoreError ServerSemaphore)
create_sem SemaphoreName
sem_nm Int
init_toks
      case Either SemaphoreError ServerSemaphore
mb_sem of
        Right ServerSemaphore
sem -> Either SemaphoreError ServerSemaphore
-> IO (Either SemaphoreError ServerSemaphore)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerSemaphore -> Either SemaphoreError ServerSemaphore
forall a b. b -> Either a b
Right ServerSemaphore
sem)
        Left  SemaphoreError
err
          | String
next : [String]
nexts <- [String]
suffs
          , Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
32 -- give up after 32 attempts
          -> Int
-> NonEmpty String -> IO (Either SemaphoreError ServerSemaphore)
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (String
next String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| [String]
nexts)
          | Bool
otherwise
          -> Either SemaphoreError ServerSemaphore
-> IO (Either SemaphoreError ServerSemaphore)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SemaphoreError -> Either SemaphoreError ServerSemaphore
forall a b. a -> Either a b
Left SemaphoreError
err)

-- | Open a pre-existing semaphore.
--
-- Returns @Left SemaphoreIncompatibleVersion@ if the semaphore protocol
-- version is not compatible with the current version of @semaphore-compat@.
openSemaphore :: SemaphoreIdentifier -> IO (Either SemaphoreError ClientSemaphore)
openSemaphore :: String -> IO (Either SemaphoreError ClientSemaphore)
openSemaphore String
ident =
  case String -> Maybe SemaphoreName
parseSemaphoreIdentifier String
ident of
    Maybe SemaphoreName
Nothing
      | SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool
versionsAreCompatible SemaphoreProtocolVersion
v1 SemaphoreProtocolVersion
semaphoreVersion ->
          SemaphoreName -> IO (Either SemaphoreError ClientSemaphore)
open_sem_raw (SemaphoreName { semaphoreProtocolVersion :: SemaphoreProtocolVersion
semaphoreProtocolVersion = SemaphoreProtocolVersion
v1
                                      , unversionedSemaphoreNameString :: String
unversionedSemaphoreNameString = String
ident })
      | Bool
otherwise ->
          Either SemaphoreError ClientSemaphore
-> IO (Either SemaphoreError ClientSemaphore)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SemaphoreError ClientSemaphore
 -> IO (Either SemaphoreError ClientSemaphore))
-> Either SemaphoreError ClientSemaphore
-> IO (Either SemaphoreError ClientSemaphore)
forall a b. (a -> b) -> a -> b
$ SemaphoreError -> Either SemaphoreError ClientSemaphore
forall a b. a -> Either a b
Left (SemaphoreError -> Either SemaphoreError ClientSemaphore)
-> SemaphoreError -> Either SemaphoreError ClientSemaphore
forall a b. (a -> b) -> a -> b
$ SemaphoreProtocolVersion -> SemaphoreError
semVerError SemaphoreProtocolVersion
v1
    Just SemaphoreName
nm
      | Bool -> Bool
not (SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool
versionsAreCompatible (SemaphoreName -> SemaphoreProtocolVersion
semaphoreProtocolVersion SemaphoreName
nm) SemaphoreProtocolVersion
semaphoreVersion) ->
          Either SemaphoreError ClientSemaphore
-> IO (Either SemaphoreError ClientSemaphore)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SemaphoreError ClientSemaphore
 -> IO (Either SemaphoreError ClientSemaphore))
-> Either SemaphoreError ClientSemaphore
-> IO (Either SemaphoreError ClientSemaphore)
forall a b. (a -> b) -> a -> b
$ SemaphoreError -> Either SemaphoreError ClientSemaphore
forall a b. a -> Either a b
Left (SemaphoreError -> Either SemaphoreError ClientSemaphore)
-> SemaphoreError -> Either SemaphoreError ClientSemaphore
forall a b. (a -> b) -> a -> b
$ SemaphoreProtocolVersion -> SemaphoreError
semVerError (SemaphoreName -> SemaphoreProtocolVersion
semaphoreProtocolVersion SemaphoreName
nm)
      | Bool
otherwise ->
          SemaphoreName -> IO (Either SemaphoreError ClientSemaphore)
open_sem_raw SemaphoreName
nm
  where
    v1 :: SemaphoreProtocolVersion
v1 = Int -> SemaphoreProtocolVersion
SemaphoreProtocolVersion Int
1
    semVerError :: SemaphoreProtocolVersion -> SemaphoreError
semVerError SemaphoreProtocolVersion
ver = SemaphoreProtocolVersion
-> SemaphoreProtocolVersion -> SemaphoreError
SemaphoreIncompatibleVersion SemaphoreProtocolVersion
ver SemaphoreProtocolVersion
semaphoreVersion

-- | Acquire a token, run an action, then release the token. Exception safe.
withSemaphoreToken :: ClientSemaphore -> (SemaphoreToken -> IO a) -> IO a
withSemaphoreToken :: forall a. ClientSemaphore -> (SemaphoreToken -> IO a) -> IO a
withSemaphoreToken ClientSemaphore
sem = IO SemaphoreToken
-> (SemaphoreToken -> IO ()) -> (SemaphoreToken -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (HasCallStack => ClientSemaphore -> IO SemaphoreToken
ClientSemaphore -> IO SemaphoreToken
waitOnSemaphore ClientSemaphore
sem) HasCallStack => SemaphoreToken -> IO ()
SemaphoreToken -> IO ()
releaseSemaphoreToken

seedStrings :: Int -> NonEmpty String
seedStrings :: Int -> NonEmpty String
seedStrings Int
seed = (Int -> String) -> NonEmpty Int -> NonEmpty String
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ( \ Int
i -> Int -> String
iToBase62 (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
seed) ) (Int
0 Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| [Int
1..])

---------------------------------------
-- Abstract semaphores

-- | Abstraction over the operations of a semaphore.
data AbstractSem =
  AbstractSem
    { AbstractSem -> IO ()
acquireSem :: IO ()
    , AbstractSem -> IO ()
releaseSem :: IO ()
    }

-- | Acquire/release bracket pattern: acquire a token, perform an action,
-- and release the token.
--
-- Guarantees that the token is released in case that the inner action throws
-- an exception.
withAbstractSem :: AbstractSem -> IO b -> IO b
withAbstractSem :: forall b. AbstractSem -> IO b -> IO b
withAbstractSem AbstractSem
s = IO () -> IO () -> IO b -> IO b
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (AbstractSem -> IO ()
acquireSem AbstractSem
s) (AbstractSem -> IO ()
releaseSem AbstractSem
s)