{-# 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
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
type Int8 = I.Int8
type UInt8 = W.Word8
type UInt16 = W.Word16
type UInt32 = W.Word32
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
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
, 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
= RebootNormal
| RebootDfu
deriving (Show, Enum)
instance Binary RebootMode where
put m = do
putWord8 $ fromIntegral $ fromEnum m
get = do
toEnum . fromIntegral <$> getWord8
data AttributeValueType
= AVTRead
| AVTNotify
| AVTIndicate
| AVTReadByType
| AVTReadBlob
| AVTIndicateRsqReq
deriving (Show, Enum)
instance Binary AttributeValueType where
put m = do
putWord8 $ fromIntegral $ fromEnum m
get = do
toEnum . fromIntegral <$> getWord8
data AttributeChangeReason
= ACRWriteRequest
| ACRWriteCommand
| ACRWriteRequestUser
deriving (Show, Enum)
instance Binary AttributeChangeReason where
put m = do
putWord8 $ fromIntegral $ fromEnum m
get = do
toEnum . fromIntegral <$> getWord8
fASNotify :: UInt8
fASNotify = 0x01
fASIndicate :: UInt8
fASIndicate = 0x02
fCConnected :: UInt8
fCConnected = 0x01
fCEncrypted :: UInt8
fCEncrypted = 0x02
fCCompleted :: UInt8
fCCompleted = 0x04
fCParametersChanged :: UInt8
fCParametersChanged = 0x08
fADLimitedDiscoverable :: UInt8
fADLimitedDiscoverable = 0x01
fADGeneralDiscoverable :: UInt8
fADGeneralDiscoverable = 0x02
fADBREDRNotSupported :: UInt8
fADBREDRNotSupported = 0x04
fADSimultaneousLEBREDRCtrl :: UInt8
fADSimultaneousLEBREDRCtrl = 0x10
fADSimultaneousLEBREDRHost :: UInt8
fADSimultaneousLEBREDRHost = 0x20
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
= GAPAll
| GAPWhitelistScan
| GAPWhitelistConnect
| 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
= GCMNonConnectable
| GCMDirectedConnectable
| GCMUndirectedConnectable
| GCMScannableNonConnectable
deriving (Show, Enum)
instance Binary GapConnectableMode where
put m = do
putWord8 $ fromIntegral $ fromEnum m
get = do
toEnum . fromIntegral <$> getWord8
data GapDiscoverableMode
= GDMNonDiscoverable
| GDMLimitedDiscoverable
| GDMGeneralDiscoverable
| GDMBroadcast
| GDMUserData
| 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
= GapDiscoverLimited
| GapDiscoverGeneric
| GapDiscoverOvservation
deriving (Show, Enum)
instance Binary GapDiscoverMode where
put m = do
putWord16le $ fromIntegral $ fromEnum m
get = do
toEnum . fromIntegral <$> getWord16le
data GSPScanHeaderFlag
= GSHFAdvInd
| GSHFAdvDirectInd
| GSHFAdvNonConnInd
| GSHFScanReq
| GSHFScanRsp
| GSHFConnectReq
| GSHFAdvDiscoverInd
deriving (Show, Enum)
instance Binary GSPScanHeaderFlag where
put m = do
putWord8 $ fromIntegral $ fromEnum m
get = do
toEnum . fromIntegral <$> getWord8
data GapScanPolicy
= GSPAll
| GSPWhitelist
deriving (Show, Enum)
instance Binary GapScanPolicy where
put m = do
putWord8 $ fromIntegral $ fromEnum m
get = do
toEnum . fromIntegral <$> getWord8
fBKLTK :: UInt8
fBKLTK = 0x01
fBKAddrPublic :: UInt8
fBKAddrPublic = 0x02
fBKAddrStatic :: UInt8
fBKAddrStatic = 0x04
fBKIRK :: UInt8
fBKIRK = 0x08
fBKEDIVRAND :: UInt8
fBKEDIVRAND = 0x10
fBKCSRK :: UInt8
fBKCSRK = 0x20
fBKMasterId :: UInt8
fBKMasterId = 0x40
data SMIOCapabilities
= SICDisplayOnly
| SICDisplayYesNo
| SICKeyboardOnly
| SICNoIO
| SICKeyboardDisplay
deriving (Enum, Show)
instance Binary SMIOCapabilities where
put m = do
putWord8 $ fromIntegral $ fromEnum m
get = do
toEnum . fromIntegral <$> getWord8
data SystemEndpoint
= SECommandParser
| SETest
| SEScript
| SEUSB
| SEUART0
| SEUART1
deriving (Show, Enum)
instance Binary SystemEndpoint where
put m = do
putWord8 $ fromIntegral $ fromEnum m
get = do
toEnum . fromIntegral <$> getWord8
data BGResult
= BGRSuccess
| BGRInvalidParameter
| BGRWrongState
| BGROutOfMemory
| BGRNotImplemented
| BGRNotRecognized
| BGRTimeout
| BGRNotConnected
| BGRFlow
| BGRUserAttribute
| BGRInvalidLicenseKey
| BGRCommandTooLong
| BGROutOfBonds
| BGRScriptOverflow
| BGRAuthenticationFailure
| BGRPinOrKeyMissing
| BGRMemoryCapacityExceeded
| BGRConnectionTimeout
| BGRConnectionLimitExceeded
| BGRCommandDisallowed
| BGRInvalidCommandParameters
| BGRRemoteUserTerminatedConnection
| BGRConnectionTErminagedByLocalHost
| BGRLLResponseTimeout
| BGRLLInstantPassed
| BGRControllerBusy
| BGRUnacceptableConnectionInterval
| BGRDirectedAdvertisingTimeout
| BGRMICFailure
| BGRConnectionFailedToBeEstablised
| BGRPasskeyEntryFailed
| BGROOBDataIsNotAvailable
| BGRAuthenticationRequirements
| BGRConfirmValueFailed
| BGRPairingNotSupported
| BGREncryptionKeySize
| BGRCommandNotSupported
| BGRUnspecifiedReason
| BGRRepeatedAttempts
| BGRInvalidParameters
| BGRInvalidHandle
| BGRReadNotPermitted
| BGRWriteNotPermitted
| BGRInvalidPDU
| BGRInsufficientAuthentication
| BGRRequestNotSupported
| BGRInvalidOffset
| BGRInsufficientAuthorization
| BGRPrepareQueueFull
| BGRAttributeNotFound
| BGRAttributeNotLong
| BGRInsufficientEncryptionKeySize
| BGRInvalidAttributeValueLength
| BGRUnlikelyError
| BGRInsufficientEncryption
| BGRUnsupportedGroupType
| BGRInsufficientResources
| BGRApplicationErrorCode UInt8
| 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