diff options
Diffstat (limited to 'wayland/Wayland/Server.hs')
| -rw-r--r-- | wayland/Wayland/Server.hs | 450 |
1 files changed, 34 insertions, 416 deletions
diff --git a/wayland/Wayland/Server.hs b/wayland/Wayland/Server.hs index 30300de..61486b0 100644 --- a/wayland/Wayland/Server.hs +++ b/wayland/Wayland/Server.hs @@ -1,426 +1,44 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} +-- | +-- Module : Wayland.Server +-- Description: Low-level API for implementing the Wayland protocol. module Wayland.Server - ( Request(..) - , ObjectID - , Global - , ArgumentMarshaller(..) - , ArgumentDemarshaller(..) - , DisplayM(..) - , ResourceClass(..) - , EventClass - , RequestClass - , InterfaceDesc(..) - , MessageDesc(..) - , ArgumentDesc(..) - , Nullability(..) - , fromRequest + ( -- * The Display Monad + DisplayM , withDisplay , bindSocket + , -- * Processing Requests + Request(..) + , RequestHandler + , fromRequest , processRequests - , flushEvents - , sendEvent - , destroyResource + , requestTermination + , -- * Managing Objects + Global , registerGlobal , unregisterGlobal + , createObject + , destroyObject + , sendEvent + , flushEvents + , -- * Event Sources + EventSource , registerSignalEvent - , requestTermination + , -- * Interface Descriptions + InterfaceDesc(..) + , MessageDesc(..) + , ArgumentDesc(..) + , Nullability(..) + , -- * Object Types + Object(..) + , AnyObject + , NewObject + , RequestClass + , EventClass + , ArgumentMarshaller(..) + , ArgumentDemarshaller(..) ) where -import Data.Typeable (Typeable, Proxy(..), cast, TypeRep, typeRep) -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 qualified Wayland.Server.System as Sys -import Control.Monad.Trans (MonadTrans(..)) -import Foreign.C (peekCString, newCString, withCString) -import Foreign.C.Types (CInt) -import Foreign (Ptr, nullPtr, new, newStablePtr, castStablePtrToPtr, castPtrToStablePtr, deRefStablePtr, freeStablePtr, Storable(..), Int32, castPtr, withArray, with, allocaArray0, FunPtr, plusPtr) -import Data.IORef (IORef, newIORef, writeIORef, readIORef) -import Control.Monad.Reader (ReaderT, MonadReader(..), runReaderT) -import Control.Exception (bracket) -import Data.Functor (($>)) -import Control.Monad (when) -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 Control.Monad.Cont (ContT(..)) - -data EventSource = EventSource (FunPtr Sys.WLEventLoopSignalFunc) (IORef Sys.WLEventSource) - deriving (Eq) - -data Global = Global (FunPtr Sys.WLGlobalBindFunc) (IORef Sys.WLGlobal) - deriving (Eq) - --- 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 - | NotNull - deriving (Show, Eq, Ord) - -data ArgumentDesc - = ArgumentInt - | ArgumentUInt - | ArgumentFixed - | ArgumentString !Nullability - | ArgumentObject !Nullability !InterfaceDesc - | ArgumentNewID !InterfaceDesc - | ArgumentArray - | ArgumentFD - deriving (Show, Eq, Ord) - -data MessageDesc - = MessageDesc { msgName :: !String - , msgSignature :: ![ArgumentDesc] - , msgSince :: !Int - , msgIsDestructor :: !Bool - } - deriving (Show, Eq, Ord) - -data InterfaceDesc - = InterfaceDesc { ifName :: !String - , ifVersion :: !Int - , ifRequests :: ![MessageDesc] - , ifEvents :: ![MessageDesc] - } - deriving (Show, Eq, Ord) - -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 } - deriving (Functor, Applicative, Monad, MonadIO, MonadState s, MonadFail) - -type RequestHandler s = Request -> DisplayM s () - -newtype EventLoop = EventLoop { handleEvent :: Request -> IO () } - -data Display - = Display { display :: !Sys.WLDisplay - , activeEventLoop :: !(IORef (Maybe EventLoop)) - } - -data DisplayState - = DisplayState { _typeInterfaces :: !(M.Map TypeRep (Ptr Sys.WLInterface)) - , _nativeInterfaces :: !(M.Map InterfaceDesc (Ptr Sys.WLInterface)) - } - -makeLenses ''DisplayState - -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 - -type instance Zoomed (DisplayM s) = Zoomed (StateT s (StateT DisplayState (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 $ lift ask - -liftDisplayState :: StateT DisplayState (ReaderT Display IO) a -> DisplayM s a -liftDisplayState m = DisplayM $ lift m - -fromRequest :: Typeable a => Request -> Maybe a -fromRequest (Request x) = cast x - -withDisplay :: s -> DisplayM s a -> IO (a, s) -withDisplay initialState f = bracket Sys.wlDisplayCreate Sys.wlDisplayDestroy $ \sysDisp -> do - eventLoop <- newIORef Nothing - let disp = Display { display = sysDisp - , activeEventLoop = eventLoop - } - dispState = DisplayState { _typeInterfaces = M.empty - , _nativeInterfaces = M.empty - } - (res, _) <- runReaderT (runStateT (runStateT (runDisplayM f) initialState) dispState) disp - pure res - -bindSocket :: DisplayM s String -bindSocket = do - disp <- getDisplay - name <- liftIO $ Sys.wlDisplayAddSocketAuto (display disp) - liftIO $ peekCString name - -processRequests :: RequestHandler s -> DisplayM s () -processRequests h = do - disp <- getDisplay - stateBefore <- get - displayStateBefore <- liftDisplayState get - stateRef <- liftIO $ newIORef (stateBefore, displayStateBefore) - let handler :: Request -> IO () - handler r = do - (s, ds) <- readIORef stateRef - ((_, s'), ds') <- runReaderT (runStateT (runStateT (runDisplayM (h r)) s) ds) disp - writeIORef stateRef (s', ds') - loop <- liftIO $ readIORef (activeEventLoop disp) - when (isJust loop) (fail "Cannot start an event loop from within an event handler.") - liftIO $ writeIORef (activeEventLoop disp) (Just (EventLoop handler)) - liftIO $ Sys.wlDisplayRun (display disp) - (stateAfter, displayStateAfter) <- liftIO $ readIORef stateRef - put stateAfter - liftDisplayState $ put displayStateAfter - -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 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 dis and des - Sys.wlResourceSetDispatcher res dis nullPtr (castStablePtrToPtr handlePtr) des - let req = mkBindReq (fromID objID) - runRequest disp (Request req) - pure () - liftIO $ do - func <- Sys.wrapWLGlobalBindFunc createObject - global <- Sys.wlGlobalCreate (display disp) iface (fromIntegral version) nullPtr func - globalRef <- newIORef global - -- TODO: Free func - pure $ Global func globalRef - -unregisterGlobal :: Global -> DisplayM s () -unregisterGlobal _ = pure () - -runRequest :: Display -> Request -> IO () -runRequest disp r = do - loop <- readIORef (activeEventLoop disp) - case loop of - Just handler -> handleEvent handler r - Nothing -> putStrLn $ "Lost request because no event loop is active: " ++ show r - -registerSignalEvent :: RequestClass req => req -> CInt -> DisplayM s EventSource -registerSignalEvent r sig = do - disp <- getDisplay - liftIO $ do - loop <- Sys.wlDisplayGetEventLoop (display disp) - func <- Sys.wrapWLEventLoopSignalFunc $ \_ _ -> runRequest disp (Request r) $> 0 - src <- Sys.wlEventLoopAddSignal loop sig func nullPtr - srcRef <- newIORef src - -- TODO: Free func - pure $ EventSource func srcRef - -requestTermination :: DisplayM s () -requestTermination = do - disp <- getDisplay - liftIO $ Sys.wlDisplayTerminate (display disp) - -wrapInterface :: InterfaceDesc -> DisplayM s (Ptr Sys.WLInterface) -wrapInterface i = do - let mkArgumentType :: ArgumentDesc -> DisplayM s (Ptr Sys.WLInterface) - mkArgumentType (ArgumentObject _ a) = wrapInterface a - mkArgumentType (ArgumentNewID a) = wrapInterface a - mkArgumentType _ = pure nullPtr - let mkArgument :: ArgumentDesc -> String - mkArgument ArgumentInt = "i" - mkArgument ArgumentUInt = "u" - mkArgument ArgumentFixed = "f" - mkArgument (ArgumentString NotNull) = "s" - mkArgument (ArgumentString AllowNull) = "?s" - mkArgument (ArgumentObject NotNull _) = "o" - mkArgument (ArgumentObject AllowNull _) = "?o" - mkArgument (ArgumentNewID _) = "n" - mkArgument ArgumentArray = "a" - mkArgument ArgumentFD = "h" - let mkMessage :: MessageDesc -> DisplayM s Sys.WLMessage - mkMessage m = do - name <- liftIO $ newCString (msgName m) - signature <- liftIO $ newCString (show (msgSince m) ++ (msgSignature m >>= mkArgument)) - types <- mapM mkArgumentType (msgSignature m) >>= liftIO . newArray - pure $ Sys.WLMessage { Sys.msgName = name - , Sys.msgSignature = signature - , Sys.msgTypes = types - } - let mkInterface :: DisplayM s (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 - } - existing <- liftDisplayState $ use nativeInterfaces - case M.lookup i existing of - Just ptr -> pure ptr - Nothing -> do ptr <- mkInterface - -- TODO: Free ptr - liftDisplayState $ nativeInterfaces %= M.insert i ptr - pure ptr - -getInterface :: ResourceClass r => Proxy r -> DisplayM s (Ptr Sys.WLInterface) -getInterface p = do - existing <- liftDisplayState $ use typeInterfaces - case M.lookup (typeRep p) existing of - Just ptr -> pure ptr - Nothing -> do ptr <- wrapInterface (interface p) - liftDisplayState $ typeInterfaces %= M.insert (typeRep p) ptr - pure ptr - -data ArgumentIteratorState - = ArgumentIteratorState { _argNext :: !(Ptr Sys.WLArgument) - , _argRemaining :: !Int - } - deriving (Show) - -makeLenses ''ArgumentIteratorState - -newtype ArgumentIterator r a = ArgumentIterator { runArgumentIterator :: StateT ArgumentIteratorState (ContT r IO) a } - deriving (Functor, Applicative, Monad, MonadFail, MonadState ArgumentIteratorState, MonadIO) - -advanceIterator :: ArgumentIterator r (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 Sys.WLResource -getObjectForHandle r = fetch (objectID r) - where fetch (ObjectID _ handle) = readIORef handle >>= check - check res@(Sys.WLResource ptr) | ptr == nullPtr = fail "Invalid object handle." - | otherwise = pure res - -liftCont :: ((a -> IO r) -> IO r) -> ArgumentIterator r a -liftCont = ArgumentIterator . lift . ContT - -instance ArgumentMarshaller (ArgumentIterator r) where - marshalInt v = do - arg <- advanceIterator - liftIO $ Sys.wlArgumentPokeInt arg (fromIntegral v) - marshalUInt v = do - arg <- advanceIterator - liftIO $ Sys.wlArgumentPokeUInt arg (fromIntegral v) - marshalFixed v = do - arg <- advanceIterator - liftIO $ Sys.wlArgumentPokeFixed arg (Sys.WLFixed (round (v * 256))) - marshalFD v = do - arg <- advanceIterator - liftIO $ Sys.wlArgumentPokeFD arg (fromIntegral v) - marshalString v = do - arg <- advanceIterator - str <- liftCont $ withCString v - liftIO $ Sys.wlArgumentPokeString arg str - marshalObject v = do - arg <- advanceIterator - obj <- liftIO $ getObjectForHandle v - liftIO $ Sys.wlArgumentPokeObject arg obj - marshalNewID v = do - arg <- advanceIterator - obj <- liftIO $ getObjectForHandle v - liftIO $ Sys.wlArgumentPokeObject arg obj - marshalArray v = do - arg <- advanceIterator - let len = fromIntegral $ length v * sizeOf (head v) - buf <- liftCont $ withArray v - arr <- liftCont $ with $ Sys.WLArray { Sys.arrSize = len - , Sys.arrAlloc = len - , Sys.arrData = castPtr buf - } - liftIO $ Sys.wlArgumentPokeArray arg arr - -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 - allocaArray0 (length params) $ \buffer -> - let s = ArgumentIteratorState { _argNext = buffer - , _argRemaining = length params - } - handler (opcode, _) = Sys.wlResourcePostEventArray ptr (fromIntegral opcode) buffer - in runContT (runStateT (runArgumentIterator (marshalEvent (Proxy :: Proxy r) e)) s) handler - -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 ptr +import Wayland.Server.Interface +import Wayland.Server.Object +import Wayland.Server.Display |