dispatch events

3 files changed, 228 insertions, 23 deletions

diff --git a/wayland/Wayland/Server.hs b/wayland/Wayland/Server.hs
index 7d60512..77dea63 100644
--- a/wayland/Wayland/Server.hs
+++ b/wayland/Wayland/Server.hs
@@ -6,13 +6,17 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module Wayland.Server
   ( Request(..)
   , ObjectID
   , Global
+  , ArgumentMarshaller(..)
+  , ArgumentDemarshaller(..)
   , DisplayM(..)
   , ResourceClass(..)
+  , EventClass
   , RequestClass
   , InterfaceDesc(..)
   , MessageDesc(..)
@@ -36,12 +40,12 @@ import Data.Kind (Type)
 import Control.Monad.State.Strict (StateT, MonadState(..), MonadIO(..), runStateT)
 import Lens.Micro.Mtl.Internal (Zoom(..), Zoomed)
 import Lens.Micro.TH (makeLenses)
-import Lens.Micro.Mtl ((%=), use)
+import Lens.Micro.Mtl ((%=), use, (<<%=))
 import qualified Wayland.Server.System as Sys
 import Control.Monad.Trans (MonadTrans(..))
 import Foreign.C (peekCString, newCString)
 import Foreign.C.Types (CInt)
-import Foreign (Ptr, nullPtr, new)
+import Foreign (Ptr, nullPtr, new, newStablePtr, castStablePtrToPtr, castPtrToStablePtr, deRefStablePtr, freeStablePtr, Storable (..), Int32, castPtr, free, mallocArray0)
 import Data.IORef (IORef, newIORef, writeIORef, readIORef)
 import Control.Monad.Reader (ReaderT, MonadReader (..), runReaderT)
 import Control.Exception (bracket)
@@ -51,11 +55,24 @@ import Data.Maybe (isJust)
 import qualified Data.Map as M
 import Foreign.Marshal (newArray)
 import Data.Word (Word32)
+import System.Mem.StableName (StableName, makeStableName)
+import Data.Hashable (Hashable(..))
+import Foreign.Ptr (plusPtr)
 
 data Global = Global
 
-data ObjectID = ObjectID
-  deriving (Show, Eq, Ord)
+-- IORef set to nullPtr once destroyed.
+data ObjectID = ObjectID (StableName (IORef Sys.WLResource)) (IORef Sys.WLResource)
+  deriving (Eq)
+
+instance Ord ObjectID where
+  (ObjectID nameA _) <= (ObjectID nameB _) = hash nameA <= hash nameB
+
+instance Hashable ObjectID where
+  hashWithSalt s (ObjectID name _) = hashWithSalt s name
+
+instance Show ObjectID where
+  show (ObjectID name _) = "ObjectID " ++ show (hash name)
 
 data Nullability
   = AllowNull
@@ -91,6 +108,8 @@ data InterfaceDesc
 
 class (Typeable r, Show r) => RequestClass r where
 
+class (Typeable e, Show e) => EventClass e where
+
 data Request = forall a. RequestClass a => Request a
 
 newtype DisplayM s a = DisplayM { runDisplayM :: StateT s (StateT DisplayState (ReaderT Display IO)) a }
@@ -112,12 +131,36 @@ data DisplayState
 
 makeLenses ''DisplayState
 
-class Typeable r => ResourceClass r where
+class (Typeable r, RequestClass (ResourceRequest r), EventClass (ResourceEvent r)) => ResourceClass r where
   type ResourceRequest r :: Type
   type ResourceEvent   r :: Type
   objectID  :: r        -> ObjectID
   fromID    :: ObjectID -> r
   interface :: Proxy r  -> InterfaceDesc
+  marshalEvent     :: ArgumentMarshaller m   => Proxy r -> ResourceEvent r -> m Int
+  demarshalRequest :: ArgumentDemarshaller m => r -> Int -> m (ResourceRequest r)
+  eventSignature   :: Proxy r -> ResourceEvent r   -> MessageDesc
+  requestSignature :: Proxy r -> ResourceRequest r -> MessageDesc
+
+class (Monad m, MonadFail m) => ArgumentMarshaller m where
+  marshalInt    :: Int                  -> m ()
+  marshalUInt   :: Word                 -> m ()
+  marshalFixed  :: Float                -> m ()
+  marshalString :: String               -> m ()
+  marshalObject :: ResourceClass r => r -> m ()
+  marshalNewID  :: ResourceClass r => r -> m ()
+  marshalArray  :: Storable a => [a]    -> m ()
+  marshalFD     :: Int32                -> m ()
+
+class (Monad m, MonadFail m) => ArgumentDemarshaller m where
+  demarshalInt    :: m Int
+  demarshalUInt   :: m Word
+  demarshalFixed  :: m Float
+  demarshalString :: m String
+  demarshalObject :: ResourceClass r => m r
+  demarshalNewID  :: ResourceClass r => m r
+  demarshalArray  :: Storable a => m [a]
+  demarshalFD     :: m Int32
 
 instance Show Request where
   show (Request r) = show r
@@ -173,25 +216,38 @@ processRequests h = do
   put stateAfter
   liftDisplayState $ put displayStateAfter
 
-sendEvent :: ResourceClass r => r -> ResourceEvent r -> DisplayM s ()
-sendEvent _ _ = pure () -- TODO
-
-flushEvents :: DisplayM s ()
-flushEvents = pure () -- TODO
-
-destroyResource :: ResourceClass r => r -> DisplayM s ()
-destroyResource _ = pure () -- TODO
-
-registerGlobal :: forall r req s. ResourceClass r => RequestClass req => (r -> req) -> Int -> DisplayM s Global
-registerGlobal mkReq version = do
+registerGlobal :: forall r bindReq unbindReq s. ResourceClass r => RequestClass bindReq => RequestClass unbindReq => (r -> bindReq) -> (r -> unbindReq) -> Int -> DisplayM s Global
+registerGlobal mkBindReq mkUnbindReq version = do
   disp <- getDisplay
   iface <- getInterface (Proxy :: Proxy r)
+  let dispatcher :: Ptr () -> Sys.WLResource -> Word32 -> Ptr Sys.WLMessage -> Ptr Sys.WLArgument -> IO CInt
+      dispatcher _ res opcode _ _ = do
+        handlePtr <- castPtrToStablePtr <$> Sys.wlResourceGetUserData res
+        objID@(ObjectID _ _) <- deRefStablePtr handlePtr
+        putStrLn $ "Handling request " ++ show opcode ++ " for " ++ show objID
+        -- TODO: Handle request
+        pure 0
+  let destroy :: Sys.WLResource -> IO ()
+      destroy res = do
+        handlePtr <- castPtrToStablePtr <$> Sys.wlResourceGetUserData res
+        objID@(ObjectID _ handle) <- deRefStablePtr handlePtr
+        writeIORef handle (Sys.WLResource nullPtr)
+        freeStablePtr handlePtr
+        let req = mkUnbindReq (fromID objID)
+        runRequest disp (Request req)
+        pure ()
   let createObject :: Sys.WLClient -> Ptr () -> Word32 -> Word32 -> IO ()
-      createObject client _ ver objID = do
-        _ <- Sys.wlResourceCreate client iface (fromIntegral ver) objID
-        -- TODO: Bind functions
-        -- TODO: Wrap resource into ObjectID
-        let req = mkReq (fromID ObjectID)
+      createObject client _ ver protID = do
+        res <- Sys.wlResourceCreate client iface (fromIntegral ver) protID
+        handle <- newIORef res
+        name <- makeStableName handle
+        let objID = ObjectID name handle
+        handlePtr <- newStablePtr objID
+        dis <- Sys.wrapWLDispatcherFunc dispatcher
+        des <- Sys.wrapWLResourceDestroyFunc destroy
+        -- TODO: Free functions
+        Sys.wlResourceSetDispatcher res dis nullPtr (castStablePtrToPtr handlePtr) des
+        let req = mkBindReq (fromID objID)
         runRequest disp (Request req)
         pure ()
   liftIO $ do
@@ -282,3 +338,80 @@ getInterface p = do
     Nothing  -> do ptr <- wrapInterface (interface p)
                    liftDisplayState $ typeInterfaces %= M.insert (typeRep p) ptr
                    pure ptr
+
+data ArgumentIteratorState
+  = ArgumentIteratorState { _argNext          :: !(Ptr Sys.WLArgument)
+                          , _argRemaining     :: !Int
+                          , _allocatedBuffers :: ![Ptr ()]
+                          }
+  deriving (Show)
+
+makeLenses ''ArgumentIteratorState
+
+newtype ArgumentIterator a = ArgumentIterator { runArgumentIterator :: StateT ArgumentIteratorState IO a }
+  deriving (Functor, Applicative, Monad, MonadFail, MonadState ArgumentIteratorState, MonadIO)
+
+advanceIterator :: ArgumentIterator (Ptr Sys.WLArgument)
+advanceIterator = do
+  next      <- argNext      <<%= \p -> plusPtr p (sizeOf (undefined :: Sys.WLArgument))
+  remaining <- argRemaining <<%= (+(-1))
+  when (remaining == 0) (fail "Out of range for argument")
+  pure next
+
+getObjectForHandle :: ResourceClass r => r -> IO (Ptr a)
+getObjectForHandle r = fetch (objectID r)
+  where fetch (ObjectID _ handle) = readIORef handle >>= check
+        check (Sys.WLResource ptr) | ptr == nullPtr = fail "Invalid object handle."
+                                   | otherwise      = pure (castPtr ptr)
+
+instance ArgumentMarshaller ArgumentIterator where
+  marshalInt    v = advanceIterator >>= (liftIO . Sys.wlArgumentSetInt   (fromIntegral v))
+  marshalUInt   v = advanceIterator >>= (liftIO . Sys.wlArgumentSetUInt  (fromIntegral v))
+  marshalFixed  v = advanceIterator >>= (liftIO . Sys.wlArgumentSetFixed (Sys.WLFixed (round (v * 256))))
+  marshalFD     v = advanceIterator >>= (liftIO . Sys.wlArgumentSetFD    (fromIntegral v))
+  marshalString v = do
+    arg <- advanceIterator
+    str <- liftIO $ newCString v
+    allocatedBuffers %= (castPtr str:)
+    liftIO $ Sys.wlArgumentSetString str arg
+  marshalObject v = do
+    arg <- advanceIterator
+    obj <- liftIO $ getObjectForHandle v
+    liftIO $ Sys.wlArgumentSetObject obj arg
+  marshalNewID v = do
+    arg <- advanceIterator
+    obj <- liftIO $ getObjectForHandle v
+    liftIO $ Sys.wlArgumentSetObject obj arg
+  marshalArray v = do
+    arg <- advanceIterator
+    let len = fromIntegral $ length v * sizeOf (head v)
+    buf <- liftIO $ newArray v
+    arr <- liftIO $ new $ Sys.WLArray { Sys.arrSize  = len
+                                      , Sys.arrAlloc = len
+                                      , Sys.arrData  = castPtr buf
+                                      }
+    allocatedBuffers %= \p -> castPtr buf:castPtr arr:p
+    liftIO $ Sys.wlArgumentSetArray arr arg
+
+sendEvent :: forall r s. ResourceClass r => r -> ResourceEvent r -> DisplayM s ()
+sendEvent res e = liftIO $ do
+  let params = msgSignature (eventSignature (Proxy :: Proxy r) e)
+  ptr <- getObjectForHandle res
+  buffer <- mallocArray0 (length params)
+  let s = ArgumentIteratorState { _argNext          = buffer
+                                , _argRemaining     = length params
+                                , _allocatedBuffers = [castPtr buffer]
+                                }
+  (opcode, s') <- runStateT (runArgumentIterator (marshalEvent (Proxy :: Proxy r) e)) s
+  Sys.wlResourcePostEventArray (Sys.WLResource ptr) (fromIntegral opcode) buffer
+  mapM_ free (_allocatedBuffers s')
+
+flushEvents :: DisplayM s ()
+flushEvents = do
+  disp <- getDisplay
+  liftIO $ Sys.wlDisplayFlushClients (display disp)
+
+destroyResource :: ResourceClass r => r -> DisplayM s ()
+destroyResource r = liftIO $ do
+  ptr <- getObjectForHandle r
+  Sys.wlResourceDestroy (Sys.WLResource ptr)
diff --git a/wayland/Wayland/Server/System.hsc b/wayland/Wayland/Server/System.hsc
index d4f5b50..0f68578 100644
--- a/wayland/Wayland/Server/System.hsc
+++ b/wayland/Wayland/Server/System.hsc
@@ -4,7 +4,7 @@ module Wayland.Server.System where
 
 #include <wayland-server.h>
 
-import Foreign (FunPtr, Ptr, Storable(..), Int32)
+import Foreign (FunPtr, Ptr, Storable(..), Int32, castPtr)
 import Foreign.C (CString, CInt(..), CSize)
 import Data.Word (Word32)
 
@@ -56,12 +56,21 @@ foreign import ccall "wrapper"
 foreign import ccall "wrapper"
   wrapWLGlobalBindFunc :: WLGlobalBindFunc -> IO (FunPtr WLGlobalBindFunc)
 
+foreign import ccall "wrapper"
+  wrapWLDispatcherFunc :: WLDispatcherFunc -> IO (FunPtr WLDispatcherFunc)
+
+foreign import ccall "wrapper"
+  wrapWLResourceDestroyFunc :: WLResourceDestroyFunc -> IO (FunPtr WLResourceDestroyFunc)
+
 foreign import ccall "wl_display_create"
   wlDisplayCreate :: IO WLDisplay
 
 foreign import ccall "wl_display_destroy"
   wlDisplayDestroy :: WLDisplay -> IO ()
 
+foreign import ccall "wl_display_flush_clients"
+  wlDisplayFlushClients :: WLDisplay -> IO ()
+
 foreign import ccall "wl_display_add_socket_auto"
   wlDisplayAddSocketAuto :: WLDisplay -> IO CString
 
@@ -86,6 +95,15 @@ foreign import ccall "wl_resource_create"
 foreign import ccall "wl_resource_set_dispatcher"
   wlResourceSetDispatcher :: WLResource -> FunPtr WLDispatcherFunc -> Ptr () -> Ptr () -> FunPtr WLResourceDestroyFunc -> IO ()
 
+foreign import ccall "wl_resource_get_user_data"
+  wlResourceGetUserData :: WLResource -> IO (Ptr ())
+
+foreign import ccall "wl_resource_post_event_array"
+  wlResourcePostEventArray :: WLResource -> Word32 -> Ptr WLArgument -> IO ()
+
+foreign import ccall "wl_resource_destroy"
+  wlResourceDestroy :: WLResource -> IO ()
+
 wlArgumentGetInt :: Ptr WLArgument -> IO Int32
 wlArgumentGetInt = #{peek union wl_argument, i}
 
@@ -98,7 +116,7 @@ wlArgumentGetFixed = #{peek union wl_argument, f}
 wlArgumentGetString :: Ptr WLArgument -> IO CString
 wlArgumentGetString = #{peek union wl_argument, s}
 
-wlArgumentGetObject :: Ptr WLArgument -> IO WLResource
+wlArgumentGetObject :: Ptr WLArgument -> IO (Ptr ())
 wlArgumentGetObject = #{peek union wl_argument, o}
 
 wlArgumentGetNewID :: Ptr WLArgument -> IO Word32
@@ -110,6 +128,30 @@ wlArgumentGetArray = #{peek union wl_argument, a}
 wlArgumentGetFD :: Ptr WLArgument -> IO Int32
 wlArgumentGetFD = #{peek union wl_argument, h}
 
+wlArgumentSetInt :: Int32 -> Ptr WLArgument -> IO ()
+wlArgumentSetInt v p = #{poke union wl_argument, i} p v
+
+wlArgumentSetUInt :: Word32 -> Ptr WLArgument -> IO ()
+wlArgumentSetUInt v p = #{poke union wl_argument, u} p v
+
+wlArgumentSetFixed :: WLFixed -> Ptr WLArgument -> IO ()
+wlArgumentSetFixed v p = #{poke union wl_argument, f} p v
+
+wlArgumentSetString :: CString -> Ptr WLArgument -> IO ()
+wlArgumentSetString v p = #{poke union wl_argument, s} p v
+
+wlArgumentSetObject :: Ptr () -> Ptr WLArgument -> IO ()
+wlArgumentSetObject v p = #{poke union wl_argument, o} p v
+
+wlArgumentSetNewID :: Word32 -> Ptr WLArgument -> IO ()
+wlArgumentSetNewID v p = #{poke union wl_argument, n} p v
+
+wlArgumentSetArray :: Ptr WLArray -> Ptr WLArgument -> IO ()
+wlArgumentSetArray v p = #{poke union wl_argument, a} p v
+
+wlArgumentSetFD :: Int32 -> Ptr WLArgument -> IO ()
+wlArgumentSetFD v p = #{poke union wl_argument, h} p v
+
 instance Storable WLMessage where
   sizeOf    _ = #{size struct wl_message}
   alignment _ = #{alignment struct wl_message}
@@ -152,3 +194,32 @@ instance Storable WLInterface where
     #{poke struct wl_interface, event_count}  p $ ifEventCount  m
     #{poke struct wl_interface, events}       p $ ifEvents      m
     return ()
+
+instance Storable WLArray where
+  sizeOf    _ = #{size struct wl_array}
+  alignment _ = #{alignment struct wl_array}
+  peek p = do
+    aSize  <- #{peek struct wl_array, size}  p
+    aAlloc <- #{peek struct wl_array, alloc} p
+    aData  <- #{peek struct wl_array, data}  p
+    return $ WLArray { arrSize  = aSize
+                     , arrAlloc = aAlloc
+                     , arrData  = aData
+                     }
+  poke p m = do
+    #{poke struct wl_array, size}  p $ arrSize  m
+    #{poke struct wl_array, alloc} p $ arrAlloc m
+    #{poke struct wl_array, data}  p $ arrData  m
+    return ()
+
+instance Storable WLFixed where
+  sizeOf    _             = sizeOf    (undefined :: #{type wl_fixed_t})
+  alignment _             = alignment (undefined :: #{type wl_fixed_t})
+  peek      p             = WLFixed <$> peek (castPtr p)
+  poke      p (WLFixed v) = poke (castPtr p) v
+
+instance Storable WLArgument where
+  sizeOf    _   = #{size union wl_argument}
+  alignment _   = #{alignment union wl_argument}
+  peek      _   = pure WLArgument
+  poke      _ _ = pure ()
diff --git a/wayland/wayland.cabal b/wayland/wayland.cabal
index c54a9fd..ee0f9a9 100644
--- a/wayland/wayland.cabal
+++ b/wayland/wayland.cabal
@@ -12,6 +12,7 @@ library
     build-depends:     base ^>=4.18.2.1,
                        mtl,
                        containers,
+                       hashable,
                        microlens,
                        microlens-mtl,
                        microlens-th