{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | POSIX backend: semaphores implemented on top of Unix domain sockets.
module System.Semaphore.Internal.Posix
  ( ClientSemaphore(..), ServerSemaphore(..)
  , SemaphoreToken(..)
  , waitOnSemaphore, tryWaitOnSemaphore
  , releaseSemaphoreToken
  , destroyClientSemaphore, destroyServerSemaphore
  , getSemaphoreValue

  , create_sem, open_sem_raw
  , get_time_seed
  ) where

-- base
import Control.Concurrent
  ( ThreadId, forkIOWithUnmask, killThread )
import Control.Concurrent.MVar
  ( MVar, mkWeakMVar, newEmptyMVar, newMVar, putMVar
  , takeMVar, tryTakeMVar )
import Control.Exception
  ( IOException, SomeException
  , finally, mask_, onException, throw, try, uninterruptibleMask_
  )
import Control.Monad ( void )
import Data.Bits ( xor )
import GHC.Clock ( getMonotonicTimeNSec )
import GHC.Stack ( HasCallStack )

-- directory
import System.Directory ( doesPathExist )

-- stm
import Control.Concurrent.STM
  ( TVar, newTVarIO, readTVarIO )

-- unix
import System.Posix.IO ( closeFd, createPipe, setFdOption, FdOption(CloseOnExec) )
import System.Posix.Files ( removeLink )
import System.Posix.Types ( Fd )
import System.Posix.Process ( getProcessID )

-- semaphore-compat
import System.Semaphore.Internal.Version
import System.Semaphore.Internal.DomainSocket
  ( connectDomainSocket, listenDomainSocket
  , fdReadByte, fdWriteByte
  , fdShutdown )
import System.Semaphore.Internal.Posix.Server
  ( serverLoop
  , pattern CmdWait, pattern CmdTryWait, pattern CmdRelease
  , pattern RspOk, pattern RspFail
  )

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

-- A client is just an identity (name + socket path); each operation that needs
-- a connection opens one internally.
data ClientSemaphore =
  ClientSemaphore
    { ClientSemaphore -> SemaphoreName
clientSemaphoreName :: !SemaphoreName
    , ClientSemaphore -> FilePath
semSocketPath :: !FilePath
    }

-- The fd is held in the 'MVar' so 'releaseSemaphoreToken' takes ownership
-- atomically: a second (erroneous) release is a safe no-op.
newtype SemaphoreToken = SemaphoreToken
  { SemaphoreToken -> MVar Fd
tokenFdLock :: MVar Fd
    -- NB: the 'Fd' is held in an 'MVar' to allow 'releaseSemaphoreToken'
    -- to takes ownership of the 'Fd' atomically. This ensures that a
    -- second (erroneous) release is a safe no-op (avoiding Fd double-close bugs).
  }

data ServerSemaphore = ServerSemaphore
  { ServerSemaphore -> ClientSemaphore
serverClientSemaphore :: !ClientSemaphore
  , ServerSemaphore -> ThreadId
serverThreadId :: !ThreadId
  , ServerSemaphore -> TVar Int
serverPool     :: !(TVar Int)
  , ServerSemaphore -> MVar ServerState
serverState    :: !(MVar ServerState)
      -- NB: the MVar is emptied when resources/fds are freed to prevent double close
  }

data ServerState = ServerState
  { ServerState -> Fd
serverListenFd :: !Fd
  , ServerState -> Fd
serverCancelFd :: !Fd
    -- Write end of the cancel pipe.  Writing a byte signals the
    -- server loop to exit its poll-accept.
  }

create_sem :: SemaphoreName -> Int -> IO (Either SemaphoreError ServerSemaphore)
create_sem :: SemaphoreName -> Int -> IO (Either SemaphoreError ServerSemaphore)
create_sem SemaphoreName
sem_nm Int
init_toks = do
  Either IOException ServerSemaphore
mb_res <- forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (IO ServerSemaphore -> IO (Either IOException ServerSemaphore))
-> IO ServerSemaphore -> IO (Either IOException ServerSemaphore)
forall a b. (a -> b) -> a -> b
$ IO ServerSemaphore -> IO ServerSemaphore
forall a. IO a -> IO a
mask_ (IO ServerSemaphore -> IO ServerSemaphore)
-> IO ServerSemaphore -> IO ServerSemaphore
forall a b. (a -> b) -> a -> b
$ do
    FilePath
socketPath <- SemaphoreName -> IO FilePath
getSemaphoreSocketPath SemaphoreName
sem_nm
    Fd
listenFd <- FilePath -> IO Fd
listenDomainSocket FilePath
socketPath
    -- ^^ creates the socket file, unlink it too on failure.
    let cleanupListen :: IO ()
cleanupListen = do
          IO (Either IOException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ()) -> IO ())
