finish implementing wayland server api

1 files changed, 94 insertions, 107 deletions

diff --git a/wayland/Wayland/Server/Object.hs b/wayland/Wayland/Server/Object.hs
index 1437cc9..b56bbaf 100644
--- a/wayland/Wayland/Server/Object.hs
+++ b/wayland/Wayland/Server/Object.hs
@@ -21,8 +21,6 @@ module Wayland.Server.Object
   , createNewObject
   , RequestClass
   , EventClass
-  , Request(..)
-  , fromRequest
   , ArgumentMarshaller(..)
   , ArgumentDemarshaller(..)
   , -- * State
@@ -38,23 +36,24 @@ module Wayland.Server.Object
   , sendResourceEvent
   ) where
 
-import System.Mem.StableName (makeStableName, StableName)
+import System.Posix.Types (Fd(..))
 import Data.Kind (Type)
 import Data.Hashable (Hashable(..))
-import Data.IORef (readIORef, newIORef, writeIORef, IORef)
-import Data.Typeable (Proxy(..), TypeRep, typeRep, Typeable, cast)
+import Data.IORef (readIORef, newIORef, IORef, writeIORef)
+import Data.Typeable (Proxy(..), TypeRep, typeRep, Typeable)
 import Foreign
 import Foreign.C (withCString, peekCString, CInt)
-import Lens.Micro.Mtl ((<<%=), use, (%=), zoom)
+import Lens.Micro.Mtl (use, (%=), zoom)
 import Lens.Micro.TH (makeLenses)
-import Control.Monad.State.Strict (StateT(..), MonadState)
+import Control.Monad.State.Strict (StateT(..), MonadState(..))
 import Control.Monad.Cont (ContT(..))
 import Control.Monad.Trans (MonadIO(..), MonadTrans(..))
-import Control.Monad (when)
+import Control.Monad.Reader (ReaderT (..), MonadReader(..))
 import Wayland.Server.System
-import Wayland.Server.Interface (MessageDesc(..), InterfaceDesc, InterfaceCache, newInterfaceCache, destroyInterfaceCache, resolveInterface)
+import Wayland.Server.Interface (MessageDesc(..), InterfaceDesc(..), InterfaceCache, newInterfaceCache, destroyInterfaceCache, resolveInterface)
+import Wayland.Server.Client (Client, unwrapClient, wrapClient)
+import Wayland.Server.Types (Handle, invalidateHandle, resolveHandle, createHandle, MessageClass, Message(..))
 import qualified Data.Map as M
-import Wayland.Server.Client (Client, unwrapClient)
 
 -- | The primary data type for typed object handles.
 --
@@ -100,18 +99,14 @@ class (Typeable o, RequestClass (ObjectRequest o), EventClass (ObjectEvent o)) =
 
 -- | A request for an object sent by a client.
 --
--- The request usually includes the object it is referring to, as well as arguments provided by the client.
---
--- The request's type is erased and it is then processed by the display's event loop.
-class (Typeable r, Show r) => RequestClass r where
+-- The request usually includes the object it is referring to, as well as arguments provided by the client. It is
+-- processed as part of the server's message loop.
+class MessageClass r => RequestClass r where
 
 -- | An event that can be emitted on an object by the server.
 --
 -- The event stores the arguments passed to the client.
-class (Typeable e, Show e) => EventClass e where
-
--- | A type-erased request.
-data Request = forall r. RequestClass r => Request r
+class MessageClass e => EventClass e where
 
 -- | A monad providing an environment for marshalling a fixed number of arguments of various types.
 --
@@ -125,7 +120,7 @@ class Monad m => ArgumentMarshaller m where
   marshalObject :: Object o => o           -> m ()
   marshalNewID  :: Object o => NewObject o -> m ()
   marshalArray  :: Storable a => [a]       -> m ()
-  marshalFD     :: Int32                   -> m ()
+  marshalFD     :: Fd                      -> m ()
 
 -- | A monad providing an environment for reading a fixed number of arguments of various types.
 --
@@ -139,28 +134,25 @@ class Monad m => ArgumentDemarshaller m where
   demarshalObject :: Object o => m o
   demarshalNewID  :: Object o => m (NewObject o)
   demarshalArray  :: Storable a => m [a]
