semaphore-compat-2.0.0: src/System/Semaphore.hs

{-# LANGUAGE CPP #-}

module System.Semaphore
  ( -- * System semaphores

    -- $server-vs-client

    ClientSemaphore, ServerSemaphore, SemaphoreName(..)

    -- | The name of a client semaphore
  , clientSemaphoreName
  , semaphoreIdentifier
    -- | Retrieve the client semaphore corresponding to a server semaphore
  , serverClientSemaphore

    -- ** Creating a semaphore
  , createSemaphore, freshSemaphore

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

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

    -- ** Releasing resources
  , releaseSemaphoreToken

    -- $destroying
  , destroyClientSemaphore, destroyServerSemaphore

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

{- $server-vs-client

Since version 2 of @semaphore-compat@, we distinguish between two kinds
of semaphores:

  - When a jobserver creates a semaphore via 'createSemaphore', it obtains
    a 'ServerSemaphore'.
  - Jobclients (which open a pre-existing semaphore via 'openSemaphore')
    obtain a 'ClientSemaphore'.

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.
-}

{- $destroying

Destroying a semaphore releases the implicit token held by the
semaphore.

For example, when @cabal-install@ invokes @ghc@, the @ghc@ process
automatically has one semaphore token at the start (the implicit
token), and can request further tokens with 'waitOnSemaphore'. The
tokens acquired by 'waitOnSemaphore' are released by
'releaseSemaphoreToken', while the implicit token is released by
'destroyClientSemaphore'.
-}

-- base
import Data.List.NonEmpty ( NonEmpty(..) )

-- exceptions
import qualified Control.Monad.Catch as MC

import System.Semaphore.Internal.Common

#if defined(mingw32_HOST_OS)
import System.Semaphore.Internal.Win32
#elif defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
import System.Semaphore.Internal.Unsupported
#else
import System.Semaphore.Internal.Posix
#endif

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

-- | Check whether two semaphore protocol versions are compatible.
-- Only identical versions are compatible.
versionsAreCompatible :: SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool
versionsAreCompatible a b = a == b

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

-- | Create a new semaphore with the given label and initial token count.
--
-- On POSIX, crash recovery is automatic: disconnected clients' tokens
-- are returned to the pool.  On Windows, tokens held by a crashed
-- client are permanently lost.
createSemaphore :: String -- ^ label
                -> Int    -- ^ number of tokens on the semaphore
                -> IO (Either SemaphoreError ServerSemaphore)
createSemaphore label init_toks = do
  let sem_nm = SemaphoreName
        { semaphoreProtocolVersion = semaphoreVersion
        , unversionedSemaphoreNameString = label
        }
  create_sem sem_nm 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 prefix init_toks = do
  seed <- getTimeSeed
  go 0 (seedStrings seed)
  where
    go :: Int -> NonEmpty String -> IO (Either SemaphoreError ServerSemaphore)
    go i (suffix :| suffs) = do
      let sem_str = prefix ++ "_" ++ suffix
          sem_nm  = SemaphoreName
            { semaphoreProtocolVersion = semaphoreVersion
            , unversionedSemaphoreNameString = sem_str
            }
      mb_sem <- create_sem sem_nm init_toks
      case mb_sem of
        Right sem -> return (Right sem)
        Left  err
          | next : nexts <- suffs
          , i < 32 -- give up after 32 attempts
          -> go (i+1) (next :| nexts)
          | otherwise
          -> return (Left err)

-- | Open a semaphore from its 'SemaphoreIdentifier'.
--
-- The identifier should normally begin with a version prefix @v\<N\>-@.
-- An unversioned identifier is treated as v1 for backwards
-- compatibility. Returns @Left SemaphoreIncompatibleVersion@ if the
-- identifier's protocol version is not compatible with this build of
-- @semaphore-compat@.
openSemaphore :: SemaphoreIdentifier -> IO (Either SemaphoreError ClientSemaphore)
openSemaphore ident =
  case parseSemaphoreIdentifier ident of
    Nothing
      | versionsAreCompatible v1 semaphoreVersion ->
          open_sem_raw (SemaphoreName { semaphoreProtocolVersion = v1
                                      , unversionedSemaphoreNameString = ident })
      | otherwise ->
          return $ Left $ semVerError v1
    Just nm
      | not (versionsAreCompatible (semaphoreProtocolVersion nm) semaphoreVersion) ->
          return $ Left $ semVerError (semaphoreProtocolVersion nm)
      | otherwise ->
          open_sem_raw nm
  where
    v1 = SemaphoreProtocolVersion 1
    semVerError ver = SemaphoreIncompatibleVersion ver semaphoreVersion

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

seedStrings :: Int -> NonEmpty String
seedStrings seed = fmap ( \ i -> iToBase62 (i + seed) ) (0 :| [1..])

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

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

withAbstractSem :: AbstractSem -> IO b -> IO b
withAbstractSem s = MC.bracket_ (acquireSem s) (releaseSem s)