implement signal handling

4 files changed, 111 insertions, 38 deletions

diff --git a/highway/Main.hs b/highway/Main.hs
index 17b768d..d387466 100644
--- a/highway/Main.hs
+++ b/highway/Main.hs
@@ -2,7 +2,7 @@
 
 import Wayland.Server
 import Lens.Micro.TH (makeLenses)
-import Lens.Micro.Mtl ((%=))
+import Lens.Micro.Mtl ((%=), (<%=))
 import Data.Data (Typeable)
 import Control.Monad (void)
 import Control.Monad.Trans (liftIO)
@@ -24,9 +24,21 @@ data BindRequest
   = BindOutput WLOutput.Handle
   deriving (Typeable, Show)
 
+data SignalRequest
+  = ReqSIGINT
+  deriving (Typeable, Show)
+
+instance RequestClass SignalRequest
+instance RequestClass BindRequest
+
 data Output = Output
+  deriving (Show)
+
+data State = State { _outputs          :: M.Map WLOutput.Handle Output
+                   , _interruptedCount :: Int
+                   }
+  deriving (Show)
 
-data State = State { _outputs :: M.Map WLOutput.Handle Output }
 makeLenses ''State
 
 handleRequest :: Request -> DisplayM State ()
@@ -37,12 +49,16 @@ handleRequest r
                                                        sendEvent o $ WLOutput.EvGeometry geometry
                                                        sendEvent o $ WLOutput.EvDone
                                                        flushEvents
+  | Just (ReqSIGINT)             <- fromRequest r = do c <- interruptedCount <%= (+1)
+                                                       liftIO $ putStrLn $ "Received SIGINT " ++ show c ++ "/3"
+                                                       if c >= 3 then requestTermination else pure ()
   | otherwise                                     = pure ()
 
 main :: IO ()
-main = void $ withDisplay (State M.empty) $ do
+main = void $ withDisplay (State M.empty 0) $ do
   socket <- bindSocket
   liftIO $ putStrLn $ "Listening on socket: " ++ socket
+  registerSignalEvent ReqSIGINT 2
   output <- registerGlobal BindOutput
   processRequests handleRequest
   unregisterGlobal output
diff --git a/protocols/Wayland/Protocols/Core/WLOutput.hs b/protocols/Wayland/Protocols/Core/WLOutput.hs
index f943169..2989fe5 100644
--- a/protocols/Wayland/Protocols/Core/WLOutput.hs
+++ b/protocols/Wayland/Protocols/Core/WLOutput.hs
@@ -12,13 +12,13 @@ module Wayland.Protocols.Core.WLOutput
   ) where
 
 import Data.Data (Typeable)
-import Wayland.Server (ResourceClass(..), ObjectID)
+import Wayland.Server (ResourceClass(..), RequestClass(..), ObjectID)
 
 newtype Handle = Handle ObjectID
   deriving (Show, Eq, Ord)
 
 instance ResourceClass Handle where
-  type ResourceEvent Handle = Event
+  type ResourceEvent   Handle = Event
   type ResourceRequest Handle = Request
   objectID (Handle h) = h
   interface _ = undefined
@@ -59,6 +59,8 @@ data Request
   = ReqRelease Handle
   deriving (Typeable, Show)
 
+instance RequestClass Request
+
 data Event
   = EvGeometry    Geometry
   | EvMode        Mode
diff --git a/wayland/Wayland/Server.hs b/wayland/Wayland/Server.hs
index 0b0b6ea..76b9ff4 100644
--- a/wayland/Wayland/Server.hs
+++ b/wayland/Wayland/Server.hs
@@ -11,6 +11,7 @@ module Wayland.Server
   , Global
   , DisplayM(..)
   , ResourceClass(..)
+  , RequestClass
   , InterfaceDesc(..)
   , MessageDesc(..)
   , ArgumentDesc(..)
@@ -24,19 +25,31 @@ module Wayland.Server
   , destroyResource
   , registerGlobal
   , unregisterGlobal
+  , registerSignalEvent
+  , requestTermination
   ) where
 
 import Data.Typeable (Typeable, Proxy, cast)
 import Data.Kind (Type)
