Should fix #18, PInvokes switched to cswin32, updated .NET version

lowleveldesign · Jan 16, 2024 · bc72ea7 · bc72ea7
1 parent 9ca6412
commit bc72ea7
Show file tree

Hide file tree

Showing 12 changed files with 268 additions and 243 deletions.
diff --git a/wtrace.cmd/Commons/Globals.fs b/wtrace.cmd/Commons/Globals.fs
@@ -10,10 +10,6 @@ open System.Runtime.CompilerServices
 
 (* Constants *)
 
-// The timeout for buffered observable - maximum amount of time that
-// the buffered observable will wait for events
-let eventBufferedObservableTimeout = TimeSpan.FromSeconds(0.5)
-
 [<Literal>]
 let invalidEventId = Int32.MinValue
 

diff --git a/wtrace.cmd/Commons/WinApi.fs b/wtrace.cmd/Commons/WinApi.fs
@@ -1,9 +1,13 @@
 module LowLevelDesign.WTrace.WinApi
 
 open System
-open PInvoke
-
-type SHandle = Kernel32.SafeObjectHandle
+open FSharp.NativeInterop
+open System.Runtime.InteropServices
+open Windows.Win32
+open Windows.Win32.Foundation
+open Windows.Win32.Security
+open Windows.Win32.System.Threading
+open System.ComponentModel
 
 let kernelProviderId = Guid(int32 0x9e814aad, int16 0x3204, int16 0x11d2, byte 0x9a, byte 0x82, byte 0x00, byte 0x60, byte 0x08, byte 0xa8, byte 0x69, byte 0x39);
 
@@ -25,55 +29,50 @@ let getNtStatusDesc (n : int32) =
 let CheckResultBool s b = 
     if b then Ok () else Error (sprintf "[%s] %s" s (Win32Exception().Message))
 
-let CheckResultHandle s h =
-    if h = Kernel32.INVALID_HANDLE_VALUE then Error (sprintf "[%s] %s" s (Win32Exception().Message))
-    else Ok h
+let CheckResultBOOL s b = 
+    if b = BOOL(true) then Ok () else Error (sprintf "[%s] %s" s (Win32Exception().Message))
 
-let CheckResultSafeHandle s (h : SHandle) =
-    if h.IsInvalid then Error (sprintf "[%s] %s" s (Win32Exception().Message))
+let CheckResultHandle s (h : HANDLE) =
+    if h = HANDLE.INVALID_HANDLE_VALUE then Error (sprintf "[%s] %s" s (Win32Exception().Message))
     else Ok h
 
 let Win32ErrorMessage (err : int) = 
     Win32Exception(err).Message
 
-
 let startProcessSuspended (args : seq<string>) spawnNewConsole =
