{-# LANGUAGE CPP #-}

-- | Process-wide POSIX signal subscriptions. No Unison code runs in an OS
-- signal handler: the RTS schedules a Haskell action which publishes to STM.
module Unison.Runtime.Signal
  ( Signal,
    Subscription,
    available,
    subscribe,
    await,
    close,
  )
where

import Control.Concurrent.STM qualified as STM
import Control.Exception (throwIO)
import Data.Unique (Unique)

#if !defined(mingw32_HOST_OS)
import Control.Concurrent.MVar
import Control.Exception (mask_, onException, uninterruptibleMask_)
import Control.Monad (forM, forM_, unless, when)
import Data.Map.Strict qualified as Map
import Data.Unique (newUnique)
import Foreign.C.Error (throwErrnoIfMinus1_, throwErrnoIfNull)
import Foreign.C.Types (CInt (..))
import Foreign.C.String (CString, peekCString)
import Foreign.Marshal.Alloc (free)
import Foreign.Ptr (Ptr)
import System.IO.Unsafe (unsafePerformIO)
import System.Posix.Signals qualified as Posix
#endif

newtype Signal = Signal Int deriving (Signal -> Signal -> Bool
(Signal -> Signal -> Bool)
-> (Signal -> Signal -> Bool) -> Eq Signal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Signal -> Signal -> Bool
== :: Signal -> Signal -> Bool
$c/= :: Signal -> Signal -> Bool
/= :: Signal -> Signal -> Bool
Eq, Eq Signal
Eq Signal =>
(Signal -> Signal -> Ordering)
-> (Signal -> Signal -> Bool)
-> (Signal -> Signal -> Bool)
-> (Signal -> Signal -> Bool)
-> (Signal -> Signal -> Bool)
-> (Signal -> Signal -> Signal)
-> (Signal -> Signal -> Signal)
-> Ord Signal
Signal -> Signal -> Bool
Signal -> Signal -> Ordering
Signal -> Signal -> Signal
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Signal -> Signal -> Ordering
compare :: Signal -> Signal -> Ordering
$c< :: Signal -> Signal -> Bool
< :: Signal -> Signal -> Bool
$c<= :: Signal -> Signal -> Bool
<= :: Signal -> Signal -> Bool
$c> :: Signal -> Signal -> Bool
> :: Signal -> Signal -> Bool
$c>= :: Signal -> Signal -> Bool
>= :: Signal -> Signal -> Bool
$cmax :: Signal -> Signal -> Signal
max :: Signal -> Signal -> Signal
$cmin :: Signal -> Signal -> Signal
min :: Signal -> Signal -> Signal
Ord)

-- The registration retains only the notification cell, not this handle.
-- Nothing means closed; Just True means at least one notification is pending.
data Subscription = Subscription !Signal !Unique !(STM.TVar (Maybe Bool))

instance Eq Subscription where
  Subscription Signal
_ Unique
a TVar (Maybe Bool)
_ == :: Subscription -> Subscription -> Bool
== Subscription Signal
_ Unique
b TVar (Maybe Bool)
_ = Unique
a Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
b

instance Ord Subscription where
  compare :: Subscription -> Subscription -> Ordering
compare (Subscription Signal
_ Unique
a TVar (Maybe Bool)
_) (Subscription Signal
_ Unique
b TVar (Maybe Bool)
_) = Unique -> Unique -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Unique
a Unique
b

await :: Subscription -> IO ()
await :: Subscription -> IO ()
await (Subscription Signal
_ Unique
_ TVar (Maybe Bool)
pending) = STM () -> IO ()
forall a. STM a -> IO a
STM.atomically do
  TVar (Maybe Bool) -> STM (Maybe Bool)
forall a. TVar a -> STM a
STM.readTVar TVar (Maybe Bool)
pending STM (Maybe Bool) -> (Maybe Bool -> STM ()) -> STM ()
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Bool
Nothing -> IOError -> STM ()
forall e a. Exception e => e -> STM a
STM.throwSTM (String -> IOError
userError String
"Signal subscription is closed")
    Just Bool
False -> STM ()
forall a. STM a
STM.retry
    Just Bool
True -> TVar (Maybe Bool) -> Maybe Bool -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar (Maybe Bool)
pending (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)

#if defined(mingw32_HOST_OS)

available :: [(String, Signal)]
available = []

subscribe :: Signal -> IO Subscription
subscribe _ = throwIO (userError "POSIX signal subscriptions are not supported on Windows")

close :: Subscription -> IO ()
close _ = pure ()

#else

data Registration = Registration
  { Registration -> Handler
previousHandler :: !Posix.Handler,
    Registration -> Ptr ()
previousAction :: !(Ptr ()),
    Registration -> TVar (Map Unique (TVar (Maybe Bool)))
listeners :: !(STM.TVar (Map.Map Unique (STM.TVar (Maybe Bool))))
  }

-- Separate registrations per installation prevent an already queued callback
-- from an old installation from reaching a later generation of subscribers.
{-# NOINLINE registrations #-}
registrations :: MVar (Map.Map Signal Registration)
registrations :: MVar (Map Signal Registration)
registrations = IO (MVar (Map Signal Registration))
-> MVar (Map Signal Registration)
forall a. IO a -> a
unsafePerformIO (Map Signal Registration -> IO (MVar (Map Signal Registration))
forall a. a -> IO (MVar a)
newMVar Map Signal Registration
forall k a. Map k a
Map.empty)

-- Synchronous hardware faults cannot be delivered safely as asynchronous
-- notifications. SIGPIPE is used by GHC to interrupt blocking foreign calls;
-- the RTS timer signal is excluded through reservedSignals as well.
-- Real-time signals (queued payloads and ordering) need a different contract.
available :: [(String, Signal)]
available :: [(String, Signal)]
available = IO [(String, Signal)] -> [(String, Signal)]
forall a. IO a -> a
unsafePerformIO do
  CInt
count <- IO CInt
signalCount
  [(String, CInt)]
entries <- [CInt] -> (CInt -> IO (String, CInt)) -> IO [(String, CInt)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CInt
0 .. CInt
count CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
- CInt
1] \CInt
index -> do
    String
name <- CString -> IO String
peekCString (CString -> IO String) -> IO CString -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CInt -> IO CString
signalName CInt
index
    CInt
number <- CInt -> IO CInt
signalNumber CInt
index
    pure (String
name, CInt
number)
  pure
    [ (String
name, Int -> Signal
Signal (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
number))
      | (String
name, CInt
number) <- [(String, CInt)]
entries,
        Bool -> Bool
not (CInt -> SignalSet -> Bool
Posix.inSignalSet CInt
number SignalSet
Posix.reservedSignals)
    ]
{-# NOINLINE available #-}

subscribe :: Signal -> IO Subscription
subscribe :: Signal -> IO Subscription
subscribe signal :: Signal
signal@(Signal Int
number) = IO Subscription -> IO Subscription
forall a. IO a -> IO a
mask_ do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Signal
signal Signal -> [Signal] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((String, Signal) -> Signal) -> [(String, Signal)] -> [Signal]
forall a b. (a -> b) -> [a] -> [b]
map (String, Signal) -> Signal
forall a b. (a, b) -> b
snd [(String, Signal)]
available) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    IOError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (String -> IOError
userError String
"Unsupported POSIX signal")
  Unique
ident <- IO Unique
newUnique
  TVar (Maybe Bool)
pending <- Maybe Bool -> IO (TVar (Maybe Bool))
forall a. a -> IO (TVar a)
STM.newTVarIO (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
  MVar (Map Signal Registration)
-> (Map Signal Registration -> IO (Map Signal Registration))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map Signal Registration)
registrations \Map Signal Registration
table -> do
    Registration
registration <- case Signal -> Map Signal Registration -> Maybe Registration
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Signal
signal Map Signal Registration
table of
      Just Registration
registration -> Registration -> IO Registration
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Registration
registration
      Maybe Registration
Nothing -> do
        TVar (Map Unique (TVar (Maybe Bool)))
listeners <- Map Unique (TVar (Maybe Bool))
-> IO (TVar (Map Unique (TVar (Maybe Bool))))
forall a. a -> IO (TVar a)
STM.newTVarIO Map Unique (TVar (Maybe Bool))
forall k a. Map k a
Map.empty
        Ptr ()
saved <- String -> IO (Ptr ()) -> IO (Ptr ())
forall a. String -> IO (Ptr a) -> IO (Ptr a)
throwErrnoIfNull String
"save signal handler" (CInt -> IO (Ptr ())
saveAction (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
number))
        Handler
previous <-
          CInt -> Handler -> Maybe SignalSet -> IO Handler
Posix.installHandler (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
number) (IO () -> Handler
Posix.Catch (TVar (Map Unique (TVar (Maybe Bool))) -> IO ()
notify TVar (Map Unique (TVar (Maybe Bool)))
listeners)) Maybe SignalSet
forall a. Maybe a
Nothing
            IO Handler -> IO () -> IO Handler
forall a b. IO a -> IO b -> IO a
`onException` Ptr () -> IO ()
forall a. Ptr a -> IO ()
free Ptr ()
saved
        pure (Handler
-> Ptr () -> TVar (Map Unique (TVar (Maybe Bool))) -> Registration
Registration Handler
previous Ptr ()
saved TVar (Map Unique (TVar (Maybe Bool)))
listeners)
    STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map Unique (TVar (Maybe Bool)))
-> (Map Unique (TVar (Maybe Bool))
    -> Map Unique (TVar (Maybe Bool)))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
STM.modifyTVar' (Registration -> TVar (Map Unique (TVar (Maybe Bool)))
listeners Registration
registration) (Unique
-> TVar (Maybe Bool)
-> Map Unique (TVar (Maybe Bool))
-> Map Unique (TVar (Maybe Bool))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Unique
ident TVar (Maybe Bool)
pending)
    pure (Signal
-> Registration
-> Map Signal Registration
-> Map Signal Registration
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Signal
signal Registration
registration Map Signal Registration
table)
  pure (Signal -> Unique -> TVar (Maybe Bool) -> Subscription
Subscription Signal
signal Unique
ident TVar (Maybe Bool)
pending)

