diff --git a/examples/WS.hs b/examples/WS.hs --- a/examples/WS.hs +++ b/examples/WS.hs @@ -1,29 +1,42 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} module Main where -import qualified Data.Aeson as JSON -import Network.WebSockets import Myo.WebSockets +import Network.WebSockets +import qualified Data.Aeson as JSON import Control.Monad +import Data.String.Conv import Lens.Family2 main :: IO () -main = runClient "localhost" 10138 "/myo/3?appid=com.example.appid" myoWS +main = connect V3 "com.example.appid" "localhost" 10138 myoApp -myoWS :: Connection -> IO () -myoWS conn = forever $ do +myoApp :: Connection -> IO () +myoApp conn = forever $ do newData <- receiveData conn - let (msg :: Either String MyoFrame) = JSON.eitherDecode' newData + let msg = JSON.eitherDecode' newData case msg of Left e -> do putStrLn e - putStrLn (show newData) - Right (Event my) -> case my ^. mye_type of - EVT_Paired -> putStrLn "MYO PAIRED!" - EVT_Connected -> putStrLn "MYO CONNECTED!" - EVT_Pose -> case my ^. mye_pose of - Nothing -> putStrLn "GOT A POSE!" - Just p -> putStrLn $ "GOT POSE: " ++ show p - EVT_Arm_Synced -> putStrLn "MYO ARM SYNCED" - EVT_Arm_Unsynced -> putStrLn "MYO ARM UNSYNCED" - _ -> return () + print newData + Right r -> case r of + Evt my -> case my ^. mye_type of + EVT_Paired -> putStrLn "MYO PAIRED!" + EVT_Connected -> putStrLn "MYO CONNECTED!" + EVT_Pose -> case my ^. mye_pose of + Nothing -> putStrLn "GOT A POSE!" + Just Double_Tap -> do + putStrLn $ "GOT POSE: " ++ show Double_Tap + let vCmd = newCommand (my ^. mye_myo) (Set_Locking_Policy LKP_standard) + putStrLn $ toS $ JSON.encode vCmd + sendCommand conn vCmd + Just p -> putStrLn $ "GOT POSE: " ++ show p + EVT_Arm_Synced -> do + putStrLn "MYO ARM SYNCED" + EVT_Arm_Unsynced -> putStrLn "MYO ARM UNSYNCED" + _ -> return () + Cmd c -> print c + Ack a -> do + putStrLn "Acknowledged command!" + print a diff --git a/myo.cabal b/myo.cabal --- a/myo.cabal +++ b/myo.cabal @@ -1,5 +1,5 @@ name: myo -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Haskell binding to the Myo armband description: Please see README.md homepage: http://github.com/adinapoli/myo @@ -14,54 +14,70 @@ cabal-version: >=1.10 +flag foreign-api + default: False + library - hs-source-dirs: src - include-dirs: - include + hs-source-dirs: src + include-dirs: include + if flag(foreign-api) + exposed-modules: + Myo + Myo.Foreign.Hub + Myo.Foreign.Hub.Types + Myo.Foreign.Types + Myo.Foreign.Result + Myo.Foreign.String + Myo.Foreign.String.Types + Myo.Foreign.Device + Myo.Foreign.Locking + Myo.Foreign.Event + Myo.Foreign.Handler + build-depends: + base >= 4.7 && < 5, + containers, + template-haskell, + websockets, + aeson, + lens-family, + lens-family-th, + vector, + text, + scientific, + unordered-containers, + inline-c + extra-libraries: + stdc++ + ld-options: + -framework myo + c-sources: + cbits/wrapper.c + src/Myo.c + src/Myo/Foreign/String.c + src/Myo/Foreign/String/Types.c + src/Myo/Foreign/Types.c + src/Myo/Foreign/Hub.c + src/Myo/Foreign/Hub/Types.c + exposed-modules: - Myo - Myo.WebSockets - Myo.WebSockets.Types - Myo.Foreign.Hub - Myo.Foreign.Hub.Types - Myo.Foreign.Types - Myo.Foreign.Result - Myo.Foreign.String - Myo.Foreign.String.Types - Myo.Foreign.Device - Myo.Foreign.Locking - Myo.Foreign.Event - Myo.Foreign.Handler + Myo.WebSockets + Myo.WebSockets.Types build-depends: - base >= 4.7 && < 5, - containers, - template-haskell, - websockets, - aeson, - lens-family, - lens-family-th, - vector, - text, - scientific, - inline-c - extra-libraries: - stdc++ - ld-options: - -framework myo + base >= 4.7 && < 5, + containers, + websockets, + aeson, + lens-family, + lens-family-th, + vector, + text, + scientific, + unordered-containers + other-extensions: TemplateHaskell QuasiQuotes OverloadedStrings - c-sources: - cbits/wrapper.c - src/Myo.c - src/Myo/Foreign/String.c - src/Myo/Foreign/String/Types.c - src/Myo/Foreign/Types.c - src/Myo/Foreign/Hub.c - src/Myo/Foreign/Hub/Types.c - ghc-options: - -Wall default-language: Haskell2010 @@ -71,8 +87,9 @@ build-depends: base , myo , websockets + , string-conv , aeson - ,lens-family + , lens-family default-language: Haskell2010 test-suite myo-test diff --git a/src/Myo/WebSockets.hs b/src/Myo/WebSockets.hs --- a/src/Myo/WebSockets.hs +++ b/src/Myo/WebSockets.hs @@ -3,21 +3,23 @@ module Myo.WebSockets.Types , ApplicationID , APIVersion(..) - , renderAPIVersion + , connect + , sendCommand ) where ---import Network.WebSockets +import Network.WebSockets +import Data.Monoid +import qualified Data.Aeson as JSON +import qualified Data.Vector as V import Myo.WebSockets.Types -import qualified Data.Text as T data APIVersion = V3 -type ApplicationID = T.Text +instance Show APIVersion where + show V3 = "3" -renderAPIVersion :: APIVersion -> T.Text -renderAPIVersion V3 = "3" +type ApplicationID = String -{- connect :: APIVersion -> ApplicationID -- ^ The Myo ApplicationID @@ -25,8 +27,12 @@ -- ^ Host -> Int -- ^ Port + -> ClientApp a -> IO a -connect apiVr aId host port = do - runClient host port (T.unpack $ "/myo/" <> renderAPIVersion <> "?appid=" <> aId) - 127.0.0.1:10138/myo/?appid=com.example.appid --} +connect apiVr aId host port app = do + runClient host port ("/myo/" <> show apiVr <> "?appid=" <> aId) app + +-------------------------------------------------------------------------------- +sendCommand :: Connection -> Command -> IO () +sendCommand conn cmd = do + sendBinaryData conn (JSON.encode $ JSON.Array (V.fromList ["command", JSON.toJSON cmd])) diff --git a/src/Myo/WebSockets/Types.hs b/src/Myo/WebSockets/Types.hs --- a/src/Myo/WebSockets/Types.hs +++ b/src/Myo/WebSockets/Types.hs @@ -1,23 +1,74 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} -module Myo.WebSockets.Types where +module Myo.WebSockets.Types ( + EventType(..) + , MyoID + , Version(..) + , EMG(..) + , Pose(..) + , Orientation(..) + , Accelerometer(..) + , Gyroscope(..) + , Arm(..) + , Direction(..) + , Frame(..) + , Event(..) + , Command + , CommandData(..) + , Vibration(..) + , StreamEMGStatus(..) + , UnlockMode(..) + , UserAction(..) + , LockingPolicy(..) + -- * Lenses + , mye_type + , mye_timestamp + , mye_myo + , mye_arm + , mye_x_direction + , mye_version + , mye_warmup_result + , mye_rssi + , mye_pose + , mye_emg + , mye_orientation + , mye_accelerometer + , mye_gyroscope + , myv_major + , myv_minor + , myv_patch + , myv_hardware + + -- * Smart constructors + , newCommand + ) where + import Data.Aeson.TH import Data.Int +import Data.Monoid import Data.Scientific -import Data.Aeson.Types +import Data.Aeson.Types hiding (Result) import Data.Char import Control.Monad import Control.Applicative import Lens.Family2.TH import qualified Data.Vector as V import qualified Data.Text as T +import qualified Data.HashMap.Strict as HM ------------------------------------------------------------------------------- -data MyoEventType = +data EventType = EVT_Paired | EVT_Battery_Level | EVT_Locked @@ -34,10 +85,10 @@ deriving (Show, Eq) ------------------------------------------------------------------------------- -type MyoID = Integer +newtype MyoID = MyoID Integer deriving (Show, Eq) ------------------------------------------------------------------------------- -data MyoVersion = MyoVersion { +data Version = Version { _myv_major :: !Integer , _myv_minor :: !Integer , _myv_patch :: !Integer @@ -49,7 +100,7 @@ data EMG = EMG Int8 deriving (Show, Eq) ------------------------------------------------------------------------------- -data MyoPose = +data Pose = Rest | Fist | Wave_In @@ -79,77 +130,155 @@ } deriving (Show, Eq) ------------------------------------------------------------------------------- -data MyoArm = Arm_Left | Arm_Right deriving (Show, Eq) +data Arm = Arm_Left | Arm_Right deriving (Show, Eq) ------------------------------------------------------------------------------- -data MyoDirection = Toward_wrist | Toward_elbow deriving (Show, Eq) +data Direction = Toward_wrist | Toward_elbow deriving (Show, Eq) ------------------------------------------------------------------------------- -data MyoFrame = Event MyoEvent - | Command MyoCommand - deriving (Show, Eq) +data Frame = Evt Event + | Cmd Command + | Ack Acknowledgement + deriving (Show, Eq) -instance FromJSON MyoFrame where - parseJSON (Array v) = case V.toList v of - [String "event", o@(Object _)] -> Event <$> parseJSON o - [String "command", o@(Object _)] -> Command <$> parseJSON o - _ -> mzero - parseJSON v = typeMismatch "MyoFrame: Expecting an Array of frames." v +instance FromJSON Frame where + parseJSON a@(Array v) = case V.toList v of + [String "event", o@(Object _)] -> Evt <$> parseJSON o + [String "acknowledgement", o@(Object _)] -> Ack <$> parseJSON o + [String "command", o@(Object b)] -> case HM.lookup "result" b of + Nothing -> Cmd <$> parseJSON o + Just _ -> Ack <$> parseJSON o + _ -> typeMismatch "Frame: Unexpected payload in Array." a + parseJSON v = typeMismatch "Frame: Expecting an Array of frames." v + ------------------------------------------------------------------------------- -data MyoEvent = MyoEvent { - _mye_type :: !MyoEventType +-- TODO: Break down this `Event` type into a mandatory section (type, timestamp, myo) +-- and a payload specific field, so that we do not have all this proliferation of +-- Maybe. The `FromJSON` instance will need to be written manually, but it's not +-- too bad. +data Event = Event { + _mye_type :: !EventType , _mye_timestamp :: !T.Text , _mye_myo :: !MyoID - , _mye_arm :: !(Maybe MyoArm) - , _mye_x_direction :: !(Maybe MyoDirection) - , _mye_version :: !(Maybe MyoVersion) - , _mye_warmup_result :: !(Maybe MyoResult) + , _mye_arm :: !(Maybe Arm) + , _mye_x_direction :: !(Maybe Direction) + , _mye_version :: !(Maybe Version) + , _mye_warmup_result :: !(Maybe Result) , _mye_rssi :: !(Maybe Int) - , _mye_pose :: !(Maybe MyoPose) + , _mye_pose :: !(Maybe Pose) , _mye_emg :: !(Maybe EMG) , _mye_orientation :: !(Maybe Orientation) , _mye_accelerometer :: !(Maybe Accelerometer) , _mye_gyroscope :: !(Maybe Gyroscope) } deriving (Show, Eq) +data Acknowledgement = Acknowledgement { + _ack_command :: AcknowledgedCommand + , _ack_result :: Result + } deriving (Show, Eq) -data MyoResult = Success | Fail deriving (Show, Eq) +data AcknowledgedCommand = + ACC_set_locking_policy + | ACC_set_stream_emg + deriving (Show, Eq) -data MyoCommandType = - COM_vibrate - | COM_request_rssi - | COM_set_stream_emg - | COM_set_locking_policy - | COM_unlock - | COM_lock - | COM_notify_user_action +------------------------------------------------------------------------------- +data Result = Success | Fail deriving (Show, Eq) + +------------------------------------------------------------------------------- +data CommandData = + Vibrate Vibration + | Set_Stream_EMG StreamEMGStatus + | Unlock UnlockMode + | Notify_User_Action UserAction + | Set_Locking_Policy LockingPolicy + | Request_RSSI + | Lock deriving (Show, Eq) +instance ToJSON CommandData where + toJSON cd = case cd of + Vibrate v -> object ["command" .= String "vibrate", "type" .= toJSON v] + Set_Stream_EMG v -> object ["command" .= String "set_stream_emg", "type" .= toJSON v] + Unlock v -> object ["command" .= String "unlock", "type" .= toJSON v] + Notify_User_Action v -> object ["command" .= String "notify_user_action", "type" .= toJSON v] + Set_Locking_Policy v -> object ["command" .= String "set_locking_policy", "type" .= toJSON v] + Lock -> object ["command" .= String "lock"] + Request_RSSI -> object ["command" .= String "request_rssi"] + +instance FromJSON CommandData where + parseJSON (Object o) = do + (cmd :: T.Text) <- o .: "command" + typ <- o .: "type" + case cmd of + "vibrate" -> Vibrate <$> parseJSON typ + "request_rssi" -> pure Request_RSSI + "set_stream_emg" -> Set_Stream_EMG <$> parseJSON typ + "set_locking_policy" -> Set_Locking_Policy <$> parseJSON typ + "unlock" -> Unlock <$> parseJSON typ + "lock" -> pure Lock + "notify_user_action" -> Notify_User_Action <$> parseJSON typ + t -> fail $ "FromJSON CommandData: invalid 'command' found: " <> show t + parseJSON t = typeMismatch ("CommandData, expected Object, found " <> show t) t + ------------------------------------------------------------------------------- -data MyoCommand = MyoCommand { - _myc_command :: !MyoCommandType - , _myc_timestamp :: !T.Text - , _myc_myo :: !MyoID - , _myc_type :: !T.Text -- Use an ADT +data Vibration = VIB_short + | VIB_medium + | VIB_long deriving (Show, Eq) + +------------------------------------------------------------------------------- +data UserAction = UAC_single deriving (Show, Eq) + +------------------------------------------------------------------------------- +data LockingPolicy = LKP_standard + | LKP_none deriving (Show, Eq) + +------------------------------------------------------------------------------- +data UnlockMode = UMD_timed + | UMD_hold deriving (Show, Eq) + +------------------------------------------------------------------------------- +data StreamEMGStatus = SES_enabled + | SES_disabled deriving (Show, Eq) + +------------------------------------------------------------------------------- +data Command = Command { + _myc_myo :: !MyoID + , _myc_info :: CommandData } deriving (Show, Eq) +instance FromJSON Command where + parseJSON v@(Object o) = Command <$> o .: "myo" <*> parseJSON v + parseJSON v = fail $ "FromJSON Command, expected Object, found " <> show v + +instance ToJSON Command where + toJSON (Command mid cd) = case toJSON cd of + Object b -> object $ ["myo" .= mid] <> HM.toList b + v -> error $ "Command: toJSON of CommandData failed, found " <> show v + +-------------------------------------------------------------------------------- +-- | Creates a new `Command`, to be sent to the Myo armband. +newCommand :: MyoID -> CommandData -> Command +newCommand mid cd = Command mid cd + ------------------------------------------------------------------------------- -instance FromJSON MyoVersion where +instance FromJSON Version where parseJSON (Array v) = do let lst = V.toList v case liftM2 (,) (Just $ length lst) (mapM toNumber lst) of Just (4, x) -> case mapM floatingOrInteger x of - Right [ma, mi, pa, ha] -> return $ MyoVersion ma mi pa ha + Right [ma, mi, pa, ha] -> return $ Version ma mi pa ha _ -> mzero _ -> mzero - parseJSON v = typeMismatch "MyoVersion: Expecting an Array like [major, minor, patch, hardware]" v - + parseJSON v = typeMismatch "Version: Expecting an Array like [major, minor, patch, hardware]" v +------------------------------------------------------------------------------- toNumber :: Value -> Maybe Scientific toNumber (Number v) = Just v toNumber _ = Nothing +------------------------------------------------------------------------------- -- TODO: Create an Int8 in a better way than this one! instance FromJSON EMG where parseJSON (Array v) = do @@ -174,19 +303,30 @@ parseJSON v = typeMismatch "Accelerometer: Expecting an Array of Double like [x,y,z]" v ------------------------------------------------------------------------------- --- JSON -deriveFromJSON defaultOptions { fieldLabelModifier = drop 5 } ''MyoEvent -deriveFromJSON defaultOptions { fieldLabelModifier = drop 5 } ''MyoCommand -deriveFromJSON defaultOptions { constructorTagModifier = map toLower . drop 4 } ''MyoCommandType -deriveFromJSON defaultOptions { constructorTagModifier = map toLower . drop 4 } ''MyoResult +-- +-- JSON instances +-- + +deriveJSON defaultOptions ''MyoID +deriveFromJSON defaultOptions { fieldLabelModifier = drop 5 } ''Event +deriveFromJSON defaultOptions { constructorTagModifier = map toLower } ''Result +deriveJSON defaultOptions { constructorTagModifier = drop 4 . map toLower } ''Vibration +deriveJSON defaultOptions { constructorTagModifier = drop 4 . map toLower } ''StreamEMGStatus +deriveJSON defaultOptions { constructorTagModifier = drop 4 . map toLower } ''LockingPolicy +deriveJSON defaultOptions { constructorTagModifier = map toLower } ''UserAction +deriveJSON defaultOptions { constructorTagModifier = map toLower } ''UnlockMode deriveFromJSON defaultOptions { fieldLabelModifier = drop 5 } ''Orientation -deriveFromJSON defaultOptions { constructorTagModifier = map toLower . drop 4 } ''MyoEventType -deriveFromJSON defaultOptions { constructorTagModifier = map toLower } ''MyoPose -deriveFromJSON defaultOptions { constructorTagModifier = map toLower } ''MyoDirection -deriveFromJSON defaultOptions { constructorTagModifier = map toLower . drop 4 } ''MyoArm +deriveFromJSON defaultOptions { constructorTagModifier = map toLower . drop 4 } ''EventType +deriveFromJSON defaultOptions { constructorTagModifier = map toLower } ''Pose +deriveFromJSON defaultOptions { constructorTagModifier = map toLower } ''Direction +deriveFromJSON defaultOptions { constructorTagModifier = map toLower . drop 4 } ''Arm +deriveFromJSON defaultOptions { fieldLabelModifier = drop 5 } ''Acknowledgement +deriveFromJSON defaultOptions { constructorTagModifier = drop 4 } ''AcknowledgedCommand ------------------------------------------------------------------------------- +-- -- Lenses -makeLenses ''MyoEvent -makeLenses ''MyoCommand -makeLenses ''MyoVersion +-- + +makeLenses ''Event +makeLenses ''Version