ble 0.2.0.0 → 0.3.0.0
raw patch · 12 files changed
+192/−93 lines, 12 filesdep ~d-bus
Dependency ranges changed: d-bus
Files
- ble.cabal +7/−6
- examples/Auth.hs +1/−1
- examples/Counter.hs +1/−1
- examples/HeartRate.hs +20/−12
- package.yaml +3/−2
- src/Bluetooth.hs +4/−3
- src/Bluetooth/Internal/DBus.hs +34/−24
- src/Bluetooth/Internal/Errors.hs +3/−0
- src/Bluetooth/Internal/HasInterface.hs +29/−19
- src/Bluetooth/Internal/Types.hs +69/−13
- test/Bluetooth/TypesSpec.hs +0/−8
- test/BluetoothSpec.hs +21/−4
ble.cabal view
@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: ble-version: 0.2.0.0+version: 0.3.0.0 synopsis: Bluetooth Low Energy (BLE) peripherals description: This package provides a Haskell API for writing Bluetooth Low Energy peripherals. stability: alpha@@ -46,7 +46,7 @@ base >= 4.7 && < 4.10 , bytestring >= 0.10 && < 0.11 , text >= 1 && < 2- , d-bus >= 0.1 && < 0.2+ , d-bus >= 0.1.5 && < 0.2 , uuid >= 1 && < 2 , mtl >= 2.2 && < 2.3 , transformers >= 0.4 && < 0.6@@ -81,7 +81,7 @@ base >= 4.7 && < 4.10 , bytestring >= 0.10 && < 0.11 , text >= 1 && < 2- , d-bus >= 0.1 && < 0.2+ , d-bus >= 0.1.5 && < 0.2 , uuid >= 1 && < 2 , mtl >= 2.2 && < 2.3 , transformers >= 0.4 && < 0.6@@ -110,7 +110,7 @@ base >= 4.7 && < 4.10 , bytestring >= 0.10 && < 0.11 , text >= 1 && < 2- , d-bus >= 0.1 && < 0.2+ , d-bus >= 0.1.5 && < 0.2 , uuid >= 1 && < 2 , mtl >= 2.2 && < 2.3 , transformers >= 0.4 && < 0.6@@ -140,7 +140,7 @@ base >= 4.7 && < 4.10 , bytestring >= 0.10 && < 0.11 , text >= 1 && < 2- , d-bus >= 0.1 && < 0.2+ , d-bus >= 0.1.5 && < 0.2 , uuid >= 1 && < 2 , mtl >= 2.2 && < 2.3 , transformers >= 0.4 && < 0.6@@ -152,6 +152,7 @@ , cereal >= 0.4 && < 0.6 , data-default-class >= 0.0 && < 0.2 , ble+ , hslogger if flag(hasBluez) cpp-options: -DBluez other-modules:@@ -170,7 +171,7 @@ base >= 4.7 && < 4.10 , bytestring >= 0.10 && < 0.11 , text >= 1 && < 2- , d-bus >= 0.1 && < 0.2+ , d-bus >= 0.1.5 && < 0.2 , uuid >= 1 && < 2 , mtl >= 2.2 && < 2.3 , transformers >= 0.4 && < 0.6
examples/Auth.hs view
@@ -20,7 +20,7 @@ conn <- connect x <- runBluetoothM (registerAndAdvertiseApplication app) conn case x of- Right () -> putStrLn "Started BLE auth application!"+ Right _ -> putStrLn "Started BLE auth application!" Left e -> error $ "Error starting application " ++ show e threadDelay maxBound
examples/Counter.hs view
@@ -15,7 +15,7 @@ conn <- connect x <- runBluetoothM (registerAndAdvertiseApplication $ app ref) conn case x of- Right () -> putStrLn "Started BLE counter application!"+ Right _ -> putStrLn "Started BLE counter application!" Left e -> error $ "Error starting application " ++ show e threadDelay maxBound
examples/HeartRate.hs view
@@ -2,38 +2,44 @@ 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)+-- (HRS). It serves as an examples of using notifications. import Bluetooth import Control.Concurrent import Control.Monad import Control.Monad.IO.Class import Data.IORef+import Data.Monoid import System.Random (randomRIO)+import System.Log.Logger +import qualified Data.Serialize as S+import qualified Data.ByteString as BS + main :: IO () main = do+ updateGlobalLogger rootLoggerName (setLevel DEBUG) heartRateRef <- newIORef 0- isNotifyingRef <- newIORef False- let s = AppState heartRateRef isNotifyingRef+ let s = AppState heartRateRef conn <- connect x <- runBluetoothM (registerAndAdvertiseApplication $ app s) conn- case x of- Right () -> putStrLn "Started BLE Heart Rate Service application!"+ registered <- case x of+ Right registered -> do+ putStrLn "Started BLE Heart Rate Service application!"+ return registered 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"+ res <- runBluetoothM (triggerNotification registered $ heartRateMeasurement s) conn+ case res of+ Right () -> putStrLn "Notification sent!"+ Left e -> error $ "Bluetooth error:\n" ++ show e -- We update the value every ten seconds threadDelay (10 ^ 7) data AppState = AppState { currentHeartRate :: IORef Int- , isNotifying :: IORef Bool } app :: AppState -> Application@@ -49,18 +55,20 @@ heartRateMeasurement :: AppState -> CharacteristicBS heartRateMeasurement appState = "00002a37-0000-1000-8000-00805f9b34fb"- & readValue ?~ encodeRead (liftIO . readIORef $ currentHeartRate appState)+ & readValue ?~ fmap heartRateToBS (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++heartRateToBS :: Int -> BS.ByteString+heartRateToBS i = "0x06" <> S.encode i bodySensorLocation :: CharacteristicBS bodySensorLocation
package.yaml view
@@ -1,5 +1,5 @@ name: ble-version: 0.2.0.0+version: 0.3.0.0 synopsis: Bluetooth Low Energy (BLE) peripherals description: > This package provides a Haskell API for writing Bluetooth Low Energy@@ -44,7 +44,7 @@ - base >= 4.7 && < 4.10 - bytestring >= 0.10 && < 0.11 - text >= 1 && < 2- - d-bus >= 0.1 && < 0.2+ - d-bus >= 0.1.5 && < 0.2 - uuid >= 1 && < 2 - mtl >= 2.2 && < 2.3 - transformers >= 0.4 && < 0.6@@ -111,6 +111,7 @@ source-dirs: examples dependencies: - ble+ - hslogger auth: main: Auth.hs source-dirs: examples
src/Bluetooth.hs view
@@ -51,13 +51,13 @@ , advertisementFor , connect , runBluetoothM+ , runHandler -- * Field lenses , uuid , properties , readValue , writeValue- , notifying , characteristics , services , path@@ -70,8 +70,9 @@ , includeTxPower , connectionName - -- * Updating values with notification- , writeChrc+ -- * Notifications+ , characteristicIsNotifying+ , triggerNotification
src/Bluetooth/Internal/DBus.hs view
@@ -1,38 +1,40 @@ module Bluetooth.Internal.DBus where -import Control.Monad.Error.Class (throwError)+import Control.Monad.Except import Control.Monad.Reader-import Data.IORef (readIORef)-import Data.Monoid ((<>))+import Data.IORef (readIORef, writeIORef)+import Data.Monoid ((<>)) import DBus-import DBus.Signal (execSignalT)+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 qualified Data.Map as Map+import qualified Data.Text as T import Bluetooth.Internal.HasInterface import Bluetooth.Internal.Interfaces import Bluetooth.Internal.Types import Bluetooth.Internal.Utils+import Bluetooth.Internal.Errors -- | 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 :: Application -> BluetoothM ApplicationRegistered registerAndAdvertiseApplication app = do- registerApplication app+ reg <- registerApplication app advertise (advertisementFor app)+ return reg -- | Registers an application (set of services) with Bluez.-registerApplication :: Application -> BluetoothM ()+registerApplication :: Application -> BluetoothM ApplicationRegistered registerApplication app = do conn <- ask addAllObjs conn app- toBluetoothM . const+ () <- toBluetoothM . const $ callMethod bluezName bluezPath (T.pack gattManagerIFace) "RegisterApplication" args [] $ dbusConn conn+ return ApplicationRegistered where args :: (ObjectPath, Map.Map T.Text Any) args = (app ^. path, Map.empty)@@ -47,11 +49,16 @@ addObject conn p $ (WOP p s `withInterface` gattServiceIFaceP) <> (WOP p s `withInterface` propertiesIFaceP)+ registerObjectPath (s ^. uuid) p 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)+ registerObjectPath (c ^. uuid) p'+ where+ registerObjectPath :: UUID -> ObjectPath -> IO ()+ registerObjectPath uuid' op = writeIORef (objectPathOf uuid') (Just op) -- | Advertise a set of services. advertise :: WithObjectPath Advertisement -> BluetoothM ()@@ -76,26 +83,29 @@ 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++-- | Triggers notifications or indications.+triggerNotification :: ApplicationRegistered -> CharacteristicBS -> BluetoothM ()+triggerNotification ApplicationRegistered c = do+ case c ^. readValue of+ Nothing -> throwError "Handler does not have a readValue implementation!"+ Just readHandler -> do+ res' <- liftIO $ runHandler readHandler+ res <- case res' of+ Left e -> throwError $ BLEError e+ Right v -> return v+ mPath <- liftIO $ readIORef $ objectPathOf (c ^. uuid)+ case mPath of+ Nothing -> throwError "UUID not found - are you sure you registered the application containing it?"+ Just path' -> runEff $ propertyChanged (valProp $ WOP path' c) res 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+ Left e -> throwError . DBusError . MethodErrorMessage $ errorBody e Right val -> return val- -- * Constants
src/Bluetooth/Internal/Errors.hs view
@@ -15,6 +15,9 @@ = Handler { getReadValue :: ExceptT T.Text IO a } deriving (Functor, Applicative, Monad, MonadIO, Generic, MonadError T.Text) +runHandler :: Handler a -> IO (Either T.Text a)+runHandler = runExceptT . getReadValue+ -- | Generic failure errorFailed :: Handler a errorFailed = throwError "org.bluez.Error.Failed"
src/Bluetooth/Internal/HasInterface.hs view
@@ -1,9 +1,10 @@ module Bluetooth.Internal.HasInterface where +import Control.Concurrent (readMVar, swapMVar, modifyMVar_) import Control.Monad.Except (liftIO, mapExceptT)+import Control.Monad import Control.Monad.Writer.Strict (WriterT)-import Data.IORef import Data.Proxy import Data.Word (Word16) import DBus@@ -71,9 +72,6 @@ -- 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@@ -82,9 +80,6 @@ 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 = []@@ -118,9 +113,9 @@ = 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 }+ getInterface char _+ = baseIface { interfaceProperties = SomeProperty prop+ : interfaceProperties baseIface } where baseIface = defPropIFace (Just $ char ^. path) (T.pack gattCharacteristicIFace) char prop = mkProperty (char ^. path)@@ -134,6 +129,7 @@ getInterface adv _ = defPropIFace Nothing (T.pack leAdvertisementIFace) adv + -- * GattService @@ -192,6 +188,7 @@ , interfaceProperties = [ SomeProperty uuid' , SomeProperty service , SomeProperty flags+ , SomeProperty notifying , SomeProperty $ valProp char ] }@@ -211,24 +208,22 @@ 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-}+ nots <- liftIO $ readMVar $+ characteristicIsNotifying (char ^. value . uuid)+ when (nots && res) $ propertyChanged (valProp char) 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+ go = liftIO . void $+ swapMVar (characteristicIsNotifying $ char ^. value . uuid) 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+ go = liftIO . void $+ swapMVar (characteristicIsNotifying $ char ^. value . uuid) True uuid' :: Property (RepType UUID) uuid' = Property@@ -260,6 +255,21 @@ , propertySet = Nothing , propertyEmitsChangedSignal = PECSFalse }++ notifying :: Property (RepType Bool)+ notifying = Property+ { propertyPath = objectPath $ (char ^. path . toText) </> "Notifying"+ , propertyInterface = T.pack gattCharacteristicIFace+ , propertyName = "Notifying"+ , propertyGet = Just $ liftIO $ toRep <$> readMVar mvar+ , propertySet = Just $ \new -> liftIO $ do+ case fromRep new of+ Nothing -> return False+ Just v -> modifyMVar_ mvar (const $ return v) >> return True+ , propertyEmitsChangedSignal = PECSFalse+ }+ where+ mvar = characteristicIsNotifying (char ^. value . uuid) valProp :: WithObjectPath (CharacteristicBS) -> Property (RepType BS.ByteString) valProp char = mkProperty (char ^. path)
src/Bluetooth/Internal/Types.hs view
@@ -9,7 +9,9 @@ module Bluetooth.Internal.Types where -import Control.Monad.Except (ExceptT (ExceptT), MonadError, runExceptT)+import Control.Concurrent (MVar, modifyMVar, newMVar)+import Control.Monad.Except (ExceptT (ExceptT), MonadError, runExceptT,+ withExceptT) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Reader (MonadReader, ReaderT (ReaderT), runReaderT) import Data.Default.Class (Default (def))@@ -28,6 +30,7 @@ import GHC.Generics (Generic) import Lens.Micro import Lens.Micro.TH (makeFields)+import System.IO.Unsafe (unsafePerformIO) import qualified Data.ByteString as BS import qualified Data.Map as Map@@ -210,20 +213,53 @@ -- | Write a value. Note that the value is only writeable externally if the -- characteristic contains the CPWrite property *and* this is a Just. , characteristicWriteValue :: Maybe (typ -> Handler Bool)- -- | 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 +-- This is essentialy the unsafePerformIO memoization trick+characteristicIsNotifying :: UUID -> MVar Bool+characteristicIsNotifying = unsafePerformIO $ do+ cm <- newMVar $ Map.empty+ return $ \uuid' -> unsafePerformIO $ do+ modifyMVar cm $ \curMap -> case Map.lookup uuid' curMap of+ Nothing -> do+ e <- newMVar False+ return (Map.insert uuid' e curMap, e)+ Just v -> return (curMap, v)+{-# NOINLINE characteristicIsNotifying #-}++-- This too is essentialy the unsafePerformIO memoization trick. Keeps track of+-- object paths for registered services and characteristics so that we can+-- expose an API that doesn't require WithObjectPath+objectPathOf :: UUID -> IORef (Maybe ObjectPath)+objectPathOf = unsafePerformIO $ do+ cm <- newMVar $ Map.empty+ return $ \uuid' -> unsafePerformIO $ do+ modifyMVar cm $ \curMap -> case Map.lookup uuid' curMap of+ Nothing -> do+ e <- newIORef Nothing+ return (Map.insert uuid' e curMap, e)+ Just v -> return (curMap, v)+{-# NOINLINE objectPathOf #-}++{-+-- Like 'characteristicIsNotifying', but for cached values.+characteristicValue :: UUID -> MVar BS.ByteString+characteristicValue = unsafePerformIO $ do+ cm <- newMVar $ Map.empty+ return $ \uuid' -> unsafePerformIO $ do+ modifyMVar cm $ \curMap -> case Map.lookup uuid' curMap of+ Nothing -> do+ e <- newMVar False+ return (Map.insert uuid' e curMap, e)+ Just v -> return (curMap, v)+{-# NOINLINE characteristicValue #-}+-}+ instance IsString (Characteristic a) where- fromString x = Characteristic (fromString x) [] Nothing Nothing Nothing+ fromString x = Characteristic (fromString x) [] Nothing Nothing -- Note [WithObjectPath] instance Representable (WithObjectPath (Characteristic a)) where@@ -403,18 +439,38 @@ -- * BluetoothM +data Error+ = DBusError MethodError+ | BLEError T.Text+ deriving (Show, Generic)++instance IsString Error where+ fromString = BLEError . fromString+ newtype BluetoothM a- = BluetoothM ( ReaderT Connection (ExceptT MethodError IO) a )- deriving (Functor, Applicative, Monad, MonadIO, MonadError MethodError,+ = BluetoothM ( ReaderT Connection (ExceptT Error IO) a )+ deriving (Functor, Applicative, Monad, MonadIO, MonadError Error, MonadReader Connection) -runBluetoothM :: BluetoothM a -> Connection -> IO (Either MethodError a)+runBluetoothM :: BluetoothM a -> Connection -> IO (Either Error a) runBluetoothM (BluetoothM e) conn = runExceptT $ runReaderT e conn toBluetoothM :: (Connection -> IO (Either MethodError a)) -> BluetoothM a-toBluetoothM = BluetoothM . ReaderT . fmap ExceptT+toBluetoothM = BluetoothM . ReaderT . fmap (withExceptT DBusError . ExceptT) +-- * Assorted++-- | This datatype, which is kept opaque, is returned when an application is+-- successfully registered, and required as an argument from functions that+-- should only be called after the application has been registered.+data ApplicationRegistered = ApplicationRegistered+ deriving (Eq, Show, Read, Generic)++data Status+ = Success+ | Failure+ deriving (Eq, Show, Read, Ord, Enum, Generic) {- Note [WithObjectPath] ~~~~~~~~~~~~~~~~~~~~~~~~~
test/Bluetooth/TypesSpec.hs view
@@ -1,10 +1,8 @@ {-# 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 ()@@ -83,12 +81,6 @@ <*> 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
@@ -7,13 +7,13 @@ import Bluetooth import Control.Monad.IO.Class+import Data.Either (isRight) import DBus import Test.Hspec import qualified Data.ByteString as BS - spec :: Spec spec = do #ifndef Bluez@@ -21,6 +21,7 @@ #else registerApplicationSpec advertiseSpec+ {-notifySpec-} #endif registerApplicationSpec :: Spec@@ -28,7 +29,7 @@ it "registers the service with bluez" $ \conn -> do v <- runBluetoothM (registerApplication testApp) conn- v `shouldBe` Right ()+ v `shouldSatisfy` isRight -- 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@@ -39,7 +40,7 @@ let checkAdvert ad conn = do v <- runBluetoothM (advertise ad) conn- v `shouldBe` Right ()+ v `shouldSatisfy` isRight -- 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@@ -57,7 +58,23 @@ let adv = testAdv & value . manufacturerData . at 1 ?~ "hi" checkAdvert adv conn +{-notifySpec :: Spec-}+{-notifySpec = describe "notification" $ before connect $ do-} + {-it "accepts StartNotify" $ \conn -> do-}+ {-readIORef isNotifying `shouldReturn` False-}+ {-v <- runBluetoothM (registerApplication testApp) conn-}+ {-_ <- runBluetoothM (testCharacteristic ^. startNotify) conn-}+ {-readIORef isNotifying `shouldReturn` True-}++ {-it "accepts StopNotify" $ \conn -> do-}+ {-readIORef isNotifying `shouldReturn` False-}+ {-v <- runBluetoothM (registerApplication testApp) conn-}+ {-_ <- runBluetoothM (testCharacteristic ^. startNotify) conn-}+ {-readIORef isNotifying `shouldReturn` True-}+ {-_ <- runBluetoothM (testCharacteristic ^. stopNotify) conn-}+ {-readIORef isNotifying `shouldReturn` False-}+ -- * Test service testApp :: Application@@ -74,7 +91,7 @@ testCharacteristic = "cdcb58aa-7e4c-4d22-b0bf-a90cd67ba60b" & readValue ?~ encodeRead go- & properties .~ [CPRead]+ & properties .~ [CPRead, CPNotify] where go :: Handler BS.ByteString go = do