Implement disposable for POSIX timer, implement settime and more clocks

src/Quasar/Timer/PosixTimer.hsc

 {-# LANGUAGE CApiFFI #-}
 
 module Quasar.Timer.PosixTimer (
-  CTimeSpec,
-  CITimerSpec,
-  boottime,
+  ClockId(..),
+  TimerSetTimeMode(..),
+  CTimeSpec(..),
+  CITimerSpec(..),
+  newPosixTimer,
+  newUnmanagedPosixTimer,
+  setPosixTimer,
+  setPosixIntervalTimer,
 ) where
 
 import Control.Concurrent
@@ -11,6 +16,7 @@ import Foreign
 import Foreign.C
 import Quasar.Disposable
 import Quasar.Prelude
+import Quasar.ResourceManager
 import System.Posix.Types
 
 #include <signal.h>
@@ -36,6 +42,51 @@ foreign import ccall "wrapper"
 type SigevNotifyFunction = (Ptr Void -> IO ())
 
 
+data ClockId
+  = Realtime
+  | Monotonic
+  | ProcessCputime
+  | ThreadCputime
+  | Boottime
+  | RealtimeAlarm
+  | BoottimeAlarm
+  | Tai
+
+toCClockId :: ClockId -> CClockId
+toCClockId Realtime = c_CLOCK_REALTIME
+toCClockId Monotonic = c_CLOCK_MONOTONIC
+toCClockId ProcessCputime = c_CLOCK_PROCESS_CPUTIME_ID
+toCClockId ThreadCputime = c_CLOCK_THREAD_CPUTIME_ID
+toCClockId Boottime = c_CLOCK_BOOTTIME
+toCClockId RealtimeAlarm = c_CLOCK_REALTIME_ALARM
+toCClockId BoottimeAlarm = c_CLOCK_BOOTTIME_ALARM
+toCClockId Tai = c_CLOCK_TAI
+
+foreign import capi "time.h value CLOCK_REALTIME"
+  c_CLOCK_REALTIME :: CClockId
+
+foreign import capi "time.h value CLOCK_MONOTONIC"
+  c_CLOCK_MONOTONIC :: CClockId
+
+foreign import capi "time.h value CLOCK_PROCESS_CPUTIME_ID"
+  c_CLOCK_PROCESS_CPUTIME_ID :: CClockId
+
+foreign import capi "time.h value CLOCK_THREAD_CPUTIME_ID"
+  c_CLOCK_THREAD_CPUTIME_ID :: CClockId
+
+foreign import capi "time.h value CLOCK_BOOTTIME"
+  c_CLOCK_BOOTTIME :: CClockId
+
+foreign import capi "time.h value CLOCK_REALTIME_ALARM"
+  c_CLOCK_REALTIME_ALARM :: CClockId
+
+foreign import capi "time.h value CLOCK_BOOTTIME_ALARM"
+  c_CLOCK_BOOTTIME_ALARM :: CClockId
+
+foreign import capi "time.h value CLOCK_TAI"
+  c_CLOCK_TAI :: CClockId
+
+
 
 data {-# CTYPE "struct timespec" #-} CTimeSpec = CTimeSpec {
   tv_sec :: CTime,
@@ -81,9 +132,6 @@ instance Storable CITimerSpec where
 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
@@ -94,17 +142,30 @@ foreign import capi "time.h timer_settime"
 foreign import capi "time.h timer_delete"
   c_timer_delete :: CTimer -> IO CInt
 
+foreign import capi "time.h value TIMER_ABSTIME"
+  c_TIMER_ABSTIME :: CInt
+
+data TimerSetTimeMode = TimeRelative | TimeAbsolute
+
+toCSetTimeFlags :: TimerSetTimeMode -> CInt
+toCSetTimeFlags TimeRelative = 0
+toCSetTimeFlags TimeAbsolute = c_TIMER_ABSTIME
+
 
 data PosixTimer = PosixTimer {
   ctimer :: CTimer,
-  callbackPtr :: (FunPtr SigevNotifyFunction)
+  disposable :: Disposable
 }
 
 instance IsDisposable PosixTimer where
-  toDisposable = undefined
+  toDisposable = disposable
 
 
-newUnmanagedPosixTimer :: CClockId -> IO () -> IO PosixTimer
+newPosixTimer :: MonadResourceManager m => ClockId -> IO () -> m PosixTimer
+newPosixTimer clockId callback = registerNewResource do
+  liftIO $ newUnmanagedPosixTimer clockId callback
+
+newUnmanagedPosixTimer :: ClockId -> IO () -> IO PosixTimer
 newUnmanagedPosixTimer clockId callback = runInBoundThread do
   callbackPtr <- mkSigevNotifyFunction (const callback)
 
@@ -112,51 +173,33 @@ newUnmanagedPosixTimer clockId callback = runInBoundThread do
     alloca \sigevent -> do
       poke sigevent $ CSigEventThreadCallback callbackPtr
       throwErrnoIfMinus1_ "timer_create" do
-        c_timer_create c_CLOCK_BOOTTIME sigevent ctimerPtr
+        c_timer_create (toCClockId clockId) sigevent ctimerPtr
       peek ctimerPtr
 
-  pure $ PosixTimer { ctimer, callbackPtr }
+  disposable <- newDisposable (delete ctimer callbackPtr)
 
-setPosixTimer :: PosixTimer -> Maybe CTimeSpec -> IO ()
-setPosixTimer PosixTimer{ctimer} timeSpec = do
-  alloca \newValue -> do
-    poke newValue $ defaultCITimerSpec {
-      it_value = fromMaybe defaultCTimeSpec timeSpec
+  pure $ PosixTimer { ctimer, disposable }
+  where
+    delete :: CTimer -> FunPtr SigevNotifyFunction -> IO ()
+    delete ctimer callbackPtr = do
+      c_timer_delete ctimer
+      -- "The treatment of any pending signal generated by the deleted timer is unspecified."
+      freeHaskellFunPtr callbackPtr
+
+
+setPosixTimer :: PosixTimer -> TimerSetTimeMode -> CTimeSpec -> IO ()
+setPosixTimer timer mode timeSpec = setPosixIntervalTimer timer mode itspec
+  where
+    itspec = defaultCITimerSpec {
+      it_value = timeSpec
     }
-    throwErrnoIfMinus1_ "timer_settime" do
-      c_timer_settime ctimer 0 newValue nullPtr
 
-setPosixIntervalTimer :: PosixTimer -> CITimerSpec -> IO ()
-setPosixIntervalTimer PosixTimer{ctimer}  iTimerSpec = do
+setPosixIntervalTimer :: PosixTimer -> TimerSetTimeMode -> CITimerSpec -> IO ()
+setPosixIntervalTimer PosixTimer{ctimer} mode 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
+      c_timer_settime ctimer (toCSetTimeFlags mode) newValue nullPtr
 
-  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"
+disarmPosixTimer :: PosixTimer -> IO ()
+disarmPosixTimer timer = setPosixIntervalTimer timer TimeRelative defaultCITimerSpec