notify :: STM.TVar (Map.Map Unique (STM.TVar (Maybe Bool))) -> IO ()
notify :: TVar (Map Unique (TVar (Maybe Bool))) -> IO ()
notify TVar (Map Unique (TVar (Maybe Bool)))
listeners = STM () -> IO ()
forall a. STM a -> IO a
STM.atomically do
  Map Unique (TVar (Maybe Bool))
cells <- TVar (Map Unique (TVar (Maybe Bool)))
-> STM (Map Unique (TVar (Maybe Bool)))
forall a. TVar a -> STM a
STM.readTVar TVar (Map Unique (TVar (Maybe Bool)))
listeners
  Map Unique (TVar (Maybe Bool))
-> (TVar (Maybe Bool) -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Map Unique (TVar (Maybe Bool))
cells \TVar (Maybe Bool)
pending -> TVar (Maybe Bool) -> Maybe Bool -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar (Maybe Bool)
pending (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)

close :: Subscription -> IO ()
close :: Subscription -> IO ()
close (Subscription signal :: Signal
signal@(Signal Int
number) Unique
ident TVar (Maybe Bool)
pending) = IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
  MVar (Map Signal Registration)
-> (Map Signal Registration -> IO (Map Signal Registration))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map Signal Registration)
registrations \Map Signal Registration
table -> case Signal -> Map Signal Registration -> Maybe Registration
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Signal
signal Map Signal Registration
table of
    Maybe Registration
