{-# 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
  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
    socketPath <- SemaphoreName -> IO FilePath
getSemaphoreSocketPath SemaphoreName
sem_nm
    listenFd <- listenDomainSocket socketPath
    -- ^^ creates the socket file, unlink it too on failure.
    let 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
    flip onException cleanupListen $ do
      pool <- newTVarIO init_toks
      (cancelRd, cancelWr) <- createPipe
      setFdOption cancelRd CloseOnExec True
      setFdOption cancelWr CloseOnExec True
      tid <- forkIOWithUnmask $ \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
      stateVar <- newMVar ServerState
        { serverListenFd = listenFd
        , serverCancelFd = cancelWr
        }
      return ServerSemaphore
        { serverClientSemaphore = ClientSemaphore { clientSemaphoreName = sem_nm
                                            , semSocketPath = socketPath }
        , serverThreadId  = tid
        , serverPool      = pool
        , serverState     = stateVar
        }
  return $ case 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
  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
    socketPath <- SemaphoreName -> IO FilePath
getSemaphoreSocketPath SemaphoreName
nm
    exists <- doesPathExist socketPath
    return (socketPath, exists)
  return $ case 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
  resultVar <- IO (MVar (Either SomeException Word8))
forall a. IO (MVar a)
newEmptyMVar
  -- Mask exceptions until we get to the interruptible takeMVar
  mask_ $ do
    fd <- connectDomainSocket (semSocketPath sem)
    -- The read() runs in a forked thread
    workerTid <- forkIOWithUnmask $ \forall a. IO a -> IO a
_ -> do
      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
      putMVar resultVar res
    -- uninterruptibleMask_: killThread is interruptible, and a
    -- second async between killThread and closeFd would leak fd.
    let 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.
    res <- takeMVar resultVar `onException` cleanup
    case 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. (HasCallStack, 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 <- FilePath -> IO Fd
connectDomainSocket (ClientSemaphore -> FilePath
semSocketPath ClientSemaphore
sem)
    resp <- flip onException (closeFd fd) $ do
      fdWriteByte fd CmdTryWait
      fdReadByte fd
    case 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
  fdVar <- Fd -> IO (MVar Fd)
forall a. a -> IO (MVar a)
newMVar Fd
fd
  _ <- mkWeakMVar fdVar $ do
    mb <- tryTakeMVar fdVar
    case 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'
  return (SemaphoreToken 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
    mb <- MVar Fd -> IO (Maybe Fd)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar Fd
fdVar
    case 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
        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 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`.
  mbState <- MVar ServerState -> IO (Maybe ServerState)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar (ServerSemaphore -> MVar ServerState
serverState ServerSemaphore
server)
  case 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
  ns <- IO Word64
getMonotonicTimeNSec
  pid <- getProcessID
  return $ fromIntegral ns `xor` fromIntegral pid