-import Control.Monad.State.Strict (StateT, MonadState(..), MonadIO(..), runStateT, gets)
+import Control.Monad.State.Strict (StateT, MonadState(..), MonadIO(..), runStateT)
 import Lens.Micro.Mtl.Internal (Zoom(..), Zoomed)
 import Wayland.Server.System
 import Control.Monad.Trans (MonadTrans(..))
 import Foreign.C (peekCString)
+import Foreign.C.Types (CInt)
+import Foreign (nullPtr)
+import Data.IORef (IORef, newIORef, writeIORef, readIORef)
+import Control.Monad.Reader (ReaderT, MonadReader (..), runReaderT)
+import Control.Exception (bracket)
+import Data.Functor (($>))
 
-data DisplayState
-  = DisplayState { display :: WLDisplay
-                 }
+type RequestHandler s = Request -> DisplayM s ()
+type EventLoopHandler = Request -> IO ()
+
+data Display
+  = Display { display         :: !WLDisplay
+            , activeEventLoop :: !(IORef (Maybe EventLoopHandler))
+            }
 
 data Global = Global
 
@@ -79,37 +92,55 @@ class ResourceClass r where
   objectID  :: r -> ObjectID
   interface :: Proxy r -> InterfaceDesc
 
-data Request = forall a. Typeable a => Request a
+class (Typeable r, Show r) => RequestClass r where
+
+data Request = forall a. RequestClass a => Request a
 
-newtype DisplayM s a = DisplayM { runDisplayM :: StateT s (StateT DisplayState IO) a }
+instance Show Request where
+  show (Request r) = show r
+
+newtype DisplayM s a = DisplayM { runDisplayM :: StateT s (ReaderT Display IO) a }
   deriving (Functor, Applicative, Monad, MonadIO, MonadState s)
 
-type instance Zoomed (DisplayM s) = Zoomed (StateT s (StateT DisplayState IO))
+type instance Zoomed (DisplayM s) = Zoomed (StateT s (ReaderT Display IO))
 
 instance Zoom (DisplayM s) (DisplayM t) s t where
   zoom l (DisplayM m) = DisplayM (zoom l m)
 
+getDisplay :: DisplayM s Display
+getDisplay = DisplayM $ lift ask
+
 fromRequest :: Typeable a => Request -> Maybe a
 fromRequest (Request x) = cast x
 
 withDisplay :: s -> DisplayM s a -> IO (a, s)
-withDisplay initialState f = do
-  disp <- wlDisplayCreate
-  let dispState = DisplayState { display = disp }
-  (res, _) <-runStateT (runStateT (runDisplayM f) initialState) dispState
-  wlDisplayDestroy disp
-  return res
+withDisplay initialState f = bracket wlDisplayCreate wlDisplayDestroy $ \sysDisp -> do
+  eventLoop <- newIORef Nothing
+  let disp = Display { display         = sysDisp
+                     , activeEventLoop = eventLoop }
+  runReaderT (runStateT (runDisplayM f) initialState) disp
 
 bindSocket :: DisplayM s String
 bindSocket = do
-  disp <- DisplayM $ lift $ gets display
-  name <- liftIO $ wlDisplayAddSocketAuto disp
+  disp <- getDisplay
+  name <- liftIO $ wlDisplayAddSocketAuto (display disp)
   liftIO $ peekCString name
 
