summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--highway/Main.hs22
-rw-r--r--protocols/Wayland/Protocols/Core/WLOutput.hs6
-rw-r--r--wayland/Wayland/Server.hs91
-rw-r--r--wayland/Wayland/Server/System.hsc30
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}
generated by cgit v1.3.1 (git 2.54.0) at 2026-11-10 15:40:29 +0000