module I3IPC
(
getSocketPath
, getSwaySocketPath
, Response(..)
, subscribe
, subscribeM
, receive
, receive'
, receiveMsg
, receiveMsg'
, getReply
, connecti3
, connectsway
, receiveEvent
, receiveEvent'
, runCommand
, runCommand'
, getWorkspaces
, getWorkspaces'
, getOutputs
, getOutputs'
, getTree
, getTree'
, getMarks
, getMarks'
, getVersion
, getVersion'
, getBarConfig
, getBarConfig'
, getBarIds
, getBindingModes
, getBindingModes'
, getConfig
, getConfig'
, getTick
, getTick'
, getSync
, getSync'
)
where
import qualified I3IPC.Message as Msg
import qualified I3IPC.Subscribe as Sub
import qualified I3IPC.Event as Evt
import I3IPC.Reply
import Control.Monad.IO.Class
import Control.Exception ( Exception )
import Control.Monad.Catch ( MonadThrow
, throwM
)
import System.Environment ( lookupEnv )
import Data.Maybe ( isJust )
import Data.Semigroup ( (<>) )
import System.Process.Typed ( proc
, readProcess
)
import System.Exit ( ExitCode(..) )
import Network.Socket hiding ( send
, sendTo
, recv
, recvFrom
)
import Network.Socket.ByteString.Lazy
import Data.Aeson ( encode )
import Data.Binary.Get
import Data.Bifunctor ( second )
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Typeable ( Typeable )
import qualified Data.Text as T
import Data.Bits ( testBit
, clearBit
)
data I3Exception = ConnectException T.Text | ProcessException
deriving stock (Show, Eq, Typeable)
instance Exception I3Exception
getSocketPath :: MonadIO m => m (Maybe BL.ByteString)
getSocketPath = do
res <- liftIO $ lookupEnv "I3SOCK"
if isJust res
then pure $ fmap BL.pack res
else do
(exitCode, out, _) <- readProcess $ proc "i3" ["--get-socketpath"]
if exitCode /= ExitSuccess
then pure Nothing
else pure $ Just (BL.filter (/= '\n') out)
getSwaySocketPath :: MonadIO m => m (Maybe BL.ByteString)
getSwaySocketPath = fmap BL.pack <$> liftIO (lookupEnv "SWAYSOCK")
subscribe
:: (MonadThrow m, MonadIO m)
=> (Either String Evt.Event -> m ())
-> [Sub.Subscribe]
-> m ()
subscribe handle subtypes = do
soc <- connecti3
Msg.sendMsgPayload soc Msg.Subscribe (encode subtypes)
>> receiveMsg soc
>> handleSoc soc
>> liftIO (close soc)
where
handleSoc soc = do
r <- receiveEvent soc
handle r
handleSoc soc
subscribeM
:: (MonadThrow m, MonadIO m)
=> (Either String Evt.Event -> m ())
-> [Sub.Subscribe]
-> m ()
subscribeM handle subtypes = do
soc <- connecti3
Msg.sendMsgPayload soc Msg.Subscribe (encode subtypes)
>> receiveMsg soc
>> pure ()
handleSoc soc >> liftIO (close soc)
where
handleSoc soc = do
r <- receiveEvent soc
handle r
handleSoc soc
connecti3 :: (MonadThrow m, MonadIO m) => m Socket
connecti3 = do
soc <- liftIO $ socket AF_UNIX Stream 0
getSocketPath >>= \case
Nothing -> throwM $ ConnectException "Failed to get i3 socket path"
Just addr' -> do
liftIO $ connect soc (SockAddrUnix $ BL.unpack addr')
pure soc
connectsway :: (MonadThrow m, MonadIO m) => m Socket
connectsway = do
soc <- liftIO $ socket AF_UNIX Stream 0
getSwaySocketPath >>= \case
Nothing -> throwM $ ConnectException "Failed to get i3 socket path"
Just addr' -> do
liftIO $ connect soc (SockAddrUnix $ BL.unpack addr')
pure soc
data Response = Message MsgReply | Event Evt.Event deriving (Show, Eq)
getReply :: MonadIO m => Socket -> m (Either String (Int, BL.ByteString))
getReply soc = do
magic <- liftIO $ recv soc 6
if magic == "i3-ipc"
then do
len <- getInt <$> liftIO (recv soc 4)
ty <- getInt <$> liftIO (recv soc 4)
body <- liftIO $ recv soc len
pure $ Right (fromIntegral ty, body)
else pure $ Left "Failed to get reply"
where getInt = fromIntegral . runGet getWord32le
test :: Int -> BL.ByteString -> IO Int
test ty body = do
putStrLn $ "type " <> show (ty `clearBit` 31)
BL.putStrLn $ "body " <> body
BL.putStrLn ""
pure ty
receive :: MonadIO m => Socket -> m (Either String Response)
receive soc = do
reply <- getReply soc
case reply of
Right (ty, body) -> pure $ if testBit ty 31
then Event `second` Evt.toEvent (ty `clearBit` 31) body
else Message `second` toMsgReply ty body
_ -> pure $ Left "Get Reply failed"
receive' :: MonadIO m => Socket -> m (Either String Response)
receive' soc = do
reply <- getReply soc
case reply of
Right (ty, body) -> pure $ if testBit ty 31
then Event `second` Evt.toEvent' (ty `clearBit` 31) body
else Message `second` toMsgReply' ty body
_ -> pure $ Left "Get Reply failed"
receiveMsg :: MonadIO m => Socket -> m (Either String MsgReply)
receiveMsg soc = do
r <- getReply soc
pure $ do
(ty, body) <- r
toMsgReply ty body
receiveMsg' :: MonadIO m => Socket -> m (Either String MsgReply)
receiveMsg' soc = do
r <- getReply soc
pure $ do
(ty, body) <- r
toMsgReply' ty body
receiveEvent :: MonadIO m => Socket -> m (Either String Evt.Event)
receiveEvent soc = do
r <- getReply soc
pure $ do
(ty, body) <- r
Evt.toEvent (ty `clearBit` 31) body
receiveEvent' :: MonadIO m => Socket -> m (Either String Evt.Event)
receiveEvent' soc = do
r <- getReply soc
pure $ do
(ty, body) <- r
Evt.toEvent' (ty `clearBit` 31) body
runCommand :: MonadIO m => Socket -> BL.ByteString -> m (Either String MsgReply)
runCommand soc b = Msg.sendMsgPayload soc Msg.RunCommand b >> receiveMsg soc
runCommand'
:: MonadIO m => Socket -> BL.ByteString -> m (Either String MsgReply)
runCommand' soc b = Msg.sendMsgPayload soc Msg.RunCommand b >> receiveMsg' soc
getWorkspaces :: MonadIO m => Socket -> m (Either String MsgReply)
getWorkspaces soc = Msg.sendMsg soc Msg.Workspaces >> receiveMsg soc
getWorkspaces' :: MonadIO m => Socket -> m (Either String MsgReply)
getWorkspaces' soc = Msg.sendMsg soc Msg.Workspaces >> receiveMsg' soc
getOutputs :: MonadIO m => Socket -> m (Either String MsgReply)
getOutputs soc = Msg.sendMsg soc Msg.Outputs >> receiveMsg soc
getOutputs' :: MonadIO m => Socket -> m (Either String MsgReply)
getOutputs' soc = Msg.sendMsg soc Msg.Outputs >> receiveMsg' soc
getTree :: MonadIO m => Socket -> m (Either String MsgReply)
getTree soc = Msg.sendMsg soc Msg.Tree >> receiveMsg soc
getTree' :: MonadIO m => Socket -> m (Either String MsgReply)
getTree' soc = Msg.sendMsg soc Msg.Tree >> receiveMsg' soc
getMarks :: MonadIO m => Socket -> m (Either String MsgReply)
getMarks soc = Msg.sendMsg soc Msg.Marks >> receiveMsg soc
getMarks' :: MonadIO m => Socket -> m (Either String MsgReply)
getMarks' soc = Msg.sendMsg soc Msg.Marks >> receiveMsg' soc
getBarIds :: MonadIO m => Socket -> m (Either String BarIds)
getBarIds soc = do
_ <- Msg.sendMsg soc Msg.BarConfig
r <- getReply soc
pure $ do
body <- r
decodeBarIds (snd body)
getBarConfig
:: MonadIO m => Socket -> BL.ByteString -> m (Either String MsgReply)
getBarConfig soc b = Msg.sendMsgPayload soc Msg.BarConfig b >> receiveMsg' soc
getBarConfig'
:: MonadIO m => Socket -> BL.ByteString -> m (Either String MsgReply)
getBarConfig' soc b = Msg.sendMsgPayload soc Msg.BarConfig b >> receiveMsg' soc
getVersion :: MonadIO m => Socket -> m (Either String MsgReply)
getVersion soc = Msg.sendMsg soc Msg.Version >> receiveMsg soc
getVersion' :: MonadIO m => Socket -> m (Either String MsgReply)
getVersion' soc = Msg.sendMsg soc Msg.Version >> receiveMsg' soc
getBindingModes :: MonadIO m => Socket -> m (Either String MsgReply)
getBindingModes soc = Msg.sendMsg soc Msg.BindingModes >> receiveMsg soc
getBindingModes' :: MonadIO m => Socket -> m (Either String MsgReply)
getBindingModes' soc = Msg.sendMsg soc Msg.BindingModes >> receiveMsg' soc
getConfig :: MonadIO m => Socket -> m (Either String MsgReply)
getConfig soc = Msg.sendMsg soc Msg.Config >> receiveMsg soc
getConfig' :: MonadIO m => Socket -> m (Either String MsgReply)
getConfig' soc = Msg.sendMsg soc Msg.Config >> receiveMsg' soc
getTick :: MonadIO m => Socket -> m (Either String MsgReply)
getTick soc = Msg.sendMsg soc Msg.Tick >> receiveMsg soc
getTick' :: MonadIO m => Socket -> m (Either String MsgReply)
getTick' soc = Msg.sendMsg soc Msg.Tick >> receiveMsg' soc
getSync :: MonadIO m => Socket -> m (Either String MsgReply)
getSync soc = Msg.sendMsg soc Msg.Sync >> receiveMsg soc
getSync' :: MonadIO m => Socket -> m (Either String MsgReply)
getSync' soc = Msg.sendMsg soc Msg.Sync >> receiveMsg' soc