ble 0.3.4.0 → 0.4.0.0
raw patch · 19 files changed
+926/−150 lines, 19 filesdep +processdep −microlens-thnew-component:exe:hrs-client
Dependencies added: process
Dependencies removed: microlens-th
Files
- README.md +34/−4
- ble.cabal +55/−16
- examples/Auth.hs +2/−2
- examples/HeartRate.hs +3/−3
- examples/HeartRateClient.hs +52/−0
- examples/README.lhs +34/−4
- package.yaml +19/−2
- src/Bluetooth.hs +35/−8
- src/Bluetooth/Internal/DBus.hs +130/−24
- src/Bluetooth/Internal/Device.hs +107/−0
- src/Bluetooth/Internal/Errors.hs +2/−2
- src/Bluetooth/Internal/HasInterface.hs +7/−5
- src/Bluetooth/Internal/Interfaces.hs +24/−1
- src/Bluetooth/Internal/Types.hs +179/−52
- test/Bluetooth/TypesSpec.hs +35/−4
- test/BluetoothSpec.hs +112/−23
- test/Mock.hs +31/−0
- test/Mock/requirements.txt +2/−0
- test/Mock/start_mock.sh +63/−0
README.md view
@@ -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.
ble.cabal view
@@ -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
examples/Auth.hs view
@@ -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))
examples/HeartRate.hs view
@@ -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))
+ examples/HeartRateClient.hs view
@@ -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"
examples/README.lhs view
@@ -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.
package.yaml view
@@ -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
src/Bluetooth.hs view
@@ -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 -- <https://github.com/plow-technologies/ble/blob/master/examples/README.lhs here>.@@ -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
src/Bluetooth/Internal/DBus.hs view
@@ -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)
+ src/Bluetooth/Internal/Device.hs view
@@ -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+ }
src/Bluetooth/Internal/Errors.hs view
@@ -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
src/Bluetooth/Internal/HasInterface.hs view
@@ -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
src/Bluetooth/Internal/Interfaces.hs view
@@ -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 #-}
src/Bluetooth/Internal/Types.hs view
@@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~
test/Bluetooth/TypesSpec.hs view
@@ -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
test/BluetoothSpec.hs view
@@ -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
+ test/Mock.hs view
@@ -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
+ test/Mock/requirements.txt view
@@ -0,0 +1,2 @@+dbus-python==1.2.4+-e git+https://github.com/ukBaz/python-dbusmock@931e057e39d39e31b59f67caacf037d571f03420#egg=dbusmock
+ test/Mock/start_mock.sh view
@@ -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