import Lean.Server.Watchdog import GameServer.FileWorker import GameServer.EnvExtensions import GameServer.Game namespace WasmServer.Watchdog open Lean open Server open Watchdog open IO open Lsp open JsonRpc open System.Uri open MyServer.FileWorker structure WasmFileState := fileWorkerState : FileWorker.WorkerState gameWorkerState : GameWorkerState headerTask : Task (Except Error (Snapshots.Snapshot × SearchPath)) structure WasmServerState := initParams? : Option InitializeParams gameServerState : GameServerState fileState : HashMap String WasmFileState := {} def wasmSearchPath : SearchPath := ["/lib", "/gamelib"] @[export game_make_state] unsafe def makeState : IO WasmServerState := do let e ← IO.getStderr try Lean.enableInitializersExecution searchPathRef.set wasmSearchPath let env ← importModules #[ { module := `GameServer : Import } ] {} 0 let state : GameServerState := { env, game := `TestGame, gameDir := "test", inventory := #[] difficulty := 0 } return ⟨none, state, {}⟩ catch err => e.putStrLn s!"Import error: {err}" throw err def readMessage (s : String) : IO JsonRpc.Message := do let j ← ofExcept (Json.parse s) let m ← match fromJson? j with | Except.ok (m : JsonRpc.Message) => pure m | Except.error inner => throw $ userError s!"JSON '{j.compress}' did not have the format of a JSON-RPC message.\n{inner}" return m def readLspRequestAs (s : String) (expectedMethod : String) (α : Type) [FromJson α] : IO (Request α) := do let m ← readMessage s match m with | Message.request id method params? => if method = expectedMethod then let j := toJson params? match fromJson? j with | Except.ok v => pure $ JsonRpc.Request.mk id expectedMethod (v : α) | Except.error inner => throw $ userError s!"Unexpected param '{j.compress}' for method '{expectedMethod}'\n{inner}" else throw $ userError s!"Expected method '{expectedMethod}', got method '{method}'" | _ => throw $ userError s!"Expected JSON-RPC request, got: '{(toJson m).compress}'" def initializeServer (id : RequestID) : IO Unit := do let o ← IO.getStdout o.writeLspResponse { id := id result := { capabilities := mkLeanServerCapabilities serverInfo? := some { name := "Lean 4 Game Server" version? := "0.1.1" } : InitializeResult } } return () def mkServerContext (state : WasmServerState) : IO ServerContext := do let i ← IO.getStdin let o ← IO.getStdout let e ← IO.getStderr let srcSearchPath ← searchPathRef.get let references ← IO.mkRef (← loadReferences) let fileWorkersRef ← IO.mkRef (RBMap.empty : FileWorkerMap) let workerPath := "no-worker-path" let some initParams := state.initParams? | throwServerError "no yet initialized" return { hIn := i hOut := o hLog := e args := [] fileWorkersRef := fileWorkersRef initParams workerPath srcSearchPath references } def runGameServerM (state : WasmServerState) (x : GameServerM α) : IO (α × WasmServerState) := do let (res, gameServerState) ← ReaderT.run (StateT.run x state.gameServerState) (← mkServerContext state) return (res, {state with gameServerState}) def mkWorkerContext (state : WasmServerState) (headerTask : Task (Except Error (Snapshots.Snapshot × SearchPath))) : IO FileWorker.WorkerContext := do let i ← IO.getStdin let o ← IO.getStdout let e ← IO.getStderr let some initParams := state.initParams? | throwServerError "no yet initialized" let clientHasWidgets := initParams.initializationOptions?.bind (·.hasWidgets?) |>.getD false return { hIn := i hOut := o hLog := e headerTask := headerTask initParams := initParams clientHasWidgets } def runGameWorkerM (state : WasmServerState) (fileState : WasmFileState) (x : GameWorkerM α) : IO (α × WasmFileState) := do let s := fileState.fileWorkerState let ctx ← mkWorkerContext state fileState.headerTask let ((res, gameWorkerState), s) ← StateRefT'.run (s := s) <| ReaderT.run (r := ctx) <| StateT.run (s := fileState.gameWorkerState) <| x let fileState := {fileState with gameWorkerState := gameWorkerState, fileWorkerState := s} return (res, fileState) def parseParams {paramType : Type} [FromJson paramType] (params : Json) : IO paramType := match fromJson? params with | Except.ok parsed => pure parsed | Except.error inner => throwServerError s!"Got param with wrong structure: {params.compress}\n{inner}" def requestWorkerUri (method : String) (params : Json) : IO (Option DocumentUri) := do if method == "$/lean/rpc/connect" then let ps : Lsp.RpcConnectParams ← parseParams params pure <| fileSource ps else match (← routeLspRequest method params) with | Except.error e => throwServerError e.message | Except.ok uri => pure uri open FileWorker in def handleDidOpen (params : DidOpenTextDocumentParams) (state : WasmServerState) : IO WasmServerState := do let some initParams := state.initParams? | throwServerError "no yet initialized" let (_, state) ← runGameServerM state do let some lvl ← GameServer.getLevelByFileName? initParams ((System.Uri.fileUriToPath? params.textDocument.uri).getD params.textDocument.uri |>.toString) | throwServerError s!"Level not found: {params.textDocument.uri} | {initParams.rootUri?}" let env ← importModules #[ { module := lvl.module : Import } ] {} 0 (← getStderr).putStr "Import for level completed" let doc := params.textDocument let meta : DocumentMeta := ⟨doc.uri, doc.version, doc.text.toFileMap, .always⟩ let clientHasWidgets := initParams.initializationOptions?.bind (·.hasWidgets?) |>.getD false let (headerStx, headerTask) ← mkHeaderTask meta (← getStdout) wasmSearchPath env {} clientHasWidgets let cancelTk ← CancelToken.new let levelParams := { uri := meta.uri gameDir := state.gameServerState.gameDir levelModule := lvl.module tactics := lvl.tactics.tiles lemmas := lvl.lemmas.tiles definitions := lvl.definitions.tiles inventory := state.gameServerState.inventory difficulty := state.gameServerState.difficulty statementName := lvl.statementName : Game.DidOpenLevelParams } let ctx ← mkWorkerContext state headerTask let cmdSnaps ← EIO.mapTask (t := headerTask) (match · with | Except.ok (s, _) => unfoldSnaps meta #[s] cancelTk levelParams ctx (startAfterMs := 0) | Except.error e => throw (e : ElabTaskError)) let doc : EditableDocument := { meta, cmdSnaps := AsyncList.delayed cmdSnaps, cancelTk } let s : WasmFileState := { fileWorkerState := { doc := doc initHeaderStx := headerStx pendingRequests := RBMap.empty rpcSessions := RBMap.empty } gameWorkerState := { levelParams } headerTask } let fileState := state.fileState.insert params.textDocument.uri s return {state with fileState} return state @[export game_send_message] unsafe def sendMessage (s : String) (state : WasmServerState) : IO WasmServerState := do let e ← IO.getStderr try let m ← readMessage s match m with | Message.request id "initialize" (some params) => let p : InitializeParams ← parseParams (toJson params) initializeServer id let p := {p with rootUri? := some (toString state.gameServerState.game)} return {state with initParams? := some p} | _ => let (isGameEv, state) ← runGameServerM state (Game.handleServerEvent (.clientMsg m)) if isGameEv then return state else match m with | Message.notification method (some params) => let handle := (fun α [FromJson α] (handler : α → WasmServerState → IO WasmServerState) => parseParams (toJson params) >>= (handler · state)) match method with --TODO | "textDocument/didOpen" => handle DidOpenTextDocumentParams handleDidOpen -- | "textDocument/didChange" => handle DidChangeTextDocumentParams handleDidChange -- | "textDocument/didClose" => handle DidCloseTextDocumentParams handleDidClose -- | "workspace/didChangeWatchedFiles" => handle DidChangeWatchedFilesParams handleDidChangeWatchedFiles -- | "$/cancelRequest" => handle CancelParams handleCancelRequest -- | "$/lean/rpc/connect" => handle RpcConnectParams (forwardNotification method) -- | "$/lean/rpc/release" => handle RpcReleaseParams (forwardNotification method) -- | "$/lean/rpc/keepAlive" => handle RpcKeepAliveParams (forwardNotification method) | _ => return state | Message.request id method (some params) => let some uri ← requestWorkerUri method (toJson params) | throwServerError s!"Could not find Uri for request: {method}" let some fileState := state.fileState.find? uri | throwServerError s!"File not open: {uri}" let (_, fileState) ← runGameWorkerM state fileState do MyServer.FileWorker.mainLoop1 m let fileState := state.fileState.insert uri fileState return {state with fileState} | Message.responseError _ _ e .. => throwServerError s!"Unhandled response error: {e}" | _ => throwServerError "Got invalid JSON-RPC message" -- match m with -- | _ => -- e.putStrLn s!"Expected JSON-RPC request, got: '{(toJson m).compress}'" -- return state catch err => e.putStrLn s!"Server error: {err}" return state