diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Tamas Fabian (c) 2018 + +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 Tamas Fabian nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,15 @@ +# haskell-bglib + +An implementation of the BGAPI serial protocol. + +This protocol is spoken by Silicon Laboratories (formely BlueGiga) +Bluetooth and Wifi products via UART or USB. + +The Bluetooth Smart Software API Reference Manual can be found at: + +https://www.silabs.com/products/wireless/bluetooth/bluetooth-low-energy-modules/ble113-bluetooth-smart-module + +The library works over a SerialPort, so the hardware need to be +connected over a standard port that is recognized by the operating +system. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bglib.cabal b/bglib.cabal new file mode 100644 --- /dev/null +++ b/bglib.cabal @@ -0,0 +1,48 @@ +name: bglib +version: 0.1.0.0 +synopsis: Implementation of the BGAPI serial protocol +description: This library implements Silicon Labs' (formerly BlueGiga) + serial protocol to communicate with certain Bluetooth and + Wifi products such as the BLED112 USB dongle or the BLE112 + and BLE113 Bluetooth Low Energy modules. +homepage: https://github.com/netom/bgapi#readme +license: MIT +license-file: LICENSE +author: Tamas Fabian +maintainer: giganetom@gmail.com +copyright: MIT +category: library +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: BGLib.Commands + , BGLib.Types + build-depends: base >= 4.7 && < 5 + , binary + , bytestring + , monad-loops + , mtl + , serialport + , stm + default-language: Haskell2010 + +executable bgapitest + hs-source-dirs: examples + main-is: bgapitest.hs + ghc-options: -Wall -threaded + build-depends: base >= 4.7 && < 5 + , bglib + , bytestring + , mtl + , optparse-applicative + , serialport + , stm + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/netom/haskell-bglib diff --git a/examples/bgapitest.hs b/examples/bgapitest.hs new file mode 100644 --- /dev/null +++ b/examples/bgapitest.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +import BGLib.Commands +import BGLib.Types +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad.IO.Class +import Control.Monad.Reader +import qualified Data.ByteString.Char8 as BSS +import Data.Semigroup ((<>)) +import Options.Applicative +import Prelude hiding (print, putStrLn) +import qualified Prelude as P +import System.Exit +import System.Hardware.Serialport + +data AppOptions = AppOptions + { appOptSerialPort :: String + , appOptDebug :: Bool + } + +data App = App + { appOptions :: AppOptions + , appSerialPort :: SerialPort + , appBGChan :: TChan BgPacket + } + +instance HasSerialPort App where + getSerialPort = appSerialPort + +instance HasBGChan App where + getBGChan = appBGChan + +instance HasDebug App where + getDebug = appOptDebug . appOptions + +optParser :: Parser AppOptions +optParser = AppOptions + <$> argument str + ( metavar "PORT" + <> help "Serial port" ) + <*> switch + ( long "debug" + <> short 'd' + <> help "Whether to be quiet" ) + +execApp :: env -> ReaderT env m a -> m a +execApp = flip runReaderT + +putStrLn :: MonadIO m => String -> m () +putStrLn = liftIO . P.putStrLn + +print :: (MonadIO m, Show a) => a -> m () +print = liftIO . P.print + +main :: IO () +main = do + appOpts <- execParser $ + info + ( optParser <**> helper ) + ( fullDesc + <> progDesc "Execute a short battery of test on port PORT" + <> header "bgapitest - a short text / example for haskell-bglib" + ) + + app <- App + <$> return appOpts + <*> openSerial + (appOptSerialPort appOpts) + (SerialPortSettings CS115200 8 One NoParity NoFlowControl 1000) + <*> atomically newBroadcastTChan + + execApp app $ do + -- Register an event handler for protocol errors. + _ <- evtSystemProtocolError $ \reason -> do + die $ "*** PROTOCOL ERROR " ++ show reason + + -- Starts a thread that keeps reading packets from the serial port, + -- pushing them to the broadcast TChan + startPacketReader + + putStrLn "Running hello" + systemHello + putStrLn "If you can read this, we're fine. :)" + putStrLn "" + + putStrLn "Getting system information:" + (major, minor, patch, build, llVersion, protocolVersion, hw) <- systemGetInfo + putStrLn $ "Major version: " ++ show major + putStrLn $ "Minor version: " ++ show minor + putStrLn $ "Patch version: " ++ show patch + putStrLn $ "Build Version: " ++ show build + putStrLn $ "Link Layer version: " ++ show llVersion + putStrLn $ "Protocol version: " ++ show protocolVersion + putStrLn $ "Hardware version: " ++ show hw + putStrLn "" + + putStrLn "We should get a \"not connected\" error:" + attclientAttributeWrite 0 0 "e" >>= print + putStrLn "" + + putStrLn "Getting Bluetooth Address:" + systemAddressGet >>= print + putStrLn "" + + putStrLn "Running some encryption-decription tests" + putStrLn "" + + let aeskey = "abcdefgh12345678" + putStrLn $ "Setting AES key to " ++ aeskey + systemAesSetkey $ toUInt8Array $ BSS.pack $ aeskey + putStrLn "" + + let plaintext = "This is plain" + putStrLn $ "Encrypting: " ++ plaintext + encrypted <- systemAesEncrypt $ toUInt8Array $ BSS.pack $ plaintext + putStrLn $ "Encrypted: " ++ bsShowHex (fromUInt8Array encrypted) + putStrLn "" + + putStrLn $ "Decrypting" + decrypted <- systemAesDecrypt encrypted + putStrLn $ "Decrypted: " ++ BSS.unpack (fromUInt8Array decrypted) + putStrLn "" + + -- Register an event handler for scan responses. Can be done anywhere. + -- The handler forks a thread that runs forever, and can be terminated + -- later if necessary. + tid <- evtGapScanResponse $ \rssi _ sender _ _ _ -> do + print rssi + print sender + putStrLn "" + return True -- We'd like to listen to further events. + + _ <- gapDiscover GapDiscoverGeneric + + liftIO $ threadDelay 5000000 + + _ <- gapEndProcedure + + liftIO $ killThread tid + + -- Let's cause trouble. + s <- askSerialPort + _ <- liftIO $ send s $ BSS.pack "a" + liftIO $ threadDelay 5000000 diff --git a/src/BGLib/Commands.hs b/src/BGLib/Commands.hs new file mode 100644 --- /dev/null +++ b/src/BGLib/Commands.hs @@ -0,0 +1,1027 @@ +{-# LANGUAGE RecordWildCards #-} + +module BGLib.Commands + ( startPacketReader + , attclientAttributeWrite + , attclientExecuteWrite + , attclientFindByTypeValue + , attclientFindInformation + , attclientIndicateConfirm + , attclientPrepareWrite + , attclientReadByGroupType + , attclientReadByHandle + , attclientReadByType + , attclientReadLong + , attclientReadMultiple + , attclientWriteCommand + , evtAttclientAttributeValue + , evtAttclientFindInformationFound + , evtAttclientGroupFound + , evtAttclientIndicated + , evtAttclientProcedureCompleted + , evtAttclientReadMultipleResponse + , attributesRead + , attributesReadType + , attributesSend + , attributesUserReadResponse + , attributesUserWriteResponse + , attributesWrite + , evtAttributesStatus + , evtAttributesUserReadRequest + , evtAttributesValue + , connectionChannelMapGet + , connectionChannelMapSet + , connectionDisconnect + , connectionGetRssi + , connectionGetStatus + , connectionSlaveLatencyDisable + , connectionUpdate + , connectionVersionUpdate + , evtConnectionDisconnected + , evtConnectionFeatureInd + , evtConnectionStatus + , evtConnectionVersionInd + , gapConnectDirect + , gapConnectSelective + , gapDiscover + , gapEndProcedure + , gapSetAdvData + , gapSetAdvParameters + , gapSetDirectedConnectableMode + , gapSetFiltering + , gapSetInitiatingConParameters + , gapSetMode + , gapSetNonresolvableAddress + , gapSetPrivacyFlags + , gapSetScanParameters + , evtGapScanResponse + , hardwareAdcRead + , hardwareAnalogComparatorConfigIrq + , hardwareAnalogComparatorEnable + , hardwareAnalogComparatorRead + , hardwareGetTimestamp + , hardwareI2cRead + , hardwareI2cWrite + , hardwareIoPortConfigDirection + , hardwareIoPortConfigFunction + , hardwareIoPortConfigIrq + , hardwareIoPortConfigPull + , hardwareIoPortIrqDirection + , hardwareIoPortIrqEnable + , hardwareIoPortRead + , hardwareIoPortWrite + , hardwareSetRxgain + , hardwareSetSoftTimer + , hardwareSetTxpower + , hardwareSleepEnable + , hardwareSpiConfig + , hardwareSpiTransfer + , hardwareTimerComparator + , hardwareUsbEnable + , evtHardwareAdcResult + , evtHardwareAnalogComparatorStatus + , evtHardwareIoPortStatus + , evtHardwareSoftTimer + , flashErasePage + , flashPsDefrag + , flashPsDump + , flashPsEraseAll + , flashPsErase + , flashPsLoad + , flashPsSave + , flashReadData + , flashWriteData + , evtFlashPsKey + , smDeleteBonding + , smEncryptStart + , smGetBonds + , smPasskeyEntry + , setBondableMode + , smSetOobData + , smSetPairingDistributionKeys + , smSetParameters + , smWhitelistBonds + , evtSmBondingFail + , evtSmBondStatus + , evtSmPasskeyDisplay + , evtSmPasskeyRequest + , systemAddressGet + , systemAesDecrypt + , systemAesEncrypt + , systemAesSetkey + , systemDelayReset + , systemEndpointRx + , systemEndpointSetWatermarks + , systemEndpointTx + , systemGetBootloaderCrc + , systemGetConnections + , systemGetCounters + , systemGetInfo + , systemHello + , systemReset + , systemUsbEnumerationStatusGet + , systemWhitelistAppend + , systemWhitelistClear + , systemWhitelistRemove + , evtSystemBoot + , evtSystemEndpointWatermarkRx + , evtSystemEndpointWatermarkTx + , evtSystemNoLicenseKey + , evtSystemProtocolError + , evtSystemScriptFailure + , evtSystemUsbEnumerated + , testChannelMode + , testGetChannelMap + , testPhyEnd + , testPhyRx + , testPhyTx + , dfuFlashSetAddress + , dfuFlashUpload + , dfuFlashUploadFinish + , dfuReset + , evtDfuBoot + ) where + +import BGLib.Types +import Control.Concurrent +import Control.Concurrent.STM.TChan +import Control.Monad.Loops +import Control.Monad.STM +import Data.Binary +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString as BSS +import System.Hardware.Serialport +import Control.Monad.IO.Class +import Control.Monad.Reader + +-- Write a BgPacket to a SerialPort +writeBGPacket' :: Bool -> SerialPort -> BgPacket -> IO () +writeBGPacket' dbg s p = do + let packetBS = BSL.toStrict $ encode p + when dbg $ do + putStr "[DEBUG] WRITE: " + putStrLn $ show p + _ <- send s packetBS + return () + +-- Write the BgPacket to the SerialPort in env asked from the MonadReader +writeBGPacket :: (MonadIO m, MonadReader env m, HasSerialPort env, HasDebug env) => BgPacket -> m () +writeBGPacket p = do + s <- askSerialPort + dbg <- askDebug + liftIO $ writeBGPacket' dbg s p + +-- Read one BgPacket from a SerialPort +readBGPacket' :: Bool -> SerialPort -> IO BgPacket +readBGPacket' dbg s = do + bgpHeader@BgPacketHeader{..} <- decode <$> BSL.fromStrict <$> recv s 4 + bgpPayload <- toBgPayload <$> recv s (fromIntegral bghLength) + let p = BgPacket {..} + when dbg $ do + putStr "[DEBUG] READ: " + putStrLn $ show p + return p + +-- Read one BgPacket from the SerialPort in env asked from the MonadReader +--readBGPacket :: (MonadIO m, MonadReader env m, HasSerialPort env) => m BgPacket +--readBGPacket = do +-- s <- askSerialPort +-- liftIO $ readBGPacket' s + +-- Launch a thread that reads packets and sends them down a TChan BgPacket +startPacketReader :: (MonadIO m, MonadReader env m, HasBGChan env, HasSerialPort env, HasDebug env) => m () +startPacketReader = do + c <- askBGChan + s <- askSerialPort + dbg <- askDebug + _ <- liftIO $ forkIO $ forever $ do + --putStrLn "* READ *" + readBGPacket' dbg s >>= atomically . writeTChan c + return () + +-- Waits for any BgPacket to appear on the TChan +waitForAnyPacket :: TChan BgPacket -> IO BgPacket +waitForAnyPacket chan = do + liftIO $ atomically $ readTChan chan + +-- Wait for a packet with specific values in it's header +waitForPacket :: TChan BgPacket -> BgMessageType -> BgTecnologyType -> BgCommandClass -> UInt8 -> IO BgPacket +waitForPacket chan mt tt cc cid = do + untilJust $ do + p@BgPacket{..} <- waitForAnyPacket chan + return $ if bgHeaderMatches mt tt cc cid bgpHeader then Just p else Nothing + +-- eXecute a Command, don't wait for any answer +xCmd' :: (MonadIO m, MonadReader env m, HasSerialPort env, HasDebug env, Binary a ) => BgMessageType -> BgTecnologyType -> BgCommandClass -> UInt8 -> a -> m () +xCmd' mt tt cc cid inp = do + let inpBS = BSL.toStrict $ encode inp + writeBGPacket $ BgPacket (BgPacketHeader mt tt (fromIntegral $ BSS.length inpBS) cc cid) (toBgPayload inpBS) + +-- Execute a command, wait for the appropriate answer +xCmd :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env, Binary a, Binary b) => BgMessageType -> BgTecnologyType -> BgCommandClass -> UInt8 -> a -> m b +xCmd mt tt cc cid inp = do + -- We need to duplicate the channel BEFORE sending the command, so we don't miss the answer by accident + chan <- askDupBGChan + xCmd' mt tt cc cid inp + decode . BSL.fromStrict . fromBgPayload . bgpPayload <$> ( liftIO $ waitForPacket chan mt tt cc cid ) + +registerEventHandler :: Binary a => (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env) => BgMessageType -> BgTecnologyType -> BgCommandClass -> UInt8 -> (a -> IO Bool) -> m ThreadId +registerEventHandler mt tt cc cid handler = do + chan <- askDupBGChan + liftIO $ forkIO $ go chan + where + go chan = do + BgPacket{..} <- waitForPacket chan mt tt cc cid + continue <- handler $ decode $ BSL.fromStrict $ fromBgPayload $ bgpPayload + if continue then go chan else return () + +curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d +curry3 func a b c = func (a, b, c) + +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 func (a, b, c) = func a b c + +curry4 :: ((a, b, c, d) -> e) -> a -> b -> c -> d -> e +curry4 func a b c d = func (a, b, c, d) + +uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e +uncurry4 func (a, b, c, d) = func a b c d + +curry5 :: ((a, b, c, d, e) -> f) -> a -> b -> c -> d -> e -> f +curry5 func a b c d e = func (a, b, c, d, e) + +uncurry5 :: (a -> b -> c -> d -> e -> f) -> (a, b, c, d, e) -> f +uncurry5 func (a, b, c, d, e) = func a b c d e + +curry6 :: ((a, b, c, d, e, f) -> g) -> a -> b -> c -> d -> e -> f -> g +curry6 func a b c d e f = func (a, b, c, d, e, f) + +uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a, b, c, d, e, f) -> g +uncurry6 func (a, b, c, d, e, f) = func a b c d e f + +uncurry7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> (a, b, c, d, e, f, g) -> h +uncurry7 func (a, b, c, d, e, f, g) = func a b c d e f g + +uncurry8 :: (a -> b -> c -> d -> e -> f -> g -> h -> i) -> (a, b, c, d, e, f, g, h) -> i +uncurry8 func (a, b, c, d, e, f, g, h) = func a b c d e f g h + +----------------------------------------------------------------------- +-- Attribute Client +----------------------------------------------------------------------- +--gapDiscover mode = xCmd BgMsgCR BgBlue BgClsGenericAccessProfile 0x02 mode + + +attclientAttributeWrite + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt16 -> UInt8Array -> m (UInt8, BGResult) +attclientAttributeWrite = curry3 $ xCmd BgMsgCR BgBlue BgClsAttributeClient 0x05 + +attclientExecuteWrite + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> Bool -> m (UInt8, BGResult) +attclientExecuteWrite = curry $ xCmd BgMsgCR BgBlue BgClsAttributeClient 0x0a + +attclientFindByTypeValue + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt16 -> UInt16 -> UInt16 -> UInt8Array -> m (UInt8, BGResult) +attclientFindByTypeValue = curry5 $ xCmd BgMsgCR BgBlue BgClsAttributeClient 0x00 + +attclientFindInformation + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt16 -> UInt16 -> m (UInt8, BGResult) +attclientFindInformation = curry3 $ xCmd BgMsgCR BgBlue BgClsAttributeClient 0x03 + +attclientIndicateConfirm + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> m BGResult +attclientIndicateConfirm = xCmd BgMsgCR BgBlue BgClsAttributeClient 0x07 + +attclientPrepareWrite + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt16 -> UInt16 -> UInt8Array -> m (UInt8, BGResult) +attclientPrepareWrite = curry4 $ xCmd BgMsgCR BgBlue BgClsAttributeClient 0x09 + +attclientReadByGroupType + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt16 -> UInt16 -> UInt8Array -> m (UInt8, BGResult) +attclientReadByGroupType = curry4 $ xCmd BgMsgCR BgBlue BgClsAttributeClient 0x01 + +attclientReadByHandle + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt16 -> m (UInt8, BGResult) +attclientReadByHandle = curry $ xCmd BgMsgCR BgBlue BgClsAttributeClient 0x04 + +attclientReadByType + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt16 -> UInt16 -> UInt8Array -> m (UInt8, BGResult) +attclientReadByType = curry4 $ xCmd BgMsgCR BgBlue BgClsAttributeClient 0x02 + +attclientReadLong + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt16 -> m (UInt8, BGResult) +attclientReadLong = curry $ xCmd BgMsgCR BgBlue BgClsAttributeClient 0x08 + +attclientReadMultiple + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8Array -> m (UInt8, BGResult) +attclientReadMultiple = curry $ xCmd BgMsgCR BgBlue BgClsAttributeClient 0x0b + +attclientWriteCommand + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt16 -> UInt8Array -> m (UInt8, BGResult) +attclientWriteCommand = curry3 $ xCmd BgMsgCR BgBlue BgClsAttributeClient 0x06 + +evtAttclientAttributeValue + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt8 -> UInt16 -> UInt8 -> UInt8Array -> IO Bool) -> m ThreadId +evtAttclientAttributeValue + = registerEventHandler BgMsgEvent BgBlue BgClsAttributeClient 0x05 . uncurry4 + +evtAttclientFindInformationFound + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt8 -> UInt16 -> UInt8Array -> IO Bool) -> m ThreadId +evtAttclientFindInformationFound + = registerEventHandler BgMsgEvent BgBlue BgClsAttributeClient 0x04 . uncurry3 + +evtAttclientGroupFound + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt8 -> UInt16 -> UInt16 -> UInt8Array -> IO Bool) -> m ThreadId +evtAttclientGroupFound + = registerEventHandler BgMsgEvent BgBlue BgClsAttributeClient 0x02 . uncurry4 + +evtAttclientIndicated + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt8 -> UInt16 -> IO Bool) -> m ThreadId +evtAttclientIndicated + = registerEventHandler BgMsgEvent BgBlue BgClsAttributeClient 0x00 . uncurry + +evtAttclientProcedureCompleted + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt8 -> BGResult -> UInt16 -> IO Bool) -> m ThreadId +evtAttclientProcedureCompleted + = registerEventHandler BgMsgEvent BgBlue BgClsAttributeClient 0x01 . uncurry3 + +evtAttclientReadMultipleResponse + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt8 -> UInt8Array -> IO Bool) -> m ThreadId +evtAttclientReadMultipleResponse + = registerEventHandler BgMsgEvent BgBlue BgClsAttributeClient 0x06 . uncurry + +----------------------------------------------------------------------- +-- Attribute Database +----------------------------------------------------------------------- + +attributesRead + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt16 -> UInt16 -> m (UInt16, UInt16, BGResult, UInt8Array) +attributesRead = curry $ xCmd BgMsgCR BgBlue BgClsAttributeDatabase 0x01 + +attributesReadType + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt16 -> m (UInt16, BGResult, UInt8Array) +attributesReadType = xCmd BgMsgCR BgBlue BgClsAttributeDatabase 0x02 + +attributesSend + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt16 -> UInt8Array -> m BGResult +attributesSend = curry3 $ xCmd BgMsgCR BgBlue BgClsAttributeDatabase 0x05 + +attributesUserReadResponse + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8 -> UInt8Array -> m () +attributesUserReadResponse = curry3 $ xCmd BgMsgCR BgBlue BgClsAttributeDatabase 0x03 + +attributesUserWriteResponse + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8 -> m () +attributesUserWriteResponse = curry $ xCmd BgMsgCR BgBlue BgClsAttributeDatabase 0x04 + +attributesWrite + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt16 -> UInt8 -> UInt8Array -> m BGResult +attributesWrite = curry3 $ xCmd BgMsgCR BgBlue BgClsAttributeDatabase 0x00 + +evtAttributesStatus + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt16 -> UInt8 -> IO Bool) -> m ThreadId +evtAttributesStatus + = registerEventHandler BgMsgEvent BgBlue BgClsAttributeDatabase 0x02 . uncurry + +evtAttributesUserReadRequest + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt8 -> UInt16 -> UInt16 -> UInt8 -> IO Bool) -> m ThreadId +evtAttributesUserReadRequest + = registerEventHandler BgMsgEvent BgBlue BgClsAttributeDatabase 0x01 . uncurry4 + +evtAttributesValue + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt8 -> UInt8 -> UInt16 -> UInt16 -> UInt8Array -> IO Bool) -> m ThreadId +evtAttributesValue + = registerEventHandler BgMsgEvent BgBlue BgClsAttributeDatabase 0x00 . uncurry5 + +----------------------------------------------------------------------- +-- Connection +----------------------------------------------------------------------- + +connectionChannelMapGet + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> m (UInt8, UInt8Array) +connectionChannelMapGet = xCmd BgMsgCR BgBlue BgClsConnection 0x04 + +connectionChannelMapSet + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8Array -> m (UInt8, BGResult) +connectionChannelMapSet = curry $ xCmd BgMsgCR BgBlue BgClsConnection 0x05 + +connectionDisconnect + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> m (UInt8, BGResult) +connectionDisconnect = xCmd BgMsgCR BgBlue BgClsConnection 0x00 + +connectionGetRssi + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> m (UInt8, Int8) +connectionGetRssi = xCmd BgMsgCR BgBlue BgClsConnection 0x01 + +connectionGetStatus + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> m UInt8 +connectionGetStatus = xCmd BgMsgCR BgBlue BgClsConnection 0x07 + +connectionSlaveLatencyDisable + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> m BGResult +connectionSlaveLatencyDisable = xCmd BgMsgCR BgBlue BgClsConnection 0x09 + +connectionUpdate + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt16 -> UInt16 -> UInt16 -> UInt16 -> m (UInt8, BGResult) +connectionUpdate = curry5 $ xCmd BgMsgCR BgBlue BgClsConnection 0x02 + +connectionVersionUpdate + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> m (UInt8, BGResult) +connectionVersionUpdate = xCmd BgMsgCR BgBlue BgClsConnection 0x03 + +evtConnectionDisconnected + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt8 -> BGResult -> IO Bool) -> m ThreadId +evtConnectionDisconnected + = registerEventHandler BgMsgEvent BgBlue BgClsConnection 0x04 . uncurry + +evtConnectionFeatureInd + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt8 -> UInt8Array -> IO Bool) -> m ThreadId +evtConnectionFeatureInd = registerEventHandler BgMsgEvent BgBlue BgClsConnection 0x02 . uncurry + +evtConnectionStatus + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt8 -> UInt8 -> BdAddr -> UInt8 -> UInt16 -> UInt16 -> UInt16 -> UInt8 -> IO Bool) + -> m ThreadId +evtConnectionStatus = registerEventHandler BgMsgEvent BgBlue BgClsConnection 0x00 . uncurry8 + +evtConnectionVersionInd + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt8 -> UInt8 -> UInt16 -> UInt16 -> IO Bool) -> m ThreadId +evtConnectionVersionInd = registerEventHandler BgMsgEvent BgBlue BgClsConnection 0x01 . uncurry4 + +----------------------------------------------------------------------- +-- Generic Access Profile +----------------------------------------------------------------------- + +gapConnectDirect + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => BdAddr -> GapAddressType -> UInt16 -> UInt16 -> UInt16 -> UInt16 -> m (BGResult, UInt8) +gapConnectDirect = curry6 $ xCmd BgMsgCR BgBlue BgClsGenericAccessProfile 0x03 + +gapConnectSelective + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt16 -> UInt16 -> UInt16 -> UInt16 -> m (BGResult, UInt8) +gapConnectSelective = curry4 $ xCmd BgMsgCR BgBlue BgClsGenericAccessProfile 0x05 + +gapDiscover + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => GapDiscoverMode -> m UInt16 +gapDiscover = xCmd BgMsgCR BgBlue BgClsGenericAccessProfile 0x02 + +gapEndProcedure + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => m UInt16 +gapEndProcedure = xCmd BgMsgCR BgBlue BgClsGenericAccessProfile 0x04 () + +gapSetAdvData + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8Array -> m BGResult +gapSetAdvData = curry $ xCmd BgMsgCR BgBlue BgClsGenericAccessProfile 0x09 + +gapSetAdvParameters + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt16 -> UInt16 -> UInt8 -> m BGResult +gapSetAdvParameters = curry3 $ xCmd BgMsgCR BgBlue BgClsGenericAccessProfile 0x08 + +gapSetDirectedConnectableMode + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => BdAddr -> GapAddressType -> m BGResult +gapSetDirectedConnectableMode = curry $ xCmd BgMsgCR BgBlue BgClsGenericAccessProfile 0x0a + +gapSetFiltering + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => GapScanPolicy -> GapAdvPolicy -> UInt8 -> m BGResult +gapSetFiltering = curry3 $ xCmd BgMsgCR BgBlue BgClsGenericAccessProfile 0x06 + +gapSetInitiatingConParameters + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt16 -> UInt16 -> m BGResult +gapSetInitiatingConParameters = curry $ xCmd BgMsgCR BgBlue BgClsGenericAccessProfile 0x0b + +gapSetMode + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => GapDiscoverableMode -> GapConnectableMode -> m BGResult +gapSetMode = curry $ xCmd BgMsgCR BgBlue BgClsGenericAccessProfile 0x01 + +gapSetNonresolvableAddress + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => BdAddr -> m BGResult +gapSetNonresolvableAddress = xCmd BgMsgCR BgBlue BgClsGenericAccessProfile 0x0c + +gapSetPrivacyFlags + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8 -> m () +gapSetPrivacyFlags = curry $ xCmd BgMsgCR BgBlue BgClsGenericAccessProfile 0x00 + +gapSetScanParameters + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt16 -> UInt16 -> UInt8 -> m BGResult +gapSetScanParameters = curry3 $ xCmd BgMsgCR BgBlue BgClsGenericAccessProfile 0x07 + +-- Register an event handler for GAP scan responses +evtGapScanResponse + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (Int8 -> UInt8 -> BdAddr -> UInt8 -> UInt8 -> UInt8Array -> IO Bool) -> m ThreadId +evtGapScanResponse + = registerEventHandler BgMsgEvent BgBlue BgClsGenericAccessProfile 0x00 . uncurry6 + +----------------------------------------------------------------------- +-- Hardware +----------------------------------------------------------------------- + +hardwareAdcRead + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8 -> UInt8 -> m BGResult +hardwareAdcRead = curry3 $ xCmd BgMsgCR BgBlue BgClsHardware 0x02 + +hardwareAnalogComparatorConfigIrq + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => Bool -> m BGResult +hardwareAnalogComparatorConfigIrq = xCmd BgMsgCR BgBlue BgClsHardware 0x12 + +hardwareAnalogComparatorEnable + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => Bool -> m () +hardwareAnalogComparatorEnable = xCmd BgMsgCR BgBlue BgClsHardware 0x10 + +hardwareAnalogComparatorRead + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => m (BGResult, UInt8) +hardwareAnalogComparatorRead = xCmd BgMsgCR BgBlue BgClsHardware 0x11 () + +hardwareGetTimestamp + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => m UInt32 +hardwareGetTimestamp = xCmd BgMsgCR BgBlue BgClsHardware 0x16 () + +hardwareI2cRead + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> Bool -> UInt8 -> m (UInt16, UInt8Array) +hardwareI2cRead = curry3 $ xCmd BgMsgCR BgBlue BgClsHardware 0x0a + +hardwareI2cWrite + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> Bool -> UInt8Array -> m UInt8 +hardwareI2cWrite = curry3 $ xCmd BgMsgCR BgBlue BgClsHardware 0x0b + +hardwareIoPortConfigDirection + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8 -> m BGResult +hardwareIoPortConfigDirection = curry $ xCmd BgMsgCR BgBlue BgClsHardware 0x03 + +hardwareIoPortConfigFunction + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8 -> m BGResult +hardwareIoPortConfigFunction = curry $ xCmd BgMsgCR BgBlue BgClsHardware 0x04 + +hardwareIoPortConfigIrq + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8 -> Bool -> m BGResult +hardwareIoPortConfigIrq = curry3 $ xCmd BgMsgCR BgBlue BgClsHardware 0x00 + +hardwareIoPortConfigPull + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8 -> Bool -> m BGResult +hardwareIoPortConfigPull = curry3 $ xCmd BgMsgCR BgBlue BgClsHardware 0x05 + +hardwareIoPortIrqDirection + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> Bool -> m BGResult +hardwareIoPortIrqDirection = curry $ xCmd BgMsgCR BgBlue BgClsHardware 0x0f + +hardwareIoPortIrqEnable + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8 -> m BGResult +hardwareIoPortIrqEnable = curry $ xCmd BgMsgCR BgBlue BgClsHardware 0x0e + +hardwareIoPortRead + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8 -> m (BGResult, UInt8, UInt8) +hardwareIoPortRead = curry $ xCmd BgMsgCR BgBlue BgClsHardware 0x07 + +hardwareIoPortWrite + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8 -> UInt8 -> m BGResult +hardwareIoPortWrite = curry3 $ xCmd BgMsgCR BgBlue BgClsHardware 0x06 + +hardwareSetRxgain + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> m () +hardwareSetRxgain = xCmd BgMsgCR BgBlue BgClsHardware 0x13 + +hardwareSetSoftTimer + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt32 -> UInt8 -> Bool -> m BGResult +hardwareSetSoftTimer = curry3 $ xCmd BgMsgCR BgBlue BgClsHardware 0x01 + +hardwareSetTxpower + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> m () +hardwareSetTxpower = xCmd BgMsgCR BgBlue BgClsHardware 0x0c + +hardwareSleepEnable + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => Bool -> m BGResult +hardwareSleepEnable = xCmd BgMsgCR BgBlue BgClsHardware 0x15 + +hardwareSpiConfig + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => Bool -> Bool -> Bool -> Bool -> UInt8 -> UInt8 -> m BGResult +hardwareSpiConfig = curry6 $ xCmd BgMsgCR BgBlue BgClsHardware 0x08 + +hardwareSpiTransfer + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8Array -> m (BGResult, UInt8, UInt8Array) +hardwareSpiTransfer = curry $ xCmd BgMsgCR BgBlue BgClsHardware 0x09 + +hardwareTimerComparator + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8 -> UInt8 -> UInt16 -> m BGResult +hardwareTimerComparator = curry4 $ xCmd BgMsgCR BgBlue BgClsHardware 0x0d + +hardwareUsbEnable + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => Bool -> m BGResult +hardwareUsbEnable = xCmd BgMsgCR BgBlue BgClsHardware 0x14 + +evtHardwareAdcResult + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt8 -> UInt16 -> IO Bool) -> m ThreadId +evtHardwareAdcResult + = registerEventHandler BgMsgEvent BgBlue BgClsHardware 0x02 . uncurry + +evtHardwareAnalogComparatorStatus + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt32 -> UInt8 -> IO Bool) -> m ThreadId +evtHardwareAnalogComparatorStatus + = registerEventHandler BgMsgEvent BgBlue BgClsHardware 0x03 . uncurry + +evtHardwareIoPortStatus + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt32 -> UInt8 -> UInt8 -> UInt8 -> IO Bool) -> m ThreadId +evtHardwareIoPortStatus + = registerEventHandler BgMsgEvent BgBlue BgClsHardware 0x00 . uncurry4 + +evtHardwareSoftTimer + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt8 -> IO Bool) -> m ThreadId +evtHardwareSoftTimer + = registerEventHandler BgMsgEvent BgBlue BgClsHardware 0x01 + +----------------------------------------------------------------------- +-- Persistent Store +----------------------------------------------------------------------- + +flashErasePage + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> m BGResult +flashErasePage = xCmd BgMsgCR BgBlue BgClsPersistentStore 0x06 + +flashPsDefrag + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => m () +flashPsDefrag = xCmd BgMsgCR BgBlue BgClsPersistentStore 0x00 () + +flashPsDump + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => m () +flashPsDump = xCmd BgMsgCR BgBlue BgClsPersistentStore 0x01 () + +flashPsEraseAll + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => m () +flashPsEraseAll = xCmd BgMsgCR BgBlue BgClsPersistentStore 0x02 () + +flashPsErase + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt16 -> m () +flashPsErase = xCmd BgMsgCR BgBlue BgClsPersistentStore 0x05 + +flashPsLoad + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt16 -> m (BGResult, UInt8Array) +flashPsLoad = xCmd BgMsgCR BgBlue BgClsPersistentStore 0x04 + +flashPsSave + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt16 -> UInt8Array -> m BGResult +flashPsSave = curry $ xCmd BgMsgCR BgBlue BgClsPersistentStore 0x03 + +flashReadData + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt32 -> UInt8 -> m UInt8Array +flashReadData = curry $ xCmd BgMsgCR BgBlue BgClsPersistentStore 0x08 + +flashWriteData + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt32 -> UInt8Array -> m BGResult +flashWriteData = curry $ xCmd BgMsgCR BgBlue BgClsPersistentStore 0x07 + +evtFlashPsKey + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt16 -> UInt8Array -> IO Bool) -> m ThreadId +evtFlashPsKey + = registerEventHandler BgMsgEvent BgBlue BgClsPersistentStore 0x00 . uncurry + +----------------------------------------------------------------------- +-- Security Manager +----------------------------------------------------------------------- + +smDeleteBonding + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> m BGResult +smDeleteBonding = xCmd BgMsgCR BgBlue BgClsSecurityManager 0x02 + +smEncryptStart + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> Bool -> m (UInt8, BGResult) +smEncryptStart = curry $ xCmd BgMsgCR BgBlue BgClsSecurityManager 0x00 + +smGetBonds + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => m UInt8 +smGetBonds = xCmd BgMsgCR BgBlue BgClsSecurityManager 0x05 () + +smPasskeyEntry + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt32 -> m BGResult +smPasskeyEntry = curry $ xCmd BgMsgCR BgBlue BgClsSecurityManager 0x04 + +setBondableMode + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => Bool -> m () +setBondableMode = xCmd BgMsgCR BgBlue BgClsSecurityManager 0x01 + +smSetOobData + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8Array -> m () +smSetOobData = xCmd BgMsgCR BgBlue BgClsSecurityManager 0x06 + +smSetPairingDistributionKeys + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8 -> m BGResult +smSetPairingDistributionKeys = curry $ xCmd BgMsgCR BgBlue BgClsSecurityManager 0x08 + +smSetParameters + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => Bool -> UInt8 -> SMIOCapabilities -> m () +smSetParameters = curry3 $ xCmd BgMsgCR BgBlue BgClsSecurityManager 0x03 + +smWhitelistBonds + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => m (BGResult, UInt8) +smWhitelistBonds = xCmd BgMsgCR BgBlue BgClsSecurityManager 0x07 () + +evtSmBondingFail + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt8 -> BGResult -> IO Bool) -> m ThreadId +evtSmBondingFail + = registerEventHandler BgMsgEvent BgBlue BgClsSecurityManager 0x01 . uncurry + +evtSmBondStatus + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt8 -> UInt8 -> Bool -> UInt8 -> IO Bool) -> m ThreadId +evtSmBondStatus + = registerEventHandler BgMsgEvent BgBlue BgClsSecurityManager 0x04 . uncurry4 + +evtSmPasskeyDisplay + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt8 -> UInt32 -> IO Bool) -> m ThreadId +evtSmPasskeyDisplay + = registerEventHandler BgMsgEvent BgBlue BgClsSecurityManager 0x02 . uncurry + +evtSmPasskeyRequest + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt8 -> IO Bool) -> m ThreadId +evtSmPasskeyRequest + = registerEventHandler BgMsgEvent BgBlue BgClsSecurityManager 0x03 + +----------------------------------------------------------------------- +-- System +----------------------------------------------------------------------- + +systemAddressGet + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => m BdAddr +systemAddressGet = xCmd BgMsgCR BgBlue BgClsSystem 0x02 () + +systemAesDecrypt + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8Array -> m UInt8Array +systemAesDecrypt = xCmd BgMsgCR BgBlue BgClsSystem 0x11 + +systemAesEncrypt + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8Array -> m UInt8Array +systemAesEncrypt = xCmd BgMsgCR BgBlue BgClsSystem 0x10 + +systemAesSetkey + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8Array -> m () +systemAesSetkey = xCmd BgMsgCR BgBlue BgClsSystem 0x0f + +systemDelayReset + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => RebootMode -> UInt16 -> m () +systemDelayReset = curry $ xCmd' BgMsgCR BgBlue BgClsSystem 0x14 + +systemEndpointRx + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8 -> m (BGResult, UInt8Array) +systemEndpointRx = curry $ xCmd BgMsgCR BgBlue BgClsSystem 0x0d + +systemEndpointSetWatermarks + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8 -> UInt8 -> m BGResult +systemEndpointSetWatermarks = curry3 $ xCmd BgMsgCR BgBlue BgClsSystem 0x0e + +systemEndpointTx + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8Array -> m BGResult +systemEndpointTx = curry $ xCmd BgMsgCR BgBlue BgClsSystem 0x09 + +systemGetBootloaderCrc + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => m UInt16 +systemGetBootloaderCrc = xCmd BgMsgCR BgBlue BgClsSystem 0x13 () + +systemGetConnections + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => m UInt8 +systemGetConnections = xCmd BgMsgCR BgBlue BgClsSystem 0x06 () + +systemGetCounters + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => m (UInt8, UInt8, UInt8, UInt8, UInt8) +systemGetCounters = xCmd BgMsgCR BgBlue BgClsSystem 0x05 () + +systemGetInfo + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => m (UInt16, UInt16, UInt16, UInt16, UInt16, UInt8, UInt8) +systemGetInfo = xCmd BgMsgCR BgBlue BgClsSystem 0x08 () + +systemHello + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => m () +systemHello = xCmd BgMsgCR BgBlue BgClsSystem 0x01 () + +systemReset + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasDebug env) + => RebootMode -> m () +systemReset = xCmd' BgMsgCR BgBlue BgClsSystem 0x01 + +systemUsbEnumerationStatusGet + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => m (BGResult, Bool) +systemUsbEnumerationStatusGet = xCmd BgMsgCR BgBlue BgClsSystem 0x12 () + +systemWhitelistAppend + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => BdAddr -> GapAddressType -> m BGResult +systemWhitelistAppend = curry $ xCmd BgMsgCR BgBlue BgClsSystem 0x0a + +systemWhitelistClear + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => m () +systemWhitelistClear = xCmd BgMsgCR BgBlue BgClsSystem 0x0c () + +systemWhitelistRemove + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => BdAddr -> GapAddressType -> m BGResult +systemWhitelistRemove = curry $ xCmd BgMsgCR BgBlue BgClsSystem 0x0b + +evtSystemBoot + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt16 -> UInt16 -> UInt16 -> UInt16 -> UInt16 -> UInt8 -> UInt8 -> IO Bool) -> m ThreadId +evtSystemBoot + = registerEventHandler BgMsgEvent BgBlue BgClsSystem 0x00 . uncurry7 + +evtSystemEndpointWatermarkRx + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt8 -> UInt8 -> IO Bool) -> m ThreadId +evtSystemEndpointWatermarkRx + = registerEventHandler BgMsgEvent BgBlue BgClsSystem 0x02 . uncurry + +evtSystemEndpointWatermarkTx + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt8 -> UInt8 -> IO Bool) -> m ThreadId +evtSystemEndpointWatermarkTx + = registerEventHandler BgMsgEvent BgBlue BgClsSystem 0x03 . uncurry + +evtSystemNoLicenseKey + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (() -> IO Bool) -> m ThreadId +evtSystemNoLicenseKey + = registerEventHandler BgMsgEvent BgBlue BgClsSystem 0x05 + +evtSystemProtocolError + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (BGResult -> IO Bool) -> m ThreadId +evtSystemProtocolError + = registerEventHandler BgMsgEvent BgBlue BgClsSystem 0x06 + +evtSystemScriptFailure + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt16 -> BGResult -> IO Bool) -> m ThreadId +evtSystemScriptFailure + = registerEventHandler BgMsgEvent BgBlue BgClsSystem 0x04 . uncurry + +evtSystemUsbEnumerated + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (Bool -> IO Bool) -> m ThreadId +evtSystemUsbEnumerated + = registerEventHandler BgMsgEvent BgBlue BgClsSystem 0x07 + +----------------------------------------------------------------------- +-- Testing +----------------------------------------------------------------------- + +testChannelMode + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> m () +testChannelMode = xCmd BgMsgCR BgBlue BgClsTest 0x06 + +testGetChannelMap + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => m UInt8Array +testGetChannelMap = xCmd BgMsgCR BgBlue BgClsTest 0x04 () + +testPhyEnd + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => m UInt16 +testPhyEnd = xCmd BgMsgCR BgBlue BgClsTest 0x02 () + +testPhyRx + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> m () +testPhyRx = xCmd BgMsgCR BgBlue BgClsTest 0x01 + +testPhyTx + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8 -> UInt8 -> UInt8 -> m () +testPhyTx = curry3 $ xCmd BgMsgCR BgBlue BgClsTest 0x00 + +----------------------------------------------------------------------- +-- Device Firmware Upgrade +----------------------------------------------------------------------- + +dfuFlashSetAddress + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt32 -> m BGResult +dfuFlashSetAddress = xCmd BgMsgCR BgBlue BgClsDfu 0x01 + +dfuFlashUpload + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => UInt8Array -> m BGResult +dfuFlashUpload = xCmd BgMsgCR BgBlue BgClsDfu 0x02 + +dfuFlashUploadFinish + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => m BGResult +dfuFlashUploadFinish = xCmd BgMsgCR BgBlue BgClsDfu 0x03 () + +dfuReset + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => Bool -> m () +dfuReset = xCmd' BgMsgCR BgBlue BgClsDfu 0x00 + +evtDfuBoot + :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env) + => (UInt32 -> IO Bool) -> m ThreadId +evtDfuBoot = registerEventHandler BgMsgEvent BgBlue BgClsDfu 0x00 diff --git a/src/BGLib/Types.hs b/src/BGLib/Types.hs new file mode 100644 --- /dev/null +++ b/src/BGLib/Types.hs @@ -0,0 +1,957 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module BGLib.Types + ( Int8 + , UInt8 + , UInt16 + , UInt32 + , UInt8Array(..) + , toUInt8Array + , BdAddr(..) + , BgMessageType(..) + , BgTecnologyType(..) + , BgCommandClass(..) + , BgPacketHeader(..) + , bgHeaderMatches + , BgPayload + , fromBgPayload + , toBgPayload + , BgPacket(..) + , HasSerialPort(..) + , askSerialPort + , HasBGChan(..) + , askBGChan + , askDupBGChan + , HasDebug(..) + , askDebug + , bsShowHex + , RebootMode(..) + , AttributeValueType(..) + , AttributeChangeReason(..) + , fASNotify + , fASIndicate + , fCConnected + , fCEncrypted + , fCCompleted + , fCParametersChanged + , fADLimitedDiscoverable + , fADGeneralDiscoverable + , fADBREDRNotSupported + , fADSimultaneousLEBREDRCtrl + , fADSimultaneousLEBREDRHost + , fADMask + , GapAdvType(..) + , GapAdvPolicy(..) + , GapAddressType(..) + , GapConnectableMode(..) + , GapDiscoverableMode(..) + , GapDiscoverMode(..) + , GSPScanHeaderFlag(..) + , GapScanPolicy(..) + , fBKLTK + , fBKAddrPublic + , fBKAddrStatic + , fBKIRK + , fBKEDIVRAND + , fBKCSRK + , fBKMasterId + , SMIOCapabilities(..) + , SystemEndpoint(..) + , BGResult(..) + ) where + +import Control.Concurrent.STM.TChan +import Control.Monad.Reader +import Control.Concurrent.STM +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.Bits +import qualified Data.ByteString as BSS +import qualified Data.Int as I +import Data.String +import qualified Data.Word as W +import Numeric +import System.Hardware.Serialport +import Text.Printf + +-- int8 1 byte Signed 8-bit integer +type Int8 = I.Int8 + +-- uint8 1 byte Unsigned 8-bit integer +type UInt8 = W.Word8 + +-- uint16 2 bytes Unsigned 16-bit integer +type UInt16 = W.Word16 + +-- uint32 4 bytes Unsigned 32-bit integer +type UInt32 = W.Word32 + +-- uint8array byte array, first byte is array size +newtype UInt8Array = UInt8Array { fromUInt8Array :: BSS.ByteString } deriving (Show, IsString) + +toUInt8Array :: BSS.ByteString -> UInt8Array +toUInt8Array s = UInt8Array s + +instance Binary UInt8Array where + put UInt8Array{..} = do + putWord8 $ fromIntegral $ BSS.length fromUInt8Array + putByteString fromUInt8Array + + get = do + l <- getWord8 + bs <- getByteString (fromIntegral l) + return $ UInt8Array bs + +-- bd_addr Bluetooth address in little endian format +newtype BdAddr = BdAddr { fromBdAddr :: (UInt8, UInt8, UInt8, UInt8, UInt8, UInt8) } + +instance Show BdAddr where + show (BdAddr (_5, _4, _3, _2, _1, _0)) = printf "%02x:%02x:%02x:%02x:%02x:%02x" _0 _1 _2 _3 _4 _5 + +instance Binary BdAddr where + put BdAddr{..} = put fromBdAddr + get = get >>= return . BdAddr + +data BgMessageType = BgMsgCR | BgMsgEvent deriving (Eq, Show, Enum) + +data BgTecnologyType = BgBlue | BgWifi deriving (Eq, Show, Enum) + +data BgCommandClass + = BgClsSystem + | BgClsPersistentStore + | BgClsAttributeDatabase + | BgClsConnection + | BgClsAttributeClient + | BgClsSecurityManager + | BgClsGenericAccessProfile + | BgClsHardware + | BgClsTest + | BgClsDfu + deriving (Eq, Show, Enum) + +data BgPacketHeader = BgPacketHeader + { bghMessageType :: BgMessageType + , bghTechnologyType :: BgTecnologyType + , bghLength :: UInt16 -- Only 11 bits actually + , bghCommandClass :: BgCommandClass + , bghCommandId :: UInt8 + } deriving Show + +instance Binary BgPacketHeader where + put BgPacketHeader{..} = do + putWord8 + $ fromIntegral (fromEnum bghMessageType `shift` 7) + .|. fromIntegral (fromEnum bghTechnologyType `shift` 3) + .|. fromIntegral ((bghLength .&. 0x0700) `shift` (-8)) + putWord8 $ fromIntegral $ bghLength .&. 0x00ff + putWord8 $ fromIntegral $ fromEnum bghCommandClass + putWord8 $ bghCommandId + + get = do + oct0 <- getWord8 + lLow <- getWord8 + clsId <- getWord8 + cmdId <- getWord8 + + let lHigh = oct0 .&. 0x07 + + let bghMessageType = toEnum $ fromIntegral $ oct0 `shift` (-7) + let bghTechnologyType = toEnum $ fromIntegral $ (oct0 `shift` (-3)) .&. 0x0f + let bghLength = (fromIntegral lHigh `shift` 8) + (fromIntegral lLow) :: UInt16 + let bghCommandClass = toEnum $ fromIntegral clsId + let bghCommandId = cmdId + + return $ BgPacketHeader{..} + +bgHeaderMatches :: BgMessageType -> BgTecnologyType -> BgCommandClass -> UInt8 -> BgPacketHeader -> Bool +bgHeaderMatches mt tt cc cid BgPacketHeader{..} + = mt == bghMessageType + && tt == bghTechnologyType + && cc == bghCommandClass + && cid == bghCommandId + +newtype BgPayload = BgPayload { fromBgPayload :: BSS.ByteString } + +toBgPayload :: BSS.ByteString -> BgPayload +toBgPayload = BgPayload + +instance Show BgPayload where + show = bsShowHex . fromBgPayload + +data BgPacket = BgPacket + { bgpHeader :: BgPacketHeader + , bgpPayload :: BgPayload + } deriving Show + +instance Binary BgPacket where + put BgPacket{..} = do + put bgpHeader + putByteString $ fromBgPayload bgpPayload + + get = do + bgpHeader@BgPacketHeader{..} <- get + bgpPayload <- toBgPayload <$> getByteString (fromIntegral bghLength) + return BgPacket{..} + +class HasSerialPort env where + getSerialPort :: env -> SerialPort + +askSerialPort :: (MonadReader env m, HasSerialPort env) => m SerialPort +askSerialPort = getSerialPort <$> ask + +class HasBGChan env where + getBGChan :: env -> TChan BgPacket + +askBGChan :: (MonadReader env m, HasBGChan env) => m (TChan BgPacket) +askBGChan = getBGChan <$> ask + +askDupBGChan :: (MonadIO m, MonadReader env m, HasBGChan env) => m (TChan BgPacket) +askDupBGChan = do + chan <- getBGChan <$> ask + liftIO $ atomically $ dupTChan chan + +class HasDebug env where + getDebug :: env -> Bool + +askDebug :: (MonadReader env m, HasDebug env) => m (Bool) +askDebug = getDebug <$> ask + +bsShowHex :: BSS.ByteString -> String +bsShowHex = concatMap (\n -> ' ' : showHex n "") . BSS.unpack + +data RebootMode + -- Reboot into application + = RebootNormal + -- Reboot into DFU mode + | RebootDfu + deriving (Show, Enum) + +instance Binary RebootMode where + put m = do + putWord8 $ fromIntegral $ fromEnum m + get = do + toEnum . fromIntegral <$> getWord8 + +data AttributeValueType + -- 0: Value was read + = AVTRead + -- 1: Value was notified + | AVTNotify + -- 2: Value was indicated + | AVTIndicate + -- 3: Value was read + | AVTReadByType + -- 4: Value was part of a long attribute + | AVTReadBlob + -- 5: Value was indicated and the remote device is + -- waiting for a confirmation + | AVTIndicateRsqReq + deriving (Show, Enum) + +instance Binary AttributeValueType where + put m = do + putWord8 $ fromIntegral $ fromEnum m + get = do + toEnum . fromIntegral <$> getWord8 + +data AttributeChangeReason + -- 0: Value was written by remote device using write request + = ACRWriteRequest + -- 1: Value was written by remote device using write command + | ACRWriteCommand + -- 2: Local attribute value was written by the + -- remote device, but the Bluetooth Smart + -- stack is waiting for the write to be + -- confirmed by the application. + -- User Write Response command should + -- be used to send the confirmation. + | ACRWriteRequestUser + deriving (Show, Enum) + +instance Binary AttributeChangeReason where + put m = do + putWord8 $ fromIntegral $ fromEnum m + get = do + toEnum . fromIntegral <$> getWord8 + +-- Attribute status flags + +-- Notifications are enabled +fASNotify :: UInt8 +fASNotify = 0x01 + +-- Indications are enabled +fASIndicate :: UInt8 +fASIndicate = 0x02 + +-- Connection status flags + +-- This status flag tells the connection exists to a remote device. +fCConnected :: UInt8 +fCConnected = 0x01 + +-- This flag tells the connection is encrypted. +fCEncrypted :: UInt8 +fCEncrypted = 0x02 + +-- Connection completed flag, which is used to tell a new connection +-- has been created. +fCCompleted :: UInt8 +fCCompleted = 0x04 + +-- This flag tells that connection parameters have changed and. It is +-- set when connection parameters have changed due to a link layer +-- operation. +fCParametersChanged :: UInt8 +fCParametersChanged = 0x08 + +-- 0x01 GAP_AD_FLAG_LIMITED_DISCOVERABLE Limited discoverability +fADLimitedDiscoverable :: UInt8 +fADLimitedDiscoverable = 0x01 + +-- 0x02 GAP_AD_FLAG_GENERAL_DISCOVERABLE General discoverability +fADGeneralDiscoverable :: UInt8 +fADGeneralDiscoverable = 0x02 + +-- 0x04 GAP_AD_FLAG_BREDR_NOT_SUPPORTED BR/EDR not supported +fADBREDRNotSupported :: UInt8 +fADBREDRNotSupported = 0x04 + +-- 0x10 GAP_AD_FLAG_SIMULTANEOUS_LEBREDR_CTRL BR/EDR controller +fADSimultaneousLEBREDRCtrl :: UInt8 +fADSimultaneousLEBREDRCtrl = 0x10 + +-- 0x20 GAP_AD_FLAG_SIMULTANEOUS_LEBREDR_HOST BE/EDR host +fADSimultaneousLEBREDRHost :: UInt8 +fADSimultaneousLEBREDRHost = 0x20 + +-- 0x1f GAP_AD_FLAG_MASK - +fADMask :: UInt8 +fADMask = 0x1f + +data GapAdvType + = GATNone + | GATFlags + | GATServices16bitMore + | GATServices16bitAll + | GATServices32bitMore + | GATServices32bitAll + | GATServices128bitMore + | GATServices128bitAll + | GATLocalnameShort + | GATLocalnameComplete + | GATTxPower + deriving (Show, Enum) + +instance Binary GapAdvType where + put m = do + putWord8 $ fromIntegral $ fromEnum m + get = do + toEnum . fromIntegral <$> getWord8 + +data GapAdvPolicy + -- Respond to scan requests from any master, allow connection + -- from any master (default) + = GAPAll + -- Respond to scan requests from whitelist only, allow connection + -- from any + | GAPWhitelistScan + -- Respond to scan requests from any, allow connection from + -- whitelist only + | GAPWhitelistConnect + -- Respond to scan requests from whitelist only, allow connection + -- from whitelist only + | GAPWhitelistAll + deriving (Show, Enum) + +instance Binary GapAdvPolicy where + put m = do + putWord8 $ fromIntegral $ fromEnum m + get = do + toEnum . fromIntegral <$> getWord8 + + +data GapAddressType + = GATPublic + | GATRandom + deriving (Show, Enum) + +instance Binary GapAddressType where + put m = do + putWord8 $ fromIntegral $ fromEnum m + get = do + toEnum . fromIntegral <$> getWord8 + +data GapConnectableMode + -- Not connectable + = GCMNonConnectable + -- Directed Connectable + | GCMDirectedConnectable + -- Undirected connectable + | GCMUndirectedConnectable + -- Same as non-connectable, but also supports ADV_SCAN_IND + -- packets. Device accepts scan requests (active scanning) but is + -- not connectable. + | GCMScannableNonConnectable + deriving (Show, Enum) + +instance Binary GapConnectableMode where + put m = do + putWord8 $ fromIntegral $ fromEnum m + get = do + toEnum . fromIntegral <$> getWord8 + + +data GapDiscoverableMode + -- Non-discoverable mode: the LE Limited Discoverable Mode and the + -- LE General Discoverable Mode bits are NOT set in the Flags AD + -- type. A master can still connect to the advertising slave in this mode. + = GDMNonDiscoverable + -- 1 gap_limited_discoverable Discoverable using limited scanning mode: the advertisement + -- packets will carry the LE Limited Discoverable Mode bit set in the + -- Flags AD type. + | GDMLimitedDiscoverable + -- 2 gap_general_discoverable Discoverable using general scanning mode: the advertisement + -- packets will carry the LE General Discoverable Mode bit set in the + -- Flags AD type. + | GDMGeneralDiscoverable + -- 3 gap_broadcast Same as gap_non_discoverable above. + | GDMBroadcast + -- 4 gap_user_data In this advertisement the advertisement and scan response data + -- defined by user will be used. The user is responsible of building the + -- advertisement data so that it also contains the appropriate desired + -- Flags AD type. + | GDMUserData + -- 0x80 gap_enhanced_broadcasting When turning the most highest bit on in GAP discoverable mode, the + -- remote devices that send scan request packets to the advertiser are + -- reported back to the application through Scan Response event. + -- This is so called Enhanced Broadcasting mode. + | GDMEnhancedBroadcasting + deriving (Show, Enum) + +instance Binary GapDiscoverableMode where + put m = do + putWord8$ case m of + GDMEnhancedBroadcasting -> 0x80 + _ -> fromIntegral $ fromEnum m + get = do + x <- getWord8 + return $ case x of + 5 -> GDMEnhancedBroadcasting + _ -> toEnum $ fromIntegral x + +data GapDiscoverMode + -- 0: Discover only limited discoverable devices, that is, Slaves which have the + -- LE Limited Discoverable Mode bit set in the Flags AD type of their + -- advertisement packets. + = GapDiscoverLimited + -- Discover limited and generic discoverable devices, that is, Slaves which + -- have the LE Limited Discoverable Mode or the LE General Discoverable + -- Mode bit set in the Flags AD type of their advertisement packets. + | GapDiscoverGeneric + -- Discover all devices regardless of the Flags AD typ + | GapDiscoverOvservation + deriving (Show, Enum) + +instance Binary GapDiscoverMode where + put m = do + putWord16le $ fromIntegral $ fromEnum m + get = do + toEnum . fromIntegral <$> getWord16le + + +-- GAP Scan header flags +data GSPScanHeaderFlag + -- Connectable undirected advertising event + = GSHFAdvInd + -- Connectable directed advertising event + | GSHFAdvDirectInd + -- Non-connectable undirected advertising event + | GSHFAdvNonConnInd + -- Scanner wants information from Advertiser + | GSHFScanReq + -- Advertiser gives more information to Scanner + | GSHFScanRsp + -- Initiator wants to connect to Advertiser + | GSHFConnectReq + -- Non-connectable undirected advertising event + | GSHFAdvDiscoverInd + deriving (Show, Enum) + +instance Binary GSPScanHeaderFlag where + put m = do + putWord8 $ fromIntegral $ fromEnum m + get = do + toEnum . fromIntegral <$> getWord8 + +data GapScanPolicy + -- All advertisement Packets (default) + = GSPAll + -- Ignore advertisement packets from remote slaves not in the running + -- whitelist + | GSPWhitelist + deriving (Show, Enum) + +instance Binary GapScanPolicy where + put m = do + putWord8 $ fromIntegral $ fromEnum m + get = do + toEnum . fromIntegral <$> getWord8 + +-- SM Bonding Key flags + +-- LTK saved in master +fBKLTK :: UInt8 +fBKLTK = 0x01 + +-- Public Address +fBKAddrPublic :: UInt8 +fBKAddrPublic = 0x02 + +-- Static Address +fBKAddrStatic :: UInt8 +fBKAddrStatic = 0x04 + +-- Identity resolving key for resolvable private addresses +fBKIRK :: UInt8 +fBKIRK = 0x08 + +-- EDIV+RAND received from slave +fBKEDIVRAND :: UInt8 +fBKEDIVRAND = 0x10 + +-- Connection signature resolving key +fBKCSRK :: UInt8 +fBKCSRK = 0x20 + +-- EDIV+RAND sent to master +fBKMasterId :: UInt8 +fBKMasterId = 0x40 + +data SMIOCapabilities + -- Display Only + = SICDisplayOnly + -- Display with Yes/No-buttons + | SICDisplayYesNo + -- Keyboard Only + | SICKeyboardOnly + -- No Input and No Output + | SICNoIO + -- Display with Keyboard + | SICKeyboardDisplay + deriving (Enum, Show) + +instance Binary SMIOCapabilities where + put m = do + putWord8 $ fromIntegral $ fromEnum m + get = do + toEnum . fromIntegral <$> getWord8 + +data SystemEndpoint + -- Command Parser + = SECommandParser + -- Radio Test + | SETest + -- BGScript (not used) + | SEScript + -- USB Interface + | SEUSB + -- USART 0 + | SEUART0 + -- USART 1 + | SEUART1 + deriving (Show, Enum) + +instance Binary SystemEndpoint where + put m = do + putWord8 $ fromIntegral $ fromEnum m + get = do + toEnum . fromIntegral <$> getWord8 + +-- Operation result +data BGResult + = BGRSuccess + -- Invalid Parameter (0x0180) + -- Command contained invalid parameter + | BGRInvalidParameter + + -- Device in Wrong State (0x0181) + -- Device is in wrong state to receive command + | BGRWrongState + + -- Out Of Memory (0x0182) + -- Device has run out of memory + | BGROutOfMemory + + -- Feature Not Implemented (0x0183) + -- Feature is not implemented + | BGRNotImplemented + + -- Command Not Recognized (0x0184) + -- Command was not recognized + | BGRNotRecognized + + -- Timeout (0x0185) + -- Command or Procedure failed due to timeout + | BGRTimeout + + -- Not Connected (0x0186) + -- Connection handle passed is to command is not a valid handle + | BGRNotConnected + + -- Flow (0x0187) + -- Command would cause either underflow or overflow error + | BGRFlow + + -- User Attribute (0x0188) + -- User attribute was accessed through API which is not supported + | BGRUserAttribute + + -- Invalid License Key (0x0189) + -- No valid license key found + | BGRInvalidLicenseKey + + -- Command Too Long (0x018A) + -- Command maximum length exceeded + | BGRCommandTooLong + + -- Out of Bonds (0x018B) + -- Bonding procedure can't be started because device has no space left for bond. + | BGROutOfBonds + + -- Script Overflow (0x018C) + -- Module was reset due to script stack overflow. + -- In BLE BGScript there is a script stack overflow detection mechanism. This solution resets module + -- when script stack overflow is detected. After next boot script failure event with specific error code is + -- generated right after system boot event. + -- This feature works only with BLE SDK version 1.7.0 or newer that support script stack overflow + -- detection mechanism. For this feature to work correctly update of bootloader is needed. + | BGRScriptOverflow + + -- Authentication Failure (0x0205) + -- Pairing or authentication failed due to incorrect results in the pairing or authentication procedure. This could be + -- due to an incorrect PIN or Link Key + | BGRAuthenticationFailure + + -- Pin or Key Missing (0x0206) + -- Pairing failed because of missing PIN, or authentication failed because of missing Key. + -- Silicon Labs + | BGRPinOrKeyMissing + + -- Memory Capacity Exceeded (0x0207) + -- Controller is out of memory. + | BGRMemoryCapacityExceeded + + -- Connection Timeout (0x0208) + -- Link supervision timeout has expired. + | BGRConnectionTimeout + + -- Connection Limit Exceeded (0x0209) + -- Controller is at limit of connections it can support. + | BGRConnectionLimitExceeded + + -- Command Disallowed (0x020C) + -- Command requested cannot be executed because the Controller is in a state where it cannot process this + -- command at this time. + | BGRCommandDisallowed + + -- Invalid Command Parameters (0x0212) + -- Command contained invalid parameters. + | BGRInvalidCommandParameters + + -- Remote User Terminated Connection (0x0213) + -- User on the remote device terminated the connection. + | BGRRemoteUserTerminatedConnection + + -- Connection Terminated by Local Host (0x0216) + -- Local device terminated the connection. + | BGRConnectionTErminagedByLocalHost + + -- LL Response Timeout (0x0222) + -- Connection terminated due to link-layer procedure timeout. + | BGRLLResponseTimeout + + -- LL Instant Passed (0x0228) + -- Received link-layer control packet where instant was in the past. + | BGRLLInstantPassed + + -- Controller Busy (0x023A) + -- Operation was rejected because the controller is busy and unable to process the request. + | BGRControllerBusy + + -- Unacceptable Connection Interval (0x023B) + -- The Unacceptable Connection Interval error code indicates that the remote device terminated the connection + -- because of an unacceptable connection interval. + | BGRUnacceptableConnectionInterval + + -- Directed Advertising Timeout (0x023C) + -- Directed advertising completed without a connection being created. + | BGRDirectedAdvertisingTimeout + + -- MIC Failure (0x023D) + -- Connection was terminated because the Message Integrity Check (MIC) failed on a received packet. + | BGRMICFailure + + -- Connection Failed to be Established (0x023E) + -- LL initiated a connection but the connection has failed to be established. Controller did not receive any packets + -- from remote end. + -- More in detail, an attempt to open a connection is made by the master by sending only one CONNECT_REQ , + -- after which the master immediately transitions to connected state (BT4.1 Vol 6 Part B 4.4.4). If the advertiser for + -- any reason (like interference) does not catch the packet it will just continue advertising, while the master + -- remains in a fast termination mode, where it will only send 6 packets before failing, independent of supervision + -- timeout (in fact, a master starts using normal supervision timeout only after it has received at least one packet + -- from slave.) If the master does not receive anything by the time its 6 packets are sent, connection establishment + -- will be considered failed and this error will be reported to the host or to the BGScript. In a busy environment it is + -- normal to see roughly 1-2% error rate when opening connections. + | BGRConnectionFailedToBeEstablised + + -- Passkey Entry Failed (0x0301) + -- The user input of passkey failed, for example, the user cancelled the operation + | BGRPasskeyEntryFailed + + -- OOB Data is not available (0x0302) + -- Out of Band data is not available for authentication + | BGROOBDataIsNotAvailable + + -- Authentication Requirements (0x0303) + -- The pairing procedure cannot be performed as authentication requirements cannot be met due to IO capabilities + -- of one or both devices + | BGRAuthenticationRequirements + + -- Confirm Value Failed (0x0304) + -- The confirm value does not match the calculated compare value + | BGRConfirmValueFailed + + -- Pairing Not Supported (0x0305) + -- Pairing is not supported by the device + | BGRPairingNotSupported + + -- Encryption Key Size (0x0306) + -- The resultant encryption key size is insufficient for the security requirements of this device + | BGREncryptionKeySize + + -- Command Not Supported (0x0307) + -- The SMP command received is not supported on this device + | BGRCommandNotSupported + + -- Unspecified Reason (0x0308) + -- Pairing failed due to an unspecified reason + | BGRUnspecifiedReason + + -- Repeated Attempts (0x0309) + -- Pairing or authentication procedure is disallowed because too little time has elapsed since last pairing request + -- or security request + | BGRRepeatedAttempts + + -- Invalid Parameters (0x030A) + -- The Invalid Parameters error code indicates: the command length is invalid or a parameter is outside of the + -- specified range. + | BGRInvalidParameters + + -- Invalid Handle (0x0401) + -- The attribute handle given was not valid on this server + | BGRInvalidHandle + + -- Read Not Permitted (0x0402) + -- The attribute cannot be read + | BGRReadNotPermitted + + -- Write Not Permitted (0x0403) + -- The attribute cannot be written + | BGRWriteNotPermitted + + -- Invalid PDU (0x0404) + -- The attribute PDU was invalid + | BGRInvalidPDU + + -- Insufficient Authentication (0x0405) + -- The attribute requires authentication before it can be read or written. + | BGRInsufficientAuthentication + + -- Request Not Supported (0x0406) + -- Attribute Server does not support the request received from the client. + | BGRRequestNotSupported + + -- Invalid Offset (0x0407) + -- Offset specified was past the end of the attribute + | BGRInvalidOffset + + -- Insufficient Authorization (0x0408) + -- The attribute requires authorization before it can be read or written. + | BGRInsufficientAuthorization + + -- Prepare Queue Full (0x0409) + -- Too many prepare writes have been queueud + | BGRPrepareQueueFull + + -- Attribute Not Found (0x040A) + -- No attribute found within the given attribute handle range. + | BGRAttributeNotFound + + -- Attribute Not Long (0x040B) + -- The attribute cannot be read or written using the Read Blob Request + | BGRAttributeNotLong + + -- Insufficient Encryption Key Size (0x040C) + -- The Encryption Key Size used for encrypting this link is insufficient. + | BGRInsufficientEncryptionKeySize + + -- Invalid Attribute Value Length (0x040D) + -- The attribute value length is invalid for the operation + | BGRInvalidAttributeValueLength + + -- Unlikely Error (0x040E) + -- The attribute request that was requested has encountered an error that was unlikely, and therefore could not be + -- completed as requested. + | BGRUnlikelyError + + -- Insufficient Encryption (0x040F) + -- The attribute requires encryption before it can be read or written. + | BGRInsufficientEncryption + + -- Unsupported Group Type (0x0410) + -- The attribute type is not a supported grouping attribute as defined by a higher layer specification. + | BGRUnsupportedGroupType + + -- Insufficient Resources (0x0411) + -- Insufficient Resources to complete the request + | BGRInsufficientResources + + -- Application Error Codes (0x0480) + -- Application error code defined by a higher layer specification. + -- The error code range 0x80-0x9F is reserved for application level errors. + | BGRApplicationErrorCode UInt8 + + -- And error code unknown by this library + | BGRUnknown UInt16 + deriving Show + +instance Binary BGResult where + put m = do + putWord16le $ case m of + BGRSuccess -> 0x0000 + BGRInvalidParameter -> 0x0180 + BGRWrongState -> 0x0181 + BGROutOfMemory -> 0x0182 + BGRNotImplemented -> 0x0183 + BGRNotRecognized -> 0x0184 + BGRTimeout -> 0x0185 + BGRNotConnected -> 0x0186 + BGRFlow -> 0x0187 + BGRUserAttribute -> 0x0188 + BGRInvalidLicenseKey -> 0x0189 + BGRCommandTooLong -> 0x018A + BGROutOfBonds -> 0x018B + BGRScriptOverflow -> 0x018C + BGRAuthenticationFailure -> 0x0205 + BGRPinOrKeyMissing -> 0x0206 + BGRMemoryCapacityExceeded -> 0x0207 + BGRConnectionTimeout -> 0x0208 + BGRConnectionLimitExceeded -> 0x0209 + BGRCommandDisallowed -> 0x020C + BGRInvalidCommandParameters -> 0x0212 + BGRRemoteUserTerminatedConnection -> 0x0213 + BGRConnectionTErminagedByLocalHost -> 0x0216 + BGRLLResponseTimeout -> 0x0222 + BGRLLInstantPassed -> 0x0228 + BGRControllerBusy -> 0x023A + BGRUnacceptableConnectionInterval -> 0x023B + BGRDirectedAdvertisingTimeout -> 0x023C + BGRMICFailure -> 0x023D + BGRConnectionFailedToBeEstablised -> 0x023E + BGRPasskeyEntryFailed -> 0x0301 + BGROOBDataIsNotAvailable -> 0x0302 + BGRAuthenticationRequirements -> 0x0303 + BGRConfirmValueFailed -> 0x0304 + BGRPairingNotSupported -> 0x0305 + BGREncryptionKeySize -> 0x0306 + BGRCommandNotSupported -> 0x0307 + BGRUnspecifiedReason -> 0x0308 + BGRRepeatedAttempts -> 0x0309 + BGRInvalidParameters -> 0x030A + BGRInvalidHandle -> 0x0401 + BGRReadNotPermitted -> 0x0402 + BGRWriteNotPermitted -> 0x0403 + BGRInvalidPDU -> 0x0404 + BGRInsufficientAuthentication -> 0x0405 + BGRRequestNotSupported -> 0x0406 + BGRInvalidOffset -> 0x0407 + BGRInsufficientAuthorization -> 0x0408 + BGRPrepareQueueFull -> 0x0409 + BGRAttributeNotFound -> 0x040A + BGRAttributeNotLong -> 0x040B + BGRInsufficientEncryptionKeySize -> 0x040C + BGRInvalidAttributeValueLength -> 0x040D + BGRUnlikelyError -> 0x040E + BGRInsufficientEncryption -> 0x040F + BGRUnsupportedGroupType -> 0x0410 + BGRInsufficientResources -> 0x0411 + BGRApplicationErrorCode errC -> (fromIntegral errC .&. 0x001f) .|. 0x0480 + BGRUnknown errC -> errC + + get = do + errC <- getWord16le + return $ case errC of + 0x0000 -> BGRSuccess + 0x0180 -> BGRInvalidParameter + 0x0181 -> BGRWrongState + 0x0182 -> BGROutOfMemory + 0x0183 -> BGRNotImplemented + 0x0184 -> BGRNotRecognized + 0x0185 -> BGRTimeout + 0x0186 -> BGRNotConnected + 0x0187 -> BGRFlow + 0x0188 -> BGRUserAttribute + 0x0189 -> BGRInvalidLicenseKey + 0x018A -> BGRCommandTooLong + 0x018B -> BGROutOfBonds + 0x018C -> BGRScriptOverflow + 0x0205 -> BGRAuthenticationFailure + 0x0206 -> BGRPinOrKeyMissing + 0x0207 -> BGRMemoryCapacityExceeded + 0x0208 -> BGRConnectionTimeout + 0x0209 -> BGRConnectionLimitExceeded + 0x020C -> BGRCommandDisallowed + 0x0212 -> BGRInvalidCommandParameters + 0x0213 -> BGRRemoteUserTerminatedConnection + 0x0216 -> BGRConnectionTErminagedByLocalHost + 0x0222 -> BGRLLResponseTimeout + 0x0228 -> BGRLLInstantPassed + 0x023A -> BGRControllerBusy + 0x023B -> BGRUnacceptableConnectionInterval + 0x023C -> BGRDirectedAdvertisingTimeout + 0x023D -> BGRMICFailure + 0x023E -> BGRConnectionFailedToBeEstablised + 0x0301 -> BGRPasskeyEntryFailed + 0x0302 -> BGROOBDataIsNotAvailable + 0x0303 -> BGRAuthenticationRequirements + 0x0304 -> BGRConfirmValueFailed + 0x0305 -> BGRPairingNotSupported + 0x0306 -> BGREncryptionKeySize + 0x0307 -> BGRCommandNotSupported + 0x0308 -> BGRUnspecifiedReason + 0x0309 -> BGRRepeatedAttempts + 0x030A -> BGRInvalidParameters + 0x0401 -> BGRInvalidHandle + 0x0402 -> BGRReadNotPermitted + 0x0403 -> BGRWriteNotPermitted + 0x0404 -> BGRInvalidPDU + 0x0405 -> BGRInsufficientAuthentication + 0x0406 -> BGRRequestNotSupported + 0x0407 -> BGRInvalidOffset + 0x0408 -> BGRInsufficientAuthorization + 0x0409 -> BGRPrepareQueueFull + 0x040A -> BGRAttributeNotFound + 0x040B -> BGRAttributeNotLong + 0x040C -> BGRInsufficientEncryptionKeySize + 0x040D -> BGRInvalidAttributeValueLength + 0x040E -> BGRUnlikelyError + 0x040F -> BGRInsufficientEncryption + 0x0410 -> BGRUnsupportedGroupType + 0x0411 -> BGRInsufficientResources + _ -> + if errC >= 0x0480 && errC <= 0x049f + then BGRApplicationErrorCode $ fromIntegral (errC .&. 0x1f) + else BGRUnknown errC