diff options
Diffstat (limited to 'wayland/Wayland/Server.hs')
| -rw-r--r-- | wayland/Wayland/Server.hs | 175 |
1 files changed, 154 insertions, 21 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) |