packages feed

ble (empty) → 0.1.0.0

raw patch · 22 files changed

+1931/−0 lines, 22 filesdep +QuickCheckdep +basedep +blesetup-changed

Dependencies added: QuickCheck, base, ble, bytestring, cereal, containers, d-bus, data-default-class, hslogger, hspec, microlens, microlens-ghc, microlens-th, mtl, quickcheck-instances, random, stm, text, transformers, uuid

Files

+ LICENSE view
@@ -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.+
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ble.cabal view
@@ -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
+ examples/Auth.hs view
@@ -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 <dev>      -- e.g hciconfig hci0+--+-- Or change it with e.g.:+--+--  hciconfig <dev> 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]
+ examples/Counter.hs view
@@ -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
+ examples/HeartRate.hs view
@@ -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]
+ package.yaml view
@@ -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
+ src/Bluetooth.hs view
@@ -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+-- <https://github.com/plow-technologies/ble/blob/master/examples/Counter.hs here>.+--+-- > {-# 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
+ src/Bluetooth/Internal/DBus.hs view
@@ -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"
+ src/Bluetooth/Internal/Descriptors.hs view
@@ -0,0 +1,6 @@+module Bluetooth.Internal.Descriptors where++-- This modules defines some commonly used GATT descriptors.+++
+ src/Bluetooth/Internal/Errors.hs view
@@ -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"
+ src/Bluetooth/Internal/HasInterface.hs view
@@ -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 <https://dbus.freedesktop.org/doc/dbus-specification.html#standard-interfaces-properties+-- relevant section of the DBus spec> 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+        }
+ src/Bluetooth/Internal/Interfaces.hs view
@@ -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 = []+  }
+ src/Bluetooth/Internal/Serialize.hs view
@@ -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'
+ src/Bluetooth/Internal/Types.hs view
@@ -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 <http://www.itu.int/rec/T-REC-X.667/en ITU-T Rec. X.677> for more+-- information on the format and generation of these UUIDs. You can use+-- the <https://www.uuidgenerator.net/ Online UUID Generator> 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@.+-}
+ src/Bluetooth/Internal/Utils.hs view
@@ -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)
+ test/Bluetooth/TypesSpec.hs view
@@ -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]
+ test/BluetoothSpec.hs view
@@ -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
+ test/Doctest.hs view
@@ -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)
+ test/Main.hs view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}