-> IO (Either IOException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ Fd -> IO ()
closeFd Fd
listenFd
          IO (Either IOException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ()) -> IO ())
-> IO (Either IOException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeLink FilePath
socketPath
    (IO ServerSemaphore -> IO () -> IO ServerSemaphore)
-> IO () -> IO ServerSemaphore -> IO ServerSemaphore
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO ServerSemaphore -> IO () -> IO ServerSemaphore
forall a b. IO a -> IO b -> IO a
onException IO ()
cleanupListen (IO ServerSemaphore -> IO ServerSemaphore)
-> IO ServerSemaphore -> IO ServerSemaphore
forall a b. (a -> b) -> a -> b
$ do
      TVar Int
pool <- Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
init_toks
      (Fd
cancelRd, Fd
cancelWr) <- IO (Fd, Fd)
createPipe
      Fd -> FdOption -> Bool -> IO ()
setFdOption Fd
cancelRd FdOption
CloseOnExec Bool
True
      Fd -> FdOption -> Bool -> IO ()
setFdOption Fd
cancelWr FdOption
CloseOnExec Bool
True
      ThreadId
tid <- ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask ->
               IO () -> IO ()
forall a. IO a -> IO a
unmask (TVar Int -> Fd -> Fd -> IO ()
serverLoop TVar Int
pool Fd
listenFd Fd
cancelRd)
                 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Fd -> IO ()
closeFd Fd
cancelRd
      MVar ServerState
stateVar <- ServerState -> IO (MVar ServerState)
forall a. a -> IO (MVar a)
newMVar ServerState
        { serverListenFd :: Fd
serverListenFd = Fd
listenFd
        , serverCancelFd :: Fd
serverCancelFd = Fd
cancelWr
        }
      ServerSemaphore -> IO ServerSemaphore
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ServerSemaphore
        { serverClientSemaphore :: ClientSemaphore
serverClientSemaphore = ClientSemaphore { clientSemaphoreName :: SemaphoreName
clientSemaphoreName = SemaphoreName
sem_nm
                                            , semSocketPath :: FilePath
semSocketPath = FilePath
socketPath }
        , serverThreadId :: ThreadId
serverThreadId  = ThreadId
tid
        , serverPool :: TVar Int
serverPool      = TVar Int
pool
        , serverState :: MVar ServerState
serverState     = MVar ServerState
stateVar
        }
  Either SemaphoreError ServerSemaphore
-> IO (Either SemaphoreError ServerSemaphore)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SemaphoreError ServerSemaphore
 -> IO (Either SemaphoreError ServerSemaphore))
-> Either SemaphoreError ServerSemaphore
-> IO (Either SemaphoreError ServerSemaphore)
forall a b. (a -> b) -> a -> b
$ case Either IOException ServerSemaphore
mb_res of
    Left  IOException
err -> SemaphoreError -> Either SemaphoreError ServerSemaphore
forall a b. a -> Either a b
Left (SemaphoreError -> Either SemaphoreError ServerSemaphore)
-> SemaphoreError -> Either SemaphoreError ServerSemaphore
forall a b. (a -> b) -> a -> b
$ IOException -> SemaphoreError
SemaphoreOtherError IOException
err
    Right ServerSemaphore
sem -> ServerSemaphore -> Either SemaphoreError ServerSemaphore
forall a b. b -> Either a b
Right ServerSemaphore
sem

open_sem_raw :: SemaphoreName -> IO (Either SemaphoreError ClientSemaphore)
open_sem_raw :: SemaphoreName -> IO (Either SemaphoreError ClientSemaphore)
open_sem_raw SemaphoreName
nm = do
  Either IOException (FilePath, Bool)
mb_res <- forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (IO (FilePath, Bool) -> IO (Either IOException (FilePath, Bool)))
-> IO (FilePath, Bool) -> IO (Either IOException (FilePath, Bool))
forall a b. (a -> b) -> a -> b
$ do
    FilePath