-    result {
-        let mutable pi = Kernel32.PROCESS_INFORMATION()
-        let mutable si = Kernel32.STARTUPINFO(hStdInput = IntPtr.Zero,
-                                              hStdOutput = IntPtr.Zero,
-                                              hStdError = IntPtr.Zero)
-
+    let cmdline = String.Join(" ", args)
+    use cmdlinePtr = fixed cmdline
 
-        let flags = 
-            if spawnNewConsole then
-                Kernel32.CreateProcessFlags.CREATE_NEW_CONSOLE
-            else Kernel32.CreateProcessFlags.None
-
-        let flags = flags |||
-                    Kernel32.CreateProcessFlags.CREATE_SUSPENDED |||
-                    Kernel32.CreateProcessFlags.CREATE_UNICODE_ENVIRONMENT
-
-        do! Kernel32.CreateProcess(null, String.Join(" ", args), IntPtr.Zero, IntPtr.Zero, false,
-                flags, IntPtr.Zero, null, &si, &pi) |> CheckResultBool "CreateProcess"
-
-        return (pi.dwProcessId, new SHandle(pi.hProcess), new SHandle(pi.hThread))
+    result {
+        let pi = NativePtr.stackalloc<PROCESS_INFORMATION> 1
+        let si = NativePtr.stackalloc<STARTUPINFOW> 1
+        NativePtr.write si (STARTUPINFOW(cb = uint32 (Marshal.SizeOf<STARTUPINFOW>())))
+
+        let flags = PROCESS_CREATION_FLAGS.CREATE_SUSPENDED ||| (
+            if spawnNewConsole then PROCESS_CREATION_FLAGS.CREATE_NEW_CONSOLE else (
+                Microsoft.FSharp.Core.LanguagePrimitives.EnumOfValue<uint32, PROCESS_CREATION_FLAGS> 0u))
+
+        do! PInvoke.CreateProcess(PCWSTR(), PWSTR(cmdlinePtr), NativePtr.nullPtr, NativePtr.nullPtr, false, flags, 
+            NativePtr.toVoidPtr NativePtr.nullPtr<int>, PCWSTR(), si, pi) |> CheckResultBOOL "CreateProcess"
+
+        let pi = NativePtr.read pi
+        return (int32 pi.dwProcessId, pi.hProcess, pi.hThread)
     }
 
-let openRunningProcess pid =
-    Kernel32.OpenProcess(Kernel32.ACCESS_MASK(uint32 Kernel32.ACCESS_MASK.StandardRight.SYNCHRONIZE), false, pid)
-    |> CheckResultSafeHandle "OpenProcess"
+let openRunningProcess (pid : int32) =
+    PInvoke.OpenProcess(PROCESS_ACCESS_RIGHTS.PROCESS_SYNCHRONIZE, false, uint32 pid)
+    |> CheckResultHandle "OpenProcess"
 
-let resumeThread hThread =
-    if Kernel32.ResumeThread(hThread) = -1 then
-        Error (sprintf "[ResumeThread] %s" (Win32Exception().Message))
+let resumeProcess (hThread : HANDLE) =
+    if PInvoke.ResumeThread(hThread) = UInt32.MaxValue then
+        Error (sprintf "[DebugActiveProcessStop] %s" (Win32Exception().Message))
     else Ok ()
 
-let waitForProcessExit hProcess timeoutMs =
-    match Kernel32.WaitForSingleObject(hProcess, timeoutMs) with
-    | Kernel32.WaitForSingleObjectResult.WAIT_OBJECT_0 -> Ok true
-    | Kernel32.WaitForSingleObjectResult.WAIT_TIMEOUT -> Ok false
-    | Kernel32.WaitForSingleObjectResult.WAIT_ABANDONED -> Error "[WaitForSingleObject] mutex abandoned"
-    | Kernel32.WaitForSingleObjectResult.WAIT_FAILED
+let waitForProcessExit (hProcess : HANDLE) timeoutMs =
+    match PInvoke.WaitForSingleObject(hProcess, timeoutMs) with
+    | WAIT_EVENT.WAIT_OBJECT_0 -> Ok true
+    | WAIT_EVENT.WAIT_TIMEOUT -> Ok false
+    | WAIT_EVENT.WAIT_ABANDONED -> Error "[WaitForSingleObject] mutex abandoned"
+    | WAIT_EVENT.WAIT_FAILED
     | _ -> Error (sprintf "[WaitForSingleObject] %s" (Win32Exception().Message))
 
diff --git a/wtrace.cmd/Events/Registry.fs b/wtrace.cmd/Events/Registry.fs
@@ -47,7 +47,7 @@ module private H =
                     match state.KeyHandleToName.TryGetValue(ev.KeyHandle) with
                     | (true, name) -> name
                     | (false, _) -> sprintf "<0x%X>" ev.KeyHandle
-                Path.Combine(baseKeyName, ev.KeyName)
+                $"{baseKeyName}\\{ev.KeyName}"
 
         let ev = toEvent ev id "" path "" ev.Status
         state.Broadcast.publishTraceEvent (TraceEventWithFields (ev, noFields))

diff --git a/wtrace.cmd/TraceControl.fs b/wtrace.cmd/TraceControl.fs
@@ -10,8 +10,11 @@ open FSharp.Control.Reactive
 open LowLevelDesign.WTrace.Events
 open LowLevelDesign.WTrace.Tracing
 open LowLevelDesign.WTrace.Processing
+open Windows.Win32
+open Windows.Win32.Foundation
 
 let mutable lostEventsCount = 0
+let mutable lastEventTime = DateTime.MinValue.Ticks
 let sessionWaitEvent = new ManualResetEvent(false)
 
 type WorkCancellation = {
@@ -62,6 +65,7 @@ module private H =
                      else sprintf " -> %s" (WinApi.getNtStatusDesc ev.Result)
         printfn "%s %s (%d.%d) %s%s%s%s" (ev.TimeStamp.ToString("HH:mm:ss.ffff")) ev.ProcessName ev.ProcessId
             ev.ThreadId ev.EventName (getPath ev.Path) (getDesc ev.Details) result
+        Interlocked.Exchange(&lastEventTime, DateTime.Now.Ticks) |> ignore
 
     let onError (ex : Exception) =
         printfn "ERROR: an error occured while collecting the trace - %s" (ex.ToString())
@@ -123,7 +127,7 @@ let traceEverything ct handlers filter showSummary debugSymbols =
 module private ProcessApi =
     // returns true if the process stopped by itself, false if the ct got cancelled
     let rec waitForProcessExit (ct : CancellationToken) hProcess =
-        match WinApi.waitForProcessExit hProcess 500 with
+        match WinApi.waitForProcessExit hProcess 500u with
         | Error err -> Error err
         | Ok processFinished ->
             if processFinished then
@@ -135,7 +139,7 @@ module private ProcessApi =
             else
                 waitForProcessExit ct hProcess
 
-    let traceProcess ct handlers filter showSummary debugSymbols includeChildren (pid, hProcess, hThread : WinApi.SHandle) =
+    let traceProcess ct handlers filter showSummary debugSymbols includeChildren (pid, hProcess, hThread) =
         result {
             let settings = {
                 Handlers = handlers
@@ -164,15 +168,28 @@ module private ProcessApi =
 
             use sub = initiateEtwSession etwObservable ct.TracingCancellationToken
 
-            if not hThread.IsInvalid then
-                do! WinApi.resumeThread hThread
+            if hThread <> HANDLE.INVALID_HANDLE_VALUE then
+                do! WinApi.resumeProcess hThread
 
             let! processFinished = waitForProcessExit ct.TracingCancellationToken hProcess
             if processFinished then
                 printfn "Process (%d) exited." pid
 
-            hThread.Close()
-            hProcess.Close()
+            let mutable savedLastEventTime = Interlocked.Read(&lastEventTime)
+            let rec waitForMoreEvents () =
+                let t = Interlocked.Read(&lastEventTime)
+                if t <> savedLastEventTime && (not ct.TracingCancellationToken.IsCancellationRequested) then
+                    savedLastEventTime <- t
+                    Thread.Sleep(1000)
+                    waitForMoreEvents ()
+
+            // when process exists too fast, we might miss some events
+            // so we wait for a few seconds to prevent that
+            Thread.Sleep(3000)
+            waitForMoreEvents ()
+
+            PInvoke.CloseHandle(hThread) |> ignore
+            PInvoke.CloseHandle(hProcess) |> ignore
 
             return (tstate, counters)
         }
@@ -189,7 +206,7 @@ let traceNewProcess ct handlers filter showSummary debugSymbols newConsole inclu
 let traceRunningProcess ct handlers filter showSummary debugSymbols includeChildren pid =
     result {
         let! hProcess = WinApi.openRunningProcess pid
-        let processIds = (pid, hProcess, WinApi.SHandle.Invalid)
+        let processIds = (pid, hProcess, HANDLE.INVALID_HANDLE_VALUE)
 
         return! ProcessApi.traceProcess ct handlers filter showSummary debugSymbols includeChildren processIds
     }

diff --git a/wtrace.cmd/wtrace.cmd.fsproj b/wtrace.cmd/wtrace.cmd.fsproj
@@ -1,56 +1,57 @@
 <Project Sdk="Microsoft.NET.Sdk">
 
-  <PropertyGroup>
-    <TargetFrameworks>net472</TargetFrameworks>
-    <Authors>Sebastian Solnica</Authors>
-    <Company>Sebastian Solnica (lowleveldesign.org)</Company>
-    <TreatWarningsAsErrors>true</TreatWarningsAsErrors>
-    <SatelliteResourceLanguages>en</SatelliteResourceLanguages>
-  </PropertyGroup>
+    <PropertyGroup>
+        <TargetFrameworks>net48</TargetFrameworks>
+        <Authors>Sebastian Solnica</Authors>
+        <Company>Sebastian Solnica (wtrace.net)</Company>
+        <TreatWarningsAsErrors>true</TreatWarningsAsErrors>
+        <SatelliteResourceLanguages>en</SatelliteResourceLanguages>
+        <NoWarn>9,3391</NoWarn> <!-- 9: unsafe code, 3391: implicit convertions in lets -->
+    </PropertyGroup>
 
-  <ItemGroup>
-    <Compile Include="Commons\CommandLine.fs" />
-    <Compile Include="Commons\ResultBuilder.fs" />
-    <Compile Include="Commons\Globals.fs" />
-    <Compile Include="Commons\WinApi.fs" />
-    <Compile Include="Commons\Events.fs" />
-    <Compile Include="Events\Commons.fs" />
-    <Compile Include="Events\Image.fs" />
-    <Compile Include="Events\ProcessThread.fs" />
-    <Compile Include="Events\FileIO.fs" />
-    <Compile Include="Events\Registry.fs" />
-    <Compile Include="Events\IsrDpc.fs" />
-    <Compile Include="Events\Rpc.fs" />
-    <Compile Include="Events\TcpIp.fs" />
-    <Compile Include="Events\UdpIp.fs" />
-    <Compile Include="Tracing\Commons.fs" />
-    <Compile Include="Tracing\EtwTraceSession.fs" />
-    <Compile Include="Tracing\EventFilter.fs" />
-    <Compile Include="Processing\TraceState.fs" />
-    <Compile Include="Processing\RpcResolver.fs" />
-    <Compile Include="Processing\SystemImages.fs" />
-    <Compile Include="Processing\ProcessTree.fs" />
-    <Compile Include="Processing\TraceEventProcessor.fs" />
-    <Compile Include="TraceCounters.fs" />
-    <Compile Include="TraceSummary.fs" />
-    <Compile Include="TraceControl.fs" />
-    <Compile Include="Program.fs" />
-  </ItemGroup>
+    <ItemGroup>
+        <Compile Include="Commons\CommandLine.fs" />
+        <Compile Include="Commons\ResultBuilder.fs" />
+        <Compile Include="Commons\Globals.fs" />
+        <Compile Include="Commons\WinApi.fs" />
+        <Compile Include="Commons\Events.fs" />
+        <Compile Include="Events\Commons.fs" />
+        <Compile Include="Events\Image.fs" />
+        <Compile Include="Events\ProcessThread.fs" />
+        <Compile Include="Events\FileIO.fs" />
+        <Compile Include="Events\Registry.fs" />
+        <Compile Include="Events\IsrDpc.fs" />
+        <Compile Include="Events\Rpc.fs" />
+        <Compile Include="Events\TcpIp.fs" />
+        <Compile Include="Events\UdpIp.fs" />
+        <Compile Include="Tracing\Commons.fs" />
+        <Compile Include="Tracing\EtwTraceSession.fs" />
+        <Compile Include="Tracing\EventFilter.fs" />
+        <Compile Include="Processing\TraceState.fs" />
+        <Compile Include="Processing\RpcResolver.fs" />
+        <Compile Include="Processing\SystemImages.fs" />
+        <Compile Include="Processing\ProcessTree.fs" />
+        <Compile Include="Processing\TraceEventProcessor.fs" />
+        <Compile Include="TraceCounters.fs" />
+        <Compile Include="TraceSummary.fs" />
+        <Compile Include="TraceControl.fs" />
+        <Compile Include="Program.fs" />
+    </ItemGroup>
 
-  <ItemGroup>
-    <PackageReference Include="FSharp.Control.Reactive" Version="5.0.5" />
-    <PackageReference Include="NtApiDotNet" Version="1.1.33" />
-    <PackageReference Include="PInvoke.Kernel32" Version="0.7.124" />
-    <PackageReference Include="System.Reactive" Version="5.0.0" />
-  </ItemGroup>
+    <ItemGroup>
+        <PackageReference Include="FSharp.Control.Reactive" Version="5.0.5" />
+        <PackageReference Include="NtApiDotNet" Version="1.1.33" />
+        <PackageReference Include="System.Memory" Version="4.5.5" />
+        <PackageReference Include="System.Reactive" Version="5.0.0" />
+    </ItemGroup>
 
-  <ItemGroup>
-    <ProjectReference Include="..\wtrace.imports\wtrace.imports.csproj" />
-  </ItemGroup>
+    <ItemGroup>
+        <ProjectReference Include="..\wtrace.imports\wtrace.imports.csproj" />
+    </ItemGroup>
 
-  <ItemGroup>
-    <PackageReference Update="FSharp.Core" Version="6.0.5" />
-  </ItemGroup>
+    <ItemGroup>
+        <PackageReference Update="FSharp.Core" Version="8.0.101" />
+    </ItemGroup>
 
 </Project>
 
diff --git a/wtrace.deps/wtrace.deps.csproj b/wtrace.deps/wtrace.deps.csproj
@@ -1,15 +1,16 @@
 <Project Sdk="Microsoft.NET.Sdk">
 
-  <PropertyGroup>
-    <OutputType>Exe</OutputType>
-    <TargetFrameworks>net472</TargetFrameworks>
-    <OutputPath>..\bin\deps</OutputPath>
-    <TreatWarningsAsErrors>true</TreatWarningsAsErrors>
-    <SatelliteResourceLanguages>en</SatelliteResourceLanguages>
-  </PropertyGroup>
+    <PropertyGroup>
+        <OutputType>Exe</OutputType>
+        <TargetFrameworks>net48</TargetFrameworks>
+        <OutputPath>..\bin\deps</OutputPath>
+        <TreatWarningsAsErrors>true</TreatWarningsAsErrors>
+        <SatelliteResourceLanguages>en</SatelliteResourceLanguages>
+        <LangVersion>9.0</LangVersion>
+    </PropertyGroup>
 
-  <ItemGroup>
-    <ProjectReference Include="..\wtrace.cmd\wtrace.cmd.fsproj" />
-  </ItemGroup>
+    <ItemGroup>
+        <ProjectReference Include="..\wtrace.cmd\wtrace.cmd.fsproj" />
+    </ItemGroup>
 
 </Project>
diff --git a/wtrace.imports/NativeMethods.json b/wtrace.imports/NativeMethods.json
@@ -0,0 +1,5 @@
+{
+  "$schema": "https://aka.ms/CsWin32.schema.json",
+  "emitSingleFile": false,
+  "public": true
+}
diff --git a/wtrace.imports/NativeMethods.txt b/wtrace.imports/NativeMethods.txt
@@ -0,0 +1,15 @@
+// methods
+CreateProcess
+OpenProcess
+ResumeThread
+WaitForSingleObject
+DebugActiveProcessStop
+
+// structures
+
+// consts
+STATUS_WAIT_1
+WAIT_EVENT
+
+INVALID_HANDLE_VALUE
+
diff --git a/wtrace.imports/wtrace.imports.csproj b/wtrace.imports/wtrace.imports.csproj
@@ -1,13 +1,17 @@
 <Project Sdk="Microsoft.NET.Sdk">
 
-  <PropertyGroup>
-    <TargetFrameworks>net472</TargetFrameworks>
-    <RootNamespace>LowLevelDesign.WTrace</RootNamespace>
-    <TreatWarningsAsErrors>true</TreatWarningsAsErrors>
-  </PropertyGroup>
+    <PropertyGroup>
+        <TargetFrameworks>net48</TargetFrameworks>
+        <RootNamespace>LowLevelDesign.WTrace</RootNamespace>
+        <TreatWarningsAsErrors>true</TreatWarningsAsErrors>
+        <LangVersion>9.0</LangVersion>
+    </PropertyGroup>
 
-  <ItemGroup>
-    <PackageReference Include="Microsoft.Diagnostics.Tracing.TraceEvent" Version="3.0.4" />
-  </ItemGroup>
+    <ItemGroup>
+        <PackageReference Include="Microsoft.Diagnostics.Tracing.TraceEvent" Version="3.1.7" />
+        <PackageReference Include="Microsoft.Windows.CsWin32" Version="0.3.49-beta">
+          <PrivateAssets>all</PrivateAssets>
+        </PackageReference>
+    </ItemGroup>
 
 </Project>