> {-# LANGUAGE BlockArguments #-}
> {-# LANGUAGE OverloadedStrings #-}
> {-# LANGUAGE LambdaCase #-}
>
> import qualified Data.Text.IO as T
> import Data.Foldable (for_)
> import Control.Monad (forever)
> import Control.Exception (handle)
> import System.Environment (getArgs)
> import qualified Network.WebSockets as WS
> import Control.Concurrent.Async (concurrently_)
> import Control.Concurrent (threadDelay)
>
> import Buttplug.Core
A `Connector` represents a method of connecting to a Buttplug server, and
contains all of the necessary information required to connect.
Connectors for secure and insecure websockets are included in this
library. You can create your own using the Connector typeclass.
Here we use an insecure websocket connector. If your server is running
somewhere other than localhost:12345, you'll need to pass the port and host as
command line args.
> main :: IO ()
> main = do
> args <- getArgs
> let (host, port) = case args of
> [host, port] -> (host, read port)
> [host] -> (host, 12345)
> [] -> ("localhost", 12345)
> _ -> error "Too many args!"
> connector =
> InsecureWebSocketConnector { insecureWSConnectorHost = host
> , insecureWSConnectorPort = port }
> clientName = "Haskell-example-buttplug-client"
`runClient` is responsible for establishing and closing the connection.
We pass it a function which takes a connection and returns an IO action,
which will make use of that connection to send and receive Buttplug messages.
The ConnectorException encapsulates the exceptions that can occur in the course
of a connection to a Buttplug server.
Once we've established a connection, we need to perform a handshake with the
server. A Buttplug handshake involves sending the server a RequestServerInfo
message.
We use the sendMessage function to send messages.
The server will reply with a ServerInfo message.
See https://buttplug-spec.docs.buttplug.io/architecture.html#stages
for details and diagrams.
> handle handleConnectorException $ runClient connector \con -> do
> putStrLn "Beginning handshake..."
> sendMessage con
> MsgRequestServerInfo { msgId = 1
> , msgClientName = clientName
> , msgMessageVersion = clientMessageVersion
> }
We receive messages using the receiveMsgs function. The server should reply
with ServerInfo to complete the handshake.
> receiveMsgs con >>= \case
> [MsgServerInfo 1 servName msgVersion maxPingTime] -> do
> T.putStrLn $ "Successfully connected to server \"" <> servName <> "\"!"
> putStrLn $ "Message version: " <> show msgVersion <>
> "\nMax ping time (ms): " <> show maxPingTime
Once we have successfully connected to the server, we ask it to
begin scanning for devices.
> putStrLn "Requesting device scan"
> sendMessage con $ MsgStartScanning 2
We now print out any further messages the server sends us, until it
disconnects. The first thing we should see is an "Ok Id=2" in
response to our request to start scanning for devices.
Additionally, the server will send us a message any time a device
connects or disconnects.
If the server's maxPingTime is set to a value other than 0, we need to
ping it regularly, or it will disconnect us. In that case, we will also see an
Ok response for each of our pings.
> concurrently_ (receiveAndPrintMsgs con)
> (pingServer maxPingTime con)
This case would indicate a server bug, it's just here for completeness.
> _ -> putStrLn "Did not receive expected handshake response"
>
> where
> handleConnectorException :: ConnectorException -> IO ()
> handleConnectorException = \case
> ConnectionFailed e -> do
> putStrLn "Connection to Buttplug server failed:"
> putStrLn e
> UnexpectedConnectionClosed ->
> putStrLn "Server closed the connection unexpectedly"
> ConnectionClosedNormally -> putStrLn "Server closed the connection"
> ReceivedInvalidMessage bs -> do
> putStrLn "Server sent a message we didn't recognize:"
> print bs
> OtherConnectorError err -> putStrLn $ "Connector error:" ++ err
>
> receiveAndPrintMsgs con = do
> putStrLn "(receiving messages)"
> forever do arr <- receiveMsgs con
> for_ arr print
We ping at twice the specified rate to leave ourselves plenty of room.
> pingServer :: Word -> Connection WebSocketConnector -> IO ()
> pingServer maxPingTime con = case maxPingTime of
> 0 -> pure ()
> n -> forever do
> sendMessage con (MsgPing 1)
> threadDelay $ fromIntegral (n * 1000 `div` 2)