diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -75,6 +75,12 @@ bluetoothd --version ``` +Note that for version 5.41 in particular you'll need to run `bluetoothd` with +the experimental flag. (You might have to change `/lib/systemd/system/bluetooth.service` +to add `--experimental` to the `ExecStart` command, and the restart the +bluetoothd service) + + ### Contributing Note that quite a number of tests are protected by a flag (`hasDBus`). This is diff --git a/ble.cabal b/ble.cabal --- a/ble.cabal +++ b/ble.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: ble -version: 0.4.0.0 +version: 0.4.1 synopsis: Bluetooth Low Energy (BLE) peripherals description: This package provides a Haskell API for writing Bluetooth Low Energy peripherals. stability: alpha @@ -131,6 +131,7 @@ , data-default-class >= 0.0 && < 0.2 , ble , hslogger + , optparse-applicative >= 0.12 && < 0.14 if flag(hasDBus) cpp-options: -DDBusMock other-modules: diff --git a/examples/HeartRate.hs b/examples/HeartRate.hs --- a/examples/HeartRate.hs +++ b/examples/HeartRate.hs @@ -3,22 +3,32 @@ -- This example contains a demonstration of the standard Heart Rate Service -- (HRS). It serves as an examples of using notifications. +-- +-- The program takes a command line argument to allow using controllers other +-- than the default (hci0). If you have multiple controllers on a single +-- machine (either hardware or virtual with something such as 'btvirt'), you +-- can thus test this service with the heart-rate client executable. import Bluetooth +import Bluetooth.Internal.Interfaces (bluezPath) import Control.Concurrent import Control.Monad import Control.Monad.IO.Class import Data.IORef import Data.Monoid -import System.Random (randomRIO) +import Data.String (fromString) +import Data.Word (Word8) import System.Log.Logger +import System.Random (randomRIO) -import qualified Data.Serialize as S -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS +import qualified Options.Applicative as Opt main :: IO () main = do - updateGlobalLogger rootLoggerName (setLevel DEBUG) + options <- Opt.execParser opts + writeIORef bluezPath $ fromString $ "/org/bluez/" ++ controller options + when (verbose options) $ updateGlobalLogger rootLoggerName (setLevel DEBUG) heartRateRef <- newIORef 0 let s = AppState heartRateRef conn <- connect @@ -39,9 +49,34 @@ threadDelay (10 ^ 7) data AppState = AppState - { currentHeartRate :: IORef Int + { currentHeartRate :: IORef Word8 } +data Options = Options + { controller :: String + , verbose :: Bool + } + +opts :: Opt.ParserInfo Options +opts = Opt.info + (parser Opt.<**> Opt.helper) + ( Opt.fullDesc + <> Opt.progDesc "Print a greeting for TARGET" + <> Opt.header "hello - a test for optparse-applicative" ) + +parser :: Opt.Parser Options +parser = Options + <$> Opt.strOption + ( Opt.long "controller" + <> Opt.metavar "HCIX" + <> Opt.showDefault + <> Opt.value "hci0" + <> Opt.help "Controller to use") + <*> Opt.switch + ( Opt.long "verbose" + <> Opt.short 'v' + <> Opt.help "Print debugging info to console") + app :: AppState -> Application app appState = "/com/turingjump/example/hrs" @@ -67,8 +102,8 @@ writeIORef (currentHeartRate appState) v return True -heartRateToBS :: Int -> BS.ByteString -heartRateToBS i = "0x06" <> S.encode i +heartRateToBS :: Word8 -> BS.ByteString +heartRateToBS i = BS.singleton 0x06 <> BS.singleton i bodySensorLocation :: CharacteristicBS 'Local bodySensorLocation diff --git a/examples/HeartRateClient.hs b/examples/HeartRateClient.hs --- a/examples/HeartRateClient.hs +++ b/examples/HeartRateClient.hs @@ -1,9 +1,14 @@ module Main (main) where import Bluetooth -import Data.Maybe -import Control.Monad.IO.Class +import Control.Concurrent +import Data.Bits (testBit) +import Data.Word (Word16) +import qualified Data.ByteString as BS +import qualified Data.Serialize as S + + -- This example contains a demonstration of a client that interacts with a -- Heart Rate Service. @@ -12,41 +17,45 @@ res <- connect >>= runBluetoothM go case res of Left e -> error $ show e - Right () -> return () + Right () -> threadDelay 1000000000000 where go = do mhrs <- getService "0000180d-0000-1000-8000-00805f9b34fb" - - let mhandlers = case mhrs of + let handler = case mhrs of Nothing -> error "No heart rate service found!" - Just hrs -> do - bodyLocChar <- listToMaybe $ filter - (\x -> x ^. uuid == bodySensorLocationUUID) - (hrs ^. characteristics) - readBodyLoc <- bodyLocChar ^. readValue - measurementChar <- listToMaybe $ filter - (\x -> x ^. uuid == heartRateMeasurementUUID) - (hrs ^. characteristics) - readMeasurement <- measurementChar ^. readValue - return (readBodyLoc, readMeasurement) + Just hrs -> case filter + (\x -> x ^. uuid == heartRateMeasurementUUID) + (hrs ^. characteristics) of + [] -> error "Couldn't find expected characteristics" + measurementChar:_ -> measurementChar + handleNotify handler - case mhandlers of - Nothing -> error "Couldn't find expected characteristics, or they're not readable" - Just (rbodyLoc, rmeasurement) -> do - liftIO $ putStrLn "Reading body location" - bodyLoc <- rbodyLoc - liftIO $ print bodyLoc + handleNotify rmeasurement = startNotify rmeasurement $ + \x -> case deserializeMeasurement x of + Nothing -> putStrLn "Error decoding value" + Just v -> do + putStrLn $ "Received Heart Rate: " ++ show v - liftIO $ putStrLn "Reading heart rate" - measurement <- rmeasurement - liftIO $ print measurement +-- * Types +-- Heart rate in bpm +newtype HeartRate = HeartRate Integer + deriving (Eq, Show, Read) +-- See https://www.bluetooth.com/specifications/gatt/viewer?attributeXmlFile=org.bluetooth.characteristic.heart_rate_measurement.xml +deserializeMeasurement :: BS.ByteString -> Maybe HeartRate +deserializeMeasurement bs = do + (flags, dat) <- BS.uncons bs + if not $ testBit flags 0 + -- Uses uint8 + then HeartRate . toInteger . fst <$> BS.uncons dat + -- Uses uint16 + else case S.decode $ BS.take 2 dat of + Left e -> error $ show e + Right (v :: Word16) -> Just $ HeartRate $ toInteger v + -- * Constants heartRateMeasurementUUID :: UUID heartRateMeasurementUUID = "00002a37-0000-1000-8000-00805f9b34fb" - -bodySensorLocationUUID :: UUID -bodySensorLocationUUID = "00002a38-0000-1000-8000-00805f9b34fb" diff --git a/examples/README.lhs b/examples/README.lhs --- a/examples/README.lhs +++ b/examples/README.lhs @@ -75,6 +75,12 @@ bluetoothd --version ``` +Note that for version 5.41 in particular you'll need to run `bluetoothd` with +the experimental flag. (You might have to change `/lib/systemd/system/bluetooth.service` +to add `--experimental` to the `ExecStart` command, and the restart the +bluetoothd service) + + ### Contributing Note that quite a number of tests are protected by a flag (`hasDBus`). This is diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: ble -version: 0.4.0.0 +version: 0.4.1 synopsis: Bluetooth Low Energy (BLE) peripherals description: > This package provides a Haskell API for writing Bluetooth Low Energy @@ -126,6 +126,7 @@ dependencies: - ble - hslogger + - optparse-applicative >= 0.12 && < 0.14 auth: main: Auth.hs source-dirs: examples diff --git a/src/Bluetooth/Internal/DBus.hs b/src/Bluetooth/Internal/DBus.hs --- a/src/Bluetooth/Internal/DBus.hs +++ b/src/Bluetooth/Internal/DBus.hs @@ -3,6 +3,7 @@ import Control.Monad.Except import Control.Monad.Reader import Data.IORef (readIORef, writeIORef) +import Data.Maybe (catMaybes) import Data.Monoid ((<>)) import DBus import DBus.Signal (execSignalT) @@ -163,7 +164,8 @@ let unmakeAny :: (Representable a) => DBusValue 'TypeVariant -> Maybe a unmakeAny x = fromRep =<< fromVariant x uuid' :: UUID <- unmakeAny =<< Map.lookup "UUID" dict - properties' <- unmakeAny =<< Map.lookup "Flags" dict + properties'' :: [DBusValue (RepType T.Text)] <- unmakeAny =<< Map.lookup "Flags" dict + let properties' = catMaybes $ fmap fromRep properties'' let mrv = if any (`elem` readProps) properties' then Just $ callMethodBM charPath gattCharacteristicIFace "ReadValue" ()