Interpreter.hs

module YMonad.Backend.River.Interpreter (
  connectRiver,
  recvEventsIO,
  flushTransportIO,
) where

import Control.Exception (bracketOnError, try)
import Data.ByteString qualified as BS
import Network.Socket
import Network.Socket.ByteString qualified as NSB
import System.FilePath ((</>))

import YMonad.Backend.River.Decode
import YMonad.Backend.River.Encode
import YMonad.Backend.River.Translate
import YMonad.Backend.River.Types
import YMonad.Core

connectRiver :: Maybe FilePath -> IO (Either BackendFault Socket)
connectRiver explicitPath = do
  resolved <- resolveSocketPath explicitPath
  case resolved of
    Left err -> pure (Left err)
    Right path -> do
      result <- (try (bracketOnError (socket AF_UNIX Stream defaultProtocol) close (\sock -> connect sock (SockAddrUnix path) >> pure sock)) :: IO (Either SomeException Socket))
      pure $ case result of
        Left ex -> Left (BackendFault ("Failed to connect to Wayland socket " <> toText path <> ": " <> toText (displayException ex)))
        Right sock -> Right sock

recvEventsIO :: Socket -> RiverRuntime -> IO (Either BackendFault (RiverRuntime, [YEvent]))
recvEventsIO sock rt = do
  recvResult <- (try (NSB.recv sock 65535) :: IO (Either SomeException BS.ByteString))
  case recvResult of
    Left ex -> pure (Left (BackendFault ("Wayland recv failed: " <> toText (displayException ex))))
    Right chunk ->
      if BS.null chunk
        then pure (Left (BackendFault "Wayland socket closed by compositor"))
        else do
          pure $ do
            (rt', callbacks) <- ingestBytes rt chunk
            events <- fmap concat (mapM decodeCallback callbacks)
            pure (rt', events)

flushTransportIO :: Socket -> RiverRuntime -> IO (Either BackendFault RiverRuntime)
flushTransportIO sock rt0 = do
  let rt1 = pumpPending rt0
      (rt2, bytes) = flushOutgoingBytes rt1
  if BS.null bytes
    then pure (Right rt2)
    else do
      sendResult <- (try (NSB.sendAll sock bytes) :: IO (Either SomeException ()))
      pure $ case sendResult of
        Left ex -> Left (BackendFault ("Wayland send failed: " <> toText (displayException ex)))
        Right () -> Right rt2

resolveSocketPath :: Maybe FilePath -> IO (Either BackendFault FilePath)
resolveSocketPath (Just path) = pure (Right path)
resolveSocketPath Nothing = do
  display <- lookupEnv "WAYLAND_DISPLAY"
  runtimeDir <- lookupEnv "XDG_RUNTIME_DIR"
  pure $ case (display, runtimeDir) of
    (Just disp, Just dir) -> Right (dir </> disp)
    (Nothing, _) -> Left (BackendFault "WAYLAND_DISPLAY is not set")
    (_, Nothing) -> Left (BackendFault "XDG_RUNTIME_DIR is not set")