diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for buttplug-hs + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright James Sully (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +# buttplug-hs-core + +A low level haskell client library for the [Buttplug Sex Toy Control System](https://buttplug.io/). Contributions, bug reports, and feature requests welcome! +Hackage release coming soon. diff --git a/buttplug-hs-core.cabal b/buttplug-hs-core.cabal new file mode 100644 --- /dev/null +++ b/buttplug-hs-core.cabal @@ -0,0 +1,95 @@ +cabal-version: 1.12 +name: buttplug-hs-core +version: 0.1.0.0 +license: BSD3 +license-file: LICENSE +copyright: 2020-2021 James Sully +maintainer: sullyj3@gmail.com +author: James Sully +homepage: https://github.com/sullyj3/buttplug-hs-core#readme +bug-reports: https://github.com/sullyj3/buttplug-hs-core/issues +synopsis: Client library for buttplug.io +description: + Library for writing clients for the Buttplug Intimate Device Control Standard. () + +category: Hardware +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/sullyj3/buttplug-hs-core + +library + exposed-modules: + Buttplug.Core + Buttplug.Core.Connector + Buttplug.Core.Device + Buttplug.Core.Internal.JSONUtils + Buttplug.Core.Message + + hs-source-dirs: src + other-modules: Paths_buttplug_hs_core + default-language: Haskell2010 + build-depends: + aeson >=1.5.5.1 && <1.6, + aeson-casing >=0.2.0.0 && <0.3, + base >=4.7 && <5, + bytestring >=0.10.12.0 && <0.11, + connection >=0.3.1 && <0.4, + containers >=0.6.2.1 && <0.7, + network >=3.1.1.1 && <3.2, + text >=1.2.4.1 && <1.3, + unordered-containers >=0.2.13.0 && <0.3, + websockets >=0.12.7.2 && <0.13, + wuss >=1.1.18 && <1.2 + +executable buttplug-example + main-is: example.lhs + hs-source-dirs: examples + other-modules: Paths_buttplug_hs_core + default-language: Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson >=1.5.5.1 && <1.6, + aeson-casing >=0.2.0.0 && <0.3, + async >=2.2.2 && <2.3, + base >=4.7 && <5, + buttplug-hs-core -any, + bytestring >=0.10.12.0 && <0.11, + connection >=0.3.1 && <0.4, + containers >=0.6.2.1 && <0.7, + network >=3.1.1.1 && <3.2, + text >=1.2.4.1 && <1.3, + unordered-containers >=0.2.13.0 && <0.3, + websockets >=0.12.7.2 && <0.13, + wuss >=1.1.18 && <1.2 + +test-suite buttplug-hs-core-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + other-modules: Paths_buttplug_hs_core + default-language: Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck >=2.14.2 && <2.15, + aeson >=1.5.5.1 && <1.6, + aeson-casing >=0.2.0.0 && <0.3, + aeson-pretty >=0.8.8 && <0.9, + base >=4.7 && <5, + buttplug-hs-core -any, + bytestring >=0.10.12.0 && <0.11, + connection >=0.3.1 && <0.4, + containers >=0.6.2.1 && <0.7, + generic-random >=1.3.0.1 && <1.4, + hspec >=2.7.8 && <2.8, + network >=3.1.1.1 && <3.2, + quickcheck-instances >=0.3.25.2 && <0.4, + raw-strings-qq ==1.1.*, + text >=1.2.4.1 && <1.3, + unordered-containers >=0.2.13.0 && <0.3, + websockets >=0.12.7.2 && <0.13, + wuss >=1.1.18 && <1.2 diff --git a/examples/example.lhs b/examples/example.lhs new file mode 100644 --- /dev/null +++ b/examples/example.lhs @@ -0,0 +1,118 @@ +> {-# 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) diff --git a/src/Buttplug/Core.hs b/src/Buttplug/Core.hs new file mode 100644 --- /dev/null +++ b/src/Buttplug/Core.hs @@ -0,0 +1,88 @@ +{- | +Module : Buttplug.Core +Description : Core functionality for clients. +Copyright : (c) James Sully, 2020-2021 +License : BSD 3-Clause +Maintainer : sullyj3@gmail.com +Stability : experimental +Portability : untested + +An implementation of the Buttplug Intimate Device Control Standard +() +-} + +module Buttplug.Core + ( + -- * Overview + -- $overview + + -- ** Tutorial + -- $tutorial + + -- ** Connectors and connections + -- Connector.hs + Connector + , Connection + , runClient + , sendMessages + , receiveMsgs + , sendMessage + , ConnectorException(..) + , WebSocketConnector(..) + + -- ** Messages + -- Message.hs + , clientMessageVersion + , Message(..) + , ErrorCode(..) + , Vibrate(..) + , Rotate(..) + , LinearActuate(..) + , RawData(..) + + -- ** Devices + -- Device.hs + , MessageAttributes(..) + , Device(..) + , DeviceMessageType(..) + ) where + +import Buttplug.Core.Message +import Buttplug.Core.Connector +import Buttplug.Core.Device + +-- $overview +-- See () for documentation of the Buttplug +-- protocol. +-- +-- The basic idea is: +-- +-- - The Buttplug protocol is designed to simplify the process of using +-- computers to control sex toys, by abstracting over individual hardware +-- details. +-- +-- - A Buttplug server is responsible for connecting to individual devices, +-- and understanding the specific details of operating them. I recommend Intiface-cli-rs, a command line server implementation: () +-- +-- - Applications act as Buttplug clients, speaking a straightforward message +-- format to the server, which abstracts over the individual details of +-- different devices. +-- In this way developers are presented with a simple API for controlling a wide +-- variety of different toys. +-- +-- This package contains the core types and functionality for writing clients, +-- including: +-- +-- - The 'Message' type, and Aeson instances for serialization and deserialization. +-- The Buttplug message format is documented here: () +-- +-- - The 'Connector' typeclass, which abstracts over different ways of +-- communicating with a Buttplug server. A connector allows the developer to open connections to the Buttplug Server, and send and receive Messages. +-- +-- - 'WebSocketConnector', for connecting to a Buttplug server using Websockets. +-- +-- As this library is still experimental, please feel free to suggest API improvements! + +-- $tutorial +-- See () for a basic tutorial. +-- diff --git a/src/Buttplug/Core/Connector.hs b/src/Buttplug/Core/Connector.hs new file mode 100644 --- /dev/null +++ b/src/Buttplug/Core/Connector.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} + +{- | +Module : Buttplug.Core.Connector +Copyright : (c) James Sully, 2020-2021 +License : BSD 3-Clause +Maintainer : sullyj3@gmail.com +Stability : experimental +Portability : untested + +Provides methods of connecting to a Buttplug Server +-} +module Buttplug.Core.Connector where + +import Control.Exception +import System.IO.Error ( isDoesNotExistError ) +import Data.ByteString.Lazy ( fromStrict, toStrict ) +import Data.ByteString ( ByteString ) +import qualified Network.WebSockets as WS +import Network.WebSockets.Stream ( makeStream ) +import qualified Wuss +import Network.Connection ( TLSSettings(..) + , ConnectionParams(..) + , initConnectionContext + , connectTo + , connectionGetChunk + , connectionPut ) +import Network.Socket ( withSocketsDo, PortNumber ) +import Data.Aeson ( encode + , decode ) + +import Buttplug.Core.Message + +-- TODO currently websocket connector runclient blocks indefinitely if host +-- exists but port is unavailable. Need to think about providing an API to +-- allow for time limits + +-- | Abstracts over methods of connecting to a buttplug server. The connector +-- contains all the information necessary for establishing a connection. +class Connector c where + -- | A Connector determines a unique connection type that is used for + -- communication. + type Connection c = conn | conn -> c + + -- | Main entry point for communicating with the Buttplug server. Establish a + -- connection to the server and pass the connection handle to the + -- continuation. + runClient :: c -> (Connection c -> IO a) -> IO a + + -- | Send 'Message's to the server. In the Buttplug protocol, all messages + -- are wrapped in a JSON array (here a Haskell list) to facilitate sending + -- multiple messages simultaneously. Use 'sendMessage' to send a single + -- message. + sendMessages :: Connection c -> [Message] -> IO () + + -- | receive 'Message's from the server + receiveMsgs :: Connection c -> IO [Message] + +-- | Send the server a single 'Message' +sendMessage :: forall c. Connector c => Connection c -> Message -> IO () +sendMessage conn msg = sendMessages @c conn [msg] + +-- | Connect to the buttplug server using websockets +data WebSocketConnector = + InsecureWebSocketConnector { insecureWSConnectorHost :: String + , insecureWSConnectorPort :: Int } + | SecureWebSocketConnector { secureWSConnectorHost :: String + , secureWSConnectorPort :: PortNumber + , secureWSBypassCertVerify :: Bool } + +-- I'm not incredibly psyched about this design, but it's not immediately +-- obvious to me how to improve it. + +-- | An exception type abstracting over the exceptions that might arise in the +-- course of communication with the buttplug server. 'Connector' instances in +-- general should throw these rather than Exceptions specific to the connection +-- type. +data ConnectorException = ConnectionFailed String + | UnexpectedConnectionClosed + | ConnectionClosedNormally + | ReceivedInvalidMessage ByteString + | OtherConnectorError String + deriving Show + +instance Exception ConnectorException + + +instance Connector WebSocketConnector where + type Connection WebSocketConnector = WS.Connection + + sendMessages :: WS.Connection -> [Message] -> IO () + sendMessages wsCon msgs = handle handleWSConnException $ + WS.sendTextData wsCon (encode msgs) + + receiveMsgs :: WS.Connection -> IO [Message] + receiveMsgs wsCon = handle handleWSConnException $ do + received <- WS.receiveData wsCon + case decode $ fromStrict received :: Maybe [Message] of + Just msgs -> pure msgs + Nothing -> throwIO $ ReceivedInvalidMessage received + + runClient :: WebSocketConnector -> (WS.Connection -> IO a) -> IO a + runClient connector client = + handle handleSockConnFailed $ handle handleWSConnFailed $ + withSocketsDo $ case connector of + InsecureWebSocketConnector host port -> + WS.runClient host port "/" client + SecureWebSocketConnector host port bypassCertVerify -> + if bypassCertVerify + then do + -- adapted from https://hackage.haskell.org/package/wuss-1.1.18/docs/Wuss.html#v:runSecureClientWith + let options = WS.defaultConnectionOptions + let headers = [] + let tlsSettings = TLSSettingsSimple + -- This is the important setting. + { settingDisableCertificateValidation = True + , settingDisableSession = False + , settingUseServerName = False + } + let connectionParams = ConnectionParams + { connectionHostname = host + , connectionPort = port + , connectionUseSecure = Just tlsSettings + , connectionUseSocks = Nothing + } + + context <- initConnectionContext + connection <- connectTo context connectionParams + stream <- makeStream + (fmap Just (connectionGetChunk connection)) + (maybe (return ()) (connectionPut connection . toStrict)) + WS.runClientWithStream stream host "/" options headers client + else Wuss.runSecureClient host port "/" client + +-- -- +-- Private -- +-- -- + +-- | Convert 'WS.HandshakeException' into 'ConnectionFailed' +handleWSConnFailed :: WS.HandshakeException -> IO a +handleWSConnFailed e = throwIO (ConnectionFailed $ show e) + +-- | Convert socket connection issues into 'ConnectionFailed' +handleSockConnFailed :: IOError -> IO a +handleSockConnFailed e + | isDoesNotExistError e = throwIO (ConnectionFailed $ show e) + | otherwise = throwIO e + +-- | Convert websocket specific connection exceptions into 'ConnectorException' +handleWSConnException :: WS.ConnectionException -> IO a +handleWSConnException = \case + WS.ConnectionClosed -> throwIO UnexpectedConnectionClosed + WS.CloseRequest 1000 _ -> throwIO ConnectionClosedNormally + e -> throwIO $ OtherConnectorError (show e) diff --git a/src/Buttplug/Core/Device.hs b/src/Buttplug/Core/Device.hs new file mode 100644 --- /dev/null +++ b/src/Buttplug/Core/Device.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} + +{- | +Module : Buttplug.Core.Device +Description : Types for representing sex toys +Copyright : (c) James Sully, 2020-2021 +License : BSD 3-Clause +Maintainer : sullyj3@gmail.com +Stability : experimental +Portability : untested + +Types for representing sex toys, as well as ways of actuating them. +-} + +module Buttplug.Core.Device where + +import GHC.Generics +import Control.Monad (foldM) +import Data.Map.Strict (Map) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Aeson.Types ( Parser ) +import Data.Aeson ( ToJSON(..) + , FromJSON(..) + , ToJSONKey(..) + , FromJSONKey(..) + , (.=) + , (.:?) + , Value(..) + , object + , genericToJSON + , genericToJSONKey + , genericFromJSONKey + , genericParseJSON + , withObject ) +import qualified Data.HashMap.Strict as HMap + +import Buttplug.Core.Internal.JSONUtils + +-- | For a particular actuation feature (Vibration, Rotation, or Linear), +-- represents how many of that feature the device has, and the available +-- resolution of control of that feature. See +-- () +-- for details. +data MessageAttributes = MessageAttributes + { attrFeatureCount :: Maybe Word + , attrStepCount :: Maybe [Word] } + deriving (Generic, Show, Eq) + + +instance ToJSON MessageAttributes where + toJSON = genericToJSON msgAttributeOptions + +instance FromJSON MessageAttributes where + parseJSON = withObject "MessageAttributes" \v -> MessageAttributes + <$> v .:? "FeatureCount" + <*> v .:? "StepCount" + +-- | An intimate device, containing info about the functionality it supports. +data Device = + Device { deviceName :: Text + , deviceIndex :: Word + , deviceMessages :: Map DeviceMessageType MessageAttributes + } + deriving (Generic, Show, Eq) + +instance ToJSON Device where + toJSON = genericToJSON pascalCaseOptions + +instance FromJSON Device where + parseJSON = genericParseJSON pascalCaseOptions +--------------------------------------------------------------- + +-- | Represents which message types the device supports +-- See +-- () +-- for details. +data DeviceMessageType = + -- Raw Device commands + DevRawWriteCmd + | DevRawReadCmd + | DevRawSubscribeCmd + | DevRawUnsubscribeCmd + -- Generic Device commands + | DevStopDeviceCmd + | DevVibrateCmd + | DevLinearCmd + | DevRotateCmd + deriving (Generic, Show, Eq, Ord) + +instance ToJSON DeviceMessageType where + toJSON = genericToJSON deviceMessageOptions + +instance FromJSON DeviceMessageType where + parseJSON = genericParseJSON deviceMessageOptions + +instance ToJSONKey DeviceMessageType where + toJSONKey = genericToJSONKey (stripPrefixKeyOptions "Dev") + +instance FromJSONKey DeviceMessageType where + fromJSONKey = genericFromJSONKey (stripPrefixKeyOptions "Dev") diff --git a/src/Buttplug/Core/Internal/JSONUtils.hs b/src/Buttplug/Core/Internal/JSONUtils.hs new file mode 100644 --- /dev/null +++ b/src/Buttplug/Core/Internal/JSONUtils.hs @@ -0,0 +1,28 @@ +module Buttplug.Core.Internal.JSONUtils where + +import Data.Aeson (Options(..), defaultOptions, JSONKeyOptions(..), defaultJSONKeyOptions) +import Data.Aeson.Casing + +-- TODO some of the uses of pascalCase are probably redundant + +stripPrefix :: String -> String -> String +stripPrefix s = drop $ length s + +stripPrefixOptions s = defaultOptions { fieldLabelModifier = stripPrefix s } + +stripPrefixKeyOptions s = defaultJSONKeyOptions { keyModifier = stripPrefix s } + +pascalCaseOptions :: Options +pascalCaseOptions = defaultOptions { fieldLabelModifier = pascalCase } + +pascalCaseKeyOptions :: JSONKeyOptions +pascalCaseKeyOptions = defaultJSONKeyOptions { keyModifier = pascalCase } + +deviceMessageOptions :: Options +deviceMessageOptions = + defaultOptions { constructorTagModifier = stripPrefix "Dev" } + +msgAttributeOptions :: Options +msgAttributeOptions = + defaultOptions { omitNothingFields = True + , fieldLabelModifier = pascalCase . stripPrefix "attr"} diff --git a/src/Buttplug/Core/Message.hs b/src/Buttplug/Core/Message.hs new file mode 100644 --- /dev/null +++ b/src/Buttplug/Core/Message.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} + +{- | +Module : Buttplug.Core.Message +Copyright : (c) James Sully, 2020-2021 +License : BSD 3-Clause +Maintainer : sullyj3@gmail.com +Stability : experimental +Portability : untested + +Contains the Message type, representing Buttplug protocol messages +() +-} +module Buttplug.Core.Message where + +import GHC.Generics +import Data.Text ( Text ) +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS +import Data.Aeson ( ToJSON(..) + , FromJSON(..) + , genericToJSON + , Options(..) + , SumEncoding(..) + , genericParseJSON + ) +import Data.Map.Strict ( Map ) + +import qualified Buttplug.Core.Device as Dev +import Buttplug.Core.Device ( Device(..) ) +import Buttplug.Core.Internal.JSONUtils + + +-- | The version of the Buttplug message protocol that the client speaks. +-- (currently version 2) +clientMessageVersion :: Word +clientMessageVersion = 2 +------------------------------------------------ + + +-- | Errors from the server, used in the Error message. +-- +-- () +data ErrorCode = ERROR_UNKNOWN -- ^ An unknown error occurred. + | ERROR_INIT -- ^ Handshake did not succeed. + | ERROR_PING -- ^ A ping was not sent in the expected time. + | ERROR_MSG -- ^ A message parsing or permission error occurred. + | ERROR_DEVICE -- ^ A command sent to a device returned an error. + deriving (Enum, Show, Eq, Generic) + + +-- TODO these should probably convert with Word not Int +-- | Parse an 'Int' to an 'ErrorCode' +errCodeFromInt :: Int -> Maybe ErrorCode +errCodeFromInt = \case + 0 -> Just ERROR_UNKNOWN + 1 -> Just ERROR_INIT + 2 -> Just ERROR_PING + 3 -> Just ERROR_MSG + 4 -> Just ERROR_DEVICE + _ -> Nothing + + +-- | Convert an 'ErrorCode' to an 'Int' +fromErrCode :: ErrorCode -> Int +fromErrCode = fromIntegral . fromEnum + + +instance ToJSON ErrorCode where + toJSON = toJSON . fromErrCode + + +instance FromJSON ErrorCode where + parseJSON v = do + m <- errCodeFromInt <$> parseJSON v + case m of + Nothing -> fail "Error code should be an int" + Just e -> pure e + +-- Circumvents the fact that Aeson doesn't +-- have bytestring encoding/decoding in genericToJSON and genericParseJSON + +-- | Used for the Raw* messages. +newtype RawData = RawData ByteString + deriving (Generic, Show, Eq) + + +instance ToJSON RawData where + toJSON (RawData bs) = toJSON $ BS.unpack bs + + +instance FromJSON RawData where + parseJSON j = RawData . BS.pack <$> parseJSON j + +-- | Used in VibrateCmd to specify the speed of the motor at the given index +data Vibrate = Vibrate { vibrateIndex :: Word + , vibrateSpeed :: Double + } + deriving (Generic, Show, Eq) + + +instance ToJSON Vibrate where + toJSON = genericToJSON (stripPrefixOptions "vibrate") + + +instance FromJSON Vibrate where + parseJSON = genericParseJSON (stripPrefixOptions "vibrate") + + +-- | Used in RotateCmd to specify the speed and direction of rotation of the +-- motor at the given index +data Rotate = Rotate + { rotateIndex :: Word + , rotateSpeed :: Double + , rotateClockwise :: Bool + } + deriving (Generic, Show, Eq) + +instance ToJSON Rotate where + toJSON = genericToJSON pascalCaseOptions { fieldLabelModifier = stripPrefix "rotate" } + + +instance FromJSON Rotate where + parseJSON = genericParseJSON pascalCaseOptions { fieldLabelModifier = stripPrefix "rotate" } + + +-- | Used in LinearCmd to specify how to move the linear actuator at the given +-- index +data LinearActuate = LinearActuate + { linActIndex :: Word + , linActDuration :: Word + , linActPosition :: Double + } + deriving (Generic, Show, Eq) + + +instance ToJSON LinearActuate where + toJSON = genericToJSON pascalCaseOptions { fieldLabelModifier = stripPrefix "linAct" } + + +instance FromJSON LinearActuate where + parseJSON = genericParseJSON pascalCaseOptions { fieldLabelModifier = stripPrefix "linAct" } + + +-- TODO technically Ids should be Word32, since the maximum id is 4294967295. +-- Not sure whether this applies to other unsigned fields, should find out + +-- | The type of Buttplug protocol messages. See +-- () for the protocol +-- specification and an explanation of the purpose of each message. +data Message = + -- status messages + MsgOk { msgId :: Word } + | MsgError { msgId :: Word + , msgErrorMessage :: Text + , msgErrorCode :: ErrorCode + } + | MsgPing { msgId :: Word } + -- handshake messages + | MsgRequestServerInfo { msgId :: Word + , msgClientName :: Text + , msgMessageVersion :: Word + } + | MsgServerInfo { msgId :: Word + , msgServerName :: Text + , msgMessageVersion :: Word + , msgMaxPingTime :: Word + } + -- enumeration messages + | MsgStartScanning { msgId :: Word } + | MsgStopScanning { msgId :: Word } + | MsgScanningFinished { msgId :: Word } + | MsgRequestDeviceList { msgId :: Word } + | MsgDeviceList { msgId :: Word + , msgDevices :: [ Device ] + } + | MsgDeviceAdded { msgId :: Word + , msgDeviceName :: Text + , msgDeviceIndex :: Word + , msgDeviceMessages :: Map Dev.DeviceMessageType Dev.MessageAttributes + } + | MsgDeviceRemoved { msgId :: Word + , msgDeviceIndex :: Word + } + -- raw device messages + | MsgRawWriteCmd { msgId :: Word + , msgDeviceIndex :: Word + , msgEndpoint :: Text + , msgData :: RawData + , msgWriteWithResponse :: Bool } + | MsgRawReadCmd { msgId :: Word + , msgDeviceIndex :: Word + , msgEndpoint :: Text + , msgExpectedLength :: Word + , msgWaitForData :: Bool } + | MsgRawReading { msgId :: Word + , msgDeviceIndex :: Word + , msgEndpoint :: Text + , msgData :: RawData } + | MsgRawSubscribeCmd { msgId :: Word + , msgDeviceIndex :: Word + , msgEndpoint :: Text } + | MsgRawUnsubscribeCmd { msgId :: Word + , msgDeviceIndex :: Word + , msgEndpoint :: Text } + -- generic device messages + | MsgStopDeviceCmd { msgId :: Word + , msgDeviceIndex :: Word + } + | MsgStopAllDevices { msgId :: Word } + | MsgVibrateCmd { msgId :: Word + , msgDeviceIndex :: Word + , msgSpeeds :: [ Vibrate ] + } + | MsgLinearCmd { msgId :: Word + , msgDeviceIndex :: Word + , msgVectors :: [ LinearActuate ] + } + | MsgRotateCmd { msgId :: Word + , msgDeviceIndex :: Word + , msgRotations :: [ Rotate ] + } + -- generic sensor messages + | MsgBatteryLevelCmd { msgId :: Word + , msgDeviceIndex :: Word + } + | MsgBatteryLevelReading { msgId :: Word + , msgDeviceIndex :: Word + , msgBatteryLevel :: Double + } + | MsgRSSILevelCmd { msgId :: Word + , msgDeviceIndex :: Word + } + | MsgRSSILevelReading { msgId :: Word + , msgDeviceIndex :: Word + , msgRSSILevel :: Int + } + deriving (Show, Eq, Generic) + + +instance ToJSON Message where + toJSON = genericToJSON $ pascalCaseOptions { sumEncoding = ObjectWithSingleField + , fieldLabelModifier = stripPrefix "msg" + , constructorTagModifier = stripPrefix "Msg" } + + +instance FromJSON Message where + parseJSON = genericParseJSON $ pascalCaseOptions { sumEncoding = ObjectWithSingleField + , fieldLabelModifier = stripPrefix "msg" + , constructorTagModifier = stripPrefix "Msg" } diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,498 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE BlockArguments #-} + +import Text.RawString.QQ +import GHC.Generics +import qualified Data.Map.Strict as Map +import Test.Hspec +import Test.Hspec.QuickCheck ( prop ) +import Test.QuickCheck +import Test.QuickCheck.Instances.ByteString +import Test.QuickCheck.Instances.Text +import Generic.Random ( genericArbitraryU ) +import Data.Aeson ( decode + , eitherDecode + , encode + , ToJSON(..) + , FromJSON(..) + , Options(..) + , SumEncoding(..) + , genericToJSON + , genericParseJSON + ) +import Data.Aeson.Encode.Pretty ( encodePretty ) +import qualified Data.Text as T +import Data.Text.Encoding ( decodeUtf8 ) +import qualified Data.Text.IO as T +import Data.Maybe (isJust) +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS +import Data.ByteString.Lazy ( toStrict ) +import Data.Word ( Word8 ) + +import Buttplug.Core.Message +import Buttplug.Core.Device +import Buttplug.Core.Internal.JSONUtils + +instance Arbitrary RawData where + arbitrary = genericArbitraryU + shrink = genericShrink +instance Arbitrary MessageAttributes where + arbitrary = genericArbitraryU + shrink = genericShrink +instance Arbitrary DeviceMessageType where + arbitrary = genericArbitraryU + shrink = genericShrink +instance Arbitrary Device where + arbitrary = genericArbitraryU + shrink = genericShrink +instance Arbitrary ErrorCode where + arbitrary = genericArbitraryU + shrink = genericShrink +instance Arbitrary Vibrate where + arbitrary = genericArbitraryU + shrink = genericShrink +instance Arbitrary LinearActuate where + arbitrary = genericArbitraryU + shrink = genericShrink +instance Arbitrary Rotate where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance Arbitrary Message where + arbitrary = genericArbitraryU + shrink = genericShrink + +main :: IO () +main = hspec do + testButtplug + +testButtplug = do + describe "Message Aeson instances" do + describe "Ok" do + let s = [r|{ + "Ok": { + "Id": 1 + } + }|] + msg = MsgOk 1 + it "Can decode it" do + decode s `shouldBe` Just msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "Error" do + let s = [r|{ + "Error": { + "Id": 0, + "ErrorMessage": "Server received invalid JSON.", + "ErrorCode": 3 + } + }|] + msg = MsgError 0 "Server received invalid JSON." ERROR_MSG + it "Can decode it" do + decode s `shouldBe` Just msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "Ping" do + let s = [r|{ + "Ping": { + "Id": 5 + } + }|] + msg = MsgPing 5 + it "Can decode it" do + decode s `shouldBe` Just msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "RequestServerInfo" do + let s = [r|{ + "RequestServerInfo": { + "Id": 1, + "ClientName": "Test Client", + "MessageVersion": 1 + } + }|] + msg = MsgRequestServerInfo 1 "Test Client" 1 + it "Can decode it" do + decode s `shouldBe` Just msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + + describe "ServerInfo" do + let s = [r|{ + "ServerInfo": { + "Id": 1, + "ServerName": "Test Server", + "MessageVersion": 1, + "MaxPingTime": 100 + } + }|] + msg = MsgServerInfo 1 "Test Server" 1 100 + it "Can decode it" do + decode s `shouldBe` Just msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "StartScanning" do + let s = [r|{ + "StartScanning": { + "Id": 1 + } + }|] + msg = MsgStartScanning 1 + it "Can decode it" do + decode s `shouldBe` Just msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "StopScanning" do + let s = [r|{ + "StopScanning": { + "Id": 1 + } + }|] + msg = MsgStopScanning 1 + it "Can decode it" do + decode s `shouldBe` Just msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "ScanningFinished" do + let s = [r|{ + "ScanningFinished": { + "Id": 0 + } + }|] + msg = MsgScanningFinished 0 + it "Can decode it" do + decode s `shouldBe` Just msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "RequestDeviceList" do + let s = [r|{ + "RequestDeviceList": { + "Id": 1 + } + }|] + msg = MsgRequestDeviceList 1 + it "Can decode it" do + decode s `shouldBe` Just msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "DeviceList" do + let s = [r|{ + "DeviceList": { + "Id": 1, + "Devices": [ + { + "DeviceName": "TestDevice 1", + "DeviceIndex": 0, + "DeviceMessages": { + "VibrateCmd": { "FeatureCount": 2 }, + "StopDeviceCmd": {} + } + }, + { + "DeviceName": "TestDevice 2", + "DeviceIndex": 1, + "DeviceMessages": { + "LinearCmd": { "FeatureCount": 1 }, + "StopDeviceCmd": {} + } + } + ] + } + }|] + msg = + MsgDeviceList 1 + [ Device "TestDevice 1" 0 $ Map.fromList + [ (DevVibrateCmd, MessageAttributes (Just 2) Nothing) + , (DevStopDeviceCmd, MessageAttributes Nothing Nothing )] + , Device "TestDevice 2" 1 $ Map.fromList + [ (DevLinearCmd, MessageAttributes (Just 1) Nothing) + , (DevStopDeviceCmd, MessageAttributes Nothing Nothing )] + ] + it "Can decode it" do + decode s `shouldBe` Just msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "DeviceAdded" do + let s = [r|{ + "DeviceAdded": { + "Id": 0, + "DeviceName": "TestDevice 1", + "DeviceIndex": 0, + "DeviceMessages": { + "VibrateCmd": { "FeatureCount": 2 }, + "StopDeviceCmd": {} + } + } + }|] + msg = MsgDeviceAdded 0 "TestDevice 1" 0 $ Map.fromList + [ (DevVibrateCmd, MessageAttributes (Just 2) Nothing) + , (DevStopDeviceCmd, MessageAttributes Nothing Nothing )] + it "Can decode it" do + decode s `shouldBe` Just msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "DeviceRemoved" do + let s = [r|{ + "DeviceRemoved": { + "Id": 0, + "DeviceIndex": 0 + } + }|] + msg = MsgDeviceRemoved 0 0 + it "Can decode it" do + decode s `shouldBe` Just msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + it "Can decode a ByteString to RawData" $ do + (decode "[0, 1, 0]" :: Maybe RawData) `shouldBe` Just (RawData $ BS.pack [0,1,0]) + + describe "RawWriteCmd" $ do + let s = [r|{ + "RawWriteCmd": { + "Id": 1, + "DeviceIndex": 0, + "Endpoint": "tx", + "Data": [0, 1, 0], + "WriteWithResponse": false + } + }|] + msg = MsgRawWriteCmd 1 0 "tx" (RawData $ BS.pack [0,1,0]) False + it "Can decode it" do + decode s `shouldBe` Just msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "RawReadCmd" $ do + let s = [r|{ + "RawReadCmd": { + "Id": 1, + "DeviceIndex": 0, + "Endpoint": "tx", + "ExpectedLength": 0, + "WaitForData": false + } + }|] + msg = MsgRawReadCmd 1 0 "tx" 0 False + it "Can decode it" do + decode s `shouldBe` Just msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "a RawReading" $ do + let s = [r|{ + "RawReading": { + "Id": 1, + "DeviceIndex": 0, + "Endpoint": "rx", + "Data": [0, 1, 0] + } + }|] + msg = MsgRawReading 1 0 "rx" (RawData $ BS.pack [0,1,0]) + it "Can decode it" do + decode s `shouldBe` Just msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "RawSubscribeCmd" $ do + let s = [r|{ + "RawSubscribeCmd": { + "Id": 1, + "DeviceIndex": 0, + "Endpoint": "tx" + } + }|] + msg = MsgRawSubscribeCmd 1 0 "tx" + it "Can decode it" do + decode s `shouldBe` Just msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "RawUnSubscribeCmd" $ do + let s = [r|{ + "RawUnsubscribeCmd": { + "Id": 1, + "DeviceIndex": 0, + "Endpoint": "tx" + } + }|] + msg = MsgRawUnsubscribeCmd 1 0 "tx" + it "Can decode it" do + decode s `shouldBe` Just msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "StopDeviceCmd" $ do + let s = [r|{ + "StopDeviceCmd": { + "Id": 1, + "DeviceIndex": 0 + } + }|] + msg = MsgStopDeviceCmd 1 0 + it "Can decode it" do + decode s `shouldBe` Just msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "StopAllDevices" $ do + let s = [r|{ + "StopAllDevices": { + "Id": 1 + } + }|] + msg = MsgStopAllDevices 1 + it "Can decode it" do + decode s `shouldBe` Just msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "VibrateCmd" $ do + let s = [r|{ + "VibrateCmd": { + "Id": 1, + "DeviceIndex": 0, + "Speeds": [ + { + "Index": 0, + "Speed": 0.5 + }, + { + "Index": 1, + "Speed": 1.0 + } + ] + } + }|] + msg = MsgVibrateCmd 1 0 [ Vibrate 0 0.5, Vibrate 1 1.0 ] + it "Can decode it" do + eitherDecode s `shouldBe` Right msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "LinearCmd" $ do + let s = [r| { + "LinearCmd": { + "Id": 1, + "DeviceIndex": 0, + "Vectors": [ + { + "Index": 0, + "Duration": 500, + "Position": 0.3 + }, + { + "Index": 1, + "Duration": 1000, + "Position": 0.8 + } + ] + } + }|] + msg = MsgLinearCmd 1 0 + [ LinearActuate 0 500 0.3, LinearActuate 1 1000 0.8 ] + it "Can decode it" do + eitherDecode s `shouldBe` Right msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "RotateCmd" $ do + let s = [r| { + "RotateCmd": { + "Id": 1, + "DeviceIndex": 0, + "Rotations": [ + { + "Index": 0, + "Speed": 0.5, + "Clockwise": true + }, + { + "Index": 1, + "Speed": 1.0, + "Clockwise": false + } + ] + } + }|] + msg = MsgRotateCmd 1 0 + [ Rotate 0 0.5 True, Rotate 1 1.0 False ] + it "Can decode it" do + eitherDecode s `shouldBe` Right msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "BatteryLevelCmd" $ do + let s = [r| { + "BatteryLevelCmd": { + "Id": 1, + "DeviceIndex": 0 + } + }|] + msg = MsgBatteryLevelCmd 1 0 + it "Can decode it" do + eitherDecode s `shouldBe` Right msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "BatteryLevelReading" $ do + let s = [r| { + "BatteryLevelReading": { + "Id": 1, + "DeviceIndex": 0, + "BatteryLevel": 0.5 + } + }|] + msg = MsgBatteryLevelReading 1 0 0.5 + it "Can decode it" do + eitherDecode s `shouldBe` Right msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "RSSILevelCmd" $ do + let s = [r| { + "RSSILevelCmd": { + "Id": 1, + "DeviceIndex": 0 + } + }|] + msg = MsgRSSILevelCmd 1 0 + it "Can decode it" do + eitherDecode s `shouldBe` Right msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "RSSILevelReading" $ do + let s = [r| { + "RSSILevelReading": { + "Id": 1, + "DeviceIndex": 0, + "RSSILevel": -40 + } + }|] + msg = MsgRSSILevelReading 1 0 (-40) + it "Can decode it" do + eitherDecode s `shouldBe` Right msg + it "Can encode it" do + decode (encode msg) `shouldBe` Just msg + + describe "all messages" do + prop "decode is inverse to encode" decodeEncodeInverse + where + decodeEncodeInverse :: Message -> Expectation + decodeEncodeInverse msg = + (decode . encode $ msg) `shouldBe` Just msg