Implement POSIX timer for CLOCK_BOOTTIME

Co-authored-by: Jan Beinke <git@janbeinke.com>

.ghci

+:set -fobject-code

quasar.cabal

@@ -97,6 +97,7 @@ library
     Quasar.ResourceManager
     Quasar.Subscribable
     Quasar.Timer
+    Quasar.Timer.PosixTimer
     Quasar.Utils.Exceptions
     Quasar.Utils.ExtraT
   hs-source-dirs:

src/Quasar/Timer/PosixTimer.hsc

+{-# LANGUAGE CApiFFI #-}
+
+module Quasar.Timer.PosixTimer (
+  CTimeSpec,
+  CITimerSpec,
+  boottime,
+) where
+
+import Control.Concurrent
+import Foreign
+import Foreign.C
+import Quasar.Disposable
+import Quasar.Prelude
+import System.Posix.Types
+
+#include <signal.h>
+#include <time.h>
+
+foreign import capi "signal.h value SIGEV_THREAD"
+  c_SIGEV_THREAD :: CInt
+
+data CSigEvent = CSigEventThreadCallback (FunPtr SigevNotifyFunction)
+
+instance Storable CSigEvent where
+  sizeOf _ = #size struct sigevent
+  alignment _ = #alignment struct sigevent
+  peek _ = fail "Cannot peek SigEvent"
+  poke ptr (CSigEventThreadCallback funPtr) = do
+    #{poke struct sigevent, sigev_notify} ptr c_SIGEV_THREAD
+    #{poke struct sigevent, sigev_notify_function} ptr funPtr
+
+
+foreign import ccall "wrapper"
+  mkSigevNotifyFunction :: SigevNotifyFunction -> IO (FunPtr SigevNotifyFunction)
+
+type SigevNotifyFunction = (Ptr Void -> IO ())
+
+
+
+data {-# CTYPE "struct timespec" #-} CTimeSpec = CTimeSpec {
+  tv_sec :: CTime,
+  tv_nsec :: CLong
+}
+
+instance Storable CTimeSpec where
+  sizeOf _ = #size struct timespec
+  alignment _ = #alignment struct timespec
+  peek ptr = do
+    tv_sec <- #{peek struct timespec, tv_sec} ptr
+    tv_nsec <- #{peek struct timespec, tv_nsec} ptr
+    pure CTimeSpec {
+      tv_sec,
+      tv_nsec
+    }
+  poke ptr CTimeSpec{tv_sec, tv_nsec} = do
+    #{poke struct timespec, tv_sec} ptr tv_sec
+    #{poke struct timespec, tv_nsec} ptr tv_nsec
+
+defaultCTimeSpec :: CTimeSpec
+defaultCTimeSpec = CTimeSpec 0 0
+
+data {-# CTYPE "struct itimerspec" #-} CITimerSpec = CITimerSpec {
+  it_interval :: CTimeSpec,
+  it_value :: CTimeSpec
+}
+
+instance Storable CITimerSpec where
+  sizeOf _ = #size struct itimerspec
+  alignment _ = #alignment struct itimerspec
+  peek ptr = do
+    it_interval <- #{peek struct itimerspec, it_interval} ptr
+    it_value <- #{peek struct itimerspec, it_value} ptr
+    pure CITimerSpec {
+      it_interval,
+      it_value
+    }
+  poke ptr CITimerSpec{it_interval, it_value} = do
+    #{poke struct itimerspec, it_interval} ptr it_interval
+    #{poke struct itimerspec, it_value} ptr it_value
+
+defaultCITimerSpec :: CITimerSpec
+defaultCITimerSpec = CITimerSpec defaultCTimeSpec defaultCTimeSpec
+
+foreign import capi "time.h value CLOCK_BOOTTIME"
+  c_CLOCK_BOOTTIME :: CClockId
+
+
+foreign import capi "time.h timer_create"
+  c_timer_create :: CClockId -> Ptr CSigEvent -> Ptr CTimer -> IO CInt
+
+foreign import capi "time.h timer_settime"
+  c_timer_settime :: CTimer -> CInt -> Ptr CITimerSpec -> Ptr CITimerSpec -> IO CInt
+
+foreign import capi "time.h timer_delete"
+  c_timer_delete :: CTimer -> IO CInt
+
+
+data PosixTimer = PosixTimer {
+  ctimer :: CTimer,
+  callbackPtr :: (FunPtr SigevNotifyFunction)
+}
+
+instance IsDisposable PosixTimer where
+  toDisposable = undefined
+
+
+newUnmanagedPosixTimer :: CClockId -> IO () -> IO PosixTimer
+newUnmanagedPosixTimer clockId callback = runInBoundThread do
+  callbackPtr <- mkSigevNotifyFunction (const callback)
+
+  ctimer <- alloca \ctimerPtr -> do
+    alloca \sigevent -> do
+      poke sigevent $ CSigEventThreadCallback callbackPtr
+      throwErrnoIfMinus1_ "timer_create" do
+        c_timer_create c_CLOCK_BOOTTIME sigevent ctimerPtr
+      peek ctimerPtr
+
+  pure $ PosixTimer { ctimer, callbackPtr }
+
+setPosixTimer :: PosixTimer -> Maybe CTimeSpec -> IO ()
+setPosixTimer PosixTimer{ctimer} timeSpec = do
+  alloca \newValue -> do
+    poke newValue $ defaultCITimerSpec {
+      it_value = fromMaybe defaultCTimeSpec timeSpec
+    }
+    throwErrnoIfMinus1_ "timer_settime" do
+      c_timer_settime ctimer 0 newValue nullPtr
+
+setPosixIntervalTimer :: PosixTimer -> CITimerSpec -> IO ()
+setPosixIntervalTimer PosixTimer{ctimer}  iTimerSpec = do
+  alloca \newValue -> do
+    poke newValue iTimerSpec
+    throwErrnoIfMinus1_ "timer_settime" do
+      c_timer_settime ctimer 0 newValue nullPtr
+
+
+
+
+boottime :: IO ()
+boottime = runInBoundThread do
+
+  callbackPtr <- mkSigevNotifyFunction callback
+
+  ctimer <- alloca \ctimerPtr -> do
+    alloca \sigevent -> do
+      poke sigevent $ CSigEventThreadCallback callbackPtr
+      throwErrnoIfMinus1_ "timer_create" do
+        c_timer_create c_CLOCK_BOOTTIME sigevent ctimerPtr
+      peek ctimerPtr
+
+  alloca \newValue -> do
+    poke newValue oneSecond
+    throwErrnoIfMinus1_ "timer_settime" do
+      c_timer_settime ctimer 0 newValue nullPtr
+  where
+    oneSecond = defaultCITimerSpec {
+      it_value = defaultCTimeSpec {
+        tv_sec = 1
+      }
+    }
+    callback :: Ptr Void -> IO ()
+    callback _ = traceIO "callback"