Terminal User Interface!

Thanks @dinosaure

config.ml

@@ -10,7 +10,14 @@ let hostkey =
 
 let main =
   let packages = [
+    package "banawa" ~pin:"git+https://github.com/sorbusursina/banawa-ssh.git";
     package "banawa-mirage" ~pin:"git+https://github.com/sorbusursina/banawa-ssh.git";
+    package "notty";
+    package "nottui"
+      ~pin:"git+https://github.com/dinosaure/lwd.git#9e78758d5987597bac65fe73bd30ff80741cfe83";
+    package "lwd"
+      ~pin:"git+https://github.com/dinosaure/lwd.git#9e78758d5987597bac65fe73bd30ff80741cfe83";
+    package "art";
   ] in
   let keys = [ Key.v port ; Key.v hostkey ] in
   foreign ~keys ~packages "Unikernel.Main" (random @-> time @-> mclock @-> stackv4v6 @-> job)

message.ml

@@ -0,0 +1,20 @@
+type t = { nickname : string; message : string }
+
+let nickname { nickname; _ } = nickname
+let message { message; _ } = message
+
+let split_at ~len:max str =
+  let rec go acc off len =
+    if len <= max then String.sub str off len :: acc
+    else go (String.sub str off max :: acc) (off + max) (len - max)
+  in
+  if max <= 0 then invalid_arg "split_at";
+  go [] 0 (String.length str) |> List.rev
+
+let split_at ~len { message; _ } =
+  split_at ~len message
+
+let make ~nickname message = { nickname; message }
+
+let msgf ?(nickname="Banawá") fmt =
+  Fmt.kstr (fun message -> { nickname; message }) fmt

message.mli