-  demarshalFD     :: m Int32
+  demarshalFD     :: m Fd
 
 -- | An opaque handle to a Wayland object.
 --
 -- The handle remains valid and can be used for equality checks even after the underlying libwayland resource was
--- destroyed. This is realized using an IORef which is set to nullPtr once the resource is destroyed. The IORef itself
--- is used for equality checks.
+-- destroyed. However, actions using the object (like sending events to it) will fail.
 --
 -- In addition, a custom type-erased cleanup action is stored which is invoked once the resource is destroyed.
 data AnyObject
-  = AnyObject { objName        :: StableName (IORef WLResource) -- ^ Name used for hashing and ordering.
-              , objResource    :: IORef WLResource              -- ^ Reference to the underlying resource.
-              , objDestroyHook :: AnyObject -> IO ()            -- ^ Function executed after the object was destroyed.
+  = AnyObject { objHandle      :: Handle WLResource  -- ^ The underlying resource.
+              , objDestroyHook :: AnyObject -> IO () -- ^ Function executed after the object was destroyed.
               }
 
 -- | Handle to an object which has not yet been created but has an ID assigned by the client.
 --
--- This handle can be used to create an object.
+-- This handle can be used to create an object. It is a programmer error to use it more than once.
 data NewObject o
   = NewObject { newClient  :: !Client            -- ^ The client this object is associated with.
               , newID      :: !Word32            -- ^ Object ID of the new object.
-              , newVersion :: !CInt              -- ^ Protocol version to use for the newly created object.
               , newObject  :: !(IORef (Maybe o)) -- ^ Reference to the object, assigned when it is created.
               }
 
@@ -180,51 +172,42 @@ data ObjectCache
 -- | A state monad providing an instance of 'ObjectCache'.
 type ObjectCacheState = StateT ObjectCache IO
 
--- | State used when iterating over a fixed number of wl_arguments.
-data ArgumentIterator
-  = ArgumentIterator { _argNext          :: !(Ptr WLArgument) -- ^ Pointer to the next argument to be processed.
-                     , _argRemaining     :: !Int              -- ^ Number of remaining arguments in the list.
-                     }
+-- | State used when iterating over a buffer of wl_arguments.
+newtype ArgumentIterator = ArgumentIterator (Ptr WLArgument)
 
--- | A state monad providing an instance of 'ArgumentIterator'.
+-- | Monad used for writing arguments into a wl_argument buffer.
 --
 -- The monad wraps a ContT monad to allow using alloca when wrapping arguments.
-newtype ArgumentIteratorState r a
-  = ArgumentIteratorState { runArgumentIteratorState :: StateT ArgumentIterator (ContT r IO) a }
+newtype ArgumentWriter r a = ArgumentWriter { runArgumentWriter :: StateT ArgumentIterator (ContT r IO) a }
   deriving (Functor, Applicative, Monad, MonadState ArgumentIterator, MonadIO)
 
-makeLenses ''ObjectCache
-makeLenses ''ArgumentIterator
+-- | Monad used for reading arguments from a wl_argument buffer.
+newtype ArgumentReader a = ArgumentReader { runArgumentReader :: StateT ArgumentIterator (ReaderT Client IO) a }
+  deriving (Functor, Applicative, Monad, MonadState ArgumentIterator, MonadIO, MonadReader Client)
 
-instance Show Request where
-  show (Request r) = show r
-
--- | Try to cast a type-erased request into a concrete 'RequestClass'.
-fromRequest :: RequestClass a => Request -> Maybe a
-fromRequest (Request x) = cast x
+makeLenses ''ObjectCache
 
 instance Eq AnyObject where
-  a == b = objResource a == objResource b
+  a == b = objHandle a == objHandle b
 
 instance Ord AnyObject where
-  a <= b = hash (objName a) <= hash (objName b)
+  a <= b = objHandle a <= objHandle b
 
 instance Hashable AnyObject where
-  hashWithSalt s o = hashWithSalt s (objName o)
+  hashWithSalt s o = hashWithSalt s (objHandle o)
 
 instance Show AnyObject where
-  show o = "AnyObject " ++ show (hash (objName o))
+  show o = show (objHandle o)
 
 instance Show (NewObject o) where
   show o = "NewObject " ++ show (newClient o) ++ " " ++ show (newID o)
 
 -- | Create a handle to an object that has yet to be created.
-createNewObject :: Client -> Word32 -> CInt -> IO (NewObject o)
-createNewObject client objID version = do
+createNewObject :: Client -> Word32 -> IO (NewObject o)
+createNewObject client objID = do
   obj <- newIORef Nothing
   pure $ NewObject { newClient  = client
                    , newID      = objID
-                   , newVersion = version
                    , newObject  = obj
                    }
 
@@ -251,10 +234,7 @@ destroyObjectCache c = do
 --
 -- This function may raise an error if the underlying resource is no longer alive.
 unwrapResource :: Object o => o -> IO WLResource
-unwrapResource o = fetch (toAny o)
-  where fetch obj = readIORef (objResource obj) >>= check
-        check res@(WLResource ptr) | ptr == nullPtr = error "Invalid object handle."
-                                   | otherwise      = pure res
+unwrapResource o = resolveHandle (objHandle (toAny o))
 
 -- | Get the typed object wrapping a Wayland resource.
 --
@@ -271,39 +251,38 @@ destroyResource :: WLResource -> IO ()
 destroyResource res = do
   objPtr <- castPtrToStablePtr <$> wlResourceGetUserData res
   obj <- deRefStablePtr objPtr
-  writeIORef (objResource obj) (WLResource nullPtr)
+  invalidateHandle (objHandle obj)
   freeStablePtr objPtr
-  -- TODO: Prevent destroy hook from being invoked while in the request handler.
   objDestroyHook obj obj
 
 -- | Create a new Wayland resource and associate it with a typed object wrapper.
 --
 -- This not only creates the object but also attaches a dispatch function to it and updates the destroy callback.
 createResource
-  :: forall o destroyReq. Object o
-  => RequestClass destroyReq
-  => (Request -> IO ()) -- ^ Request handler used for dispatching object requests and the destroy hook.
+  :: forall o destroyMsg. Object o
+  => MessageClass destroyMsg
+  => (Message -> IO ()) -- ^ Message handler used for dispatching object requests and the destroy hook.
   -> NewObject o        -- ^ Handle describing the object to be created
-  -> (o -> destroyReq)  -- ^ Function creating a request dispatched after the object was destroyed.
+  -> (o -> destroyMsg)  -- ^ Function creating a message dispatched after the object was destroyed.
   -> ObjectCacheState o -- ^ State monad returning the newly created object.
-createResource handle newObj destroyHook = do
+createResource handler newObj destroyHook = do
   existing <- liftIO $ readIORef (newObject newObj)
   case existing of
-    Just obj -> pure obj
-    Nothing  -> do typeInfo <- resolveTypeInfo (Proxy :: Proxy o)
-                   destroyFunc <- use cacheDestroyFunc
-                   liftIO $ do
-                     client <- unwrapClient (newClient newObj)
-                     res <- wlResourceCreate client (typeInterface typeInfo) (newVersion newObj) (newID newObj)
-                     resRef <- newIORef res
-                     name <- makeStableName resRef
-                     let obj = fromAny $ AnyObject { objName        = name
-                                                   , objResource    = resRef
-                                                   , objDestroyHook = handle . Request . destroyHook . fromAny
-                                                   }
-                     objPtr <- newStablePtr obj
-                     wlResourceSetDispatcher res (typeDispatchFunc typeInfo) nullPtr (castStablePtrToPtr objPtr) destroyFunc
-                     pure obj
+    Just _  -> error "The NewObject instance was already used to create an object."
+    Nothing -> do typeInfo <- resolveTypeInfo (Proxy :: Proxy o) handler
+                  destroyFunc <- use cacheDestroyFunc
+                  liftIO $ do
+                    let version = Wayland.Server.Interface.ifVersion (describeInterface (Proxy :: Proxy o))
+                    client <- unwrapClient (newClient newObj)
+                    res <- wlResourceCreate client (typeInterface typeInfo) (fromIntegral version) (newID newObj)
+                    handle <- createHandle res
+                    let obj = fromAny $ AnyObject { objHandle      = handle
+                                                  , objDestroyHook = handler . Message . destroyHook . fromAny
+                                                  }
+                    objPtr <- newStablePtr obj
+                    wlResourceSetDispatcher res (typeDispatchFunc typeInfo) nullPtr (castStablePtrToPtr objPtr) destroyFunc
+                    writeIORef (newObject newObj) (Just obj)
+                    pure obj
 
 -- | Send an event for a typed object.
 --
@@ -313,32 +292,36 @@ sendResourceEvent o e = do
   let paramCount = length $ msgArguments (eventSignature (Proxy :: Proxy o) e)
   res <- unwrapResource o
   allocaArray0 paramCount $ \buffer ->
-    let s = ArgumentIterator { _argNext      = buffer
-                             , _argRemaining = paramCount
-                             }
-        handler (opcode, _) = wlResourcePostEventArray res (fromIntegral opcode) buffer
-    in runContT (runStateT (runArgumentIteratorState (marshalEvent (Proxy :: Proxy o) e)) s) handler
+    runContT (runStateT (runArgumentWriter (marshalEvent (Proxy :: Proxy o) e)) (ArgumentIterator buffer)) $ \(opcode, _) ->
+      wlResourcePostEventArray res (fromIntegral opcode) buffer
 
 -- | Request handler for a typed object.
 --
 -- This provides a WLDispatcherFunc for an object type.
-dispatchResourceRequest :: forall o. Object o => Proxy o -> Ptr () -> WLResource -> Word32 -> Ptr WLMessage -> Ptr WLArgument -> IO CInt
-dispatchResourceRequest _ _ res _ _ _ = do
-  _ :: o <- wrapResource res
-  -- TODO: Handle request
+dispatchResourceRequest :: forall o. Object o => Proxy o -> (Message -> IO ()) -> Ptr () -> WLResource -> Word32 -> Ptr WLMessage -> Ptr WLArgument -> IO CInt
+dispatchResourceRequest _ handler _ res opcode _ args = do
+  obj :: o <- wrapResource res
+  client <- wlResourceGetClient res >>= wrapClient
+  (req, _) <- runReaderT (runStateT (runArgumentReader (demarshalRequest obj (fromIntegral opcode))) (ArgumentIterator args)) client
+  handler $ Message req
   pure 0
 
 -- | Resolve a type information for an object type.
 --
 -- This will first attempt to use an existing instance from the 'ObjectCache'. If there is none, it will create a new
 -- structure storing the wl_interface pointer and allocating a function pointer to the typed dispatcher function.
-resolveTypeInfo :: Object o => Proxy o -> ObjectCacheState TypeInfo
-resolveTypeInfo proxy = do
+resolveTypeInfo
+  :: Object o
+  => Proxy o                   -- ^ Proxy for the object type to resolve.
+  -> (Message -> IO ())        -- ^ Message handler used to dispatch requests in the type's dispatch func.
+  -> ObjectCacheState TypeInfo -- ^ State monad wrapping the type information.
+resolveTypeInfo proxy handler = do
   existing <- use cacheTypeInfo
   case M.lookup (typeRep proxy) existing of
     Just info -> pure info
-    Nothing   -> do interface    <- zoom cacheInterfaces $ resolveInterface (describeInterface proxy)
-                    dispatchFunc <- liftIO $ wrapWLDispatcherFunc (dispatchResourceRequest proxy)
+    Nothing   -> do let desc = describeInterface proxy
+                    interface    <- zoom cacheInterfaces $ resolveInterface desc
+                    dispatchFunc <- liftIO $ wrapWLDispatcherFunc (dispatchResourceRequest proxy handler)
                     let info = TypeInfo { typeInterface    = interface
                                         , typeDispatchFunc = dispatchFunc
                                         }
@@ -346,24 +329,27 @@ resolveTypeInfo proxy = do
                     pure info
 
 -- | Resolve the native interface for an object type.
-resolveTypeInterface :: Object o => Proxy o -> ObjectCacheState (Ptr WLInterface)
-resolveTypeInterface proxy = typeInterface <$> resolveTypeInfo proxy
+resolveTypeInterface
+  :: Object o
+  => Proxy o                            -- ^ Proxy for the object type to resolve.
+  -> (Message -> IO ())                 -- ^ Message handler used to dispatch requests in the type's dispatch func.
+  -> ObjectCacheState (Ptr WLInterface) -- ^ State monad wrapping the native interface.
+resolveTypeInterface proxy handler = typeInterface <$> resolveTypeInfo proxy handler
 
 -- | Get the next argument in an argument iterator.
 --
 -- This function may raise an error if there is no more argument remaining.
-advanceIterator :: ArgumentIteratorState r (Ptr WLArgument)
+advanceIterator :: MonadState ArgumentIterator m => m (Ptr WLArgument)
 advanceIterator = do
-  next      <- argNext      <<%= \p -> plusPtr p (sizeOf (undefined :: WLArgument))
-  remaining <- argRemaining <<%= (+(-1))
-  when (remaining == 0) (error "Out of range for argument")
-  pure next
+  ArgumentIterator arg <- get
+  put $ ArgumentIterator $ plusPtr arg (sizeOf (undefined :: WLArgument))
+  pure arg
 
--- | Create an 'ArgumentIteratorState' wrapping a continuation (like alloca).
-liftCont :: ((a -> IO r) -> IO r) -> ArgumentIteratorState r a
-liftCont = ArgumentIteratorState . lift . ContT
+-- | Create an 'ArgumentWriter' wrapping a continuation (like alloca).
+liftCont :: ((a -> IO r) -> IO r) -> ArgumentWriter r a
+liftCont = ArgumentWriter . lift . ContT
 
-instance ArgumentMarshaller (ArgumentIteratorState r) where
+instance ArgumentMarshaller (ArgumentWriter r) where
   marshalInt v = do
     arg <- advanceIterator
     liftIO $ wlArgumentPokeInt arg (fromIntegral v)
@@ -373,7 +359,7 @@ instance ArgumentMarshaller (ArgumentIteratorState r) where
   marshalFixed v = do
     arg <- advanceIterator
     liftIO $ wlArgumentPokeFixed arg (WLFixed (round (v * 256)))
-  marshalFD v = do
+  marshalFD (Fd v) = do
     arg <- advanceIterator
     liftIO $ wlArgumentPokeFD arg (fromIntegral v)
   marshalString v = do
@@ -385,8 +371,8 @@ instance ArgumentMarshaller (ArgumentIteratorState r) where
     obj <- liftIO $ unwrapResource v
     liftIO $ wlArgumentPokeObject arg obj
   marshalNewID v = do
-    -- TODO
-    undefined
+    arg <- advanceIterator
+    liftIO $ wlArgumentPokeNewID arg (newID v)
   marshalArray v = do
     arg <- advanceIterator
     let len = fromIntegral $ length v * sizeOf (head v)
@@ -397,7 +383,7 @@ instance ArgumentMarshaller (ArgumentIteratorState r) where
                                      }
     liftIO $ wlArgumentPokeArray arg arr
 
