{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Hercules.CNix.Util
( setInterruptThrown,
triggerInterrupt,
installDefaultSigINTHandler,
createInterruptCallback,
)
where
import Hercules.CNix.Store.Context
( context,
)
import qualified Language.C.Inline.Cpp as C
import qualified Language.C.Inline.Cpp.Exception as C
import Protolude
import System.Mem.Weak (deRefWeak)
import System.Posix (Handler (Catch), installHandler, sigHUP, sigINT, sigTERM, sigUSR1)
import Prelude ()
C.context context
C.include "<nix/config.h>"
C.include "<nix/util.hh>"
C.using "namespace nix"
setInterruptThrown :: IO ()
setInterruptThrown :: IO ()
setInterruptThrown =
[C.throwBlock| void {
nix::setInterruptThrown();
} |]
triggerInterrupt :: IO ()
triggerInterrupt :: IO ()
triggerInterrupt =
[C.throwBlock| void {
nix::triggerInterrupt();
} |]
installDefaultSigINTHandler :: IO ()
installDefaultSigINTHandler :: IO ()
installDefaultSigINTHandler = do
ThreadId
mainThread <- IO ThreadId
myThreadId
Weak ThreadId
weakId <- ThreadId -> IO (Weak ThreadId)
mkWeakThreadId ThreadId
mainThread
let defaultHaskellHandler :: IO ()
defaultHaskellHandler = do
Maybe ThreadId
mt <- Weak ThreadId -> IO (Maybe ThreadId)
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak ThreadId
weakId
Maybe ThreadId -> (ThreadId -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe ThreadId
mt \ThreadId
t -> do
ThreadId -> SomeException -> IO ()
forall (m :: * -> *) e.
(MonadIO m, Exception e) =>
ThreadId -> e -> m ()
throwTo ThreadId
t (AsyncException -> SomeException
forall e. Exception e => e -> SomeException
toException AsyncException
UserInterrupt)
[Handler]
_oldHandler <-
[CInt] -> (CInt -> IO Handler) -> IO [Handler]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [CInt
sigINT, CInt
sigTERM, CInt
sigHUP] \CInt
sig ->
CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler
CInt
sig
( IO () -> Handler
Catch do
IO ()
triggerInterrupt
IO ()
defaultHaskellHandler
)
Maybe SignalSet
forall a. Maybe a
Nothing
Handler
_oldHandler <-
CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler
CInt
sigUSR1
(
IO () -> Handler
Catch IO ()
forall (f :: * -> *). Applicative f => f ()
pass
)
Maybe SignalSet
forall a. Maybe a
Nothing
IO () -> IO ()
createInterruptCallback IO ()
defaultHaskellHandler
createInterruptCallback :: IO () -> IO ()
createInterruptCallback :: IO () -> IO ()
createInterruptCallback IO ()
onInterrupt = do
FunPtr (IO ())
onInterruptPtr <- IO () -> IO (FunPtr (IO ()))
mkCallback IO ()
onInterrupt
[C.throwBlock| void {
nix::createInterruptCallback($(void (*onInterruptPtr)()));
} |]
#ifndef __GHCIDE__
foreign import ccall "wrapper"
mkCallback :: IO () -> IO (FunPtr (IO ()))
#else
mkCallback :: IO () -> IO (FunPtr (IO ()))
mkCallback = panic "This is a stub to work around a ghcide issue. Please compile without -D__GHCIDE__"
#endif