buttplug-hs-core-0.1.0.0: src/Buttplug/Core/Message.hs
{-# 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" }