-instance ArgumentDemarshaller (ArgumentIteratorState r) where
+instance ArgumentDemarshaller ArgumentReader where
   demarshalInt    = fromIntegral   <$> (advanceIterator >>= liftIO . wlArgumentPeekInt)
   demarshalUInt   = fromIntegral   <$> (advanceIterator >>= liftIO . wlArgumentPeekUInt)
   demarshalFixed  = wlFixedToFloat <$> (advanceIterator >>= liftIO . wlArgumentPeekFixed)
@@ -408,10 +394,11 @@ instance ArgumentDemarshaller (ArgumentIteratorState r) where
     ptr <- advanceIterator >>= liftIO . wlArgumentPeekObject
     liftIO $ wrapResource ptr
   demarshalNewID = do
-    -- TODO
-    undefined
+    objID <- advanceIterator >>= liftIO . wlArgumentPeekNewID
+    client <- ask
+    liftIO $ createNewObject client objID
   demarshalArray = do
     ptr <- advanceIterator >>= liftIO . wlArgumentPeekArray
     arr <- liftIO $ peek ptr
     liftIO $ peekArray (fromIntegral (arrSize arr)) (castPtr (arrData arr))
-  demarshalFD = advanceIterator >>= liftIO . wlArgumentPeekFD
+  demarshalFD = Fd . fromIntegral <$> (advanceIterator >>= liftIO . wlArgumentPeekFD)