enhanced fvr daemon wip

Program.fs

@@ -132,7 +132,7 @@ let main(args: string[]) =
     match opts.intent with
     | Setup -> setup()
     | Uninstall -> uninstall()
-    | Daemon(pipe, nvim) -> daemon pipe nvim
+    | Daemon(pipe, nvim, enc) -> daemon pipe nvim enc
     | Start(a,b,c) -> startMainWindow app (a,b,c) 
   with 
     | ex -> startCrashReportWindow app ex

common.fs

@@ -1,7 +1,9 @@
 module FVim.common
 
-open System.Runtime.InteropServices
 open System.Threading.Tasks
+open System
+open FSharp.Control.Tasks.V2.ContextSensitive
+open System.Diagnostics
 
 let mkparams1 (t1: 'T1)                                          = [| box t1 |]
 let mkparams2 (t1: 'T1) (t2: 'T2)                                = [| box t1; box t2 |]
@@ -119,6 +121,44 @@ let run (t: Task) =
 let runSync (t: Task) =
     t.Wait()
 
+let rec read (stream: System.IO.Stream) (buf: Memory<byte>) = 
+  task {
+    let! n = stream.ReadAsync(buf)
+    if n = 0 then failwith "read"
+    if n < buf.Length then return! read stream (buf.Slice n)
+  }
+
+let write (stream: System.IO.Stream) (buf: ReadOnlyMemory<byte>) = 
+  stream.WriteAsync(buf)
+
+let inline toInt32LE (x: _[]) =
+  int32 (x.[0])
+  ||| (int32(x.[1]) <<< 8)
+  ||| (int32(x.[2]) <<< 16)
+  ||| (int32(x.[3]) <<< 24)
+
+let inline fromInt32LE (x: int32) =
+  [|
+    byte (x)
+    byte (x >>> 8)
+    byte (x >>> 16)
+    byte (x >>> 24)
+  |]
+
+let runProcess prog args stderrenc =
+  let args = args |> escapeArgs |> join
+  let psi  = ProcessStartInfo(prog, args)
+  psi.CreateNoWindow          <- true
+  psi.ErrorDialog             <- false
+  psi.RedirectStandardError   <- true
+  psi.RedirectStandardInput   <- true
+  psi.RedirectStandardOutput  <- true
+  psi.StandardErrorEncoding   <- stderrenc
+  psi.UseShellExecute         <- false
+  psi.WindowStyle             <- ProcessWindowStyle.Hidden
+  psi.WorkingDirectory        <- Environment.CurrentDirectory
+  Process.Start(psi)
+
 [<AutoOpen>]
 module internal helpers =
     let _d x = Option.defaultValue x

daemon.fs

@@ -1,12 +1,36 @@
 module FVim.Daemon
 
-open log
-open System.Runtime.InteropServices
-open System.Diagnostics
-open FVim.common
 open System
 open System.IO.Pipes
+open System.Runtime.InteropServices
+open System.Diagnostics
+open System.Threading.Tasks
+
 open FSharp.Control.Tasks.V2.ContextSensitive
+open FSharp.Span.Utils
+open FSharp.Json
+
+open log
+open common
+open getopt
+open System.Security.Principal
+open MessagePack
+open System.IO
+
+type Session =
+  {
+    id: int
+    // None=Free to connect
+    // Some=Exclusively connected
+    server: NamedPipeServerStream option
+    proc: Process
+    // in case the daemon crashed and we happen to be running Windows(tm)...
+    killHandle: IDisposable
+  }
+
+let private sessions = hashmap []
+let mutable private sessionId = 0
+let FVR_MAGIC = [| 0x46uy ; 0x56uy ; 0x49uy ; 0x4Duy |]
 
 let inline private trace x = trace "daemon" x
 
@@ -15,43 +39,117 @@ let pipeaddr x =
     then @"\\.\pipe\" + x
     else "/tmp/" + x
 
-let pipename = sprintf "fvr-%s"
+let pipename = sprintf "fvr_%s"
+
+let defaultDaemonName = pipename "main"
 
-let daemon (pname: string option) (nvim: string) =
+let attachSession id svrpipe =
+  match sessions.TryGetValue id with
+  | true, ({ server = None } as s) -> 
+    let ns = {s with server = Some svrpipe}
+    sessions.[id] <- ns
+    Some ns
+  | _ -> None
+
+let newSession nvim stderrenc args svrpipe = 
+  let myid = sessionId
+
+  let pname = pipename (string myid)
+  let paddr = pipeaddr pname
+  let proc = runProcess nvim ("--headless" :: "--listen" :: paddr :: args) stderrenc
+  let sub = AppDomain.CurrentDomain.ProcessExit.Subscribe(fun _ -> proc.Kill(true))
+  let session = 
+    { 
+      id = myid 
+      server = Some svrpipe
+      proc = proc
+      killHandle = sub
+    }
+
+  sessionId <- sessionId + 1
+  sessions.[myid] <- session
+  Some session
+
+
+let attachFirstSession svrpipe =
+  sessions |> Seq.tryFind (fun kv -> kv.Value.server.IsNone)
+  >>= fun kv ->
+    let ns = {kv.Value with server = Some svrpipe}
+    sessions.[kv.Key] <- ns
+    Some ns
+
+let serveSession (session: Session) =
+  task {
+    let pname = pipename (string session.id)
+    use client = new NamedPipeClientStream(".", pname, IO.Pipes.PipeDirection.InOut, IO.Pipes.PipeOptions.Asynchronous, TokenImpersonationLevel.Impersonation)
+
+    let fromNvim = client.CopyToAsync(session.server.Value)
+    let toNvim = session.server.Value.CopyToAsync(client)
+    let! _ = Task.WhenAny [| fromNvim; toNvim |]
+    // Something is completed, let's investigate why
+    if not client.IsConnected then
+      // the connection to neovim server is gone
+      session.proc.Kill(true)
+      // remove the session
+      sessions.Remove(session.id) |> ignore
+    else
+      // the connection from the remote FVim is gone
+      sessions.[session.id] <- { session with server = None }
+    return ()
+  }
+
+let serve nvim stderrenc (pipe: NamedPipeServerStream) = 
+  run <| task {
+    try
+      let rbuf = Array.zeroCreate 8192
+      let rmem = rbuf.AsMemory()
+      // read protocol header
+      // [magic header FVIM] 4B
+      // [payload len] 4B, little-endian
+      do! read pipe rmem.[0..7]
+      if rbuf.[0..3] <> FVR_MAGIC then return()
+      let len = rbuf.[4..7] |> toInt32LE
+      if len >= rbuf.Length || len <= 0 then return()
+      do! read pipe rmem.[0..len-1]
+      let request: FVimRemoteVerb = 
+        (rbuf, 0, len)
+        |> Text.Encoding.UTF8.GetString
+        |> Json.deserialize
+      let session = 
+        match request with
+        | NewSession args -> newSession nvim stderrenc args pipe
+        | AttachTo id -> attachSession id pipe
+        | AttachFirst -> attachFirstSession pipe
+
+      match session with
+      | None -> return()
+      | Some session -> do! serveSession session
+    finally
+      pipe.Dispose()
+  }
+
+let daemon (pname: string option) (nvim: string) (stderrenc: Text.Encoding) =
     trace "Running as daemon."
-    let pname = pname |> Option.defaultValue (pipename "main")
+    let pname = pname |> Option.defaultValue defaultDaemonName
     let paddr = pipeaddr pname
     trace "FVR server address is '%s'" paddr
 
     while true do
-      (task {
+      runSync <| task {
         let svrpipe =
             new NamedPipeServerStream(pname, PipeDirection.InOut, NamedPipeServerStream.MaxAllowedServerInstances,
                                       PipeTransmissionMode.Byte, PipeOptions.Asynchronous)
         do! svrpipe.WaitForConnectionAsync()
-      }).Wait()
-        (*
-        try
-            let pipe = new System.IO.Pipes.NamedPipeClientStream(".", FVim.Shell.FVimServerAddress, IO.Pipes.PipeDirection.InOut, IO.Pipes.PipeOptions.Asynchronous, TokenImpersonationLevel.Impersonation)
-            pipe.Connect(timeout=50)
-            RemoteSession pipe
-        with :? TimeoutException ->
-            //  transition from TryDamon to StartNew, add "--embed"
-            this.createIO {opts with serveropts = StartNew; args = ["--embed"] @ args}
-        *)
-        (*let psi = ProcessStartInfo(nvim, join ("--headless" :: pipeArgs))*)
-        (*psi.CreateNoWindow <- true*)
-        (*psi.ErrorDialog <- false*)
-        (*psi.RedirectStandardError <- true*)
-        (*psi.RedirectStandardInput <- true*)
-        (*psi.RedirectStandardOutput <- true*)
-        (*psi.UseShellExecute <- false*)
-        (*psi.WindowStyle <- ProcessWindowStyle.Hidden*)
-        (*psi.WorkingDirectory <- Environment.CurrentDirectory*)
-
-        (*use proc = Process.Start(psi)*)
-        (*use __sub = AppDomain.CurrentDomain.ProcessExit.Subscribe(fun _ -> proc.Kill(true))*)
-        (*trace "Neovim process started. Pid = %d" proc.Id*)
-        (*proc.WaitForExit()*)
-        (*trace "Neovim process terminated. ExitCode = %d" proc.ExitCode*)
+        serve nvim stderrenc svrpipe
+      }
     0
+
+let fvrConnect (stdin: Stream) (stdout: Stream) (verb: FVimRemoteVerb) =
+  let payload = 
+    verb
+    |> Json.serialize
+    |> Text.Encoding.UTF8.GetBytes
+  let len = fromInt32LE payload.Length
+  stdin.Write(FVR_MAGIC, 0, FVR_MAGIC.Length)
+  stdin.Write(len, 0, len.Length)
+  stdin.Write(payload, 0, payload.Length)

fvim.fsproj

@@ -78,6 +78,8 @@
     <PackageReference Include="FSharp.Control.Reactive" Version="4.4.2" />
     <PackageReference Include="FSharp.Data" Version="3.3.3" />
     <PackageReference Include="FSharp.Core" Version="5.0" />
+    <PackageReference Include="FSharp.Json" Version="0.4.0" />
+    <PackageReference Include="FSharp.Span.Utils" Version="1.1.3353.13900" />
     <PackageReference Include="MessagePack" Version="1.9.11" />
     <PackageReference Include="Microsoft.Win32.Registry" Version="4.7.0" />
     <PackageReference Include="NSubsys" Version="1.0.0">

getopt.fs

@@ -8,9 +8,9 @@ type NeovimRemoteEndpoint =
     | NamedPipe of address: string
 
 type FVimRemoteVerb =
-    | AttachTo of id: int * files: string list
+    | AttachTo of id: int
     | NewSession of args: string list
-    | AttachFirst of files: string list
+    | AttachFirst
     // | Interactive
 
 type FVimRemoteTransport =
@@ -20,13 +20,13 @@ type FVimRemoteTransport =
 type ServerOptions =
     | Embedded of prog: string * args: string list * stderrenc: System.Text.Encoding
     | NeovimRemote of addr: NeovimRemoteEndpoint * files: string list
-    | FVimRemote of transport: FVimRemoteTransport * verb: FVimRemoteVerb
+    | FVimRemote of serverName: string option * transport: FVimRemoteTransport * verb: FVimRemoteVerb * files: string list
 
 type Intent =
     | Start of serveropts: ServerOptions * norc: bool * debugMultigrid: bool
     | Setup
     | Uninstall
-    | Daemon of pipe: string option * nvim: string
+    | Daemon of pipe: string option * nvim: string * stderrenc: System.Text.Encoding
 
 type Options =
     {
@@ -98,13 +98,17 @@ let parseOptions (args: string[]) =
         | None -> "+terminal"
         |> args.Add
 
+    let enc = 
+      if wsl then System.Text.Encoding.Unicode 
+      else System.Text.Encoding.UTF8
+
     // stop altering the args list now
     let argsL = List.ofSeq args
 
     let intent = 
         if setup then Setup
         elif uninstall then Uninstall
-        elif daemon then Daemon(pipe, nvim)
+        elif daemon then Daemon(pipe, nvim, enc)
         else 
         let serveropts = 
             match fvr, nvr with
@@ -116,10 +120,14 @@ let parseOptions (args: string[]) =
                 else Local
               let verb = 
                 match fvrVerb.ToLowerInvariant() with
-                | "attach" | "a" -> AttachFirst(argsL)
+                | "attach" | "a" -> AttachFirst
                 | "new" | "n" -> NewSession(argsL)
-                | v -> AttachTo(int v, argsL)
-              FVimRemote(transport, verb)
+                | v -> AttachTo(int v)
+              let files = 
+                match verb with
+                | NewSession _ -> []
+                | _ -> argsL
+              FVimRemote(pipe, transport, verb, files)
             | _, Some nvrAddr ->
               match nvrAddr.Split(":") with
               | [| ParseIp ipaddr; ParseUInt16 port |] -> NeovimRemote(Tcp <| IPEndPoint(ipaddr, int port), argsL)
@@ -132,9 +140,6 @@ let parseOptions (args: string[]) =
                     "ssh", [ssh.Value; nvim; "--embed"] @ argsL
                 else 
                     nvim, ["--embed"] @ argsL
-              let enc = 
-                if wsl then System.Text.Encoding.Unicode 
-                else System.Text.Encoding.UTF8
               in
                 Embedded(prog, args, enc)
         in

model.fs

@@ -553,10 +553,9 @@ let Start (serveropts, norc, debugMultigrid) =
             match serveropts with
             // for embedded & fvr new session, edit file args are passed thru to neovim
             | Embedded _             
-            | FVimRemote(_, NewSession _) -> []
+            | FVimRemote(_, _, NewSession _, _) -> []
             | NeovimRemote(_, files) 
-            | FVimRemote(_, (AttachTo(_, files) 
-                           | AttachFirst files))  -> files
+            | FVimRemote(_, _, _, files)  -> files
         for file in remoteEditFiles do
             let! _ = Async.AwaitTask(nvim.edit file)
             in ()