#if !MIN_VERSION_base(4,9,0)
#endif
module Bluetooth.Internal.Types where
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))
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 (dBusConnectionName, root)
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
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
(</>) :: 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
[] -> "/"
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')
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)
data WithObjectPath a = WOP
{ withObjectPathPath :: ObjectPath
, withObjectPathValue :: a
} deriving (Eq, Show, Generic, Functor)
makeFields ''WithObjectPath
type AnyDBusDict = 'TypeDict 'TypeString 'TypeVariant
data Descriptor = Descriptor
{ descriptorUuid :: UUID
} deriving (Eq, Show, Generic)
data AdvertisingPacketType
= ConnectableUndirected
| ConnectableDirected
| NonConnnectableUndirected
| ScannableUndirected
deriving (Eq, Show, Read, Generic, Ord)
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 (Handler typ)
, characteristicWriteValue :: Maybe (typ -> Handler Bool)
} deriving (Generic)
makeFields ''Characteristic
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)
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)
instance IsString (Characteristic a) where
fromString x = Characteristic (fromString x) [] Nothing Nothing
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)
data Service = Service
{ serviceUuid :: UUID
, serviceCharacteristics :: [CharacteristicBS]
} deriving (Generic)
makeFields ''Service
instance IsString Service where
fromString x = Service (fromString x) []
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 )
, ("Primary", MkAny $ True)
, ("Characteristics", MkAny (charPaths . length $ serv ^. value . characteristics))
]
charPaths :: Int -> [ObjectPath]
charPaths i
= characteristicObjectPath (objectPath $ serv ^. path . toText) <$> [0..i1]
fromRep _ = error "not implemented"
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)
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
data Connection = Connection
{ dbusConn :: DBusConnection
, addObject :: ObjectPath -> Object -> IO ()
}
connectionName :: Connection -> T.Text
connectionName = dBusConnectionName . dbusConn
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
data Error
= DBusError MethodError
| BLEError T.Text
deriving (Show, Generic)
instance IsString Error where
fromString = BLEError . fromString
newtype BluetoothM a
= BluetoothM ( ReaderT Connection (ExceptT Error IO) a )
deriving (Functor, Applicative, Monad, MonadIO, MonadError Error,
MonadReader Connection)
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 (withExceptT DBusError . ExceptT)
data ApplicationRegistered = ApplicationRegistered
deriving (Eq, Show, Read, Generic)
data Status
= Success
| Failure
deriving (Eq, Show, Read, Ord, Enum, Generic)