diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ # ble - Bluetooth Low Energy for Haskell -*ble* is a Haskell library for writing Bluetooth Low Energy peripherals (and -soon centrals). +*ble* is a Haskell library for writing Bluetooth Low Energy peripherals and +centrals. For usage, see the [haddocks](https://hackage.haskell.org/package/ble). There are also examples in @@ -37,12 +37,12 @@ = "/com/turingjump/example/counter" & services .~ [counter ref] -counter :: TVar Int -> Service +counter :: TVar Int -> Service 'Local counter ref = "4f1f704f-0a0b-49e4-bd27-6368f27697a7" & characteristics .~ [getCounter ref] -getCounter :: TVar Int -> CharacteristicBS +getCounter :: TVar Int -> CharacteristicBS 'Local getCounter ref = "90874979-563e-4224-9da6-3b1a6c03e97d" & readValue ?~ encodeRead readV @@ -63,6 +63,9 @@ return True ~~~ +You can also write centrals (clients). See `HeartRateClient` in the `examples` +directory. + ## Requirements `ble` currently only supports Linux, and requires Bluez versions 5.41 and up. @@ -71,3 +74,30 @@ ``` bash bluetoothd --version ``` + +### Contributing + +Note that quite a number of tests are protected by a flag (`hasDBus`). This is +in part because of extra system dependencies; and in part because the tests +require mocking DBus objects, which in turn require changing the dbus +configuration files. + +If you are contributing to this packages, you *should* run all tests (and +possibly write further ones utilizing the mock infrastructure). You'll need to +run: + +``` bash +sudo ./test/Mock/dbus-permissions.sh +``` + +And then reboot (yes, terrible, but DBus has trouble reloading its +configuration). + +You then need the python dependencies. Minimally, this will involve: + +``` bash +pip install -r test/Mock/requirements.txt +``` + +`stack.yaml` has the `hasDBus` flag set, so if you're using `stack` you'll by +default be running all the tests. 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.3.4.0 +version: 0.4.0.0 synopsis: Bluetooth Low Energy (BLE) peripherals description: This package provides a Haskell API for writing Bluetooth Low Energy peripherals. stability: alpha @@ -22,7 +22,11 @@ LICENSE package.yaml README.md + test/Mock/requirements.txt +data-files: + test/Mock/start_mock.sh + source-repository head type: git location: https://github.com/plow-technologies/ble @@ -37,6 +41,11 @@ manual: True default: True +flag hasDBus + description: Whether to run tests that require DBus mocking + manual: True + default: False + library hs-source-dirs: src @@ -53,15 +62,15 @@ , containers >= 0.5 && < 0.6 , random >= 1 && < 2 , microlens >= 0.4 && < 0.5 - , microlens-th >= 0.4 && < 0.5 , microlens-ghc >= 0.4 && < 0.5 , cereal >= 0.4 && < 0.6 , data-default-class >= 0.0 && < 0.2 - if flag(hasBluez) - cpp-options: -DBluez + if flag(hasDBus) + cpp-options: -DDBusMock exposed-modules: Bluetooth Bluetooth.Internal.DBus + Bluetooth.Internal.Device Bluetooth.Internal.Errors Bluetooth.Internal.HasInterface Bluetooth.Internal.Interfaces @@ -88,15 +97,15 @@ , containers >= 0.5 && < 0.6 , random >= 1 && < 2 , microlens >= 0.4 && < 0.5 - , microlens-th >= 0.4 && < 0.5 , microlens-ghc >= 0.4 && < 0.5 , cereal >= 0.4 && < 0.6 , data-default-class >= 0.0 && < 0.2 , ble - if flag(hasBluez) - cpp-options: -DBluez + if flag(hasDBus) + cpp-options: -DDBusMock other-modules: HeartRate + HeartRateClient README default-language: Haskell2010 @@ -117,19 +126,48 @@ , containers >= 0.5 && < 0.6 , random >= 1 && < 2 , microlens >= 0.4 && < 0.5 - , microlens-th >= 0.4 && < 0.5 , microlens-ghc >= 0.4 && < 0.5 , cereal >= 0.4 && < 0.6 , data-default-class >= 0.0 && < 0.2 , ble , hslogger - if flag(hasBluez) - cpp-options: -DBluez + if flag(hasDBus) + cpp-options: -DDBusMock other-modules: Auth + HeartRateClient README default-language: Haskell2010 +executable hrs-client + main-is: HeartRateClient.hs + hs-source-dirs: + examples + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.8 && < 4.10 + , bytestring >= 0.10 && < 0.11 + , text >= 1 && < 2 + , d-bus >= 0.1.5 && < 0.2 + , uuid >= 1 && < 2 + , mtl >= 2.2 && < 2.3 + , transformers >= 0.4 && < 0.6 + , containers >= 0.5 && < 0.6 + , random >= 1 && < 2 + , microlens >= 0.4 && < 0.5 + , microlens-ghc >= 0.4 && < 0.5 + , cereal >= 0.4 && < 0.6 + , data-default-class >= 0.0 && < 0.2 + , ble + if flag(hasDBus) + cpp-options: -DDBusMock + other-modules: + Auth + HeartRate + README + default-language: Haskell2010 + executable readme main-is: README.lhs hs-source-dirs: @@ -147,18 +185,18 @@ , containers >= 0.5 && < 0.6 , random >= 1 && < 2 , microlens >= 0.4 && < 0.5 - , microlens-th >= 0.4 && < 0.5 , microlens-ghc >= 0.4 && < 0.5 , cereal >= 0.4 && < 0.6 , data-default-class >= 0.0 && < 0.2 , ble , stm , markdown-unlit - if flag(hasBluez) - cpp-options: -DBluez + if flag(hasDBus) + cpp-options: -DDBusMock other-modules: Auth HeartRate + HeartRateClient default-language: Haskell2010 test-suite spec @@ -179,7 +217,6 @@ , containers >= 0.5 && < 0.6 , random >= 1 && < 2 , microlens >= 0.4 && < 0.5 - , microlens-th >= 0.4 && < 0.5 , microlens-ghc >= 0.4 && < 0.5 , cereal >= 0.4 && < 0.6 , data-default-class >= 0.0 && < 0.2 @@ -187,12 +224,14 @@ , hspec > 2 && < 3 , QuickCheck >= 2.8 && < 2.10 , quickcheck-instances >= 0.3 && < 0.4 + , process >= 1.2 && < 1.5 , hslogger - if flag(hasBluez) - cpp-options: -DBluez + if flag(hasDBus) + cpp-options: -DDBusMock other-modules: Bluetooth.TypesSpec BluetoothSpec Doctest + Mock Spec default-language: Haskell2010 diff --git a/examples/Auth.hs b/examples/Auth.hs --- a/examples/Auth.hs +++ b/examples/Auth.hs @@ -30,12 +30,12 @@ = "/com/turingjump/example/auth" & services .~ [auth] -auth :: Service +auth :: Service 'Local auth = "18b2e7ec-2706-429e-a021-ab5e8158477b" & characteristics .~ [secret] -secret :: CharacteristicBS +secret :: CharacteristicBS 'Local secret = "5bf24762-d9d1-445f-b81d-87069cc35e36" & readValue ?~ encodeRead (return ("Juke/19" :: String)) diff --git a/examples/HeartRate.hs b/examples/HeartRate.hs --- a/examples/HeartRate.hs +++ b/examples/HeartRate.hs @@ -47,12 +47,12 @@ = "/com/turingjump/example/hrs" & services .~ [heartRateService appState] -heartRateService :: AppState -> Service +heartRateService :: AppState -> Service 'Local heartRateService appState = "0000180d-0000-1000-8000-00805f9b34fb" & characteristics .~ [heartRateMeasurement appState, bodySensorLocation] -heartRateMeasurement :: AppState -> CharacteristicBS +heartRateMeasurement :: AppState -> CharacteristicBS 'Local heartRateMeasurement appState = "00002a37-0000-1000-8000-00805f9b34fb" & readValue ?~ fmap heartRateToBS (liftIO . readIORef $ currentHeartRate appState) @@ -70,7 +70,7 @@ heartRateToBS :: Int -> BS.ByteString heartRateToBS i = "0x06" <> S.encode i -bodySensorLocation :: CharacteristicBS +bodySensorLocation :: CharacteristicBS 'Local bodySensorLocation = "00002a38-0000-1000-8000-00805f9b34fb" & readValue ?~ encodeRead (return (0x01 :: Word)) diff --git a/examples/HeartRateClient.hs b/examples/HeartRateClient.hs new file mode 100644 --- /dev/null +++ b/examples/HeartRateClient.hs @@ -0,0 +1,52 @@ +module Main (main) where + +import Bluetooth +import Data.Maybe +import Control.Monad.IO.Class + +-- This example contains a demonstration of a client that interacts with a +-- Heart Rate Service. + +main :: IO () +main = do + res <- connect >>= runBluetoothM go + case res of + Left e -> error $ show e + Right () -> return () + + where + go = do + mhrs <- getService "0000180d-0000-1000-8000-00805f9b34fb" + + let mhandlers = 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) + + 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 + + liftIO $ putStrLn "Reading heart rate" + measurement <- rmeasurement + liftIO $ print measurement + + +-- * 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 @@ -1,7 +1,7 @@ # ble - Bluetooth Low Energy for Haskell -*ble* is a Haskell library for writing Bluetooth Low Energy peripherals (and -soon centrals). +*ble* is a Haskell library for writing Bluetooth Low Energy peripherals and +centrals. For usage, see the [haddocks](https://hackage.haskell.org/package/ble). There are also examples in @@ -37,12 +37,12 @@ = "/com/turingjump/example/counter" & services .~ [counter ref] -counter :: TVar Int -> Service +counter :: TVar Int -> Service 'Local counter ref = "4f1f704f-0a0b-49e4-bd27-6368f27697a7" & characteristics .~ [getCounter ref] -getCounter :: TVar Int -> CharacteristicBS +getCounter :: TVar Int -> CharacteristicBS 'Local getCounter ref = "90874979-563e-4224-9da6-3b1a6c03e97d" & readValue ?~ encodeRead readV @@ -63,6 +63,9 @@ return True ~~~ +You can also write centrals (clients). See `HeartRateClient` in the `examples` +directory. + ## Requirements `ble` currently only supports Linux, and requires Bluez versions 5.41 and up. @@ -71,3 +74,30 @@ ``` bash bluetoothd --version ``` + +### Contributing + +Note that quite a number of tests are protected by a flag (`hasDBus`). This is +in part because of extra system dependencies; and in part because the tests +require mocking DBus objects, which in turn require changing the dbus +configuration files. + +If you are contributing to this packages, you *should* run all tests (and +possibly write further ones utilizing the mock infrastructure). You'll need to +run: + +``` bash +sudo ./test/Mock/dbus-permissions.sh +``` + +And then reboot (yes, terrible, but DBus has trouble reloading its +configuration). + +You then need the python dependencies. Minimally, this will involve: + +``` bash +pip install -r test/Mock/requirements.txt +``` + +`stack.yaml` has the `hasDBus` flag set, so if you're using `stack` you'll by +default be running all the tests. diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: ble -version: 0.3.4.0 +version: 0.4.0.0 synopsis: Bluetooth Low Energy (BLE) peripherals description: > This package provides a Haskell API for writing Bluetooth Low Energy @@ -26,12 +26,20 @@ description: Whether to run tests that require Bluez manual: True default: True + hasDBus: + description: Whether to run tests that require DBus mocking + manual: True + default: False extra-source-files: - README.md - package.yaml - LICENSE + - test/Mock/requirements.txt +data-files: + - test/Mock/start_mock.sh + when: - condition: flag(bluez543) cpp-options: -DBluezGEQ543 @@ -40,6 +48,10 @@ - condition: flag(hasBluez) cpp-options: -DBluez +when: + - condition: flag(hasDBus) + cpp-options: -DDBusMock + dependencies: - base >= 4.8 && < 4.10 - bytestring >= 0.10 && < 0.11 @@ -51,7 +63,6 @@ - containers >= 0.5 && < 0.6 - random >= 1 && < 2 - microlens >= 0.4 && < 0.5 - - microlens-th >= 0.4 && < 0.5 - microlens-ghc >= 0.4 && < 0.5 - cereal >= 0.4 && < 0.6 - data-default-class >= 0.0 && < 0.2 @@ -90,6 +101,7 @@ - hspec > 2 && < 3 - QuickCheck >= 2.8 && < 2.10 - quickcheck-instances >= 0.3 && < 0.4 + - process >= 1.2 && < 1.5 - hslogger # doctest: # main: Doctest.hs @@ -116,6 +128,11 @@ - hslogger auth: main: Auth.hs + source-dirs: examples + dependencies: + - ble + hrs-client: + main: HeartRateClient.hs source-dirs: examples dependencies: - ble diff --git a/src/Bluetooth.hs b/src/Bluetooth.hs --- a/src/Bluetooth.hs +++ b/src/Bluetooth.hs @@ -16,7 +16,9 @@ -- ['Advertisement'] This describes how an application will advertise itself -- to other BLE devices. -- --- All three have @IsString@ instances and lens field accessors. The +-- ['Device'] Refers to a BLE-capable device. +-- +-- All four have @IsString@ instances and lens field accessors. The -- recommended way of using this library is by using the @OverloadedStrings@ -- pragma and lenses. A complete example can be found -- . @@ -44,6 +46,7 @@ -- > threadDelay maxBound module Bluetooth ( + -- * Writing peripherals/servers registerApplication , registerAndAdvertiseApplication , unregisterApplication @@ -54,6 +57,30 @@ , runBluetoothM , runHandler + -- ** Notifications + , characteristicIsNotifying + , triggerNotification + + -- * Writing centrals/clients + , getAllServices + , getService + + -- ** Notifications + , startNotify + , stopNotify + + -- * Devices + , getAllDevices + , connectTo + , disconnectFrom + , isConnected + , pairWith + , isPaired + , trust + , distrust + , isTrusted + , getDeviceServiceUUIDs + -- * Field lenses , uuid , properties @@ -71,9 +98,6 @@ , includeTxPower , connectionName - -- * Notifications - , characteristicIsNotifying - , triggerNotification @@ -89,6 +113,8 @@ , CharacteristicBS , Advertisement(..) , WithObjectPath + , Location(..) + , Device(..) -- * Encoding and decoding @@ -113,11 +139,12 @@ , module Lens.Micro.GHC ) where -import Bluetooth.Internal.DBus as X -import Bluetooth.Internal.Types as X +import Bluetooth.Internal.DBus as X +import Bluetooth.Internal.Device as X +import Bluetooth.Internal.Errors as X +import Bluetooth.Internal.Lenses as X import Bluetooth.Internal.Serialize as X -import Bluetooth.Internal.Errors as X -import Bluetooth.Internal.Lenses as X +import Bluetooth.Internal.Types as X import Lens.Micro import Lens.Micro.GHC 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 @@ -8,16 +8,18 @@ import DBus.Signal (execSignalT) import Lens.Micro +import qualified Data.ByteString as BS import qualified Data.Map as Map import qualified Data.Text as T +import Bluetooth.Internal.Errors import Bluetooth.Internal.HasInterface import Bluetooth.Internal.Interfaces +import Bluetooth.Internal.Lenses import Bluetooth.Internal.Types import Bluetooth.Internal.Utils -import Bluetooth.Internal.Errors -import Bluetooth.Internal.Lenses + -- | Registers an application and advertises it. If you would like to have -- finer-grained control of the advertisement, use @registerApplication@ and -- @advertise@. @@ -32,10 +34,8 @@ registerApplication app = do conn <- ask addAllObjs conn app - () <- toBluetoothM . const - $ callMethod bluezName bluezPath (T.pack gattManagerIFace) - "RegisterApplication" args [] - $ dbusConn conn + bluezPath' <- liftIO $ readIORef bluezPath + () <- callMethodBM bluezPath' gattManagerIFace "RegisterApplication" args return $ ApplicationRegistered (app ^. path) where args :: (ObjectPath, Map.Map T.Text Any) @@ -43,11 +43,8 @@ unregisterApplication :: ApplicationRegistered -> BluetoothM () unregisterApplication (ApplicationRegistered appPath) = do - conn <- ask - toBluetoothM . const - $ callMethod bluezName bluezPath (T.pack gattManagerIFace) - "UnregisterApplication" appPath [] - $ dbusConn conn + bluezPath' <- liftIO $ readIORef bluezPath + callMethodBM bluezPath' gattManagerIFace "UnregisterApplication" appPath -- | Adds handlers for all the objects managed by the Application (plus the @@ -79,9 +76,8 @@ addObject conn (adv ^. path) $ (adv `withInterface` leAdvertisementIFaceP) <> ((adv ^. value) `withInterface` propertiesIFaceP) - toBluetoothM . const $ do - callMethod bluezName bluezPath (T.pack leAdvertisingManagerIFace) "RegisterAdvertisement" args [] - $ dbusConn conn + bluezPath' <- liftIO $ readIORef bluezPath + callMethodBM bluezPath' leAdvertisingManagerIFace "RegisterAdvertisement" args where args :: (ObjectPath, Map.Map T.Text Any) args = (adv ^. path, Map.empty) @@ -89,10 +85,8 @@ -- | Unregister an adverstisement. unadvertise :: WithObjectPath Advertisement -> BluetoothM () unadvertise adv = do - conn <- ask - toBluetoothM . const $ do - callMethod bluezName bluezPath (T.pack leAdvertisingManagerIFace) "UnregisterAdvertisement" args [] - $ dbusConn conn + bluezPath' <- liftIO $ readIORef bluezPath + callMethodBM bluezPath' leAdvertisingManagerIFace "UnregisterAdvertisement" args where args :: ObjectPath args = adv ^. path @@ -108,7 +102,7 @@ -- | Triggers notifications or indications. -triggerNotification :: ApplicationRegistered -> CharacteristicBS -> BluetoothM () +triggerNotification :: ApplicationRegistered -> CharacteristicBS 'Local -> BluetoothM () triggerNotification (ApplicationRegistered _) c = do case c ^. readValue of Nothing -> throwError "Handler does not have a readValue implementation!" @@ -130,10 +124,122 @@ Left e -> throwError . DBusError . MethodErrorMessage $ errorBody e Right val -> return val --- * Constants +-- | Get a service by UUID. Returns Nothing if the service could not be found. +getService :: UUID -> BluetoothM (Maybe (Service 'Remote)) +getService serviceUUID = do + services' <- getAllServices + return $ case filter (\x -> x ^. uuid == serviceUUID) services' of + [] -> Nothing + -- This should never be a list with more than one element. + (x:_) -> Just x -bluezName :: T.Text -bluezName = "org.bluez" +-- | Get all registered services. +getAllServices :: BluetoothM [Service 'Remote] +getAllServices = do + objects :: Map.Map ObjectPath (Map.Map T.Text (Map.Map T.Text DontCareFromRep)) + <- callMethodBM "/" objectManagerIFace "GetManagedObjects" () -bluezPath :: ObjectPath -bluezPath = "/org/bluez/hci0" + -- We need to construct services manually, since we get the characteristics + -- separately. + let chars = + Map.keys $ Map.filter (T.pack gattCharacteristicIFace `Map.member`) objects + let servs = + Map.keys $ Map.filter (T.pack gattServiceIFace `Map.member`) objects + forM servs $ \s -> mkService s [ c | c <- chars , s `isPathPrefix` c ] + + where + + readProps :: [CharacteristicProperty] + readProps = [CPRead, CPEncryptRead, CPEncryptAuthenticatedRead] + + writeProps :: [CharacteristicProperty] + writeProps = [ CPWrite, CPWriteWithoutResponse, CPEncryptWrite + , CPEncryptAuthenticatedRead, CPAuthenticatedSignedWrites] + + charFromRep :: ObjectPath -> DBusValue AnyDBusDict + -> Maybe (CharacteristicBS 'Remote) + charFromRep charPath dict' = do + dict :: Map.Map T.Text (DBusValue 'TypeVariant) <- fromRep dict' + 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 + let mrv = if any (`elem` readProps) properties' + then Just $ + callMethodBM charPath gattCharacteristicIFace "ReadValue" () + else Nothing + let mwv = if any (`elem` writeProps) properties' + then Just $ + callMethodBM charPath gattCharacteristicIFace "WriteValue" + else Nothing + let char = RemoteChar uuid' properties' mrv mwv charPath + return char + + mkChar :: ObjectPath -> BluetoothM (CharacteristicBS 'Remote) + mkChar charPath = do + charProps <- callMethodBM charPath propertiesIFace "GetAll" + (T.pack gattCharacteristicIFace) + case charFromRep charPath charProps of + Nothing -> throwError $ OtherError + "Bluez returned invalid characteristic" + Just c -> return c + + serviceFromRep :: DBusValue AnyDBusDict -> Maybe (Service m) + serviceFromRep dict' = do + dict :: Map.Map T.Text (DBusValue 'TypeVariant) <- fromRep dict' + let unmakeAny :: (Representable a) => DBusValue 'TypeVariant -> Maybe a + unmakeAny x = fromRep =<< fromVariant x + uuid' :: UUID <- unmakeAny =<< Map.lookup "UUID" dict + return $ Service uuid' [] + + mkService :: ObjectPath -> [ObjectPath] -> BluetoothM (Service 'Remote) + mkService servicePath charPaths = do + serviceProps <- callMethodBM servicePath propertiesIFace "GetAll" + (T.pack gattServiceIFace) + chars <- mapM mkChar charPaths + case serviceFromRep serviceProps of + Nothing -> throwError $ OtherError + "Bluez returned invalid service" + Just serv -> return $ serv & characteristics .~ chars + +-- | Starts notifications on the remote (peripheral), handling it with the +-- provided callback. +startNotify :: + {-(Representable a, ArgParity (FlattenRepType (RepType a)) ~ 'Arg 'Null)-} + CharacteristicBS 'Remote -> (BS.ByteString -> IO ()) -> BluetoothM () +startNotify char handler = do + conn <- dbusConn <$> ask + rprop <- liftIO $ valRemoteProp char + liftIO $ handlePropertyChanged rprop (whenJust handler) conn + callMethodBM (char ^. path) gattCharacteristicIFace "StartNotify" () + where + whenJust fn (Just v) = fn v + whenJust _ Nothing = return () + +-- | Stop notifications on the remote (peripheral). +stopNotify :: Characteristic 'Remote a -> BluetoothM () +stopNotify char + = callMethodBM (char ^. path) gattCharacteristicIFace "StopNotify" () + +-- Helpers + +valRemoteProp :: CharacteristicBS 'Remote -> IO (RemoteProperty (RepType BS.ByteString)) +valRemoteProp char = do + bluezName' <- readIORef bluezName + return $ RP + { rpEntity = bluezName' -- Is this the right entity? + , rpObject = char ^. path + , rpInterface = T.pack gattCharacteristicIFace + , rpName = "Value" + } + +callMethodBM :: (Representable args, Representable ret) + => ObjectPath + -> String + -> T.Text + -> args + -> BluetoothM ret +callMethodBM opath iface methodName args = do + conn <- ask + bluezName' <- liftIO $ readIORef bluezName + toBluetoothM . const $ callMethod bluezName' opath (T.pack iface) methodName args [] (dbusConn conn) diff --git a/src/Bluetooth/Internal/Device.hs b/src/Bluetooth/Internal/Device.hs new file mode 100644 --- /dev/null +++ b/src/Bluetooth/Internal/Device.hs @@ -0,0 +1,107 @@ +module Bluetooth.Internal.Device where + +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (ask) +import Data.IORef (readIORef) +import DBus (DBusType, RemoteProperty (..), Representable, + callMethod, getProperty, setProperty, ObjectPath) +import Lens.Micro + +import qualified Data.Text as T +import qualified Data.Map as Map + +import Bluetooth.Internal.Interfaces +import Bluetooth.Internal.Lenses +import Bluetooth.Internal.Types + +-- | Retrieves the list of all known devices. This does not by itself do device +-- discovery; instead, it just lists devices that have already been discovered. +-- +-- Usually device discovery happens at regular intervals and automatically. +getAllDevices :: BluetoothM [Device] +getAllDevices = do + conn <- ask + bluezName' <- liftIO $ readIORef bluezName + objects :: Map.Map ObjectPath (Map.Map T.Text (Map.Map T.Text DontCareFromRep)) + <- toBluetoothM . const + $ callMethod bluezName' "/" (T.pack objectManagerIFace) "GetManagedObjects" () + [] (dbusConn conn) + let devices = + Map.keys $ Map.filter (T.pack deviceIFace `Map.member`) objects + return $ Device <$> devices + + +-- Prepositional bestiary + +-- | Connect to a bluetooth device +connectTo :: Device -> BluetoothM () +connectTo dev = callDeviceMethod dev "Connect" + +-- | Disconnect from a bluetooth device +disconnectFrom :: Device -> BluetoothM () +disconnectFrom dev = callDeviceMethod dev "Disonnect" + +-- | Is a device connected? +isConnected :: Device -> BluetoothM Bool +isConnected dev = getDeviceProperty dev "Connected" + +-- | Pair with a device +pairWith :: Device -> BluetoothM () +pairWith dev = callDeviceMethod dev "Pair" + +-- | Is device paired? +isPaired :: Device -> BluetoothM Bool +isPaired dev = getDeviceProperty dev "Paired" + +-- | Trust device +trust :: Device -> BluetoothM () +trust dev = setDeviceProperty dev "Trusted" True + +-- | Stop trusting device +distrust :: Device -> BluetoothM () +distrust dev = setDeviceProperty dev "Trusted" False + +-- | Is device trusted? +isTrusted :: Device -> BluetoothM Bool +isTrusted dev = getDeviceProperty dev "Trusted" + +getDeviceServiceUUIDs :: Device -> BluetoothM [UUID] +getDeviceServiceUUIDs dev = getDeviceProperty dev "UUIDs" + + +-- * Helpers + +callDeviceMethod :: Device -> T.Text -> BluetoothM () +callDeviceMethod dev methodName = do + conn <- ask + bluezName' <- liftIO $ readIORef bluezName + toBluetoothM . const + $ callMethod bluezName' (dev ^. path) (T.pack deviceIFace) methodName () + [] (dbusConn conn) + +setDeviceProperty :: Representable a => Device -> T.Text -> a -> BluetoothM () +setDeviceProperty dev propertyName newValue = do + conn <- ask + prop <- liftIO $ deviceRemoteProperty dev propertyName + liftIO (setProperty prop newValue $ dbusConn conn) >>= \r -> case r of + Left e -> throwError $ DBusError e + Right () -> return () + +getDeviceProperty :: Representable a => Device -> T.Text -> BluetoothM a +getDeviceProperty dev propertyName = do + conn <- ask + prop <- liftIO $ deviceRemoteProperty dev propertyName + liftIO (getProperty prop $ dbusConn conn) >>= \r -> case r of + Left e -> throwError $ DBusError e + Right v -> return v + +deviceRemoteProperty :: Device -> T.Text -> IO (RemoteProperty (b :: DBusType)) +deviceRemoteProperty dev propertyName = do + bluezName' <- readIORef bluezName + return $ RP + { rpEntity = bluezName' -- Is this the right entity? + , rpObject = dev ^. path + , rpInterface = T.pack deviceIFace + , rpName = propertyName + } diff --git a/src/Bluetooth/Internal/Errors.hs b/src/Bluetooth/Internal/Errors.hs --- a/src/Bluetooth/Internal/Errors.hs +++ b/src/Bluetooth/Internal/Errors.hs @@ -12,11 +12,11 @@ import GHC.Generics (Generic) newtype Handler a - = Handler { getReadValue :: ExceptT T.Text IO a } + = Handler { getHandler :: ExceptT T.Text IO a } deriving (Functor, Applicative, Monad, MonadIO, Generic, MonadError T.Text) runHandler :: Handler a -> IO (Either T.Text a) -runHandler = runExceptT . getReadValue +runHandler = runExceptT . getHandler -- | Generic failure errorFailed :: Handler a diff --git a/src/Bluetooth/Internal/HasInterface.hs b/src/Bluetooth/Internal/HasInterface.hs --- a/src/Bluetooth/Internal/HasInterface.hs +++ b/src/Bluetooth/Internal/HasInterface.hs @@ -109,11 +109,11 @@ , signalDArguments = "changes" :> Done } -instance HasInterface (WithObjectPath Service) Properties where +instance HasInterface (WithObjectPath (Service 'Local)) Properties where getInterface service _ = defPropIFace (Just $ service ^. path) (T.pack gattServiceIFace) service -instance HasInterface (WithObjectPath CharacteristicBS) Properties where +instance HasInterface (WithObjectPath (CharacteristicBS 'Local)) Properties where getInterface char _ = baseIface { interfaceProperties = SomeProperty prop : interfaceProperties baseIface } @@ -134,7 +134,7 @@ -- * GattService -instance HasInterface (WithObjectPath Service) GattService where +instance HasInterface (WithObjectPath (Service 'Local)) GattService where getInterface service _ = Interface { interfaceMethods = [] @@ -180,7 +180,7 @@ Left e -> return . Left $ MsgError e Nothing [] Right v -> return $ Right v -instance HasInterface (WithObjectPath CharacteristicBS) GattCharacteristic where +instance HasInterface (WithObjectPath (CharacteristicBS 'Local)) GattCharacteristic where getInterface char _ = Interface { interfaceMethods = [readVal, writeVal, startNotify, stopNotify] @@ -272,13 +272,15 @@ where mvar = characteristicIsNotifying (char ^. value . uuid) -valProp :: WithObjectPath (CharacteristicBS) -> Property (RepType BS.ByteString) +valProp :: WithObjectPath (CharacteristicBS 'Local) + -> Property (RepType BS.ByteString) valProp char = mkProperty (char ^. path) (T.pack gattCharacteristicIFace) "Value" (handlerToMethodHandler <$> char ^. value . readValue) (fmap handlerToMethodHandler <$> char ^. value . writeValue) PECSTrue + instance HasInterface (WithObjectPath Advertisement) LEAdvertisement where diff --git a/src/Bluetooth/Internal/Interfaces.hs b/src/Bluetooth/Internal/Interfaces.hs --- a/src/Bluetooth/Internal/Interfaces.hs +++ b/src/Bluetooth/Internal/Interfaces.hs @@ -1,10 +1,14 @@ module Bluetooth.Internal.Interfaces where +import Data.IORef (IORef, newIORef) import Data.Proxy import DBus import GHC.TypeLits +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.Text as T + type ObjectManager = "org.freedesktop.DBus.ObjectManager" objectManagerIFaceP :: Proxy ObjectManager @@ -14,7 +18,7 @@ objectManagerIFace = symbolVal objectManagerIFaceP -type Properties = "org.freedesktop.DBus.Properties" +type Properties = "org.freedesktop.DBus.Properties" propertiesIFaceP :: Proxy Properties propertiesIFaceP = Proxy @@ -66,6 +70,14 @@ leAdvertisingManagerIFace :: String leAdvertisingManagerIFace = symbolVal leAdvertisingManagerIFaceP +type Device1 = "org.bluez.Device1" + +deviceIFaceP :: Proxy Device1 +deviceIFaceP = Proxy + +deviceIFace :: String +deviceIFace = symbolVal deviceIFaceP + -- * Errors invalidArgs :: MsgError @@ -81,3 +93,14 @@ , errorText = Nothing , errorBody = [] } + +-- * Constants (ish) +-- We use IORefs here rather than have it be a constant because when mocking +-- for tests we can't take up this name. +bluezName :: IORef T.Text +bluezName = unsafePerformIO $ newIORef "org.bluez" +{-# NOINLINE bluezName #-} + +bluezPath :: IORef ObjectPath +bluezPath = unsafePerformIO $ newIORef "/org/bluez/hci0" +{-# NOINLINE bluezPath #-} diff --git a/src/Bluetooth/Internal/Types.hs b/src/Bluetooth/Internal/Types.hs --- a/src/Bluetooth/Internal/Types.hs +++ b/src/Bluetooth/Internal/Types.hs @@ -3,6 +3,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -ddump-splices #-} #if !MIN_VERSION_base(4,9,0) {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} #endif @@ -30,7 +31,6 @@ import GHC.Exts (IsList (..)) import GHC.Generics (Generic) import Lens.Micro -import Lens.Micro.TH (makeFields) import System.IO.Unsafe (unsafePerformIO) import qualified Data.ByteString as BS @@ -44,6 +44,7 @@ import Bluetooth.Internal.Utils import Bluetooth.Internal.Lenses + -- | Append two Texts, keeping exactly one slash between them. () :: T.Text -> T.Text -> T.Text a b @@ -56,7 +57,14 @@ _:xs -> T.intercalate "/" $ reverse xs [] -> "/" +-- * Place +-- | Whether a service/characteristic is running on this computer (`Local`) or +-- another (`Remote`). If `Local`, we're acting as a peripheral; otherwise, as +-- a central. +data Location = Local | Remote + deriving (Eq, Show, Read, Generic) + -- * UUID -- | UUIDs, used for services and characteristics. @@ -105,7 +113,7 @@ let (a', g') = Rand.randomR (lo,hi) g in (UUID a', g') random g = let (a', g') = Rand.random g in (UUID a', g') --- * Any +-- * Any and DontCare -- | A Haskell existential type corresponding to DBus' @Variant@. data Any where @@ -114,7 +122,7 @@ instance Representable Any where type RepType Any = 'TypeVariant toRep (MkAny x) = DBVVariant (toRep x) - fromRep (DBVVariant x) = Just (MkAny x) + fromRep = error "not implemented" -- Note [WithObjectPath] data WithObjectPath a = WOP @@ -122,16 +130,24 @@ , withObjectPathValue :: a } deriving (Eq, Show, Generic, Functor) -makeFields ''WithObjectPath +instance HasPath (WithObjectPath a) ObjectPath where + {-# INLINE path #-} + path f (WOP p v) + = fmap (\y -> WOP y v) (f p) +instance HasValue (WithObjectPath a) a where + {-# INLINE value #-} + value f (WOP p v) + = fmap (\ y -> WOP p y) (f v) -type AnyDBusDict = 'TypeDict 'TypeString 'TypeVariant +data DontCareFromRep = DontCareFromRep + deriving (Eq, Show, Read, Generic) --- * Method +instance Representable DontCareFromRep where + type RepType DontCareFromRep = 'TypeVariant + toRep _ = DBVVariant (toRep ()) + fromRep _ = Just DontCareFromRep -{-data Method where-} - {-ReadValue :: ReadValueM BS.ByteString-} - {-WriteValue :: BS.ByteString -> WriteValueM BS.ByteString-} - {-Notify :: -} +type AnyDBusDict = 'TypeDict 'TypeString 'TypeVariant -- * Descriptor @@ -161,7 +177,6 @@ | CPAuthenticatedSignedWrites | CPNotify | CPIndicate - | CPSignedWriteCommand deriving (Eq, Show, Read, Enum, Bounded, Ord, Generic) instance Representable CharacteristicProperty where @@ -186,14 +201,16 @@ , (CPAuthenticatedSignedWrites, "authenticated-signed-writes") , (CPNotify, "notify") , (CPIndicate, "indicate") - , (CPSignedWriteCommand, "authenticated-signed-writes") ] data CharacteristicOptions = CharacteristicOptions { characteristicOptionsOffset :: Maybe Word16 } deriving (Eq, Show, Read, Generic) -makeFields ''CharacteristicOptions +instance HasOffset CharacteristicOptions (Maybe Word16) where + {-# INLINE offset #-} + offset f (CharacteristicOptions x) + = fmap (\ y -> CharacteristicOptions y) (f x) instance Representable CharacteristicOptions where type RepType CharacteristicOptions = AnyDBusDict @@ -206,20 +223,62 @@ Nothing -> DBVDict [] Just v -> DBVDict [(toRep ("offset" :: T.Text), toRep $ MkAny v)] -type CharacteristicBS = Characteristic BS.ByteString +type CharacteristicBS m = Characteristic m BS.ByteString -data Characteristic typ = Characteristic - { characteristicUuid :: UUID - , characteristicProperties :: [CharacteristicProperty] - , characteristicReadValue :: Maybe (Handler typ) - -- | Write a value. Note that the value is only writeable externally if the - -- characteristic contains the CPWrite property *and* this is a Just. - , characteristicWriteValue :: Maybe (typ -> Handler Bool) - } deriving (Generic) +data Characteristic (loc :: Location) typ where + LocalChar :: + { characteristicLUuid :: UUID + , characteristicLProperties :: [CharacteristicProperty] + , characteristicLReadValue :: Maybe (Handler typ) + , characteristicLWriteValue :: Maybe (typ -> Handler Bool) + } -> Characteristic 'Local typ + RemoteChar :: + { characteristicRUuid :: UUID + , characteristicRProperties :: [CharacteristicProperty] + , characteristicRReadValue :: Maybe (BluetoothM typ) + , characteristicRWriteValue :: Maybe (typ -> BluetoothM Bool) + , characteristicRPath :: ObjectPath + } -> Characteristic 'Remote typ -makeFields ''Characteristic +instance HasProperties (Characteristic m v) [CharacteristicProperty] where + {-# INLINE properties #-} + properties f (LocalChar u p rv wv) + = fmap (\ y -> LocalChar u y rv wv) (f p) + properties f (RemoteChar u p rv wv p') + = fmap (\ y -> RemoteChar u y rv wv p') (f p) +instance HasReadValue (Characteristic 'Local v) (Maybe (Handler v)) where + {-# INLINE readValue #-} + readValue f (LocalChar u p rv wv) + = fmap (\ y -> LocalChar u p y wv) (f rv) +instance HasReadValue (Characteristic 'Remote v) (Maybe (BluetoothM v)) where + {-# INLINE readValue #-} + readValue f (RemoteChar u p rv wv p') + = fmap (\ y -> RemoteChar u p y wv p') (f rv) + +instance HasUuid (Characteristic m v) UUID where + {-# INLINE uuid #-} + uuid f (LocalChar u p rv wv) + = fmap (\ y -> LocalChar y p rv wv) (f u) + uuid f (RemoteChar u p rv wv p') + = fmap (\ y -> RemoteChar y p rv wv p') (f u) + +instance HasWriteValue (Characteristic 'Local v) (Maybe (v -> Handler Bool)) where + {-# INLINE writeValue #-} + writeValue f (LocalChar u p rv wv) + = fmap (\ y -> LocalChar u p rv y) (f wv) + +instance HasWriteValue (Characteristic 'Remote v) (Maybe (v -> BluetoothM Bool)) where + {-# INLINE writeValue #-} + writeValue f (RemoteChar u p rv wv p') + = fmap (\ y -> RemoteChar u p rv y p') (f wv) + +instance HasPath (Characteristic 'Remote v) ObjectPath where + {-# INLINE path #-} + path f (RemoteChar u p rv wv p') + = fmap (\ y -> RemoteChar u p rv wv y) (f p') + -- This is essentialy the unsafePerformIO memoization trick characteristicIsNotifying :: UUID -> MVar Bool characteristicIsNotifying = unsafePerformIO $ do @@ -246,26 +305,12 @@ Just v -> return (curMap, v) {-# NOINLINE objectPathOf #-} -{- --- Like 'characteristicIsNotifying', but for cached values. -characteristicValue :: UUID -> MVar BS.ByteString -characteristicValue = unsafePerformIO $ do - cm <- newMVar $ Map.empty - return $ \uuid' -> unsafePerformIO $ do - modifyMVar cm $ \curMap -> case Map.lookup uuid' curMap of - Nothing -> do - e <- newMVar False - return (Map.insert uuid' e curMap, e) - Just v -> return (curMap, v) -{-# NOINLINE characteristicValue #-} --} - -instance IsString (Characteristic a) where - fromString x = Characteristic (fromString x) [] Nothing Nothing +instance IsString (Characteristic 'Local a) where + fromString x = LocalChar (fromString x) [] Nothing Nothing -- Note [WithObjectPath] -instance Representable (WithObjectPath (Characteristic a)) where - type RepType (WithObjectPath (Characteristic a)) = AnyDBusDict +instance Representable (WithObjectPath (Characteristic m a)) where + type RepType (WithObjectPath (Characteristic m a)) = AnyDBusDict toRep char = toRep tmap where tmap :: Map.Map T.Text Any @@ -273,8 +318,9 @@ , ("Service", MkAny $ (char ^. path) & toText %~ parentPath) , ("Flags", MkAny $ char ^. value . properties) ] - fromRep _ = error "not implemented" + fromRep = error "not implemented" + characteristicObjectPath :: ObjectPath -> Int -> ObjectPath characteristicObjectPath appOPath idx = appOPath & toText %~ addSuffix where @@ -288,19 +334,27 @@ -- * Service -data Service = Service +data Service m = Service { serviceUuid :: UUID - , serviceCharacteristics :: [CharacteristicBS] + , serviceCharacteristics :: [CharacteristicBS m] } deriving (Generic) -makeFields ''Service +instance HasCharacteristics (Service m) [CharacteristicBS m] where + {-# INLINE characteristics #-} + characteristics f (Service u c) + = fmap (\ y -> Service u y) (f c) -instance IsString Service where +instance HasUuid (Service m) UUID where + {-# INLINE uuid #-} + uuid f (Service u c) + = fmap (\ y -> Service y c) (f u) + +instance IsString (Service m) where fromString x = Service (fromString x) [] -- Note [WithObjectPath] -instance Representable (WithObjectPath Service) where - type RepType (WithObjectPath Service) = AnyDBusDict +instance Representable (WithObjectPath (Service m)) where + type RepType (WithObjectPath (Service m)) = AnyDBusDict toRep serv = toRep tmap where tmap :: Map.Map T.Text Any @@ -317,7 +371,6 @@ fromRep _ = error "not implemented" - -- * Application -- | An application. Can be created from it's @IsString@ instance. @@ -325,11 +378,20 @@ -- have relevance within Bluetooth. data Application = Application { applicationPath :: ObjectPath - , applicationServices :: [Service] + , applicationServices :: [Service 'Local] } deriving (Generic) -makeFields ''Application +instance HasPath Application ObjectPath where + {-# INLINE path #-} + path f (Application p s) + = fmap (\ y -> Application y s) (f p) + +instance HasServices Application [Service 'Local] where + {-# INLINE services #-} + services f (Application p s) + = fmap (\ y -> Application p y) (f s) + instance IsString Application where fromString x = Application (fromString x) [] @@ -388,8 +450,49 @@ , advertisementIncludeTxPower :: Bool } deriving (Eq, Show, Generic) -makeFields ''Advertisement +instance HasIncludeTxPower Advertisement Bool where + {-# INLINE includeTxPower #-} + includeTxPower + fn + (Advertisement a b c d e f) + = fmap (\ y -> Advertisement a b c d e y) (fn f) +instance HasManufacturerData Advertisement (Map.Map Word16 BS.ByteString) where + {-# INLINE manufacturerData #-} + manufacturerData + fn + (Advertisement a b c d e f) + = fmap (\ y -> Advertisement a b c y e f) (fn d) + +instance HasServiceData Advertisement (Map.Map UUID BS.ByteString) where + {-# INLINE serviceData #-} + serviceData + fn + (Advertisement a b c d e f) + = fmap (\ y -> Advertisement a b c d y f) (fn e) + +instance HasServiceUUIDs Advertisement [UUID] where + {-# INLINE serviceUUIDs #-} + serviceUUIDs + fn + (Advertisement a b c d e f) + = fmap (\ y -> Advertisement a y c d e f) (fn b) + +instance HasSolicitUUIDs Advertisement [UUID] where + {-# INLINE solicitUUIDs #-} + solicitUUIDs + fn + (Advertisement a b c d e f) + = fmap + (\ y -> Advertisement a b y d e f) (fn c) + +instance HasType_ Advertisement AdvertisementType where + {-# INLINE type_ #-} + type_ + fn + (Advertisement a b c d e f) + = fmap (\ y -> Advertisement y b c d e f) (fn a) + instance IsList Advertisement where type Item Advertisement = UUID fromList services' = Advertisement @@ -425,11 +528,33 @@ instance Default Advertisement where def = Advertisement Peripheral [] [] mempty mempty False +-- * Device +-- | A BLE-enabled device. The @IsString@ instance takes a MAC address such as +-- @11:22:33:44:55:66@ and generates a device connected on @hci0@. Usually this +-- is correct adapter, but if using a different one, use the constructor along +-- with the DBus object path of the device (e.g. +-- @/org/bluez/hci1/dev_11_22_33_44_55_66@). +data Device = Device + { devicePath :: ObjectPath + } deriving (Eq, Show, Generic) +instance HasPath Device ObjectPath where + {-# INLINE path #-} + path f (Device p) + = fmap (\y -> Device y) (f p) + +instance IsString Device where + fromString s = Device . fromString $ "/org/bluez/hci0/dev_" ++ s' + where + s' = fmap (\x -> if x == ':' then '_' else x) s + -- * Connection -- The constructor should not be exported. + +-- A connection to the the DBus message bus. This does *not* represent a +-- connection to a Bluetooth 'Device'. data Connection = Connection { dbusConn :: DBusConnection -- Should it be possible to remove objects? @@ -461,6 +586,7 @@ data Error = DBusError MethodError | BLEError T.Text + | OtherError T.Text deriving (Show, Generic) instance IsString Error where @@ -490,6 +616,7 @@ = Success | Failure deriving (Eq, Show, Read, Ord, Enum, Generic) + {- Note [WithObjectPath] ~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/test/Bluetooth/TypesSpec.hs b/test/Bluetooth/TypesSpec.hs --- a/test/Bluetooth/TypesSpec.hs +++ b/test/Bluetooth/TypesSpec.hs @@ -1,8 +1,12 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Bluetooth.TypesSpec (spec) where +import Data.Maybe (fromJust) import Data.Proxy (Proxy (Proxy)) +import Data.Tuple (swap) +import Data.Void (Void) import DBus +import Lens.Micro import Test.Hspec import Test.QuickCheck import Test.QuickCheck.Instances () @@ -10,6 +14,7 @@ import qualified Data.Text as T import Bluetooth.Internal.Types +import Bluetooth.Internal.Lenses spec :: Spec spec = do @@ -49,6 +54,12 @@ it "contains all constructors of CharacteristicProperty" $ do all (`elem` (fst <$> chrPropPairs)) [minBound..maxBound] `shouldBe` True + it "is one-to-one" $ do + let there = [ fromJust $ lookup d chrPropPairs | d <- fst <$> chrPropPairs ] + let back = [ fromJust $ lookup d (swap <$> chrPropPairs) | d <- there ] + back `shouldBe` fst <$> chrPropPairs + + -- * Utils fromRepToRepInverse @@ -65,18 +76,21 @@ ,"FFFFFFFF-FFFF-FFFF-FFFF-FFFFFFFFFFFF" ) +instance Arbitrary a => Arbitrary (WithObjectPath a) where + arbitrary = WOP <$> arbitrary <*> arbitrary + instance Arbitrary Application where arbitrary = Application <$> arbitrary <*> arbitrary instance Arbitrary ObjectPath where arbitrary = objectPath . T.pack <$> arbitrary -instance Arbitrary Service where +instance Arbitrary (Service 'Local) where arbitrary = Service <$> arbitrary <*> arbitrary -instance (CoArbitrary a, Arbitrary a) - => Arbitrary (Characteristic a) where - arbitrary = Characteristic +instance {-# OVERLAPPABLE #-} (CoArbitrary a, Arbitrary a) + => Arbitrary (Characteristic 'Local a) where + arbitrary = LocalChar <$> arbitrary <*> arbitrary <*> (fmap return <$> arbitrary) @@ -84,3 +98,20 @@ instance Arbitrary CharacteristicProperty where arbitrary = elements [minBound..maxBound] + +instance Eq (Characteristic m Void) where + a == b + = a ^. uuid == b ^. uuid + && a ^. properties == b ^. properties + +instance Show (Characteristic m Void) where + show a = "Characteristic { " + ++ "characteristicUuid = " ++ show (a ^. uuid) ++ ", " + ++ "characteristicProperties = " ++ show (a ^. properties) ++ " }" + +instance {-# OVERLAPPING #-} Arbitrary (Characteristic 'Local Void) where + arbitrary = LocalChar + <$> arbitrary + <*> arbitrary + <*> pure Nothing + <*> pure Nothing diff --git a/test/BluetoothSpec.hs b/test/BluetoothSpec.hs --- a/test/BluetoothSpec.hs +++ b/test/BluetoothSpec.hs @@ -2,29 +2,41 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} #ifndef Bluez {-# OPTIONS_GHC -fno-warn-unused-binds #-} +#else +#ifndef DBus +{-# OPTIONS_GHC -fno-warn-unused-binds #-} #endif +#endif module BluetoothSpec (spec) where import Bluetooth +import Bluetooth.Internal.Types (Error) +import Control.Monad import Control.Monad.IO.Class -import Data.Either (isRight) +import Data.Either (isRight) +import Data.Maybe (isJust) import DBus import Test.Hspec import qualified Data.ByteString as BS +import Mock + spec :: Spec spec = do -#ifndef Bluez - return () -#else +#ifdef Bluez registerApplicationSpec unregisterApplicationSpec advertiseSpec unadvertiseSpec - {-notifySpec-} #endif +#ifdef DBusMock + getServiceSpec + getAllServicesSpec + getAllDevicesSpec +#endif + return () registerApplicationSpec :: Spec registerApplicationSpec = describe "registerApplication" $ before connect $ do @@ -35,6 +47,7 @@ -- We verify that the application is in fact registered by checking that -- attempting to register it again throws an AlreadyExists error. Left err <- runBluetoothM (registerApplication testApp) conn + _ <- runBluetoothM (unregisterApplication $ fromRight v) conn show err `shouldContain` "Already Exists" unregisterApplicationSpec :: Spec @@ -45,6 +58,7 @@ v1 <- runBluetoothM (unregisterApplication p) conn v1 `shouldSatisfy` isRight v2 <- runBluetoothM (registerApplication testApp) conn + void $ runBluetoothM (unregisterApplication $ fromRight v2) conn v2 `shouldSatisfy` isRight advertiseSpec :: Spec @@ -59,7 +73,7 @@ _ <- runBluetoothM (unadvertise ad) conn show err `shouldContain` "Already Exists" - it "adverstises a set of services" $ \conn -> checkAdvert testAdv conn + it "advertises a set of services" $ \conn -> checkAdvert testAdv conn {-it "works with service data" $ \conn -> do-} {-let adv = testAdv-} @@ -84,23 +98,83 @@ v3 <- runBluetoothM (advertise testAdv) conn v3 `shouldSatisfy` isRight -{-notifySpec :: Spec-} -{-notifySpec = describe "notification" $ before connect $ do-} +getServiceSpec :: Spec +getServiceSpec = describe "getService" $ before connect $ do - {-it "accepts StartNotify" $ \conn -> do-} - {-readIORef isNotifying `shouldReturn` False-} - {-v <- runBluetoothM (registerApplication testApp) conn-} - {-_ <- runBluetoothM (testCharacteristic ^. startNotify) conn-} - {-readIORef isNotifying `shouldReturn` True-} + it "retrieves services by UUID" $ \conn -> withAService $ do + Right ms <- runBluetoothM (getService mockServiceUUID) conn + ms `shouldSatisfy` isJust - {-it "accepts StopNotify" $ \conn -> do-} - {-readIORef isNotifying `shouldReturn` False-} - {-v <- runBluetoothM (registerApplication testApp) conn-} - {-_ <- runBluetoothM (testCharacteristic ^. startNotify) conn-} - {-readIORef isNotifying `shouldReturn` True-} - {-_ <- runBluetoothM (testCharacteristic ^. stopNotify) conn-} - {-readIORef isNotifying `shouldReturn` False-} + it "returns Nothing if the application does not exist" $ \conn -> withAService $ do + let unknownUUID = "da92ce4a-2a0f-4c5d-ac68-9d3b01886976" + h <- runBluetoothM (getService unknownUUID) conn + h `shouldBe` Right Nothing + context "the returned service" $ do + + it "has the service's characteristics" $ \conn -> withAService $ do + Right (Just serv) <- runBluetoothM (getService mockServiceUUID) conn + let [char] = serv ^. characteristics + char ^. uuid `shouldBe` mockCharUUID + + it "has characteristics that can be read" $ \conn -> withAService $ do + Right (Just serv) <- runBluetoothM (getService mockServiceUUID) conn + let [char] = serv ^. characteristics + let Just handler = char ^. readValue + res <- runBluetoothM handler conn + res `shouldBe` (Right $ BS.singleton 3) + + it "has characteristics that can be written" $ \conn -> withAService $ do + Right (Just serv) <- runBluetoothM (getService mockServiceUUID) conn + let [char] = serv ^. characteristics + let Just whandler = char ^. writeValue + Just rhandler = char ^. readValue + writeResult <- runBluetoothM (whandler $ BS.singleton 10) conn + writeResult `shouldBe` Right True + readResult <- runBluetoothM rhandler conn + readResult `shouldBe` (Right $ BS.singleton 10) + +getAllServicesSpec :: Spec +getAllServicesSpec = describe "getAllServices" $ before connect $ do + + it "retrieves services" $ \conn -> withAService $ do + Right [service] <- runBluetoothM getAllServices conn + service ^. uuid `shouldBe` mockServiceUUID + +getAllDevicesSpec :: Spec +getAllDevicesSpec = describe "getAllDevices" $ before connect $ do + + it "retrieves devices" $ \conn -> withAService $ do + Right devices <- runBluetoothM getAllDevices conn + devices `shouldContain` ["11:22:33:44:55:66"] + + {-context "the returned device" $-} + {-pendingWith "dbusmock doesn't currently allow changing properties"-} + + {-it "allows connecting" $ \conn -> withAService $ do-} + {-resp1 <- runBluetoothM (isConnected "11:22:33:44:55:66") conn-} + {-resp1 `shouldBe` Right False-} + {-Right () <- runBluetoothM (connectTo "11:22:33:44:55:66") conn-} + {-resp2 <- runBluetoothM (isConnected "11:22:33:44:55:66") conn-} + {-resp2 `shouldBe` Right True-} + + {-it "allows pairing" $ \conn -> withAService $ do-} + {-resp1 <- runBluetoothM (isPaired "11:22:33:44:55:66") conn-} + {-resp1 `shouldBe` Right False-} + {-Right () <- runBluetoothM (pairWith "11:22:33:44:55:66") conn-} + {-resp2 <- runBluetoothM (isPaired "11:22:33:44:55:66") conn-} + {-resp2 `shouldBe` Right True-} + + {-it "allows trusting" $ \conn -> withAService $ do-} + {-resp1 <- runBluetoothM (isTrusted "11:22:33:44:55:66") conn-} + {-resp1 `shouldBe` Right False-} + {-Right () <- runBluetoothM (trust "11:22:33:44:55:66") conn-} + {-resp2 <- runBluetoothM (isTrusted "11:22:33:44:55:66") conn-} + {-resp2 `shouldBe` Right True-} + {-Right () <- runBluetoothM (distrust "11:22:33:44:55:66") conn-} + {-resp3 <- runBluetoothM (isTrusted "11:22:33:44:55:66") conn-} + {-resp3 `shouldBe` Right True-} + -- * Test service testApp :: Application @@ -108,12 +182,12 @@ = "/com/turingjump/test" & services .~ [testService] -testService :: Service +testService :: Service 'Local testService = "351930f8-7d31-43c1-92f5-fd2f0eac272f" & characteristics .~ [testCharacteristic] -testCharacteristic :: CharacteristicBS +testCharacteristic :: CharacteristicBS 'Local testCharacteristic = "cdcb58aa-7e4c-4d22-b0bf-a90cd67ba60b" & readValue ?~ encodeRead go @@ -122,13 +196,28 @@ go :: Handler BS.ByteString go = do liftIO $ putStrLn "Reading characteristic!" - return "s" + return "response" testAdv :: WithObjectPath Advertisement testAdv = advertisementFor testApp +-- * Utils + +fromRight :: Either a b -> b +fromRight (Right x) = x +fromRight _ = error "Expected Right, got Left" + -- * Orphans instance Eq MethodError where a == b = show a == show b + +instance Eq Error where + a == b = show a == show b + +instance Show (Service m) where + show a = show $ a ^. uuid + +instance Eq (Service m) where + a == b = a ^. uuid == b ^. uuid diff --git a/test/Mock.hs b/test/Mock.hs new file mode 100644 --- /dev/null +++ b/test/Mock.hs @@ -0,0 +1,31 @@ +module Mock where + +import Bluetooth (UUID) +import Bluetooth.Internal.Interfaces (bluezName, bluezPath) +import Data.IORef +import Paths_ble +import System.IO +import qualified System.Process as P + +withAService :: IO a -> IO a +withAService action = do + writeIORef bluezName "org.bluez.Mock" + writeIORef bluezPath "/org/bluez/hci0" + hSetBuffering stdout LineBuffering + hSetBuffering stdin LineBuffering + file <- getDataFileName "test/Mock/start_mock.sh" + (_inHandle, Just outHandle, _errHandle, proc) + <- P.createProcess (P.shell $ "bash " ++ file) { P.std_out = P.CreatePipe } + _ <- hGetLine outHandle + val <- action + P.terminateProcess proc + return val + +mockServiceUUID :: UUID +mockServiceUUID = "4ea7235c-8d49-4a6f-abe6-1883218a93a7" + +mockCharUUID :: UUID +mockCharUUID = "6fe4afc7-ebf8-4369-90aa-0fe45064e3f9" + +mockCharValue :: Int +mockCharValue = 1797 diff --git a/test/Mock/requirements.txt b/test/Mock/requirements.txt new file mode 100644 --- /dev/null +++ b/test/Mock/requirements.txt @@ -0,0 +1,2 @@ +dbus-python==1.2.4 +-e git+https://github.com/ukBaz/python-dbusmock@931e057e39d39e31b59f67caacf037d571f03420#egg=dbusmock diff --git a/test/Mock/start_mock.sh b/test/Mock/start_mock.sh new file mode 100644 --- /dev/null +++ b/test/Mock/start_mock.sh @@ -0,0 +1,63 @@ +#!/bin/bash + +set -o errexit + +# This script registers a mock service with DBus. The service contains one +# characteristic. + + +SERVICE_UUID=4ea7235c-8d49-4a6f-abe6-1883218a93a7 +CHARACTERISTIC_UUID=6fe4afc7-ebf8-4369-90aa-0fe45064e3f9 +CHARACTERISTIC_VALUE=3 +LOG_TO=${BLE_TEST_LOG_FILE:-/dev/null} + + +while getopts l: opt; do + case $opt in + l) LOG_TO=$OPTARG ;; + \?) printf "Invalid option: %s" "$OPTARG" ;; + esac +done + +# echo "Logging to $LOG_TO" + +python3 -m dbusmock --system org.bluez.Mock / org.bluez \ + >> "$LOG_TO" 2>&1 & + +sleep 5 +trap 'kill $(jobs -p)' EXIT + +gdbus call --system -d org.bluez.Mock -o / \ + -m org.freedesktop.DBus.Mock.AddTemplate 'bluez5' '{}' \ + >> "$LOG_TO" 2>&1 + +gdbus call --system -d org.bluez.Mock -o / \ + -m org.bluez.Mock.AddAdapter \ + 'hci0' \ + 'computer' >> "$LOG_TO" 2>&1 + +gdbus call --system -d org.bluez.Mock -o / \ + -m org.bluez.Mock.AddDevice \ + 'hci0' \ + '11:22:33:44:55:66' \ + 'Test Device' >> "$LOG_TO" 2>&1 + +gdbus call --system -d org.bluez.Mock -o / \ + -m org.bluez.Mock.AddGATTService \ + '/org/bluez/hci0' \ + '1' \ + "$SERVICE_UUID" \ + 'true' >> "$LOG_TO" 2>&1 + +gdbus call --system -d org.bluez.Mock -o / \ + -m org.bluez.Mock.AddGATTCharacteristic \ + "/org/bluez/hci0/service0001" \ + '1' \ + "$CHARACTERISTIC_UUID" \ + '["read", "write"]' \ + "$CHARACTERISTIC_VALUE" \ + 'false' >> "$LOG_TO" 2>&1 + +printf "ready\n" + +sleep 100000