banawa-chat/unikernel.ml

open Lwt.Syntax

type state =
  { env : (string, string) Hashtbl.t
  ; sigwinch : (int * int) Lwt_condition.t
  ; mutable size : int * int
  }

module Main (_ : Mirage_random.S) (T : Mirage_time.S) (M : Mirage_clock.MCLOCK) (Stack : Tcpip.Stack.V4V6) = struct
  module Ssh = Banawa_mirage.Make(Stack.TCP)(T)(M)
  module Nottui' = Nottui_mirage.Make(T)

  let buffer = Rb.make 1024
  let buffer_var = Lwd.var buffer

  let callback flow stop t ~username r =
    match r with
    | Ssh.Pty_req { width; height; _ } ->
      t.size <- (Int32.to_int width, Int32.to_int height);
      Lwt.return_unit
    | Ssh.Pty_set { width; height; _ } ->
      Lwt_condition.broadcast t.sigwinch
        (Int32.to_int width, Int32.to_int height);
      Lwt.return_unit
    | Ssh.Set_env _ -> Lwt.return_unit
    | Ssh.Channel { cmd; ic=_; oc=_; ec } ->
      let* () =
        ec (Printf.ksprintf Cstruct.of_string
              "Thanks for logging in! Currently, %S is unsupported\r\n\
               Check back later." cmd)
      in
      let* () = Lwt_switch.turn_off stop in
      Stack.TCP.close flow
    | Ssh.Shell { ic; oc; ec=_ } ->
      let ic () =
        let+ r = ic () in
        match r with
        | `Data cs -> `Data (Cstruct.map (function '\r' -> '\n' | c -> c) cs)
        | `Eof -> `Eof
      in
      let cursor = Lwd.var (0, 0) in
      let message m =
        let msg = Message.make ~nickname:username m in
        Lwd.set buffer_var (Rb.push buffer msg; buffer);
      in
      let quit () =
        let msg = Message.msgf "%s tried to quit, but it is not implemented" username in
        Lwd.set buffer_var (Rb.push buffer msg; buffer);
      in
      Lwd.set buffer_var
        (Rb.push buffer (Message.msgf "Welcome, %s!" username); buffer);
      let ui =
        let ( let* ) x f = Lwd.bind x ~f in
        let* prompt = Prompt.make ~quit ~message cursor in
        let* window = Window.make buffer_var in
        Lwd.return (Nottui.Ui.vcat [window; prompt])
      in
      Lwt.join [
        Nottui'.run ~cursor (t.size, t.sigwinch) ui ic oc;
      ]

  let start _random _time _mtime stack =
    let port = Key_gen.port () in
    let user_db = Banawa.Auth.Db.create 20 in
    let hostkey = Key_gen.hostkey () in
    let hostkey =
      match Banawa.Keys.of_string hostkey with
      | Ok k -> k
      | Error `Msg e ->
        Logs.err (fun m -> m "%s" e); exit 1
    in
    let server, msgs = Banawa.Server.make hostkey user_db in
    Stack.TCP.listen (Stack.tcp stack) ~port
      (fun flow ->
         let stop = Lwt_switch.create () in
         let state =
           { env = Hashtbl.create 0x10
           ; sigwinch = Lwt_condition.create ()
           ; size = (0, 0)
           }
         in
         let _ssh = Ssh.spawn_server ~stop server msgs flow (callback flow stop state) in
         Lwt.return_unit);
    fst (Lwt.wait ())
end