From 7dd46a9b5b67b8cbf7208bebdfe8475b4cbe0c8b Mon Sep 17 00:00:00 2001 From: jappeace-sloth Date: Mon, 13 Jul 2026 17:59:56 +0200 Subject: [PATCH 01/13] BLE: deliver advertisement payloads with scan results (#238) Scan results carried only name, address and RSSI; the service data and manufacturer data that devices broadcast precisely to avoid connections were dropped at every bridge. This blocked identifying devices that advertise only service data (KBeacons' 0x2080) or manufacturer data (iBeacon), reading broadcast state like battery bytes, and recovering MACs on iOS. - New pure module Hatter.BleAdvertisement (re-exported from Hatter.Ble): parses raw AD structures into service data entries (keyed by the full lowercase 128-bit UUID text, 16/32-bit UUIDs expanded with the Bluetooth base UUID) and manufacturer data entries (keyed by the 16-bit company id), with serviceDataForUuid for case-insensitive lookup. Malformed air data degrades to "no payload" instead of failing: zero padding terminates, truncated tails are dropped. - BleScanResult gains bsrAdvertisement; the scan callback chain (Java/ObjC -> C -> haskellOnBleScanResult -> dispatchBleScanResult) gains a bytes+length parameter, mirroring the notification path. - Android passes ScanRecord.getBytes() through unchanged. iOS re-encodes CoreBluetooth's parsed advertisementData dictionary into the same AD structure format (CoreBluetooth never exposes the raw bytes), so Haskell has a single decoding path for both platforms. - The virtual test peripheral now broadcasts a 0xFEED service data entry and ble.sh asserts its payload arrives parsed in Haskell; BleDemoMain logs advertisement service data as decimal byte lists like the GATT logs. Eight new unit tests cover the parser and the dispatch path. Closes #238. Prompt: add these as issues to hatter if you feel it would be a nice addition, I maintain that as well / I suppose we've to address 238 first to even support this tool Co-Authored-By: Claude Fable 5 --- Changelog.md | 10 ++ .../java/me/jappie/hatter/HatterActivity.java | 9 +- cbits/ble_bridge_android.c | 20 ++- cbits/jni_bridge.c | 3 +- hatter.cabal | 1 + include/Hatter.h | 3 +- ios/Hatter/BleBridgeIOS.m | 63 ++++++- src/Hatter.hs | 10 +- src/Hatter/Ble.hs | 17 +- src/Hatter/BleAdvertisement.hs | 162 ++++++++++++++++++ test/BleDemoMain.hs | 10 +- test/Test/PlatformTests.hs | 122 ++++++++++++- test/android/ble.sh | 4 + test/android/ble_peripheral.py | 7 + 14 files changed, 415 insertions(+), 26 deletions(-) create mode 100644 src/Hatter/BleAdvertisement.hs diff --git a/Changelog.md b/Changelog.md index 2ee384e..cb5e1b6 100644 --- a/Changelog.md +++ b/Changelog.md @@ -4,6 +4,16 @@ ### Added +- Scan results now carry the advertisement's service data and + manufacturer data (issue #238): `BleScanResult` gained + `bsrAdvertisement`, parsed by the new `Hatter.BleAdvertisement` + module (re-exported from `Hatter.Ble`) with `serviceDataForUuid` + for keyed lookup. 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..c9eac2b 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 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/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..864f79c 100644 --- a/src/Hatter/Ble.hs +++ b/src/Hatter/Ble.hs @@ -24,6 +24,7 @@ module Hatter.Ble ( BleAdapterStatus(..) , BleScanResult(..) + , module Hatter.BleAdvertisement , BleDeviceAddress(..) , BleServiceUuid(..) , BleCharacteristicUuid(..) @@ -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,9 @@ data BleScanResult = BleScanResult { bsrDeviceName :: Text , bsrDeviceAddress :: BleDeviceAddress , bsrRssi :: Int + , bsrAdvertisement :: BleAdvertisement + -- ^ Service data and manufacturer data broadcast in the + -- advertisement, see "Hatter.BleAdvertisement". } deriving (Show, Eq) -- | A connection state change delivered by the platform for the @@ -590,8 +596,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,10 +609,14 @@ dispatchBleScanResult bleState cName cAddr cRssi = do addrStr <- if cAddr == nullPtr then pure "" else pack <$> peekCString cAddr + advBytes <- if advPtr == nullPtr || advLength <= 0 + then pure BS.empty + else BS.packCStringLen (castPtr advPtr, CInt.toInt advLength) let scanResult = BleScanResult { bsrDeviceName = nameStr , bsrDeviceAddress = BleDeviceAddress addrStr , bsrRssi = CInt.toInt cRssi + , bsrAdvertisement = parseBleAdvertisement advBytes } callback scanResult diff --git a/src/Hatter/BleAdvertisement.hs b/src/Hatter/BleAdvertisement.hs new file mode 100644 index 0000000..af8a2e7 --- /dev/null +++ b/src/Hatter/BleAdvertisement.hs @@ -0,0 +1,162 @@ +{-# 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(..) + , ManufacturerId(..) + , emptyBleAdvertisement + , parseBleAdvertisement + , serviceDataForUuid + ) where + +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Char (intToDigit) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Word (Word8, Word16) +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 in +-- lowercase text form (16- and 32-bit UUIDs are expanded with the +-- Bluetooth base UUID, matching the textual convention of +-- "Hatter.Ble"); manufacturer data is keyed by the 16-bit company +-- identifier. Entries keep their advertisement order. +data BleAdvertisement = BleAdvertisement + { advServiceData :: [(Text, 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) + +-- | 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 +-- (Android's @ScanRecord.getBytes()@ zero-pads to the fixed +-- advertisement buffer size); a structure whose length exceeds the +-- remaining bytes is dropped along with everything after it. +-- +-- Decision: tolerate malformed input instead of failing. The bytes +-- come straight off the air from arbitrary third-party devices, so a +-- garbled advertisement must degrade to "no payload", never take the +-- app down or suppress the scan result carrying it. +parseBleAdvertisement :: ByteString -> BleAdvertisement +parseBleAdvertisement bytes = + case BS.uncons bytes of + Nothing -> emptyBleAdvertisement + Just (lengthByte, afterLength) -> + let structureLength = Word8.toInt lengthByte + in if lengthByte == 0 || BS.length afterLength < structureLength + then emptyBleAdvertisement + else + let structure = BS.take structureLength afterLength + parsedRest = parseBleAdvertisement (BS.drop structureLength afterLength) + in case BS.uncons structure of + Nothing -> parsedRest + Just (adType, payload) -> addAdStructure adType payload parsedRest + +-- | Fold one AD structure into the advertisement parsed from the +-- bytes after it. Only the payload-bearing types are kept: service +-- data at each UUID width (0x16, 0x20, 0x21) and manufacturer data +-- (0xFF). Names, flags and service-class UUID lists are dropped; the +-- platforms already surface the name, and the UUID lists carry no +-- payload. +addAdStructure :: Word8 -> ByteString -> BleAdvertisement -> BleAdvertisement +addAdStructure adType payload adv = if + | adType == 0x16 -> addServiceData 2 payload adv + | adType == 0x20 -> addServiceData 4 payload adv + | adType == 0x21 -> addServiceData 16 payload adv + | adType == 0xFF -> addManufacturerData payload adv + | otherwise -> adv + +-- | Prepend one service data entry: a little-endian UUID of the given +-- byte width, then the payload. Too short to hold its UUID means a +-- malformed structure, which is skipped (see 'parseBleAdvertisement' +-- on tolerating air garbage). +addServiceData :: Int -> ByteString -> BleAdvertisement -> BleAdvertisement +addServiceData uuidWidth payload adv = + if BS.length payload < uuidWidth + then adv + else + let (uuidBytes, dataBytes) = BS.splitAt uuidWidth payload + in adv { advServiceData = + (uuidTextFromLittleEndian uuidBytes, dataBytes) : advServiceData adv } + +-- | Prepend one manufacturer data entry: little-endian company +-- identifier, then the payload. +addManufacturerData :: ByteString -> BleAdvertisement -> BleAdvertisement +addManufacturerData payload adv = + if BS.length payload < 2 + then adv + else + let companyId = Word8.toWord16 (BS.index payload 1) * 256 + + Word8.toWord16 (BS.index payload 0) + dataBytes = BS.drop 2 payload + in adv { advManufacturerData = + (ManufacturerId companyId, dataBytes) : advManufacturerData adv } + +-- | Look up a service data payload by UUID text +-- (case-insensitively). Accepts the same 128-bit form used across +-- "Hatter.Ble", e.g. @"00002080-0000-1000-8000-00805F9B34FB"@. +serviceDataForUuid :: Text -> BleAdvertisement -> Maybe ByteString +serviceDataForUuid uuid adv = + lookup (Text.toLower uuid) (advServiceData adv) + +-- | The last 12 bytes of the Bluetooth base UUID +-- (@xxxxxxxx-0000-1000-8000-00805F9B34FB@), which 16- and 32-bit +-- UUIDs are an alias into. +bluetoothBaseUuidTail :: ByteString +bluetoothBaseUuidTail = BS.pack + [0x00, 0x00, 0x10, 0x00, 0x80, 0x00, 0x00, 0x80, 0x5F, 0x9B, 0x34, 0xFB] + +-- | Render an advertisement UUID (2, 4 or 16 bytes little-endian on +-- air) as full lowercase 128-bit text. +uuidTextFromLittleEndian :: ByteString -> Text +uuidTextFromLittleEndian uuidBytes = + let bigEndian = BS.reverse uuidBytes + full = if BS.length bigEndian == 16 + then bigEndian + else BS.replicate (4 - BS.length bigEndian) 0x00 + <> bigEndian + <> bluetoothBaseUuidTail + in formatUuid128 full + +-- | Format 16 big-endian bytes as @xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx@. +formatUuid128 :: ByteString -> Text +formatUuid128 bigEndian = + let hexText = Text.pack (concatMap hexByte (BS.unpack bigEndian)) + in Text.intercalate "-" + [ Text.take 8 hexText + , Text.take 4 (Text.drop 8 hexText) + , Text.take 4 (Text.drop 12 hexText) + , Text.take 4 (Text.drop 16 hexText) + , Text.drop 20 hexText + ] + +-- | Two lowercase hex digits for one byte. +hexByte :: Word8 -> String +hexByte byte = + let (high, low) = Word8.toInt byte `divMod` 16 + in [intToDigit high, intToDigit low] diff --git a/test/BleDemoMain.hs b/test/BleDemoMain.hs index c8bae38..48fa7d4 100644 --- a/test/BleDemoMain.hs +++ b/test/BleDemoMain.hs @@ -39,6 +39,7 @@ import Hatter.AppContext (AppContext(..), derefAppContext) import Hatter.Ble ( BleState(..) , BleScanResult(..) + , BleAdvertisement(..) , BleDeviceAddress(..) , BleServiceUuid(..) , BleCharacteristicUuid(..) @@ -171,11 +172,16 @@ 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)) + mapM_ (\(uuid, payload) -> + platformLog ("BLE adv service data: " <> uuid + <> "=" <> pack (show (BS.unpack payload)))) + (advServiceData (bsrAdvertisement scanResult)) writeIORef lastAddressRef (Just (bsrDeviceAddress scanResult)) -- | Address the Connect button targets: the last discovered device, diff --git a/test/Test/PlatformTests.hs b/test/Test/PlatformTests.hs index 749330c..3e2d002 100644 --- a/test/Test/PlatformTests.hs +++ b/test/Test/PlatformTests.hs @@ -24,7 +24,7 @@ import Data.IntMap.Strict qualified as IntMap 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 +65,11 @@ import Hatter.Ble , BleGattError(..) , BleGattCompletion(..) , BleState(..) + , BleAdvertisement(..) + , ManufacturerId(..) + , emptyBleAdvertisement + , parseBleAdvertisement + , serviceDataForUuid , newBleState , bleAdapterStatusFromInt , bleAdapterStatusToInt @@ -418,7 +423,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 +433,14 @@ bleTests ffiBleState = testGroup "BLE" bsrDeviceName scanResult @?= "TestDevice" bsrDeviceAddress scanResult @?= BleDeviceAddress "AA:BB:CC:DD:EE:FF" bsrRssi scanResult @?= (-42) + bsrAdvertisement scanResult @?= 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 +450,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 +475,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 +488,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 +497,108 @@ 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 -> + serviceDataForUuid "00002080-0000-1000-8000-00805F9B34FB" + (bsrAdvertisement scanResult) + @?= 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]) + @?= BleAdvertisement + { advServiceData = + [("0000feed-0000-1000-8000-00805f9b34fb", 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 + ]) + @?= BleAdvertisement + { advServiceData = + [("50db505c-8ac4-4738-8448-3b1d9cc09cc5", 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]) + @?= 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 + ]) + @?= BleAdvertisement + { advServiceData = + [ ("0000feaa-0000-1000-8000-00805f9b34fb", BS.pack [0x01]) + , ("00002080-0000-1000-8000-00805f9b34fb", 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]) + @?= BleAdvertisement + { advServiceData = + [("0000feed-0000-1000-8000-00805f9b34fb", BS.pack [0x2A, 0x63])] + , advManufacturerData = [] + } + + , testCase "parseBleAdvertisement drops a truncated tail" $ + -- The final structure claims 9 bytes but only 3 follow. + parseBleAdvertisement + (BS.pack [0x04, 0xFF, 0x53, 0x0A, 0x21, 0x09, 0x16, 0xED, 0xFE]) + @?= BleAdvertisement + { advServiceData = [] + , advManufacturerData = [(ManufacturerId 0x0A53, BS.pack [0x21])] + } + + , testCase "serviceDataForUuid is case-insensitive" $ do + let adv = parseBleAdvertisement + (BS.pack [0x05, 0x16, 0x80, 0x20, 0x55, 0x63]) + serviceDataForUuid "00002080-0000-1000-8000-00805F9B34FB" adv + @?= Just (BS.pack [0x55, 0x63]) + serviceDataForUuid "00002080-0000-1000-8000-00805f9b34fb" adv + @?= Just (BS.pack [0x55, 0x63]) + serviceDataForUuid "0000FEAA-0000-1000-8000-00805F9B34FB" adv + @?= Nothing + , 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]), + ), ] ) ) From 9ee7f920c77dfbc596e620b169a46483be6800d0 Mon Sep 17 00:00:00 2001 From: jappeace-sloth Date: Mon, 13 Jul 2026 18:03:44 +0200 Subject: [PATCH 02/13] Comment: the zero-length check also prevents infinite recursion Co-Authored-By: Claude Fable 5 --- src/Hatter/BleAdvertisement.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Hatter/BleAdvertisement.hs b/src/Hatter/BleAdvertisement.hs index af8a2e7..1f32cde 100644 --- a/src/Hatter/BleAdvertisement.hs +++ b/src/Hatter/BleAdvertisement.hs @@ -68,6 +68,8 @@ parseBleAdvertisement bytes = Nothing -> emptyBleAdvertisement Just (lengthByte, afterLength) -> let structureLength = Word8.toInt lengthByte + -- The zero check also guards the recursion: a zero-length + -- structure would drop zero bytes and loop here forever. in if lengthByte == 0 || BS.length afterLength < structureLength then emptyBleAdvertisement else From 03bc3806582c72d0dbdd0529017d6f899d6932de Mon Sep 17 00:00:00 2001 From: jappeace-sloth Date: Mon, 13 Jul 2026 18:15:19 +0200 Subject: [PATCH 03/13] Key service data by NormalizedBleUuid; write out "advertisement" Review findings: the service-data UUID flowed through four signatures as bare Text while the sibling module newtypes every UUID string, and the same file already newtypes ManufacturerId for the other key. Move NormalizedBleUuid (with its Decision comment) into Hatter.BleAdvertisement, the import direction Hatter.Ble already has, and key advServiceData with it; the parser constructs it lowercase by construction. Also rename the abbreviated "adv" parameters to "advertisement" per the full-names style rule. Co-Authored-By: Claude Fable 5 --- Changelog.md | 3 +- src/Hatter/Ble.hs | 19 --------- src/Hatter/BleAdvertisement.hs | 74 ++++++++++++++++++++++------------ test/BleDemoMain.hs | 3 +- test/Test/PlatformTests.hs | 11 ++--- 5 files changed, 58 insertions(+), 52 deletions(-) diff --git a/Changelog.md b/Changelog.md index cb5e1b6..8670ea2 100644 --- a/Changelog.md +++ b/Changelog.md @@ -8,7 +8,8 @@ manufacturer data (issue #238): `BleScanResult` gained `bsrAdvertisement`, parsed by the new `Hatter.BleAdvertisement` module (re-exported from `Hatter.Ble`) with `serviceDataForUuid` - for keyed lookup. Android passes `ScanRecord.getBytes()` through + for keyed lookup; service data is keyed by `NormalizedBleUuid`, + which moved into that module. 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 diff --git a/src/Hatter/Ble.hs b/src/Hatter/Ble.hs index 864f79c..f799c0a 100644 --- a/src/Hatter/Ble.hs +++ b/src/Hatter/Ble.hs @@ -28,7 +28,6 @@ module Hatter.Ble , BleDeviceAddress(..) , BleServiceUuid(..) , BleCharacteristicUuid(..) - , NormalizedBleUuid(..) , BleCharacteristicKey(..) , BleCharacteristicValue(..) , BleMtu(..) @@ -118,24 +117,6 @@ newtype BleCharacteristicUuid = BleCharacteristicUuid { unBleCharacteristicUuid deriving (Show, Eq, Ord) deriving newtype (IsString) --- | A UUID string normalized to lowercase for comparisons. UUIDs are --- case-insensitive per the Bluetooth spec, but the platforms disagree --- on the case they report (Android lowercase, iOS uppercase), so raw --- strings must never be compared directly. Constructed via --- 'normalizeBleServiceUuid' \/ 'normalizeBleCharacteristicUuid'; --- deliberately no 'IsString' instance, a literal would bypass the --- normalization. --- --- Decision: case-insensitivity is a dedicated normalized newtype --- built only through smart constructors. Alternatives considered: --- lowercasing ad hoc at each comparison site (error-prone, exactly --- how the original subscribe\/notify mismatch bug happened), and a --- case-insensitive 'Ord' on the raw UUID newtypes (invisible at use --- sites and surprising for anyone sorting or printing them). A type --- that cannot exist un-normalized makes the mistake unrepresentable. -newtype NormalizedBleUuid = NormalizedBleUuid { unNormalizedBleUuid :: Text } - deriving (Show, Eq, Ord) - -- | Identifies one characteristic on the connected device: its -- containing service and its own UUID, case-normalized so lookups -- match across platforms. Used as the notification-callback key. diff --git a/src/Hatter/BleAdvertisement.hs b/src/Hatter/BleAdvertisement.hs index 1f32cde..d2ef4c4 100644 --- a/src/Hatter/BleAdvertisement.hs +++ b/src/Hatter/BleAdvertisement.hs @@ -14,6 +14,7 @@ -- parser is the single decoding path for both platforms. module Hatter.BleAdvertisement ( BleAdvertisement(..) + , NormalizedBleUuid(..) , ManufacturerId(..) , emptyBleAdvertisement , parseBleAdvertisement @@ -28,14 +29,32 @@ import Data.Text qualified as Text import Data.Word (Word8, Word16) import Unwitch.Convert.Word8 qualified as Word8 +-- | A UUID string normalized to lowercase for comparisons. UUIDs are +-- case-insensitive per the Bluetooth spec, but the platforms disagree +-- on the case they report (Android lowercase, iOS uppercase), so raw +-- strings must never be compared directly. Constructed via +-- 'Hatter.Ble.normalizeBleServiceUuid' \/ +-- 'Hatter.Ble.normalizeBleCharacteristicUuid', or lowercase by +-- construction in 'parseBleAdvertisement'; deliberately no 'IsString' +-- instance, a literal would bypass the normalization. +-- +-- Decision: case-insensitivity is a dedicated normalized newtype +-- built only through smart constructors. Alternatives considered: +-- lowercasing ad hoc at each comparison site (error-prone, exactly +-- how the original subscribe\/notify mismatch bug happened), and a +-- case-insensitive 'Ord' on the raw UUID newtypes (invisible at use +-- sites and surprising for anyone sorting or printing them). A type +-- that cannot exist un-normalized makes the mistake unrepresentable. +newtype NormalizedBleUuid = NormalizedBleUuid { unNormalizedBleUuid :: Text } + deriving (Show, Eq, Ord) + -- | The advertisement fields a scan result carries beyond name, --- address and RSSI. Service data is keyed by the full 128-bit UUID in --- lowercase text form (16- and 32-bit UUIDs are expanded with the --- Bluetooth base UUID, matching the textual convention of --- "Hatter.Ble"); manufacturer data is keyed by the 16-bit company --- identifier. Entries keep their advertisement order. +-- address and RSSI. Service data is keyed by the full 128-bit +-- 'NormalizedBleUuid' (16- and 32-bit UUIDs are expanded with the +-- Bluetooth base UUID); manufacturer data is keyed by the 16-bit +-- company identifier. Entries keep their advertisement order. data BleAdvertisement = BleAdvertisement - { advServiceData :: [(Text, ByteString)] + { advServiceData :: [(NormalizedBleUuid, ByteString)] , advManufacturerData :: [(ManufacturerId, ByteString)] } deriving (Show, Eq) @@ -86,45 +105,47 @@ parseBleAdvertisement bytes = -- platforms already surface the name, and the UUID lists carry no -- payload. addAdStructure :: Word8 -> ByteString -> BleAdvertisement -> BleAdvertisement -addAdStructure adType payload adv = if - | adType == 0x16 -> addServiceData 2 payload adv - | adType == 0x20 -> addServiceData 4 payload adv - | adType == 0x21 -> addServiceData 16 payload adv - | adType == 0xFF -> addManufacturerData payload adv - | otherwise -> adv +addAdStructure adType payload advertisement = if + | adType == 0x16 -> addServiceData 2 payload advertisement + | adType == 0x20 -> addServiceData 4 payload advertisement + | adType == 0x21 -> addServiceData 16 payload advertisement + | adType == 0xFF -> addManufacturerData payload advertisement + | otherwise -> advertisement -- | Prepend one service data entry: a little-endian UUID of the given -- byte width, then the payload. Too short to hold its UUID means a -- malformed structure, which is skipped (see 'parseBleAdvertisement' -- on tolerating air garbage). addServiceData :: Int -> ByteString -> BleAdvertisement -> BleAdvertisement -addServiceData uuidWidth payload adv = +addServiceData uuidWidth payload advertisement = if BS.length payload < uuidWidth - then adv + then advertisement else let (uuidBytes, dataBytes) = BS.splitAt uuidWidth payload - in adv { advServiceData = - (uuidTextFromLittleEndian uuidBytes, dataBytes) : advServiceData adv } + in advertisement { advServiceData = + (normalizedUuidFromLittleEndian uuidBytes, dataBytes) + : advServiceData advertisement } -- | Prepend one manufacturer data entry: little-endian company -- identifier, then the payload. addManufacturerData :: ByteString -> BleAdvertisement -> BleAdvertisement -addManufacturerData payload adv = +addManufacturerData payload advertisement = if BS.length payload < 2 - then adv + then advertisement else let companyId = Word8.toWord16 (BS.index payload 1) * 256 + Word8.toWord16 (BS.index payload 0) dataBytes = BS.drop 2 payload - in adv { advManufacturerData = - (ManufacturerId companyId, dataBytes) : advManufacturerData adv } + in advertisement { advManufacturerData = + (ManufacturerId companyId, dataBytes) + : advManufacturerData advertisement } -- | Look up a service data payload by UUID text -- (case-insensitively). Accepts the same 128-bit form used across -- "Hatter.Ble", e.g. @"00002080-0000-1000-8000-00805F9B34FB"@. serviceDataForUuid :: Text -> BleAdvertisement -> Maybe ByteString -serviceDataForUuid uuid adv = - lookup (Text.toLower uuid) (advServiceData adv) +serviceDataForUuid uuid advertisement = + lookup (NormalizedBleUuid (Text.toLower uuid)) (advServiceData advertisement) -- | The last 12 bytes of the Bluetooth base UUID -- (@xxxxxxxx-0000-1000-8000-00805F9B34FB@), which 16- and 32-bit @@ -134,16 +155,17 @@ bluetoothBaseUuidTail = BS.pack [0x00, 0x00, 0x10, 0x00, 0x80, 0x00, 0x00, 0x80, 0x5F, 0x9B, 0x34, 0xFB] -- | Render an advertisement UUID (2, 4 or 16 bytes little-endian on --- air) as full lowercase 128-bit text. -uuidTextFromLittleEndian :: ByteString -> Text -uuidTextFromLittleEndian uuidBytes = +-- air) as a full 128-bit 'NormalizedBleUuid' (the hex rendering is +-- lowercase by construction). +normalizedUuidFromLittleEndian :: ByteString -> NormalizedBleUuid +normalizedUuidFromLittleEndian uuidBytes = let bigEndian = BS.reverse uuidBytes full = if BS.length bigEndian == 16 then bigEndian else BS.replicate (4 - BS.length bigEndian) 0x00 <> bigEndian <> bluetoothBaseUuidTail - in formatUuid128 full + in NormalizedBleUuid (formatUuid128 full) -- | Format 16 big-endian bytes as @xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx@. formatUuid128 :: ByteString -> Text diff --git a/test/BleDemoMain.hs b/test/BleDemoMain.hs index 48fa7d4..876421e 100644 --- a/test/BleDemoMain.hs +++ b/test/BleDemoMain.hs @@ -40,6 +40,7 @@ import Hatter.Ble ( BleState(..) , BleScanResult(..) , BleAdvertisement(..) + , NormalizedBleUuid(..) , BleDeviceAddress(..) , BleServiceUuid(..) , BleCharacteristicUuid(..) @@ -179,7 +180,7 @@ logAndRememberScanResult :: IORef (Maybe BleDeviceAddress) -> BleScanResult -> I logAndRememberScanResult lastAddressRef scanResult = do platformLog ("BLE scan result: " <> pack (show scanResult)) mapM_ (\(uuid, payload) -> - platformLog ("BLE adv service data: " <> uuid + platformLog ("BLE adv service data: " <> unNormalizedBleUuid uuid <> "=" <> pack (show (BS.unpack payload)))) (advServiceData (bsrAdvertisement scanResult)) writeIORef lastAddressRef (Just (bsrDeviceAddress scanResult)) diff --git a/test/Test/PlatformTests.hs b/test/Test/PlatformTests.hs index 3e2d002..b437754 100644 --- a/test/Test/PlatformTests.hs +++ b/test/Test/PlatformTests.hs @@ -66,6 +66,7 @@ import Hatter.Ble , BleGattCompletion(..) , BleState(..) , BleAdvertisement(..) + , NormalizedBleUuid(..) , ManufacturerId(..) , emptyBleAdvertisement , parseBleAdvertisement @@ -526,7 +527,7 @@ bleTests ffiBleState = testGroup "BLE" (BS.pack [0x02, 0x01, 0x06, 0x05, 0x16, 0xED, 0xFE, 0x2A, 0x63]) @?= BleAdvertisement { advServiceData = - [("0000feed-0000-1000-8000-00805f9b34fb", BS.pack [0x2A, 0x63])] + [(NormalizedBleUuid "0000feed-0000-1000-8000-00805f9b34fb", BS.pack [0x2A, 0x63])] , advManufacturerData = [] } @@ -542,7 +543,7 @@ bleTests ffiBleState = testGroup "BLE" ]) @?= BleAdvertisement { advServiceData = - [("50db505c-8ac4-4738-8448-3b1d9cc09cc5", BS.pack [0x7F])] + [(NormalizedBleUuid "50db505c-8ac4-4738-8448-3b1d9cc09cc5", BS.pack [0x7F])] , advManufacturerData = [] } @@ -563,8 +564,8 @@ bleTests ffiBleState = testGroup "BLE" ]) @?= BleAdvertisement { advServiceData = - [ ("0000feaa-0000-1000-8000-00805f9b34fb", BS.pack [0x01]) - , ("00002080-0000-1000-8000-00805f9b34fb", BS.pack [0x02]) + [ (NormalizedBleUuid "0000feaa-0000-1000-8000-00805f9b34fb", BS.pack [0x01]) + , (NormalizedBleUuid "00002080-0000-1000-8000-00805f9b34fb", BS.pack [0x02]) ] , advManufacturerData = [(ManufacturerId 0x004C, BS.empty)] } @@ -576,7 +577,7 @@ bleTests ffiBleState = testGroup "BLE" (BS.pack [0x05, 0x16, 0xED, 0xFE, 0x2A, 0x63, 0x00, 0x00, 0x00, 0x00]) @?= BleAdvertisement { advServiceData = - [("0000feed-0000-1000-8000-00805f9b34fb", BS.pack [0x2A, 0x63])] + [(NormalizedBleUuid "0000feed-0000-1000-8000-00805f9b34fb", BS.pack [0x2A, 0x63])] , advManufacturerData = [] } From 99d34d82825e207321ed7c8d4fdad2524d11f49f Mon Sep 17 00:00:00 2001 From: jappeace-sloth Date: Mon, 13 Jul 2026 19:25:11 +0200 Subject: [PATCH 04/13] Report advertisement parse defects in the type; render UUIDs via uuid-types Review findings on #239: the parser silently dropped malformed structures (truncated tails, service data too short for its UUID, manufacturer data without a company id), and the UUID text rendering was hand-rolled. Per https://jappie.me/failing-in-haskell.html we want to know what fails, why and where, with concrete types rather than mtl: - parseBleAdvertisement :: ByteString -> Either AdvertisementParseErrors BleAdvertisement. Every malformed branch has its own constructor carrying the byte offset of the offending structure plus the sizes involved (AdStructureTruncated, ServiceDataUuidTruncated, ManufacturerDataTooShort); all defects in one advertisement are accumulated as a NonEmpty. Unknown AD types remain non-failures (names, flags, UUID lists are legitimate structures this module does not surface). The zero padding byte remains a clean terminator. - The helpers carry the failure in their signatures too (Either AdvertisementParseError). - bsrAdvertisement is now the full Either: the scan dispatch logs defects loudly with the sending device's address and still delivers the result, and applications can surface them as well. - UUID rendering goes through uuid-types (UUID.fromWords is total, UUID.toText is canonical lowercase), replacing the hand-rolled hex formatting; the Bluetooth base-UUID aliasing keeps its three word constants. uuid-types and its non-boot transitive deps (hashable, random, splitmix) are added to the cross-build collection lists. Prompt: address my review comments, refer to my blogpost failing in haskell. you've added silent failures, that's bad, we want to know what fails, why and where / I use mtl style in the blogpost, that's not a good idea, use concrete types instead if you can Co-Authored-By: Claude Fable 5 --- Changelog.md | 9 +- hatter.cabal | 3 +- nix/cross-deps.nix | 12 +- nix/ios-deps.nix | 8 +- src/Hatter/Ble.hs | 31 +++-- src/Hatter/BleAdvertisement.hs | 237 ++++++++++++++++++++++----------- test/BleDemoMain.hs | 12 +- test/Test/PlatformTests.hs | 52 +++++--- 8 files changed, 244 insertions(+), 120 deletions(-) diff --git a/Changelog.md b/Changelog.md index 8670ea2..929c077 100644 --- a/Changelog.md +++ b/Changelog.md @@ -6,10 +6,15 @@ - Scan results now carry the advertisement's service data and manufacturer data (issue #238): `BleScanResult` gained - `bsrAdvertisement`, parsed by the new `Hatter.BleAdvertisement` + `bsrAdvertisement :: Either AdvertisementParseErrors + BleAdvertisement`, parsed by the new `Hatter.BleAdvertisement` module (re-exported from `Hatter.Ble`) with `serviceDataForUuid` for keyed lookup; service data is keyed by `NormalizedBleUuid`, - which moved into that module. Android passes `ScanRecord.getBytes()` through + which moved into that module. 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 diff --git a/hatter.cabal b/hatter.cabal index c9eac2b..f857f7f 100644 --- a/hatter.cabal +++ b/hatter.cabal @@ -121,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 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/Ble.hs b/src/Hatter/Ble.hs index f799c0a..683d3a5 100644 --- a/src/Hatter/Ble.hs +++ b/src/Hatter/Ble.hs @@ -142,9 +142,12 @@ data BleScanResult = BleScanResult { bsrDeviceName :: Text , bsrDeviceAddress :: BleDeviceAddress , bsrRssi :: Int - , bsrAdvertisement :: BleAdvertisement + , bsrAdvertisement :: Either AdvertisementParseErrors BleAdvertisement -- ^ Service data and manufacturer data broadcast in the - -- advertisement, see "Hatter.BleAdvertisement". + -- advertisement, or every defect found in a malformed one, 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,16 +593,24 @@ dispatchBleScanResult bleState cName cAddr cRssi advPtr advLength = do addrStr <- if cAddr == nullPtr then pure "" else pack <$> peekCString cAddr - advBytes <- if advPtr == nullPtr || advLength <= 0 + advertisementBytes <- if advPtr == nullPtr || advLength <= 0 then pure BS.empty else BS.packCStringLen (castPtr advPtr, CInt.toInt advLength) - let scanResult = BleScanResult - { bsrDeviceName = nameStr - , bsrDeviceAddress = BleDeviceAddress addrStr - , bsrRssi = CInt.toInt cRssi - , bsrAdvertisement = parseBleAdvertisement advBytes - } - callback scanResult + 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 defects -> hPutStrLn stderr + ("dispatchBleScanResult: malformed advertisement from " + ++ unpack addrStr ++ ": " ++ show defects) + 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 index d2ef4c4..a284589 100644 --- a/src/Hatter/BleAdvertisement.hs +++ b/src/Hatter/BleAdvertisement.hs @@ -16,17 +16,22 @@ module Hatter.BleAdvertisement ( BleAdvertisement(..) , NormalizedBleUuid(..) , ManufacturerId(..) + , AdvertisementParseError(..) + , AdvertisementParseErrors(..) , emptyBleAdvertisement , parseBleAdvertisement , serviceDataForUuid ) where +import Data.Bits (shiftL, (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS -import Data.Char (intToDigit) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Text (Text) import Data.Text qualified as Text -import Data.Word (Word8, Word16) +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 -- | A UUID string normalized to lowercase for comparisons. UUIDs are @@ -63,6 +68,35 @@ data BleAdvertisement = BleAdvertisement newtype ManufacturerId = ManufacturerId { unManufacturerId :: Word16 } deriving (Show, Eq, Ord) +-- | One malformed AD structure: what failed, why, and where (every +-- constructor carries the byte offset of the offending structure's +-- length byte within the raw advertisement). +data AdvertisementParseError + = -- | A structure declares more bytes than the advertisement still + -- holds, so it (and anything after it) cannot be framed. + AdStructureTruncated + Int -- ^ Byte offset of the structure's length byte. + Int -- ^ Length the structure declares. + Int -- ^ Bytes actually remaining after the length byte. + | -- | A service data structure too short to hold the UUID its AD + -- type promises. + ServiceDataUuidTruncated + Int -- ^ Byte offset of the structure's length byte. + Word8 -- ^ The AD type (0x16, 0x20 or 0x21). + Int -- ^ UUID width in bytes that AD type requires. + Int -- ^ Bytes the structure actually carries after the type. + | -- | A manufacturer data structure too short to hold the 2-byte + -- company identifier. + ManufacturerDataTooShort + Int -- ^ Byte offset of the structure's length byte. + 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) + -- | An advertisement carrying no service or manufacturer data (also -- what desktop's stubbed scan and payload-less advertisements parse -- to). @@ -73,72 +107,112 @@ emptyBleAdvertisement = BleAdvertisement } -- | Parse raw AD structures. A zero length byte ends the data --- (Android's @ScanRecord.getBytes()@ zero-pads to the fixed --- advertisement buffer size); a structure whose length exceeds the --- remaining bytes is dropped along with everything after it. +-- cleanly: it is the value Android's @ScanRecord.getBytes()@ pads +-- the fixed advertisement buffer with, not a defect. -- --- Decision: tolerate malformed input instead of failing. The bytes --- come straight off the air from arbitrary third-party devices, so a --- garbled advertisement must degrade to "no payload", never take the --- app down or suppress the scan result carrying it. -parseBleAdvertisement :: ByteString -> BleAdvertisement +-- 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 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 AdvertisementParseErrors BleAdvertisement parseBleAdvertisement bytes = + case parseAdStructuresFrom 0 bytes of + (advertisement, []) -> Right advertisement + (_, firstDefect : moreDefects) -> + Left (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 :: Int -> ByteString -> (BleAdvertisement, [AdvertisementParseError]) +parseAdStructuresFrom offset bytes = case BS.uncons bytes of - Nothing -> emptyBleAdvertisement + Nothing -> (emptyBleAdvertisement, []) Just (lengthByte, afterLength) -> let structureLength = Word8.toInt lengthByte - -- The zero check also guards the recursion: a zero-length - -- structure would drop zero bytes and loop here forever. - in if lengthByte == 0 || BS.length afterLength < structureLength - then emptyBleAdvertisement - else - let structure = BS.take structureLength afterLength - parsedRest = parseBleAdvertisement (BS.drop structureLength afterLength) - in case BS.uncons structure of - Nothing -> parsedRest - Just (adType, payload) -> addAdStructure adType payload parsedRest + 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 offset structureLength (BS.length afterLength)] + ) + | otherwise -> + -- In bounds: structureLength >= 1 was just established. + let adType = BS.index afterLength 0 + payload = BS.take (structureLength - 1) (BS.drop 1 afterLength) + (restAdvertisement, restDefects) = + parseAdStructuresFrom (offset + 1 + structureLength) + (BS.drop structureLength afterLength) + in 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. Only the payload-bearing types are kept: service --- data at each UUID width (0x16, 0x20, 0x21) and manufacturer data --- (0xFF). Names, flags and service-class UUID lists are dropped; the --- platforms already surface the name, and the UUID lists carry no --- payload. -addAdStructure :: Word8 -> ByteString -> BleAdvertisement -> BleAdvertisement -addAdStructure adType payload advertisement = if - | adType == 0x16 -> addServiceData 2 payload advertisement - | adType == 0x20 -> addServiceData 4 payload advertisement - | adType == 0x21 -> addServiceData 16 payload advertisement - | adType == 0xFF -> addManufacturerData payload advertisement - | otherwise -> advertisement +-- 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 + :: Int + -> 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. Too short to hold its UUID means a --- malformed structure, which is skipped (see 'parseBleAdvertisement' --- on tolerating air garbage). -addServiceData :: Int -> ByteString -> BleAdvertisement -> BleAdvertisement -addServiceData uuidWidth payload advertisement = +-- byte width, then the payload. A structure too short to hold its +-- UUID is reported with the widths involved. +addServiceData + :: Int + -> Word8 + -> Int + -> ByteString + -> BleAdvertisement + -> Either AdvertisementParseError BleAdvertisement +addServiceData offset adType uuidWidth payload advertisement = if BS.length payload < uuidWidth - then advertisement + then Left (ServiceDataUuidTruncated offset adType uuidWidth (BS.length payload)) else let (uuidBytes, dataBytes) = BS.splitAt uuidWidth payload - in advertisement { advServiceData = - (normalizedUuidFromLittleEndian uuidBytes, dataBytes) - : advServiceData advertisement } + in Right advertisement { advServiceData = + (normalizedUuidFromLittleEndian uuidBytes, dataBytes) + : advServiceData advertisement } -- | Prepend one manufacturer data entry: little-endian company --- identifier, then the payload. -addManufacturerData :: ByteString -> BleAdvertisement -> BleAdvertisement -addManufacturerData payload advertisement = +-- identifier, then the payload. A structure too short to hold the +-- company identifier is reported with its actual size. +addManufacturerData + :: Int + -> ByteString + -> BleAdvertisement + -> Either AdvertisementParseError BleAdvertisement +addManufacturerData offset payload advertisement = if BS.length payload < 2 - then advertisement + then Left (ManufacturerDataTooShort offset (BS.length payload)) else let companyId = Word8.toWord16 (BS.index payload 1) * 256 + Word8.toWord16 (BS.index payload 0) dataBytes = BS.drop 2 payload - in advertisement { advManufacturerData = - (ManufacturerId companyId, dataBytes) - : advManufacturerData advertisement } + in Right advertisement { advManufacturerData = + (ManufacturerId companyId, dataBytes) + : advManufacturerData advertisement } -- | Look up a service data payload by UUID text -- (case-insensitively). Accepts the same 128-bit form used across @@ -147,40 +221,45 @@ serviceDataForUuid :: Text -> BleAdvertisement -> Maybe ByteString serviceDataForUuid uuid advertisement = lookup (NormalizedBleUuid (Text.toLower uuid)) (advServiceData advertisement) --- | The last 12 bytes of the Bluetooth base UUID +-- | Words 2 to 4 of the Bluetooth base UUID -- (@xxxxxxxx-0000-1000-8000-00805F9B34FB@), which 16- and 32-bit -- UUIDs are an alias into. -bluetoothBaseUuidTail :: ByteString -bluetoothBaseUuidTail = BS.pack - [0x00, 0x00, 0x10, 0x00, 0x80, 0x00, 0x00, 0x80, 0x5F, 0x9B, 0x34, 0xFB] +bluetoothBaseUuidWord2 :: Word32 +bluetoothBaseUuidWord2 = 0x00001000 + +bluetoothBaseUuidWord3 :: Word32 +bluetoothBaseUuidWord3 = 0x80000080 + +bluetoothBaseUuidWord4 :: Word32 +bluetoothBaseUuidWord4 = 0x5F9B34FB -- | Render an advertisement UUID (2, 4 or 16 bytes little-endian on --- air) as a full 128-bit 'NormalizedBleUuid' (the hex rendering is --- lowercase by construction). +-- air) as a full 128-bit 'NormalizedBleUuid'; 'UUID.toText' renders +-- the canonical lowercase form. normalizedUuidFromLittleEndian :: ByteString -> NormalizedBleUuid normalizedUuidFromLittleEndian uuidBytes = let bigEndian = BS.reverse uuidBytes - full = if BS.length bigEndian == 16 - then bigEndian - else BS.replicate (4 - BS.length bigEndian) 0x00 - <> bigEndian - <> bluetoothBaseUuidTail - in NormalizedBleUuid (formatUuid128 full) - --- | Format 16 big-endian bytes as @xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx@. -formatUuid128 :: ByteString -> Text -formatUuid128 bigEndian = - let hexText = Text.pack (concatMap hexByte (BS.unpack bigEndian)) - in Text.intercalate "-" - [ Text.take 8 hexText - , Text.take 4 (Text.drop 8 hexText) - , Text.take 4 (Text.drop 12 hexText) - , Text.take 4 (Text.drop 16 hexText) - , Text.drop 20 hexText - ] - --- | Two lowercase hex digits for one byte. -hexByte :: Word8 -> String -hexByte byte = - let (high, low) = Word8.toInt byte `divMod` 16 - in [intToDigit high, intToDigit low] + in NormalizedBleUuid (UUID.toText (if BS.length bigEndian == 16 + then uuidFromBigEndianBytes bigEndian + else UUID.fromWords + (word32BigEndianAt (BS.replicate (4 - BS.length bigEndian) 0x00 <> bigEndian) 0) + bluetoothBaseUuidWord2 + bluetoothBaseUuidWord3 + bluetoothBaseUuidWord4)) + +-- | Build a 'UUID' from its 16 big-endian bytes. +uuidFromBigEndianBytes :: ByteString -> 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 (bounds +-- already checked by callers). +word32BigEndianAt :: ByteString -> Int -> Word32 +word32BigEndianAt bytes offset = + Word8.toWord32 (BS.index bytes offset) `shiftL` 24 + .|. Word8.toWord32 (BS.index bytes (offset + 1)) `shiftL` 16 + .|. Word8.toWord32 (BS.index bytes (offset + 2)) `shiftL` 8 + .|. Word8.toWord32 (BS.index bytes (offset + 3)) diff --git a/test/BleDemoMain.hs b/test/BleDemoMain.hs index 876421e..8b795e4 100644 --- a/test/BleDemoMain.hs +++ b/test/BleDemoMain.hs @@ -179,10 +179,14 @@ main = do logAndRememberScanResult :: IORef (Maybe BleDeviceAddress) -> BleScanResult -> IO () logAndRememberScanResult lastAddressRef scanResult = do platformLog ("BLE scan result: " <> pack (show scanResult)) - mapM_ (\(uuid, payload) -> - platformLog ("BLE adv service data: " <> unNormalizedBleUuid uuid - <> "=" <> pack (show (BS.unpack payload)))) - (advServiceData (bsrAdvertisement scanResult)) + case bsrAdvertisement scanResult of + Left parseErrors -> + platformLog ("BLE adv parse errors: " <> pack (show parseErrors)) + Right advertisement -> + mapM_ (\(uuid, payload) -> + platformLog ("BLE adv service data: " <> unNormalizedBleUuid uuid + <> "=" <> pack (show (BS.unpack payload)))) + (advServiceData advertisement) writeIORef lastAddressRef (Just (bsrDeviceAddress scanResult)) -- | Address the Connect button targets: the last discovered device, diff --git a/test/Test/PlatformTests.hs b/test/Test/PlatformTests.hs index b437754..2a994f4 100644 --- a/test/Test/PlatformTests.hs +++ b/test/Test/PlatformTests.hs @@ -21,6 +21,7 @@ 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.List.NonEmpty (NonEmpty(..)) import Data.Text qualified as Text import Foreign.C.String (newCString) import Foreign.Marshal.Alloc (free) @@ -68,6 +69,8 @@ import Hatter.Ble , BleAdvertisement(..) , NormalizedBleUuid(..) , ManufacturerId(..) + , AdvertisementParseError(..) + , AdvertisementParseErrors(..) , emptyBleAdvertisement , parseBleAdvertisement , serviceDataForUuid @@ -434,7 +437,7 @@ bleTests ffiBleState = testGroup "BLE" bsrDeviceName scanResult @?= "TestDevice" bsrDeviceAddress scanResult @?= BleDeviceAddress "AA:BB:CC:DD:EE:FF" bsrRssi scanResult @?= (-42) - bsrAdvertisement scanResult @?= emptyBleAdvertisement + bsrAdvertisement scanResult @?= Right emptyBleAdvertisement , testCase "dispatchBleScanResult with no active scan is no-op" $ do bleState <- newBleState @@ -518,14 +521,14 @@ bleTests ffiBleState = testGroup "BLE" case result of Nothing -> assertFailure "callback should have been fired" Just scanResult -> - serviceDataForUuid "00002080-0000-1000-8000-00805F9B34FB" + fmap (serviceDataForUuid "00002080-0000-1000-8000-00805F9B34FB") (bsrAdvertisement scanResult) - @?= Just (BS.pack [0x55, 0x00, 0x01, 0xF6]) + @?= 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]) - @?= BleAdvertisement + @?= Right BleAdvertisement { advServiceData = [(NormalizedBleUuid "0000feed-0000-1000-8000-00805f9b34fb", BS.pack [0x2A, 0x63])] , advManufacturerData = [] @@ -541,7 +544,7 @@ bleTests ffiBleState = testGroup "BLE" , 0x38, 0x47, 0xC4, 0x8A, 0x5C, 0x50, 0xDB, 0x50 , 0x7F ]) - @?= BleAdvertisement + @?= Right BleAdvertisement { advServiceData = [(NormalizedBleUuid "50db505c-8ac4-4738-8448-3b1d9cc09cc5", BS.pack [0x7F])] , advManufacturerData = [] @@ -550,7 +553,7 @@ bleTests ffiBleState = testGroup "BLE" , testCase "parseBleAdvertisement reads manufacturer data" $ -- KKM's company id 0x0A53, little-endian on air. parseBleAdvertisement (BS.pack [0x04, 0xFF, 0x53, 0x0A, 0x21]) - @?= BleAdvertisement + @?= Right BleAdvertisement { advServiceData = [] , advManufacturerData = [(ManufacturerId 0x0A53, BS.pack [0x21])] } @@ -562,7 +565,7 @@ bleTests ffiBleState = testGroup "BLE" , 0x03, 0xFF, 0x4C, 0x00 , 0x04, 0x16, 0x80, 0x20, 0x02 ]) - @?= BleAdvertisement + @?= Right BleAdvertisement { advServiceData = [ (NormalizedBleUuid "0000feaa-0000-1000-8000-00805f9b34fb", BS.pack [0x01]) , (NormalizedBleUuid "00002080-0000-1000-8000-00805f9b34fb", BS.pack [0x02]) @@ -575,30 +578,37 @@ bleTests ffiBleState = testGroup "BLE" -- size; the padding must not become phantom entries. parseBleAdvertisement (BS.pack [0x05, 0x16, 0xED, 0xFE, 0x2A, 0x63, 0x00, 0x00, 0x00, 0x00]) - @?= BleAdvertisement + @?= Right BleAdvertisement { advServiceData = [(NormalizedBleUuid "0000feed-0000-1000-8000-00805f9b34fb", BS.pack [0x2A, 0x63])] , advManufacturerData = [] } - , testCase "parseBleAdvertisement drops a truncated tail" $ - -- The final structure claims 9 bytes but only 3 follow. + , testCase "parseBleAdvertisement reports a truncated structure with its offset" $ + -- The second structure (length byte at offset 5) claims 9 + -- bytes but only 3 follow. parseBleAdvertisement (BS.pack [0x04, 0xFF, 0x53, 0x0A, 0x21, 0x09, 0x16, 0xED, 0xFE]) - @?= BleAdvertisement - { advServiceData = [] - , advManufacturerData = [(ManufacturerId 0x0A53, BS.pack [0x21])] - } + @?= Left (AdvertisementParseErrors (AdStructureTruncated 5 9 3 :| [])) + + , 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. + parseBleAdvertisement + (BS.pack [0x02, 0x16, 0xED, 0x02, 0xFF, 0x53]) + @?= Left (AdvertisementParseErrors + (ServiceDataUuidTruncated 0 0x16 2 1 + :| [ManufacturerDataTooShort 3 1])) , testCase "serviceDataForUuid is case-insensitive" $ do - let adv = parseBleAdvertisement + let parsed = parseBleAdvertisement (BS.pack [0x05, 0x16, 0x80, 0x20, 0x55, 0x63]) - serviceDataForUuid "00002080-0000-1000-8000-00805F9B34FB" adv - @?= Just (BS.pack [0x55, 0x63]) - serviceDataForUuid "00002080-0000-1000-8000-00805f9b34fb" adv - @?= Just (BS.pack [0x55, 0x63]) - serviceDataForUuid "0000FEAA-0000-1000-8000-00805F9B34FB" adv - @?= Nothing + fmap (serviceDataForUuid "00002080-0000-1000-8000-00805F9B34FB") parsed + @?= Right (Just (BS.pack [0x55, 0x63])) + fmap (serviceDataForUuid "00002080-0000-1000-8000-00805f9b34fb") parsed + @?= Right (Just (BS.pack [0x55, 0x63])) + fmap (serviceDataForUuid "0000FEAA-0000-1000-8000-00805F9B34FB") parsed + @?= Right Nothing , testCase "bleConnectionEventFromInt roundtrips all constructors" $ do let allEvents = [BleConnectionEstablished, BleConnectionClosed, BleConnectionFailed] From c346ce3a6b4b288534855893b8b96587c7516144 Mon Sep 17 00:00:00 2001 From: jappeace-sloth Date: Mon, 13 Jul 2026 19:35:35 +0200 Subject: [PATCH 05/13] Newtype the AD structure byte offset The offset threaded through four parser functions and stored in all three error constructors was a bare Int, and sat next to the equally bare uuidWidth Int in addServiceData where the two could transpose without a type error. AdStructureOffset makes that mistake unrepresentable. Co-Authored-By: Claude Fable 5 --- src/Hatter/BleAdvertisement.hs | 36 ++++++++++++++++++++++------------ test/Test/PlatformTests.hs | 7 ++++--- 2 files changed, 28 insertions(+), 15 deletions(-) diff --git a/src/Hatter/BleAdvertisement.hs b/src/Hatter/BleAdvertisement.hs index a284589..82f2a4a 100644 --- a/src/Hatter/BleAdvertisement.hs +++ b/src/Hatter/BleAdvertisement.hs @@ -18,6 +18,7 @@ module Hatter.BleAdvertisement , ManufacturerId(..) , AdvertisementParseError(..) , AdvertisementParseErrors(..) + , AdStructureOffset(..) , emptyBleAdvertisement , parseBleAdvertisement , serviceDataForUuid @@ -68,27 +69,31 @@ data BleAdvertisement = BleAdvertisement newtype ManufacturerId = ManufacturerId { unManufacturerId :: Word16 } deriving (Show, Eq, Ord) --- | One malformed AD structure: what failed, why, and where (every --- constructor carries the byte offset of the offending structure's --- length byte within the raw advertisement). +-- | 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. data AdvertisementParseError = -- | A structure declares more bytes than the advertisement still -- holds, so it (and anything after it) cannot be framed. AdStructureTruncated - Int -- ^ Byte offset of the structure's length byte. + AdStructureOffset -- ^ Where the structure starts. Int -- ^ Length the structure declares. Int -- ^ Bytes actually remaining after the length byte. | -- | A service data structure too short to hold the UUID its AD -- type promises. ServiceDataUuidTruncated - Int -- ^ Byte offset of the structure's length byte. + AdStructureOffset -- ^ Where the structure starts. Word8 -- ^ The AD type (0x16, 0x20 or 0x21). Int -- ^ UUID width in bytes that AD type requires. Int -- ^ Bytes the structure actually carries after the type. | -- | A manufacturer data structure too short to hold the 2-byte -- company identifier. ManufacturerDataTooShort - Int -- ^ Byte offset of the structure's length byte. + AdStructureOffset -- ^ Where the structure starts. Int -- ^ Bytes the structure actually carries after the type. deriving (Show, Eq) @@ -121,7 +126,7 @@ emptyBleAdvertisement = BleAdvertisement -- hides the device that sent it. parseBleAdvertisement :: ByteString -> Either AdvertisementParseErrors BleAdvertisement parseBleAdvertisement bytes = - case parseAdStructuresFrom 0 bytes of + case parseAdStructuresFrom (AdStructureOffset 0) bytes of (advertisement, []) -> Right advertisement (_, firstDefect : moreDefects) -> Left (AdvertisementParseErrors (firstDefect :| moreDefects)) @@ -130,7 +135,8 @@ parseBleAdvertisement bytes = -- 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 :: Int -> ByteString -> (BleAdvertisement, [AdvertisementParseError]) +parseAdStructuresFrom + :: AdStructureOffset -> ByteString -> (BleAdvertisement, [AdvertisementParseError]) parseAdStructuresFrom offset bytes = case BS.uncons bytes of Nothing -> (emptyBleAdvertisement, []) @@ -150,7 +156,7 @@ parseAdStructuresFrom offset bytes = let adType = BS.index afterLength 0 payload = BS.take (structureLength - 1) (BS.drop 1 afterLength) (restAdvertisement, restDefects) = - parseAdStructuresFrom (offset + 1 + structureLength) + parseAdStructuresFrom (nextStructureOffset offset structureLength) (BS.drop structureLength afterLength) in case addAdStructure offset adType payload restAdvertisement of Right grown -> (grown, restDefects) @@ -164,7 +170,7 @@ parseAdStructuresFrom offset bytes = -- service-class UUID lists), not defects: the platforms already -- deliver the name and the rest carries no payload. addAdStructure - :: Int + :: AdStructureOffset -> Word8 -> ByteString -> BleAdvertisement @@ -180,7 +186,7 @@ addAdStructure offset adType payload advertisement = if -- byte width, then the payload. A structure too short to hold its -- UUID is reported with the widths involved. addServiceData - :: Int + :: AdStructureOffset -> Word8 -> Int -> ByteString @@ -199,7 +205,7 @@ addServiceData offset adType uuidWidth payload advertisement = -- identifier, then the payload. A structure too short to hold the -- company identifier is reported with its actual size. addManufacturerData - :: Int + :: AdStructureOffset -> ByteString -> BleAdvertisement -> Either AdvertisementParseError BleAdvertisement @@ -214,6 +220,12 @@ addManufacturerData offset payload advertisement = (ManufacturerId companyId, dataBytes) : advManufacturerData advertisement } +-- | 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 UUID text -- (case-insensitively). Accepts the same 128-bit form used across -- "Hatter.Ble", e.g. @"00002080-0000-1000-8000-00805F9B34FB"@. diff --git a/test/Test/PlatformTests.hs b/test/Test/PlatformTests.hs index 2a994f4..7ac776e 100644 --- a/test/Test/PlatformTests.hs +++ b/test/Test/PlatformTests.hs @@ -71,6 +71,7 @@ import Hatter.Ble , ManufacturerId(..) , AdvertisementParseError(..) , AdvertisementParseErrors(..) + , AdStructureOffset(..) , emptyBleAdvertisement , parseBleAdvertisement , serviceDataForUuid @@ -589,7 +590,7 @@ bleTests ffiBleState = testGroup "BLE" -- bytes but only 3 follow. parseBleAdvertisement (BS.pack [0x04, 0xFF, 0x53, 0x0A, 0x21, 0x09, 0x16, 0xED, 0xFE]) - @?= Left (AdvertisementParseErrors (AdStructureTruncated 5 9 3 :| [])) + @?= Left (AdvertisementParseErrors (AdStructureTruncated (AdStructureOffset 5) 9 3 :| [])) , testCase "parseBleAdvertisement accumulates every defect" $ -- Service data too short for its 16-bit UUID at offset 0, then @@ -597,8 +598,8 @@ bleTests ffiBleState = testGroup "BLE" parseBleAdvertisement (BS.pack [0x02, 0x16, 0xED, 0x02, 0xFF, 0x53]) @?= Left (AdvertisementParseErrors - (ServiceDataUuidTruncated 0 0x16 2 1 - :| [ManufacturerDataTooShort 3 1])) + (ServiceDataUuidTruncated (AdStructureOffset 0) 0x16 2 1 + :| [ManufacturerDataTooShort (AdStructureOffset 3) 1])) , testCase "serviceDataForUuid is case-insensitive" $ do let parsed = parseBleAdvertisement From 7bdc8a7e4fd818a497ca8efce058e693d0f777ff Mon Sep 17 00:00:00 2001 From: jappeace-sloth Date: Mon, 13 Jul 2026 19:53:12 +0200 Subject: [PATCH 06/13] collect-deps: skip already-collected .conf files A package can reach the collector twice, once through a consumer's resolved deps and once through hatterOwnDeps (hashable did, as a dep of both unordered-containers and the new uuid-types), and the second cp of the same .conf into the read-only output failed with Permission denied. Guard the .conf copy like the .a copies already are. This is the dedup fix kbeacon's consumer-cabal2nix Decision comment deferred to hatter. Co-Authored-By: Claude Fable 5 --- nix/collect-deps.nix | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) 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 From 1f6eb08f81300679891d48cb7c04e5cdfad1218b Mon Sep 17 00:00:00 2001 From: jappeace-sloth Date: Mon, 13 Jul 2026 22:13:21 +0200 Subject: [PATCH 07/13] ci: give macos-apk 180 minutes for uncached cross closures The job's VM builds anything missing from nix-cache.jappie.me under TCG emulation on every run (its store is ephemeral, so the host-side actions cache cannot help), and the uuid-types closure from PR #239 hit the 120-minute timeout at exactly 2h00m (run 29272233710, step cancelled 12 seconds after start+120min). Raise the budget so an uncached closure can complete; cached runs stay at ~45 minutes. Co-Authored-By: Claude Fable 5 --- .github/workflows/ci.yaml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) 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 From 7b6199a37acb6f7566d675d55a9781f9866bfbb8 Mon Sep 17 00:00:00 2001 From: jappeace-sloth Date: Mon, 13 Jul 2026 23:10:58 +0200 Subject: [PATCH 08/13] ci: retrigger after the ios simulator test hit the 45-minute timeout The ios build itself passed; the combined simulator test step was cancelled at the job timeout, the known flake class from issue #235 (same remedy as 9dcf105). Co-Authored-By: Claude Fable 5 From 69e1ec3415fad87d08618de89847dcbf963e7159 Mon Sep 17 00:00:00 2001 From: jappeace-sloth Date: Tue, 14 Jul 2026 10:18:28 +0200 Subject: [PATCH 09/13] Per-error record types; replace partial BS.index with indexMaybe Review round 2 on #239: - Every AdvertisementParseError constructor now wraps its own record (AdStructureTruncation, ServiceDataTruncation, ManufacturerDataTruncation) bundling the offset with the sizes, so the fields have total record accessors instead of positional Ints. - All BS.index uses are gone: word32BigEndianAt chains BS.indexMaybe and pushes Maybe into its signature, normalizedUuidFromLittleEndian returns Maybe (Nothing unless the slice is exactly 2, 4 or 16 bytes), and addServiceData consumes that Maybe as its truncation check, leaving one place that decides what a valid UUID slice is. addManufacturerData reads its two company-id bytes via indexMaybe with all four cases written out. The structure walker peels the type byte with BS.uncons on the already-split structure instead of an index. Prompt: address the review comments in hatter Co-Authored-By: Claude Fable 5 --- src/Hatter/BleAdvertisement.hs | 167 +++++++++++++++++++++------------ test/Test/PlatformTests.hs | 11 ++- 2 files changed, 116 insertions(+), 62 deletions(-) diff --git a/src/Hatter/BleAdvertisement.hs b/src/Hatter/BleAdvertisement.hs index 82f2a4a..5d4c627 100644 --- a/src/Hatter/BleAdvertisement.hs +++ b/src/Hatter/BleAdvertisement.hs @@ -19,6 +19,9 @@ module Hatter.BleAdvertisement , AdvertisementParseError(..) , AdvertisementParseErrors(..) , AdStructureOffset(..) + , AdStructureTruncation(..) + , ServiceDataTruncation(..) + , ManufacturerDataTruncation(..) , emptyBleAdvertisement , parseBleAdvertisement , serviceDataForUuid @@ -75,28 +78,52 @@ newtype ManufacturerId = ManufacturerId { unManufacturerId :: Word16 } newtype AdStructureOffset = AdStructureOffset { unAdStructureOffset :: Int } deriving (Show, Eq) --- | One malformed AD structure: what failed, why, and where. +-- | 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 - AdStructureOffset -- ^ Where the structure starts. - Int -- ^ Length the structure declares. - Int -- ^ Bytes actually remaining after the length byte. + AdStructureTruncated AdStructureTruncation | -- | A service data structure too short to hold the UUID its AD -- type promises. - ServiceDataUuidTruncated - AdStructureOffset -- ^ Where the structure starts. - Word8 -- ^ The AD type (0x16, 0x20 or 0x21). - Int -- ^ UUID width in bytes that AD type requires. - Int -- ^ Bytes the structure actually carries after the type. + ServiceDataUuidTruncated ServiceDataTruncation | -- | A manufacturer data structure too short to hold the 2-byte -- company identifier. - ManufacturerDataTooShort - AdStructureOffset -- ^ Where the structure starts. - Int -- ^ Bytes the structure actually carries after the type. + 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 } @@ -149,18 +176,23 @@ parseAdStructuresFrom offset bytes = | lengthByte == 0 -> (emptyBleAdvertisement, []) | BS.length afterLength < structureLength -> ( emptyBleAdvertisement - , [AdStructureTruncated offset structureLength (BS.length afterLength)] + , [AdStructureTruncated (AdStructureTruncation offset structureLength + (BS.length afterLength))] ) | otherwise -> - -- In bounds: structureLength >= 1 was just established. - let adType = BS.index afterLength 0 - payload = BS.take (structureLength - 1) (BS.drop 1 afterLength) + let (structure, remainder) = BS.splitAt structureLength afterLength (restAdvertisement, restDefects) = parseAdStructuresFrom (nextStructureOffset offset structureLength) - (BS.drop structureLength afterLength) - in case addAdStructure offset adType payload restAdvertisement of - Right grown -> (grown, restDefects) - Left defect -> (restAdvertisement, defect : restDefects) + 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 @@ -184,7 +216,9 @@ addAdStructure offset adType payload advertisement = if -- | 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. +-- UUID is reported with the widths involved; the check IS +-- 'normalizedUuidFromLittleEndian' declining the short slice, so +-- there is exactly one place deciding what a valid UUID is. addServiceData :: AdStructureOffset -> Word8 @@ -193,13 +227,12 @@ addServiceData -> BleAdvertisement -> Either AdvertisementParseError BleAdvertisement addServiceData offset adType uuidWidth payload advertisement = - if BS.length payload < uuidWidth - then Left (ServiceDataUuidTruncated offset adType uuidWidth (BS.length payload)) - else - let (uuidBytes, dataBytes) = BS.splitAt uuidWidth payload - in Right advertisement { advServiceData = - (normalizedUuidFromLittleEndian uuidBytes, dataBytes) - : advServiceData advertisement } + let (uuidBytes, dataBytes) = BS.splitAt uuidWidth payload + in case normalizedUuidFromLittleEndian 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 @@ -210,15 +243,19 @@ addManufacturerData -> BleAdvertisement -> Either AdvertisementParseError BleAdvertisement addManufacturerData offset payload advertisement = - if BS.length payload < 2 - then Left (ManufacturerDataTooShort offset (BS.length payload)) - else - let companyId = Word8.toWord16 (BS.index payload 1) * 256 - + Word8.toWord16 (BS.index payload 0) + 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. @@ -245,33 +282,45 @@ bluetoothBaseUuidWord3 = 0x80000080 bluetoothBaseUuidWord4 :: Word32 bluetoothBaseUuidWord4 = 0x5F9B34FB --- | Render an advertisement UUID (2, 4 or 16 bytes little-endian on --- air) as a full 128-bit 'NormalizedBleUuid'; 'UUID.toText' renders --- the canonical lowercase form. -normalizedUuidFromLittleEndian :: ByteString -> NormalizedBleUuid +-- | Render an advertisement UUID as a full 128-bit +-- 'NormalizedBleUuid'; 'UUID.toText' renders the canonical lowercase +-- form. Nothing unless the input is exactly 2, 4 or 16 bytes (the +-- little-endian on-air widths), which is how 'addServiceData' +-- detects a structure too short for its UUID. +normalizedUuidFromLittleEndian :: ByteString -> Maybe NormalizedBleUuid normalizedUuidFromLittleEndian uuidBytes = let bigEndian = BS.reverse uuidBytes - in NormalizedBleUuid (UUID.toText (if BS.length bigEndian == 16 - then uuidFromBigEndianBytes bigEndian - else UUID.fromWords - (word32BigEndianAt (BS.replicate (4 - BS.length bigEndian) 0x00 <> bigEndian) 0) - bluetoothBaseUuidWord2 - bluetoothBaseUuidWord3 - bluetoothBaseUuidWord4)) + uuid = if BS.length bigEndian == 16 + then uuidFromBigEndianBytes bigEndian + else if BS.length bigEndian == 2 || BS.length bigEndian == 4 + then fmap + (\value -> UUID.fromWords value + bluetoothBaseUuidWord2 + bluetoothBaseUuidWord3 + bluetoothBaseUuidWord4) + (word32BigEndianAt + (BS.replicate (4 - BS.length bigEndian) 0x00 <> bigEndian) 0) + else Nothing + in fmap (NormalizedBleUuid . UUID.toText) uuid --- | Build a 'UUID' from its 16 big-endian bytes. -uuidFromBigEndianBytes :: ByteString -> UUID +-- | 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) + <$> word32BigEndianAt bigEndian 0 + <*> word32BigEndianAt bigEndian 4 + <*> word32BigEndianAt bigEndian 8 + <*> word32BigEndianAt bigEndian 12 --- | Big-endian 32-bit word starting at the given offset (bounds --- already checked by callers). -word32BigEndianAt :: ByteString -> Int -> Word32 -word32BigEndianAt bytes offset = - Word8.toWord32 (BS.index bytes offset) `shiftL` 24 - .|. Word8.toWord32 (BS.index bytes (offset + 1)) `shiftL` 16 - .|. Word8.toWord32 (BS.index bytes (offset + 2)) `shiftL` 8 - .|. Word8.toWord32 (BS.index bytes (offset + 3)) +-- | 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/Test/PlatformTests.hs b/test/Test/PlatformTests.hs index 7ac776e..13a8601 100644 --- a/test/Test/PlatformTests.hs +++ b/test/Test/PlatformTests.hs @@ -72,6 +72,9 @@ import Hatter.Ble , AdvertisementParseError(..) , AdvertisementParseErrors(..) , AdStructureOffset(..) + , AdStructureTruncation(..) + , ServiceDataTruncation(..) + , ManufacturerDataTruncation(..) , emptyBleAdvertisement , parseBleAdvertisement , serviceDataForUuid @@ -590,7 +593,7 @@ bleTests ffiBleState = testGroup "BLE" -- bytes but only 3 follow. parseBleAdvertisement (BS.pack [0x04, 0xFF, 0x53, 0x0A, 0x21, 0x09, 0x16, 0xED, 0xFE]) - @?= Left (AdvertisementParseErrors (AdStructureTruncated (AdStructureOffset 5) 9 3 :| [])) + @?= Left (AdvertisementParseErrors (AdStructureTruncated (AdStructureTruncation (AdStructureOffset 5) 9 3) :| [])) , testCase "parseBleAdvertisement accumulates every defect" $ -- Service data too short for its 16-bit UUID at offset 0, then @@ -598,8 +601,10 @@ bleTests ffiBleState = testGroup "BLE" parseBleAdvertisement (BS.pack [0x02, 0x16, 0xED, 0x02, 0xFF, 0x53]) @?= Left (AdvertisementParseErrors - (ServiceDataUuidTruncated (AdStructureOffset 0) 0x16 2 1 - :| [ManufacturerDataTooShort (AdStructureOffset 3) 1])) + (ServiceDataUuidTruncated + (ServiceDataTruncation (AdStructureOffset 0) 0x16 2 1) + :| [ManufacturerDataTooShort + (ManufacturerDataTruncation (AdStructureOffset 3) 1)])) , testCase "serviceDataForUuid is case-insensitive" $ do let parsed = parseBleAdvertisement From c3445d756ec13417f972bfd7b27035079ce8d634 Mon Sep 17 00:00:00 2001 From: jappeace-sloth Date: Tue, 14 Jul 2026 10:30:03 +0200 Subject: [PATCH 10/13] Check the declared UUID width, not the slice's own length The indexMaybe refactor (69e1ec3) introduced a truncation-detection hole: addServiceData split the payload at the declared width and let normalizedUuidFromLittleEndian judge the slice by its own length, so a 0x21 structure (16-byte UUID) truncated to two bytes passed as a valid 16-bit UUID, and [0x80, 0x20] would read as 0x2080, the exact KKM identity UUID. The builder now takes the declared width and returns Nothing unless the slice has exactly that width, restoring the parent commit's behaviour with the single-decision-point shape kept. Regression tests cover 0x21 truncated to 2 and 4 bytes and 0x20 truncated to 2. Co-Authored-By: Claude Fable 5 --- src/Hatter/BleAdvertisement.hs | 43 +++++++++++++++++++--------------- test/Test/PlatformTests.hs | 17 ++++++++++++++ 2 files changed, 41 insertions(+), 19 deletions(-) diff --git a/src/Hatter/BleAdvertisement.hs b/src/Hatter/BleAdvertisement.hs index 5d4c627..ce466e6 100644 --- a/src/Hatter/BleAdvertisement.hs +++ b/src/Hatter/BleAdvertisement.hs @@ -228,7 +228,7 @@ addServiceData -> Either AdvertisementParseError BleAdvertisement addServiceData offset adType uuidWidth payload advertisement = let (uuidBytes, dataBytes) = BS.splitAt uuidWidth payload - in case normalizedUuidFromLittleEndian uuidBytes of + in case normalizedUuidFromLittleEndian uuidWidth uuidBytes of Nothing -> Left (ServiceDataUuidTruncated (ServiceDataTruncation offset adType uuidWidth (BS.length payload))) Just uuid -> Right advertisement { advServiceData = @@ -282,25 +282,30 @@ bluetoothBaseUuidWord3 = 0x80000080 bluetoothBaseUuidWord4 :: Word32 bluetoothBaseUuidWord4 = 0x5F9B34FB --- | Render an advertisement UUID as a full 128-bit --- 'NormalizedBleUuid'; 'UUID.toText' renders the canonical lowercase --- form. Nothing unless the input is exactly 2, 4 or 16 bytes (the --- little-endian on-air widths), which is how 'addServiceData' --- detects a structure too short for its UUID. -normalizedUuidFromLittleEndian :: ByteString -> Maybe NormalizedBleUuid -normalizedUuidFromLittleEndian uuidBytes = +-- | Render an advertisement UUID of the declared byte width as a +-- full 128-bit 'NormalizedBleUuid'; 'UUID.toText' renders the +-- canonical lowercase form. 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. +normalizedUuidFromLittleEndian :: Int -> ByteString -> Maybe NormalizedBleUuid +normalizedUuidFromLittleEndian declaredWidth uuidBytes = let bigEndian = BS.reverse uuidBytes - uuid = if BS.length bigEndian == 16 - then uuidFromBigEndianBytes bigEndian - else if BS.length bigEndian == 2 || BS.length bigEndian == 4 - then fmap - (\value -> UUID.fromWords value - bluetoothBaseUuidWord2 - bluetoothBaseUuidWord3 - bluetoothBaseUuidWord4) - (word32BigEndianAt - (BS.replicate (4 - BS.length bigEndian) 0x00 <> bigEndian) 0) - else Nothing + uuid = 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 in fmap (NormalizedBleUuid . UUID.toText) uuid -- | Build a 'UUID' from its 16 big-endian bytes; Nothing when fewer diff --git a/test/Test/PlatformTests.hs b/test/Test/PlatformTests.hs index 13a8601..25792d2 100644 --- a/test/Test/PlatformTests.hs +++ b/test/Test/PlatformTests.hs @@ -595,6 +595,23 @@ bleTests ffiBleState = testGroup "BLE" (BS.pack [0x04, 0xFF, 0x53, 0x0A, 0x21, 0x09, 0x16, 0xED, 0xFE]) @?= Left (AdvertisementParseErrors (AdStructureTruncated (AdStructureTruncation (AdStructureOffset 5) 9 3) :| [])) + , 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 (AdvertisementParseErrors + (ServiceDataUuidTruncated + (ServiceDataTruncation (AdStructureOffset 0) 0x21 16 2) :| [])) + parseBleAdvertisement (BS.pack [0x05, 0x21, 0x01, 0x02, 0x03, 0x04]) + @?= Left (AdvertisementParseErrors + (ServiceDataUuidTruncated + (ServiceDataTruncation (AdStructureOffset 0) 0x21 16 4) :| [])) + parseBleAdvertisement (BS.pack [0x03, 0x20, 0x80, 0x20]) + @?= Left (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. From 119e58cc4b50ad1be3f801efdac4d300f25d72c4 Mon Sep 17 00:00:00 2001 From: jappeace-sloth Date: Tue, 14 Jul 2026 10:37:49 +0200 Subject: [PATCH 11/13] Key service data by the UUID type itself, no text round-trip Review: converting the parsed UUID back to normalized text was silly. advServiceData is keyed by uuid-types' binary UUID now (comparisons cannot be bitten by platform case differences, by construction), uuidFromLittleEndian returns Maybe UUID, and serviceDataForUuid takes the UUID value; constants build with the total UUID.fromWords. Text conversion happens only at the logging edge (UUID.toText in the demo). NormalizedBleUuid returns to Hatter.Ble, where its remaining users (the characteristic keys) live. Prompt: one more review comment Co-Authored-By: Claude Fable 5 --- Changelog.md | 5 +- hatter.cabal | 3 +- src/Hatter/Ble.hs | 19 +++++++ src/Hatter/BleAdvertisement.hs | 98 ++++++++++++++-------------------- test/BleDemoMain.hs | 4 +- test/Test/PlatformTests.hs | 32 ++++++----- 6 files changed, 85 insertions(+), 76 deletions(-) diff --git a/Changelog.md b/Changelog.md index 929c077..e6662f7 100644 --- a/Changelog.md +++ b/Changelog.md @@ -9,8 +9,9 @@ `bsrAdvertisement :: Either AdvertisementParseErrors BleAdvertisement`, parsed by the new `Hatter.BleAdvertisement` module (re-exported from `Hatter.Ble`) with `serviceDataForUuid` - for keyed lookup; service data is keyed by `NormalizedBleUuid`, - which moved into that module. Malformed advertisements report + 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 diff --git a/hatter.cabal b/hatter.cabal index f857f7f..a781c20 100644 --- a/hatter.cabal +++ b/hatter.cabal @@ -255,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/src/Hatter/Ble.hs b/src/Hatter/Ble.hs index 683d3a5..4254f4d 100644 --- a/src/Hatter/Ble.hs +++ b/src/Hatter/Ble.hs @@ -25,6 +25,7 @@ module Hatter.Ble ( BleAdapterStatus(..) , BleScanResult(..) , module Hatter.BleAdvertisement + , NormalizedBleUuid(..) , BleDeviceAddress(..) , BleServiceUuid(..) , BleCharacteristicUuid(..) @@ -117,6 +118,24 @@ newtype BleCharacteristicUuid = BleCharacteristicUuid { unBleCharacteristicUuid deriving (Show, Eq, Ord) deriving newtype (IsString) +-- | A UUID string normalized to lowercase for comparisons. UUIDs are +-- case-insensitive per the Bluetooth spec, but the platforms disagree +-- on the case they report (Android lowercase, iOS uppercase), so raw +-- strings must never be compared directly. Constructed via +-- 'normalizeBleServiceUuid' \/ 'normalizeBleCharacteristicUuid'; +-- deliberately no 'IsString' instance, a literal would bypass the +-- normalization. +-- +-- Decision: case-insensitivity is a dedicated normalized newtype +-- built only through smart constructors. Alternatives considered: +-- lowercasing ad hoc at each comparison site (error-prone, exactly +-- how the original subscribe\/notify mismatch bug happened), and a +-- case-insensitive 'Ord' on the raw UUID newtypes (invisible at use +-- sites and surprising for anyone sorting or printing them). A type +-- that cannot exist un-normalized makes the mistake unrepresentable. +newtype NormalizedBleUuid = NormalizedBleUuid { unNormalizedBleUuid :: Text } + deriving (Show, Eq, Ord) + -- | Identifies one characteristic on the connected device: its -- containing service and its own UUID, case-normalized so lookups -- match across platforms. Used as the notification-callback key. diff --git a/src/Hatter/BleAdvertisement.hs b/src/Hatter/BleAdvertisement.hs index ce466e6..3e1e968 100644 --- a/src/Hatter/BleAdvertisement.hs +++ b/src/Hatter/BleAdvertisement.hs @@ -14,7 +14,7 @@ -- parser is the single decoding path for both platforms. module Hatter.BleAdvertisement ( BleAdvertisement(..) - , NormalizedBleUuid(..) + , UUID , ManufacturerId(..) , AdvertisementParseError(..) , AdvertisementParseErrors(..) @@ -31,39 +31,19 @@ import Data.Bits (shiftL, (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.List.NonEmpty (NonEmpty(..)) -import Data.Text (Text) -import Data.Text qualified as Text 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 --- | A UUID string normalized to lowercase for comparisons. UUIDs are --- case-insensitive per the Bluetooth spec, but the platforms disagree --- on the case they report (Android lowercase, iOS uppercase), so raw --- strings must never be compared directly. Constructed via --- 'Hatter.Ble.normalizeBleServiceUuid' \/ --- 'Hatter.Ble.normalizeBleCharacteristicUuid', or lowercase by --- construction in 'parseBleAdvertisement'; deliberately no 'IsString' --- instance, a literal would bypass the normalization. --- --- Decision: case-insensitivity is a dedicated normalized newtype --- built only through smart constructors. Alternatives considered: --- lowercasing ad hoc at each comparison site (error-prone, exactly --- how the original subscribe\/notify mismatch bug happened), and a --- case-insensitive 'Ord' on the raw UUID newtypes (invisible at use --- sites and surprising for anyone sorting or printing them). A type --- that cannot exist un-normalized makes the mistake unrepresentable. -newtype NormalizedBleUuid = NormalizedBleUuid { unNormalizedBleUuid :: Text } - deriving (Show, Eq, Ord) - -- | The advertisement fields a scan result carries beyond name, --- address and RSSI. Service data is keyed by the full 128-bit --- 'NormalizedBleUuid' (16- and 32-bit UUIDs are expanded with the --- Bluetooth base UUID); manufacturer data is keyed by the 16-bit --- company identifier. Entries keep their advertisement order. +-- 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 :: [(NormalizedBleUuid, ByteString)] + { advServiceData :: [(UUID, ByteString)] , advManufacturerData :: [(ManufacturerId, ByteString)] } deriving (Show, Eq) @@ -217,8 +197,8 @@ addAdStructure offset adType payload advertisement = if -- | 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 --- 'normalizedUuidFromLittleEndian' declining the short slice, so --- there is exactly one place deciding what a valid UUID is. +-- 'uuidFromLittleEndian' declining the short slice, so there is +-- exactly one place deciding what a valid UUID is. addServiceData :: AdStructureOffset -> Word8 @@ -228,7 +208,7 @@ addServiceData -> Either AdvertisementParseError BleAdvertisement addServiceData offset adType uuidWidth payload advertisement = let (uuidBytes, dataBytes) = BS.splitAt uuidWidth payload - in case normalizedUuidFromLittleEndian uuidWidth uuidBytes of + in case uuidFromLittleEndian uuidWidth uuidBytes of Nothing -> Left (ServiceDataUuidTruncated (ServiceDataTruncation offset adType uuidWidth (BS.length payload))) Just uuid -> Right advertisement { advServiceData = @@ -263,12 +243,13 @@ nextStructureOffset :: AdStructureOffset -> Int -> AdStructureOffset nextStructureOffset (AdStructureOffset offset) structureLength = AdStructureOffset (offset + 1 + structureLength) --- | Look up a service data payload by UUID text --- (case-insensitively). Accepts the same 128-bit form used across --- "Hatter.Ble", e.g. @"00002080-0000-1000-8000-00805F9B34FB"@. -serviceDataForUuid :: Text -> BleAdvertisement -> Maybe ByteString +-- | 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 (NormalizedBleUuid (Text.toLower uuid)) (advServiceData advertisement) + lookup uuid (advServiceData advertisement) -- | Words 2 to 4 of the Bluetooth base UUID -- (@xxxxxxxx-0000-1000-8000-00805F9B34FB@), which 16- and 32-bit @@ -282,31 +263,30 @@ bluetoothBaseUuidWord3 = 0x80000080 bluetoothBaseUuidWord4 :: Word32 bluetoothBaseUuidWord4 = 0x5F9B34FB --- | Render an advertisement UUID of the declared byte width as a --- full 128-bit 'NormalizedBleUuid'; 'UUID.toText' renders the --- canonical lowercase form. 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. -normalizedUuidFromLittleEndian :: Int -> ByteString -> Maybe NormalizedBleUuid -normalizedUuidFromLittleEndian declaredWidth uuidBytes = +-- | 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 - uuid = 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 - in fmap (NormalizedBleUuid . UUID.toText) uuid + 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. diff --git a/test/BleDemoMain.hs b/test/BleDemoMain.hs index 8b795e4..428130b 100644 --- a/test/BleDemoMain.hs +++ b/test/BleDemoMain.hs @@ -36,11 +36,11 @@ import Hatter , createAction ) import Hatter.AppContext (AppContext(..), derefAppContext) +import Data.UUID.Types qualified as UUID import Hatter.Ble ( BleState(..) , BleScanResult(..) , BleAdvertisement(..) - , NormalizedBleUuid(..) , BleDeviceAddress(..) , BleServiceUuid(..) , BleCharacteristicUuid(..) @@ -184,7 +184,7 @@ logAndRememberScanResult lastAddressRef scanResult = do platformLog ("BLE adv parse errors: " <> pack (show parseErrors)) Right advertisement -> mapM_ (\(uuid, payload) -> - platformLog ("BLE adv service data: " <> unNormalizedBleUuid uuid + platformLog ("BLE adv service data: " <> UUID.toText uuid <> "=" <> pack (show (BS.unpack payload)))) (advServiceData advertisement) writeIORef lastAddressRef (Just (bsrDeviceAddress scanResult)) diff --git a/test/Test/PlatformTests.hs b/test/Test/PlatformTests.hs index 25792d2..fd7aa98 100644 --- a/test/Test/PlatformTests.hs +++ b/test/Test/PlatformTests.hs @@ -21,6 +21,7 @@ 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) @@ -67,7 +68,6 @@ import Hatter.Ble , BleGattCompletion(..) , BleState(..) , BleAdvertisement(..) - , NormalizedBleUuid(..) , ManufacturerId(..) , AdvertisementParseError(..) , AdvertisementParseErrors(..) @@ -385,6 +385,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 @@ -525,7 +530,7 @@ bleTests ffiBleState = testGroup "BLE" case result of Nothing -> assertFailure "callback should have been fired" Just scanResult -> - fmap (serviceDataForUuid "00002080-0000-1000-8000-00805F9B34FB") + fmap (serviceDataForUuid kkmExtDataUuid) (bsrAdvertisement scanResult) @?= Right (Just (BS.pack [0x55, 0x00, 0x01, 0xF6])) @@ -534,7 +539,7 @@ bleTests ffiBleState = testGroup "BLE" (BS.pack [0x02, 0x01, 0x06, 0x05, 0x16, 0xED, 0xFE, 0x2A, 0x63]) @?= Right BleAdvertisement { advServiceData = - [(NormalizedBleUuid "0000feed-0000-1000-8000-00805f9b34fb", BS.pack [0x2A, 0x63])] + [(UUID.fromWords 0x0000FEED 0x00001000 0x80000080 0x5F9B34FB, BS.pack [0x2A, 0x63])] , advManufacturerData = [] } @@ -550,7 +555,7 @@ bleTests ffiBleState = testGroup "BLE" ]) @?= Right BleAdvertisement { advServiceData = - [(NormalizedBleUuid "50db505c-8ac4-4738-8448-3b1d9cc09cc5", BS.pack [0x7F])] + [(UUID.fromWords 0x50DB505C 0x8AC44738 0x84483B1D 0x9CC09CC5, BS.pack [0x7F])] , advManufacturerData = [] } @@ -571,8 +576,8 @@ bleTests ffiBleState = testGroup "BLE" ]) @?= Right BleAdvertisement { advServiceData = - [ (NormalizedBleUuid "0000feaa-0000-1000-8000-00805f9b34fb", BS.pack [0x01]) - , (NormalizedBleUuid "00002080-0000-1000-8000-00805f9b34fb", BS.pack [0x02]) + [ (UUID.fromWords 0x0000FEAA 0x00001000 0x80000080 0x5F9B34FB, BS.pack [0x01]) + , (UUID.fromWords 0x00002080 0x00001000 0x80000080 0x5F9B34FB, BS.pack [0x02]) ] , advManufacturerData = [(ManufacturerId 0x004C, BS.empty)] } @@ -584,7 +589,7 @@ bleTests ffiBleState = testGroup "BLE" (BS.pack [0x05, 0x16, 0xED, 0xFE, 0x2A, 0x63, 0x00, 0x00, 0x00, 0x00]) @?= Right BleAdvertisement { advServiceData = - [(NormalizedBleUuid "0000feed-0000-1000-8000-00805f9b34fb", BS.pack [0x2A, 0x63])] + [(UUID.fromWords 0x0000FEED 0x00001000 0x80000080 0x5F9B34FB, BS.pack [0x2A, 0x63])] , advManufacturerData = [] } @@ -623,15 +628,18 @@ bleTests ffiBleState = testGroup "BLE" :| [ManufacturerDataTooShort (ManufacturerDataTruncation (AdStructureOffset 3) 1)])) - , testCase "serviceDataForUuid is case-insensitive" $ do + , testCase "serviceDataForUuid keys on the UUID value" $ do let parsed = parseBleAdvertisement (BS.pack [0x05, 0x16, 0x80, 0x20, 0x55, 0x63]) - fmap (serviceDataForUuid "00002080-0000-1000-8000-00805F9B34FB") parsed - @?= Right (Just (BS.pack [0x55, 0x63])) - fmap (serviceDataForUuid "00002080-0000-1000-8000-00805f9b34fb") parsed + fmap (serviceDataForUuid kkmExtDataUuid) parsed @?= Right (Just (BS.pack [0x55, 0x63])) - fmap (serviceDataForUuid "0000FEAA-0000-1000-8000-00805F9B34FB") parsed + 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] From 079dadfcfa0ff5b980e534f0765eec0d4dcb6b98 Mon Sep 17 00:00:00 2001 From: jappeace-sloth Date: Tue, 14 Jul 2026 11:39:39 +0200 Subject: [PATCH 12/13] Carry the salvaged partial advertisement alongside the parse errors Review: parseBleAdvertisement returns Either BleAdvertisementWithErrors BleAdvertisement now, the Left a record of the partial advertisement plus the NonEmpty defects. AD structures are independent TLVs, so the partial holds every structure that still parsed (a mid-stream defect skips only itself; a truncation keeps everything before it) and is empty only when the first structure is truncated or all are defective. The link layer's CRC already dropped radio corruption, so defects here are firmware quirks in single structures and the well-formed remainder is trustworthy: a beacon with one garbled structure must not lose its valid service data. Tests pin both the filled-salvage and empty-salvage cases. Prompt: one more review comment for hatter. I'm not sure if it makes sense though, like if we get an error does it make sense to return the partial result, will this always be an empty ble advertisemetn or will it be filled with something? I don't know, you make the judgement if the review comment even make sense Co-Authored-By: Claude Fable 5 --- Changelog.md | 6 ++-- src/Hatter/Ble.hs | 10 +++--- src/Hatter/BleAdvertisement.hs | 28 +++++++++++---- test/BleDemoMain.hs | 21 +++++++---- test/Test/PlatformTests.hs | 65 ++++++++++++++++++++++++---------- 5 files changed, 93 insertions(+), 37 deletions(-) diff --git a/Changelog.md b/Changelog.md index e6662f7..97e4dd5 100644 --- a/Changelog.md +++ b/Changelog.md @@ -6,8 +6,10 @@ - Scan results now carry the advertisement's service data and manufacturer data (issue #238): `BleScanResult` gained - `bsrAdvertisement :: Either AdvertisementParseErrors - BleAdvertisement`, parsed by the new `Hatter.BleAdvertisement` + `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 diff --git a/src/Hatter/Ble.hs b/src/Hatter/Ble.hs index 4254f4d..91f75a3 100644 --- a/src/Hatter/Ble.hs +++ b/src/Hatter/Ble.hs @@ -161,9 +161,10 @@ data BleScanResult = BleScanResult { bsrDeviceName :: Text , bsrDeviceAddress :: BleDeviceAddress , bsrRssi :: Int - , bsrAdvertisement :: Either AdvertisementParseErrors BleAdvertisement + , bsrAdvertisement :: Either BleAdvertisementWithErrors BleAdvertisement -- ^ Service data and manufacturer data broadcast in the - -- advertisement, or every defect found in a malformed one, see + -- 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. @@ -620,9 +621,10 @@ dispatchBleScanResult bleState cName cAddr cRssi advPtr advLength = do -- device sent them) but still deliver the scan result: a -- garbled advertisement must never hide the device. case parsedAdvertisement of - Left defects -> hPutStrLn stderr + Left withErrors -> hPutStrLn stderr ("dispatchBleScanResult: malformed advertisement from " - ++ unpack addrStr ++ ": " ++ show defects) + ++ unpack addrStr ++ ": " + ++ show (advertisementParseErrors withErrors)) Right _ -> pure () callback BleScanResult { bsrDeviceName = nameStr diff --git a/src/Hatter/BleAdvertisement.hs b/src/Hatter/BleAdvertisement.hs index 3e1e968..24eb522 100644 --- a/src/Hatter/BleAdvertisement.hs +++ b/src/Hatter/BleAdvertisement.hs @@ -14,6 +14,7 @@ -- parser is the single decoding path for both platforms. module Hatter.BleAdvertisement ( BleAdvertisement(..) + , BleAdvertisementWithErrors(..) , UUID , ManufacturerId(..) , AdvertisementParseError(..) @@ -109,6 +110,15 @@ 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). @@ -128,15 +138,21 @@ emptyBleAdvertisement = BleAdvertisement -- 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 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 AdvertisementParseErrors BleAdvertisement +-- 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 - (_, firstDefect : moreDefects) -> - Left (AdvertisementParseErrors (firstDefect :| moreDefects)) + (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 diff --git a/test/BleDemoMain.hs b/test/BleDemoMain.hs index 428130b..d5122a5 100644 --- a/test/BleDemoMain.hs +++ b/test/BleDemoMain.hs @@ -41,6 +41,7 @@ import Hatter.Ble ( BleState(..) , BleScanResult(..) , BleAdvertisement(..) + , BleAdvertisementWithErrors(..) , BleDeviceAddress(..) , BleServiceUuid(..) , BleCharacteristicUuid(..) @@ -180,15 +181,21 @@ logAndRememberScanResult :: IORef (Maybe BleDeviceAddress) -> BleScanResult -> I logAndRememberScanResult lastAddressRef scanResult = do platformLog ("BLE scan result: " <> pack (show scanResult)) case bsrAdvertisement scanResult of - Left parseErrors -> - platformLog ("BLE adv parse errors: " <> pack (show parseErrors)) - Right advertisement -> - mapM_ (\(uuid, payload) -> - platformLog ("BLE adv service data: " <> UUID.toText uuid - <> "=" <> pack (show (BS.unpack payload)))) - (advServiceData advertisement) + 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 fd7aa98..63b1e43 100644 --- a/test/Test/PlatformTests.hs +++ b/test/Test/PlatformTests.hs @@ -71,6 +71,7 @@ import Hatter.Ble , ManufacturerId(..) , AdvertisementParseError(..) , AdvertisementParseErrors(..) + , BleAdvertisementWithErrors(..) , AdStructureOffset(..) , AdStructureTruncation(..) , ServiceDataTruncation(..) @@ -593,40 +594,68 @@ bleTests ffiBleState = testGroup "BLE" , advManufacturerData = [] } - , testCase "parseBleAdvertisement reports a truncated structure with its offset" $ + , 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. + -- 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 (AdvertisementParseErrors (AdStructureTruncated (AdStructureTruncation (AdStructureOffset 5) 9 3) :| [])) + @?= 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 (AdvertisementParseErrors - (ServiceDataUuidTruncated - (ServiceDataTruncation (AdStructureOffset 0) 0x21 16 2) :| [])) + @?= Left (BleAdvertisementWithErrors emptyBleAdvertisement + (AdvertisementParseErrors + (ServiceDataUuidTruncated + (ServiceDataTruncation (AdStructureOffset 0) 0x21 16 2) :| []))) parseBleAdvertisement (BS.pack [0x05, 0x21, 0x01, 0x02, 0x03, 0x04]) - @?= Left (AdvertisementParseErrors - (ServiceDataUuidTruncated - (ServiceDataTruncation (AdStructureOffset 0) 0x21 16 4) :| [])) + @?= Left (BleAdvertisementWithErrors emptyBleAdvertisement + (AdvertisementParseErrors + (ServiceDataUuidTruncated + (ServiceDataTruncation (AdStructureOffset 0) 0x21 16 4) :| []))) parseBleAdvertisement (BS.pack [0x03, 0x20, 0x80, 0x20]) - @?= Left (AdvertisementParseErrors - (ServiceDataUuidTruncated - (ServiceDataTruncation (AdStructureOffset 0) 0x20 4 2) :| [])) + @?= 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. + -- 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 (AdvertisementParseErrors - (ServiceDataUuidTruncated - (ServiceDataTruncation (AdStructureOffset 0) 0x16 2 1) - :| [ManufacturerDataTooShort - (ManufacturerDataTruncation (AdStructureOffset 3) 1)])) + @?= 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 From 9c36ad8380bd2cc234a5deed3b75b3d20a7d4be8 Mon Sep 17 00:00:00 2001 From: jappeace-sloth Date: Tue, 14 Jul 2026 12:39:56 +0200 Subject: [PATCH 13/13] ci: retrigger after a nix-cache NAR broke mid-transfer on the android job Also serves as the diagnostic for the kbeacon x86_64 emulator startup SIGSEGV: the android job's x86_64 emulator tests never ran on 079dadf. Co-Authored-By: Claude Fable 5