├── dune ├── src ├── Makefile ├── dune ├── utils.ml ├── TODO.md ├── widgets.ml └── main.ml ├── .gitignore ├── .ocamlformat ├── .gitmodules ├── Makefile ├── dune-project ├── README.md ├── citty.opam └── LICENSE.md /dune: -------------------------------------------------------------------------------- 1 | (vendored_dirs lwd ocaml-ci) 2 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | dune exec ./main.bc 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | _opam/ 3 | .merlin 4 | *.install 5 | error.log 6 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.15.0 2 | profile = conventional 3 | break-infix = fit-or-vertical 4 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (modes byte exe) 4 | (libraries ocaml-ci-api current_rpc capnp-rpc-unix lwd nottui nottui-lwt 5 | nottui-widgets)) 6 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "ocaml-ci"] 2 | path = ocaml-ci 3 | url = https://github.com/ocaml-ci/ocaml-ci.git 4 | [submodule "lwd"] 5 | path = lwd 6 | url = https://github.com/let-def/lwd.git 7 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | dune build ./src/main.bc 3 | 4 | run: 5 | dune build ./src/main.bc 6 | dune exec ./src/main.bc 2> error.log 7 | cat error.log 8 | 9 | test-stress: 10 | dune exec ./lib/tests/stress.exe 11 | 12 | test-reranger: 13 | dune exec ./lib/tests/reranger.bc 14 | 15 | test-misc: 16 | dune exec ./lib/tests/misc.bc 17 | 18 | clean: 19 | dune clean 20 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | 3 | (name citty) 4 | 5 | (generate_opam_files true) 6 | (source (github ocaml-ci/citty)) 7 | (authors "Frédéric Bour") 8 | (maintainers "Navin Keswani " "Tim McGilchrist ") 9 | (license "MIT") 10 | 11 | (package 12 | (name citty) 13 | (synopsis "CI in TTY") 14 | (depends current_rpc capnp capnp-rpc-unix lwt notty fpath fmt)) 15 | -------------------------------------------------------------------------------- /src/utils.ml: -------------------------------------------------------------------------------- 1 | let rec interleave sep = function 2 | | ([] | [ _ ]) as tail -> tail 3 | | hd :: tail -> 4 | let tail = interleave sep tail in 5 | hd :: sep :: tail 6 | 7 | let failwithf fmt = Printf.ksprintf failwith fmt 8 | 9 | let rec filter_map f = function 10 | | [] -> [] 11 | | x :: xs -> ( 12 | match f x with 13 | | None -> filter_map f xs 14 | | Some x' -> x' :: filter_map f xs ) 15 | 16 | let update_if_changed v x = if Lwd.peek v <> x then Lwd.set v x 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # A WIP terminal UI for OCaml-ci 2 | 3 | ### 1. Clone the project 4 | 5 | ```bash 6 | git clone --recursive https://github.com/ocaml-ci/citty.git 7 | ``` 8 | 9 | Note: if you missed the `--recursive` flag, run `git submodule init` 10 | 11 | ### 2. Install dependencies 12 | 13 | ```bash 14 | opam pin add --yes ocaml-ci/ocurrent/ 15 | opam install --yes --deps-only ./citty.opam 16 | ``` 17 | 18 | ### 2. Install a capability file 19 | 20 | For now, Citty assumes that the capability is stored in `~/.ocaml-ci.cap`. 21 | 22 | ### 3. Run! 23 | 24 | ```bash 25 | make run 26 | # dune exec ./src/main.bc 27 | ``` 28 | ### 4. Quit it 29 | 30 | `(alt,meta,...)-q`, or just kill the process :-). 31 | TODO: add a clean way to exit. 32 | -------------------------------------------------------------------------------- /citty.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "CI in TTY" 4 | maintainer: [ 5 | "Navin Keswani " 6 | "Tim McGilchrist " 7 | ] 8 | authors: ["Frédéric Bour"] 9 | license: "MIT" 10 | homepage: "https://github.com/ocaml-ci/citty" 11 | bug-reports: "https://github.com/ocaml-ci/citty/issues" 12 | depends: [ 13 | "dune" {>= "2.0"} 14 | "current_rpc" 15 | "capnp" 16 | "capnp-rpc-unix" 17 | "lwt" 18 | "notty" 19 | "fpath" 20 | "fmt" 21 | ] 22 | build: [ 23 | ["dune" "subst"] {pinned} 24 | [ 25 | "dune" 26 | "build" 27 | "-p" 28 | name 29 | "-j" 30 | jobs 31 | "@install" 32 | "@runtest" {with-test} 33 | "@doc" {with-doc} 34 | ] 35 | ] 36 | dev-repo: "git+https://github.com/ocaml-ci/citty.git" 37 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) Frédéric Bour 2019-2020 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /src/TODO.md: -------------------------------------------------------------------------------- 1 | UI framework 2 | ============ 3 | 4 | 1) _Resource management_. Capnp references are never released, we need a 5 | pattern to tie a resource to an UI element so that their lifetime can be 6 | managed together. 7 | 8 | ... That's annoying, I feel like the Capnp interface is not helping much. 9 | 10 | 2) Customizing UI scheduling. The UI is composed in two passes: 11 | - layout is computed from leafs to root (building the Nottui values) 12 | - rendered image is composed from root to leafs 13 | 14 | These passes are informal, but for implementing more difficult layout and 15 | drawing schemes it might make sense to make these passes explicit and allow 16 | "hooking" into them (for instance, the update content after layout and before 17 | rendering). 18 | Such as text layout which depends on the "box layout" having been computed 19 | already or "virtual" widgets which determine their contents based on the 20 | visible area. 21 | 22 | 3) Lwd: to get a finer grained invalidation model, maybe a node to trace 23 | effects... 24 | 25 | Citty 26 | ===== 27 | 28 | 1) _Search and visualize log_. Add searching ('/') and highlighting, detect 29 | some patterns (e.g. regular-expressions). 30 | -------------------------------------------------------------------------------- /src/widgets.ml: -------------------------------------------------------------------------------- 1 | open Nottui 2 | 3 | let empty = Lwd.pure Ui.empty 4 | 5 | (* Find the index of next control character in a string *) 6 | let control_character_index str i = 7 | let len = String.length str in 8 | let i = ref i in 9 | while 10 | let i = !i in 11 | i < len && str.[i] >= ' ' 12 | do 13 | incr i 14 | done; 15 | if !i = len then raise Not_found; 16 | !i 17 | 18 | (* Typeset the strings stored in a table with a fixed width, wrapping 19 | characters at the end of the line. *) 20 | let word_wrap_string_table table width = 21 | if width <= 0 then empty 22 | else 23 | (* Wrap at least around 8 characters *) 24 | let width = max 8 width in 25 | (* Split lines around newline characters. 26 | Control characters will normally be \n or \r, but other might sneak in. 27 | TODO: allow customization of handling of control characters? *) 28 | let rec split_lines x acc i = 29 | match control_character_index x i with 30 | | exception Not_found -> String.sub x i (String.length x - i) :: acc 31 | | j -> split_lines x (String.sub x i (j - i) :: acc) (j + 1) 32 | in 33 | (* Turn an input line into visual lines. 34 | Split the line into chunks of the right width, 35 | surrounding the splits with ↳ and ↲. *) 36 | let wrap_line str = 37 | let lines = ref [] in 38 | let pos = ref 0 in 39 | let len = String.length str in 40 | (* Compute visual lines *) 41 | while len - !pos > if !pos > 0 then width - 1 else width do 42 | if !pos = 0 then ( 43 | lines := (String.sub str !pos (width - 1) ^ "↲") :: !lines; 44 | pos := !pos + (width - 1) ) 45 | else ( 46 | lines := ("↳" ^ String.sub str !pos (width - 2) ^ "↲") :: !lines; 47 | pos := !pos + (width - 2) ) 48 | done; 49 | 50 | (* Produce an image for one visual line *) 51 | let render_line str = Ui.atom Notty.(I.string A.empty str) in 52 | match !lines with 53 | | [] -> 54 | (* Nothing to split, render the full input *) 55 | render_line str 56 | | lines -> 57 | (* Something was split: 58 | - append remaining characters 59 | - render each line 60 | - concatenate them vertically *) 61 | ("↳" ^ String.sub str !pos (len - !pos)) :: lines 62 | |> List.rev_map render_line 63 | |> Lwd_utils.pure_pack Ui.pack_y 64 | in 65 | (* Stack three images vertically *) 66 | let join3 a b c = Ui.join_y a (Ui.join_y b c) in 67 | 68 | (* Map reduce the table, lifting the strings to an intermediate type 69 | that is suitable for word wrapping. 70 | 71 | The input is provided as a stream of strings, but they don't represent 72 | lines, just a continuous stream of characters. 73 | Therefore we don't know where a line starts or ends until we see a 74 | control character. 75 | 76 | So individual pieces are represented as values of type 77 | [string * (ui * string) option] 78 | as follow: 79 | - a string "foo" that does not contain any newline character is 80 | [("foo", None)] 81 | - a string "foo\nbar" that contains a single newline character is 82 | [("foo", Some (empty, "bar"))] 83 | - a string "foo\nbar\nbaz" that contains two newline characters, and 84 | thus one fully defined line, is 85 | [("foo", Some (I.string "bar", "baz"))] 86 | - a string "foo\nbar\nbaz\foo" that contains three newline characters, 87 | and two fully defined lines, is 88 | [("foo", Some (I.vcat [string "bar"; string "baz"], "foo"))] 89 | 90 | The informal interpretation is thus [(prefix, Some (body, suffix))]: 91 | - [prefix] is string of character to append to the preceding line 92 | - [body] is the image of lines already rendered 93 | - [suffix] is string of character to prepend to the following line 94 | 95 | This type can be given monoid structure compatible with the string 96 | monoid. This gives a wrapping algorithm with efficient concatenation, 97 | suitable for incrementally rendering a stream of characters. 98 | *) 99 | Lwd_table.map_reduce 100 | (fun _ x -> 101 | match control_character_index x 0 with 102 | | exception Not_found -> (x, None) 103 | | i -> ( 104 | let prefix = String.sub x 0 i in 105 | match split_lines x [] (i + 1) with 106 | | [] -> assert false 107 | | suffix :: rest -> 108 | let ui = 109 | rest 110 | |> List.rev_map wrap_line 111 | |> Lwd_utils.pure_pack Ui.pack_y 112 | in 113 | (prefix, Some (ui, suffix)) )) 114 | ( ("", None), 115 | fun (pa, ta) (pb, tb) -> 116 | match ta with 117 | | None -> (pa ^ pb, tb) 118 | | Some (ua, sa) -> 119 | let line = sa ^ pb in 120 | ( pa, 121 | Some 122 | ( match tb with 123 | | None -> (ua, line) 124 | | Some (ub, sb) -> (join3 ua (wrap_line line) ub, sb) ) ) ) 125 | table 126 | |> (* After reducing the table, we produce the final UI, interpreting 127 | unterminated prefix and suffix has line of their own. *) 128 | Lwd.map (function 129 | | pa, None -> wrap_line pa 130 | | pa, Some (ub, sb) -> join3 (wrap_line pa) ub (wrap_line sb)) 131 | 132 | (* Grab the mouse and repeat an event until button is released *) 133 | let grab_and_repeat f = 134 | let stop = ref false in 135 | let rec step delay () = 136 | if not !stop then 137 | Lwt.bind (f ()) @@ fun () -> Lwt.bind (Lwt_unix.sleep delay) (step 0.025) 138 | else Lwt.return_unit 139 | in 140 | Lwt.async (step 0.4); 141 | `Grab ((fun ~x:_ ~y:_ -> ()), fun ~x:_ ~y:_ -> stop := true) 142 | 143 | let on_click f ~x:_ ~y:_ = function 144 | | `Left -> 145 | f (); 146 | `Handled 147 | | _ -> `Unhandled 148 | 149 | let button attr text f = 150 | Ui.mouse_area (on_click f) (Nottui_widgets.string ~attr text) 151 | 152 | (* Render a vertical scroll representing a [Nottui_widgets.scroll_state]. 153 | The [set_scroll] function is called when the state should be updated to 154 | reflect a user interaction. *) 155 | let vertical_scrollbar ~set_scroll (st : Nottui_widgets.scroll_state) = 156 | let bar color h = Notty.(I.char A.(bg color) ' ' 1 h) in 157 | let gray = Notty.A.gray 1 in 158 | let lightgray = Notty.A.white in 159 | if st.visible = 0 then Ui.atom Notty.I.empty 160 | else if st.total > st.visible then 161 | (* Compute size of the handle inside the bar *) 162 | let ratio = max 1 (st.visible * st.visible / st.total) in 163 | let rest = st.visible - ratio in 164 | let prefix = rest * st.position / st.bound in 165 | let suffix = rest - prefix in 166 | (* React to mouse events on the scroll bar *) 167 | let mouse_handler ~x:_ ~y = function 168 | | `Left -> 169 | if y < prefix then 170 | let position = ref st.position in 171 | grab_and_repeat (fun () -> 172 | position := max 0 (!position - (st.visible / 2)); 173 | set_scroll { st with position = !position }; 174 | Lwt.return_unit) 175 | else if y > prefix + ratio then 176 | let position = ref st.position in 177 | grab_and_repeat (fun () -> 178 | position := min st.bound (!position + (st.visible / 2)); 179 | set_scroll { st with position = !position }; 180 | Lwt.return_unit) 181 | else 182 | `Grab 183 | ( (fun ~x:_ ~y:y' -> 184 | let dy = y' - y in 185 | let position = 186 | float st.position 187 | +. (float dy /. float st.visible *. float st.total) 188 | in 189 | let position = max 0 (min st.bound (int_of_float position)) in 190 | set_scroll { st with position }), 191 | fun ~x:_ ~y:_ -> () ) 192 | | _ -> `Unhandled 193 | in 194 | Notty.I.vcat [ bar gray prefix; bar lightgray ratio; bar gray suffix ] 195 | |> Ui.atom 196 | |> Ui.mouse_area mouse_handler 197 | else Ui.atom (bar gray st.visible) 198 | 199 | let list_box ~items ~render ~select = 200 | let prev_highlight = ref (Lwd.var false) in 201 | let select_item (var, item) = 202 | Lwd.set !prev_highlight false; 203 | Lwd.set var true; 204 | prev_highlight := var; 205 | select item 206 | in 207 | let select_next list = 208 | let rec seek = function 209 | | [] -> false 210 | | ((x, _), _) :: (item, _) :: _ when Lwd.peek x -> 211 | select_item item; 212 | true 213 | | _ :: rest -> seek rest 214 | in 215 | if seek list then () 216 | else match list with (item, _) :: _ -> select_item item | [] -> () 217 | and select_prev list = 218 | let rec seek = function 219 | | [] -> () 220 | | (item, _) :: ((y, _), _) :: _ when Lwd.peek y -> select_item item 221 | | [ (item, _) ] -> select_item item 222 | | _ :: rest -> seek rest 223 | in 224 | seek list 225 | and activate list = 226 | let rec seek = function 227 | | [] -> false 228 | | (item, _) :: _ when Lwd.peek (fst item) -> 229 | select_item item; 230 | true 231 | | _ :: rest -> seek rest 232 | in 233 | if seek list then () 234 | else match list with (item, _) :: _ -> select_item item | [] -> () 235 | in 236 | let show_item x = 237 | let item = (Lwd.var false, x) in 238 | let ui = 239 | Lwd.map' (Lwd.get (fst item)) @@ fun highlight -> 240 | Ui.mouse_area 241 | (on_click @@ fun () -> select_item item) 242 | (render (snd item) highlight) 243 | in 244 | (item, ui) 245 | in 246 | let items = List.map show_item items in 247 | let view = Lwd_utils.pack Ui.pack_y (List.map snd items) in 248 | let dispatch = function 249 | | `Select_prev -> select_prev items 250 | | `Select_next -> select_next items 251 | | `Activate -> activate items 252 | in 253 | (view, dispatch) 254 | 255 | let fit_string str len = 256 | let len0 = String.length str in 257 | if len < len0 then String.sub str 0 len 258 | else if len > len0 then str ^ String.make (len - len0) ' ' 259 | else str 260 | 261 | module Pane : sig 262 | type 'a t 263 | 264 | type 'a view 265 | 266 | val make : unit -> 'a t 267 | 268 | val render : 'a t -> ui Lwd.t 269 | 270 | val current_view : 'a t -> [ `Left | `Middle | `Right ] -> 'a view option 271 | 272 | val open_root : 'a t -> 'a view 273 | 274 | val open_subview : 'a view -> 'a view 275 | 276 | val close_subview : 'a view -> unit 277 | 278 | val set : 'a view -> 'a option -> ui Lwd.t -> unit 279 | 280 | val get : 'a view -> 'a option 281 | end = struct 282 | type 'a visual_pane = { 283 | var : ui Lwd.t Lwd.var; 284 | mutable view : 'a view option; 285 | } 286 | 287 | and 'a view = { 288 | t : 'a t; 289 | content : ui Lwd.t Lwd.var; 290 | mutable tag : 'a option; 291 | previous : 'a view option; 292 | } 293 | 294 | and 'a t = { 295 | left : 'a visual_pane; 296 | middle : 'a visual_pane; 297 | right : 'a visual_pane; 298 | } 299 | 300 | let bind_pane visual view = 301 | visual.view <- view; 302 | Lwd.set visual.var 303 | ( match view with 304 | | None -> empty 305 | | Some view -> Lwd.join (Lwd.get view.content) ) 306 | 307 | let make () = 308 | let visual () = { var = Lwd.var empty; view = None } in 309 | { left = visual (); middle = visual (); right = visual () } 310 | 311 | let render t = 312 | let place_ui_var ?sw v = 313 | Lwd.(v |> get |> join |> map (Ui.resize ~w:0 ?sw)) 314 | in 315 | let spacer = 316 | Ui.empty |> Ui.resize ~w:1 ~sh:1 ~bg:Notty.A.(bg (gray 1)) |> Lwd.pure 317 | in 318 | Lwd_utils.pack Ui.pack_x 319 | [ 320 | place_ui_var t.left.var ~sw:1; 321 | spacer; 322 | place_ui_var t.middle.var ~sw:2; 323 | spacer; 324 | place_ui_var t.right.var ~sw:6; 325 | ] 326 | 327 | let current_view t = function 328 | | `Left -> t.left.view 329 | | `Middle -> t.middle.view 330 | | `Right -> t.right.view 331 | 332 | let display view = 333 | let left, middle, right = 334 | match view with 335 | | { previous = None; _ } as middle -> (None, middle, None) 336 | | { previous = Some ({ previous; _ } as middle); _ } -> 337 | (previous, middle, Some view) 338 | in 339 | bind_pane view.t.left left; 340 | bind_pane view.t.middle (Some middle); 341 | bind_pane view.t.right right 342 | 343 | let mkview t previous = { t; content = Lwd.var empty; tag = None; previous } 344 | 345 | let open_root t = 346 | let view = mkview t None in 347 | display view; 348 | view 349 | 350 | let open_subview v = 351 | let view = mkview v.t (Some v) in 352 | display view; 353 | view 354 | 355 | let close_subview v = display v 356 | 357 | let set view tag ui = 358 | view.tag <- tag; 359 | Lwd.set view.content ui 360 | 361 | let get view = view.tag 362 | end 363 | 364 | (* Widgets that can adjust their contents based on the visible size *) 365 | 366 | let dynamic_width ?(w = 0) ~sw ?h ?sh f = 367 | let width = Lwd.var w in 368 | let body = f (Lwd.get width) in 369 | body 370 | |> Lwd.map (fun ui -> 371 | ui 372 | |> Ui.resize ~w ~sw ?h ?sh 373 | |> Ui.size_sensor (fun w _ -> 374 | if Lwd.peek width <> w then Lwd.set width w)) 375 | -------------------------------------------------------------------------------- /src/main.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open Ocaml_ci_api 3 | open Nottui 4 | open Utils 5 | module C = Capnp_rpc_lwt 6 | module NW = Nottui_widgets 7 | module W = Widgets 8 | module Pane = W.Pane 9 | 10 | let clampi mn mx a : int = if a > mx then mx else if a < mn then mn else a 11 | 12 | let header = Lwd.var W.empty 13 | 14 | let body = Lwd.var W.empty 15 | 16 | let footer = Lwd.var W.empty 17 | 18 | let spinner = 19 | let rec frames = 20 | "⠋" 21 | :: "⠙" 22 | :: "⠹" 23 | :: "⠸" 24 | :: "⠼" 25 | :: "⠴" 26 | :: "⠦" 27 | :: "⠧" 28 | :: "⠇" 29 | :: "⠏" 30 | :: frames 31 | in 32 | Lwd.prim 33 | ~acquire:(fun () -> 34 | let running = ref true in 35 | let frame = Lwd.var frames in 36 | let rec next_frame () = 37 | Lwt_unix.sleep 0.080 >>= fun () -> 38 | let frames = Lwd.peek frame in 39 | Lwd.set frame (List.tl frames); 40 | if !running then next_frame () else Lwt.return_unit 41 | in 42 | Lwt.async next_frame; 43 | (running, Lwd.get frame)) 44 | ~release:(fun (running, _) -> running := false) 45 | |> Lwd.get_prim 46 | |> Lwd.map (fun (_running, var) -> var) 47 | |> Lwd.join 48 | |> Lwd.map List.hd 49 | 50 | let ui = 51 | let place_ui_var v = Lwd.(v |> get |> join |> map (Ui.resize ~w:0)) in 52 | Lwd_utils.pack Ui.pack_y 53 | [ place_ui_var header; Lwd.get body |> Lwd.join; place_ui_var footer ] 54 | 55 | let render_list_item highlight text = 56 | let attr = 57 | if highlight then Notty.A.(st bold ++ fg lightblue ++ st reverse) 58 | else Notty.A.(st bold ++ fg lightblue) 59 | in 60 | NW.string ~attr text 61 | 62 | let render_state highlight (state : Raw.Reader.JobInfo.State.unnamed_union_t) = 63 | let icon, color = 64 | let open Notty.A in 65 | match state with 66 | | NotStarted -> ("[ ]", white) 67 | | Passed -> ("[✓]", green) 68 | | Failed _ -> ("[X]", red) 69 | | Active -> ("[.]", yellow) 70 | | Aborted -> ("[A]", lightred) 71 | | Undefined _ -> ("[�]", white) 72 | in 73 | if highlight then NW.string ~attr:Notty.A.(fg color ++ st reverse) icon 74 | else NW.string ~attr:Notty.A.(fg color) icon 75 | 76 | let import_ci_ref ~vat = function 77 | | Some url -> Capnp_rpc_unix.Vat.import vat url 78 | | None -> ( 79 | match Sys.getenv_opt "HOME" with 80 | | None -> failwithf "$HOME not set! Can't get default cap file location." 81 | | Some home -> 82 | let path = Filename.concat home ".ocaml-ci.cap" in 83 | if Sys.file_exists path then Capnp_rpc_unix.Cap_file.load vat path 84 | else failwithf "Default cap file %S not found!" path ) 85 | 86 | let log_file = Filename.temp_file "citty" ".log" 87 | 88 | let () = at_exit (fun () -> Sys.remove log_file) 89 | 90 | let open_in_editor refresh log_lines = function 91 | | `Activate -> 92 | let oc = open_out_bin log_file in 93 | Lwd_table.iter (output_string oc) log_lines; 94 | close_out_noerr oc; 95 | let safe_name = Filename.quote log_file in 96 | let candidates = 97 | match Sys.getenv_opt "VISUAL" with 98 | | Some x -> [ x ] 99 | | None -> ( 100 | match Sys.getenv_opt "EDITOR" with 101 | | Some x -> [ x ] 102 | | None -> ( 103 | match Sys.getenv_opt "PAGER" with Some x -> [ x ] | None -> [] ) 104 | ) 105 | in 106 | let candidates = candidates @ [ "xdg-open"; "open" ] in 107 | ignore 108 | (List.exists 109 | (fun bin -> 110 | Sys.command (Filename.quote bin ^ " " ^ safe_name) <> 127) 111 | candidates); 112 | refresh () 113 | | _ -> () 114 | 115 | let rec show_job pane job = 116 | let dispatch, dispatch_var = Lwt.wait () in 117 | let open_editor_asap = ref false in 118 | let footer, set_footer = 119 | let display msg = Lwd.map (fun img -> NW.string (img ^ msg)) spinner in 120 | let var = Lwd.var (display " Receiving log") in 121 | let footer_content = function 122 | | `Opening -> display " Opening editor as soon as possible" 123 | | `Done -> W.empty 124 | | `Refresh -> Lwd.peek var 125 | in 126 | (Lwd.join (Lwd.get var), fun status -> Lwd.set var (footer_content status)) 127 | in 128 | Lwt.ignore_result (Lwt.map (fun _ -> set_footer `Done) dispatch); 129 | let dispatch_fun action = 130 | match Lwt.state dispatch with 131 | | Return fn -> fn action 132 | | Fail _ -> () 133 | | Sleep -> 134 | if (not !open_editor_asap) && action = `Activate then ( 135 | open_editor_asap := true; 136 | set_footer `Opening; 137 | Lwt.ignore_result (Lwt.map (fun fn -> fn `Activate) dispatch) ) 138 | in 139 | Pane.set pane (Some dispatch_fun) 140 | (Lwd.map' footer 141 | (Ui.resize ~sh:1 ~fill:(Gravity.make ~h:`Negative ~v:`Positive))); 142 | let status = Current_rpc.Job.status job in 143 | let start_log = Current_rpc.Job.log ~start:0L job in 144 | status 145 | |> Lwt_result.map 146 | @@ fun { Current_rpc.Job.id; description; can_cancel; can_rebuild } -> 147 | let text = 148 | Format.asprintf "@[Job %S:@,Description: @[%a@]@]@." id Fmt.lines 149 | description 150 | in 151 | let buttons = Lwd.var Ui.empty in 152 | [ 153 | ( if can_rebuild then 154 | Some 155 | ( W.button Notty.A.(bg red) "[Rebuild]" @@ fun () -> 156 | Lwd.set buttons Ui.empty; 157 | ignore (show_job pane (Current_rpc.Job.rebuild job)) ) 158 | else None ); 159 | ( if can_cancel then 160 | Some 161 | ( W.button Notty.A.(bg blue) "[Cancel]" @@ fun () -> 162 | Lwd.set buttons Ui.empty; 163 | Lwt.async (fun () -> 164 | Current_rpc.Job.cancel job >>= fun _ -> 165 | ignore (show_job pane job); 166 | Lwt.return_unit) ) 167 | else None ); 168 | ] 169 | |> filter_map (fun x -> x) 170 | |> interleave (Ui.atom (Notty.I.void 1 0)) 171 | |> Lwd_utils.pure_pack Ui.pack_x 172 | |> Lwd.set buttons; 173 | let log_lines = Lwd_table.make () in 174 | Lwt.async (fun () -> 175 | let show_log table job = 176 | let add str = if str <> "" then Lwd_table.append' table str in 177 | let rec aux = function 178 | | Error _ as e -> 179 | add "ERROR"; 180 | Lwt.return e 181 | | Ok ("", _) -> Lwt.return_ok () 182 | | Ok (data, next) -> 183 | add data; 184 | Current_rpc.Job.log ~start:next job >>= aux 185 | in 186 | start_log >>= aux 187 | in 188 | show_log log_lines job >|= fun _ -> 189 | let refresh () = set_footer `Refresh in 190 | Lwt.wakeup dispatch_var (open_in_editor refresh log_lines)); 191 | let description = Lwd.pure (text |> NW.string |> Ui.resize ~w:0 ~sw:1) in 192 | let buttons = 193 | Lwd.map2 194 | (fun x y -> Ui.resize ~w:0 ~sw:1 (Ui.join_x x y)) 195 | (Lwd.get buttons) 196 | (Lwd.pure (Ui.resize Ui.empty ~h:1 ~sw:1 ~bg:Notty.A.(bg (gray 1)))) 197 | in 198 | let text_view = 199 | (* Setup scrolling *) 200 | let scroll_state = Lwd.var NW.default_scroll_state in 201 | let set_scroll reason st = 202 | let off_screen = reason = `Content && st.NW.position > st.NW.bound in 203 | let scroll_on_output = 204 | reason = `Content 205 | && 206 | let st' = Lwd.peek scroll_state in 207 | st'.NW.position = st'.NW.bound 208 | && st.NW.position = st'.NW.position 209 | && st.NW.position < st.NW.bound 210 | in 211 | if scroll_on_output || off_screen then 212 | Lwd.set scroll_state { st with position = st.NW.bound } 213 | else Lwd.set scroll_state st 214 | in 215 | let text_body = 216 | W.dynamic_width ~w:0 ~sw:1 ~h:0 ~sh:1 (fun width -> 217 | Lwd.bind width (W.word_wrap_string_table log_lines) 218 | |> NW.vscroll_area ~state:(Lwd.get scroll_state) ~change:set_scroll 219 | |> (* Scroll when dragging *) 220 | Lwd.map 221 | (Ui.mouse_area (fun ~x:_ ~y:y0 -> function 222 | | `Left -> 223 | let st = Lwd.peek scroll_state in 224 | `Grab 225 | ( (fun ~x:_ ~y:y1 -> 226 | let position = st.position + y0 - y1 in 227 | let position = clampi 0 st.bound position in 228 | set_scroll `Change { st with position }), 229 | fun ~x:_ ~y:_ -> () ) 230 | | _ -> `Unhandled))) 231 | in 232 | let scroll_bar = 233 | Lwd.get scroll_state 234 | |> Lwd.map (fun x -> 235 | x 236 | |> W.vertical_scrollbar ~set_scroll:(set_scroll `Change) 237 | |> Ui.resize ~w:1 ~sw:0 ~h:0 ~sh:1) 238 | in 239 | Lwd_utils.pack Ui.pack_x [ text_body; scroll_bar ] 240 | in 241 | Lwd_utils.pack Ui.pack_y [ description; buttons; text_view; footer ] 242 | |> Pane.set pane (Some dispatch_fun) 243 | 244 | let show_jobs commit pane = 245 | Client.Commit.jobs commit >|= function 246 | | Ok items -> 247 | let select Client.{ variant; _ } = 248 | let pane = Pane.open_subview pane in 249 | Lwt.ignore_result 250 | (show_job pane (Client.Commit.job_of_variant commit variant) 251 | >|= function 252 | | Ok () -> () 253 | | Error (`Capnp e) -> 254 | Pane.set pane None (Lwd.pure (NW.fmt "%a" Capnp_rpc.Error.pp e)) 255 | | Error `No_job -> 256 | Pane.set pane None (Lwd.pure (NW.string "No jobs"))) 257 | and render Client.{ variant; outcome } highlight = 258 | Ui.hcat 259 | [ 260 | render_state highlight outcome; 261 | Ui.atom (Notty.I.void 1 1); 262 | render_list_item highlight variant; 263 | ] 264 | in 265 | let ui, dispatch = W.list_box ~items ~render ~select in 266 | Pane.set pane (Some dispatch) ui 267 | | Error (`Capnp e) -> 268 | Pane.close_subview pane; 269 | Pane.set pane None (Lwd.pure (NW.fmt "%a" Capnp_rpc.Error.pp e)) 270 | 271 | let show_repo repo pane = 272 | Client.Repo.refs repo >>= function 273 | | Ok refs -> 274 | let select (_, (hash, _status)) = 275 | let pane = Pane.open_subview pane in 276 | Pane.set pane None (Lwd.pure (NW.string "...")); 277 | Lwt.async (fun () -> 278 | let commit = Client.Repo.commit_of_hash repo hash in 279 | show_jobs commit pane) 280 | in 281 | let render (gref, (hash, _status)) highlight = 282 | render_list_item highlight 283 | (Printf.sprintf "%10s #%s" (W.fit_string gref 24) 284 | (String.sub hash 0 6)) 285 | in 286 | let items = refs |> Client.Ref_map.to_seq |> List.of_seq in 287 | let ui, dispatch = W.list_box ~items ~render ~select in 288 | Pane.set pane (Some dispatch) ui; 289 | Lwt.return_unit 290 | | Error (`Capnp e) -> 291 | Pane.close_subview pane; 292 | Pane.set pane None (Lwd.pure (NW.fmt "%a" Capnp_rpc.Error.pp e)); 293 | Lwt.return_unit 294 | 295 | let show_repos pane = 296 | let vat = Capnp_rpc_unix.client_only_vat () in 297 | match import_ci_ref ~vat None with 298 | | Error _ as e -> Lwt.return e 299 | | Ok sr -> ( 300 | let host = Uri.host_with_default (Capnp_rpc_unix.Vat.export vat sr) in 301 | Lwd.set header (Lwd.pure (NW.string ~attr:Notty.A.(fg green) host)); 302 | C.Sturdy_ref.connect_exn sr >>= fun ci -> 303 | Client.CI.orgs ci >>= function 304 | | Error _ as err -> Lwt.return err 305 | | Ok orgs -> 306 | let render repo hl = 307 | match repo with 308 | | Ok ((org, repo), _handle) -> 309 | render_list_item hl (Printf.sprintf "%s/%s" org repo) 310 | | Error (`Capnp e) -> 311 | NW.fmt ~attr:Notty.A.(fg red) "%a" Capnp_rpc.Error.pp e 312 | in 313 | let select = function 314 | | Ok (_repo, handle) -> 315 | let pane = Pane.open_subview pane in 316 | Lwt.async (fun () -> 317 | (* C.Capability.with_ref handle (fun handle -> *) 318 | show_repo handle pane 319 | (* ) *)) 320 | | Error _ -> Pane.close_subview pane 321 | in 322 | Lwt_list.map_s 323 | (fun x -> x) 324 | (List.map 325 | (fun org -> 326 | let handle = Client.CI.org ci org in 327 | Lwt.map 328 | (function 329 | | Error e -> [ Error e ] 330 | | Ok repos -> 331 | let handle_of { Client.Org.name; master_status = _ } = 332 | Ok ((org, name), Client.Org.repo handle name) 333 | in 334 | List.map handle_of repos) 335 | (Client.Org.repos handle)) 336 | orgs) 337 | >>= fun items -> 338 | let items = List.flatten items in 339 | let ui, dispatch = W.list_box ~items ~render ~select in 340 | Pane.set pane (Some dispatch) ui; 341 | Lwt.return_ok () ) 342 | 343 | let main () = 344 | let pane = Pane.make () in 345 | let dispatch pos action = 346 | match Pane.current_view pane pos with 347 | | None -> `Unhandled 348 | | Some view -> ( 349 | match Pane.get view with 350 | | None -> `Unhandled 351 | | Some dispatch -> 352 | dispatch action; 353 | `Handled ) 354 | in 355 | let focus_handle = Focus.make () in 356 | Focus.request focus_handle; 357 | Lwd.set body 358 | ( Pane.render pane 359 | |> Lwd.map2 360 | (fun focus -> 361 | Ui.keyboard_area ~focus @@ function 362 | | (`Arrow `Up | `ASCII 'k'), [] -> dispatch `Middle `Select_prev 363 | | (`Arrow `Down | `ASCII 'j'), [] -> dispatch `Middle `Select_next 364 | | (`Arrow `Left | `ASCII 'h'), [] -> dispatch `Left `Activate 365 | | (`Arrow `Right | `ASCII 'l'), [] -> dispatch `Right `Activate 366 | | (`Escape | `ASCII 'q'), [] -> exit 0 367 | | _ -> `Unhandled) 368 | (Focus.status focus_handle) ); 369 | Lwt_main.run 370 | (show_repos (Pane.open_root pane) >>= function 371 | | Ok () -> Nottui_lwt.run ui 372 | | Error (`Capnp err) -> 373 | Format.eprintf "%a" Capnp_rpc.Error.pp err; 374 | Lwt.return_unit 375 | | Error (`Msg msg) -> 376 | Format.eprintf "Error: %S" msg; 377 | Lwt.return_unit) 378 | 379 | let () = main () 380 | --------------------------------------------------------------------------------