path: root/wayland/Wayland/Server.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Wayland.Server
  ( Request(..)
  , ObjectID
  , Global
  , DisplayM(..)
  , ResourceClass(..)
  , RequestClass
  , InterfaceDesc(..)
  , MessageDesc(..)
  , ArgumentDesc(..)
  , Nullability(..)
  , fromRequest
  , withDisplay
  , bindSocket
  , processRequests
  , flushEvents
  , sendEvent
  , destroyResource
  , registerGlobal
  , unregisterGlobal
  , registerSignalEvent
  , requestTermination
  ) 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)
import Foreign.C.Types (CInt)
import Foreign (Ptr, nullPtr, new)
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)

data Global = Global

data ObjectID = ObjectID
  deriving (Show, Eq, Ord)

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

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 => ResourceClass r where
  type ResourceRequest r :: Type
  type ResourceEvent   r :: Type
  objectID  :: r        -> ObjectID
  fromID    :: ObjectID -> r
  interface :: Proxy r  -> InterfaceDesc

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

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
  disp <- getDisplay
  iface <- getInterface (Proxy :: Proxy r)
  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)
        runRequest disp (Request req)
        pure ()
  liftIO $ do
    func <- Sys.wrapWLGlobalBindFunc createObject
    _ <- Sys.wlGlobalCreate (display disp) iface (fromIntegral version) nullPtr func
    -- TODO: Free func
    -- TODO: Return proper Global
    pure ()
  pure Global

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 ()
registerSignalEvent r sig = do
  disp <- getDisplay
  liftIO $ do
    loop <- Sys.wlDisplayGetEventLoop (display disp)
    func <- Sys.wrapWLEventLoopSignalFunc $ \_ _ -> runRequest disp (Request r) $> 0
    _ <- Sys.wlEventLoopAddSignal loop sig func nullPtr
    -- TODO: Free func
    -- TODO: Return event source handle
    pure ()

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