socketPath <- SemaphoreName -> IO FilePath
getSemaphoreSocketPath SemaphoreName
nm
    Bool
exists <- FilePath -> IO Bool
doesPathExist FilePath
socketPath
    (FilePath, Bool) -> IO (FilePath, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
socketPath, Bool
exists)
  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
$ case Either IOException (FilePath, Bool)
mb_res of
    Left  IOException
err             -> 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
$ IOException -> SemaphoreError
SemaphoreOtherError IOException
err
    Right (FilePath
_, Bool
False)      -> 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
$ FilePath -> SemaphoreError
SemaphoreDoesNotExist (SemaphoreName -> FilePath
semaphoreIdentifier SemaphoreName
nm)
    Right (FilePath
socketPath, Bool
_) -> ClientSemaphore -> Either SemaphoreError ClientSemaphore
forall a b. b -> Either a b
Right (ClientSemaphore -> Either SemaphoreError ClientSemaphore)
-> ClientSemaphore -> Either SemaphoreError ClientSemaphore
forall a b. (a -> b) -> a -> b
$
      ClientSemaphore
        { clientSemaphoreName :: SemaphoreName
clientSemaphoreName = SemaphoreName
nm
        , semSocketPath :: FilePath
semSocketPath = FilePath
socketPath
        }

waitOnSemaphore :: HasCallStack => ClientSemaphore -> IO SemaphoreToken
waitOnSemaphore :: HasCallStack => ClientSemaphore -> IO SemaphoreToken
waitOnSemaphore ClientSemaphore
sem = do
  MVar (Either SomeException Word8)
resultVar <- IO (MVar (Either SomeException Word8))
forall a. IO (MVar a)
newEmptyMVar
  -- Mask exceptions until we get to the interruptible takeMVar
  IO SemaphoreToken -> IO SemaphoreToken
forall a. IO a -> IO a
mask_ (IO SemaphoreToken -> IO SemaphoreToken)
-> IO SemaphoreToken -> IO SemaphoreToken
forall a b. (a -> b) -> a -> b
$ do
    Fd
fd <- FilePath -> IO Fd
connectDomainSocket (ClientSemaphore -> FilePath
semSocketPath ClientSemaphore
sem)
    -- The read() runs in a forked thread
    ThreadId
workerTid <- ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
_ -> do
      Either SomeException Word8
res <- forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (IO Word8 -> IO (Either SomeException Word8))
-> IO Word8 -> IO (Either SomeException Word8)
forall a b. (a -> b) -> a -> b
$ do
        HasCallStack => Fd -> Word8 -> IO ()
Fd -> Word8 -> IO ()
fdWriteByte Fd
fd Word8
CmdWait
        HasCallStack => Fd -> IO Word8
Fd -> IO Word8
fdReadByte Fd
fd
      MVar (Either SomeException Word8)
-> Either SomeException Word8 -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException Word8)
resultVar Either SomeException Word8
res
    -- uninterruptibleMask_: killThread is interruptible, and a
    -- second async between killThread and closeFd would leak fd.
    let cleanup :: IO ()
cleanup = IO () -> IO ()
forall a. IO a -> IO a
uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          -- shutdown(SHUT_RDWR) causes the worker's read() to return EOF immediately
          IO (Either IOException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ()) -> IO ())
-> IO (Either IOException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ Fd -> IO ()
fdShutdown Fd
fd
          -- Wait for the worker to exit before closing the fd.
          -- this prevents double close bugs
          ThreadId -> IO ()
killThread ThreadId
workerTid
          -- Finally close the fd
          IO (Either IOException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ()) -> IO ())
-> IO (Either IOException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ Fd -> IO ()
closeFd Fd
fd
    -- We achieve interruptiblity by relying on the interruptiblity of takeMVar
    -- The worker thread is blocked on read(), fdShutdown in cleanup interrupts
    -- it if we are interrupt by an async exception here.
    Either SomeException Word8
res <- MVar (Either SomeException Word8)
-> IO (Either SomeException Word8)
forall a. MVar a -> IO a
takeMVar MVar (Either SomeException Word8)
resultVar IO (Either SomeException Word8)
-> IO () -> IO (Either SomeException Word8)
forall a b. IO a -> IO b -> IO a
`onException` IO ()
cleanup
    case Either SomeException Word8
res of
      Right Word8
resp
        | Word8
resp Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
RspOk -> Fd -> IO SemaphoreToken
mkToken Fd
fd
        | Bool
otherwise     -> do IO (Either IOException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ()) -> IO ())
-> IO (Either IOException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ Fd -> IO ()
closeFd Fd
fd
                              FilePath -> IO SemaphoreToken
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO SemaphoreToken) -> FilePath -> IO SemaphoreToken
forall a b. (a -> b) -> a -> b
$ FilePath
"semaphore-compat: unexpected response in waitOnSemaphore: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Word8 -> FilePath
forall a. Show a => a -> FilePath
show Word8
resp
      Left SomeException
