diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 375eec9..6847ed7 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -61,7 +61,13 @@ jobs: # hence the long timeout. macos-apk: runs-on: macos-15-intel - timeout-minutes: 120 + # 180 rather than 120: cross packages missing from + # nix-cache.jappie.me get built inside the TCG-emulated VM on + # every run (its store is ephemeral, the host cache cannot help), + # and the new uuid-types closure (PR #239) blew the 120-minute + # budget at exactly 2h00m (run 29272233710). Once the cache + # carries the closure this job returns to ~45 minutes. + timeout-minutes: 180 steps: - uses: actions/checkout@v4 - uses: cachix/install-nix-action@v31 diff --git a/Changelog.md b/Changelog.md index 2ee384e..97e4dd5 100644 --- a/Changelog.md +++ b/Changelog.md @@ -4,6 +4,25 @@ ### Added +- Scan results now carry the advertisement's service data and + manufacturer data (issue #238): `BleScanResult` gained + `bsrAdvertisement :: Either BleAdvertisementWithErrors + BleAdvertisement` (the Left carries every defect found alongside + the salvaged partial advertisement, since AD structures are + independent), parsed by the new `Hatter.BleAdvertisement` + module (re-exported from `Hatter.Ble`) with `serviceDataForUuid` + for keyed lookup; service data is keyed by the binary `UUID` from + `uuid-types` (constants build with the total `fromWords`), so + platform case differences are unrepresentable. Malformed advertisements report + every defect with its byte offset instead of being silently + dropped, and the scan dispatch logs them while still delivering + the result. UUID rendering uses the `uuid-types` package (new + dependency, also in the cross builds). Android passes `ScanRecord.getBytes()` through + the bridge; iOS re-encodes CoreBluetooth's parsed dictionary into + the same AD structure format. This unblocks identifying devices + that only advertise service data (e.g. KBeacons' 0x2080) or + manufacturer data (iBeacon) without connecting to them. + - `Hatter.Ble` GATT operations, completing the core of issue #108 and unblocking the kbeacon OTA tool: `discoverBleServices`, `readBleCharacteristic`, `writeBleCharacteristic` (with or without diff --git a/android/java/me/jappie/hatter/HatterActivity.java b/android/java/me/jappie/hatter/HatterActivity.java index 31b7e87..5d095c4 100644 --- a/android/java/me/jappie/hatter/HatterActivity.java +++ b/android/java/me/jappie/hatter/HatterActivity.java @@ -81,7 +81,8 @@ public class HatterActivity extends Activity implements View.OnClickListener { private native void onLifecycleLowMemory(); private native void onPermissionResult(int requestCode, int statusCode); private native void onSecureStorageResult(int requestId, int statusCode, String value); - private native void onBleScanResult(String deviceName, String deviceAddress, int rssi); + private native void onBleScanResult(String deviceName, String deviceAddress, int rssi, + byte[] advertisement); private native void onBleConnectionEvent(int event); private native void onBleCharacteristicDiscovered(String serviceUuid, String characteristicUuid, @@ -309,8 +310,12 @@ public void onScanResult(int callbackType, ScanResult result) { String name = record != null ? record.getDeviceName() : null; String address = result.getDevice().getAddress(); int rssi = result.getRssi(); + // The raw AD structures (advertisement + scan response as + // received); Haskell parses service data and manufacturer + // data out of them, see Hatter.BleAdvertisement. + byte[] advertisement = record != null ? record.getBytes() : null; bleScannedDevices.put(address, result.getDevice()); - onBleScanResult(name, address, rssi); + onBleScanResult(name, address, rssi, advertisement); } }; diff --git a/cbits/ble_bridge_android.c b/cbits/ble_bridge_android.c index 7390eab..0f835e9 100644 --- a/cbits/ble_bridge_android.c +++ b/cbits/ble_bridge_android.c @@ -21,7 +21,8 @@ #define LOGE(...) __android_log_print(ANDROID_LOG_ERROR, LOG_TAG, __VA_ARGS__) /* Haskell FFI exports (dispatch results back to Haskell callbacks) */ -extern void haskellOnBleScanResult(void *ctx, const char *name, const char *address, int32_t rssi); +extern void haskellOnBleScanResult(void *ctx, const char *name, const char *address, int32_t rssi, + const uint8_t *advertisement, int32_t advertisement_length); extern void haskellOnBleConnectionEvent(void *ctx, int32_t event); extern void haskellOnBleCharacteristicDiscovered(void *ctx, const char *serviceUuid, const char *characteristicUuid, @@ -350,12 +351,15 @@ void setup_android_ble_bridge(JNIEnv *env, jobject activity, void *haskellCtx) /* ---- JNI callback from Java BLE scan result ---- */ JNIEXPORT void JNICALL -JNI_METHOD(onBleScanResult)(JNIEnv *env, jobject thiz, jstring jname, jstring jaddr, jint rssi) +JNI_METHOD(onBleScanResult)(JNIEnv *env, jobject thiz, jstring jname, jstring jaddr, jint rssi, + jbyteArray jadvertisement) { g_env = env; const char *cname = NULL; const char *caddr = NULL; + jbyte *advertisement = NULL; + jsize advertisement_length = 0; if (jname) { cname = (*env)->GetStringUTFChars(env, jname, NULL); @@ -363,10 +367,18 @@ JNI_METHOD(onBleScanResult)(JNIEnv *env, jobject thiz, jstring jname, jstring ja if (jaddr) { caddr = (*env)->GetStringUTFChars(env, jaddr, NULL); } + if (jadvertisement) { + advertisement_length = (*env)->GetArrayLength(env, jadvertisement); + advertisement = (*env)->GetByteArrayElements(env, jadvertisement, NULL); + } - LOGI("onBleScanResult(name=%s, addr=%s, rssi=%d)", cname ? cname : "(null)", caddr ? caddr : "(null)", rssi); - haskellOnBleScanResult(g_haskell_ctx, cname, caddr, (int32_t)rssi); + LOGI("onBleScanResult(name=%s, addr=%s, rssi=%d, advLen=%d)", cname ? cname : "(null)", caddr ? caddr : "(null)", rssi, (int)advertisement_length); + haskellOnBleScanResult(g_haskell_ctx, cname, caddr, (int32_t)rssi, + (const uint8_t *)advertisement, (int32_t)advertisement_length); + if (advertisement) { + (*env)->ReleaseByteArrayElements(env, jadvertisement, advertisement, JNI_ABORT); + } if (cname) { (*env)->ReleaseStringUTFChars(env, jname, cname); } diff --git a/cbits/jni_bridge.c b/cbits/jni_bridge.c index c7acc1d..877f169 100644 --- a/cbits/jni_bridge.c +++ b/cbits/jni_bridge.c @@ -99,7 +99,8 @@ extern void haskellOnUITextChange(void *ctx, int callbackId, const char *text); extern void haskellOnPermissionResult(void *ctx, int32_t requestId, int32_t statusCode); extern void haskellOnSecureStorageResult(void *ctx, int32_t requestId, int32_t statusCode, const char *value); -extern void haskellOnBleScanResult(void *ctx, const char *name, const char *address, int32_t rssi); +extern void haskellOnBleScanResult(void *ctx, const char *name, const char *address, int32_t rssi, + const uint8_t *advertisement, int32_t advertisement_length); extern void haskellOnDialogResult(void *ctx, int32_t requestId, int32_t actionCode); extern void haskellOnLocationUpdate(void *ctx, double lat, double lon, double alt, double acc); extern void haskellOnAuthSessionResult(void *ctx, int32_t requestId, diff --git a/hatter.cabal b/hatter.cabal index a126182..a781c20 100644 --- a/hatter.cabal +++ b/hatter.cabal @@ -102,6 +102,7 @@ library Hatter.Permission Hatter.SecureStorage Hatter.Ble + Hatter.BleAdvertisement Hatter.Dialog Hatter.Location Hatter.AuthSession @@ -120,7 +121,8 @@ library bytestring < 1, transformers < 0.7, time, - unwitch >= 3.0.0 && < 4 + unwitch >= 3.0.0 && < 4, + uuid-types >= 1.0.4 && < 2 c-sources: cbits/android_stubs.c cbits/platform_log.c @@ -253,4 +255,5 @@ test-suite unit bytestring, directory, filepath, - unwitch >= 3.0.0 && < 4 + unwitch >= 3.0.0 && < 4, + uuid-types >= 1.0.4 && < 2 diff --git a/include/Hatter.h b/include/Hatter.h index a07a629..83aac45 100644 --- a/include/Hatter.h +++ b/include/Hatter.h @@ -130,7 +130,8 @@ void haskellOnSecureStorageResult(void *ctx, int32_t requestId, * address: device address string. * rssi: received signal strength indicator. * ctx must be a pointer returned by haskellRunMain(). */ -void haskellOnBleScanResult(void *ctx, const char *name, const char *address, int32_t rssi); +void haskellOnBleScanResult(void *ctx, const char *name, const char *address, int32_t rssi, + const uint8_t *advertisement, int32_t advertisement_length); /* Dispatch a BLE connection event from native code back to Haskell. * event: one of the BLE_CONNECTION_* codes from BleBridge.h. diff --git a/ios/Hatter/BleBridgeIOS.m b/ios/Hatter/BleBridgeIOS.m index 232c97c..5261833 100644 --- a/ios/Hatter/BleBridgeIOS.m +++ b/ios/Hatter/BleBridgeIOS.m @@ -23,7 +23,8 @@ #define LOGE(fmt, ...) os_log_error(g_log, fmt, ##__VA_ARGS__) /* Haskell FFI exports (dispatch results back to Haskell callbacks) */ -extern void haskellOnBleScanResult(void *ctx, const char *name, const char *address, int32_t rssi); +extern void haskellOnBleScanResult(void *ctx, const char *name, const char *address, int32_t rssi, + const uint8_t *advertisement, int32_t advertisement_length); extern void haskellOnBleConnectionEvent(void *ctx, int32_t event); extern void haskellOnBleCharacteristicDiscovered(void *ctx, const char *serviceUuid, const char *characteristicUuid, @@ -94,6 +95,61 @@ - (void)centralManagerDidUpdateState:(CBCentralManager *)central { } } +/* Re-encode CoreBluetooth's parsed advertisement dictionary into the + * raw AD structure format (length : type : payload) that Android + * delivers as-is, so the Haskell side (Hatter.BleAdvertisement) has a + * single decoding path for both platforms. CoreBluetooth never + * exposes the original bytes, only parsed fields; the two fields + * Haskell surfaces are encoded back: service data (AD 0x16/0x20/0x21 + * by UUID width, UUID little-endian like on air) and manufacturer + * data (AD 0xFF, whose NSData already starts with the little-endian + * company id). */ +static NSData *encodeAdvertisementData(NSDictionary *advertisementData) +{ + NSMutableData *encoded = [NSMutableData data]; + + NSDictionary *serviceData = + advertisementData[CBAdvertisementDataServiceDataKey]; + for (CBUUID *uuid in serviceData) { + NSData *payload = serviceData[uuid]; + NSData *uuidBytes = uuid.data; /* big-endian */ + uint8_t adType; + if (uuidBytes.length == 2) { + adType = 0x16; + } else if (uuidBytes.length == 4) { + adType = 0x20; + } else if (uuidBytes.length == 16) { + adType = 0x21; + } else { + continue; + } + NSUInteger bodyLength = 1 + uuidBytes.length + payload.length; + if (bodyLength > 0xFF) { + continue; + } + uint8_t lengthByte = (uint8_t)bodyLength; + [encoded appendBytes:&lengthByte length:1]; + [encoded appendBytes:&adType length:1]; + const uint8_t *bigEndian = uuidBytes.bytes; + for (NSUInteger i = uuidBytes.length; i > 0; i--) { + [encoded appendBytes:&bigEndian[i - 1] length:1]; + } + [encoded appendData:payload]; + } + + NSData *manufacturerData = + advertisementData[CBAdvertisementDataManufacturerDataKey]; + if (manufacturerData.length >= 2 && manufacturerData.length + 1 <= 0xFF) { + uint8_t lengthByte = (uint8_t)(manufacturerData.length + 1); + uint8_t adType = 0xFF; + [encoded appendBytes:&lengthByte length:1]; + [encoded appendBytes:&adType length:1]; + [encoded appendData:manufacturerData]; + } + + return encoded; +} + - (void)centralManager:(CBCentralManager *)central didDiscoverPeripheral:(CBPeripheral *)peripheral advertisementData:(NSDictionary *)advertisementData @@ -104,9 +160,12 @@ - (void)centralManager:(CBCentralManager *)central const char *name = peripheral.name ? [peripheral.name UTF8String] : NULL; const char *address = [identifier UTF8String]; int32_t rssi = [RSSI intValue]; + NSData *advertisement = encodeAdvertisementData(advertisementData); dispatch_async(dispatch_get_main_queue(), ^{ - haskellOnBleScanResult(self.haskellCtx, name, address, rssi); + haskellOnBleScanResult(self.haskellCtx, name, address, rssi, + advertisement.length ? (const uint8_t *)advertisement.bytes : NULL, + (int32_t)advertisement.length); }); } diff --git a/nix/collect-deps.nix b/nix/collect-deps.nix index 879e4f1..b8684fb 100644 --- a/nix/collect-deps.nix +++ b/nix/collect-deps.nix @@ -46,13 +46,20 @@ in pkgs.runCommand "hatter-collected-deps" { for pkg in ${depsList}; do echo "Processing: $pkg" - # Copy .conf files, skipping benchmark/test sub-libraries + # Copy .conf files, skipping benchmark/test sub-libraries. + # Skip .confs already collected: a package can be listed twice + # (once through a consumer's resolved deps and once through + # hatterOwnDeps), and the first copy is read-only, so copying the + # same .conf again fails with "Permission denied". for conf in $(find "$pkg" -name "*.conf" -path "*/package.conf.d/*"); do LIB_NAME=$(grep '^lib-name:' "$conf" | sed 's/^lib-name: *//' || true) case "$LIB_NAME" in *benchmark*|*test*) echo " skip sub-lib: $LIB_NAME"; continue ;; esac - cp "$conf" $out/pkgdb/ + confName=$(basename "$conf") + if [ ! -f "$out/pkgdb/$confName" ]; then + cp "$conf" $out/pkgdb/ + fi done # Copy all non-profiling .a files from this package, skipping diff --git a/nix/cross-deps.nix b/nix/cross-deps.nix index 0a0570c..45f8614 100644 --- a/nix/cross-deps.nix +++ b/nix/cross-deps.nix @@ -293,8 +293,16 @@ WRAPPER hatterDep = if hatterSrc != null then [ crossHaskellPkgs.hatter ] else []; # Hatter's own non-boot dependencies — must be collected so hatter's - # .conf can resolve them (collect-deps doesn't follow propagatedBuildInputs). - hatterOwnDeps = [ crossHaskellPkgs.unwitch ]; + # .conf can resolve them (collect-deps doesn't follow + # propagatedBuildInputs), including uuid-types' transitive non-boot + # dependencies for the same reason. + hatterOwnDeps = [ + crossHaskellPkgs.unwitch + crossHaskellPkgs.uuid-types + crossHaskellPkgs.hashable + crossHaskellPkgs.random + crossHaskellPkgs.splitmix + ]; in import ./collect-deps.nix { inherit pkgs ghc ghcPkgCmd; diff --git a/nix/ios-deps.nix b/nix/ios-deps.nix index 7c14b7d..b6282d4 100644 --- a/nix/ios-deps.nix +++ b/nix/ios-deps.nix @@ -76,7 +76,13 @@ let # Hatter's own non-boot dependencies — always included so mkIOSLib's # raw GHC invocation can find them even without a consumer cabal file. - hatterOwnDeps = [ nativeHaskellPkgs.unwitch ]; + hatterOwnDeps = [ + nativeHaskellPkgs.unwitch + nativeHaskellPkgs.uuid-types + nativeHaskellPkgs.hashable + nativeHaskellPkgs.random + nativeHaskellPkgs.splitmix + ]; in import ./collect-deps.nix { inherit pkgs ghc ghcPkgCmd; diff --git a/src/Hatter.hs b/src/Hatter.hs index 5ca7c7e..cbc02cf 100644 --- a/src/Hatter.hs +++ b/src/Hatter.hs @@ -366,13 +366,15 @@ foreign export ccall haskellOnPermissionResult :: Ptr AppContext -> CInt -> CInt -- | Handle a BLE scan result from native code. Dispatches to the -- callback registered by 'Hatter.Ble.startBleScan'. -haskellOnBleScanResult :: Ptr AppContext -> CString -> CString -> CInt -> IO () -haskellOnBleScanResult ctxPtr cName cAddr cRssi = +haskellOnBleScanResult + :: Ptr AppContext -> CString -> CString -> CInt -> Ptr Word8 -> CInt -> IO () +haskellOnBleScanResult ctxPtr cName cAddr cRssi advPtr advLength = withExceptionHandler ctxPtr $ do appCtx <- derefAppContext ctxPtr - dispatchBleScanResult (acBleState appCtx) cName cAddr cRssi + dispatchBleScanResult (acBleState appCtx) cName cAddr cRssi advPtr advLength -foreign export ccall haskellOnBleScanResult :: Ptr AppContext -> CString -> CString -> CInt -> IO () +foreign export ccall haskellOnBleScanResult + :: Ptr AppContext -> CString -> CString -> CInt -> Ptr Word8 -> CInt -> IO () -- | Handle a BLE connection event from native code. Decodes the C -- event code here at the FFI boundary so 'dispatchBleConnectionEvent' diff --git a/src/Hatter/Ble.hs b/src/Hatter/Ble.hs index 2156eb8..91f75a3 100644 --- a/src/Hatter/Ble.hs +++ b/src/Hatter/Ble.hs @@ -24,10 +24,11 @@ module Hatter.Ble ( BleAdapterStatus(..) , BleScanResult(..) + , module Hatter.BleAdvertisement + , NormalizedBleUuid(..) , BleDeviceAddress(..) , BleServiceUuid(..) , BleCharacteristicUuid(..) - , NormalizedBleUuid(..) , BleCharacteristicKey(..) , BleCharacteristicValue(..) , BleMtu(..) @@ -80,10 +81,12 @@ import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.String (IsString) import Data.Text (Text, pack, toLower, unpack) +import Data.Word (Word8) import Foreign.C.String (CString, peekCString, withCString) import Foreign.C.Types (CInt(..)) import Foreign.Marshal.Utils (maybeWith) -import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Ptr (Ptr, castPtr, nullPtr) +import Hatter.BleAdvertisement import System.IO (hPutStrLn, stderr) import Unwitch.Convert.CInt qualified as CInt import Unwitch.Convert.Int qualified as Int @@ -158,6 +161,13 @@ data BleScanResult = BleScanResult { bsrDeviceName :: Text , bsrDeviceAddress :: BleDeviceAddress , bsrRssi :: Int + , bsrAdvertisement :: Either BleAdvertisementWithErrors BleAdvertisement + -- ^ Service data and manufacturer data broadcast in the + -- advertisement; a malformed advertisement delivers every defect + -- found alongside the salvaged partial advertisement, see + -- "Hatter.BleAdvertisement". 'dispatchBleScanResult' has already + -- logged the defects; they are passed on so applications can + -- also surface them. } deriving (Show, Eq) -- | A connection state change delivered by the platform for the @@ -590,8 +600,9 @@ requestBleMtu bleState mtu callback = -- registered Haskell callback. Called from the FFI entry point. -- If no scan is active (callback is 'Nothing'), the result is -- silently dropped. -dispatchBleScanResult :: BleState -> CString -> CString -> CInt -> IO () -dispatchBleScanResult bleState cName cAddr cRssi = do +dispatchBleScanResult + :: BleState -> CString -> CString -> CInt -> Ptr Word8 -> CInt -> IO () +dispatchBleScanResult bleState cName cAddr cRssi advPtr advLength = do maybeCallback <- readIORef (blesScanCallback bleState) case maybeCallback of Nothing -> pure () -- No active scan, drop result @@ -602,12 +613,25 @@ dispatchBleScanResult bleState cName cAddr cRssi = do addrStr <- if cAddr == nullPtr then pure "" else pack <$> peekCString cAddr - let scanResult = BleScanResult - { bsrDeviceName = nameStr - , bsrDeviceAddress = BleDeviceAddress addrStr - , bsrRssi = CInt.toInt cRssi - } - callback scanResult + advertisementBytes <- if advPtr == nullPtr || advLength <= 0 + then pure BS.empty + else BS.packCStringLen (castPtr advPtr, CInt.toInt advLength) + let parsedAdvertisement = parseBleAdvertisement advertisementBytes + -- Log defects loudly (what, why and where, including which + -- device sent them) but still deliver the scan result: a + -- garbled advertisement must never hide the device. + case parsedAdvertisement of + Left withErrors -> hPutStrLn stderr + ("dispatchBleScanResult: malformed advertisement from " + ++ unpack addrStr ++ ": " + ++ show (advertisementParseErrors withErrors)) + Right _ -> pure () + callback BleScanResult + { bsrDeviceName = nameStr + , bsrDeviceAddress = BleDeviceAddress addrStr + , bsrRssi = CInt.toInt cRssi + , bsrAdvertisement = parsedAdvertisement + } -- | Dispatch a BLE connection event from the platform back to the -- registered Haskell callback. The FFI entry point diff --git a/src/Hatter/BleAdvertisement.hs b/src/Hatter/BleAdvertisement.hs new file mode 100644 index 0000000..24eb522 --- /dev/null +++ b/src/Hatter/BleAdvertisement.hs @@ -0,0 +1,327 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Advertisement payloads carried by BLE scan results (issue #238): +-- service data and manufacturer data, the two fields devices use to +-- broadcast identity and state without a connection (Eddystone frames +-- live in service data, iBeacon in manufacturer data, KKM beacons in +-- both). +-- +-- The scan callback delivers the advertisement's raw AD structures +-- (@length : type : payload@, Bluetooth Core Specification Supplement +-- part A). Android hands them over exactly as received +-- (@ScanRecord.getBytes()@); iOS re-encodes CoreBluetooth's parsed +-- dictionary into the same format (see @BleBridgeIOS.m@), so this +-- parser is the single decoding path for both platforms. +module Hatter.BleAdvertisement + ( BleAdvertisement(..) + , BleAdvertisementWithErrors(..) + , UUID + , ManufacturerId(..) + , AdvertisementParseError(..) + , AdvertisementParseErrors(..) + , AdStructureOffset(..) + , AdStructureTruncation(..) + , ServiceDataTruncation(..) + , ManufacturerDataTruncation(..) + , emptyBleAdvertisement + , parseBleAdvertisement + , serviceDataForUuid + ) where + +import Data.Bits (shiftL, (.|.)) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.List.NonEmpty (NonEmpty(..)) +import Data.UUID.Types (UUID) +import Data.UUID.Types qualified as UUID +import Data.Word (Word8, Word16, Word32) +import Unwitch.Convert.Word8 qualified as Word8 + +-- | The advertisement fields a scan result carries beyond name, +-- address and RSSI. Service data is keyed by the full 128-bit 'UUID' +-- (16- and 32-bit UUIDs are expanded with the Bluetooth base UUID); +-- comparisons are on the binary value, so platform case differences +-- cannot matter. Manufacturer data is keyed by the 16-bit company +-- identifier. Entries keep their advertisement order. +data BleAdvertisement = BleAdvertisement + { advServiceData :: [(UUID, ByteString)] + , advManufacturerData :: [(ManufacturerId, ByteString)] + } deriving (Show, Eq) + +-- | A Bluetooth SIG company identifier, e.g. 0x004C (Apple) or +-- 0x0A53 (KKM). +newtype ManufacturerId = ManufacturerId { unManufacturerId :: Word16 } + deriving (Show, Eq, Ord) + +-- | Byte offset of an AD structure's length byte within the raw +-- advertisement: every parse error carries one, so a defect points +-- at the exact spot in the bytes. +newtype AdStructureOffset = AdStructureOffset { unAdStructureOffset :: Int } + deriving (Show, Eq) + +-- | One malformed AD structure: what failed, why, and where. Every +-- constructor wraps its own record, so the fields are reachable with +-- total record accessors. +data AdvertisementParseError + = -- | A structure declares more bytes than the advertisement still + -- holds, so it (and anything after it) cannot be framed. + AdStructureTruncated AdStructureTruncation + | -- | A service data structure too short to hold the UUID its AD + -- type promises. + ServiceDataUuidTruncated ServiceDataTruncation + | -- | A manufacturer data structure too short to hold the 2-byte + -- company identifier. + ManufacturerDataTooShort ManufacturerDataTruncation + deriving (Show, Eq) + +-- | Details of a structure that runs past the advertisement's end. +data AdStructureTruncation = AdStructureTruncation + { truncationOffset :: AdStructureOffset + -- ^ Where the structure starts. + , truncationDeclaredLength :: Int + -- ^ Length the structure declares. + , truncationRemainingBytes :: Int + -- ^ Bytes actually remaining after the length byte. + } deriving (Show, Eq) + +-- | Details of a service data structure shorter than its UUID. +data ServiceDataTruncation = ServiceDataTruncation + { serviceDataOffset :: AdStructureOffset + -- ^ Where the structure starts. + , serviceDataAdType :: Word8 + -- ^ The AD type (0x16, 0x20 or 0x21). + , serviceDataUuidWidth :: Int + -- ^ UUID width in bytes that AD type requires. + , serviceDataPayloadLength :: Int + -- ^ Bytes the structure actually carries after the type. + } deriving (Show, Eq) + +-- | Details of a manufacturer data structure shorter than the +-- company identifier. +data ManufacturerDataTruncation = ManufacturerDataTruncation + { manufacturerDataOffset :: AdStructureOffset + -- ^ Where the structure starts. + , manufacturerDataPayloadLength :: Int + -- ^ Bytes the structure actually carries after the type. + } deriving (Show, Eq) + +-- | Every defect found in one advertisement, in structure order. +newtype AdvertisementParseErrors = AdvertisementParseErrors + { unAdvertisementParseErrors :: NonEmpty AdvertisementParseError } + deriving (Show, Eq) + +-- | A parse that found defects, without discarding the salvage: AD +-- structures are independent, so the partial advertisement carries +-- every structure that still parsed. It is only empty when the very +-- first structure was truncated or every structure was defective. +data BleAdvertisementWithErrors = BleAdvertisementWithErrors + { partialAdvertisement :: BleAdvertisement + , advertisementParseErrors :: AdvertisementParseErrors + } deriving (Show, Eq) + +-- | An advertisement carrying no service or manufacturer data (also +-- what desktop's stubbed scan and payload-less advertisements parse +-- to). +emptyBleAdvertisement :: BleAdvertisement +emptyBleAdvertisement = BleAdvertisement + { advServiceData = [] + , advManufacturerData = [] + } + +-- | Parse raw AD structures. A zero length byte ends the data +-- cleanly: it is the value Android's @ScanRecord.getBytes()@ pads +-- the fixed advertisement buffer with, not a defect. +-- +-- Decision: malformed structures fail the parse with every defect +-- found, in the signature, instead of being silently dropped: per +-- we +-- want to know what fails, why and where (each error carries its +-- byte offset and the sizes involved), and the bytes come off the +-- air from arbitrary third-party devices, so defects WILL occur in +-- the field. The Left still carries the salvaged partial +-- advertisement ('BleAdvertisementWithErrors'): the link layer's CRC +-- already dropped radio corruption, so a defect here is a firmware +-- quirk in one structure and the well-formed rest remains +-- trustworthy (a beacon with one garbled structure must not lose its +-- valid service data). The scan dispatch in "Hatter.Ble" logs the +-- defects and still delivers the scan result, so a garbled +-- advertisement never hides the device that sent it. +parseBleAdvertisement :: ByteString -> Either BleAdvertisementWithErrors BleAdvertisement +parseBleAdvertisement bytes = + case parseAdStructuresFrom (AdStructureOffset 0) bytes of + (advertisement, []) -> Right advertisement + (advertisement, firstDefect : moreDefects) -> + Left (BleAdvertisementWithErrors advertisement + (AdvertisementParseErrors (firstDefect :| moreDefects))) + +-- | Walk the AD structures, accumulating both the parsed entries and +-- every defect, with the byte offset threaded through for the error +-- reports. A truncated structure ends the walk (framing is lost); a +-- defect inside a well-framed structure skips only that structure. +parseAdStructuresFrom + :: AdStructureOffset -> ByteString -> (BleAdvertisement, [AdvertisementParseError]) +parseAdStructuresFrom offset bytes = + case BS.uncons bytes of + Nothing -> (emptyBleAdvertisement, []) + Just (lengthByte, afterLength) -> + let structureLength = Word8.toInt lengthByte + in if + -- Zero length is the padding terminator. The check also + -- guards the recursion: a zero-length structure would drop + -- zero bytes and loop here forever. + | lengthByte == 0 -> (emptyBleAdvertisement, []) + | BS.length afterLength < structureLength -> + ( emptyBleAdvertisement + , [AdStructureTruncated (AdStructureTruncation offset structureLength + (BS.length afterLength))] + ) + | otherwise -> + let (structure, remainder) = BS.splitAt structureLength afterLength + (restAdvertisement, restDefects) = + parseAdStructuresFrom (nextStructureOffset offset structureLength) + remainder + in case BS.uncons structure of + -- Unreachable: structureLength >= 1 (the zero branch + -- above) with enough bytes remaining (the truncation + -- branch above), so the structure has its type byte. + Nothing -> (restAdvertisement, restDefects) + Just (adType, payload) -> + case addAdStructure offset adType payload restAdvertisement of + Right grown -> (grown, restDefects) + Left defect -> (restAdvertisement, defect : restDefects) + +-- | Fold one AD structure into the advertisement parsed from the +-- bytes after it, or say why it cannot be. Only the payload-bearing +-- types are kept: service data at each UUID width (0x16, 0x20, 0x21) +-- and manufacturer data (0xFF). Other AD types are legitimate +-- structures this module does not surface (names, flags, +-- service-class UUID lists), not defects: the platforms already +-- deliver the name and the rest carries no payload. +addAdStructure + :: AdStructureOffset + -> Word8 + -> ByteString + -> BleAdvertisement + -> Either AdvertisementParseError BleAdvertisement +addAdStructure offset adType payload advertisement = if + | adType == 0x16 -> addServiceData offset adType 2 payload advertisement + | adType == 0x20 -> addServiceData offset adType 4 payload advertisement + | adType == 0x21 -> addServiceData offset adType 16 payload advertisement + | adType == 0xFF -> addManufacturerData offset payload advertisement + | otherwise -> Right advertisement + +-- | Prepend one service data entry: a little-endian UUID of the given +-- byte width, then the payload. A structure too short to hold its +-- UUID is reported with the widths involved; the check IS +-- 'uuidFromLittleEndian' declining the short slice, so there is +-- exactly one place deciding what a valid UUID is. +addServiceData + :: AdStructureOffset + -> Word8 + -> Int + -> ByteString + -> BleAdvertisement + -> Either AdvertisementParseError BleAdvertisement +addServiceData offset adType uuidWidth payload advertisement = + let (uuidBytes, dataBytes) = BS.splitAt uuidWidth payload + in case uuidFromLittleEndian uuidWidth uuidBytes of + Nothing -> Left (ServiceDataUuidTruncated + (ServiceDataTruncation offset adType uuidWidth (BS.length payload))) + Just uuid -> Right advertisement { advServiceData = + (uuid, dataBytes) : advServiceData advertisement } + +-- | Prepend one manufacturer data entry: little-endian company +-- identifier, then the payload. A structure too short to hold the +-- company identifier is reported with its actual size. +addManufacturerData + :: AdStructureOffset + -> ByteString + -> BleAdvertisement + -> Either AdvertisementParseError BleAdvertisement +addManufacturerData offset payload advertisement = + case (BS.indexMaybe payload 0, BS.indexMaybe payload 1) of + (Just lowByte, Just highByte) -> + let companyId = Word8.toWord16 highByte * 256 + Word8.toWord16 lowByte + dataBytes = BS.drop 2 payload + in Right advertisement { advManufacturerData = + (ManufacturerId companyId, dataBytes) + : advManufacturerData advertisement } + (Just _, Nothing) -> Left (ManufacturerDataTooShort + (ManufacturerDataTruncation offset (BS.length payload))) + (Nothing, Just _) -> Left (ManufacturerDataTooShort + (ManufacturerDataTruncation offset (BS.length payload))) + (Nothing, Nothing) -> Left (ManufacturerDataTooShort + (ManufacturerDataTruncation offset (BS.length payload))) + +-- | The offset of the structure after the current one: past the +-- length byte and the bytes it declares. +nextStructureOffset :: AdStructureOffset -> Int -> AdStructureOffset +nextStructureOffset (AdStructureOffset offset) structureLength = + AdStructureOffset (offset + 1 + structureLength) + +-- | Look up a service data payload by its service 'UUID'. Constants +-- are best built with the total 'UUID.fromWords' (e.g. KKM's 0x2080 +-- is @fromWords 0x00002080 0x00001000 0x80000080 0x5F9B34FB@); +-- runtime strings parse via 'UUID.fromText'. +serviceDataForUuid :: UUID -> BleAdvertisement -> Maybe ByteString +serviceDataForUuid uuid advertisement = + lookup uuid (advServiceData advertisement) + +-- | Words 2 to 4 of the Bluetooth base UUID +-- (@xxxxxxxx-0000-1000-8000-00805F9B34FB@), which 16- and 32-bit +-- UUIDs are an alias into. +bluetoothBaseUuidWord2 :: Word32 +bluetoothBaseUuidWord2 = 0x00001000 + +bluetoothBaseUuidWord3 :: Word32 +bluetoothBaseUuidWord3 = 0x80000080 + +bluetoothBaseUuidWord4 :: Word32 +bluetoothBaseUuidWord4 = 0x5F9B34FB + +-- | The 'UUID' of an advertisement's service data structure, from +-- the declared byte width and the little-endian on-air slice. +-- Nothing when the slice does not have exactly the declared width, +-- or the width is not one of the on-air widths (2, 4 or 16): the +-- declared width MUST be checked against the slice, not inferred +-- from it, or a 128-bit structure truncated down to two bytes would +-- pass as a valid 16-bit UUID. This is how 'addServiceData' detects +-- a structure too short for its UUID. +uuidFromLittleEndian :: Int -> ByteString -> Maybe UUID +uuidFromLittleEndian declaredWidth uuidBytes = + let bigEndian = BS.reverse uuidBytes + in if BS.length bigEndian /= declaredWidth + then Nothing + else if declaredWidth == 16 + then uuidFromBigEndianBytes bigEndian + else if declaredWidth == 2 || declaredWidth == 4 + then fmap + (\value -> UUID.fromWords value + bluetoothBaseUuidWord2 + bluetoothBaseUuidWord3 + bluetoothBaseUuidWord4) + (word32BigEndianAt + (BS.replicate (4 - declaredWidth) 0x00 <> bigEndian) 0) + else Nothing + +-- | Build a 'UUID' from its 16 big-endian bytes; Nothing when fewer +-- bytes are available. +uuidFromBigEndianBytes :: ByteString -> Maybe UUID +uuidFromBigEndianBytes bigEndian = UUID.fromWords + <$> word32BigEndianAt bigEndian 0 + <*> word32BigEndianAt bigEndian 4 + <*> word32BigEndianAt bigEndian 8 + <*> word32BigEndianAt bigEndian 12 + +-- | Big-endian 32-bit word starting at the given offset; Nothing +-- when the four bytes are not all present. +word32BigEndianAt :: ByteString -> Int -> Maybe Word32 +word32BigEndianAt bytes offset = do + byte0 <- BS.indexMaybe bytes offset + byte1 <- BS.indexMaybe bytes (offset + 1) + byte2 <- BS.indexMaybe bytes (offset + 2) + byte3 <- BS.indexMaybe bytes (offset + 3) + pure (Word8.toWord32 byte0 `shiftL` 24 + .|. Word8.toWord32 byte1 `shiftL` 16 + .|. Word8.toWord32 byte2 `shiftL` 8 + .|. Word8.toWord32 byte3) diff --git a/test/BleDemoMain.hs b/test/BleDemoMain.hs index c8bae38..d5122a5 100644 --- a/test/BleDemoMain.hs +++ b/test/BleDemoMain.hs @@ -36,9 +36,12 @@ import Hatter , createAction ) import Hatter.AppContext (AppContext(..), derefAppContext) +import Data.UUID.Types qualified as UUID import Hatter.Ble ( BleState(..) , BleScanResult(..) + , BleAdvertisement(..) + , BleAdvertisementWithErrors(..) , BleDeviceAddress(..) , BleServiceUuid(..) , BleCharacteristicUuid(..) @@ -171,13 +174,28 @@ main = do writeIORef bleStateRef (Just (acBleState appCtx)) pure ctxPtr --- | Scan callback: log the result and remember its address as the --- Connect target. +-- | Scan callback: log the result (advertisement payloads on their +-- own line, as decimal byte lists like the GATT logs) and remember +-- its address as the Connect target. logAndRememberScanResult :: IORef (Maybe BleDeviceAddress) -> BleScanResult -> IO () logAndRememberScanResult lastAddressRef scanResult = do platformLog ("BLE scan result: " <> pack (show scanResult)) + case bsrAdvertisement scanResult of + Left withErrors -> do + platformLog ("BLE adv parse errors: " + <> pack (show (advertisementParseErrors withErrors))) + logServiceData (partialAdvertisement withErrors) + Right advertisement -> logServiceData advertisement writeIORef lastAddressRef (Just (bsrDeviceAddress scanResult)) +-- | Log every service data entry as a decimal byte list. +logServiceData :: BleAdvertisement -> IO () +logServiceData advertisement = + mapM_ (\(uuid, payload) -> + platformLog ("BLE adv service data: " <> UUID.toText uuid + <> "=" <> pack (show (BS.unpack payload)))) + (advServiceData advertisement) + -- | Address the Connect button targets: the last discovered device, -- or a placeholder when nothing was discovered yet (so the connect -- path is still exercised and fails visibly). diff --git a/test/Test/PlatformTests.hs b/test/Test/PlatformTests.hs index 749330c..63b1e43 100644 --- a/test/Test/PlatformTests.hs +++ b/test/Test/PlatformTests.hs @@ -21,10 +21,12 @@ import Test.Tasty.HUnit import Data.ByteString qualified as BS import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef') import Data.IntMap.Strict qualified as IntMap +import Data.UUID.Types qualified as UUID +import Data.List.NonEmpty (NonEmpty(..)) import Data.Text qualified as Text import Foreign.C.String (newCString) import Foreign.Marshal.Alloc (free) -import Foreign.Ptr (nullPtr) +import Foreign.Ptr (castPtr, nullPtr) import Hatter.AppContext (AppContext(..), freeAppContext, derefAppContext) import Hatter.AppContext (newAppContext) import Hatter.Widget (TextConfig(..), Widget(..)) @@ -65,6 +67,18 @@ import Hatter.Ble , BleGattError(..) , BleGattCompletion(..) , BleState(..) + , BleAdvertisement(..) + , ManufacturerId(..) + , AdvertisementParseError(..) + , AdvertisementParseErrors(..) + , BleAdvertisementWithErrors(..) + , AdStructureOffset(..) + , AdStructureTruncation(..) + , ServiceDataTruncation(..) + , ManufacturerDataTruncation(..) + , emptyBleAdvertisement + , parseBleAdvertisement + , serviceDataForUuid , newBleState , bleAdapterStatusFromInt , bleAdapterStatusToInt @@ -372,6 +386,11 @@ secureStorageTests ffiSecureStorageState = sequentialTestGroup "SecureStorage" A -- wired to a real FFI app context, so the connect test exercises the -- actual desktop C stub round trip (Haskell -> ble_connect -> -- haskellOnBleConnectionEvent -> callback). +-- | KKM's 0x2080 ext-data service UUID, built with the total +-- fromWords. +kkmExtDataUuid :: UUID.UUID +kkmExtDataUuid = UUID.fromWords 0x00002080 0x00001000 0x80000080 0x5F9B34FB + bleTests :: BleState -> TestTree bleTests ffiBleState = testGroup "BLE" [ testCase "bleAdapterStatusFromInt roundtrips all constructors" $ do @@ -418,7 +437,7 @@ bleTests ffiBleState = testGroup "BLE" startBleScan bleState (\result -> writeIORef ref (Just result)) cName <- newCString "TestDevice" cAddr <- newCString "AA:BB:CC:DD:EE:FF" - dispatchBleScanResult bleState cName cAddr (-42) + dispatchBleScanResult bleState cName cAddr (-42) nullPtr 0 free cName free cAddr result <- readIORef ref @@ -428,13 +447,14 @@ bleTests ffiBleState = testGroup "BLE" bsrDeviceName scanResult @?= "TestDevice" bsrDeviceAddress scanResult @?= BleDeviceAddress "AA:BB:CC:DD:EE:FF" bsrRssi scanResult @?= (-42) + bsrAdvertisement scanResult @?= Right emptyBleAdvertisement , testCase "dispatchBleScanResult with no active scan is no-op" $ do bleState <- newBleState cName <- newCString "Ignored" cAddr <- newCString "00:00:00:00:00:00" -- Should not throw or crash - dispatchBleScanResult bleState cName cAddr 0 + dispatchBleScanResult bleState cName cAddr 0 nullPtr 0 free cName free cAddr @@ -444,12 +464,12 @@ bleTests ffiBleState = testGroup "BLE" startBleScan bleState (\result -> modifyIORef' ref (++ [result])) cName1 <- newCString "Device1" cAddr1 <- newCString "11:22:33:44:55:66" - dispatchBleScanResult bleState cName1 cAddr1 (-50) + dispatchBleScanResult bleState cName1 cAddr1 (-50) nullPtr 0 free cName1 free cAddr1 cName2 <- newCString "Device2" cAddr2 <- newCString "AA:BB:CC:DD:EE:FF" - dispatchBleScanResult bleState cName2 cAddr2 (-70) + dispatchBleScanResult bleState cName2 cAddr2 (-70) nullPtr 0 free cName2 free cAddr2 results <- readIORef ref @@ -469,7 +489,7 @@ bleTests ffiBleState = testGroup "BLE" startBleScan bleState (\_ -> modifyIORef' refNew (+ 1)) cName <- newCString "Test" cAddr <- newCString "00:11:22:33:44:55" - dispatchBleScanResult bleState cName cAddr (-60) + dispatchBleScanResult bleState cName cAddr (-60) nullPtr 0 free cName free cAddr oldCount <- readIORef refOld @@ -482,7 +502,7 @@ bleTests ffiBleState = testGroup "BLE" ref <- newIORef (Nothing :: Maybe BleScanResult) startBleScan bleState (\result -> writeIORef ref (Just result)) cAddr <- newCString "FF:EE:DD:CC:BB:AA" - dispatchBleScanResult bleState nullPtr cAddr (-80) + dispatchBleScanResult bleState nullPtr cAddr (-80) nullPtr 0 free cAddr result <- readIORef ref case result of @@ -491,6 +511,165 @@ bleTests ffiBleState = testGroup "BLE" bsrDeviceName scanResult @?= "" bsrDeviceAddress scanResult @?= BleDeviceAddress "FF:EE:DD:CC:BB:AA" + , testCase "dispatchBleScanResult parses the advertisement bytes" $ do + bleState <- newBleState + ref <- newIORef (Nothing :: Maybe BleScanResult) + startBleScan bleState (\result -> writeIORef ref (Just result)) + cName <- newCString "KBPro-F4F5F6" + cAddr <- newCString "BC:57:29:F4:F5:F6" + -- flags, then 0x2080 service data carrying 55 00 01 F6. + let advBytes = BS.pack + [ 0x02, 0x01, 0x06 + , 0x07, 0x16, 0x80, 0x20, 0x55, 0x00, 0x01, 0xF6 + ] + BS.length advBytes @?= 11 + BS.useAsCStringLen advBytes (\(advPtr, _len) -> + dispatchBleScanResult bleState cName cAddr (-42) (castPtr advPtr) 11) + free cName + free cAddr + result <- readIORef ref + case result of + Nothing -> assertFailure "callback should have been fired" + Just scanResult -> + fmap (serviceDataForUuid kkmExtDataUuid) + (bsrAdvertisement scanResult) + @?= Right (Just (BS.pack [0x55, 0x00, 0x01, 0xF6])) + + , testCase "parseBleAdvertisement reads 16-bit service data" $ + parseBleAdvertisement + (BS.pack [0x02, 0x01, 0x06, 0x05, 0x16, 0xED, 0xFE, 0x2A, 0x63]) + @?= Right BleAdvertisement + { advServiceData = + [(UUID.fromWords 0x0000FEED 0x00001000 0x80000080 0x5F9B34FB, BS.pack [0x2A, 0x63])] + , advManufacturerData = [] + } + + , testCase "parseBleAdvertisement reads 128-bit service data" $ + -- UUID travels little-endian on air; this is + -- 50DB505C-8AC4-4738-8448-3B1D9CC09CC5 reversed, then one byte. + parseBleAdvertisement + (BS.pack + [ 0x12, 0x21 + , 0xC5, 0x9C, 0xC0, 0x9C, 0x1D, 0x3B, 0x48, 0x84 + , 0x38, 0x47, 0xC4, 0x8A, 0x5C, 0x50, 0xDB, 0x50 + , 0x7F + ]) + @?= Right BleAdvertisement + { advServiceData = + [(UUID.fromWords 0x50DB505C 0x8AC44738 0x84483B1D 0x9CC09CC5, BS.pack [0x7F])] + , advManufacturerData = [] + } + + , testCase "parseBleAdvertisement reads manufacturer data" $ + -- KKM's company id 0x0A53, little-endian on air. + parseBleAdvertisement (BS.pack [0x04, 0xFF, 0x53, 0x0A, 0x21]) + @?= Right BleAdvertisement + { advServiceData = [] + , advManufacturerData = [(ManufacturerId 0x0A53, BS.pack [0x21])] + } + + , testCase "parseBleAdvertisement keeps entry order across types" $ + parseBleAdvertisement + (BS.pack + [ 0x04, 0x16, 0xAA, 0xFE, 0x01 + , 0x03, 0xFF, 0x4C, 0x00 + , 0x04, 0x16, 0x80, 0x20, 0x02 + ]) + @?= Right BleAdvertisement + { advServiceData = + [ (UUID.fromWords 0x0000FEAA 0x00001000 0x80000080 0x5F9B34FB, BS.pack [0x01]) + , (UUID.fromWords 0x00002080 0x00001000 0x80000080 0x5F9B34FB, BS.pack [0x02]) + ] + , advManufacturerData = [(ManufacturerId 0x004C, BS.empty)] + } + + , testCase "parseBleAdvertisement stops at the zero padding" $ + -- ScanRecord.getBytes() zero-pads to the advertisement buffer + -- size; the padding must not become phantom entries. + parseBleAdvertisement + (BS.pack [0x05, 0x16, 0xED, 0xFE, 0x2A, 0x63, 0x00, 0x00, 0x00, 0x00]) + @?= Right BleAdvertisement + { advServiceData = + [(UUID.fromWords 0x0000FEED 0x00001000 0x80000080 0x5F9B34FB, BS.pack [0x2A, 0x63])] + , advManufacturerData = [] + } + + , testCase "a truncated structure reports its offset and keeps the salvage" $ + -- The second structure (length byte at offset 5) claims 9 + -- bytes but only 3 follow; the well-formed manufacturer data + -- before it survives in the partial advertisement. + parseBleAdvertisement + (BS.pack [0x04, 0xFF, 0x53, 0x0A, 0x21, 0x09, 0x16, 0xED, 0xFE]) + @?= Left BleAdvertisementWithErrors + { partialAdvertisement = BleAdvertisement + { advServiceData = [] + , advManufacturerData = [(ManufacturerId 0x0A53, BS.pack [0x21])] + } + , advertisementParseErrors = AdvertisementParseErrors + (AdStructureTruncated (AdStructureTruncation (AdStructureOffset 5) 9 3) :| []) + } + + , testCase "a mid-stream defect keeps the structures around it" $ + -- Defective service data first, valid manufacturer data after: + -- the defect skips only its own structure. + parseBleAdvertisement + (BS.pack [0x02, 0x16, 0xED, 0x04, 0xFF, 0x53, 0x0A, 0x21]) + @?= Left BleAdvertisementWithErrors + { partialAdvertisement = BleAdvertisement + { advServiceData = [] + , advManufacturerData = [(ManufacturerId 0x0A53, BS.pack [0x21])] + } + , advertisementParseErrors = AdvertisementParseErrors + (ServiceDataUuidTruncated + (ServiceDataTruncation (AdStructureOffset 0) 0x16 2 1) :| []) + } + + , testCase "a truncated 128-bit service data UUID never passes as narrower" $ do + -- A 0x21 structure promises a 16-byte UUID; truncated to two + -- bytes it must NOT parse as the 16-bit UUID those bytes spell + -- (regression: [0x80, 0x20] would otherwise read as 0x2080). + parseBleAdvertisement (BS.pack [0x03, 0x21, 0x80, 0x20]) + @?= Left (BleAdvertisementWithErrors emptyBleAdvertisement + (AdvertisementParseErrors + (ServiceDataUuidTruncated + (ServiceDataTruncation (AdStructureOffset 0) 0x21 16 2) :| []))) + parseBleAdvertisement (BS.pack [0x05, 0x21, 0x01, 0x02, 0x03, 0x04]) + @?= Left (BleAdvertisementWithErrors emptyBleAdvertisement + (AdvertisementParseErrors + (ServiceDataUuidTruncated + (ServiceDataTruncation (AdStructureOffset 0) 0x21 16 4) :| []))) + parseBleAdvertisement (BS.pack [0x03, 0x20, 0x80, 0x20]) + @?= Left (BleAdvertisementWithErrors emptyBleAdvertisement + (AdvertisementParseErrors + (ServiceDataUuidTruncated + (ServiceDataTruncation (AdStructureOffset 0) 0x20 4 2) :| []))) + + , testCase "parseBleAdvertisement accumulates every defect" $ + -- Service data too short for its 16-bit UUID at offset 0, then + -- manufacturer data too short for its company id at offset 3: + -- all structures defective, so the salvage is empty. + parseBleAdvertisement + (BS.pack [0x02, 0x16, 0xED, 0x02, 0xFF, 0x53]) + @?= Left (BleAdvertisementWithErrors emptyBleAdvertisement + (AdvertisementParseErrors + (ServiceDataUuidTruncated + (ServiceDataTruncation (AdStructureOffset 0) 0x16 2 1) + :| [ManufacturerDataTooShort + (ManufacturerDataTruncation (AdStructureOffset 3) 1)]))) + + , testCase "serviceDataForUuid keys on the UUID value" $ do + let parsed = parseBleAdvertisement + (BS.pack [0x05, 0x16, 0x80, 0x20, 0x55, 0x63]) + fmap (serviceDataForUuid kkmExtDataUuid) parsed + @?= Right (Just (BS.pack [0x55, 0x63])) + fmap (serviceDataForUuid + (UUID.fromWords 0x0000FEAA 0x00001000 0x80000080 0x5F9B34FB)) parsed + @?= Right Nothing + -- Both platform spellings parse to the same binary key, so the + -- old case-mismatch bug is unrepresentable. + UUID.fromText "00002080-0000-1000-8000-00805F9B34FB" + @?= UUID.fromText "00002080-0000-1000-8000-00805f9b34fb" + , testCase "bleConnectionEventFromInt roundtrips all constructors" $ do let allEvents = [BleConnectionEstablished, BleConnectionClosed, BleConnectionFailed] mapM_ (\event -> diff --git a/test/android/ble.sh b/test/android/ble.sh index 6e5bf6e..958697d 100644 --- a/test/android/ble.sh +++ b/test/android/ble.sh @@ -133,6 +133,10 @@ if [ "$BLE_SIM" = "1" ]; then "$ADB" -s "$EMULATOR_SERIAL" logcat -d '*:I' > "$LOGCAT_SCAN" 2>&1 || true assert_logcat "$LOGCAT_SCAN" "BLE scan result:.*HatterBleSim" \ "hatter received the simulated advertisement" + # The peripheral broadcasts 0xFEED service data with payload + # 2A 63 (decimal 42, 99); it must arrive parsed in Haskell. + assert_logcat "$LOGCAT_SCAN" "BLE adv service data: 0000feed-0000-1000-8000-00805f9b34fb=\[42,99\]" \ + "advertisement service data delivered to Haskell" # Connect to the discovered peripheral from hatter code. tap_button "Connect" || { echo "WARNING: could not tap Connect"; } diff --git a/test/android/ble_peripheral.py b/test/android/ble_peripheral.py index 042dc6e..0580b9d 100644 --- a/test/android/ble_peripheral.py +++ b/test/android/ble_peripheral.py @@ -89,6 +89,9 @@ async def on_echo_write(connection, value): ], ) ) + # The 0xFEED service data entry (payload 2A 63) exercises the + # advertisement-payload path: the BLE test asserts the bytes + # arrive parsed in Haskell (Hatter.BleAdvertisement). device.advertising_data = bytes( AdvertisingData( [ @@ -97,6 +100,10 @@ async def on_echo_write(connection, value): AdvertisingData.COMPLETE_LIST_OF_128_BIT_SERVICE_CLASS_UUIDS, UUID(TEST_SERVICE_UUID).to_bytes(), ), + ( + AdvertisingData.SERVICE_DATA_16_BIT_UUID, + bytes([0xED, 0xFE, 0x2A, 0x63]), + ), ] ) )