@@ -0,0 +1,11 @@
+type t
+
+val split_at : len:int -> t -> string list
+val make : nickname:string -> string -> t
+val nickname : t -> string
+val message : t -> string
+
+val msgf :
+  ?nickname:string
+  -> ('a, Format.formatter, unit, t) format4
+  -> 'a

nottui_mirage.ml

@@ -0,0 +1,87 @@
+let src = Logs.Src.create "nottui.mirage"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+module Make (Time : Mirage_time.S) = struct
+  open Notty_mirage.Make (Time)
+
+  let copy_until quit ~f input =
+    let quit = Lwt.map (fun () -> None) quit in
+    let stream, push = Lwt_stream.create () in
+    let rec go () =
+      Lwt.bind (Lwt.choose [ quit; Lwt_stream.peek input ]) @@ function
+      | None ->
+          push None;
+          Lwt.return_unit
+      | Some x ->
+          push (Some (f x));
+          Lwt.bind (Lwt_stream.junk input) go
+    in
+    Lwt.async go;
+    stream
+
+  let render ?quit ~size events document =
+    let renderer = Nottui.Renderer.make () in
+    let refresh_stream, push_refresh = Lwt_stream.create () in
+    let root =
+      Lwd.observe
+        ~on_invalidate:(fun _ ->
+          if not (Lwt_stream.is_closed refresh_stream) then
+            push_refresh (Some ()))
+        document
+    in
+    let quit, _do_quit =
+      match quit with
+      | Some quit -> (quit, None)
+      | None ->
+          let t, u = Lwt.wait () in
+          (t, Some u)
+    in
+    let events =
+      copy_until quit events ~f:(fun e ->
+          (e
+            : [ `Resize of _ | Notty.Unescape.event ]
+            :> [ `Resize of _ | Nottui.Ui.event ]))
+    in
+    let size = ref size in
+    let result, push = Lwt_stream.create () in
+    let refresh () =
+      let ui = Lwd.quick_sample root in
+      Nottui.Renderer.update renderer !size ui;
+      push (Some (Nottui.Renderer.image renderer))
+    in
+    refresh ();
+    let process_event = function
+      | #Nottui.Ui.event as event ->
+          ignore (Nottui.Renderer.dispatch_event renderer event)
+      | `Resize size' ->
+          size := size';
+          refresh ()
+    in
+    Lwt.async (fun () ->
+        Lwt.finalize
+          (fun () -> Lwt_stream.iter process_event events)
+          (fun () ->
+            push None;
+            Lwt.return_unit));
+    Lwt.async (fun () -> Lwt_stream.iter refresh refresh_stream);
+    result
+
+  let run ?cursor ?quit (size, sigwinch) document ic oc =
+    let term = Term.create (size, sigwinch) ic oc in
+    let images = render ?quit ~size (Term.events term) document in
+    let cursor () =
+      let cursor =
+        cursor
+        |> Option.map @@ fun cursor ->
+           Lwd.quick_sample (Lwd.observe (Lwd.get cursor))
+      in
+      Term.cursor term cursor
+    in
+    Lwt.finalize
+      (fun () ->
+        Lwt_stream.iter_s
+          (fun image -> Lwt.join [ Term.image term image; cursor () ])
+          images)
+      (fun () -> Term.release term)
+end

notty_mirage.ml

@@ -0,0 +1,147 @@
+let src = Logs.Src.create "notty.mirage"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+open Lwt.Infix
+open Notty
+
+let ( </> ) a b = Lwt.pick [ a >|= Either.left; b >|= Either.right ]
+let ( <??> ) a b = a >|= Either.left <?> (b >|= Either.right)
+
+module Make (Time : Mirage_time.S) = struct
+  module Lwt_condition = struct
+    include Lwt_condition
+
+    let map f v =
+      let v' = create () in
+      let rec go () =
+        wait v >>= fun x ->
+        broadcast v' (f x);
+        go ()
+      in
+      Lwt.async go;
+      v'
+
+    let unburst ~timeout v =
+      let v' = create () in
+      let rec delay x =
+        Time.sleep_ns timeout </> wait v >>= function
+        | Either.Left () ->
+            broadcast v' x;
+            start ()
+        | Either.Right x -> delay x
+      and start () = wait v >>= delay in
+      Lwt.async start;
+      v'
+  end
+
+  module Term = struct
+    let input_stream ic stop =
+      let flt = Unescape.create () in
+      let ibuf = Bytes.create 1024 in
+      let rec next () =
+        match Unescape.next flt with
+        | #Unescape.event as r -> Lwt.return_some r
+        | `End -> Lwt.return_none
+        | `Await -> (
+            ic () <??> stop >>= function
+            | Either.Right _ -> Lwt.return_none
+            | Either.Left `Eof ->
+                Unescape.input flt ibuf 0 0;
+                next ()
+            | Either.Left (`Data cs) ->
+                let rec go cs =
+                  if Cstruct.length cs > 0 then (
+                    let len = min (Bytes.length ibuf) (Cstruct.length cs) in
+                    Cstruct.blit_to_bytes cs 0 ibuf 0 len;
+                    Unescape.input flt ibuf 0 len;
+                    go (Cstruct.shift cs len))
+                  else Lwt.return_unit
+                in
+                go cs >>= next)
+      in
+      Lwt_stream.from next
+
+    type t =
+      { oc : Cstruct.t -> unit Lwt.t
+      ; trm : Notty.Tmachine.t
+      ; buf : Buffer.t
+      ; events : [ Unescape.event | `Resize of int * int ] Lwt_stream.t
+      ; stop : unit -> unit
+      }
+
+    let write t =
+      Tmachine.output t.trm t.buf;
+      let out = Buffer.contents t.buf in
+      Buffer.clear t.buf;
+      t.oc (Cstruct.of_string out)
+
+    let refresh t =
+      Tmachine.refresh t.trm;
+      write t
+
+    let image t image =
+      Tmachine.image t.trm image;
+      write t
+
+    let cursor t curs =
+      Tmachine.cursor t.trm curs;
+      write t
+
+    let set_size t dim = Tmachine.set_size t.trm dim
+    let size t = Tmachine.size t.trm
+
+    let release t =
+      if Tmachine.release t.trm then (
+        t.stop ();
+        write t (* TODO(dinosaure): send [`Eof] *))
+      else Lwt.return_unit
+
+    let resize dim stop on_resize =
+      (* TODO(dinosaure): we can save some allocations here but I mostly followed `notty-lwt`. *)
+      let rcond =
+        Lwt_condition.unburst ~timeout:1000L dim
+        |> Lwt_condition.map Option.some
+      in
+      let rec monitor () =
+        Lwt_condition.wait rcond <?> stop >>= function
+        | Some dim ->
+            on_resize dim;
+            monitor ()
+        | None -> Lwt.return_unit
+      in
+      Lwt.dont_wait monitor (fun exn ->
+          Logs.err @@ fun m ->
+          m "Got an exception from the resizer: %S" (Printexc.to_string exn));
+      Lwt_stream.from (fun () -> Lwt_condition.wait rcond <?> stop)
+      |> Lwt_stream.map (fun dim -> `Resize dim)
+
+    let create ?(dispose = true) ?(bpaste = true) ?(mouse = true)
+        (size, sigwinch) ic oc =
+      let stop, do_stop = Lwt.wait () in
+      let rec t =
+        lazy
+          { trm =
+              Tmachine.create ~mouse ~bpaste
+                Cap.ansi (* XXX(dinosaure): we assume! *)
+          ; oc
+          ; buf = Buffer.create 4096
+          ; stop = (fun () -> Lwt.wakeup do_stop None)
+          ; events =
+              Lwt_stream.choose
+                [ input_stream ic stop
+                ; ( resize sigwinch stop @@ fun dim ->
+                    let t = Lazy.force t in
+                    Buffer.reset t.buf;
+                    set_size t dim )
+                ]
+          }
+      in
+      let t = Lazy.force t in
+      set_size t size;
+      Lwt.async (fun () -> write t);
+      if dispose then Mirage_runtime.at_exit (fun () -> release t);
+      t
+
+    let events t = t.events
+  end
+end

prompt.ml

@@ -0,0 +1,129 @@
+open Nottui
+open Notty
+
+type t = {
+  message : string -> unit;
+  cursor : Rp.Cursor.cursor;
+}
+
+let make message =
+  let cursor = Rp.Cursor.create Rp.empty 0 in
+  { message; cursor }
+
+let map_cursor f state =
+  { state with cursor = f state.cursor }
+
+module Utils = struct
+  let move_cursor ?(visual = true) ~hook cursor = function
+    | `Left ->
+        let position = Rp.Cursor.position cursor in
+        (if position > 0 then
+           let cursor = Rp.Cursor.move_backward cursor 1 in
+           hook cursor);
+        `Handled
+    | `Right ->
+        let position = Rp.Cursor.position cursor in
+        let rope = Rp.Cursor.to_rope cursor in
+        let len = Rp.length rope in
+        let len = if visual then len - 1 else len in
+        (if position < len then
+           let cursor = Rp.Cursor.move_forward cursor 1 in
+           hook cursor);
+        `Handled
+
+  let is_print = function '\x21' .. '\x7e' | ' ' -> true | _ -> false
+
+  let render_cursor ~width cursor =
+    let rope = Rp.Cursor.to_rope cursor in
+    let position = Rp.Cursor.position cursor in
+    let length = Rp.length rope in
+    let offset = if position >= width then position - width else 0 in
+    let rope = Rp.sub rope offset (length - offset) in
+    (* XXX(dinosaure): shift our text according to [offset]. *)
+    let length = Rp.length rope in
+    let left, middle, right =
+      match position >= 0 && position < length with
+      | true ->
+          ( Rp.sub rope 0 position
+          , Some (Rp.get rope position)
+          , Rp.sub rope (position + 1) (length - position - 1) )
+      | false -> (rope, None, Rp.empty)
+    in
+    let middle =
+      match middle with
+      | None -> I.uchar A.empty (Uchar.of_char ' ') 1 1
+      | Some uchar -> I.uchar A.empty uchar 1 1
+    in
+    ( I.hcat [ I.strf "%a" Rp.print left; middle; I.strf "%a" Rp.print right ]
+    , position - offset )
+end
+
+module User_prompt = struct
+  let render ~cursor ~y ~w state =
+    let text, position =
+      Utils.render_cursor ~width:(max 0 (w - 3)) state.cursor
+    in
+    Lwd.set cursor (position + 1, y);
+    I.hcat [ I.char A.empty ' ' 1 1 ; text ]
+end
+
+let handler ~hook state = function
+  | `ASCII chr, [] when Utils.is_print chr ->
+    map_cursor (fun cursor ->
+        let cursor = Rp.Cursor.insert_char cursor (Uchar.of_char chr) in
+        Rp.Cursor.move_forward cursor 1)
+      state
+    |> hook;
+    `Handled
+  | `Uchar uchar, [] ->
+    map_cursor (fun cursor ->
+        let cursor = Rp.Cursor.insert_char cursor uchar in
+        Rp.Cursor.move_forward cursor 1)
+      state
+    |> hook;
+    `Handled
+  | `Backspace, [] ->
+    if Rp.Cursor.position state.cursor > 0 then
+      map_cursor (fun cursor ->
+          let cursor = Rp.Cursor.move_backward cursor 1 in
+          Rp.Cursor.delete cursor)
+        state
+      |> hook;
+    `Handled
+  | `Arrow (`Left | `Right as direction), [] ->
+    let hook cursor = hook { state with cursor } in
+    Utils.move_cursor ~visual:false ~hook state.cursor direction
+  | `Enter, [] ->
+    let rope = Rp.Cursor.to_rope state.cursor in
+    let msg =
+      let len = Rp.length rope in
+      let buf = Buffer.create len in
+      Rp.iter_range (Uutf.Buffer.add_utf_8 buf) rope 0 len;
+      Buffer.contents buf
+    in
+    state.message msg;
+    hook { state with cursor = Rp.Cursor.create Rp.empty 0 };
+    `Handled
+  | _ -> `Unhandled
+
+let make ~message cursor =
+  let ( let* ) x f = Lwd.bind x ~f in
+  let ( let+ ) x f = Lwd.map ~f x in
+  let ( and+ ) = Lwd.map2 ~f:(fun x y -> (x, y)) in
+  let state = Lwd.var (make message) in
+  let position = Lwd.var (0, 0) in
+  let hook = Lwd.set state in
+  let update_prompt state (y, w) =
+    let user = User_prompt.render ~cursor ~y ~w state in
+    Ui.keyboard_area (handler ~hook state) (Ui.atom user)
+  in
+  let update_position ~x:_ ~y ~w ~h:_ () =
+    let y', w' = Lwd.peek position in
+    if y' <> y || w' <> w then Lwd.set position (y, w)
+  in
+  let* prompts =
+    let+ state = Lwd.get state
+    and+ position = Lwd.get position in
+    update_prompt state position
+  in
+  Lwd.return (Ui.transient_sensor update_position prompts)

rb.ml

@@ -0,0 +1,69 @@
+type ('c, 'a) t =
+  { arr : 'a option array; mutable rd_cursor : int; mutable wr_cursor : int }
+  constraint 'c = < .. >
+
+type ro = < rd : unit >
+type wo = < wr : unit >
+type rdwr = < rd : unit ; wr : unit >
+type 'a rd = < rd : unit ; .. > as 'a
+type 'a wr = < wr : unit ; .. > as 'a
+
+let make len = { arr = Array.make len None; rd_cursor = 0; wr_cursor = 0 }
+
+exception Full
+exception Empty
+
+let length t =
+  if t.rd_cursor <= t.wr_cursor then t.wr_cursor - t.rd_cursor
+  else
+    let len = Array.length t.arr in
+    len - t.rd_cursor + t.wr_cursor
+
+let is_empty t = length t = 0
+let available t = Array.length t.arr - length t
+let is_full t = length t = Array.length t.arr
+let mask t v = v mod Array.length t.arr
+
+let push t v =
+  if is_full t then raise Full;
+  t.arr.(t.wr_cursor) <- Some v;
+  t.wr_cursor <- mask t (t.wr_cursor + 1)
+
+let pop t =
+  if is_empty t then raise Empty;
+  let[@warning "-8"] (Some v) = t.arr.(t.rd_cursor) in
+  t.rd_cursor <- mask t (t.rd_cursor + 1);
+  v
+
+let fit_and_push t v =
+  if is_full t then ignore (pop t);
+  push t v
+
+let drop t =
+  if is_empty t then raise Empty;
+  t.wr_cursor <- mask t (t.wr_cursor - 1)
+
+let iter ~f t a =
+  let i = ref t.rd_cursor in
+  let a = ref a in
+  while !i <> t.wr_cursor do
+    a := f (Option.get t.arr.(mask t !i)) !a;
+    incr i
+  done;
+  !a
+
+let rev_iter ~f t a =
+  let i = ref (t.wr_cursor - 1) in
+  let a = ref a in
+  while !i >= t.rd_cursor do
+    a := f (Option.get t.arr.(mask t !i)) !a;
+    decr i
+  done;
+  !a
+
+let ( .%[] ) t idx =
+  if idx >= length t then invalid_arg "Out of bounds";
+  Option.get t.arr.(mask t (t.rd_cursor + idx))
+
+external to_ro : ('c rd, 'a) t -> (ro, 'a) t = "%identity"
+external to_wo : ('c wr, 'a) t -> (wo, 'a) t = "%identity"

rb.mli

@@ -0,0 +1,25 @@
+(** A simple ring-buffer. *)
+
+type ('c, 'a) t constraint 'c = < .. >
+(** The type of a ring-buffer whose elements have type ['a]. *)
+
+type ro = < rd : unit >
+type wo = < wr : unit >
+type rdwr = < rd : unit ; wr : unit >
+type 'a rd = < rd : unit ; .. > as 'a
+type 'a wr = < wr : unit ; .. > as 'a
+
+val make : int -> (< rd : unit ; wr : unit >, 'a) t
+val length : ('c rd, 'a) t -> int
+val is_empty : ('c rd, 'a) t -> bool
+val available : ('c rd, 'a) t -> int
+val is_full : ('c rd, 'a) t -> bool
+val push : ('c wr, 'a) t -> 'a -> unit
+val pop : ('c wr, 'a) t -> 'a
+val fit_and_push : ('c wr, 'a) t -> 'a -> unit
+val drop : ('c wr, 'a) t -> unit
+val iter : f:('a -> 'acc -> 'acc) -> ('c rd, 'a) t -> 'acc -> 'acc
+val rev_iter : f:('a -> 'acc -> 'acc) -> ('c rd, 'a) t -> 'acc -> 'acc
+val ( .%[] ) : ('c rd, 'a) t -> int -> 'a
+val to_ro : ('c rd, 'a) t -> (ro, 'a) t
+val to_wo : ('c wr, 'a) t -> (wo, 'a) t

rope.ml

@@ -0,0 +1,539 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Copyright (C) Jean-Christophe Filliatre                               *)
+(*                                                                        *)
+(*  This software is free software; you can redistribute it and/or        *)
+(*  modify it under the terms of the GNU Library General Public           *)
+(*  License version 2.1, with the special exception on linking            *)
+(*  described in file LICENSE.                                            *)
+(*                                                                        *)
+(*  This software is distributed in the hope that it will be useful,      *)
+(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
+(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                  *)
+(*                                                                        *)
+(**************************************************************************)
+
+exception Out_of_bounds
+
+module type STRING = sig
+  type t
+  type char
+
+  val length : t -> int
+  val empty : t
+  val singleton : char -> t
+  val append : t -> t -> t
+  val get : t -> int -> char
+  val sub : t -> int -> int -> t
+  val iter_range : (char -> unit) -> t -> int -> int -> unit
+  val print : Format.formatter -> t -> unit
+end
+
+module type ROPE = sig
+  include STRING
+
+  val is_empty : t -> bool
+  val set : t -> int -> char -> t
+  val delete : t -> int -> t
+  val insert_char : t -> int -> char -> t
+  val insert : t -> int -> t -> t
+
+  module Cursor : sig
+    type cursor
+
+    val empty : cursor
+    val create : t -> int -> cursor
+    val position : cursor -> int
+    val to_rope : cursor -> t
+    val move_forward : cursor -> int -> cursor
+    val move_backward : cursor -> int -> cursor
+    val move : cursor -> int -> cursor
+    val get : cursor -> char
+    val set : cursor -> char -> cursor
+    val insert_char : cursor -> char -> cursor
+    val insert : cursor -> t -> cursor
+    val delete : cursor -> cursor
+    val print : Format.formatter -> cursor -> unit
+  end
+end
+
+module type CONTROL = sig
+  val small_length : int
+  val maximal_height : int
+end
+
+module Make (S : STRING) (C : CONTROL) = struct
+  type t =
+    (* s,ofs,len with 0 <= ofs < len(s), ofs+len <= len(s) *)
+    | Str of S.t * int * int
+    (* t1,t2,len,height with 0 < len t1, len t2 *)
+    | App of t * t * int * int
+
+  type char = S.char
+
+  let empty = Str (S.empty, 0, 0)
+  let length = function Str (_, _, n) | App (_, _, n, _) -> n
+  let of_string s = Str (s, 0, S.length s)
+  let singleton c = of_string (S.singleton c)
+  let height = function Str _ -> 0 | App (_, _, _, h) -> h
+
+  (* smart constructor *)
+  let mk_app t1 t2 =
+    App (t1, t2, length t1 + length t2, 1 + max (height t1) (height t2))
+
+  let app = function
+    | Str (_, _, 0), t | t, Str (_, _, 0) -> t
+    | Str (s1, ofs1, len1), Str (s2, ofs2, len2)
+      when len1 <= C.small_length && len2 <= C.small_length ->
+        Str (S.append (S.sub s1 ofs1 len1) (S.sub s2 ofs2 len2), 0, len1 + len2)
+    | App (t1, Str (s1, ofs1, len1), _, _), Str (s2, ofs2, len2)
+      when len1 <= C.small_length && len2 <= C.small_length ->
+        App
+          ( t1
+          , Str
+              ( S.append (S.sub s1 ofs1 len1) (S.sub s2 ofs2 len2)
+              , 0
+              , len1 + len2 )
+          , length t1 + len1 + len2
+          , 1 + height t1 )
+    | Str (s1, ofs1, len1), App (Str (s2, ofs2, len2), t2, _, _)
+      when len1 <= C.small_length && len2 <= C.small_length ->
+        App
+          ( Str
+              ( S.append (S.sub s1 ofs1 len1) (S.sub s2 ofs2 len2)
+              , 0
+              , len1 + len2 )
+          , t2
+          , len1 + len2 + length t2
+          , 1 + height t2 )
+    | t1, t2 ->
+        App (t1, t2, length t1 + length t2, 1 + max (height t1) (height t2))
+
+  let append t1 t2 = app (t1, t2)
+  let ( ++ ) = append
+
+  let _balance t =
+    let rec to_list ((n, l) as acc) = function
+      | Str _ as x -> (n + 1, x :: l)
+      | App (t1, t2, _, _) -> to_list (to_list acc t2) t1
+    in
+    let rec build n l =
+      assert (n >= 1);
+      if n = 1 then match l with [] -> assert false | x :: r -> (x, r)
+      else
+        let n' = n / 2 in
+        let t1, l = build n' l in
+        let t2, l = build (n - n') l in
+        (mk_app t1 t2, l)
+    in
+    let n, l = to_list (0, []) t in
+    let t, l = build n l in
+    assert (l = []);
+    t
+
+  let rec unsafe_get t i =
+    match t with
+    | Str (s, ofs, _) -> S.get s (ofs + i)
+    | App (t1, t2, _, _) ->
+        let n1 = length t1 in
+        if i < n1 then unsafe_get t1 i else unsafe_get t2 (i - n1)
+
+  let get t i =
+    if i < 0 || i >= length t then raise Out_of_bounds;
+    unsafe_get t i
+
+  let is_empty t = length t = 0
+
+  (* assumption: 0 <= start < stop <= len(t) *)
+  let rec mksub start stop t =
+    if start = 0 && stop = length t then t
+    else
+      match t with
+      | Str (s, ofs, _) -> Str (s, ofs + start, stop - start)
+      | App (t1, t2, _, _) ->
+          let n1 = length t1 in
+          if stop <= n1 then mksub start stop t1
+          else if start >= n1 then mksub (start - n1) (stop - n1) t2
+          else app (mksub start n1 t1, mksub 0 (stop - n1) t2)
+
+  let sub t ofs len =
+    let stop = ofs + len in
+    if ofs < 0 || len < 0 || stop > length t then raise Out_of_bounds;
+    if len = 0 then empty else mksub ofs stop t
+
+  let rec safe_iter_range f i n = function
+    | Str (s, ofs, _) -> S.iter_range f s (ofs + i) n
+    | App (t1, t2, _, _) ->
+        let n1 = length t1 in
+        if i + n <= n1 then safe_iter_range f i n t1
+        else if i >= n1 then safe_iter_range f (i - n1) n t2
+        else (
+          safe_iter_range f i n1 t1;
+          safe_iter_range f (i - n1) (n - n1) t2)
+
+  let iter_range f t ofs len =
+    if ofs < 0 || len < 0 || ofs + len > length t then raise Out_of_bounds;
+    safe_iter_range f ofs len t
+
+  let rec print fmt = function
+    | Str (s, ofs, len) -> S.print fmt (S.sub s ofs len) (* TODO: improve? *)
+    | App (t1, t2, _, _) ->
+        print fmt t1;
+        print fmt t2
+
+  (* assumption: 0 <= i < len t *)
+  let rec set_rec i c = function
+    | Str (s, ofs, len) when i = 0 ->
+        app (singleton c, Str (s, ofs + 1, len - 1))
+    | Str (s, ofs, len) when i = len - 1 ->
+        app (Str (s, ofs, len - 1), singleton c)
+    | Str (s, ofs, len) ->
+        app
+          (Str (s, ofs, i), app (singleton c, Str (s, ofs + i + 1, len - i - 1)))
+    | App (t1, t2, _, _) ->
+        let n1 = length t1 in
+        if i < n1 then app (set_rec i c t1, t2)
+        else app (t1, set_rec (i - n1) c t2)
+
+  (* set t i c = sub t 0 i ++ singleton c ++ sub t (i+1) (length t-i-1) *)
+  let set t i c =
+    let n = length t in
+    if i < 0 || i >= n then raise Out_of_bounds;
+    set_rec i c t
+
+  (* assumption: 0 <= i < len t *)
+  let rec delete_rec i = function
+    | Str (_, _, 1) ->
+        assert (i = 0);
+        empty
+    | Str (s, ofs, len) when i = 0 -> Str (s, ofs + 1, len - 1)
+    | Str (s, ofs, len) when i = len - 1 -> Str (s, ofs, len - 1)
+    | Str (s, ofs, len) ->
+        app (Str (s, ofs, i), Str (s, ofs + i + 1, len - i - 1))
+    | App (t1, t2, _, _) ->
+        let n1 = length t1 in
+        if i < n1 then app (delete_rec i t1, t2)
+        else app (t1, delete_rec (i - n1) t2)
+
+  (* delete t i = sub t 0 i ++ sub t (i + 1) (length t - i - 1) *)
+  let delete t i =
+    let n = length t in
+    if i < 0 || i >= n then raise Out_of_bounds;
+    delete_rec i t
+
+  (* assumption: 0 <= i < len t *)
+  let rec insert_rec i r = function
+    | Str _ as s when i = 0 -> app (r, s)
+    | Str (_, _, len) as s when i = len -> app (s, r)
+    | Str (s, ofs, len) -> Str (s, ofs, i) ++ r ++ Str (s, ofs + i, len - i)
+    | App (t1, t2, _, _) ->
+        let n1 = length t1 in
+        if i < n1 then app (insert_rec i r t1, t2)
+        else app (t1, insert_rec (i - n1) r t2)
+
+  (* insert t i r = sub t 0 i ++ r ++ sub t i (length t - i) *)
+  let insert t i r =
+    let n = length t in
+    if i < 0 || i > n then raise Out_of_bounds;
+    insert_rec i r t
+
+  let insert_char t i c = insert t i (singleton c)
+
+  (* cursors *)
+  module Cursor = struct
+    type path = Top | Left of path * t | Right of t * path
+
+    type cursor =
+      { rpos : int (* position of the cursor relative to the current leaf *)
+      ; lofs : int (* offset of the current leaf wrt whole rope *)
+      ; leaf : t (* the leaf i.e. Str (s,ofs,len) *)
+      ; path : path (* context = zipper *)
+      }
+    (* INVARIANT: 0 <= rpos <= len
+                  rpos = len iff we are located at the end of the whole rope *)
+    (* TODO(dinosaure): prove that [leaf] contains only a concrete [Str] value. *)
+
+    let position c = c.lofs + c.rpos
+
+    (* cursor -> rope *)
+    let rec unzip t = function
+      | Top -> t
+      | Left (p, tr) -> unzip (app (t, tr)) p
+      | Right (tl, p) -> unzip (app (tl, t)) p
+
+    let to_rope c = unzip c.leaf c.path
+
+    let create r i =
+      let rec zip lofs p = function
+        | Str (_, _, len) as leaf ->
+            assert (lofs <= i && i <= lofs + len);
+            { rpos = i - lofs; lofs; leaf; path = p }
+        | App (t1, t2, _, _) ->
+            let n1 = length t1 in
+            if i < lofs + n1 then zip lofs (Left (p, t2)) t1
+            else zip (lofs + n1) (Right (t1, p)) t2
+      in
+      if i < 0 || i > length r then raise Out_of_bounds;
+      zip 0 Top r
+
+    let get c =
+      match c.leaf with
+      | Str (s, ofs, len) ->
+          let i = c.rpos in
+          if i = len then raise Out_of_bounds;
+          S.get s (ofs + i)
+      | App _ -> assert false
+
+    (* TODO: improve using concatenations when lengths <= small_length *)
+    let set c x =
+      match c.leaf with
+      | Str (s, ofs, len) ->
+          let i = c.rpos in
+          if i = len then raise Out_of_bounds;
+          let leaf = Str (S.singleton x, 0, 1) in
+          if i = 0 then
+            if len = 1 then { c with leaf }
+            else
+              { c with leaf; path = Left (c.path, Str (s, ofs + 1, len - 1)) }
+          else if i = len - 1 then
+            { lofs = c.lofs + len - 1
+            ; rpos = 0
+            ; leaf
+            ; path = Right (Str (s, ofs, len - 1), c.path)
+            }
+          else
+            { lofs = c.lofs + i
+            ; rpos = 0
+            ; leaf
+            ; path =
+                Left
+                  ( Right (Str (s, ofs, i), c.path)
+                  , Str (s, ofs + i + 1, len - i - 1) )
+            }
+      | App _ -> assert false
+
+    let rec concat_path p1 p2 =
+      match p1 with
+      | Top -> p2
+      | Left (p, r) -> Left (concat_path p p2, r)
+      | Right (l, p) -> Right (l, concat_path p p2)
+
+    (* TODO: improve using concatenations when lengths <= small_length *)
+    let insert c r =
+      match c.leaf with
+      | Str (s, ofs, len) ->
+          let i = c.rpos in
+          let cr = create r 0 in
+          if i = 0 then
+            { cr with
+              lofs = c.lofs
+            ; path = concat_path cr.path (Left (c.path, c.leaf))
+            }
+          else if i = len then
+            { cr with
+              lofs = c.lofs + len
+            ; path = concat_path cr.path (Right (c.leaf, c.path))
+            }
+          else
+            { cr with
+              lofs = c.lofs + i
+            ; path =
+                concat_path cr.path
+                  (Left
+                     (Right (Str (s, ofs, i), c.path), Str (s, ofs + i, len - i)))
+            }
+      | App _ -> assert false
+
+    let insert_char c x = insert c (of_string (S.singleton x))
+
+    (* moves to start of next leaf (on the right) if any,
+       or raises [Out_of_bounds] *)
+    let next_leaf c =
+      let lofs = c.lofs + length c.leaf in
+      let rec down p = function
+        | Str _ as leaf -> { rpos = 0; lofs; leaf; path = p }
+        | App (t1, t2, _, _) -> down (Left (p, t2)) t1
+      in
+      let rec up t = function
+        | Top -> raise Out_of_bounds
+        | Right (l, p) -> up (mk_app l t) p
+        | Left (p, r) -> down (Right (t, p)) r
+      in
+      up c.leaf c.path
+
+    let rec move_forward_rec c n =
+      match c.leaf with
+      | Str (_, _, len) ->
+          let rpos' = c.rpos + n in
+          if rpos' < len then { c with rpos = rpos' }
+          else if rpos' = len then
+            try next_leaf c with Out_of_bounds -> { c with rpos = rpos' }
+          else
+            (* rpos' > len *)
+            let c = next_leaf c in
+            move_forward_rec c (rpos' - len)
+          (* TODO: improve? *)
+      | App _ -> assert false
+
+    let move_forward c n =
+      if n < 0 then invalid_arg "Rop.move_forward";
+      if n = 0 then c else move_forward_rec c n
+
+    (* moves to the end of previous leaf (on the left) if any,
+       raises [Out_of_bounds] otherwise *)
+    let prev_leaf c =
+      let rec down p = function
+        | Str (_, _, len) as leaf ->
+            { rpos = len; lofs = c.lofs - len; leaf; path = p }
+        | App (t1, t2, _, _) -> down (Right (t1, p)) t2
+      in
+      let rec up t = function
+        | Top -> raise Out_of_bounds
+        | Right (l, p) -> down (Left (p, t)) l
+        | Left (p, r) -> up (mk_app t r) p
+      in
+      up c.leaf c.path
+
+    let rec move_backward_rec c n =
+      match c.leaf with
+      | Str (_, _, _len) ->
+          let rpos' = c.rpos - n in
+          if rpos' >= 0 then { c with rpos = rpos' }
+          else
+            (* rpos' < 0 *)
+            let c = prev_leaf c in
+            move_backward_rec c (-rpos')
+      | App _ -> assert false
+
+    let move_backward c n =
+      if n < 0 then invalid_arg "Rop.move_backward";
+      if n = 0 then c else move_backward_rec c n
+
+    let move c n =
+      if n = 0 then c
+      else if n > 0 then move_forward_rec c n
+      else move_backward_rec c (-n)
+
+    let rec _leftmost lofs p = function
+      | Str _ as leaf -> { rpos = 0; lofs; leaf; path = p }
+      | App (t1, t2, _, _) -> _leftmost lofs (Left (p, t2)) t1
+
+    (* XXX(dinosaure): the code does not work when we
+       delete the last character and redo the operation.
+       Actually, this impl. works with:
+       - next_leaf { c with leaf = Str (s, ofs, len - 1) }
+       + try next_leaf { c with leaf = Str (s, ofs, len - 1) }
+       + with Out_of_bounds (* Top *) ->
+       +   { c with leaf= Str (s, ofs, len - 1) }
+
+       But we need to fuzz and prove it! *)
+    let delete c =
+      match c.leaf with
+      | Str (s, ofs, len) ->
+          let i = c.rpos in
+          if i = len then raise Out_of_bounds;
+          if i = 0 then
+            if len = 1 then
+              match c.path with
+              | Top -> { c with leaf = empty }
+              | Left (p, t) ->
+                  (* leftmost c.lofs p r *)
+                  let r = to_rope { c with leaf = t; path = p } in
+                  create r c.lofs
+              | Right (t, p) ->
+                  (* TODO: improve *)
+                  let r = to_rope { c with leaf = t; path = p } in
+                  create r c.lofs
+            else { c with leaf = Str (s, ofs + 1, len - 1) }
+          else if i = len - 1 then
+            try next_leaf { c with leaf = Str (s, ofs, len - 1) }
+            with Out_of_bounds (* Top *) ->
+              { c with leaf = Str (s, ofs, len - 1) }
+          else
+            { lofs = c.lofs + i
+            ; rpos = 0
+            ; leaf = Str (s, ofs + i + 1, len - i - 1)
+            ; path = Right (Str (s, ofs, i), c.path)
+            }
+      | App _ -> assert false
+
+    let print fmt c =
+      (* TODO: improve *)
+      let r = to_rope c in
+      let i = position c in
+      let before = sub r 0 i in
+      let after = sub r i (length r - i) in
+      print fmt before;
+      Format.fprintf fmt "|";
+      print fmt after
+
+    let empty = { rpos = 0; lofs = 0; leaf = Str (S.empty, 0, 0); path = Top }
+  end
+end
+
+(* flat strings *)
+module Str = struct
+  include String
+
+  let get = unsafe_get
+
+  type char = Char.t
+
+  let empty = ""
+  let singleton = String.make 1
+  let append = ( ^ )
+  let print = Format.pp_print_string
+
+  let iter_range f s ofs len =
+    (* safe *)
+    for i = ofs to ofs + len - 1 do
+      f (String.unsafe_get s i)
+    done
+end
+
+module Control = struct
+  let small_length = 256
+  let maximal_height = max_int
+end
+
+module String = Make (Str) (Control)
+
+(* ropes of any type (using arrays as flat sequences) *)
+
+module type Print = sig
+  type t
+
+  val print : Format.formatter -> t -> unit
+end
+
+module Make_array (X : Print) = struct
+  module A = struct
+    type char = X.t
+    type t = X.t array
+
+    let length = Array.length
+    let empty = [||]
+    let singleton l = [| l |]
+    let append = Array.append
+    let get = Array.get
+    let sub = Array.sub
+
+    let iter_range f a ofs len =
+      for i = ofs to ofs + len - 1 do
+        f a.(i)
+      done
+
+    let print fmt a = Array.iter (X.print fmt) a
+  end
+
+  module C = struct
+    let small_length = 256
+    let maximal_height = max_int
+  end
+
+  include Make (A) (C)
+
+  let of_array = of_string
+  let create n v = of_string (Array.make n v)
+  let init n f = of_string (Array.init n f)
+end

rope.mli

@@ -0,0 +1,220 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Copyright (C) Jean-Christophe Filliatre                               *)
+(*                                                                        *)
+(*  This software is free software; you can redistribute it and/or        *)
+(*  modify it under the terms of the GNU Library General Public           *)
+(*  License version 2.1, with the special exception on linking            *)
+(*  described in file LICENSE.                                            *)
+(*                                                                        *)
+(*  This software is distributed in the hope that it will be useful,      *)
+(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
+(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                  *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Ropes are persistent data structures for long sequences.  Elements
+    are of any type. When elements are characters, ropes thus implement
+    strings (with an interface identical to that of [String]) but with
+    far better performances w.r.t. concatenation of substring
+    extraction, especially on very large strings. *)
+
+(** Ropes are naturally implemented as a functor turning a (possibly
+    inefficient) data structure of ``strings'' into another (more
+    efficient) data structure with the same signature. *)
+
+exception Out_of_bounds
+
+(** Input signature for the functor *)
+
+module type STRING = sig
+  type t
+  type char
+
+  val length : t -> int
+  val empty : t
+  val singleton : char -> t
+  val append : t -> t -> t
+  val get : t -> int -> char
+
+  val sub : t -> int -> int -> t
+  (** [sub t ofs len] extracts the substring of length [len] at offset
+      [ofs], that is [t[ofs..ofs+len-1]].
+      Will always be called with a valid range. *)
+
+  val iter_range : (char -> unit) -> t -> int -> int -> unit
+  (** [iter_range f t ofs len] successively iterates [f] over characters
+      of [t] at offsets [ofs], [ofs+1], ..., [ofs+len-1], in this order.
+      Will always be called with a valid range. *)
+
+  val print : Format.formatter -> t -> unit
+end
+
+(** Output signature of the functor. Note that it extends signature
+    [STRING] and thus functor [Make] below can be iterated several
+    times. *)
+
+module type ROPE = sig
+  include STRING
+
+  val is_empty : t -> bool
+  (** [is_empty t] returns [true] if the given rope is empty. *)
+
+  val set : t -> int -> char -> t
+  (** [set t i c] returns a new rope identical to [t],
+      apart character [i] which is set to [c].
+      Raises [Out_of_bounds] if [i < 0 || i >= length t].
+      It is more equivalent to (but more efficient than) 
+      [sub t 0 i ++ singleton c ++ sub t (i+1) (length t-i-1)] *)
+
+  val delete : t -> int -> t
+  (** [delete t i] returns a new rope obtained by removing character [i]
+      in [t]. Raises [Out_of_bounds] if [i < 0 || i >= length t].
+      It is more equivalent to (but more efficient than)
+      [sub t 0 i ++ sub t (i + 1) (length t - i - 1)] *)
+
+  val insert_char : t -> int -> char -> t
+  (** [insert t i c] returns a new rope resulting from the insertion of 
+      character [c] at position [i] in [t], that right before character [i].
+      Raises [Out_of_bounds] if [i < 0 || i > length t].
+      It is more equivalent to (but more efficient than)
+      [sub t 0 i ++ singleton c ++ sub t i (length t - i)] *)
+
+  val insert : t -> int -> t -> t
+  (** [insert t i r] returns a new rope resulting from the insertion
+      of rope [r] at position [i] in [t].
+      Raises [Out_of_bounds] if [i < 0 || i > length t].
+      It is more equivalent to (but more efficient than)
+      [sub t 0 i ++ r ++ sub t i (length t - i)] *)
+
+  (** Cursors are persistent data structures to navigate within ropes.
+      When several operations are to be performed locally on a rope
+      (such as local deletions, insertions or even simple accesses),
+      then the use of cursors can be more efficient than the use of
+      rope operations. 
+      It is convenient to see the cursor as placed between two characters,
+      so that a rope of length [n] has [n+1] cursor positions. *)
+
+  module Cursor : sig
+    type cursor
+
+    val empty : cursor
+    (** [empty] is a cursor for an empty rope. *)
+
+    val create : t -> int -> cursor
+    (** [create t i] returns a cursor placed before character [i] of rope 
+        [t]. Raises [Out_of_bounds] is [i < 0 || i > length t].
+        Note that [i = length t] is a valid argument, resulting in a cursor
+        placed right after the last character of the rope (i.e. at the
+        end of the rope). *)
+
+    val position : cursor -> int
+    (** [position c] returns the position of cursor [c] in its rope. *)
+
+    val to_rope : cursor -> t
+    (** [to_rope c] returns the rope corresponding to cursor [c]. *)
+
+    val move_forward : cursor -> int -> cursor
+    (** [move_forward c n] moves cursor [c] [n] characters forward.
+        Raises [Invalid_argument] if [n < 0]. 
+        Raises [Out_of_bounds] if it moves the cursor beyond the end of
+        the rope. *)
+
+    val move_backward : cursor -> int -> cursor
+    (** [move_backward c n] moves cursor [c] [n] characters
+        backward.  Raises [Invalid_argument] if [n < 0].  Raises
+        [Out_of_bounds] if it moves the cursor beyond the start of
+        the rope. *)
+
+    val move : cursor -> int -> cursor
+    (** [move c n] moves cursor [c] [n] characters away from its current
+        location, relatively to the sign of [n] (i.e. forward if [n > 0] and
+        backward if [n < 0]). Raises [Out_of_bounds] if it moves the cursor
+        beyond the start or the end of the rope. *)
+
+    val get : cursor -> char
+    (** [get c] returns the character right after cursor
+        [c].  Raises [Out_of_bounds] if the cursor is located at the
+        end of the rope. *)
+
+    val set : cursor -> char -> cursor
+    (** [set c x] returns a new cursor identical to [c] apart from
+        the character right after the cursor position, which is set
+        to [x].  Raises [Out_of_bounds] if the cursor is located at
+        the end of the rope. *)
+
+    val insert_char : cursor -> char -> cursor
+    (** [insert_char c x] returns a new cursor obtained from [c] by
+        inserting character [x] at the cursor position. The new
+        cursor is located right before the newly inserted character
+        (i.e. at the same absolute position in the rope). *)
+
+    val insert : cursor -> t -> cursor
+    (** [insert c r] is similar to [insert_char] but inserts a rope [r] at
+        the cursor point instead of a character. *)
+
+    val delete : cursor -> cursor
+    (** [delete c] deletes the character right after the cursor location.
+        Raises [Out_of_bounds] if the cursor is located at the end of the 
+        rope. *)
+
+    val print : Format.formatter -> cursor -> unit
+    (** [print fmt c] prints cursor [c] on formatter [fmt], as a string
+        ["abc...|def..."] where ["abc..."] is the portion of the rope
+        before the cursor position and ["def..."] the portion after. *)
+  end
+end
+
+(** The functor to build ropes, turning an implemention of strings [S]
+    into an implemention of ropes.
+
+    It is controlled by two parameters: 
+    - [small_length] is the maximal length under which we perform
+    concatenation of flat strings, i.e. when two ropes of length at most
+    [small_length] are concatenated, then the corresponding flat string is
+    built. 
+    - [maximal_height] is the threshold for rebalancing: when a rope has
+    height at least [maximal_height] it is then rebalanced; setting 
+    [small_length] to [max_int] will result in ropes that are never 
+    rebalanced (which is perfectly fine in many applications).
+*)
+
+module type CONTROL = sig
+  val small_length : int
+  val maximal_height : int
+end
+
+module Make (S : STRING) (C : CONTROL) : sig
+  include ROPE with type char = S.char
+
+  val of_string : S.t -> t
+end
+
+(** Instance: usual strings (i.e. with [type char = Char.t]) is a
+    particular instance of functor [Make] above, which is directly
+    provided here as module [S] *)
+
+module String : sig
+  include ROPE with type char = Char.t
+
+  val of_string : string -> t
+end
+
+(** Elements of ropes can be of any type, of course. In that case,
+    they must rather be seen as arrays instead of strings. The
+    following functor builds ropes for a given (printable) type of
+    elements (using arrays internally for flat strings). *)
+
+module type Print = sig
+  type t
+
+  val print : Format.formatter -> t -> unit
+end
+
+module Make_array (X : Print) : sig
+  include ROPE with type char = X.t
+
+  val of_array : X.t array -> t
+  val create : int -> X.t -> t
+  val init : int -> (int -> X.t) -> t
+end

rp.ml

@@ -0,0 +1,30 @@
+include Rope.Make_array (struct
+  include Uchar
+
+  let uchar_to_utf_8 =
+    let buf = Buffer.create 16 in
+    fun uchar ->
+      Uutf.Buffer.add_utf_8 buf uchar;
+      let res = Buffer.contents buf in
+      Buffer.clear buf;
+      res
+
+  let print =
+    Fmt.if_utf_8
+      Fmt.(using uchar_to_utf_8 string)
+      Fmt.(using Uchar.to_int (any "U+04X"))
+end)
+
+let to_utf_8_string rope =
+  let len = length rope in
+  let buf = Buffer.create len in
+  iter_range (Uutf.Buffer.add_utf_8 buf) rope 0 len;
+  Buffer.contents buf
+
+let of_utf_8_string str =
+  Uutf.String.fold_utf_8
+    (fun (rope, upos) _bpos -> function
+      | `Malformed _ -> (insert_char rope upos Uutf.u_rep, succ upos)
+      | `Uchar uchr -> (insert_char rope upos uchr, succ upos))
+    (empty, 0) str
+  |> fst

unikernel.ml

@@ -1,14 +1,16 @@
 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)
 
-  type message =
+  let c : Message.t Lwt_condition.t = Lwt_condition.create ()
-    | Message of { sender : string; message : string }
-    | Join of string
-    | Part of string
-
-  let c : message Lwt_condition.t = Lwt_condition.create ()
 
   let read username ic =
     let rec loop () =
@@ -19,36 +21,28 @@ module Main (_ : Mirage_random.S) (T : Mirage_time.S) (M : Mirage_clock.MCLOCK)
         if String.equal message "" then
           loop ()
         else
-          let m = Message {
+          let m = Message.make ~nickname:username (String.trim message) in
-              sender = username;
-              message = String.trim message;
-            } in
           Lwt_condition.broadcast c m;
           loop ()
       | `Eof ->
-        Lwt_condition.broadcast c (Part username);
+        Lwt_condition.broadcast c (Message.make ~nickname:"<--" username);
         Lwt.return_unit
     in
     loop ()
 
   let rec write me oc =
     let* m = Lwt_condition.wait c in
-    match m with
+    if String.equal (Message.nickname m) me then
-    | Message { sender; message=_ } when String.equal sender me ->
       write me oc
-    | Message { sender; message } ->
+    else
-      let* () = oc (Printf.ksprintf Cstruct.of_string "\x07%s: %s\r\n" sender message) in
+      let* () =
+        oc (Printf.ksprintf Cstruct.of_string "\x07%s: %s\r\n"
+              (Message.nickname m) (Message.message m))
+      in
       write me oc
-    | Join username ->
-      let* () = oc (Printf.ksprintf Cstruct.of_string "--> %s joined!\r\n" username) in
-      write me oc
-    | Part username ->
-      let* () = oc (Printf.ksprintf Cstruct.of_string "<-- %s left\r\n" username) in
-      write me oc
-
 
   let chat flow stop username ic oc =
-    Lwt_condition.broadcast c (Join username);
+    Lwt_condition.broadcast c (Message.make ~nickname:"-->" username);
     let* () = oc (Cstruct.of_string (Printf.sprintf "Hello, %s!\r\n" username)) in
     let* () =
       Lwt.pick [
@@ -59,16 +53,46 @@ module Main (_ : Mirage_random.S) (T : Mirage_time.S) (M : Mirage_clock.MCLOCK)
     let* () = Lwt_switch.turn_off stop in
     Stack.TCP.close flow
 
-  let callback flow stop ~username r =
+  let callback flow stop t ~username r =
     match r with
-    | Ssh.Pty_req _ | Ssh.Pty_set _ | Ssh.Set_env _ ->
+    | Ssh.Pty_req { width; height; _ } ->
+      t.size <- (Int32.to_int width, Int32.to_int height);
       Lwt.return_unit
-    | Ssh.Channel { cmd; ic; oc; ec; } ->
+    | Ssh.Pty_set { width; height; _ } ->
-      chat flow stop username ic oc
+      Lwt_condition.broadcast t.sigwinch
-    | Ssh.Shell { ic; oc; ec; } ->
+        (Int32.to_int width, Int32.to_int height);
-      let* () = ec (Cstruct.of_string "Banawá-chat does currently not work well with TTY.\r\n\
+      Lwt.return_unit
-                                       Consider reconnecting without tty (ssh -T)\r\n") in
+    | Ssh.Set_env _ -> Lwt.return_unit
+    | Ssh.Channel { cmd=_; ic; oc; ec=_ } ->
       chat flow stop username ic oc
+    | 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 = Lwt_condition.broadcast c (Message.make ~nickname:username m) in
+      let buffer = Rb.make 100 in
+      Rb.push buffer (Message.msgf "Welcome, %s!" username);
+      let buffer_var = Lwd.var buffer in
+      let ui =
+        let ( let* ) x f = Lwd.bind x ~f in
+        let* prompt = Prompt.make ~message cursor in
+        let* window = Window.make buffer_var in
+        Lwd.return (Nottui.Ui.vcat [window; prompt])
+      in
+      let rec handle_receive () =
+        let* msg = Lwt_condition.wait c in
+        Lwd.set buffer_var (Rb.push buffer msg; buffer);
+        handle_receive ()
+      in
+      Lwt_condition.broadcast c (Message.make ~nickname:"-->" username);
+      Lwt.join [
+        Nottui'.run ~cursor (t.size, t.sigwinch) ui ic oc;
+        handle_receive ();
+      ]
 
   let start _random _time _mtime stack =
     let port = Key_gen.port () in
@@ -84,7 +108,13 @@ module Main (_ : Mirage_random.S) (T : Mirage_time.S) (M : Mirage_clock.MCLOCK)
     Stack.TCP.listen (Stack.tcp stack) ~port
       (fun flow ->
          let stop = Lwt_switch.create () in
-         let _ssh = Ssh.spawn_server ~stop server msgs flow (callback flow stop) 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

window.ml

@@ -0,0 +1,78 @@
+open Nottui
+open Notty
+
+type t = { w : int; h : int; p : int }
+
+let render_message ~width ~width_nicknames msg =
+  let width_message =
+    max 1 (width - width_nicknames - 1)
+  in
+  let message = Message.split_at ~len:width_message msg in
+  let color = A.white in
+  let rest =
+    List.map @@ fun msg ->
+    I.hcat
+      [ I.void width_nicknames 1
+      ; I.strf "│"
+      ; I.strf "%s" msg
+      ]
+  in
+  I.vcat
+    (I.hcat
+       [ I.strf " "
+       ; I.hsnap ~align:`Right width_nicknames
+           (I.strf ~attr:A.(fg color) "%s" (Message.nickname msg))
+       ; I.strf "│"
+       ; I.strf "%s" (List.hd message)
+       ]
+    :: rest (List.tl message))
+
+let width_nicknames msgs =
+  let f msg acc = max (String.length (Message.nickname msg)) acc in
+  Rb.iter ~f msgs 0
+ 
+let render { w; h; p } msgs =
+  let idx = ref (Rb.length msgs - 1 - p) in
+  let image = ref I.empty in
+  let message = ref I.empty in
+  let width_nicknames = width_nicknames msgs in
+  while
+    !idx >= 0
+    &&
+    (message :=
+       render_message ~width_nicknames ~width:w msgs.Rb.%[!idx];
+     I.height !message + I.height !image <= h)
+  do
+    (image := I.(!message <-> !image));
+    decr idx
+  done;
+  Ui.atom (I.vsnap ~align:`Bottom h !image)
+
+let handler ~hook:_ _state _buffer _key = `Unhandled
+
+let make w =
+  let ( let* ) x f = Lwd.bind ~f x in
+  let ( let+ ) x f = Lwd.map ~f x in
+  let ( and+ ) = Lwd.map2 ~f:(fun x y -> (x, y)) in
+
+  let state = Lwd.var { w = 0; h = 0; p = 0 } in
+  let hook = Lwd.set state in
+
+  let* document =
+    let+ state = Lwd.get state
+    and+ buffer = Lwd.get w in
+    Ui.keyboard_area
+      (handler ~hook state buffer)
+      (render state buffer)
+  in
+
+  let update_size ~w ~h =
+    let state' = Lwd.peek state in
+    if state'.w <> w || state'.h <> h then Lwd.set state { state' with w; h }
+  in
+
+  let measure_size document =
+    Ui.size_sensor update_size (Ui.resize ~sh:1 document)
+  in
+
+  Lwd.return (measure_size document)