e            -> do IO (Either IOException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ()) -> IO ())
-> IO (Either IOException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ Fd -> IO ()
closeFd Fd
fd
                              SomeException -> IO SemaphoreToken
forall a e. Exception e => e -> a
throw SomeException
e

tryWaitOnSemaphore :: HasCallStack => ClientSemaphore -> IO (Maybe SemaphoreToken)
tryWaitOnSemaphore :: HasCallStack => ClientSemaphore -> IO (Maybe SemaphoreToken)
tryWaitOnSemaphore ClientSemaphore
sem =
  IO (Maybe SemaphoreToken) -> IO (Maybe SemaphoreToken)
forall a. IO a -> IO a
mask_ (IO (Maybe SemaphoreToken) -> IO (Maybe SemaphoreToken))
-> IO (Maybe SemaphoreToken) -> IO (Maybe SemaphoreToken)
forall a b. (a -> b) -> a -> b
$ do
    Fd
fd <- FilePath -> IO Fd
connectDomainSocket (ClientSemaphore -> FilePath
semSocketPath ClientSemaphore
sem)
    Word8
resp <- (IO Word8 -> IO () -> IO Word8) -> IO () -> IO Word8 -> IO Word8
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO Word8 -> IO () -> IO Word8
forall a b. IO a -> IO b -> IO a
onException (Fd -> IO ()
closeFd Fd
fd) (IO Word8 -> IO Word8) -> IO Word8 -> IO Word8
forall a b. (a -> b) -> a -> b
$ do
      HasCallStack => Fd -> Word8 -> IO ()
Fd -> Word8 -> IO ()
fdWriteByte Fd
fd Word8
CmdTryWait
      HasCallStack => Fd -> IO Word8
Fd -> IO Word8
fdReadByte Fd
fd
    case Word8
resp of
      Word8
RspOk -> SemaphoreToken -> Maybe SemaphoreToken
forall a. a -> Maybe a
Just (SemaphoreToken -> Maybe SemaphoreToken)
-> IO SemaphoreToken -> IO (Maybe SemaphoreToken)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fd -> IO SemaphoreToken
mkToken Fd
fd
      Word8
_     -> do IO (Either IOException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ()) -> IO ())
-> IO (Either IOException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ Fd -> IO ()
closeFd Fd
fd
                  Maybe SemaphoreToken -> IO (Maybe SemaphoreToken)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemaphoreToken
forall a. Maybe a
Nothing

mkToken :: Fd -> IO SemaphoreToken
mkToken :: Fd -> IO SemaphoreToken
mkToken Fd
fd = do
  MVar Fd
fdVar <- Fd -> IO (MVar Fd)
forall a. a -> IO (MVar a)
newMVar Fd
fd
  Weak (MVar Fd)
_ <- MVar Fd -> IO () -> IO (Weak (MVar Fd))
forall a. MVar a -> IO () -> IO (Weak (MVar a))
mkWeakMVar MVar Fd
fdVar (IO () -> IO (Weak (MVar Fd))) -> IO () -> IO (Weak (MVar Fd))
forall a b. (a -> b) -> a -> b
$ do
    Maybe Fd
mb <- MVar Fd -> IO (Maybe Fd)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar Fd
fdVar
    case Maybe Fd
mb of
      Maybe Fd
Nothing  -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()       -- already released
      -- Closing the fd triggers the server's disconnect handling,
      -- which returns the token to the pool.
      Just Fd
fd' -> IO (Either IOException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ()) -> IO ())
-> IO (Either IOException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ Fd -> IO ()
closeFd Fd
fd'
  SemaphoreToken -> IO SemaphoreToken
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar Fd -> SemaphoreToken
SemaphoreToken MVar Fd
fdVar)

releaseSemaphoreToken :: HasCallStack => SemaphoreToken -> IO ()
releaseSemaphoreToken :: HasCallStack => SemaphoreToken -> IO ()
releaseSemaphoreToken (SemaphoreToken MVar Fd
fdVar) =
  IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe Fd
mb <- MVar Fd -> IO (Maybe Fd)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar Fd
fdVar
    case Maybe Fd
mb of
      Maybe Fd
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- already released
      Just Fd
fd -> do
        Word8
resp <- (do HasCallStack => Fd -> Word8 -> IO ()
Fd -> Word8 -> IO ()
fdWriteByte Fd
fd Word8
CmdRelease
                    HasCallStack => Fd -> IO Word8
Fd -> IO Word8
fdReadByte Fd
fd
                ) IO Word8 -> IO () -> IO Word8
forall a b. IO a -> IO b -> IO a
`finally` (IO (Either IOException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ()) -> IO ())
-> IO (Either IOException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ Fd -> IO ()
closeFd Fd
fd)
        case Word8
resp of
          Word8
RspOk   -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          -- myCount <= 0 on the server means the token is effectively
          -- already released; stay idempotent.
          Word8
RspFail -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Word8
_       -> FilePath -> IO ()
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"semaphore-compat: unexpected response in releaseSemaphoreToken"

-- On POSIX this is a no-op: 'ClientSemaphore' holds no live connection.
destroyClientSemaphore :: ClientSemaphore -> IO ()
destroyClientSemaphore :: ClientSemaphore -> IO ()
destroyClientSemaphore ClientSemaphore
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

destroyServerSemaphore :: ServerSemaphore -> IO ()
destroyServerSemaphore :: ServerSemaphore -> IO ()
destroyServerSemaphore ServerSemaphore
server = IO () -> IO ()
forall a. IO a -> IO a
uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  -- we justify the uninterruptibleMask_ here by analysis of the server, which must exit
  -- in a bounded amount of time once it receives the cancel signal on serverCancelFd
  -- It has a bounded number of child threads it needs to cleanup before returning,
  -- but otherwise it should exit promptly.
  --
  -- Without uninterruptibleMask_, we potentially leak serverListenFd and path if an
  -- exception arrives when we are in `killThread`.
  Maybe ServerState
mbState <- MVar ServerState -> IO (Maybe ServerState)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar (ServerSemaphore -> MVar ServerState
serverState ServerSemaphore
server)
  case Maybe ServerState
mbState of
    Maybe ServerState
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- already destroyed
    Just ServerState{Fd
serverListenFd :: ServerState -> Fd
serverCancelFd :: ServerState -> Fd
serverListenFd :: Fd
serverCancelFd :: Fd
..} -> do
      let path :: FilePath
path = ClientSemaphore -> FilePath
semSocketPath (ClientSemaphore -> FilePath) -> ClientSemaphore -> FilePath
forall a b. (a -> b) -> a -> b
$ ServerSemaphore -> ClientSemaphore
serverClientSemaphore ServerSemaphore
server
      -- Signal the server loop to exit pollAcceptSocket, then wait for it.
      IO (Either IOException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ()) -> IO ())