Nothing -> Map Signal Registration -> IO (Map Signal Registration)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Signal Registration
table
    Just Registration
registration -> do
      Map Unique (TVar (Maybe Bool))
cells <- TVar (Map Unique (TVar (Maybe Bool)))
-> IO (Map Unique (TVar (Maybe Bool)))
forall a. TVar a -> IO a
STM.readTVarIO (Registration -> TVar (Map Unique (TVar (Maybe Bool)))
listeners Registration
registration)
      if Unique -> Map Unique (TVar (Maybe Bool)) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember Unique
ident Map Unique (TVar (Maybe Bool))
cells
        then Map Signal Registration -> IO (Map Signal Registration)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Signal Registration
table
        else do
          let remaining :: Map Unique (TVar (Maybe Bool))
remaining = Unique
-> Map Unique (TVar (Maybe Bool)) -> Map Unique (TVar (Maybe Bool))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Unique
ident Map Unique (TVar (Maybe Bool))
cells
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Map Unique (TVar (Maybe Bool)) -> Bool
forall k a. Map k a -> Bool
Map.null Map Unique (TVar (Maybe Bool))
remaining) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
uninterruptibleMask_ do
            -- Restore the Haskell handler table and then the complete native
            -- action, including flags and mask which unix does not preserve.
            -- GHC can report Default even when a native handler was installed.
            -- Do not briefly install SIG_DFL: a signal arriving before the
            -- native action is restored could terminate the process. Ignore
            -- clears GHC's handler bookkeeping without that unsafe interval;
            -- restoreAction installs the actual original disposition below.
            -- installHandler can wait for GHC's internal handler-table lock
            -- after changing the native disposition, so defer cancellation
            -- across this short transition (which never runs user code).
            Handler