-processRequests :: (Request -> DisplayM s ()) -> DisplayM s ()
-processRequests _ = do
-  disp <- DisplayM $ lift $ gets display
-  liftIO $ wlDisplayRun disp
+processRequests :: RequestHandler s -> DisplayM s ()
+processRequests h = do
+  disp <- getDisplay
+  stateBefore <- get
+  stateRef <- liftIO $ newIORef stateBefore
+  let handler :: Request -> IO ()
+      handler r = do
+        s <- readIORef stateRef
+        (_, s') <- runReaderT (runStateT (runDisplayM (h r)) s) disp
+        writeIORef stateRef s'
+        pure ()
+  liftIO $ writeIORef (activeEventLoop disp) (Just handler)
+  liftIO $ wlDisplayRun (display disp)
+  stateAfter <- liftIO $ readIORef stateRef
+  put stateAfter
 
 sendEvent :: ResourceClass r => r -> ResourceEvent r -> DisplayM s ()
 sendEvent _ _ = undefined
@@ -120,8 +151,28 @@ flushEvents = undefined
 destroyResource :: ResourceClass r => r -> DisplayM s ()
 destroyResource _ = undefined
 
-registerGlobal :: ResourceClass r => Typeable req => (r -> req) -> DisplayM s Global
+registerGlobal :: ResourceClass r => RequestClass req => (r -> req) -> DisplayM s Global
 registerGlobal _ = pure Global
 
 unregisterGlobal :: Global -> DisplayM s ()
 unregisterGlobal _ = pure ()
+
+runRequest :: Display -> Request -> IO ()
+runRequest disp r = do
+  loop <- readIORef (activeEventLoop disp)
+  case loop of
+    Just handler -> handler r
+    Nothing      -> putStrLn $ "Lost request because no event loop is active: " ++ show r
+
+registerSignalEvent :: RequestClass req => req -> CInt -> DisplayM s ()
+registerSignalEvent r sig = do
+  disp <- getDisplay
+  loop <- liftIO $ wlDisplayGetEventLoop (display disp)
+  func <- liftIO $ wrapWLEventLoopSignalFunc $ \_ _ -> runRequest disp (Request r) $> 0
+  _ <- liftIO $ wlEventLoopAddSignal loop sig func nullPtr
+  pure ()
+
+requestTermination :: DisplayM s ()
+requestTermination = do
+  disp <- getDisplay
+  liftIO $ wlDisplayTerminate (display disp)
diff --git a/wayland/Wayland/Server/System.hsc b/wayland/Wayland/Server/System.hsc
index d86f59a..60940ce 100644
--- a/wayland/Wayland/Server/System.hsc
+++ b/wayland/Wayland/Server/System.hsc
@@ -1,20 +1,11 @@
 {-# LANGUAGE ForeignFunctionInterface #-}
 
-module Wayland.Server.System
-  ( WLMessage(..)
-  , WLInterface(..)
-  , WLDisplay(WLDisplay)
-  , wlDisplayCreate
-  , wlDisplayDestroy
-  , wlDisplayAddSocketAuto
-  , wlDisplayRun
-  , wlDisplayTerminate
-  ) where
+module Wayland.Server.System where
 
 #include <wayland-server.h>
 
-import Foreign (Ptr, Storable(..))
-import Foreign.C (CString, CInt)
+import Foreign (FunPtr, Ptr, Storable(..))
+import Foreign.C (CString, CInt(..))
 
 data WLMessage
   = WLMessage { msgName      :: CString
@@ -31,7 +22,14 @@ data WLInterface
                 , ifEvents      :: Ptr WLMessage
                 }
 
-newtype WLDisplay = WLDisplay (Ptr WLDisplay)
+newtype WLDisplay     = WLDisplay     (Ptr WLDisplay)
+newtype WLEventLoop   = WLEventLoop   (Ptr WLEventLoop)
+newtype WLEventSource = WLEventSource (Ptr WLEventSource)
+
+type WLEventLoopSignalFunc = CInt -> Ptr () -> IO CInt
+
+foreign import ccall "wrapper"
+  wrapWLEventLoopSignalFunc :: WLEventLoopSignalFunc -> IO (FunPtr WLEventLoopSignalFunc)
 
 foreign import ccall "wl_display_create"
   wlDisplayCreate :: IO WLDisplay
@@ -48,6 +46,12 @@ foreign import ccall "wl_display_run"
 foreign import ccall "wl_display_terminate"
   wlDisplayTerminate :: WLDisplay -> IO ()
 
+foreign import ccall "wl_display_get_event_loop"
+  wlDisplayGetEventLoop :: WLDisplay -> IO WLEventLoop
+
+foreign import ccall "wl_event_loop_add_signal"
+  wlEventLoopAddSignal :: WLEventLoop -> CInt -> FunPtr WLEventLoopSignalFunc -> Ptr () -> IO WLEventSource
+
 instance Storable WLMessage where
   sizeOf    _ = #{size struct wl_message}
   alignment _ = #{alignment struct wl_message}