buttplug-hs-core (empty) → 0.1.0.0
raw patch · 11 files changed
+1389/−0 lines, 11 filesdep +QuickCheckdep +aesondep +aeson-casing
Dependencies added: QuickCheck, aeson, aeson-casing, aeson-pretty, async, base, buttplug-hs-core, bytestring, connection, containers, generic-random, hspec, network, quickcheck-instances, raw-strings-qq, text, unordered-containers, websockets, wuss
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +4/−0
- buttplug-hs-core.cabal +95/−0
- examples/example.lhs +118/−0
- src/Buttplug/Core.hs +88/−0
- src/Buttplug/Core/Connector.hs +163/−0
- src/Buttplug/Core/Device.hs +103/−0
- src/Buttplug/Core/Internal/JSONUtils.hs +28/−0
- src/Buttplug/Core/Message.hs +259/−0
- test/Spec.hs +498/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for buttplug-hs++## Unreleased changes
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ buttplug-hs-core.cabal view
@@ -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. (<https://buttplug.io/>)++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
+ examples/example.lhs view
@@ -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)
+ src/Buttplug/Core.hs view
@@ -0,0 +1,88 @@+{- |+Module : Buttplug.Core+Description : Core functionality for <https://buttplug.io/> 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+(<https://buttplug.io/>)+-}++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 (<https://buttplug.io/documentation/>) 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: (<https://github.com/intiface/intiface-cli-rs>)+--+-- - 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: (<https://buttplug-spec.docs.buttplug.io/messages.html#basic-message-structure>)+--+-- - 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 (<https://github.com/sullyj3/buttplug-hs-core/blob/main/examples/example.lhs>) for a basic tutorial.+--
+ src/Buttplug/Core/Connector.hs view
@@ -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)
+ src/Buttplug/Core/Device.hs view
@@ -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+-- (<https://buttplug-spec.docs.buttplug.io/enumeration.html#message-attributes-for-devicelist-and-deviceadded>)+-- 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+-- (<https://buttplug-spec.docs.buttplug.io/enumeration.html#message-attributes-for-devicelist-and-deviceadded>)+-- 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")
+ src/Buttplug/Core/Internal/JSONUtils.hs view
@@ -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"}
+ src/Buttplug/Core/Message.hs view
@@ -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+(<https://buttplug-spec.docs.buttplug.io/messages.html>)+-}+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.+--+-- (<https://buttplug-spec.docs.buttplug.io/status.html#error>)+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+-- (<https://buttplug-spec.docs.buttplug.io/messages.html>) 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" }
+ test/Spec.hs view
@@ -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