handler <- case Registration -> Handler
previousHandler Registration
registration of
              Handler
Posix.Default -> do
                CInt
isDefault <- Ptr () -> IO CInt
savedActionIsDefault (Registration -> Ptr ()
previousAction Registration
registration)
                -- Preserve Default in GHC's bookkeeping when it really was
                -- the native disposition, so later installHandler callers
                -- receive the correct previous handler.
                pure if CInt
isDefault CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0 then Handler
Posix.Default else Handler
Posix.Ignore
              Handler
previous -> Handler -> IO Handler
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handler
previous
            Handler
_ <- CInt -> Handler -> Maybe SignalSet -> IO Handler
Posix.installHandler (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
number) Handler
handler Maybe SignalSet
forall a. Maybe a
Nothing
            String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ String
"restore signal handler" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$
              CInt -> Ptr () -> IO CInt
restoreAction (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
number) (Registration -> Ptr ()
previousAction Registration
registration)
            Ptr () -> IO ()
forall a. Ptr a -> IO ()
free (Registration -> Ptr ()
previousAction Registration
registration)
          STM () -> IO ()
forall a. STM a -> IO a
STM.atomically do
            TVar (Maybe Bool) -> Maybe Bool -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar (Maybe Bool)
pending Maybe Bool
forall a. Maybe a
Nothing
            TVar (Map Unique (TVar (Maybe Bool)))
-> Map Unique (TVar (Maybe Bool)) -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar (Registration -> TVar (Map Unique (TVar (Maybe Bool)))
listeners Registration
registration) Map Unique (TVar (Maybe Bool))
remaining
          pure if Map Unique (TVar (Maybe Bool)) -> Bool
forall k a. Map k a -> Bool
Map.null Map Unique (TVar (Maybe Bool))
remaining then Signal -> Map Signal Registration -> Map Signal Registration
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Signal
signal Map Signal Registration
table else Map Signal Registration
table

foreign import ccall unsafe "unison_signal_save"
  saveAction :: CInt -> IO (Ptr ())

foreign import ccall unsafe "unison_signal_restore"
  restoreAction :: CInt -> Ptr () -> IO CInt

foreign import ccall unsafe "unison_signal_is_default"
  savedActionIsDefault :: Ptr () -> IO CInt

foreign import ccall unsafe "unison_signal_count"
  signalCount :: IO CInt

foreign import ccall unsafe "unison_signal_name"
  signalName :: CInt -> IO CString

foreign import ccall unsafe "unison_signal_number"
  signalNumber :: CInt -> IO CInt

#endif