1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Wayland.Server
( Request(..)
, ObjectID
, Global
, DisplayM(..)
, ResourceClass(..)
, RequestClass
, InterfaceDesc(..)
, MessageDesc(..)
, ArgumentDesc(..)
, Nullability(..)
, fromRequest
, withDisplay
, bindSocket
, processRequests
, flushEvents
, sendEvent
, 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)
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 (($>))
type RequestHandler s = Request -> DisplayM s ()
type EventLoopHandler = Request -> IO ()
data Display
= Display { display :: !WLDisplay
, activeEventLoop :: !(IORef (Maybe EventLoopHandler))
}
data Global = Global
newtype ObjectID = ObjectID String
deriving (Show, Eq, Ord)
data Nullability
= AllowNull
| NotNull
data ArgumentDesc
= ArgumentInt
| ArgumentUInt
| ArgumentFixed
| ArgumentString !Nullability
| ArgumentObject !Nullability
| ArgumentNewID
| ArgumentArray
| ArgumentFD
data MessageDesc
= MessageDesc { msgName :: !String
, msgSignature :: ![ArgumentDesc]
, msgSince :: !Int
, msgIsDestructor :: !Bool
, msgCreatedInterface :: !(Maybe InterfaceDesc)
, msgArgumentInterface :: ![InterfaceDesc]
}
data InterfaceDesc
= InterfaceDesc { ifName :: !String
, ifVersion :: !Int
, ifRequests :: ![MessageDesc]
, ifEvents :: ![MessageDesc]
}
class ResourceClass r where
type ResourceRequest r :: Type
type ResourceEvent r :: Type
objectID :: r -> ObjectID
interface :: Proxy r -> InterfaceDesc
class (Typeable r, Show r) => RequestClass r where
data Request = forall a. RequestClass a => Request 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 (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 = 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 <- getDisplay
name <- liftIO $ wlDisplayAddSocketAuto (display disp)
liftIO $ peekCString name
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
flushEvents :: DisplayM s ()
flushEvents = undefined
destroyResource :: ResourceClass r => r -> DisplayM s ()
destroyResource _ = undefined
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)
|
