wip refactoring

1 files changed, 159 insertions, 0 deletions

diff --git a/wayland/Wayland/Server/Interface.hs b/wayland/Wayland/Server/Interface.hs
new file mode 100644
index 0000000..07cc34e
--- /dev/null
+++ b/wayland/Wayland/Server/Interface.hs
@@ -0,0 +1,159 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+-- |
+-- Module     : Wayland.Server.Interface
+-- Description: Description of the API for an object.
+--
+-- This module provides data types for describing the requests and events supported by a Wayland object. This is used
+-- for marshalling/demarshalling the message using the binary wire protocol.
+--
+-- In addition, this module provides support for converting interface descriptions into their C equivalents and caching
+-- the results (ensuring pointer equality for the same interface).
+
+module Wayland.Server.Interface
+  ( -- * Interface Descriptions
+    InterfaceDesc(..)
+  , MessageDesc(..)
+  , ArgumentDesc(..)
+  , Nullability(..)
+  , -- * Native Interfaces
+    InterfaceCache
+  , InterfaceCacheState
+  , newInterfaceCache
+  , destroyInterfaceCache
+  , resolveInterface
+  ) where
+
+import Control.Monad.State.Strict (MonadState(..), StateT)
+import Control.Monad.Trans (MonadIO(..))
+import Foreign (Ptr, nullPtr, newArray, new, free, peekArray, Storable(..))
+import Foreign.C (newCString)
+import qualified Wayland.Server.System as Sys
+import qualified Data.Map as M
+
+-- | Description of a Wayland interface and the functionality it provides.
+--
+-- This is analogous to the wl_interface structure in libwayland and is converted into it as needed.
+--
+-- An interface can be implemented by an object which is associated with a client.
+data InterfaceDesc
+  = InterfaceDesc { ifName     :: !String        -- ^ Name of the interface (for example, "wl_output").
+                  , ifVersion  :: !Int           -- ^ Version of the interface described in this data structure.
+                  , ifRequests :: ![MessageDesc] -- ^ The requests a server should handle to implement the interface.
+                  , ifEvents   :: ![MessageDesc] -- ^ The events sent out by a server for instances of the interface.
+                  }
+  deriving (Show, Eq, Ord)
+
+-- | Description of a message sent between the server and a client (either a request or an event).
+--
+-- A message operates on an object implementing an interface.
+data MessageDesc
+  = MessageDesc { msgName              :: !String         -- ^ Name of the protocol message.
+                , msgArguments         :: ![ArgumentDesc] -- ^ The argument types passed to the message.
+                , msgSince             :: !Int            -- ^ Protocol version where the message was introduced.
+                , msgIsDestructor      :: !Bool           -- ^ Indicates whether this is a request to destroy an object.
+                }
+  deriving (Show, Eq, Ord)
+
+-- | Description of an argument in the signature of a message.
+data ArgumentDesc
+  = ArgumentInt
+  | ArgumentUInt
+  | ArgumentFixed
+  | ArgumentString !Nullability
+  | ArgumentObject !Nullability !InterfaceDesc
+  | ArgumentNewID               !InterfaceDesc
+  | ArgumentArray
+  | ArgumentFD
+  deriving (Show, Eq, Ord)
+
+-- | Describes whether a string/object argument in a message is optional.
+data Nullability
+  = Nullable
+  | NotNull
+  deriving (Show, Eq, Ord)
+
+-- | State used to cache C interfaces.
+--
+-- The wl_interface instances are cached so the same interface description always yields the same wl_interface pointer.
+newtype InterfaceCache = InterfaceCache (M.Map InterfaceDesc (Ptr Sys.WLInterface))
+
+-- | A state monad providing an instance of 'InterfaceCache'.
+type InterfaceCacheState = StateT InterfaceCache IO
+
+-- | Initialize an interface cache.
+newInterfaceCache :: IO InterfaceCache
+newInterfaceCache = pure $ InterfaceCache M.empty
+
+-- | Destroy an interface cache, freeing all acquired resources.
+--
+-- This should only be done after no wl_interface instances are referenced as it will free their underlying memory.
+destroyInterfaceCache :: InterfaceCache -> IO ()
+destroyInterfaceCache (InterfaceCache m) =
+  let freeMessage :: Sys.WLMessage -> IO ()
+      freeMessage msg = do
+        free (Sys.msgName msg)
+        free (Sys.msgSignature msg)
+        free (Sys.msgTypes msg)
+      freeInterface :: Ptr Sys.WLInterface -> IO ()
+      freeInterface iface = do
+        iface' <- peek iface
+        peekArray (fromIntegral (Sys.ifMethodCount iface')) (Sys.ifMethods iface') >>= mapM_ freeMessage
+        peekArray (fromIntegral (Sys.ifEventCount iface'))  (Sys.ifEvents iface')  >>= mapM_ freeMessage
+        free (Sys.ifName iface')
+        free (Sys.ifMethods iface')
+        free (Sys.ifEvents iface')
+        free iface
+  in mapM_ freeInterface m
+
+-- | Resolve a native wl_interface pointer for an interface description.
+--
+-- This will first attempt to use an existing instance from the 'InterfaceCache'. If there is none, it will create a new
+-- native interface and put it in the cache. Resources are freed using 'destroyInterfaceCache'.
+--
+-- Resolving an interface may also require resolving other interfaces used as arguments, thus this function is
+-- implemented recursively.
+resolveInterface :: InterfaceDesc -> InterfaceCacheState (Ptr Sys.WLInterface)
+resolveInterface i = do
+  let mkArgumentType :: ArgumentDesc -> InterfaceCacheState (Ptr Sys.WLInterface)
+      mkArgumentType (ArgumentObject _ a) = resolveInterface a
+      mkArgumentType (ArgumentNewID a)    = resolveInterface a
+      mkArgumentType _                    = pure nullPtr
+  let mkArgument :: ArgumentDesc -> String
+      mkArgument ArgumentInt                 = "i"
+      mkArgument ArgumentUInt                = "u"
+      mkArgument ArgumentFixed               = "f"
+      mkArgument (ArgumentString NotNull)    = "s"
+      mkArgument (ArgumentString Nullable)   = "?s"
+      mkArgument (ArgumentObject NotNull _)  = "o"
+      mkArgument (ArgumentObject Nullable _) = "?o"
+      mkArgument (ArgumentNewID _)           = "n"
+      mkArgument ArgumentArray               = "a"
+      mkArgument ArgumentFD                  = "h"
+  let mkMessage :: MessageDesc -> InterfaceCacheState Sys.WLMessage
+      mkMessage m = do
+        name      <- liftIO $ newCString (msgName m)
+        signature <- liftIO $ newCString (show (msgSince m) ++ (msgArguments m >>= mkArgument))
+        types     <- mapM mkArgumentType (msgArguments m) >>= liftIO . newArray
+        pure $ Sys.WLMessage { Sys.msgName      = name
+                             , Sys.msgSignature = signature
+                             , Sys.msgTypes     = types
+                             }
+  let mkInterface :: InterfaceCacheState (Ptr Sys.WLInterface)
+      mkInterface = do
+        name    <- liftIO $ newCString (ifName i)
+        methods <- mapM mkMessage (ifRequests i) >>= liftIO . newArray
+        events  <- mapM mkMessage (ifEvents   i) >>= liftIO . newArray
+        liftIO $ new $ Sys.WLInterface { Sys.ifName = name
+                                       , Sys.ifVersion = fromIntegral (ifVersion i)
+                                       , Sys.ifMethodCount = fromIntegral (length (ifRequests i))
+                                       , Sys.ifMethods     = methods
+                                       , Sys.ifEventCount  = fromIntegral (length (ifEvents i))
+                                       , Sys.ifEvents      = events
+                                       }
+  InterfaceCache existing <- get
+  case M.lookup i existing of
+    Just ptr -> pure ptr
+    Nothing  -> do ptr <- mkInterface
+                   put $ InterfaceCache $ M.insert i ptr existing
+                   pure ptr