diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) Julian K. Arni 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,11 @@ +# ble - Bluetooth Low Energy for Haskell + +*ble* is a Haskell library for writing Bluetooth Low Energy peripherals. It +currently only supports Linux, and requires Bluez versions 5.41 and up. To see +what version you are running, type: + +``` bash +bluetoothd --version +``` + +For usage, see the haddocks. There are also examples in 'examples' directory. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ble.cabal b/ble.cabal new file mode 100644 --- /dev/null +++ b/ble.cabal @@ -0,0 +1,196 @@ +-- This file has been generated from package.yaml by hpack version 0.15.0. +-- +-- see: https://github.com/sol/hpack + +name: ble +version: 0.1.0.0 +synopsis: Bluetooth Low Energy (BLE) peripherals +description: This package provides a Haskell API for writing Bluetooth Low Energy peripherals. +stability: alpha +homepage: http://github.com/plow-technologies/ble#readme +bug-reports: https://github.com/plow-techonolgies/ble/issues +author: Julian K. Arni +maintainer: jkarni@turingjump.com +copyright: 2016 Julian K. Arni +license: BSD3 +license-file: LICENSE +tested-with: GHC == 7.10.3, GHC == 8.0.1 +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + LICENSE + package.yaml + README.md + +source-repository head + type: git + location: https://github.com/plow-techonolgies/ble + +flag bluez543 + description: Bluez version 5.43 or greater + manual: True + default: False + +flag hasBluez + description: Whether to run tests that require Bluez + manual: True + default: True + +library + hs-source-dirs: + src + 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.7 && < 4.10 + , bytestring >= 0.10 && < 0.11 + , text >= 1 && < 2 + , d-bus >= 0.1 && < 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-th >= 0.4 && < 0.5 + , microlens-ghc >= 0.4 && < 0.5 + , cereal >= 0.5 && < 0.6 + , data-default-class >= 0.0 && < 0.2 + if flag(hasBluez) + cpp-options: -DBluez + exposed-modules: + Bluetooth + Bluetooth.Internal.DBus + Bluetooth.Internal.Descriptors + Bluetooth.Internal.Errors + Bluetooth.Internal.HasInterface + Bluetooth.Internal.Interfaces + Bluetooth.Internal.Serialize + Bluetooth.Internal.Types + Bluetooth.Internal.Utils + default-language: Haskell2010 + +executable auth + main-is: Auth.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.7 && < 4.10 + , bytestring >= 0.10 && < 0.11 + , text >= 1 && < 2 + , d-bus >= 0.1 && < 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-th >= 0.4 && < 0.5 + , microlens-ghc >= 0.4 && < 0.5 + , cereal >= 0.5 && < 0.6 + , data-default-class >= 0.0 && < 0.2 + , ble + if flag(hasBluez) + cpp-options: -DBluez + other-modules: + Counter + HeartRate + default-language: Haskell2010 + +executable counter + main-is: Counter.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.7 && < 4.10 + , bytestring >= 0.10 && < 0.11 + , text >= 1 && < 2 + , d-bus >= 0.1 && < 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-th >= 0.4 && < 0.5 + , microlens-ghc >= 0.4 && < 0.5 + , cereal >= 0.5 && < 0.6 + , data-default-class >= 0.0 && < 0.2 + , ble + , stm + if flag(hasBluez) + cpp-options: -DBluez + other-modules: + Auth + HeartRate + default-language: Haskell2010 + +executable hrs + main-is: HeartRate.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.7 && < 4.10 + , bytestring >= 0.10 && < 0.11 + , text >= 1 && < 2 + , d-bus >= 0.1 && < 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-th >= 0.4 && < 0.5 + , microlens-ghc >= 0.4 && < 0.5 + , cereal >= 0.5 && < 0.6 + , data-default-class >= 0.0 && < 0.2 + , ble + if flag(hasBluez) + cpp-options: -DBluez + other-modules: + Auth + Counter + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + test + 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.7 && < 4.10 + , bytestring >= 0.10 && < 0.11 + , text >= 1 && < 2 + , d-bus >= 0.1 && < 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-th >= 0.4 && < 0.5 + , microlens-ghc >= 0.4 && < 0.5 + , cereal >= 0.5 && < 0.6 + , data-default-class >= 0.0 && < 0.2 + , ble + , hspec > 2 && < 3 + , QuickCheck >= 2.8 && < 2.9 + , quickcheck-instances >= 0.3 && < 0.4 + , hslogger + if flag(hasBluez) + cpp-options: -DBluez + other-modules: + Bluetooth.TypesSpec + BluetoothSpec + Doctest + Spec + default-language: Haskell2010 diff --git a/examples/Auth.hs b/examples/Auth.hs new file mode 100644 --- /dev/null +++ b/examples/Auth.hs @@ -0,0 +1,42 @@ +module Main (main) where + +-- This examples contains a simple Characteristic which only allows encrypted +-- authenticated reads. If the device pairing was not authenticated and +-- encrypted, the characteristic cannot be read. The default bluetooth agent +-- can handle PIN authentication. Check that the relevant device is setup to +-- use encryption and authentication: +-- +-- hciconfig -- e.g hciconfig hci0 +-- +-- Or change it with e.g.: +-- +-- hciconfig auth +-- +import Bluetooth +import Control.Concurrent (threadDelay) + +main :: IO () +main = do + conn <- connect + x <- runBluetoothM (registerAndAdvertiseApplication app) conn + case x of + Right () -> putStrLn "Started BLE auth application!" + Left e -> error $ "Error starting application " ++ show e + threadDelay maxBound + + +app :: Application +app + = "/com/turingjump/example/auth" + & services .~ [auth] + +auth :: Service +auth + = "18b2e7ec-2706-429e-a021-ab5e8158477b" + & characteristics .~ [secret] + +secret :: CharacteristicBS +secret + = "5bf24762-d9d1-445f-b81d-87069cc35e36" + & readValue ?~ encodeRead (return ("Juke/19" :: String)) + & properties .~ [CPEncryptAuthenticatedRead] diff --git a/examples/Counter.hs b/examples/Counter.hs new file mode 100644 --- /dev/null +++ b/examples/Counter.hs @@ -0,0 +1,50 @@ +module Main (main) where + +-- A simple example of a complete Bluetooth Low Energy application. The +-- application allows a counter to be read, and adds one to the value of the +-- counter, as well as allowing the counter to be set to any value. + +import Bluetooth +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM +import Control.Monad.IO.Class + +main :: IO () +main = do + ref <- newTVarIO 0 + conn <- connect + x <- runBluetoothM (registerAndAdvertiseApplication $ app ref) conn + case x of + Right () -> putStrLn "Started BLE counter application!" + Left e -> error $ "Error starting application " ++ show e + threadDelay maxBound + +app :: TVar Int -> Application +app ref + = "/com/turingjump/example/counter" + & services .~ [counter ref] + +counter :: TVar Int -> Service +counter ref + = "4f1f704f-0a0b-49e4-bd27-6368f27697a7" + & characteristics .~ [getCounter ref] + +getCounter :: TVar Int -> CharacteristicBS +getCounter ref + = "90874979-563e-4224-9da6-3b1a6c03e97d" + & readValue ?~ encodeRead readV + & writeValue ?~ encodeWrite writeV + & properties .~ [CPRead, CPWrite] + where + readV :: ReadValueM Int + readV = liftIO $ do + v <- atomically $ modifyTVar' ref succ >> readTVar ref + putStrLn $ "Value requested. New value: " ++ show v + return v + + writeV :: Int -> WriteValueM Bool + writeV i = liftIO $ do + v <- atomically $ swapTVar ref i + putStrLn $ "Value changed to: " ++ show i + putStrLn $ "Old value: " ++ show v + return True diff --git a/examples/HeartRate.hs b/examples/HeartRate.hs new file mode 100644 --- /dev/null +++ b/examples/HeartRate.hs @@ -0,0 +1,69 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +module Main (main) where + +-- This example contains a demonstration of the standard Heart Rate Service +-- (HRS). It serves as an examples of using notifications. (NOT YET FUNCTIONAL) +import Bluetooth +import Control.Concurrent +import Control.Monad +import Control.Monad.IO.Class +import Data.IORef +import System.Random (randomRIO) + + +main :: IO () +main = do + heartRateRef <- newIORef 0 + isNotifyingRef <- newIORef False + let s = AppState heartRateRef isNotifyingRef + conn <- connect + x <- runBluetoothM (registerAndAdvertiseApplication $ app s) conn + case x of + Right () -> putStrLn "Started BLE Heart Rate Service application!" + Left e -> error $ "Error starting application" ++ show e + forever $ do + newValue <- randomRIO (50, 150) + {-writeChrc (heartRateMeasurement s) newValue-} + writeIORef heartRateRef newValue + putStrLn "Value updated!" + nots <- readIORef isNotifyingRef + putStrLn $ if nots then "Notifying" else "Not notifying" + -- We update the value every ten seconds + threadDelay (10 ^ 7) + +data AppState = AppState + { currentHeartRate :: IORef Int + , isNotifying :: IORef Bool + } + +app :: AppState -> Application +app appState + = "/com/turingjump/example/hrs" + & services .~ [heartRateService appState] + +heartRateService :: AppState -> Service +heartRateService appState + = "0000180d-0000-1000-8000-00805f9b34fb" + & characteristics .~ [heartRateMeasurement appState, bodySensorLocation] + +heartRateMeasurement :: AppState -> CharacteristicBS +heartRateMeasurement appState + = "00002a37-0000-1000-8000-00805f9b34fb" + & readValue ?~ encodeRead (liftIO . readIORef $ currentHeartRate appState) + -- Even though we add a @writeValue@, this does not mean that the + -- characteristic is writable (for that, we would need to add the CPWrite + -- property to it). Instead, we can use the writeValue internally to + -- update the value and send notifications each time the value is changed. + & writeValue ?~ encodeWrite (liftIO <$> write) + & properties .~ [CPNotify, CPRead] + & notifying ?~ isNotifying appState + where + write v = do + writeIORef (currentHeartRate appState) v + return True + +bodySensorLocation :: CharacteristicBS +bodySensorLocation + = "00002a38-0000-1000-8000-00805f9b34fb" + & readValue ?~ encodeRead (return (0x01 :: Word)) + & properties .~ [CPRead] diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,118 @@ +name: ble +version: 0.1.0.0 +synopsis: Bluetooth Low Energy (BLE) peripherals +description: > + This package provides a Haskell API for writing Bluetooth Low Energy + peripherals. + +homepage: http://github.com/plow-technologies/ble#readme +license: BSD3 +license-file: LICENSE +author: Julian K. Arni +maintainer: jkarni@turingjump.com +copyright: 2016 Julian K. Arni +github: plow-techonolgies/ble +stability: alpha +tested-with: GHC == 7.10.3, GHC == 8.0.1 + +ghc-options: -Wall + +flags: + bluez543: + description: Bluez version 5.43 or greater + manual: True + default: False + hasBluez: + description: Whether to run tests that require Bluez + manual: True + default: True + +extra-source-files: + - README.md + - package.yaml + - LICENSE + +when: + - condition: flag(bluez543) + cpp-options: -DBluezGEQ543 + +when: + - condition: flag(hasBluez) + cpp-options: -DBluez + +dependencies: + - base >= 4.7 && < 4.10 + - bytestring >= 0.10 && < 0.11 + - text >= 1 && < 2 + - d-bus >= 0.1 && < 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-th >= 0.4 && < 0.5 + - microlens-ghc >= 0.4 && < 0.5 + - cereal >= 0.5 && < 0.6 + - data-default-class >= 0.0 && < 0.2 + +default-extensions: + - AutoDeriveTypeable + - ConstraintKinds + - DataKinds + - DefaultSignatures + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable + - FlexibleContexts + - FlexibleInstances + - FunctionalDependencies + - GADTs + - KindSignatures + - MultiParamTypeClasses + - OverloadedStrings + - RankNTypes + - ScopedTypeVariables + - TypeFamilies + - TypeOperators + +library: + source-dirs: src + other-modules: [] + +tests: + spec: + main: Main.hs + source-dirs: test + dependencies: + - ble + - hspec > 2 && < 3 + - QuickCheck >= 2.8 && < 2.9 + - quickcheck-instances >= 0.3 && < 0.4 + - hslogger +# doctest: +# main: Doctest.hs +# source-dirs: test +# dependencies: +# - doctest >= 0.9 && < 0.12 +# - Glob >= 0.7 && < 0.8 +# - yaml == 0.8.* + +executables: + counter: + main: Counter.hs + source-dirs: examples + dependencies: + - ble + - stm + hrs: + main: HeartRate.hs + source-dirs: examples + dependencies: + - ble + auth: + main: Auth.hs + source-dirs: examples + dependencies: + - ble diff --git a/src/Bluetooth.hs b/src/Bluetooth.hs new file mode 100644 --- /dev/null +++ b/src/Bluetooth.hs @@ -0,0 +1,121 @@ + +-- | This module exports all you should need to build a Bluetooth Low Energy +-- (BLE) peripheral. +-- +-- The core concepts involved are: +-- +-- ['Application'] This contains the entirety of your application, and is +-- composed of zero or more @Service@s. +-- +-- ['Service'] A set of zero or more conceptually related @Characteristic@s. +-- Identified by it's 'UUID'. +-- +-- ['Characteristic'] @Characteristic@s represent the actual data of your +-- application. They may allow reading, writing, and subscribing. Also +-- identified by it's 'UUID'. +-- +-- ['Advertisement'] This describes how an application will advertise itself +-- to other BLE devices. +-- +-- All three 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 +-- . +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > import Bluetooth +-- > import Control.Concurrent (threadDelay) +-- > +-- > app :: Application +-- > app = "/com/turingjump/example" & services .~ [aService] +-- > +-- > aService :: Service +-- > aService = "d0bc6707-e9a5-4c85-8d22-d73d33f0330c" +-- > & characteristics .~ [aCharacteristic] +-- > +-- > aCharacteristic :: CharacteristicBS +-- > aCharacteristic = "b3170df6-1770-4d60-86db-a487534cbcc3" +-- > & readValue ?~ encodeRead (return (32::Int)) +-- > & properties .~ [CPRead] +-- > +-- > main :: IO () +-- > main = do +-- > conn <- connect +-- > runBluetoothM (registerAndAdverstiseApplication app) conn +-- > threadDelay maxBound +module Bluetooth + ( + registerApplication + , registerAndAdvertiseApplication + , advertise + , advertisementFor + , connect + , runBluetoothM + + -- * Field lenses + , uuid + , properties + , readValue + , writeValue + , notifying + , characteristics + , services + , path + , type_ + , value + , solicitUUIDs + , serviceUUIDs + , manufacturerData + , serviceData + , includeTxPower + + -- * Updating values with notification + , writeChrc + + + + -- * BLE Types + -- | Types representing components of a BLE application. + , Connection + , Application + , Service + , UUID(UUID) + , CharacteristicProperty(..) + , Characteristic + , CharacteristicBS + , Advertisement + , WithObjectPath + + + -- * Encoding and decoding + -- | Helpers for 'readValue' and 'writeValue'. + , encodeRead + , encodeWrite + + -- * Handler + -- | @Handler err@ is a monad that allows the errors in the type-level list + -- @err@. + , Handler + , ReadValueM + , WriteValueM + + -- ** Handler error classes + , ThrowsFailed(..) + , ThrowsInProgress(..) + , ThrowsNotPermitted(..) + , ThrowsNotAuthorized(..) + , ThrowsNotSupported(..) + , ThrowsInvalidValueLength(..) + + -- * Re-exports + , module Lens.Micro + , module Lens.Micro.GHC + ) where + +import Bluetooth.Internal.DBus as X +import Bluetooth.Internal.Types as X +import Bluetooth.Internal.Serialize as X +import Bluetooth.Internal.Errors as X + +import Lens.Micro +import Lens.Micro.GHC diff --git a/src/Bluetooth/Internal/DBus.hs b/src/Bluetooth/Internal/DBus.hs new file mode 100644 --- /dev/null +++ b/src/Bluetooth/Internal/DBus.hs @@ -0,0 +1,106 @@ +module Bluetooth.Internal.DBus where + +import Control.Monad.Error.Class (throwError) +import Control.Monad.Reader +import Data.IORef (readIORef) +import Data.Monoid ((<>)) +import DBus +import DBus.Signal (execSignalT) +import Lens.Micro + +import qualified Data.Map as Map +import qualified Data.Serialize as S +import qualified Data.Text as T + +import Bluetooth.Internal.HasInterface +import Bluetooth.Internal.Interfaces +import Bluetooth.Internal.Types +import Bluetooth.Internal.Utils + +-- | Registers an application and advertises it. If you would like to have +-- finer-grained control of the advertisement, use @registerApplication@ and +-- @advertise@. +registerAndAdvertiseApplication :: Application -> BluetoothM () +registerAndAdvertiseApplication app = do + registerApplication app + advertise (advertisementFor app) + +-- | Registers an application (set of services) with Bluez. +registerApplication :: Application -> BluetoothM () +registerApplication app = do + conn <- ask + addAllObjs conn app + toBluetoothM . const + $ callMethod bluezName bluezPath (T.pack gattManagerIFace) "RegisterApplication" args [] + $ dbusConn conn + where + args :: (ObjectPath, Map.Map T.Text Any) + args = (app ^. path, Map.empty) + +-- | Adds handlers for all the objects managed by the Application (plus the +-- Application itself). +addAllObjs :: Connection -> Application -> BluetoothM () +addAllObjs conn app = do + liftIO $ addObject conn (app ^. path) (app `withInterface` objectManagerIFaceP) + liftIO $ forM_ (zip [0..] (app ^. services)) $ \(i,s) -> do + let p = serviceObjectPath (app ^. path) i + addObject conn p + $ (WOP p s `withInterface` gattServiceIFaceP) + <> (WOP p s `withInterface` propertiesIFaceP) + forM_ (zip [0..] (s ^. characteristics)) $ \(i', c) -> do + let p' = characteristicObjectPath p i' + addObject conn p' + $ (WOP p' c `withInterface` gattCharacteristicIFaceP) + <> (WOP p' c `withInterface` propertiesIFaceP) + +-- | Advertise a set of services. +advertise :: WithObjectPath Advertisement -> BluetoothM () +advertise adv = do + conn <- ask + liftIO $ do + addObject conn (adv ^. path) + $ (adv `withInterface` leAdvertisementIFaceP) + <> ((adv ^. value) `withInterface` propertiesIFaceP) + toBluetoothM . const $ do + callMethod bluezName bluezPath (T.pack leAdvertisingManagerIFace) "RegisterAdvertisement" args [] + $ dbusConn conn + where + args :: (ObjectPath, Map.Map T.Text Any) + args = (adv ^. path, Map.empty) + +-- | Create an advertisement for all of an application's services. +-- The advertisement will be for peripheral (not broadcast) by default. +advertisementFor :: Application -> WithObjectPath Advertisement +advertisementFor app = WOP p adv + where + adv = def & serviceUUIDs .~ (app ^.. services . traversed . uuid) + p = app ^. path & toText %~ ( "adv") + +-- | Write a characteristic (if possible). Returns True if characterstic was +-- successfully written. +writeChrc :: S.Serialize x => WithObjectPath CharacteristicBS -> x -> BluetoothM Bool +writeChrc c v = case (c ^. value . writeValue, c ^. value . notifying) of + (Nothing, _) -> return False + (Just f, Nothing) -> runEff . handlerToMethodHandler $ f (S.encode v) + (Just f, Just r) -> runEff $ do + changed <- handlerToMethodHandler (f $ S.encode v) + notify <- liftIO $ readIORef r + when (changed && notify) $ propertyChanged (valProp c) (S.encode v) + return changed + where + runEff :: MethodHandlerT IO x -> BluetoothM x + runEff act = do + conn <- asks dbusConn + res <- liftIO $ execSignalT act conn + case res of + Left e -> throwError $ MethodErrorMessage $ errorBody e + Right val -> return val + + +-- * Constants + +bluezName :: T.Text +bluezName = "org.bluez" + +bluezPath :: ObjectPath +bluezPath = "/org/bluez/hci0" diff --git a/src/Bluetooth/Internal/Descriptors.hs b/src/Bluetooth/Internal/Descriptors.hs new file mode 100644 --- /dev/null +++ b/src/Bluetooth/Internal/Descriptors.hs @@ -0,0 +1,6 @@ +module Bluetooth.Internal.Descriptors where + +-- This modules defines some commonly used GATT descriptors. + + + diff --git a/src/Bluetooth/Internal/Errors.hs b/src/Bluetooth/Internal/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Bluetooth/Internal/Errors.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE UndecidableInstances #-} +#if MIN_VERSION_base(4,9,0) +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +#endif +module Bluetooth.Internal.Errors where + +import Control.Monad.Except +import qualified Data.Text as T +import GHC.Exts (Constraint) + +-- All of this would be less verbose with overloaded labels, but then we +-- couldn't supported GHC < 8. + +type ReadValueM a = Handler '[ ThrowsFailed + , ThrowsInProgress + , ThrowsNotPermitted + , ThrowsNotAuthorized + , ThrowsNotSupported + ] a + +type WriteValueM a = Handler '[ ThrowsFailed + , ThrowsInProgress + , ThrowsNotPermitted + , ThrowsInvalidValueLength + , ThrowsNotAuthorized + , ThrowsNotSupported + ] a + +newtype Handler (errs :: [(* -> *) -> Constraint]) a + = Handler { getReadValue :: ExceptT T.Text IO a } + -- NOT MonadError! + deriving (Functor, Applicative, Monad, MonadIO) + +type family IsElem (x :: k) (list :: [k]) :: Constraint where + IsElem x (x ': xs) = () + IsElem x (y ': xs) = IsElem x xs + +class ThrowsFailed m where errFailed :: m a +instance (ThrowsFailed `IsElem` errs) => ThrowsFailed (Handler errs) where + errFailed = Handler $ throwError "org.bluez.Error.Failed" + +class ThrowsInProgress m where errInProgress :: m a +instance (ThrowsInProgress `IsElem` errs) => ThrowsInProgress (Handler errs) where + errInProgress = Handler $ throwError "org.bluez.Error.InProgress" + +class ThrowsNotPermitted m where errNotPermitted :: m a +instance (ThrowsNotPermitted `IsElem` errs) => ThrowsNotPermitted (Handler errs) where + errNotPermitted = Handler $ throwError "org.bluez.Error.NotPermitted" + +class ThrowsNotAuthorized m where errNotAuthorized :: m a +instance (ThrowsNotAuthorized `IsElem` errs) => ThrowsNotAuthorized (Handler errs) where + errNotAuthorized = Handler $ throwError "org.bluez.Error.NotAuthorized" + +class ThrowsNotSupported m where errNotSupported :: m a +instance (ThrowsNotSupported `IsElem` errs) => ThrowsNotSupported (Handler errs) where + errNotSupported = Handler $ throwError "org.bluez.Error.NotSupported" + +class ThrowsInvalidValueLength m where errInvalidValueLength :: m a +instance (ThrowsInvalidValueLength `IsElem` errs) => ThrowsInvalidValueLength (Handler errs) where + errInvalidValueLength = Handler $ throwError "org.bluez.Error.InvalidValueLength" diff --git a/src/Bluetooth/Internal/HasInterface.hs b/src/Bluetooth/Internal/HasInterface.hs new file mode 100644 --- /dev/null +++ b/src/Bluetooth/Internal/HasInterface.hs @@ -0,0 +1,347 @@ +module Bluetooth.Internal.HasInterface where + + +import Control.Monad.Except (liftIO, mapExceptT) +import Control.Monad.Writer.Strict (WriterT) +import Data.IORef +import Data.Proxy +import Data.Word (Word16) +import DBus +import DBus.Types (SomeSignal, methodError, object) +import GHC.TypeLits +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.Interfaces +import Bluetooth.Internal.Types +import Bluetooth.Internal.Utils + +-- The Bluez DBus API makes certain requirements about the interfaces +-- that objects must meet. These requirements are outlined in: +-- +-- https://kernel.googlesource.com/pub/scm/bluetooth/bluez/+/5.43/doc/gatt-api.txt +-- +-- In this file, we declare how our objects meet these interfaces. + + +-- A class that declares that @obj@ meets the interface @iface@. +class KnownSymbol iface => HasInterface obj (iface :: Symbol) where + getInterface :: obj -> Proxy iface -> Interface + +withInterface :: HasInterface obj iface => obj -> Proxy iface -> Object +withInterface o p = object (T.pack i) $ getInterface o p + where + i = symbolVal p + +-- * ObjectManager + + +instance HasInterface Application ObjectManager where + getInterface app _ = + Interface + { interfaceMethods = [getManagedObjects] + , interfaceSignals = [] + , interfaceAnnotations = [] + , interfaceProperties = [] + } + where + + getManagedObjects :: Method + getManagedObjects + = Method (repMethod (return app :: IO Application)) + "GetManagedObjects" + Done + ("rep" :> Done) + +-- * Properties +-- | The @org.freedesktop.DBus.Properties@ interface. +-- +-- See the for more information. + +type ChangedProperties = 'TypeStruct + [ 'DBusSimpleType 'TypeString -- interface_name + , AnyDBusDict -- changed_properties + , 'TypeArray ('DBusSimpleType 'TypeString) -- invalidated_properties + ] + +-- A helper function for constructing D-Bus Property interfaces. Pass a +-- non-Nothing if the object supports the PropertiesChanged signal. +-- +-- The 'Get' and 'Set' methods don't seem to be used by the Bluez DBus API, but +-- are supplied for compliance with the D-Bus Property Interface. +defPropIFace :: forall a. + ( Representable a + , RepType a ~ AnyDBusDict + ) + => Maybe ObjectPath -> T.Text -> a -> Interface +defPropIFace opath supportedIFaceName val = + Interface + { interfaceMethods = [getAll] + -- The 'd-bus' library's implementation of @DBus.Property.property@ does + -- not create an independent signal for PropertyChanged, which makes me + -- wonder whether this is the right thing to do. + , interfaceSignals = signals + , interfaceAnnotations = [] + , interfaceProperties = [] + } + where + getAll + = Method (repMethod go) + "GetAll" + ("interface" :> Done) + ("rep" :> Done) + where + go :: T.Text -> MethodHandlerT IO a + go iface + | iface == supportedIFaceName = return val + | otherwise = methodError invalidArgs + + signals = case opath of + Nothing -> [] + Just p -> [SSD propertiesChanged] + where + propertiesChanged :: SignalDescription '[ChangedProperties] + propertiesChanged = SignalDescription + { signalDPath = p + , signalDInterface = T.pack propertiesIFace + , signalDMember = "PropertiesChanged" + , signalDArguments = "changes" :> Done + } + +instance HasInterface (WithObjectPath Service) Properties where + getInterface service _ + = defPropIFace (Just $ service ^. path) (T.pack gattServiceIFace) service + +instance HasInterface (WithObjectPath CharacteristicBS) Properties where + getInterface char _ = case char ^. value . notifying of + Nothing -> baseIface + Just _ -> baseIface { interfaceProperties = SomeProperty prop : interfaceProperties baseIface } + where + baseIface = defPropIFace (Just $ char ^. path) (T.pack gattCharacteristicIFace) char + prop = mkProperty (char ^. path) + (T.pack gattCharacteristicIFace) + "Value" + (handlerToMethodHandler <$> char ^. value . readValue) + (fmap handlerToMethodHandler <$> char ^. value . writeValue) + PECSTrue + +instance HasInterface Advertisement Properties where + getInterface adv _ + = defPropIFace Nothing (T.pack leAdvertisementIFace) adv + +-- * GattService + + +instance HasInterface (WithObjectPath Service) GattService where + getInterface service _ = + Interface + { interfaceMethods = [] + , interfaceSignals = [] + , interfaceAnnotations = [] + , interfaceProperties = [SomeProperty uuid', SomeProperty primary] + } + where + uuid' :: Property (RepType UUID) + uuid' = Property + { propertyPath = objectPath $ (service ^. path . toText) "UUID" + , propertyInterface = T.pack gattServiceIFace + , propertyName = "UUID" + , propertyGet = Just . return $ toRep (service ^. value . uuid) + , propertySet = Nothing + , propertyEmitsChangedSignal = PECSFalse + } + + primary :: Property (RepType Bool) + primary = Property + { propertyPath = objectPath $ (service ^. path . toText) "Primary" + , propertyInterface = T.pack gattServiceIFace + , propertyName = "Primary" + , propertyGet = Just . return $ toRep True + , propertySet = Nothing + , propertyEmitsChangedSignal = PECSFalse + } + +-- * GattCharacteristic + +acceptingOptions :: MethodHandlerT IO BS.ByteString + -> CharacteristicOptions + -> MethodHandlerT IO BS.ByteString +acceptingOptions handler opts = case opts ^. offset of + Nothing -> handler + Just v -> BS.drop (fromInteger $ toInteger v) <$> handler + +handlerToMethodHandler :: Handler errs a -> MethodHandlerT IO a +handlerToMethodHandler (Handler h) = MHT $ mapExceptT go h + where + go :: IO (Either T.Text a) -> WriterT [SomeSignal] IO (Either MsgError a) + go x = liftIO $ x >>= \x' -> case x' of + Left e -> return . Left $ MsgError e Nothing [] + Right v -> return $ Right v + +instance HasInterface (WithObjectPath CharacteristicBS) GattCharacteristic where + getInterface char _ = + Interface + { interfaceMethods = [readVal, writeVal, startNotify, stopNotify] + , interfaceSignals = [] + , interfaceAnnotations = [] + , interfaceProperties = [ SomeProperty uuid' + , SomeProperty service + , SomeProperty flags + , SomeProperty $ valProp char + ] + } + where + notSup :: MethodHandlerT IO () + notSup = methodError notSupported + + readVal = case char ^. value . readValue of + Just v -> Method (repMethod $ acceptingOptions $ handlerToMethodHandler v) + "ReadValue" ("options" :> Done) ("rep" :> Done) + Nothing -> Method (repMethod notSup) "ReadValue" Done Done + + writeVal = case char ^. value . writeValue of + Just w -> Method (repMethod $ go w) + "WriteValue" ("arg" :> Done) ("rep" :> Done) + Nothing -> Method (repMethod notSup) "WriteValue" Done Done + where + go writeTheVal newVal = do + res <- handlerToMethodHandler $ writeTheVal newVal + nots <- liftIO $ sequence $ readIORef <$> char ^. value . notifying + liftIO $ print (nots, res) + {-when (nots == Just True && res) $ propertyChanged val newVal-} + return res + + stopNotify = Method (repMethod go) "StopNotify" Done Done + where + go :: MethodHandlerT IO () + go = case char ^. value . notifying of + Nothing -> return () + Just r -> liftIO $ writeIORef r False + + startNotify = Method (repMethod go) "StartNotify" Done Done + where + go :: MethodHandlerT IO () + go = case char ^. value . notifying of + Nothing -> return () + Just r -> liftIO $ writeIORef r True + + uuid' :: Property (RepType UUID) + uuid' = Property + { propertyPath = objectPath $ (char ^. path . toText) "UUID" + , propertyInterface = T.pack gattCharacteristicIFace + , propertyName = "UUID" + , propertyGet = Just . return . toRep $ char ^. value . uuid + , propertySet = Nothing + , propertyEmitsChangedSignal = PECSFalse + } + + service :: Property (RepType ObjectPath) + service = Property + { propertyPath = objectPath $ (char ^. path . toText) "Service" + , propertyInterface = T.pack gattCharacteristicIFace + , propertyName = "Service" + , propertyGet = Just . return . toRep . objectPath . parentPath + $ char ^. path . toText + , propertySet = Nothing + , propertyEmitsChangedSignal = PECSFalse + } + + flags :: Property (RepType [CharacteristicProperty]) + flags = Property + { propertyPath = objectPath $ (char ^. path . toText) "Flags" + , propertyInterface = T.pack gattCharacteristicIFace + , propertyName = "Flags" + , propertyGet = Just . return . toRep $ char ^. value . properties + , propertySet = Nothing + , propertyEmitsChangedSignal = PECSFalse + } + +valProp :: WithObjectPath (CharacteristicBS) -> 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 + getInterface adv _ = + Interface + { interfaceMethods = [release] + , interfaceSignals = [] + , interfaceAnnotations = [] + , interfaceProperties = [ SomeProperty type' + , SomeProperty serviceUUIDs' + , SomeProperty manufacturerData' + , SomeProperty solicitUUIDs' + , SomeProperty serviceData' + , SomeProperty includeTxPower'] + } + where + release = Method (repMethod (return () :: IO ())) "Release" Done Done + + type' :: Property (RepType AdvertisementType) + type' = Property + { propertyPath = objectPath $ (adv ^. path . toText) "Type" + , propertyInterface = T.pack leAdvertisementIFace + , propertyName = "Type" + , propertyGet = Just . return . toRep $ adv ^. value . type_ + , propertySet = Nothing + , propertyEmitsChangedSignal = PECSFalse + } + + serviceUUIDs' :: Property (RepType [UUID]) + serviceUUIDs' = Property + { propertyPath = objectPath $ (adv ^. path . toText) "ServiceUUIDs" + , propertyInterface = T.pack leAdvertisementIFace + , propertyName = "ServiceUUIDs" + , propertyGet = Just . return . toRep $ adv ^. value . serviceUUIDs + , propertySet = Nothing + , propertyEmitsChangedSignal = PECSFalse + } + + solicitUUIDs' :: Property (RepType [UUID]) + solicitUUIDs' = Property + { propertyPath = objectPath $ (adv ^. path . toText) "SolicitUUIDs" + , propertyInterface = T.pack leAdvertisementIFace + , propertyName = "SolicitUUIDs" + , propertyGet = Just . return . toRep $ adv ^. value . solicitUUIDs + , propertySet = Nothing + , propertyEmitsChangedSignal = PECSFalse + } + + manufacturerData' :: Property (RepType (Map.Map Word16 BS.ByteString)) + manufacturerData' = Property + { propertyPath = objectPath $ (adv ^. path . toText) "ManufacturerData" + , propertyInterface = T.pack leAdvertisementIFace + , propertyName = "ManufacturerData" + , propertyGet = Just . return . toRep $ adv ^. value . manufacturerData + , propertySet = Nothing + , propertyEmitsChangedSignal = PECSFalse + } + + serviceData' :: Property (RepType (Map.Map UUID BS.ByteString)) + serviceData' = Property + { propertyPath = objectPath $ (adv ^. path . toText) "ServiceData" + , propertyInterface = T.pack leAdvertisementIFace + , propertyName = "ServiceData" + , propertyGet = Just . return . toRep $ adv ^. value . serviceData + , propertySet = Nothing + , propertyEmitsChangedSignal = PECSFalse + } + + includeTxPower' :: Property (RepType Bool) + includeTxPower' = Property + { propertyPath = objectPath $ (adv ^. path . toText) "IncludeTxPower" + , propertyInterface = T.pack leAdvertisementIFace + , propertyName = "IncludeTxPower" + , propertyGet = Just . return . toRep $ adv ^. value . includeTxPower + , propertySet = Nothing + , propertyEmitsChangedSignal = PECSFalse + } diff --git a/src/Bluetooth/Internal/Interfaces.hs b/src/Bluetooth/Internal/Interfaces.hs new file mode 100644 --- /dev/null +++ b/src/Bluetooth/Internal/Interfaces.hs @@ -0,0 +1,83 @@ +module Bluetooth.Internal.Interfaces where + +import Data.Proxy +import DBus +import GHC.TypeLits + + +type ObjectManager = "org.freedesktop.DBus.ObjectManager" + +objectManagerIFaceP :: Proxy ObjectManager +objectManagerIFaceP = Proxy + +objectManagerIFace :: String +objectManagerIFace = symbolVal objectManagerIFaceP + + +type Properties = "org.freedesktop.DBus.Properties" + +propertiesIFaceP :: Proxy Properties +propertiesIFaceP = Proxy + +propertiesIFace :: String +propertiesIFace = symbolVal propertiesIFaceP + + +type GattService = "org.bluez.GattService1" + +gattServiceIFaceP :: Proxy GattService +gattServiceIFaceP = Proxy + +gattServiceIFace :: String +gattServiceIFace = symbolVal gattServiceIFaceP + +type GattCharacteristic = "org.bluez.GattCharacteristic1" + +gattCharacteristicIFaceP :: Proxy GattCharacteristic +gattCharacteristicIFaceP = Proxy + +gattCharacteristicIFace :: String +gattCharacteristicIFace = symbolVal gattCharacteristicIFaceP + + +type GattManager = "org.bluez.GattManager1" + +gattManagerIFaceP :: Proxy GattManager +gattManagerIFaceP = Proxy + +gattManagerIFace :: String +gattManagerIFace = symbolVal gattManagerIFaceP + + +type LEAdvertisement = "org.bluez.LEAdvertisement1" + +leAdvertisementIFaceP :: Proxy LEAdvertisement +leAdvertisementIFaceP = Proxy + +leAdvertisementIFace :: String +leAdvertisementIFace = symbolVal leAdvertisementIFaceP + + +type LEAdvertisingManager1 = "org.bluez.LEAdvertisingManager1" + +leAdvertisingManagerIFaceP :: Proxy LEAdvertisingManager1 +leAdvertisingManagerIFaceP = Proxy + +leAdvertisingManagerIFace :: String +leAdvertisingManagerIFace = symbolVal leAdvertisingManagerIFaceP + +-- * Errors + +invalidArgs :: MsgError +invalidArgs = MsgError + { errorName = "org.freedesktop.DBus.Error.InvalidArgs" + , errorText = Nothing + , errorBody = [] + } + +notSupported :: MsgError +notSupported = MsgError + { errorName = "org.bluez.Error.NotSupported" + , errorText = Nothing + , errorBody = [] + } diff --git a/src/Bluetooth/Internal/Serialize.hs b/src/Bluetooth/Internal/Serialize.hs new file mode 100644 --- /dev/null +++ b/src/Bluetooth/Internal/Serialize.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE UndecidableInstances #-} +module Bluetooth.Internal.Serialize where + +import qualified Data.ByteString as BS +import qualified Data.Serialize as S + +import Bluetooth.Internal.Errors + +encodeRead :: S.Serialize a => ReadValueM a -> ReadValueM BS.ByteString +encodeRead h = S.encode <$> h + +encodeWrite :: (S.Serialize a) + => (a -> WriteValueM Bool) -> (BS.ByteString -> WriteValueM Bool) +encodeWrite h v = case S.decode v of + Left _ -> errFailed + Right v' -> h v' diff --git a/src/Bluetooth/Internal/Types.hs b/src/Bluetooth/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Bluetooth/Internal/Types.hs @@ -0,0 +1,427 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +#if !MIN_VERSION_base(4,9,0) +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +#endif +module Bluetooth.Internal.Types where + + +import Control.Monad.Except (ExceptT (ExceptT), MonadError, runExceptT) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (MonadReader, ReaderT (ReaderT), runReaderT) +import Data.Default.Class (Default (def)) +import Data.IORef +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.String (IsString (fromString)) +import Data.Word (Word16) +import DBus (ConnectionType (System), DBusConnection, + DBusSimpleType (..), + DBusType (DBusSimpleType, TypeDict, TypeVariant), + DBusValue (..), MethodError, Object, ObjectPath, + Representable (..), connectBus, objectPath, + objectRoot) +import DBus.Types (root) +import GHC.Generics (Generic) +import Lens.Micro +import Lens.Micro.TH (makeFields) + +import qualified Data.ByteString as BS +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.UUID as UUID +import qualified System.Random as Rand + +import Bluetooth.Internal.Errors +import Bluetooth.Internal.Interfaces +import Bluetooth.Internal.Utils + +-- | Append two Texts, keeping exactly one slash between them. +() :: T.Text -> T.Text -> T.Text +a b + | "/" `T.isSuffixOf` a && "/" `T.isPrefixOf` b = a <> T.tail b + | "/" `T.isSuffixOf` a || "/" `T.isPrefixOf` b = a <> b + | otherwise = a <> "/" <> b + +parentPath :: T.Text -> T.Text +parentPath p = case reverse $ T.splitOn "/" p of + _:xs -> T.intercalate "/" $ reverse xs + [] -> "/" + + +-- * UUID + +-- | UUIDs, used for services and characteristics. +-- +-- Unofficial UUIDs will have 128-bits, and will look this: +-- +-- d45e83fb-c772-459e-91a8-43cbf1443af4 +-- +-- Official UUIDs will have either 32 or 16 bits. +-- +-- See for more +-- information on the format and generation of these UUIDs. You can use +-- the to generate +-- UUIDs. +data UUID + = UUID UUID.UUID + deriving (Eq, Show, Ord, Generic) + +baseUUID :: String +baseUUID = "-0000-1000-8000-00805F9B34FB" + +instance IsString UUID where + fromString x + | length x > 8 = UUID + $ fromMaybe (error "UUID.fromString: invalid UUID") $ UUID.fromString x + | length x == 8 = UUID + $ fromMaybe (error "UUID.fromString: invalid UUID") $ UUID.fromString + $ x <> baseUUID + | length x == 4 = UUID + $ fromMaybe (error "UUID.fromString: invalid UUID") $ UUID.fromString + $ "0000" <> x <> baseUUID + | otherwise = error "UUID.fromString: expecting 16, 32 or 128-bit UUID" + + +instance Representable UUID where + type RepType UUID = 'DBusSimpleType 'TypeString + toRep (UUID w) = toRep $ UUID.toText w + fromRep x = do + s <- fromRep x + case T.length s of + 36 -> UUID <$> UUID.fromText s + _ -> Nothing + +instance Rand.Random UUID where + randomR (UUID lo, UUID hi) g = + 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 + +-- | A Haskell existential type corresponding to DBus' @Variant@. +data Any where + MkAny :: forall a . (Representable a) => a -> Any + +instance Representable Any where + type RepType Any = 'TypeVariant + toRep (MkAny x) = DBVVariant (toRep x) + fromRep (DBVVariant x) = Just (MkAny x) + +-- Note [WithObjectPath] +data WithObjectPath a = WOP + { withObjectPathPath :: ObjectPath + , withObjectPathValue :: a + } deriving (Eq, Show, Generic, Functor) + +makeFields ''WithObjectPath + +type AnyDBusDict = 'TypeDict 'TypeString 'TypeVariant + +-- * Method + +{-data Method where-} + {-ReadValue :: ReadValueM BS.ByteString-} + {-WriteValue :: BS.ByteString -> WriteValueM BS.ByteString-} + {-Notify :: -} + +-- * Descriptor + +data Descriptor = Descriptor + { descriptorUuid :: UUID + } deriving (Eq, Show, Generic) + + +data AdvertisingPacketType + = ConnectableUndirected + | ConnectableDirected + | NonConnnectableUndirected + | ScannableUndirected + deriving (Eq, Show, Read, Generic, Ord) + +-- * Characteristic + +data CharacteristicProperty + = CPBroadcast + | CPRead + | CPEncryptRead + | CPEncryptAuthenticatedRead + | CPWriteWithoutResponse + | CPWrite + | CPEncryptWrite + | CPEncryptAuthenticatedWrite + | CPAuthenticatedSignedWrites + | CPNotify + | CPIndicate + | CPSignedWriteCommand + deriving (Eq, Show, Read, Enum, Bounded, Ord, Generic) + +instance Representable CharacteristicProperty where + type RepType CharacteristicProperty = 'DBusSimpleType 'TypeString + toRep x = maybe (error "impossible") toRep $ lookup x chrPropPairs + fromRep x = do + key <- fromRep x + let swapped = (\(a,b) -> (b,a)) <$> chrPropPairs + lookup key swapped + + +chrPropPairs :: [(CharacteristicProperty, T.Text)] +chrPropPairs = + [ (CPBroadcast, "broadcast") + , (CPRead, "read") + , (CPEncryptRead, "encrypt-read") + , (CPEncryptAuthenticatedRead, "encrypt-authenticated-read") + , (CPWriteWithoutResponse, "write-without-response") + , (CPWrite, "write") + , (CPEncryptWrite, "encrypt-write") + , (CPEncryptAuthenticatedWrite, "encrypt-authenticated-write") + , (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 Representable CharacteristicOptions where + type RepType CharacteristicOptions = AnyDBusDict + fromRep x = do + m <- fromRep x + return $ case Map.lookup ("offset" :: T.Text) m of + Just (DBVVariant (DBVUInt16 w)) -> CharacteristicOptions (Just w) + _ -> CharacteristicOptions Nothing + toRep x = case x ^. offset of + Nothing -> DBVDict [] + Just v -> DBVDict [(toRep ("offset" :: T.Text), toRep $ MkAny v)] + +type CharacteristicBS = Characteristic BS.ByteString + +data Characteristic typ = Characteristic + { characteristicUuid :: UUID + , characteristicProperties :: [CharacteristicProperty] + , characteristicReadValue :: Maybe (ReadValueM 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 -> WriteValueM Bool) + -- | If @Nothing@, this characteristic does not send notifications. + -- If @Just False@, the characteristic does not currently send notifications, but + -- can be made to (with a @StartNotify@ method request). + -- If @Just True@, the characteristic currently sends notifications (and can + -- be made to stop with a @StopNotify@ method request). + -- **NOTE**: Notifications do not currently work. + , characteristicNotifying :: Maybe (IORef Bool) + } deriving (Generic) + +makeFields ''Characteristic + + +instance IsString (Characteristic a) where + fromString x = Characteristic (fromString x) [] Nothing Nothing Nothing + +-- Note [WithObjectPath] +instance Representable (WithObjectPath (Characteristic a)) where + type RepType (WithObjectPath (Characteristic a)) = AnyDBusDict + toRep char = toRep tmap + where + tmap :: Map.Map T.Text Any + tmap = Map.fromList [ ("UUID", MkAny $ char ^. value . uuid) + , ("Service", MkAny $ (char ^. path) & toText %~ parentPath) + , ("Flags", MkAny $ char ^. value . properties) + ] + fromRep _ = error "not implemented" + +characteristicObjectPath :: ObjectPath -> Int -> ObjectPath +characteristicObjectPath appOPath idx = appOPath & toText %~ addSuffix + where + fourDigits = T.pack $ case show idx of + [a] -> ['0','0','0',a] + [a,b] -> ['0','0',a,b] + [a,b,c] -> ['0',a,b,c] + [a,b,c,d] -> [a,b,c,d] + _ -> error "maximum 9999 characteristics" + addSuffix r = r ("char" <> fourDigits) + +-- * Service + +data Service = Service + { serviceUuid :: UUID + , serviceCharacteristics :: [CharacteristicBS] + } deriving (Generic) + +makeFields ''Service + +instance IsString Service where + fromString x = Service (fromString x) [] + +-- Note [WithObjectPath] +instance Representable (WithObjectPath Service) where + type RepType (WithObjectPath Service) = AnyDBusDict + toRep serv = toRep tmap + where + tmap :: Map.Map T.Text Any + tmap = Map.fromList + [ ("UUID", MkAny $ serv ^. value . uuid ) + -- Only primary services for now + , ("Primary", MkAny $ True) + , ("Characteristics", MkAny (charPaths . length $ serv ^. value . characteristics)) + ] + + charPaths :: Int -> [ObjectPath] + charPaths i + = characteristicObjectPath (objectPath $ serv ^. path . toText) <$> [0..i-1] + + fromRep _ = error "not implemented" + + +-- * Application + +-- | An application. Can be created from it's @IsString@ instance. +-- The string (application path) is used only for the DBus API, and will not +-- have relevance within Bluetooth. +data Application = Application + { applicationPath :: ObjectPath + , applicationServices :: [Service] + } deriving (Generic) + +makeFields ''Application + +instance IsString Application where + fromString x = Application (fromString x) [] + +instance Representable Application where + type RepType Application + = 'TypeDict 'TypeObjectPath + ('TypeDict 'TypeString AnyDBusDict) + toRep app = toRep $ Map.fromList $ concat $ do + (idxS, serv) <- zip [0..] (app ^. services) + let servPath = serviceObjectPath (app ^. path) idxS + chars = do + (idxC, char) <- zip [0..] (serv ^. characteristics) + let charPath = characteristicObjectPath servPath idxC + return $ charAsEntry charPath char + return $ serviceAsEntry servPath serv : chars + where + serviceAsEntry path' serv + = (path', toRep $ Map.fromList [(T.pack gattServiceIFace, WOP path' serv)]) + charAsEntry path' char + = (path', toRep $ Map.fromList [(T.pack gattCharacteristicIFace, WOP path' char)]) + fromRep _ = error "not implemented" + + +serviceObjectPath :: ObjectPath -> Int -> ObjectPath +serviceObjectPath appOPath idx = appOPath & toText %~ addSuffix + where + twoDigits = T.pack $ case show idx of + [a] -> ['0', a] + [a,b] -> [a, b] + _ -> error "maximum 99 services" + addSuffix r = r ("service" <> twoDigits) + +-- * Advertisement + +data AdvertisementType = Broadcast | Peripheral + deriving (Eq, Show, Read, Generic, Bounded, Enum) + +instance Representable AdvertisementType where + type RepType AdvertisementType = 'DBusSimpleType 'TypeString + toRep x = case x of + Broadcast -> toRep ("broadcast" :: T.Text) + Peripheral -> toRep ("peripheral" :: T.Text) + fromRep _ = error "not implemented" + +data Advertisement = Advertisement + { advertisementType_ :: AdvertisementType + , advertisementServiceUUIDs :: [UUID] + , advertisementSolicitUUIDs :: [UUID] + , advertisementManufacturerData :: Map.Map Word16 BS.ByteString + , advertisementServiceData :: Map.Map UUID BS.ByteString + , advertisementIncludeTxPower :: Bool + } deriving (Generic) + +makeFields ''Advertisement + +instance Representable Advertisement where + type RepType Advertisement = 'TypeDict 'TypeString 'TypeVariant + toRep adv = toRep m + where + m :: Map.Map T.Text Any + m = Map.fromList + [ ("Type", MkAny $ adv ^. type_) + , ("ServiceUUIDs", MkAny $ adv ^. serviceUUIDs) + , ("SolicitUUIDs", MkAny $ adv ^. solicitUUIDs) +#ifdef BluezGEQ543 + , ("ManufacturerData", MkAny $ MkAny <$> adv ^. manufacturerData) + , ("ServiceData", MkAny $ MkAny <$> adv ^. serviceData) +#else + , ("ManufacturerData", MkAny $ adv ^. manufacturerData) + , ("ServiceData", MkAny $ adv ^. serviceData) +#endif + , ("IncludeTxPower", MkAny $ adv ^. includeTxPower) + ] + fromRep _ = error "not implemented" + +instance Default Advertisement where + def = Advertisement Peripheral [] [] mempty mempty False + + + +-- * Connection + +-- The constructor should not be exported. +data Connection = Connection + { dbusConn :: DBusConnection + -- Should it be possible to remove objects? + , addObject :: ObjectPath -> Object -> IO () + } + +-- | Creates a connection to DBus. This does *not* represent Bluetooth +-- connection. +connect :: IO Connection +connect = do + let noHandler _ _ _ = return () + ref <- newIORef mempty + let addObj objPath obj = modifyIORef' ref (root objPath obj `mappend`) + methodHandler conn hdr val = readIORef ref >>= \f -> objectRoot f conn hdr val + dbusC <- connectBus System methodHandler noHandler + return $ Connection dbusC addObj + +-- * BluetoothM + +newtype BluetoothM a + = BluetoothM ( ReaderT Connection (ExceptT MethodError IO) a ) + deriving (Functor, Applicative, Monad, MonadIO, MonadError MethodError, + MonadReader Connection) + +runBluetoothM :: BluetoothM a -> Connection -> IO (Either MethodError a) +runBluetoothM (BluetoothM e) conn = runExceptT $ runReaderT e conn + +toBluetoothM :: (Connection -> IO (Either MethodError a)) -> BluetoothM a +toBluetoothM = BluetoothM . ReaderT . fmap ExceptT + + + +{- Note [WithObjectPath] +~~~~~~~~~~~~~~~~~~~~~~~~~ + +In OOP, which is explicitly the programming model around which +DBus was designed, methods have access to the object they are +a method of. Here, we prefer to not unnecessarily tie services, +characteristics, and descriptors to the data that may have them +as fields. This makes it possible for different services to have +the "same" characteristic (e.g.). + +But the ObjectPath of each of these types messes up with this, +since it depends on the 'object' of which this characteristic +is a property or method. + +So we use WithObjectPath to attach ObjectPaths to these values, +and write instances for Representable for @WithObjectPath a@ +rather than @a@. +-} diff --git a/src/Bluetooth/Internal/Utils.hs b/src/Bluetooth/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Bluetooth/Internal/Utils.hs @@ -0,0 +1,18 @@ +module Bluetooth.Internal.Utils where + +import qualified Data.Text as T +import Lens.Micro +import DBus + +-- Doing Iso's would require the full 'lens' dependency +class ToText a where + toText :: Lens' a T.Text + +instance ToText ObjectPath where + toText = lens objectPathToText (const objectPath) + +class FromText a where + fromText :: Lens' T.Text a + +instance FromText ObjectPath where + fromText = lens objectPath (const objectPathToText) diff --git a/test/Bluetooth/TypesSpec.hs b/test/Bluetooth/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Bluetooth/TypesSpec.hs @@ -0,0 +1,94 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Bluetooth.TypesSpec (spec) where + +import Data.IORef +import Data.Proxy (Proxy (Proxy)) +import DBus +import System.IO.Unsafe (unsafePerformIO) +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Instances () + +import qualified Data.Text as T + +import Bluetooth.Internal.Types + +spec :: Spec +spec = do + uuidSpec + parentPathSpec + chrPropPairsSpec + +uuidSpec :: Spec +uuidSpec = describe "UUID" $ do + + context "fromString" $ do + + it "works for full UUIDs" $ do + show ("636e8de5-c57b-4069-8c59-bb72e1ad805e" :: UUID) + `shouldBe` "UUID 636e8de5-c57b-4069-8c59-bb72e1ad805e" + + it "works for 32-bit UUIDs" $ do + show ("636e8de5" :: UUID) + `shouldBe` "UUID 636e8de5-0000-1000-8000-00805f9b34fb" + + it "throws an error for invalid UUIDs" $ do + print ("boo" :: UUID) `shouldThrow` anyException + + context "Representable" $ do + fromRepToRepInverse (Proxy :: Proxy UUID) + +parentPathSpec :: Spec +parentPathSpec = describe "parentPath" $ do + + it "returns the path of the parent" $ do + parentPath "/com/turingjump/service01/char10" + `shouldBe` "/com/turingjump/service01" + +chrPropPairsSpec :: Spec +chrPropPairsSpec = describe "chrPropPairs" $ do + + it "contains all constructors of CharacteristicProperty" $ do + all (`elem` (fst <$> chrPropPairs)) [minBound..maxBound] `shouldBe` True + +-- * Utils + +fromRepToRepInverse + :: forall proxy a. (Eq a, Arbitrary a, Representable a, Show a) + => proxy a -> Spec +fromRepToRepInverse _ + = it "has fromRep as a left inverse of toRep" $ property $ \val -> do + fromRep (toRep (val :: a)) `shouldBe` Just val + +-- * Instances + +instance Arbitrary UUID where + arbitrary = choose ("00000000-0000-0000-0000-000000000000" + ,"FFFFFFFF-FFFF-FFFF-FFFF-FFFFFFFFFFFF" + ) + +instance Arbitrary Application where + arbitrary = Application <$> arbitrary <*> arbitrary + +instance Arbitrary ObjectPath where + arbitrary = objectPath . T.pack <$> arbitrary + +instance Arbitrary Service where + arbitrary = Service <$> arbitrary <*> arbitrary + +instance (CoArbitrary a, Arbitrary a) + => Arbitrary (Characteristic a) where + arbitrary = Characteristic + <$> arbitrary + <*> arbitrary + <*> (fmap return <$> arbitrary) + <*> (fmap (fmap return) <$> arbitrary) + <*> genIORef + where + genIORef = do + m <- arbitrary + if m then Just . unsafePerformIO . newIORef <$> arbitrary + else return Nothing + +instance Arbitrary CharacteristicProperty where + arbitrary = elements [minBound..maxBound] diff --git a/test/BluetoothSpec.hs b/test/BluetoothSpec.hs new file mode 100644 --- /dev/null +++ b/test/BluetoothSpec.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +#ifndef Bluez +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +#endif +module BluetoothSpec (spec) where + +import Bluetooth +import Control.Monad.IO.Class +import DBus +import Test.Hspec + +import qualified Data.ByteString as BS + + + +spec :: Spec +spec = do +#ifndef Bluez + return () +#else + registerApplicationSpec + advertiseSpec +#endif + +registerApplicationSpec :: Spec +registerApplicationSpec = describe "registerApplication" $ before connect $ do + + it "registers the service with bluez" $ \conn -> do + v <- runBluetoothM (registerApplication testApp) conn + v `shouldBe` Right () + -- 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 + show err `shouldContain` "Already Exists" + +advertiseSpec :: Spec +advertiseSpec = describe "advertise" $ before connect $ do + + let checkAdvert ad conn = do + v <- runBluetoothM (advertise ad) conn + v `shouldBe` Right () + -- We verify that the advertisement was registered by checking that + -- attempting to register it again throws an AlreadyExists error. + Left err <- runBluetoothM (advertise ad) conn + show err `shouldContain` "Already Exists" + + it "adverstises a set of services" $ \conn -> checkAdvert testAdv conn + + {-it "works with service data" $ \conn -> do-} + {-let adv = testAdv-} + {-& value . serviceData . at "351930f8"-} + {-?~ "hi"-} + {-checkAdvert adv conn-} + + it "works with manufacturer data" $ \conn -> do + let adv = testAdv & value . manufacturerData . at 1 ?~ "hi" + checkAdvert adv conn + + +-- * Test service + +testApp :: Application +testApp + = "/com/turingjump/test" + & services .~ [testService] + +testService :: Service +testService + = "351930f8-7d31-43c1-92f5-fd2f0eac272f" + & characteristics .~ [testCharacteristic] + +testCharacteristic :: CharacteristicBS +testCharacteristic + = "cdcb58aa-7e4c-4d22-b0bf-a90cd67ba60b" + & readValue ?~ encodeRead go + & properties .~ [CPRead] + where + go :: ReadValueM BS.ByteString + go = do + liftIO $ putStrLn "Reading characteristic!" + return "s" + +testAdv :: WithObjectPath Advertisement +testAdv + = advertisementFor testApp + +-- * Orphans + +instance Eq MethodError where + a == b = show a == show b diff --git a/test/Doctest.hs b/test/Doctest.hs new file mode 100644 --- /dev/null +++ b/test/Doctest.hs @@ -0,0 +1,26 @@ +module Main (main) where + +-- Runs doctest on all files in "src" dir. Assumes: +-- (a) You are using hpack +-- (b) The top-level "default-extensions" are the only extensions besides the +-- ones in the files. + +import System.FilePath.Glob (glob) +import Test.DocTest (doctest) +import Data.Yaml + +newtype Exts = Exts { getExts :: [String] } + deriving (Eq, Show, Read) + +instance FromJSON Exts where + parseJSON (Object v) = Exts <$> v .: "default-extensions" + parseJSON _ = fail "expecting object" + +main :: IO () +main = do + hpack' <- decodeFile "package.yaml" + hpack <- case hpack' of + Nothing -> return $ Exts [] + Just v -> return v + files <- glob "src/**/*.hs" + doctest $ files ++ fmap ("-X" ++) (getExts hpack) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,13 @@ +module Main (main) where + +import System.Log.Logger +import System.Log.Handler.Simple +import System.IO +import qualified Spec +import Test.Hspec + +main :: IO () +main = do + h <- streamHandler stderr DEBUG + updateGlobalLogger rootLoggerName (addHandler h) + hspec Spec.spec diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}