-> IO (Either IOException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ HasCallStack => Fd -> Word8 -> IO ()
Fd -> Word8 -> IO ()
fdWriteByte Fd
serverCancelFd Word8
0
      IO (Either IOException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ()) -> IO ())
-> IO (Either IOException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ Fd -> IO ()
closeFd Fd
serverCancelFd
      ThreadId -> IO ()
killThread (ServerSemaphore -> ThreadId
serverThreadId ServerSemaphore
server)
      IO (Either IOException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ()) -> IO ())
-> IO (Either IOException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ Fd -> IO ()
closeFd Fd
serverListenFd
      IO (Either IOException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ()) -> IO ())
-> IO (Either IOException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeLink FilePath
path

getSemaphoreValue :: ServerSemaphore -> IO Int
getSemaphoreValue :: ServerSemaphore -> IO Int
getSemaphoreValue ServerSemaphore
server = TVar Int -> IO Int
forall a. TVar a -> IO a
readTVarIO (ServerSemaphore -> TVar Int
serverPool ServerSemaphore
server)

get_time_seed :: IO Int
get_time_seed :: IO Int
get_time_seed = do
  Word64
ns <- IO Word64
getMonotonicTimeNSec
  ProcessID
pid <- IO ProcessID
getProcessID
  Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ns Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor` ProcessID -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ProcessID
pid