keyboard input from specific devices on windows

tasty.fsx

// dotnet fsi tasty.fsx

#I @"C:\Program Files\dotnet\shared\Microsoft.WindowsDesktop.App\8.0.11"
#r "System.Windows.Forms"

open System
open System.Runtime.InteropServices
open System.Windows.Forms

[<Struct>]
type MSG = {
    mutable hwnd: nativeint
    mutable message: uint32
    mutable wParam: nativeint
    mutable lParam: nativeint
    mutable time: uint32
    mutable pt: System.Drawing.Point
}

[<Struct>]
type RAWINPUTDEVICE = {
    mutable usUsagePage: uint16
    mutable usUsage: uint16
    mutable dwFlags: uint32
    mutable hwndTarget: nativeint
}

[<Struct>]
type RAWINPUTHEADER = {
    mutable dwType: uint32
    mutable dwSize: uint32
    mutable hDevice: nativeint
    mutable wParam: nativeint
}

[<Struct>]
type RAWKEYBOARD = {
    mutable MakeCode: uint16
    mutable Flags: uint16
    mutable Reserved: uint16
    mutable VKey: uint16
    mutable Message: uint32
    mutable ExtraInformation: uint32
}

[<Struct>]
type RAWINPUT = {
    mutable header: RAWINPUTHEADER
    mutable keyboard: RAWKEYBOARD
}

let WM_INPUT: uint32 = 0x00FFu
let WM_KEYDOWN: uint32 = 256u
let WM_KEYUP: uint32 = 257u

let RID_INPUT = 0x10000003u
let RIM_TYPEKEYBOARD = 1u
let RIDEV_INPUTSINK = 0x00000100u

[<DllImport("user32.dll", SetLastError = true)>]
extern bool RegisterRawInputDevices(RAWINPUTDEVICE[] pRawInputDevices, uint32 uiNumDevices, uint32 cbSize)

[<DllImport("user32.dll", SetLastError = true)>]
extern uint32 GetRawInputData(nativeint hRawInput, uint32 uiCommand, nativeint pData, uint32& pcbSize, uint32 cbSizeHeader)

[<DllImport("user32.dll", SetLastError = true)>]
extern int GetMessage(nativeint lpMsg, nativeint hWnd, uint32 wMsgFilterMin, uint32 wMsgFilterMax)

[<DllImport("user32.dll", CharSet = CharSet.Auto, SetLastError = true)>]
extern bool TranslateMessage(nativeint lpMsg)

[<DllImport("user32.dll", CharSet = CharSet.Auto, SetLastError = true)>]
extern nativeint DispatchMessage(nativeint lpMsg)

type RawInputReceiverWindow() as this =
    inherit NativeWindow()

    do
        let createParams = CreateParams(X = 0, Y = 0, Width = 0, Height = 0, Style = 0x800000)
        this.CreateHandle(createParams)

let window = RawInputReceiverWindow()

let registerRawInputDevices() =
    let rid = [|
        { usUsagePage = 1us; usUsage = 6us; dwFlags = RIDEV_INPUTSINK; hwndTarget = window.Handle }
    |]
    let result = RegisterRawInputDevices(rid, uint32 rid.Length, uint32 (Marshal.SizeOf<RAWINPUTDEVICE>()))
    if not result then
        let error = Marshal.GetLastWin32Error()
        failwithf "Failed to register raw input devices. Error code: %d" error
    printfn "Raw input devices registered"

let processRawInput(hRawInput: nativeint) =
    let mutable size = 0u
    // First call to get the size of the data
    GetRawInputData(hRawInput, RID_INPUT, nativeint 0, &size, uint32 (Marshal.SizeOf<RAWINPUTHEADER>())) |> ignore
    let buffer = Marshal.AllocHGlobal(int size)
    try
        // Second call to get the actual data
        if GetRawInputData(hRawInput, RID_INPUT, buffer, &size, uint32 (Marshal.SizeOf<RAWINPUTHEADER>())) = size then
            let raw = Marshal.PtrToStructure<RAWINPUT>(buffer)
            if raw.header.dwType = RIM_TYPEKEYBOARD && raw.keyboard.Message = WM_KEYUP then
                printfn "Key pressed: %A, Device: %A" raw.keyboard.VKey raw.header.hDevice
    finally
        Marshal.FreeHGlobal(buffer)

registerRawInputDevices()

// Custom message loop to keep the script running and responsive to keyboard events
let msg = Marshal.AllocHGlobal(28) // MSG structure size is 28 bytes
try
    let mutable running = true
    while running do
        match GetMessage(msg, nativeint 0, 0u, 0u) with
        | 0 ->
            printfn "Exiting message loop"
            running <- false
        | -1 ->
            let error = Marshal.GetLastWin32Error()
            failwithf "GetMessage failed with error code: %d" error
        | _ ->
            let message = Marshal.PtrToStructure<MSG>(msg)
            if message.message = WM_INPUT
            then processRawInput(message.lParam)
            else
                TranslateMessage(msg) |> ignore
                DispatchMessage(msg) |> ignore
    printfn "Message loop exited"
finally
    printfn "Freeing message loop memory"
    Marshal.FreeHGlobal(msg)