{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Functions calling Nix's libutil
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>"

#if NIX_IS_AT_LEAST(2,19,0)
C.include "<nix/signals.hh>"
#endif

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)

  -- Install Nix interrupter in Haskell
  [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

  -- Install dummy SIGUSR1 handler for Nix interrupt signal propagation
  -- (installHandler uses process-wide sigprocmask, so this should apply to all
  -- capability threads, as required for Nix)
  Handler
_oldHandler <-
    CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler
      CInt
sigUSR1
      ( -- Not Ignore, because we want to cause EINTR
        IO () -> Handler
Catch IO ()
forall (f :: * -> *). Applicative f => f ()
pass
      )
      Maybe SignalSet
forall a. Maybe a
Nothing

  -- Install Haskell interrupter in Nix
  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
  -- leaks onInterruptPtr
  [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