├── lib ├── interaction │ ├── action │ │ ├── project.mli │ │ ├── sector.mli │ │ ├── project.ml │ │ ├── sector.ml │ │ ├── global.mli │ │ ├── state.mli │ │ ├── log.mli │ │ ├── global.ml │ │ ├── transient_log.mli │ │ ├── state.ml │ │ ├── described_item.ml │ │ ├── transient_log.ml │ │ └── log.ml │ ├── workflow │ │ ├── project.mli │ │ ├── sector.mli │ │ ├── sector.ml │ │ ├── project.ml │ │ ├── state.ml │ │ ├── state.mli │ │ ├── supervised_directory.ml │ │ ├── transient_log.mli │ │ ├── log.ml │ │ ├── supervised_directory.mli │ │ ├── log.mli │ │ ├── described_item.ml │ │ └── transient_log.ml │ └── dune ├── model │ ├── context.ml │ ├── dune │ ├── context.mli │ ├── resolver.ml │ ├── url.mli │ ├── key_value.mli │ ├── key_value.ml │ ├── resolver.mli │ ├── state.mli │ ├── described_item.mli │ ├── log.mli │ ├── url.ml │ ├── described_item.ml │ ├── state.ml │ ├── transient_log.mli │ └── log.ml ├── yocaml_rensai │ ├── dune │ ├── yocaml_rensai.mli │ └── yocaml_rensai.ml ├── core │ ├── dune │ ├── regex.mli │ ├── uuid.mli │ ├── regex.ml │ ├── duration.mli │ ├── uuid.ml │ ├── sigs.mli │ ├── error.mli │ ├── path.mli │ ├── duration.ml │ ├── eff.ml │ ├── path.ml │ ├── eff.mli │ └── error.ml ├── yocaml_kohai │ ├── dune │ ├── log.mli │ ├── state.mli │ ├── path.mli │ ├── url.mli │ ├── duration.mli │ ├── datetime.mli │ ├── path.ml │ ├── key_value.mli │ ├── uuid.mli │ ├── described_item.mli │ ├── key_value.ml │ ├── duration.ml │ ├── uuid.ml │ ├── datetime.ml │ ├── state.ml │ ├── described_item.ml │ ├── url.ml │ └── log.ml ├── server │ ├── server.mli │ ├── services.mli │ ├── dune │ ├── jsonrpc.mli │ ├── server.ml │ └── jsonrpc.ml └── rensai │ ├── dune │ ├── nel.ml │ ├── lang.mli │ ├── json.mli │ ├── nel.mli │ ├── kind.mli │ ├── parser.mly │ ├── lang.ml │ ├── lexer.mll │ ├── kind.ml │ ├── ast.ml │ ├── json.ml │ └── sigs.mli ├── media ├── log-record.gif ├── project-creation.gif └── sector-creation.gif ├── test ├── core │ ├── dune │ ├── path_test.ml │ └── datetime_query.ml ├── rensai │ ├── dune │ ├── nel_test.ml │ ├── random_test.ml │ └── kind_pretty_printer_test.ml ├── model │ ├── dune │ ├── state_test.ml │ ├── url_test.ml │ └── described_item_test.ml └── server │ ├── dune │ ├── virtfs.mli │ ├── virtfs_test.ml │ ├── input_parser.ml │ ├── util.mli │ └── virtfs.ml ├── .ocamlformat ├── bin ├── dune └── kohai.ml ├── README.md ├── yocaml_rensai.opam ├── yocaml_kohai.opam ├── .gitignore ├── LICENSE ├── rensai.opam ├── site-lisp ├── rensai-mode.el ├── kohai-transient.el ├── kohai-buffer.el ├── kohai-sector.el ├── kohai-project.el ├── kohai.el ├── kohai-state.el └── kohai-generic.el ├── kohai.opam ├── .github └── workflows │ └── test-ocaml-ci.yml └── dune-project /lib/interaction/action/project.mli: -------------------------------------------------------------------------------- 1 | include Described_item.S 2 | -------------------------------------------------------------------------------- /lib/interaction/action/sector.mli: -------------------------------------------------------------------------------- 1 | include Described_item.S 2 | -------------------------------------------------------------------------------- /lib/interaction/workflow/project.mli: -------------------------------------------------------------------------------- 1 | include Described_item.S 2 | -------------------------------------------------------------------------------- /lib/interaction/workflow/sector.mli: -------------------------------------------------------------------------------- 1 | include Described_item.S 2 | -------------------------------------------------------------------------------- /lib/interaction/workflow/sector.ml: -------------------------------------------------------------------------------- 1 | include Described_item.Make (Action.Sector) 2 | -------------------------------------------------------------------------------- /lib/interaction/workflow/project.ml: -------------------------------------------------------------------------------- 1 | include Described_item.Make (Action.Project) 2 | -------------------------------------------------------------------------------- /media/log-record.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xvw/kohai/HEAD/media/log-record.gif -------------------------------------------------------------------------------- /media/project-creation.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xvw/kohai/HEAD/media/project-creation.gif -------------------------------------------------------------------------------- /media/sector-creation.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xvw/kohai/HEAD/media/sector-creation.gif -------------------------------------------------------------------------------- /lib/model/context.ml: -------------------------------------------------------------------------------- 1 | type t = { now : Datetime.t } 2 | 3 | let make ~now = { now } 4 | let now ctx = ctx.now 5 | -------------------------------------------------------------------------------- /lib/yocaml_rensai/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name yocaml_rensai) 3 | (public_name yocaml_rensai) 4 | (libraries rensai yocaml)) 5 | -------------------------------------------------------------------------------- /lib/interaction/action/project.ml: -------------------------------------------------------------------------------- 1 | include Described_item.Make (struct 2 | let resolver = Kohai_model.Resolver.projects 3 | end) 4 | -------------------------------------------------------------------------------- /lib/interaction/action/sector.ml: -------------------------------------------------------------------------------- 1 | include Described_item.Make (struct 2 | let resolver = Kohai_model.Resolver.sectors 3 | end) 4 | -------------------------------------------------------------------------------- /lib/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name kohai_core) 3 | (public_name kohai.core) 4 | (modules_without_implementation sigs) 5 | (libraries uuidm re rensai)) 6 | -------------------------------------------------------------------------------- /lib/yocaml_kohai/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name yocaml_kohai) 3 | (public_name yocaml_kohai) 4 | (libraries rensai yocaml yocaml_rensai kohai.core kohai.model)) 5 | -------------------------------------------------------------------------------- /lib/yocaml_kohai/log.mli: -------------------------------------------------------------------------------- 1 | type t = Kohai_model.Log.t 2 | 3 | include Yocaml.Required.DATA_READABLE with type t := t 4 | 5 | val normalize : t -> Yocaml.Data.t 6 | -------------------------------------------------------------------------------- /lib/model/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name kohai_model) 3 | (public_name kohai.model) 4 | (flags (:standard) -open Kohai_core) 5 | (libraries uri kohai.core rensai)) 6 | -------------------------------------------------------------------------------- /lib/yocaml_kohai/state.mli: -------------------------------------------------------------------------------- 1 | type t = Kohai_model.State.t 2 | 3 | include Yocaml.Required.DATA_READABLE with type t := t 4 | 5 | val normalize : t -> Yocaml.Data.t 6 | -------------------------------------------------------------------------------- /test/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name core_test) 3 | (package kohai) 4 | (inline_tests) 5 | (libraries rensai kohai.core) 6 | (preprocess 7 | (pps ppx_expect))) 8 | -------------------------------------------------------------------------------- /lib/interaction/workflow/state.ml: -------------------------------------------------------------------------------- 1 | let get = Action.State.get 2 | let get_for_sector = Action.State.get_for_sector 3 | let get_for_project = Action.State.get_for_project 4 | -------------------------------------------------------------------------------- /test/rensai/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name rensai_test) 3 | (package rensai) 4 | (inline_tests) 5 | (libraries yojson rensai fmt) 6 | (preprocess 7 | (pps ppx_expect))) 8 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.28.1 2 | ocaml-version = 5.3 3 | profile = janestreet 4 | margin = 80 5 | parse-docstrings 6 | break-separators = before 7 | break-infix = fit-or-vertical -------------------------------------------------------------------------------- /lib/yocaml_kohai/path.mli: -------------------------------------------------------------------------------- 1 | type t = Kohai_core.Path.t 2 | 3 | val validate : Yocaml.Data.t -> t Yocaml.Data.Validation.validated_value 4 | val normalize : t -> Yocaml.Data.t 5 | -------------------------------------------------------------------------------- /lib/yocaml_kohai/url.mli: -------------------------------------------------------------------------------- 1 | type t = Kohai_model.Url.t 2 | 3 | val validate : Yocaml.Data.t -> t Yocaml.Data.Validation.validated_value 4 | val normalize : t -> Yocaml.Data.t 5 | -------------------------------------------------------------------------------- /test/model/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name model_test) 3 | (package kohai) 4 | (inline_tests) 5 | (libraries rensai kohai.core kohai.model) 6 | (preprocess 7 | (pps ppx_expect))) 8 | -------------------------------------------------------------------------------- /lib/yocaml_kohai/duration.mli: -------------------------------------------------------------------------------- 1 | type t = Kohai_core.Duration.t 2 | 3 | val validate : Yocaml.Data.t -> t Yocaml.Data.Validation.validated_value 4 | val normalize : t -> Yocaml.Data.t 5 | -------------------------------------------------------------------------------- /lib/server/server.mli: -------------------------------------------------------------------------------- 1 | (** A simple server to handle Kohai JSONRpc method. *) 2 | 3 | val input_parser : string Eio.Buf_read.parser 4 | val run : Eff.handler -> Eio_unix.Stdenv.base -> unit 5 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name kohai) 3 | (public_name kohai) 4 | (package kohai) 5 | (libraries eio eio_main cmdliner unix kohai.server) 6 | (promote 7 | (until-clean) 8 | (into "../"))) 9 | -------------------------------------------------------------------------------- /test/server/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name server_test) 3 | (package kohai) 4 | (inline_tests) 5 | (libraries rensai unix fmt kohai.core kohai.server eio yojson) 6 | (preprocess 7 | (pps ppx_expect))) 8 | -------------------------------------------------------------------------------- /lib/model/context.mli: -------------------------------------------------------------------------------- 1 | (** The context is built into a request and sent to the controller and 2 | a service finalizer. *) 3 | 4 | type t 5 | 6 | val make : now:Datetime.t -> t 7 | val now : t -> Datetime.t 8 | -------------------------------------------------------------------------------- /lib/interaction/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name kohai_interaction) 3 | (public_name kohai.interaction) 4 | (flags (:standard) -open Kohai_core) 5 | (libraries rensai kohai.core kohai.model)) 6 | 7 | (include_subdirs qualified) 8 | -------------------------------------------------------------------------------- /lib/yocaml_kohai/datetime.mli: -------------------------------------------------------------------------------- 1 | type t = Kohai_core.Datetime.t 2 | 3 | val validate : Yocaml.Data.t -> t Yocaml.Data.Validation.validated_value 4 | val to_yocaml : t -> Yocaml.Datetime.t 5 | val normalize : t -> Yocaml.Data.t 6 | -------------------------------------------------------------------------------- /lib/yocaml_kohai/path.ml: -------------------------------------------------------------------------------- 1 | type t = Kohai_core.Path.t 2 | 3 | let validate = 4 | let open Yocaml.Data.Validation in 5 | string $ Kohai_core.Path.from_string 6 | ;; 7 | 8 | let normalize path = path |> Kohai_core.Path.to_string |> Yocaml.Data.string 9 | -------------------------------------------------------------------------------- /lib/rensai/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name rensai) 3 | (public_name rensai) 4 | (modules_without_implementation sigs) 5 | (libraries fmt)) 6 | 7 | (menhir 8 | (modules parser)) 9 | 10 | (ocamllex lexer) 11 | 12 | (mdx 13 | (files *.mli) 14 | (libraries rensai)) 15 | -------------------------------------------------------------------------------- /lib/server/services.mli: -------------------------------------------------------------------------------- 1 | (** Set of services (methods) supported by the JSONRPC server. *) 2 | 3 | (** A shortcut describing a pair of method name and controller. *) 4 | type t = string * Jsonrpc.service 5 | 6 | (** List of available methods of the server. *) 7 | val all : t list 8 | -------------------------------------------------------------------------------- /lib/core/regex.mli: -------------------------------------------------------------------------------- 1 | (** Some presaved Regexp. *) 2 | 3 | val trim : Re.t -> Re.t 4 | val constant : string -> Re.t 5 | val time_sep : Re.t 6 | val min_or_sec : Re.t 7 | val hour : Re.t 8 | val at : Re.t 9 | val time_full : Re.t 10 | val opt_int_of_group : Re.Group.t -> int -> int option 11 | -------------------------------------------------------------------------------- /lib/yocaml_kohai/key_value.mli: -------------------------------------------------------------------------------- 1 | type 'a t = 'a Kohai_model.Key_value.t 2 | 3 | val validate 4 | : (Yocaml.Data.t -> 'a Yocaml.Data.Validation.validated_value) 5 | -> Yocaml.Data.t 6 | -> 'a t Yocaml.Data.Validation.validated_value 7 | 8 | val normalize : ('a -> Yocaml.Data.t) -> 'a t -> Yocaml.Data.t 9 | -------------------------------------------------------------------------------- /lib/server/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name kohai_server) 3 | (public_name kohai.server) 4 | (flags (:standard) -open Kohai_core -open Kohai_interaction) 5 | (libraries 6 | rensai 7 | kohai.core 8 | kohai.model 9 | kohai.interaction 10 | yojson 11 | eio 12 | eio_main)) 13 | 14 | (include_subdirs qualified) 15 | -------------------------------------------------------------------------------- /lib/yocaml_kohai/uuid.mli: -------------------------------------------------------------------------------- 1 | type t = Kohai_core.Uuid.t 2 | 3 | val validate : Yocaml.Data.t -> t Yocaml.Data.Validation.validated_value 4 | val normalize : t -> Yocaml.Data.t 5 | 6 | module Set : sig 7 | type t = Kohai_core.Uuid.Set.t 8 | 9 | include Yocaml.Required.DATA_READABLE with type t := t 10 | 11 | val normalize : t -> Yocaml.Data.t 12 | end 13 | -------------------------------------------------------------------------------- /lib/yocaml_rensai/yocaml_rensai.mli: -------------------------------------------------------------------------------- 1 | (** Support of Rensai as a YOCaml metadata *) 2 | 3 | (** @inline *) 4 | include 5 | Yocaml.Required.DATA_READER 6 | with type t = Rensai.Ast.t 7 | and type 'a eff := 'a Yocaml.Eff.t 8 | and type ('a, 'b) arr := ('a, 'b) Yocaml.Task.t 9 | and type extraction_strategy := Yocaml.Metadata.extraction_strategy 10 | -------------------------------------------------------------------------------- /lib/yocaml_kohai/described_item.mli: -------------------------------------------------------------------------------- 1 | type t = Kohai_model.Described_item.t 2 | 3 | val validate : Yocaml.Data.t -> t Yocaml.Data.Validation.validated_value 4 | val normalize : t -> Yocaml.Data.t 5 | 6 | module Set : sig 7 | type t = Kohai_model.Described_item.Set.t 8 | 9 | include Yocaml.Required.DATA_READABLE with type t := t 10 | 11 | val normalize : t -> Yocaml.Data.t 12 | end 13 | -------------------------------------------------------------------------------- /lib/interaction/workflow/state.mli: -------------------------------------------------------------------------------- 1 | (** Get the global state. *) 2 | val get : (module Sigs.EFFECT_HANDLER) -> unit -> Kohai_model.State.t 3 | 4 | (** Get state for a given sector *) 5 | val get_for_sector 6 | : (module Sigs.EFFECT_HANDLER) 7 | -> string 8 | -> Kohai_model.State.t 9 | 10 | (** Get state for a given project *) 11 | val get_for_project 12 | : (module Sigs.EFFECT_HANDLER) 13 | -> string 14 | -> Kohai_model.State.t 15 | -------------------------------------------------------------------------------- /lib/model/resolver.ml: -------------------------------------------------------------------------------- 1 | let state ~cwd = Path.(cwd / "state.rens") 2 | let sectors ~cwd = Path.(cwd / "list" / "sectors.rens") 3 | let projects ~cwd = Path.(cwd / "list" / "projects.rens") 4 | let logs ~cwd = Path.(cwd / "logs") 5 | let all_logs ~cwd = Path.(logs ~cwd / "list") 6 | let transient_logs ~cwd = Path.(logs ~cwd / "transient.rens") 7 | let sector_folder ~cwd = Path.(cwd / "sectors") 8 | let project_folder ~cwd = Path.(cwd / "projects") 9 | let last_logs ~cwd = Path.(logs ~cwd / "last_logs.rens") 10 | -------------------------------------------------------------------------------- /lib/interaction/workflow/supervised_directory.ml: -------------------------------------------------------------------------------- 1 | let set (module H : Eff.HANDLER) path = 2 | let path = Action.Global.check_supervised_path (module H) path in 3 | let () = Eff.set_supervised_directory (module H) (Some path) in 4 | path 5 | ;; 6 | 7 | let get (module H : Eff.HANDLER) () = Eff.get_supervised_directory (module H) 8 | 9 | let is_valid (module H : Eff.HANDLER) path = 10 | Path.is_absolute path && Eff.is_dir (module H) path 11 | ;; 12 | 13 | let ensure = Action.Global.ensure_supervision 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # kohai 2 | 3 | > **Kohai** is a timetracking software (inspired, _very conceptually_, 4 | > by [Sensei](https://github.com/abailly/sensei)). 5 | 6 | The aim of the project is to re-implement the 7 | [timetracker](https://github.com/xvw/planet/tree/master/src/bin/log) 8 | buried in [Planet](https://github.com/xvw/planet) (_RIP_), however, 9 | the **real** objective is to, once again, _reinvent the wheel_ because 10 | it's great fun to try out encodings in a project that may never see 11 | the light of day! _Muehe_. 12 | 13 | -------------------------------------------------------------------------------- /lib/model/url.mli: -------------------------------------------------------------------------------- 1 | (** Represents a URL. *) 2 | 3 | type t 4 | type scheme 5 | 6 | val make 7 | : uri:Uri.t 8 | -> scheme:scheme 9 | -> port:int option 10 | -> host:string 11 | -> query:string list Key_value.t 12 | -> path:Path.t 13 | -> unit 14 | -> t 15 | 16 | val validate_scheme : string -> scheme 17 | val to_uri : t -> Uri.t 18 | val from_string : (string, t) Rensai.Validation.v 19 | val from_rensai : t Rensai.Validation.t 20 | val to_rensai : t Rensai.Ast.conv 21 | val to_compact_rensai : t Rensai.Ast.conv 22 | -------------------------------------------------------------------------------- /lib/model/key_value.mli: -------------------------------------------------------------------------------- 1 | (** Describes a key-value structure for assigning arbitrary values 2 | indexed by strings. *) 3 | 4 | type 'a t 5 | 6 | val from_rensai : 'a Rensai.Validation.t -> 'a t Rensai.Validation.t 7 | val to_rensai : 'a Rensai.Ast.conv -> 'a t Rensai.Ast.conv 8 | val empty : unit -> 'a t 9 | val add : string -> 'a -> 'a t -> 'a t 10 | val remove : string -> 'a t -> 'a t 11 | val keys : 'a t -> string list 12 | val from_list : (string * 'a) list -> 'a t 13 | val to_list : 'a t -> (string * 'a) list 14 | val is_empty : 'a t -> bool 15 | -------------------------------------------------------------------------------- /lib/interaction/workflow/transient_log.mli: -------------------------------------------------------------------------------- 1 | (** Get a current log by index. *) 2 | val get 3 | : (module Sigs.EFFECT_HANDLER) 4 | -> int 5 | -> Kohai_model.Transient_log.t option 6 | 7 | (** List all current transient logs. *) 8 | val list 9 | : (module Sigs.EFFECT_HANDLER) 10 | -> unit 11 | -> Kohai_model.Transient_log.t list 12 | 13 | (** Perform update on transient log. *) 14 | val action 15 | : (module Sigs.EFFECT_HANDLER) 16 | -> Kohai_model.Context.t 17 | -> Kohai_model.Transient_log.operation 18 | -> Kohai_model.Transient_log.result 19 | -------------------------------------------------------------------------------- /lib/interaction/action/global.mli: -------------------------------------------------------------------------------- 1 | (** Global actions. *) 2 | 3 | (** Check that a path is a valid candidate for supervision. *) 4 | val check_supervised_path : (module Sigs.EFFECT_HANDLER) -> Path.t -> Path.t 5 | 6 | (** Ensure that an action is guarded by a supervised directory. *) 7 | val ensure_supervision : (module Sigs.EFFECT_HANDLER) -> unit -> Path.t 8 | 9 | (** Perform an operation guarded by the presence of a supervised directory. *) 10 | val with_supervision 11 | : (module Sigs.EFFECT_HANDLER) 12 | -> ((module Sigs.EFFECT_HANDLER) -> 'a -> 'b) 13 | -> 'a 14 | -> 'b 15 | -------------------------------------------------------------------------------- /lib/yocaml_kohai/key_value.ml: -------------------------------------------------------------------------------- 1 | type 'a t = 'a Kohai_model.Key_value.t 2 | 3 | let validate subject = 4 | let open Yocaml.Data.Validation in 5 | list_of 6 | (pair string subject 7 | / record (fun f -> 8 | let+ key = required f "key" string 9 | and+ value = required f "value" subject in 10 | key, value)) 11 | $ Kohai_model.Key_value.from_list 12 | ;; 13 | 14 | let normalize subject obj = 15 | let open Yocaml.Data in 16 | obj 17 | |> Kohai_model.Key_value.to_list 18 | |> list_of (fun (k, v) -> record [ "key", string k; "value", subject v ]) 19 | ;; 20 | -------------------------------------------------------------------------------- /lib/interaction/workflow/log.ml: -------------------------------------------------------------------------------- 1 | let get = Action.Log.get 2 | let last = Action.Log.last 3 | let last_for_sector = Action.Log.last_for_sector 4 | let last_for_project = Action.Log.last_for_project 5 | 6 | let unpromote (module H : Eff.HANDLER) uuid = 7 | match Action.Log.unpromote (module H) uuid with 8 | | None -> Eff.raise (module H) @@ Error.no_related_log ~uuid () 9 | | Some transient_log -> 10 | let cwd = Action.Global.ensure_supervision (module H) () in 11 | let file = Kohai_model.Resolver.transient_logs ~cwd in 12 | let _ = Action.Transient_log.save (module H) file transient_log in 13 | Action.Transient_log.list (module H) () 14 | ;; 15 | -------------------------------------------------------------------------------- /lib/interaction/workflow/supervised_directory.mli: -------------------------------------------------------------------------------- 1 | (** The supervised directory is where log artifacts are stored. *) 2 | 3 | (** Defines a new supervised directory. *) 4 | val set : (module Sigs.EFFECT_HANDLER) -> Path.t -> Path.t 5 | 6 | (** Return the supervised directory for the current session. *) 7 | val get : (module Sigs.EFFECT_HANDLER) -> unit -> Path.t option 8 | 9 | (** Return [true] if a path is valid for supervision, [false] 10 | otherwise. *) 11 | val is_valid : (module Sigs.EFFECT_HANDLER) -> Path.t -> bool 12 | 13 | (** Ensure that an action is guarded by a supervised directory. *) 14 | val ensure : (module Sigs.EFFECT_HANDLER) -> unit -> Path.t 15 | -------------------------------------------------------------------------------- /lib/yocaml_kohai/duration.ml: -------------------------------------------------------------------------------- 1 | type t = Kohai_core.Duration.t 2 | 3 | let validate = Yocaml.Data.Validation.(int $ Kohai_core.Duration.from_int) 4 | 5 | let normalize duration = 6 | let open Yocaml.Data in 7 | let Kohai_core.Duration.{ d; h; m; s } = 8 | Kohai_core.Duration.compute duration 9 | in 10 | record 11 | [ "duration", int @@ Kohai_core.Duration.to_int duration 12 | ; "d", int @@ Kohai_core.Duration.to_int d 13 | ; "h", int @@ Kohai_core.Duration.to_int h 14 | ; "m", int @@ Kohai_core.Duration.to_int m 15 | ; "s", int @@ Kohai_core.Duration.to_int s 16 | ; "repr", string @@ Format.asprintf "%a" Kohai_core.Duration.pp duration 17 | ] 18 | ;; 19 | -------------------------------------------------------------------------------- /lib/core/uuid.mli: -------------------------------------------------------------------------------- 1 | (** Uuid5 for cross-reference indexing. *) 2 | 3 | type t 4 | 5 | (** Generate a UUID for a given string. *) 6 | val gen : string -> t 7 | 8 | val from_string : string -> t option 9 | val to_rensai : t Rensai.Ast.conv 10 | val from_rensai : t Rensai.Validation.t 11 | val to_string : t -> string 12 | 13 | (** {1 Set} *) 14 | 15 | module Set : sig 16 | type uid := t 17 | type t 18 | 19 | val empty : t 20 | val from_list : uid list -> t 21 | val to_list : t -> uid list 22 | val dump : t -> string 23 | val to_rensai : t Rensai.Ast.conv 24 | val from_rensai : t Rensai.Validation.t 25 | val push : uid -> t -> t 26 | val remove : uid -> t -> t 27 | val from_file_content : string -> t 28 | end 29 | -------------------------------------------------------------------------------- /lib/interaction/workflow/log.mli: -------------------------------------------------------------------------------- 1 | (** Get a log by UUID. *) 2 | val get : (module Sigs.EFFECT_HANDLER) -> Uuid.t -> Kohai_model.Log.t option 3 | 4 | (** Return the list of last log. *) 5 | val last : (module Sigs.EFFECT_HANDLER) -> unit -> Kohai_model.Log.t list 6 | 7 | (** Return the list of last log for a given sector. *) 8 | val last_for_sector 9 | : (module Sigs.EFFECT_HANDLER) 10 | -> string 11 | -> Kohai_model.Log.t list 12 | 13 | (** Return the list of last log for a given project. *) 14 | val last_for_project 15 | : (module Sigs.EFFECT_HANDLER) 16 | -> string 17 | -> Kohai_model.Log.t list 18 | 19 | (** Unpromote a log to a transient log *) 20 | val unpromote 21 | : (module Sigs.EFFECT_HANDLER) 22 | -> Uuid.t 23 | -> Kohai_model.Transient_log.t list 24 | -------------------------------------------------------------------------------- /lib/interaction/action/state.mli: -------------------------------------------------------------------------------- 1 | (** Upgrade the state when a new log is promotted. *) 2 | val upgrade 3 | : Path.t 4 | -> (module Sigs.EFFECT_HANDLER) 5 | -> Kohai_model.Log.t 6 | -> unit 7 | 8 | (** Downgrade the state when a new log is promotted. *) 9 | val downgrade 10 | : Path.t 11 | -> (module Sigs.EFFECT_HANDLER) 12 | -> Kohai_model.Log.t 13 | -> unit 14 | 15 | (** Get the global state. *) 16 | val get : (module Sigs.EFFECT_HANDLER) -> unit -> Kohai_model.State.t 17 | 18 | (** Get state for a given sector *) 19 | val get_for_sector 20 | : (module Sigs.EFFECT_HANDLER) 21 | -> string 22 | -> Kohai_model.State.t 23 | 24 | (** Get state for a given project *) 25 | val get_for_project 26 | : (module Sigs.EFFECT_HANDLER) 27 | -> string 28 | -> Kohai_model.State.t 29 | -------------------------------------------------------------------------------- /lib/rensai/nel.ml: -------------------------------------------------------------------------------- 1 | type 'a t = ( :: ) of 'a * 'a list 2 | 3 | let make x xs = x :: xs 4 | let singleton x = make x [] 5 | let cons x (y :: z) = x :: y :: z 6 | 7 | let init len f = 8 | if len < 1 9 | then raise @@ Invalid_argument "Nel.init" 10 | else f 0 :: List.init (len - 1) (fun i -> f @@ (i + 1)) 11 | ;; 12 | 13 | let to_list (x :: xs) = List.cons x xs 14 | 15 | let rev (x :: xs) = 16 | let rec aux acc first = function 17 | | List.[] -> first :: acc 18 | | List.(x :: xs) -> aux (first :: acc) x xs 19 | in 20 | aux [] x xs 21 | ;; 22 | 23 | let append (x :: xs) ys = x :: List.append xs (to_list ys) 24 | let equal eq (x :: xs) (y :: ys) = eq x y && List.equal eq xs ys 25 | 26 | let pp ?(pp_sep = fun st () -> Format.fprintf st "; @,") pp st (x :: xs) = 27 | Format.pp_print_list ~pp_sep pp st (List.cons x xs) 28 | ;; 29 | -------------------------------------------------------------------------------- /lib/yocaml_kohai/uuid.ml: -------------------------------------------------------------------------------- 1 | type t = Kohai_core.Uuid.t 2 | 3 | let validate = 4 | let open Yocaml.Data.Validation in 5 | string 6 | & fun str -> 7 | str 8 | |> Kohai_core.Uuid.from_string 9 | |> Option.fold ~none:(fail_with ~given:str "Not a valid UUID") ~some:Result.ok 10 | ;; 11 | 12 | let normalize id = id |> Kohai_core.Uuid.to_string |> Yocaml.Data.string 13 | 14 | module Set = struct 15 | type t = Kohai_core.Uuid.Set.t 16 | 17 | let entity_name = "Kohai.Uuid.Set" 18 | let neutral = Yocaml.Metadata.required entity_name 19 | 20 | let validate = 21 | let open Yocaml.Data.Validation in 22 | (list_of validate $ Kohai_core.Uuid.Set.from_list) 23 | / (null $ Fun.const Kohai_core.Uuid.Set.empty) 24 | ;; 25 | 26 | let normalize set = 27 | set |> Kohai_core.Uuid.Set.to_list |> Yocaml.Data.list_of normalize 28 | ;; 29 | end 30 | -------------------------------------------------------------------------------- /lib/model/key_value.ml: -------------------------------------------------------------------------------- 1 | module M = Stdlib.Map.Make (String) 2 | 3 | type 'a t = 'a M.t 4 | 5 | let from_rensai subject = 6 | let open Rensai.Validation in 7 | list_of 8 | (pair string subject 9 | / record (fun b -> 10 | let open Record in 11 | let+ key = required b "key" (string & String.is_not_blank) 12 | and+ value = required b "value" subject in 13 | key, value)) 14 | $ M.of_list 15 | ;; 16 | 17 | let to_rensai subject = 18 | let open Rensai.Ast in 19 | use 20 | M.to_list 21 | (list (fun (k, v) -> record [ "key", string k; "value", subject v ])) 22 | ;; 23 | 24 | let empty () = M.empty 25 | let add key value map = M.add key value map 26 | let remove key map = M.remove key map 27 | let keys map = map |> M.bindings |> List.map fst 28 | let from_list = M.of_list 29 | let to_list = M.to_list 30 | let is_empty = M.is_empty 31 | -------------------------------------------------------------------------------- /yocaml_rensai.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "dev" 4 | synopsis: "Inject and Read from Rensai to YOCaml" 5 | description: "Use Rensai as a Metadata language for YOCaml" 6 | maintainer: ["Xavier Van de Woestyne "] 7 | authors: ["Xavier Van de Woestyne "] 8 | license: "MIT" 9 | homepage: "https://github.com/xvw/kohai" 10 | bug-reports: "https://github.com/xvw/kohai/issues" 11 | depends: [ 12 | "dune" {>= "3.17"} 13 | "rensai" {= version} 14 | "yocaml" {>= "2.0.0"} 15 | "odoc" {with-doc} 16 | ] 17 | build: [ 18 | ["dune" "subst"] {dev} 19 | [ 20 | "dune" 21 | "build" 22 | "-p" 23 | name 24 | "-j" 25 | jobs 26 | "@install" 27 | "@runtest" {with-test} 28 | "@doc" {with-doc} 29 | ] 30 | ] 31 | dev-repo: "git+https://github.com/xvw/kohai.git" 32 | -------------------------------------------------------------------------------- /lib/interaction/workflow/described_item.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | (** Returns the set of item. *) 3 | val list 4 | : (module Sigs.EFFECT_HANDLER) 5 | -> unit 6 | -> Kohai_model.Described_item.Set.t 7 | 8 | (** Smartly save into the item set. *) 9 | val save 10 | : (module Sigs.EFFECT_HANDLER) 11 | -> Kohai_model.Described_item.t 12 | -> Kohai_model.Described_item.Set.t 13 | 14 | (** Find by his name. *) 15 | val get 16 | : (module Sigs.EFFECT_HANDLER) 17 | -> string 18 | -> Kohai_model.Described_item.t option 19 | 20 | (** Delete by his name. *) 21 | val delete 22 | : (module Sigs.EFFECT_HANDLER) 23 | -> string 24 | -> Kohai_model.Described_item.Set.t 25 | end 26 | 27 | module Make (A : Action.Described_item.S) = struct 28 | let list = A.list 29 | let save = A.save 30 | let get = A.get 31 | let delete = A.delete 32 | end 33 | -------------------------------------------------------------------------------- /lib/interaction/action/log.mli: -------------------------------------------------------------------------------- 1 | (** Get a log by UUID. *) 2 | val get : (module Sigs.EFFECT_HANDLER) -> Uuid.t -> Kohai_model.Log.t option 3 | 4 | (** Promote a transient log into a log (and propagate update in 5 | caches) *) 6 | val promote 7 | : (module Sigs.EFFECT_HANDLER) 8 | -> Kohai_model.Transient_log.t 9 | -> unit option 10 | 11 | (** Unpromote a log. *) 12 | val unpromote 13 | : (module Sigs.EFFECT_HANDLER) 14 | -> Uuid.t 15 | -> Kohai_model.Transient_log.t option 16 | 17 | (** Return the list of last log. *) 18 | val last : (module Sigs.EFFECT_HANDLER) -> unit -> Kohai_model.Log.t list 19 | 20 | (** Return the list of last log for a given sector. *) 21 | val last_for_sector 22 | : (module Sigs.EFFECT_HANDLER) 23 | -> string 24 | -> Kohai_model.Log.t list 25 | 26 | (** Return the list of last log for a given project. *) 27 | val last_for_project 28 | : (module Sigs.EFFECT_HANDLER) 29 | -> string 30 | -> Kohai_model.Log.t list 31 | -------------------------------------------------------------------------------- /yocaml_kohai.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "dev" 4 | synopsis: "Convert Kohai object as YOCaml object" 5 | description: "Kohai object available as YOCaml object for web reporting" 6 | maintainer: ["Xavier Van de Woestyne "] 7 | authors: ["Xavier Van de Woestyne "] 8 | license: "MIT" 9 | homepage: "https://github.com/xvw/kohai" 10 | bug-reports: "https://github.com/xvw/kohai/issues" 11 | depends: [ 12 | "dune" {>= "3.17"} 13 | "rensai" {= version} 14 | "kohai" {= version} 15 | "yocaml_rensai" {= version} 16 | "yocaml" {>= "2.0.0"} 17 | "odoc" {with-doc} 18 | ] 19 | build: [ 20 | ["dune" "subst"] {dev} 21 | [ 22 | "dune" 23 | "build" 24 | "-p" 25 | name 26 | "-j" 27 | jobs 28 | "@install" 29 | "@runtest" {with-test} 30 | "@doc" {with-doc} 31 | ] 32 | ] 33 | dev-repo: "git+https://github.com/xvw/kohai.git" 34 | -------------------------------------------------------------------------------- /lib/core/regex.ml: -------------------------------------------------------------------------------- 1 | let trim r = Re.(seq [ rep blank; r; rep blank ]) 2 | let constant k = trim Re.(no_case @@ str k) 3 | let time_sep = Re.set ":-/T " 4 | let min_or_sec = Re.(seq [ opt (rg '0' '5'); digit ]) 5 | let hour = Re.(seq [ opt (rg '0' '2'); digit ]) 6 | let at = Re.(seq [ rep blank; opt (no_case @@ str "at"); rep blank ]) 7 | 8 | let time_full = 9 | Re.( 10 | seq 11 | [ at 12 | ; group hour 13 | ; alt 14 | [ no_case (char 'h') 15 | ; opt 16 | (seq 17 | [ alt [ time_sep; no_case (char 'h') ] 18 | ; group min_or_sec 19 | ; opt 20 | (seq 21 | [ alt [ time_sep; no_case (char 'm') ] 22 | ; group min_or_sec 23 | ]) 24 | ]) 25 | ] 26 | ]) 27 | |> trim 28 | ;; 29 | 30 | let opt_int_of_group g i = Option.bind (Re.Group.get_opt g i) int_of_string_opt 31 | -------------------------------------------------------------------------------- /lib/interaction/action/global.ml: -------------------------------------------------------------------------------- 1 | let check_supervised_path (module H : Eff.HANDLER) path = 2 | if Path.is_relative path 3 | then 4 | Eff.raise (module H) 5 | @@ Error.supervised_directory_error 6 | ~message:"Supervised directory need to be absolute" 7 | () 8 | else if not (Eff.is_dir (module H) path) 9 | then 10 | Eff.raise (module H) 11 | @@ Error.supervised_directory_error 12 | ~message:"The given directory does not exists" 13 | () 14 | else path 15 | ;; 16 | 17 | let ensure_supervision (module H : Eff.HANDLER) () = 18 | match Eff.get_supervised_directory (module H) with 19 | | None -> Eff.raise (module H) @@ Error.no_supervised_directory () 20 | | Some path -> 21 | let _ = check_supervised_path (module H) path in 22 | path 23 | ;; 24 | 25 | let with_supervision (module H : Eff.HANDLER) callback arg = 26 | let _ = ensure_supervision (module H) () in 27 | callback (module H : Eff.HANDLER) arg 28 | ;; 29 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | 11 | # ocamlbuild working directory 12 | _build/ 13 | 14 | # ocamlbuild targets 15 | *.byte 16 | *.native 17 | *.exe 18 | 19 | # oasis generated files 20 | setup.data 21 | setup.log 22 | 23 | # Merlin configuring file for Vim and Emacs 24 | .merlin 25 | 26 | # Dune generated files 27 | *.install 28 | 29 | # Local OPAM switch 30 | _opam/ 31 | 32 | # Kohai stuff 33 | .kohai/ 34 | 35 | # Rust artifacts 36 | target/ 37 | 38 | # Node artifacts 39 | build/ 40 | prebuilds/ 41 | node_modules/ 42 | 43 | # Swift artifacts 44 | .build/ 45 | 46 | # Go artifacts 47 | _obj/ 48 | 49 | # Python artifacts 50 | .venv/ 51 | dist/ 52 | *.egg-info 53 | *.whl 54 | 55 | # C artifacts 56 | *.a 57 | *.so 58 | *.so.* 59 | *.dylib 60 | *.dll 61 | *.pc 62 | 63 | # Example dirs 64 | /examples/*/ 65 | 66 | # Grammar volatiles 67 | *.wasm 68 | *.obj 69 | *.o 70 | 71 | # Archives 72 | *.tar.gz 73 | *.tgz 74 | *.zip -------------------------------------------------------------------------------- /lib/model/resolver.mli: -------------------------------------------------------------------------------- 1 | (** A list of tools for easy access to working directory items. *) 2 | 3 | (** Return the state. *) 4 | val state : cwd:Path.t -> Path.t 5 | 6 | (** Return the path where the list of sectors is stored. *) 7 | val sectors : cwd:Path.t -> Path.t 8 | 9 | (** Return the path where the list of projects is stored. *) 10 | val projects : cwd:Path.t -> Path.t 11 | 12 | (** Returns the folder containing logs. *) 13 | val logs : cwd:Path.t -> Path.t 14 | 15 | (** Returns the folder containing the list of logs. *) 16 | val all_logs : cwd:Path.t -> Path.t 17 | 18 | (** Return the list of last logs. *) 19 | val last_logs : cwd:Path.t -> Path.t 20 | 21 | (** Returns the path containing transient logs. *) 22 | val transient_logs : cwd:Path.t -> Path.t 23 | 24 | (** Return the path where the sector cache is stored. *) 25 | val sector_folder : cwd:Path.t -> Path.t 26 | 27 | (** Return the path where the project cache is stored. *) 28 | val project_folder : cwd:Path.t -> Path.t 29 | -------------------------------------------------------------------------------- /lib/yocaml_kohai/datetime.ml: -------------------------------------------------------------------------------- 1 | type t = Kohai_core.Datetime.t 2 | 3 | let month_to_yocaml = function 4 | | Kohai_core.Datetime.Jan -> 1 5 | | Feb -> 2 6 | | Mar -> 3 7 | | Apr -> 4 8 | | May -> 5 9 | | Jun -> 6 10 | | Jul -> 7 11 | | Aug -> 8 12 | | Sep -> 9 13 | | Oct -> 10 14 | | Nov -> 11 15 | | Dec -> 12 16 | ;; 17 | 18 | let to_yocaml_aux Kohai_core.Datetime.{ year; month; day; hour; min; sec } = 19 | Yocaml.Datetime.make 20 | ~time:(hour, min, sec) 21 | ~year 22 | ~month:(month_to_yocaml month) 23 | ~day 24 | () 25 | ;; 26 | 27 | let validate = 28 | let open Yocaml.Data.Validation in 29 | string 30 | & fun x -> 31 | match Kohai_core.Datetime.from_string x with 32 | | Ok dt -> Ok dt 33 | | Error _ -> fail_with ~given:x "Invalid datetime" 34 | ;; 35 | 36 | let to_yocaml dt = 37 | match to_yocaml_aux dt with 38 | | Ok x -> x 39 | | Error _ -> failwith "kohai_datetime: should not happen" 40 | ;; 41 | 42 | let normalize dt = dt |> to_yocaml |> Yocaml.Datetime.normalize 43 | -------------------------------------------------------------------------------- /lib/server/jsonrpc.mli: -------------------------------------------------------------------------------- 1 | (** A very naive approach to describing compliant services/methods 2 | with JSONRPC 2.0. 3 | 4 | There are already many libraries that do this very well... but as 5 | mentioned, I really like the principle of reinventing the wheel, 6 | gradually adding the necessary functionality. *) 7 | 8 | (** {1 Services} *) 9 | 10 | (** The type that describes a service/method. *) 11 | type service 12 | 13 | (** [service ~meth ~with_params ~finalizer callback] describe a pair 14 | [meth/service]. *) 15 | val service 16 | : meth:string 17 | -> with_params:'a Rensai.Validation.t 18 | -> finalizer:(Kohai_model.Context.t -> 'b Rensai.Ast.conv) 19 | -> (Eff.handler -> Kohai_model.Context.t -> 'a -> 'b) 20 | -> string * service 21 | 22 | (** {1 Run} *) 23 | 24 | (** [run ~services body (module Handler)] tries to transform the 25 | request body through the various services described. *) 26 | val run 27 | : Eff.handler 28 | -> services:(string * service) list 29 | -> string 30 | -> (Rensai.Ast.t, Error.t) result 31 | -------------------------------------------------------------------------------- /lib/model/state.mli: -------------------------------------------------------------------------------- 1 | (** Describes an application state (essentially for caching). *) 2 | 3 | type t 4 | 5 | (** Create a new cache environment. *) 6 | val big_bang : unit -> t 7 | 8 | (** Create a state. *) 9 | val make 10 | : ?big_bang:Datetime.t 11 | -> ?end_of_world:Datetime.t 12 | -> ?number_of_logs:int 13 | -> ?duration:Duration.t 14 | -> unit 15 | -> t 16 | 17 | (** Update date boundaries of the cache. *) 18 | val patch_date_boundaries : Datetime.t -> t -> t 19 | 20 | val increase_duration : Duration.t -> t -> t 21 | val decrease_duration : Duration.t -> t -> t 22 | val increase_counter : int -> t -> t 23 | val decrease_counter : int -> t -> t 24 | 25 | (** {1 Serialization} *) 26 | 27 | val from_rensai : t Rensai.Validation.t 28 | val to_compact_rensai : t Rensai.Ast.conv 29 | val from_string : string -> t 30 | val dump : t -> string 31 | 32 | (** {1 Extract information} *) 33 | 34 | val big_bang_of : t -> Datetime.t option 35 | val end_of_world_of : t -> Datetime.t option 36 | val number_of_logs_of : t -> int 37 | val duration_of : t -> Duration.t 38 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2025 Xavier Van de Woestyne 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 | -------------------------------------------------------------------------------- /lib/yocaml_kohai/state.ml: -------------------------------------------------------------------------------- 1 | type t = Kohai_model.State.t 2 | 3 | let entity_name = "Kohai.State" 4 | let neutral = Yocaml.Metadata.required entity_name 5 | 6 | let validate = 7 | let open Yocaml.Data.Validation in 8 | record (fun fields -> 9 | let+ big_bang = optional fields "big_bang" Datetime.validate 10 | and+ end_of_world = optional fields "end_of_world" Datetime.validate 11 | and+ number_of_logs = optional_or ~default:0 fields "number_of_logs" int 12 | and+ duration = 13 | optional_or 14 | ~default:Kohai_core.Duration.zero 15 | fields 16 | "duration" 17 | Duration.validate 18 | in 19 | Kohai_model.State.make ?big_bang ?end_of_world ~number_of_logs ~duration ()) 20 | / (null $ Kohai_model.State.big_bang) 21 | ;; 22 | 23 | let normalize state = 24 | let open Kohai_model.State in 25 | let open Yocaml.Data in 26 | record 27 | [ "big_bang", option Datetime.normalize (big_bang_of state) 28 | ; "end_of_world", option Datetime.normalize (end_of_world_of state) 29 | ; "number_of_logs", int (number_of_logs_of state) 30 | ; "duration", Duration.normalize (duration_of state) 31 | ] 32 | ;; 33 | -------------------------------------------------------------------------------- /test/model/state_test.ml: -------------------------------------------------------------------------------- 1 | open Kohai_core 2 | open Kohai_model 3 | 4 | let mk_date s = 5 | s 6 | |> Datetime.from_string 7 | (* Since it is a test, we can discard 8 | the error case *) 9 | |> Result.get_ok 10 | ;; 11 | 12 | let a_date = mk_date "2025-02-18 10:00:00" 13 | 14 | let dump state = 15 | state 16 | |> State.to_compact_rensai 17 | |> Format.asprintf "%a" Rensai.Lang.pp 18 | |> print_endline 19 | ;; 20 | 21 | let%expect_test "dump boundaries - 1" = 22 | let state = State.big_bang () |> State.patch_date_boundaries a_date in 23 | dump state; 24 | [%expect 25 | {| 26 | 28 | |}] 29 | ;; 30 | 31 | let%expect_test "dump boundaries - 2" = 32 | let a_second_date = Datetime.(a_date + min 30) in 33 | let state = 34 | State.big_bang () 35 | |> State.patch_date_boundaries a_date 36 | |> State.patch_date_boundaries a_second_date 37 | in 38 | dump state; 39 | [%expect 40 | {| 41 | 43 | |}] 44 | ;; 45 | -------------------------------------------------------------------------------- /rensai.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "dev" 4 | synopsis: "Rensai can be used to describe generic encoders and decoders" 5 | description: """ 6 | By lifting heterogeneous data into a finite set of constructors, 7 | it is possible to describe languages similar to JSON, TOML or 8 | S-Expression, for which the encoding and validation functions 9 | become generic (and interchangeable).""" 10 | maintainer: ["Xavier Van de Woestyne "] 11 | authors: ["Xavier Van de Woestyne "] 12 | license: "MIT" 13 | homepage: "https://github.com/xvw/kohai" 14 | bug-reports: "https://github.com/xvw/kohai/issues" 15 | depends: [ 16 | "dune" {>= "3.17"} 17 | "ocaml" {>= "5.3.0"} 18 | "menhir" 19 | "yojson" {>= "3.0.0"} 20 | "fmt" {>= "0.9.0"} 21 | "ppx_expect" 22 | "mdx" {with-test} 23 | "odoc" {with-doc} 24 | ] 25 | build: [ 26 | ["dune" "subst"] {dev} 27 | [ 28 | "dune" 29 | "build" 30 | "-p" 31 | name 32 | "-j" 33 | jobs 34 | "@install" 35 | "@runtest" {with-test} 36 | "@doc" {with-doc} 37 | ] 38 | ] 39 | dev-repo: "git+https://github.com/xvw/kohai.git" 40 | -------------------------------------------------------------------------------- /lib/rensai/lang.mli: -------------------------------------------------------------------------------- 1 | (** [Lang] describes a small syntax used as a substitute for JSON 2 | (because it's fun to reinvent the wheel). *) 3 | 4 | (** Lift a string into a Rensai expression. *) 5 | val from_string : string -> Ast.t option 6 | 7 | (** Read a lexingbuf into a Rensai expression. *) 8 | val from_lexingbuf : Lexing.lexbuf -> Ast.t option 9 | 10 | (** Read a lexingbuf into a Rensai expression (or null if there is no valid expression). 11 | *) 12 | val from_lexingbuf_or_null : Lexing.lexbuf -> Ast.t 13 | 14 | (** Lex the content of a lexing buf and collect every result in a 15 | string. By default, the result is not reversed. Use [?reverse] to 16 | trigger [List.rev]. *) 17 | val from_lexingbuf_to_list : ?reverse:bool -> Lexing.lexbuf -> Ast.t list 18 | 19 | (** Pretty-printer according to the visual representation of a 20 | Rensai.Lang. Something printer with the following pretty-printer 21 | should be bi-directionnaly parsed.*) 22 | val pp : Format.formatter -> Ast.t -> unit 23 | 24 | (** Dump an element into a string. *) 25 | val dump : ('a -> Ast.t) -> 'a -> string 26 | 27 | (** Dump a list of element into a lexbuffable string. *) 28 | val dump_list : ('a -> Ast.t) -> 'a list -> string 29 | -------------------------------------------------------------------------------- /lib/rensai/json.mli: -------------------------------------------------------------------------------- 1 | (** A wrapper for dealing with the Json library, which tries to be a 2 | bit clever about how to represent input data and project it into 3 | ideal representations. *) 4 | 5 | (** Yojson.Safe AST. *) 6 | type yojson = 7 | [ `Null 8 | | `Bool of bool 9 | | `Int of int 10 | | `Intlit of string 11 | | `Float of float 12 | | `String of string 13 | | `Assoc of (string * yojson) list 14 | | `List of yojson list 15 | ] 16 | 17 | (** Ezjsonm AST. *) 18 | type ezjsonm = 19 | [ `Null 20 | | `Bool of bool 21 | | `Float of float 22 | | `String of string 23 | | `A of ezjsonm list 24 | | `O of (string * ezjsonm) list 25 | ] 26 | 27 | (** [to_yojson rensai] Transforms a Rensai expression into a Yojson 28 | expression. *) 29 | val to_yojson : Ast.t -> yojson 30 | 31 | (** [from_yojson yojson] Transforms a Yosjon expression into a Rensai 32 | expression. *) 33 | val from_yojson : yojson -> Ast.t 34 | 35 | (** [to_ezjsonm rensai] Transforms a Rensai expression into a Ezjsonm 36 | expression. *) 37 | val to_ezjsonm : Ast.t -> ezjsonm 38 | 39 | (** [from_yojson yojson] Transforms a Ezjsonm expression into a Rensai 40 | expression. *) 41 | val from_ezjsonm : ezjsonm -> Ast.t 42 | -------------------------------------------------------------------------------- /lib/core/duration.mli: -------------------------------------------------------------------------------- 1 | (** A rather naive way of dealing with durations (The under the hood 2 | representation is described using integers (64) representing 3 | seconds). *) 4 | 5 | (** {1 Types} *) 6 | 7 | (** A duration (as a number of seconds). *) 8 | type t 9 | 10 | (** A duration splitted by days, hours, mins and sec. *) 11 | type representation = 12 | { d : t 13 | ; h : t 14 | ; m : t 15 | ; s : t 16 | } 17 | 18 | (** {1 From regular number} *) 19 | 20 | val from_int : int -> t 21 | val from_int32 : int32 -> t 22 | val from_float : float -> t 23 | val from_int64 : int64 -> t 24 | 25 | (** {1 To regular number} *) 26 | 27 | val to_int : t -> int 28 | val to_int32 : t -> int32 29 | val to_int64 : t -> int64 30 | val to_float : t -> float 31 | 32 | (** {1 Tools} *) 33 | 34 | val zero : t 35 | val add : t -> t -> t 36 | val sub : t -> t -> t 37 | val bound_positive : t -> t 38 | val compute : t -> representation 39 | 40 | (** {1 Misc} *) 41 | 42 | (** Lift a duration into a rensai expression. *) 43 | val to_rensai : t Rensai.Ast.conv 44 | 45 | (** Pretty-printer for displaying a date from a representation. *) 46 | val pp : Format.formatter -> t -> unit 47 | 48 | (** Comparison between duration. *) 49 | val compare : t -> t -> int 50 | -------------------------------------------------------------------------------- /lib/yocaml_kohai/described_item.ml: -------------------------------------------------------------------------------- 1 | type t = Kohai_model.Described_item.t 2 | 3 | let validate = 4 | let open Yocaml.Data.Validation in 5 | record (fun f -> 6 | let+ name = required f "name" string 7 | and+ description = optional f "description" string 8 | and+ counter = optional_or f ~default:0 "counter" int in 9 | Kohai_model.Described_item.make ~counter ?description name) 10 | ;; 11 | 12 | let normalize di = 13 | let open Yocaml.Data in 14 | record 15 | [ "name", string (Kohai_model.Described_item.name di) 16 | ; "description", option string (Kohai_model.Described_item.description di) 17 | ; "counter", int (Kohai_model.Described_item.counter di) 18 | ] 19 | ;; 20 | 21 | module Set = struct 22 | type t = Kohai_model.Described_item.Set.t 23 | 24 | let entity_name = "Kohai.Described_item.Set" 25 | let neutral = Yocaml.Metadata.required entity_name 26 | 27 | let validate = 28 | let open Yocaml.Data.Validation in 29 | (list_of validate $ Kohai_model.Described_item.Set.from_list) 30 | / (null $ Fun.const Kohai_model.Described_item.Set.empty) 31 | ;; 32 | 33 | let normalize set = 34 | set 35 | |> Kohai_model.Described_item.Set.to_list 36 | |> Yocaml.Data.list_of normalize 37 | ;; 38 | end 39 | -------------------------------------------------------------------------------- /lib/yocaml_kohai/url.ml: -------------------------------------------------------------------------------- 1 | type t = Kohai_model.Url.t 2 | 3 | let uri_to_data uri = 4 | let open Yocaml.Data in 5 | record 6 | [ "scheme", option string (uri |> Uri.scheme) 7 | ; "host", option string (uri |> Uri.host) 8 | ; "port", option int (uri |> Uri.port) 9 | ; "path", string (uri |> Uri.path) 10 | ; "query", list_of (pair string (list_of string)) (uri |> Uri.query) 11 | ] 12 | ;; 13 | 14 | let validate = 15 | let open Yocaml.Data.Validation in 16 | string $ Uri.of_string 17 | & fun uri -> 18 | uri 19 | |> uri_to_data 20 | |> record (fun f -> 21 | let+ scheme = 22 | required 23 | f 24 | "scheme" 25 | (string 26 | $ Stdlib.String.lowercase_ascii 27 | $ Kohai_model.Url.validate_scheme) 28 | and+ host = required f "host" string 29 | and+ query = 30 | optional_or 31 | ~default:(Kohai_model.Key_value.empty ()) 32 | f 33 | "query" 34 | (Key_value.validate (list_of string)) 35 | and+ port = optional f "port" int 36 | and+ path = required f "path" Path.validate in 37 | Kohai_model.Url.make ~uri ~scheme ~port ~host ~query ~path ()) 38 | ;; 39 | 40 | let normalize url = url |> Kohai_model.Url.to_rensai |> Yocaml_rensai.normalize 41 | -------------------------------------------------------------------------------- /lib/yocaml_rensai/yocaml_rensai.ml: -------------------------------------------------------------------------------- 1 | module Data_provider = struct 2 | type t = Rensai.Ast.t 3 | 4 | let rec normalize = function 5 | | Rensai.Ast.Null -> Yocaml.Data.null 6 | | Unit -> Yocaml.Data.null 7 | | Bool b -> Yocaml.Data.bool b 8 | | Char c -> Yocaml.Data.string @@ String.make 1 c 9 | | Int i -> Yocaml.Data.int i 10 | | Int32 i -> Yocaml.Data.float (Int32.to_float i) 11 | | Int64 i -> Yocaml.Data.float (Int64.to_float i) 12 | | Float f -> Yocaml.Data.float f 13 | | String s -> Yocaml.Data.string s 14 | | Pair (a, b) -> Yocaml.Data.pair normalize normalize (a, b) 15 | | List xs -> Yocaml.Data.list_of normalize xs 16 | | Constr (kname, value) -> 17 | Yocaml.Data.sum (fun () -> kname, normalize value) () 18 | | Record fields -> 19 | fields 20 | |> Rensai.Ast.record_to_assoc 21 | |> List.map (fun (k, v) -> k, normalize v) 22 | |> Yocaml.Data.record 23 | ;; 24 | 25 | let from_string given = 26 | given 27 | |> Rensai.Lang.from_string 28 | |> Option.to_result 29 | ~none: 30 | (Yocaml.Required.Parsing_error 31 | { given; message = "Rensai: unable to parse rensai expression" }) 32 | ;; 33 | end 34 | 35 | include Yocaml.Make.Data_reader (Data_provider) 36 | -------------------------------------------------------------------------------- /lib/rensai/nel.mli: -------------------------------------------------------------------------------- 1 | (** A naive implementation of a non-empty list (essentially to collect 2 | errors). *) 3 | 4 | (** Type describing a non-empty list. *) 5 | type 'a t = ( :: ) of 'a * 'a list 6 | 7 | (** [make x xs] creates an non-empty list. *) 8 | val make : 'a -> 'a list -> 'a t 9 | 10 | (** [singleton x] creates an non-empty list with one element. *) 11 | val singleton : 'a -> 'a t 12 | 13 | (** [init len f] is [f 0; f 1; ...; f (len-1)], evaluated left to right. 14 | @raise Invalid_argument if [len < 1]. *) 15 | val init : int -> (int -> 'a) -> 'a t 16 | 17 | (** [to_list nel] convert a non-empty list into a regular list. *) 18 | val to_list : 'a t -> 'a list 19 | 20 | (** [rev nel] reverse [nel]. *) 21 | val rev : 'a t -> 'a t 22 | 23 | (** [append xs ys] concat [xs] and [ys]. *) 24 | val append : 'a t -> 'a t -> 'a t 25 | 26 | (** [cons x xs] constructs a non-empty list whose head is [x] and whose tail is 27 | [xs]. *) 28 | val cons : 'a -> 'a t -> 'a t 29 | 30 | (** Equality between non-empty list. *) 31 | val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool 32 | 33 | (** Pretty printer for non-empty list. *) 34 | val pp 35 | : ?pp_sep:(Format.formatter -> unit -> unit) 36 | -> (Format.formatter -> 'a -> unit) 37 | -> Format.formatter 38 | -> 'a t 39 | -> unit 40 | -------------------------------------------------------------------------------- /site-lisp/rensai-mode.el: -------------------------------------------------------------------------------- 1 | ;;; rens-mode.el --- Modest mode for Rensai -*- coding: utf-8; lexical-binding: t -*- 2 | 3 | ;; Copyright (C) since 2025 Xavier Van de Woestyne 4 | ;; Licensed under the MIT license. 5 | 6 | ;; Author: Xavier Van de Woestyne 7 | 8 | ;; This file is NOT part of GNU Emac 9 | 10 | ;; Maintainer: Xavier Van de Woestyne 11 | ;; Created: 13 February 2025 12 | ;; Keywords: tool timetracker productivity 13 | ;; URL: https://github.com/xvw/kohai 14 | ;; Package-Requires: ((emacs "29.1")) 15 | ;; Package-Version: 0.1 16 | ;; SPDX-License-Identifier: MIT 17 | 18 | ;;; Commentary: 19 | 20 | ;; Request specific module 21 | 22 | ;;; Code: 23 | 24 | (defvar rensai-constants 25 | '("null" "true" "false") 26 | "Constants for the Rensai Language.") 27 | 28 | (defvar rensai-font-lock-defaults 29 | `((("\"\\.\\*\\?" . font-lock-string-face) 30 | ( ,(regexp-opt rensai-constants 'words) . font-lock-builtin-face))) 31 | "Default Font Lock for the Rensai Language.") 32 | 33 | (define-derived-mode rens-mode fundamental-mode "Rensai" 34 | "Major mode for highlighting Rensai text buffer." 35 | (setq font-lock-defaults rensai-font-lock-defaults)) 36 | 37 | ;;;###autoload 38 | (add-to-list 'auto-mode-alist '("\\.rens\\'" . rens-mode)) 39 | 40 | (provide 'rensai-mode) 41 | ;;; rens-mode.el ends here 42 | -------------------------------------------------------------------------------- /kohai.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "dev" 4 | synopsis: "A small hand-crafted tool for recording activities" 5 | description: """ 6 | A tool for collecting personal activity reports (and an excuse 7 | to write OCaml and reinvent the wheel)""" 8 | maintainer: ["Xavier Van de Woestyne "] 9 | authors: ["Xavier Van de Woestyne "] 10 | license: "MIT" 11 | homepage: "https://github.com/xvw/kohai" 12 | bug-reports: "https://github.com/xvw/kohai/issues" 13 | depends: [ 14 | "dune" {>= "3.17"} 15 | "ocaml" {>= "5.3.0"} 16 | "re" 17 | "uri" 18 | "uuidm" 19 | "rensai" {= version} 20 | "ppx_expect" 21 | "mdx" {with-test} 22 | "yojson" {>= "3.0.0"} 23 | "fmt" {>= "0.9.0"} 24 | "logs" {>= "0.7.0"} 25 | "cmdliner" {>= "1.3.0"} 26 | "eio" {>= "1.1"} 27 | "eio_main" {>= "1.1"} 28 | "ocamlformat" {with-dev-setup} 29 | "ocp-indent" {with-dev-setup} 30 | "merlin" {with-dev-setup} 31 | "ocaml-lsp-server" {with-dev-setup} 32 | "utop" {with-dev-setup} 33 | "odoc" {with-doc} 34 | ] 35 | build: [ 36 | ["dune" "subst"] {dev} 37 | [ 38 | "dune" 39 | "build" 40 | "-p" 41 | name 42 | "-j" 43 | jobs 44 | "@install" 45 | "@runtest" {with-test} 46 | "@doc" {with-doc} 47 | ] 48 | ] 49 | dev-repo: "git+https://github.com/xvw/kohai.git" 50 | -------------------------------------------------------------------------------- /lib/core/uuid.ml: -------------------------------------------------------------------------------- 1 | type t = Uuidm.t 2 | 3 | let gen s = Uuidm.v5 Uuidm.ns_oid s 4 | let from_string v = Uuidm.of_string v 5 | 6 | let from_rensai = 7 | let open Rensai.Validation in 8 | string 9 | & fun str -> 10 | str 11 | |> from_string 12 | |> function 13 | | None -> fail_with ~subject:str "Not a valid uuid" 14 | | Some x -> Ok x 15 | ;; 16 | 17 | let to_rensai id = 18 | let open Rensai.Ast in 19 | id |> Uuidm.to_string |> string 20 | ;; 21 | 22 | let to_string s = Uuidm.to_string s 23 | 24 | module Set = struct 25 | module S = Stdlib.Set.Make (Uuidm) 26 | 27 | type t = S.t 28 | 29 | let from_list = S.of_list 30 | let to_list = S.to_list 31 | 32 | let dump items = 33 | items |> to_list |> Rensai.Lang.dump (Rensai.Ast.list to_rensai) 34 | ;; 35 | 36 | let to_rensai set = set |> S.to_list |> Rensai.Ast.list to_rensai 37 | let empty = S.empty 38 | 39 | let from_rensai = 40 | let open Rensai.Validation in 41 | (list_of from_rensai $ S.of_list) / (null $ Fun.const empty) 42 | ;; 43 | 44 | let push uid set = S.add uid set 45 | let remove uid set = S.remove uid set 46 | 47 | let from_file_content content = 48 | let lexbuf = Lexing.from_string content in 49 | lexbuf 50 | |> Rensai.Lang.from_lexingbuf 51 | |> Option.fold ~none:S.empty ~some:(fun x -> 52 | x 53 | |> from_rensai 54 | |> function 55 | | Error _ -> S.empty 56 | | Ok x -> x) 57 | ;; 58 | end 59 | -------------------------------------------------------------------------------- /test/rensai/nel_test.ml: -------------------------------------------------------------------------------- 1 | open Rensai 2 | 3 | let dump pp value = 4 | value |> Format.asprintf "nel@[[%a]@]" (Nel.pp pp) |> print_endline 5 | ;; 6 | 7 | let%expect_test "make - 1" = 8 | let expr = Nel.make 1 [] in 9 | expr |> dump Format.pp_print_int; 10 | [%expect {| nel[1] |}] 11 | ;; 12 | 13 | let%expect_test "make - 2" = 14 | let expr = Nel.make 1 [ 2; 3; 4 ] in 15 | expr |> dump Format.pp_print_int; 16 | [%expect {| nel[1; 2; 3; 4] |}] 17 | ;; 18 | 19 | let%expect_test "equal, make, singleton - 1" = 20 | let nel_a = Nel.make 1 [] in 21 | let nel_b = Nel.singleton 1 in 22 | if Nel.equal Int.equal nel_a nel_b 23 | then print_endline "ok" 24 | else print_endline "not-ok"; 25 | [%expect {| ok |}] 26 | ;; 27 | 28 | let%expect_test "cons - 1" = 29 | let expr = Nel.(cons 1 @@ singleton 2) in 30 | expr |> dump Format.pp_print_int; 31 | [%expect {| nel[1; 2] |}] 32 | ;; 33 | 34 | let%expect_test "rev - 1" = 35 | let expr = Nel.(1 :: 2 :: 3 :: [ 4 ] |> rev) in 36 | expr |> dump Format.pp_print_int; 37 | [%expect {| nel[4; 3; 2; 1] |}] 38 | ;; 39 | 40 | let%expect_test "append - 1" = 41 | let expr = Nel.(1 :: 2 :: 3 :: [ 4 ] |> append (0 :: [])) in 42 | expr |> dump Format.pp_print_int; 43 | [%expect {| nel[0; 1; 2; 3; 4] |}] 44 | ;; 45 | 46 | let%expect_test "append - 2" = 47 | let expr = Nel.(1 :: 2 :: 3 :: [ 4 ] |> append (-2 :: -1 :: [ 0 ])) in 48 | expr |> dump Format.pp_print_int; 49 | [%expect {| nel[-2; -1; 0; 1; 2; 3; 4] |}] 50 | ;; 51 | -------------------------------------------------------------------------------- /lib/core/sigs.mli: -------------------------------------------------------------------------------- 1 | (** Some shared interfaces *) 2 | 3 | (** Describes all the effects a program can propagate. This module 4 | serves as a requirement for building a Handler. *) 5 | module type EFFECT_REQUIREMENT = sig 6 | (** {1 Filesystem function} *) 7 | 8 | val exists : Path.t -> bool 9 | val is_file : Path.t -> bool 10 | val is_dir : Path.t -> bool 11 | val create_dir : Path.t -> unit 12 | val read_file : Path.t -> string 13 | val write_file : Path.t -> string -> unit 14 | val append_to_file : Path.t -> string -> unit 15 | val delete_file : Path.t -> unit 16 | val delete_dir : ?recursive:bool -> Path.t -> unit 17 | 18 | (** {1 Time function} *) 19 | 20 | val now : unit -> float 21 | val datetime_from_float : float -> Datetime.t Rensai.Validation.checked 22 | 23 | (** {1 Specific function} *) 24 | 25 | val set_supervised_directory : Path.t option -> unit 26 | val get_supervised_directory : unit -> Path.t option 27 | end 28 | 29 | (** An effect handler is built around a 30 | {!module-type:EFFECT_REQUIREMENT} to propagate platform-specific 31 | operations.*) 32 | module type EFFECT_HANDLER = sig 33 | include EFFECT_REQUIREMENT 34 | 35 | exception Handler_exn of Error.custom 36 | 37 | (** [raise error] throws a fixed-error. *) 38 | val raise : Error.custom -> 'a 39 | 40 | (** [handle_with_error program], handle [program ()] with 41 | exception. *) 42 | val handle_with_error : (unit -> 'a) -> ('a, Error.custom) result 43 | end 44 | -------------------------------------------------------------------------------- /test/server/virtfs.mli: -------------------------------------------------------------------------------- 1 | (** A virtual (and artificial) file system mainly used to describe 2 | unit tests. Since the main purpose is mostly testing, the code is 3 | not particularly optimized. *) 4 | 5 | open Kohai_core 6 | 7 | (** {1 Types} *) 8 | 9 | (** An item in the filesystem. *) 10 | type item 11 | 12 | (** A file system representation. *) 13 | type t 14 | 15 | (** {1 Build filesystem} *) 16 | 17 | (** [file ?mtime ?content name] create a virtual file. *) 18 | val file : ?mtime:int -> ?content:string -> string -> item 19 | 20 | (** [dir ?mtime name children] create a virtual directory. *) 21 | val dir : ?mtime:int -> string -> item list -> item 22 | 23 | (** [from_list ?mtime elt] create a file system from a list. ([mtime] 24 | is used for the root of the file tree) *) 25 | val from_list : ?mtime:int -> item list -> t 26 | 27 | (** {1 Interacting with filesystem} *) 28 | 29 | (** [get fs path] try to reach a path. *) 30 | val get : t -> Path.t -> item option 31 | 32 | (** [cat fs path] a very naive way to read a file (it is a little bit 33 | like [Unix cat] but that does not concatenate file because 34 | hehe). *) 35 | val cat : t -> Path.t -> string 36 | 37 | val update 38 | : t 39 | -> Path.t 40 | -> (target:string -> ?previous:item -> unit -> item option) 41 | -> t 42 | 43 | (** {1 Effect handler} *) 44 | 45 | module Make (_ : sig 46 | val fs : t 47 | val now : Datetime.t 48 | end) : sig 49 | include Sigs.EFFECT_REQUIREMENT 50 | 51 | val get_fs : unit -> t 52 | val manip_time : (Datetime.t -> Datetime.t) -> unit 53 | end 54 | -------------------------------------------------------------------------------- /lib/core/error.mli: -------------------------------------------------------------------------------- 1 | (** Description of errors propagated by a JSONRPC server. *) 2 | 3 | (** {1 Types} *) 4 | 5 | (** Jsonrpc errors. *) 6 | type t 7 | 8 | (** Custom errors. *) 9 | type custom 10 | 11 | (** {1 Build errors} *) 12 | 13 | (** {2 Jsonrpc errors} *) 14 | 15 | val parse_error : body:string -> unit -> t 16 | 17 | val invalid_request 18 | : body:string 19 | -> error:Rensai.Validation.value_error 20 | -> unit 21 | -> t 22 | 23 | val method_not_found : body:string -> ?id:int -> meth:string -> unit -> t 24 | 25 | val invalid_params 26 | : body:string 27 | -> ?id:int 28 | -> error:Rensai.Validation.value_error 29 | -> unit 30 | -> t 31 | 32 | val internal_error : body:string -> ?id:int -> message:string -> unit -> t 33 | 34 | val custom_error 35 | : ?with_offset:bool 36 | -> body:string 37 | -> ?id:int 38 | -> ?code:int 39 | -> ?message:string 40 | -> unit 41 | -> t 42 | 43 | (** {2 Internal errors} *) 44 | 45 | val custom_to_jsonrpc : body:string -> ?id:int -> custom -> t 46 | val unknown_error : message:string -> unit -> custom 47 | val no_supervised_directory : unit -> custom 48 | val supervised_directory_error : message:string -> unit -> custom 49 | 50 | val resource_not_found 51 | : index:string 52 | -> subject:string 53 | -> code:int 54 | -> unit 55 | -> custom 56 | 57 | val no_related_transient_log : index:int -> unit -> custom 58 | val no_related_log : uuid:Uuid.t -> unit -> custom 59 | val invalid_datetime : float -> Rensai.Validation.value_error -> custom 60 | 61 | (** {1 Rensai} *) 62 | 63 | val to_rensai : t -> Rensai.Ast.t 64 | -------------------------------------------------------------------------------- /lib/model/described_item.mli: -------------------------------------------------------------------------------- 1 | (** Describe an item associated to a description (the item name is 2 | always unique in a set). Something that can be described as a 3 | category for log or a project. *) 4 | 5 | type t 6 | 7 | (** Convert item to rensai lang. *) 8 | val to_rensai : t Rensai.Ast.conv 9 | 10 | (** Convert rensai expression to item. *) 11 | val from_rensai : t Rensai.Validation.t 12 | 13 | val make : ?counter:int -> ?description:string -> string -> t 14 | val can_be_erased : t -> bool 15 | val name : t -> string 16 | val description : t -> string option 17 | val counter : t -> int 18 | 19 | module Set : sig 20 | type item := t 21 | type t 22 | 23 | (** [push item items] push a item in the item list, if the 24 | item already exists, it takes the most complete.*) 25 | val push : item -> t -> t 26 | 27 | val from_ast_list : Rensai.Ast.t list -> t 28 | val from_list : item list -> t 29 | val empty : t 30 | val to_list : t -> item list 31 | 32 | (** Convert item set to rensai lang. *) 33 | val to_rensai : t Rensai.Ast.conv 34 | 35 | (** Convert rensai expression to item set. *) 36 | val from_rensai : t Rensai.Validation.t 37 | 38 | (** Render a item set into a string to be stored in a file. *) 39 | val dump : t -> string 40 | 41 | (** find a item in a set. *) 42 | val find : string -> t -> item option 43 | 44 | (** Remove an item from the given set.*) 45 | val remove : string -> t -> t 46 | 47 | (** Increase an item counter. *) 48 | val increase : string -> t -> t 49 | 50 | (** Decrease an item counter. *) 51 | val decrease : string -> t -> t 52 | end 53 | -------------------------------------------------------------------------------- /lib/interaction/workflow/transient_log.ml: -------------------------------------------------------------------------------- 1 | let list = Action.Transient_log.list 2 | let get = Action.Transient_log.get 3 | 4 | let action (module H : Eff.HANDLER) ctx = function 5 | | Kohai_model.Transient_log.Record { date_query; project; sector; label } -> 6 | Action.Transient_log.record 7 | (module H) 8 | ctx 9 | ~date_query 10 | ~project 11 | ~sector 12 | ~label 13 | | Stop_recording { index; duration } -> 14 | Action.Transient_log.stop_record (module H) ctx ~index ~duration 15 | | Rewrite { index; date_query; project; sector; label } -> 16 | Action.Transient_log.rewrite 17 | (module H) 18 | ctx 19 | ~index 20 | ~date_query 21 | ~project 22 | ~sector 23 | ~label 24 | | Delete { index } -> Action.Transient_log.delete (module H) ~index 25 | | Duplicate { index } -> Action.Transient_log.duplicate (module H) ~index 26 | | Add_meta { index; key; value } -> 27 | Action.Transient_log.add_meta (module H) ~index ~key ~value 28 | | Remove_meta { index; key } -> 29 | Action.Transient_log.remove_meta (module H) ~index ~key 30 | | Add_link { index; key; value } -> 31 | Action.Transient_log.add_link (module H) ~index ~key ~value 32 | | Remove_link { index; key } -> 33 | Action.Transient_log.remove_link (module H) ~index ~key 34 | | Promote { index } -> 35 | (match 36 | Option.bind 37 | (Action.Transient_log.get (module H) index) 38 | (Action.Log.promote (module H)) 39 | with 40 | | Some () -> Action.Transient_log.delete (module H) ~index 41 | | None -> Eff.raise (module H) (Error.no_related_transient_log ~index ())) 42 | ;; 43 | -------------------------------------------------------------------------------- /site-lisp/kohai-transient.el: -------------------------------------------------------------------------------- 1 | ;;; kohai-transient.el --- Transient widget -*- coding: utf-8; lexical-binding: t -*- 2 | 3 | ;; Copyright (C) since 2025 Xavier Van de Woestyne 4 | ;; Licensed under the MIT license. 5 | 6 | ;; Author: Xavier Van de Woestyne 7 | 8 | ;; This file is NOT part of GNU Emac 9 | 10 | ;; Maintainer: Xavier Van de Woestyne 11 | ;; Created: 13 February 2025 12 | ;; Keywords: tool timetracker productivity 13 | ;; URL: https://github.com/xvw/kohai 14 | ;; Package-Requires: ((emacs "29.1")) 15 | ;; Package-Version: 0.1 16 | ;; SPDX-License-Identifier: MIT 17 | 18 | ;;; Commentary: 19 | 20 | ;; Some transient widgets used in Kohai 21 | 22 | ;;; Code: 23 | 24 | (require 'transient) 25 | 26 | 27 | ;;; Global dashboard 28 | 29 | (transient-define-prefix kohai-transient--dashboard () 30 | "General Dashboard, opened when `kohai' is called." 31 | [["Supervised" 32 | ("dg" "get" kohai-get-supervised) 33 | ("ds" "set" kohai-set-supervised)] 34 | 35 | ["Sector" 36 | ("sl" "list" kohai-list-sectors) 37 | ("sn" "new" kohai-new-sector)] 38 | 39 | ["Projects" 40 | ("pl" "list" kohai-list-projects) 41 | ("pn" "new" kohai-new-project)] 42 | 43 | ["Transient logs" 44 | ("t" "list" kohai-list-transient-log) 45 | ("r" "record" kohai-record-transient-log)] 46 | 47 | ["State" 48 | ("st" "current" kohai-get-state) 49 | ("ss" "by sector" kohai-get-state-by-sector) 50 | ("sp" "by project" kohai-get-state-by-project)] 51 | 52 | ["Other" 53 | ("q" "close" transient-quit-one)]]) 54 | 55 | 56 | (provide 'kohai-transient) 57 | ;;; kohai-transient.el ends here 58 | 59 | -------------------------------------------------------------------------------- /lib/core/path.mli: -------------------------------------------------------------------------------- 1 | (** A (pure) abstraction to represent file paths. (Very largely inspired by 2 | {{:https://github.com/xhtmlboi/yocaml} YOCaml}!) *) 3 | 4 | (** {1 Types} *) 5 | 6 | (** The type describing a Path. *) 7 | type t 8 | 9 | (** {1 Building Path} *) 10 | 11 | (** Return the current path. *) 12 | val pwd : t 13 | 14 | (** Return the root path. *) 15 | val root : t 16 | 17 | (** [from_string s] convert a string into a path. *) 18 | val from_string : string -> t 19 | 20 | (** [from x ~into:s] build a path of [s] into [x]. *) 21 | val from : t -> into:string -> t 22 | 23 | (** {1 Path Manipulation} *) 24 | 25 | (** [extension path] return the extension of the given [path] (and 26 | an empty string if the path does not have any extension). *) 27 | val extension : t -> string 28 | 29 | (** [extension_opt] is [extension] but wrap the result into an option. *) 30 | val extension_opt : t -> string option 31 | 32 | (** Get the parent folder. *) 33 | val parent : t -> t option 34 | 35 | (** {1 Infix} *) 36 | 37 | module Infix : sig 38 | (** [p / s] is [from p ~into:s]. *) 39 | val ( / ) : t -> string -> t 40 | 41 | (** [~/s] is [from pwd ~into:s]. *) 42 | val ( ~/ ) : string -> t 43 | end 44 | 45 | include module type of Infix (** @inline *) 46 | 47 | (** {1 Misc} *) 48 | 49 | (** Equality Between Path. *) 50 | val equal : t -> t -> bool 51 | 52 | (** Return the representation (in string) of a Path. *) 53 | val to_string : t -> string 54 | 55 | val from_rensai : t Rensai.Validation.t 56 | val to_rensai : t -> Rensai.Ast.t 57 | val is_relative : t -> bool 58 | val is_absolute : t -> bool 59 | val to_list : t -> string list 60 | val as_target : t -> (string list * string) option 61 | -------------------------------------------------------------------------------- /lib/rensai/kind.mli: -------------------------------------------------------------------------------- 1 | (** describes and classifies the different types of nodes in the 2 | Rensai data AST. 3 | 4 | The main purpose of kind is to report errors. So it's not a 5 | reliable type system at all (as demonstrated by the particularly 6 | sad treatment of records). *) 7 | 8 | (** {1 Types} *) 9 | 10 | (** Set of possible node types. And is a clumsy way of expressing the 11 | ambivalence of the List constructor (which can handle both 12 | homogeneous and heterogeneous lists). Since records carry no 13 | structural information... they are treated as equivalent and 14 | notified by the kind [?record].*) 15 | type t = 16 | | Null 17 | | Unit 18 | | Bool 19 | | Char 20 | | Int 21 | | Int32 22 | | Int64 23 | | Float 24 | | String 25 | | Pair of t * t 26 | | List of t 27 | | Constr of string * t 28 | | Record 29 | | Any 30 | | Or of t * t 31 | | And of t * t 32 | 33 | (** {1 Helpers} *) 34 | 35 | (** [classify fragment] returns the main classification of a node. *) 36 | val classify : Ast.t -> t 37 | 38 | (** [from_list] Builds a kind list as a succession of Or. If the list 39 | is empty, the result will be [Any]. *) 40 | val from_list : t list -> t 41 | 42 | (** Pretty-Printers for Kind. *) 43 | val pp : Format.formatter -> t -> unit 44 | 45 | (** Equality between kinds. *) 46 | val equal : t -> t -> bool 47 | 48 | (** {1 Infix operators} 49 | 50 | Infix operators for easy creation of kinds composition. *) 51 | 52 | module Infix : sig 53 | (** [k1 || k2] is the [Or (k1, k2)]. *) 54 | val ( || ) : t -> t -> t 55 | 56 | (** [k1 && k2] is the [And (k1, k2)]. *) 57 | val ( && ) : t -> t -> t 58 | end 59 | 60 | include module type of Infix (** @inline *) 61 | -------------------------------------------------------------------------------- /test/server/virtfs_test.ml: -------------------------------------------------------------------------------- 1 | open Kohai_core 2 | 3 | let a_fs = 4 | let open Virtfs in 5 | from_list 6 | [ dir 7 | "foo" 8 | [ dir "bar" [ file ~content:"foobar" "foobar" ] 9 | ; dir "baz" [ file ~content:"a textual file" "notes.txt" ] 10 | ] 11 | ; dir "tmp" [] 12 | ] 13 | ;; 14 | 15 | let%expect_test "cat - with a file" = 16 | let result = Virtfs.cat a_fs Path.(root / "foo" / "bar" / "foobar") in 17 | print_endline result; 18 | [%expect {| foobar |}] 19 | ;; 20 | 21 | let%expect_test "cat - with an other file" = 22 | let result = Virtfs.cat a_fs Path.(root / "foo" / "baz" / "notes.txt") in 23 | print_endline result; 24 | [%expect {| a textual file |}] 25 | ;; 26 | 27 | let%expect_test "cat - with a directory" = 28 | let result = Virtfs.cat a_fs Path.(root / "tmp") in 29 | print_endline result; 30 | [%expect {| cat: /tmp: Is a directory |}] 31 | ;; 32 | 33 | let%expect_test "cat - with an inexistant target" = 34 | let result = Virtfs.cat a_fs Path.(root / "kohai" / "tmp") in 35 | print_endline result; 36 | [%expect {| cat: /kohai/tmp: No such file or directory |}] 37 | ;; 38 | 39 | let%expect_test "create-dir - 1" = 40 | let fs = 41 | Virtfs.update 42 | a_fs 43 | Path.(root / "xvw" / "lol" / "foobar") 44 | (fun ~target ?previous:_ () -> Some (Virtfs.dir target [])) 45 | in 46 | let xvw = Virtfs.cat fs Path.(root / "xvw") in 47 | let lol = Virtfs.cat fs Path.(root / "xvw" / "lol") in 48 | let foobar = Virtfs.cat fs Path.(root / "xvw" / "lol" / "foobar") in 49 | List.iter print_endline [ xvw; lol; foobar ]; 50 | [%expect 51 | {| 52 | cat: /xvw: Is a directory 53 | cat: /xvw/lol: Is a directory 54 | cat: /xvw/lol/foobar: Is a directory 55 | |}] 56 | ;; 57 | -------------------------------------------------------------------------------- /lib/core/duration.ml: -------------------------------------------------------------------------------- 1 | type t = int64 2 | 3 | type representation = 4 | { d : t 5 | ; h : t 6 | ; m : t 7 | ; s : t 8 | } 9 | 10 | let compare = Int64.compare 11 | let from_int = Int64.of_int 12 | let from_int32 = Int64.of_int32 13 | let from_float = Int64.of_float 14 | let from_int64 x = x 15 | let to_int = Int64.to_int 16 | let to_int32 = Int64.to_int32 17 | let to_int64 x = x 18 | let to_float = Int64.to_float 19 | let to_rensai = Rensai.Ast.int64 20 | 21 | let compute x = 22 | let ( - ) = Int64.sub 23 | and ( * ) = Int64.mul in 24 | let d = Int64.div x 86400L in 25 | let h = Int64.div (x - (d * 86400L)) 3600L in 26 | let m = Int64.div (x - (d * 86400L) - (h * 3600L)) 60L in 27 | let s = x - (d * 86400L) - (h * 3600L) - (m * 60L) in 28 | { d; h; m; s } 29 | ;; 30 | 31 | let pp st duration = 32 | let { d; h; m; s } = compute duration in 33 | let sum others = List.fold_left Int64.add Int64.zero others in 34 | let pp_with_suffix suff others st x = 35 | let coma = if Int64.(equal zero (sum others)) then "" else ", " in 36 | if Int64.(equal zero x) 37 | then Format.fprintf st "" 38 | else Format.fprintf st "%Ld%s%s" x suff coma 39 | in 40 | let pp_seconds others st x = 41 | if Int64.(equal zero x && not (equal (sum others) zero)) 42 | then Format.fprintf st "" 43 | else Format.fprintf st "%Lds" x 44 | in 45 | Format.fprintf 46 | st 47 | "%a%a%a%a" 48 | (pp_with_suffix "d" [ h; m; s ]) 49 | d 50 | (pp_with_suffix "h" [ m; s ]) 51 | h 52 | (pp_with_suffix "m" [ s ]) 53 | m 54 | (pp_seconds [ d; h; m ]) 55 | s 56 | ;; 57 | 58 | let add a b = Int64.add a b 59 | let zero = Int64.zero 60 | let sub a b = Int64.sub a b 61 | let bound_positive x = Int64.max x zero 62 | 63 | module Query = struct end 64 | -------------------------------------------------------------------------------- /lib/rensai/parser.mly: -------------------------------------------------------------------------------- 1 | %token EOF 2 | %token INT 3 | %token INT32 4 | %token INT64 5 | %token FLOAT 6 | %token CHAR 7 | %token STRING 8 | %token ATOM 9 | %token TRUE 10 | %token FALSE 11 | %token NULL 12 | %token OPEN_OBJ 13 | %token CLOSE_OBJ 14 | %token OPEN_LIST 15 | %token CLOSE_LIST 16 | %token OPEN_PARENS 17 | %token CLOSE_PARENS 18 | %token COLON 19 | %token SEMICOLON 20 | %token COMMA 21 | %token HASH 22 | %start main 23 | %% 24 | 25 | main: 26 | | v = value { Some v } 27 | | EOF { None } 28 | ; 29 | 30 | value: 31 | | i = INT32 { Ast.int32 i } 32 | | i = INT64 { Ast.int64 i } 33 | | i = INT { Ast.int i } 34 | | f = FLOAT { Ast.float f } 35 | | c = CHAR { Ast.char c } 36 | | s = STRING { Ast.string s } 37 | | TRUE { Ast.bool true } 38 | | FALSE { Ast.bool false } 39 | | NULL { Ast.null () } 40 | | OPEN_PARENS; CLOSE_PARENS { Ast.unit () } 41 | | OPEN_OBJ; obj = obj_fields; CLOSE_OBJ { Ast.record obj } 42 | | OPEN_LIST; l = list_fields; CLOSE_LIST { Ast.hlist l } 43 | | HASH; k = ATOM; OPEN_PARENS v = value; CLOSE_PARENS { Ast.lconstr k v } 44 | | OPEN_PARENS; a = value; COMMA; b = value; CLOSE_PARENS { Ast.lpair a b } 45 | ; 46 | 47 | obj_fields: 48 | | obj = separated_list(SEMICOLON, obj_field) { obj } 49 | ; 50 | 51 | obj_field: 52 | | k = ATOM; COLON; v = value { (k, v) } 53 | ; 54 | 55 | list_fields: 56 | | v = separated_list(COMMA, value) { v } 57 | ; 58 | -------------------------------------------------------------------------------- /site-lisp/kohai-buffer.el: -------------------------------------------------------------------------------- 1 | ;;; kohai-buffer.el --- Buffer helpers for Kohai -*- coding: utf-8; lexical-binding: t -*- 2 | 3 | ;; Copyright (C) since 2025 Xavier Van de Woestyne 4 | ;; Licensed under the MIT license. 5 | 6 | ;; Author: Xavier Van de Woestyne 7 | 8 | ;; This file is NOT part of GNU Emac 9 | 10 | ;; Maintainer: Xavier Van de Woestyne 11 | ;; Created: 13 February 2025 12 | ;; Keywords: tool timetracker productivity 13 | ;; URL: https://github.com/xvw/kohai 14 | ;; Package-Requires: ((emacs "29.1")) 15 | ;; Package-Version: 0.1 16 | ;; SPDX-License-Identifier: MIT 17 | 18 | ;;; Commentary: 19 | 20 | ;; Buffer manipulatio 21 | 22 | ;;; Code: 23 | 24 | (defun kohai-buffer--truncate-with (buffer-name &optional action) 25 | "Truncate and fill buffer BUFFER-NAME and perform ACTION (if non nil)." 26 | (let ((buff (get-buffer-create buffer-name))) 27 | (with-current-buffer buff 28 | (setq buffer-read-only nil) 29 | (erase-buffer) 30 | (goto-char 1) 31 | (when action (funcall action buff)) 32 | (setq buffer-read-only t)))) 33 | 34 | (defun kohai-buffer--empty (buffer-name &optional close) 35 | "Truncate a given BUFFER-NAME. If CLOSE is given, the buffer will be closed." 36 | (kohai-buffer--truncate-with 37 | buffer-name (lambda (buff) 38 | (when close (kill-buffer buff))))) 39 | 40 | (defun kohai-buffer--with (buffer-name &optional action) 41 | "Switch to truncated BUFFER-NAME and perform ACTION (if non nil)." 42 | (let ((buff (get-buffer-create buffer-name))) 43 | (kohai-buffer--truncate-with buffer-name action) 44 | (pop-to-buffer buff))) 45 | 46 | (defun kohai-buffer--kill (buffer-name) 47 | "Kill BUFFER-NAME if it exists." 48 | (when (get-buffer buffer-name) 49 | (kill-buffer buffer-name))) 50 | 51 | (provide 'kohai-buffer) 52 | ;;; kohai-buffer.el ends here 53 | 54 | -------------------------------------------------------------------------------- /lib/server/server.ml: -------------------------------------------------------------------------------- 1 | let rensai obj = 2 | let s = obj |> Rensai.Json.to_yojson |> Yojson.Safe.to_string in 3 | let len = String.length s in 4 | "Content-Length: " ^ string_of_int len ^ "\r\n\r\n" ^ s 5 | ;; 6 | 7 | let rensai_error message = 8 | let obj = Error.unknown_error ~message () in 9 | rensai (obj |> Error.custom_to_jsonrpc ~body:"null" |> Error.to_rensai) 10 | ;; 11 | 12 | let handler (module H : Eff.HANDLER) body = 13 | match Jsonrpc.run (module H) ~services:Services.all body with 14 | | Ok result -> rensai result 15 | | Error err -> rensai (Error.to_rensai err) 16 | ;; 17 | 18 | let parse p flow ~max_size = 19 | let buf = Eio.Buf_read.of_flow flow ~max_size in 20 | Eio.Buf_read.format_errors p buf 21 | ;; 22 | 23 | let input_parser = 24 | let open Eio.Buf_read.Syntax in 25 | let* () = Eio.Buf_read.string "Content-Length: " in 26 | let* len = 27 | Eio.Buf_read.take_while (function 28 | | '0' .. '9' -> true 29 | | _ -> false) 30 | in 31 | let len = 32 | match int_of_string_opt len with 33 | | Some len -> len 34 | | None -> failwith ("Invalid length " ^ len) 35 | in 36 | let* _ = Eio.Buf_read.char '\r' in 37 | let* _ = Eio.Buf_read.char '\n' in 38 | let* _ = Eio.Buf_read.char '\r' in 39 | let* _ = Eio.Buf_read.char '\n' in 40 | Eio.Buf_read.take len 41 | ;; 42 | 43 | let run (module H : Eff.HANDLER) env = 44 | let stdin = Eio.Stdenv.stdin env in 45 | let stdout = Eio.Stdenv.stdout env in 46 | let rec aux () = 47 | let () = 48 | match parse ~max_size:1024 input_parser stdin with 49 | | Ok res -> 50 | let r = handler (module H) res in 51 | Eio.Buf_write.with_flow stdout (fun w -> Eio.Buf_write.string w r) 52 | | Error (`Msg message) -> 53 | let error = rensai_error message in 54 | Eio.Buf_write.with_flow stdout (fun w -> Eio.Buf_write.string w error) 55 | in 56 | aux () 57 | in 58 | aux () 59 | ;; 60 | -------------------------------------------------------------------------------- /.github/workflows/test-ocaml-ci.yml: -------------------------------------------------------------------------------- 1 | name: Test 2 | on: 3 | push: 4 | branches: [ main ] 5 | paths-ignore: 6 | - '**.md' 7 | - '**.el' 8 | - 'media/**' 9 | pull_request: 10 | branches: [ main ] 11 | paths-ignore: 12 | - '**.md' 13 | - '**.el' 14 | - 'media/**' 15 | 16 | jobs: 17 | 18 | build-and-test: 19 | strategy: 20 | fail-fast: true 21 | matrix: 22 | os: [ ubuntu-latest ] 23 | ocaml-compiler: [ ocaml-base-compiler.5.3.0 ] 24 | runs-on: ${{ matrix.os }} 25 | 26 | steps: 27 | - name: Checkout Tree 28 | uses: actions/checkout@v4 29 | 30 | - name: Set-up OCaml 31 | uses: ocaml/setup-ocaml@v3 32 | with: 33 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 34 | 35 | - run: opam install . --deps-only --with-test 36 | - run: opam exec -- dune build 37 | - run: opam exec -- dune runtest 38 | 39 | lint-doc: 40 | strategy: 41 | fail-fast: true 42 | matrix: 43 | os: [ ubuntu-latest ] 44 | ocaml-compiler: [ ocaml-base-compiler.5.3.0 ] 45 | runs-on: ${{ matrix.os }} 46 | 47 | steps: 48 | - name: Checkout Tree 49 | uses: actions/checkout@v4 50 | 51 | - name: Set-up OCaml 52 | uses: ocaml/setup-ocaml@v3 53 | with: 54 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 55 | - uses: ocaml/setup-ocaml/lint-doc@v3 56 | 57 | lint-fmt: 58 | strategy: 59 | fail-fast: true 60 | matrix: 61 | os: [ ubuntu-latest ] 62 | ocaml-compiler: [ ocaml-base-compiler.5.3.0 ] 63 | runs-on: ${{ matrix.os }} 64 | 65 | steps: 66 | - name: Checkout Tree 67 | uses: actions/checkout@v4 68 | 69 | - name: Set-up OCaml 70 | uses: ocaml/setup-ocaml@v3 71 | with: 72 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 73 | - uses: ocaml/setup-ocaml/lint-fmt@v3 74 | -------------------------------------------------------------------------------- /lib/yocaml_kohai/log.ml: -------------------------------------------------------------------------------- 1 | type t = Kohai_model.Log.t 2 | 3 | let entity_name = "Kohai.Log" 4 | let neutral = Yocaml.Metadata.required entity_name 5 | 6 | let validate = 7 | let open Yocaml.Data.Validation in 8 | record (fun f -> 9 | let+ start_date = required f "start_date" Datetime.validate 10 | and+ duration = required f "duration" Duration.validate 11 | and+ project = optional f "project" string 12 | and+ sector = required f "sector" string 13 | and+ label = required f "label" string 14 | and+ meta = 15 | optional_or 16 | ~default:(Kohai_model.Key_value.empty ()) 17 | f 18 | "meta" 19 | (Key_value.validate string) 20 | and+ links = 21 | optional_or 22 | ~default:(Kohai_model.Key_value.empty ()) 23 | f 24 | "links" 25 | (Key_value.validate Url.validate) 26 | and+ id = required f "id" Uuid.validate in 27 | Kohai_model.Log.make 28 | ~start_date 29 | ~duration 30 | ?project 31 | ~sector 32 | ~label 33 | ~meta 34 | ~links 35 | ~id 36 | ()) 37 | ;; 38 | 39 | let normalize log = 40 | let open Yocaml.Data in 41 | let s, p = Kohai_model.Log.sector_and_project log 42 | and meta = Kohai_model.Log.meta log 43 | and links = Kohai_model.Log.links log in 44 | record 45 | [ "start_date", Datetime.normalize (Kohai_model.Log.start_date log) 46 | ; "end_date", Datetime.normalize (Kohai_model.Log.end_date log) 47 | ; "duration", Duration.normalize (Kohai_model.Log.duration log) 48 | ; "project", option string p 49 | ; "sector", string s 50 | ; "label", string (Kohai_model.Log.label log) 51 | ; "meta", Key_value.normalize string meta 52 | ; "links", Key_value.normalize Url.normalize links 53 | ; "has_project", bool @@ Option.is_some p 54 | ; "has_meta", bool @@ not (Kohai_model.Key_value.is_empty meta) 55 | ; "has_links", bool @@ not (Kohai_model.Key_value.is_empty links) 56 | ] 57 | ;; 58 | -------------------------------------------------------------------------------- /lib/rensai/lang.ml: -------------------------------------------------------------------------------- 1 | let from_string str = 2 | try str |> Lexing.from_string |> Parser.main Lexer.read with 3 | | _ -> None 4 | ;; 5 | 6 | let from_lexingbuf lexing_buf = 7 | try lexing_buf |> Parser.main Lexer.read with 8 | | _ -> None 9 | ;; 10 | 11 | let from_lexingbuf_or_null lexing_buf = 12 | lexing_buf |> from_lexingbuf |> Option.fold ~some:Fun.id ~none:(Ast.null ()) 13 | ;; 14 | 15 | let from_lexingbuf_to_list ?(reverse = false) lexing_buf = 16 | let rec aux acc = 17 | match from_lexingbuf lexing_buf with 18 | | None -> acc 19 | | Some x -> aux (x :: acc) 20 | in 21 | let result = aux [] in 22 | if reverse then List.rev result else result 23 | ;; 24 | 25 | let surround s1 s2 pp_v ppf v = 26 | Format.( 27 | pp_print_string ppf s1; 28 | pp_v ppf v; 29 | pp_print_string ppf s2) 30 | ;; 31 | 32 | let obj pp_v = Fmt.box ~indent:1 (surround "<" ">" pp_v) 33 | 34 | let rec pp st = function 35 | | Ast.Null -> Fmt.pf st "null" 36 | | Ast.Unit -> Fmt.pf st "()" 37 | | Ast.Bool x -> Fmt.bool st x 38 | | Ast.Int x -> Fmt.int st x 39 | | Ast.Int32 x -> Fmt.int32 st x 40 | | Ast.Int64 x -> Fmt.int64 st x 41 | | Ast.Float x -> Fmt.float st x 42 | | Ast.Char x -> Fmt.pf st "'%a'" Fmt.char x 43 | | Ast.String x -> Fmt.pf st "\"%a\"" Fmt.string x 44 | | Ast.Pair (a, b) -> Fmt.Dump.pair pp pp st (a, b) 45 | | Ast.List xs -> Fmt.brackets (Fmt.list ~sep:Fmt.comma (Fmt.box pp)) st xs 46 | | Ast.Constr (k, v) -> Fmt.pf st "#%s%a" k (Fmt.parens pp) v 47 | | Ast.Record record -> 48 | let fields = 49 | Fmt.list ~sep:(Fmt.any ";@, ") (fun st (k, v) -> 50 | Fmt.pf st "@[<1>%s:@ %a@]" k pp v) 51 | in 52 | let fields = Fmt.using Ast.record_to_assoc fields in 53 | (Fmt.box ~indent:2 (obj fields)) st record 54 | ;; 55 | 56 | let dump to_rensai elt = elt |> to_rensai |> Format.asprintf "%a" pp 57 | 58 | let dump_list to_rensai list = 59 | list 60 | |> List.map (fun elt -> Format.asprintf "%a" pp (to_rensai elt)) 61 | |> String.concat "\n" 62 | ;; 63 | -------------------------------------------------------------------------------- /site-lisp/kohai-sector.el: -------------------------------------------------------------------------------- 1 | ;;; kohai-sector.el --- Deal with sectors -*- coding: utf-8; lexical-binding: t -*- 2 | 3 | ;; Copyright (C) since 2025 Xavier Van de Woestyne 4 | ;; Licensed under the MIT license. 5 | 6 | ;; Author: Xavier Van de Woestyne 7 | 8 | ;; This file is NOT part of GNU Emac 9 | 10 | ;; Maintainer: Xavier Van de Woestyne 11 | ;; Created: 13 February 2025 12 | ;; Keywords: tool timetracker productivity 13 | ;; URL: https://github.com/xvw/kohai 14 | ;; Package-Requires: ((emacs "29.1")) 15 | ;; Package-Version: 0.1 16 | ;; SPDX-License-Identifier: MIT 17 | 18 | ;;; Commentary: 19 | 20 | ;; Interaction with sectors 21 | 22 | ;;; Code: 23 | 24 | (require 'kohai-core) 25 | (require 'kohai-generic) 26 | 27 | (defun kohai-sector--ac (&optional sectors not-empty default) 28 | "Get SECTORS as a completion list. 29 | If NOT-EMPTY the list must be filled. DEFAULT is the default value." 30 | (kohai-generic--ditem-ac "sector" 31 | sectors 32 | not-empty 33 | default)) 34 | 35 | 36 | (defun kohai-sector--list (&optional given-sectors) 37 | "Return the list of sectors (or GIVEN-SECTORS)." 38 | (kohai-generic--ditem-list "sector" 39 | kohai-sectors-buffer-name 40 | given-sectors)) 41 | 42 | (defun kohai-sector--save (name desc) 43 | "Smartly save a sector (with NAME and DESC)." 44 | (kohai-generic--ditem-save "sector" 45 | kohai-sectors-buffer-name 46 | name desc)) 47 | 48 | (defun kohai-sector--update-desc (name) 49 | "Update the description of a sector by his NAME." 50 | (kohai-generic--ditem-update-desc "sector" 51 | kohai-sectors-buffer-name 52 | name)) 53 | 54 | (defun kohai-sector--new () 55 | "Prompt a sector's save procedure" 56 | (kohai-generic--ditem-new "sector" kohai-sectors-buffer-name)) 57 | 58 | 59 | (provide 'kohai-sector) 60 | ;;; kohai-sector.el ends here 61 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.17) 2 | (name kohai) 3 | (version dev) 4 | (generate_opam_files true) 5 | (executables_implicit_empty_intf) 6 | (using menhir 3.0) 7 | (using mdx 0.4) 8 | 9 | (source (github xvw/kohai)) 10 | (license MIT) 11 | (authors "Xavier Van de Woestyne ") 12 | (maintainers "Xavier Van de Woestyne ") 13 | 14 | (package 15 | (name rensai) 16 | (synopsis "Rensai can be used to describe generic encoders and decoders") 17 | (description 18 | "By lifting heterogeneous data into a finite set of constructors, 19 | it is possible to describe languages similar to JSON, TOML or 20 | S-Expression, for which the encoding and validation functions 21 | become generic (and interchangeable).") 22 | (depends 23 | (ocaml (>= 5.3.0)) 24 | menhir 25 | (yojson (>= 3.0.0)) 26 | (fmt (>= 0.9.0)) 27 | ppx_expect 28 | (mdx :with-test))) 29 | 30 | (package 31 | (name kohai) 32 | (allow_empty) 33 | (synopsis "A small hand-crafted tool for recording activities") 34 | (description 35 | "A tool for collecting personal activity reports (and an excuse 36 | to write OCaml and reinvent the wheel)") 37 | (depends 38 | (ocaml (>= 5.3.0)) 39 | re 40 | uri 41 | uuidm 42 | (rensai (= :version)) 43 | ppx_expect 44 | (mdx :with-test) 45 | (yojson (>= 3.0.0)) 46 | (fmt (>= 0.9.0)) 47 | (logs (>= 0.7.0)) 48 | (cmdliner (>= 1.3.0)) 49 | (eio (>= 1.1)) 50 | (eio_main (>= 1.1)) 51 | (ocamlformat :with-dev-setup) 52 | (ocp-indent :with-dev-setup) 53 | (merlin :with-dev-setup) 54 | (ocaml-lsp-server :with-dev-setup) 55 | (utop :with-dev-setup))) 56 | 57 | 58 | (package 59 | (name yocaml_rensai) 60 | (synopsis "Inject and Read from Rensai to YOCaml") 61 | (description "Use Rensai as a Metadata language for YOCaml") 62 | (depends 63 | (rensai (= :version)) 64 | (yocaml (>= 2.0.0)))) 65 | 66 | (package 67 | (name yocaml_kohai) 68 | (synopsis "Convert Kohai object as YOCaml object") 69 | (description "Kohai object available as YOCaml object for web reporting") 70 | (depends 71 | (rensai (= :version)) 72 | (kohai (= :version)) 73 | (yocaml_rensai (= :version)) 74 | (yocaml (>= 2.0.0)))) 75 | -------------------------------------------------------------------------------- /lib/rensai/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Lexing 3 | open Parser 4 | 5 | exception Syntax_error of string 6 | } 7 | 8 | let int = '-'? ['0'-'9'] ['0'-'9']* 9 | let int32 = '-'? ['0'-'9'] ['0'-'9']* 'l' 10 | let int64 = '-'? ['0'-'9'] ['0'-'9']* 'L' 11 | let white = [' ' '\t']+ 12 | let newline = '\r' | '\n' | "\r\n" 13 | let id = ['a'-'z' 'A'-'Z' '_'] ['a'-'z' 'A'-'Z' '0'-'9' '_']* 14 | let digit = ['0'-'9'] 15 | let frac = '.' digit* 16 | let exp = ['e' 'E'] ['-' '+']? digit+ 17 | let float = digit* frac? exp? 18 | 19 | rule read = parse 20 | | white { read lexbuf } 21 | | newline { new_line lexbuf; read lexbuf } 22 | | int { INT (int_of_string (lexeme lexbuf)) } 23 | | int32 { INT32 (Int32.of_string (lexeme lexbuf)) } 24 | | int64 { INT64 (Int64.of_string (lexeme lexbuf)) } 25 | | float { FLOAT (float_of_string (lexeme lexbuf)) } 26 | | "null" { NULL } 27 | | "true" { TRUE } 28 | | "false" { FALSE } 29 | | "#" { HASH } 30 | | "[" { OPEN_LIST } 31 | | "]" { CLOSE_LIST } 32 | | "(" { OPEN_PARENS } 33 | | ")" { CLOSE_PARENS } 34 | | "<" { OPEN_OBJ } 35 | | ">" { CLOSE_OBJ } 36 | | ":" { COLON } 37 | | ";" { SEMICOLON } 38 | | "," { COMMA } 39 | | "'" [^ '\\'] "'" { CHAR (lexeme_char lexbuf 1) } 40 | | '"' { read_string (Buffer.create 17) lexbuf } 41 | | ['a'-'z' 'A'-'Z' '0'-'9' '\'' '_' '.']+ as w { ATOM w } 42 | | eof { EOF } 43 | 44 | and read_string buf = parse 45 | | '"' { STRING (Buffer.contents buf) } 46 | | '\\' '/' { Buffer.add_char buf '/'; read_string buf lexbuf } 47 | | '\\' '\\' { Buffer.add_char buf '\\'; read_string buf lexbuf } 48 | | '\\' 'b' { Buffer.add_char buf '\b'; read_string buf lexbuf } 49 | | '\\' 'f' { Buffer.add_char buf '\012'; read_string buf lexbuf } 50 | | '\\' 'n' { Buffer.add_char buf '\n'; read_string buf lexbuf } 51 | | '\\' 'r' { Buffer.add_char buf '\r'; read_string buf lexbuf } 52 | | '\\' 't' { Buffer.add_char buf '\t'; read_string buf lexbuf } 53 | | [^ '"' '\\']+ 54 | { Buffer.add_string buf (Lexing.lexeme lexbuf); 55 | read_string buf lexbuf 56 | } 57 | | _ { raise (Syntax_error 58 | ("Illegal string character: " ^ Lexing.lexeme lexbuf)) } 59 | | eof { raise (Syntax_error ("String is not terminated")) } -------------------------------------------------------------------------------- /lib/server/jsonrpc.ml: -------------------------------------------------------------------------------- 1 | type service = 2 | | Handler : 3 | 'a Rensai.Validation.t 4 | * (Kohai_model.Context.t -> 'b Rensai.Ast.conv) 5 | * ((module Eff.HANDLER) -> Kohai_model.Context.t -> 'a -> 'b) 6 | -> service 7 | 8 | let validate_request_body = 9 | let open Rensai.Validation in 10 | record (fun e -> 11 | let open Record in 12 | let+ () = ensure e "jsonrpc" (string & String.equal "2.0") 13 | and+ meth = required e "method" (string & String.is_not_blank) 14 | and+ id = optional e "id" int 15 | and+ params = optional_or ~default:(Rensai.Ast.null ()) e "params" ast in 16 | meth, id, params) 17 | ;; 18 | 19 | let service ~meth ~with_params ~finalizer callback = 20 | meth, Handler (with_params, finalizer, callback) 21 | ;; 22 | 23 | let from_response body = 24 | try 25 | body 26 | |> Yojson.Safe.from_string 27 | |> Rensai.Json.from_yojson 28 | |> validate_request_body 29 | |> Result.map_error (fun error -> Error.invalid_request ~body ~error ()) 30 | with 31 | | _ -> Error (Error.parse_error ~body ()) 32 | ;; 33 | 34 | let succeed ?id value = 35 | let open Rensai.Ast in 36 | record [ "jsonrpc", string "2.0"; "id", option int id; "result", value ] 37 | ;; 38 | 39 | let run (module H : Eff.HANDLER) ~services body = 40 | match from_response body with 41 | | Error err -> Error err 42 | | Ok (meth, id, params) -> 43 | (match List.assoc_opt meth services with 44 | | None -> Error (Error.method_not_found ~body ?id ~meth ()) 45 | | Some (Handler (validator, finalizer, controller)) -> 46 | (try 47 | match validator params with 48 | | Error error -> Error (Error.invalid_params ~body ?id ~error ()) 49 | | Ok params -> 50 | Eff.handle 51 | (module H) 52 | (fun (module H) -> 53 | let now = Eff.now (module H) in 54 | let context = Kohai_model.Context.make ~now in 55 | let result = controller (module H) context params in 56 | context, result) 57 | |> Result.map (fun (context, result) -> 58 | result |> finalizer context |> succeed ?id) 59 | |> Result.map_error (fun err -> 60 | Error.custom_to_jsonrpc ~body ?id err) 61 | with 62 | | H.Handler_exn err -> Error (Error.custom_to_jsonrpc ~body ?id err))) 63 | ;; 64 | -------------------------------------------------------------------------------- /test/rensai/random_test.ml: -------------------------------------------------------------------------------- 1 | let as_int64 x = Scanf.sscanf_opt x "%LdL%!" (fun x -> Int64.to_string x) 2 | let as_int32 x = Scanf.sscanf_opt x "%ldl%!" (fun x -> Int32.to_string x) 3 | let as_int x = Scanf.sscanf_opt x "%d%!" (fun x -> Int.to_string x) 4 | 5 | let print = function 6 | | None -> print_endline "none" 7 | | Some x -> print_endline @@ "some " ^ x 8 | ;; 9 | 10 | let%expect_test "test string from number (int64) - 1" = 11 | print @@ as_int64 "123L"; 12 | [%expect {| some 123 |}] 13 | ;; 14 | 15 | let%expect_test "test string from number (int32) - 1" = 16 | print @@ as_int32 "123l"; 17 | [%expect {| some 123 |}] 18 | ;; 19 | 20 | let%expect_test "test string from number (int) - 1" = 21 | print @@ as_int "123"; 22 | [%expect {| some 123 |}] 23 | ;; 24 | 25 | let%expect_test "test string from number (int64) - 2" = 26 | print @@ as_int64 "+123L"; 27 | [%expect {| some 123 |}] 28 | ;; 29 | 30 | let%expect_test "test string from number (int32) - 2" = 31 | print @@ as_int32 "+123l"; 32 | [%expect {| some 123 |}] 33 | ;; 34 | 35 | let%expect_test "test string from number (int) - 2" = 36 | print @@ as_int "-123"; 37 | [%expect {| some -123 |}] 38 | ;; 39 | 40 | let%expect_test "test string from number (int64) - 3" = 41 | print @@ as_int64 "-123L"; 42 | [%expect {| some -123 |}] 43 | ;; 44 | 45 | let%expect_test "test string from number (int32) - 3" = 46 | print @@ as_int32 "-123l"; 47 | [%expect {| some -123 |}] 48 | ;; 49 | 50 | let%expect_test "test string from number (int) - 3" = 51 | print @@ as_int "-123"; 52 | [%expect {| some -123 |}] 53 | ;; 54 | 55 | let%expect_test "test string from number (int64) - 4" = 56 | print @@ as_int64 "-123Lsdasd"; 57 | [%expect {| none |}] 58 | ;; 59 | 60 | let%expect_test "test string from number (int32) - 4" = 61 | print @@ as_int32 "-123lsad"; 62 | [%expect {| none |}] 63 | ;; 64 | 65 | let%expect_test "test string from number (int) - 4" = 66 | print @@ as_int "-123asdsad"; 67 | [%expect {| none |}] 68 | ;; 69 | 70 | let%expect_test "test string from number (int64) - 5" = 71 | print @@ as_int64 "daasdsad"; 72 | [%expect {| none |}] 73 | ;; 74 | 75 | let%expect_test "test string from number (int32) - 5" = 76 | print @@ as_int32 "asdsadsads"; 77 | [%expect {| none |}] 78 | ;; 79 | 80 | let%expect_test "test string from number (int) - 5" = 81 | print @@ as_int "asdsadsad"; 82 | [%expect {| none |}] 83 | ;; 84 | -------------------------------------------------------------------------------- /site-lisp/kohai-project.el: -------------------------------------------------------------------------------- 1 | ;;; kohai-project.el --- Deal with projects -*- coding: utf-8; lexical-binding: t -*- 2 | 3 | ;; Copyright (C) since 2025 Xavier Van de Woestyne 4 | ;; Licensed under the MIT license. 5 | 6 | ;; Author: Xavier Van de Woestyne 7 | 8 | ;; This file is NOT part of GNU Emac 9 | 10 | ;; Maintainer: Xavier Van de Woestyne 11 | ;; Created: 13 February 2025 12 | ;; Keywords: tool timetracker productivity 13 | ;; URL: https://github.com/xvw/kohai 14 | ;; Package-Requires: ((emacs "29.1")) 15 | ;; Package-Version: 0.1 16 | ;; SPDX-License-Identifier: MIT 17 | 18 | ;;; Commentary: 19 | 20 | ;; Interaction with projects 21 | 22 | ;;; Code: 23 | 24 | (require 'kohai-core) 25 | (require 'kohai-generic) 26 | 27 | (defun kohai-project--ac (&optional projects not-empty default) 28 | "Get PROJECTS as a completion list. 29 | If NOT-EMPTY the list must be filled. DEFAULT is the default value." 30 | (let* ((no-project (make-vector 31 | 1 (list :name "none" :description "Nothing"))) 32 | (projects (or projects (kohai-req--project-list))) 33 | (full-projects (if (not not-empty) (vconcat no-project projects) 34 | projects))) 35 | (print full-projects) 36 | (let ((result 37 | (kohai-generic--ditem-ac "project" 38 | full-projects 39 | not-empty 40 | default))) 41 | (if (string= result "none") nil result)))) 42 | 43 | 44 | (defun kohai-project--list (&optional given-projects) 45 | "Return the list of projects (or GIVEN-PROJECTS)." 46 | (kohai-generic--ditem-list "project" 47 | kohai-projects-buffer-name 48 | given-projects)) 49 | 50 | (defun kohai-project--save (name desc) 51 | "Smartly save a project (with NAME and DESC)." 52 | (kohai-generic--ditem-save "project" 53 | kohai-projects-buffer-name 54 | name desc)) 55 | 56 | (defun kohai-project--update-desc (name) 57 | "Update the description of a project by his NAME." 58 | (kohai-generic--ditem-update-desc "project" 59 | kohai-projects-buffer-name 60 | name)) 61 | 62 | (defun kohai-project--new () 63 | "Prompt a project's save procedure" 64 | (kohai-generic--ditem-new "project" kohai-projects-buffer-name)) 65 | 66 | (provide 'kohai-project) 67 | ;;; kohai-project.el ends here 68 | -------------------------------------------------------------------------------- /lib/model/log.mli: -------------------------------------------------------------------------------- 1 | (** Represents a stored log (non-transient). *) 2 | 3 | (** Type describing a log. *) 4 | type t 5 | 6 | (** Build a log. *) 7 | val make 8 | : start_date:Datetime.t 9 | -> duration:Duration.t 10 | -> ?project:string 11 | -> sector:string 12 | -> label:string 13 | -> ?meta:string Key_value.t 14 | -> ?links:Url.t Key_value.t 15 | -> id:Uuid.t 16 | -> unit 17 | -> t 18 | 19 | (** Convert a log into a transient one. *) 20 | val from_transient_log : Transient_log.t -> t option 21 | 22 | val to_transient_log : t -> Transient_log.t 23 | 24 | (** Return the ID of a log. *) 25 | val id : t -> Uuid.t 26 | 27 | (** Return the start date of a log. *) 28 | val start_date : t -> Datetime.t 29 | 30 | (** Return the end date of a log. *) 31 | val end_date : t -> Datetime.t 32 | 33 | (** Return the duration of a log. *) 34 | val duration : t -> Duration.t 35 | 36 | val label : t -> string 37 | val meta : t -> string Key_value.t 38 | val links : t -> Url.t Key_value.t 39 | 40 | (** Validate a log from a rensai expression. *) 41 | val from_rensai : t Rensai.Validation.t 42 | 43 | (** Serialize a log result. *) 44 | val return_rensai : (Datetime.t * t) Rensai.Ast.conv 45 | 46 | (** Serialize a log with relative date. *) 47 | val list_to_rensai : (Datetime.t * t list) Rensai.Ast.conv 48 | 49 | (** Lift a log into a dumpable rensai expression. *) 50 | val to_rensai : t -> Rensai.Ast.t 51 | 52 | val from_file_content : (string, t) Rensai.Validation.v 53 | 54 | (** Find the relevant file for a log. *) 55 | val find_file_by_month : cwd:Path.t -> t -> Path.t 56 | 57 | (** Find the file of the log. *) 58 | val find_file : cwd:Path.t -> t -> Path.t 59 | 60 | (** Create an ordered set of logs. *) 61 | val truncate_list : ?len:int -> t -> t list -> Uuid.Set.t 62 | 63 | (** Retreive sector and project. *) 64 | val sector_and_project : t -> string * string option 65 | 66 | (** sort a list of log by date. *) 67 | val sort : t list -> t list 68 | 69 | (** Add complementary metadata. *) 70 | val add_meta : key:string -> value:string -> t -> t 71 | 72 | (** Remove complementary metadata. *) 73 | val remove_meta : key:string -> t -> t 74 | 75 | (** Add complementary link. *) 76 | val add_link : key:string -> value:Url.t -> t -> t 77 | 78 | (** Remove complementary link. *) 79 | val remove_link : key:string -> t -> t 80 | 81 | (** {1 Result as a call-API} *) 82 | 83 | module Expanded : sig 84 | val as_list : Context.t -> t list Rensai.Ast.conv 85 | val as_single : Context.t -> t Rensai.Ast.conv 86 | val as_option : Context.t -> t option Rensai.Ast.conv 87 | end 88 | -------------------------------------------------------------------------------- /lib/core/eff.ml: -------------------------------------------------------------------------------- 1 | module type HANDLER = Sigs.EFFECT_HANDLER 2 | 3 | type handler = (module HANDLER) 4 | 5 | module Handler (R : Sigs.EFFECT_REQUIREMENT) : HANDLER = struct 6 | include R 7 | 8 | exception Handler_exn of Error.custom 9 | 10 | let raise error = raise (Handler_exn error) 11 | 12 | let handle_with_error program = 13 | try Ok (program ()) with 14 | | Handler_exn error -> Error error 15 | | exn -> Error (Error.unknown_error ~message:(Printexc.to_string exn) ()) 16 | ;; 17 | end 18 | 19 | let raise (module H : HANDLER) error = H.raise error 20 | 21 | let set_supervised_directory (module H : HANDLER) potential_path = 22 | H.set_supervised_directory potential_path 23 | ;; 24 | 25 | let get_supervised_directory (module H : HANDLER) = 26 | H.get_supervised_directory () 27 | ;; 28 | 29 | let from_result (module H : HANDLER) callback = function 30 | | Ok x -> x 31 | | Error err -> raise (module H) (callback err) 32 | ;; 33 | 34 | let exists (module H : HANDLER) path = H.exists path 35 | let is_file (module H : HANDLER) path = H.is_file path 36 | let is_dir (module H : HANDLER) path = H.is_dir path 37 | let read_file (module H : HANDLER) path = H.read_file path 38 | 39 | let create_dir (module H : HANDLER) path = 40 | let rec aux path = 41 | if is_file (module H) path 42 | then () 43 | else if not (is_dir (module H) path) 44 | then ( 45 | let () = 46 | match Path.parent path with 47 | | None -> () 48 | | Some parent -> aux parent 49 | in 50 | H.create_dir path) 51 | else () 52 | in 53 | aux path 54 | ;; 55 | 56 | let write_file (module H : HANDLER) path content = 57 | match Path.parent path with 58 | | Some parent -> 59 | let () = create_dir (module H) parent in 60 | H.write_file path content 61 | | None -> H.write_file path content 62 | ;; 63 | 64 | let append_to_file (module H : HANDLER) path content = 65 | match Path.parent path with 66 | | Some parent -> 67 | let () = create_dir (module H) parent in 68 | H.append_to_file path content 69 | | None -> H.append_to_file path content 70 | ;; 71 | 72 | let now (module H : HANDLER) = 73 | let time = H.now () in 74 | time 75 | |> H.datetime_from_float 76 | |> from_result (module H) (Error.invalid_datetime time) 77 | ;; 78 | 79 | let delete (module H : HANDLER) path = 80 | if is_dir (module H) path 81 | then H.delete_dir ~recursive:true path 82 | else H.delete_file path 83 | ;; 84 | 85 | let handle (module H : HANDLER) program = 86 | let program () = program (module H : HANDLER) in 87 | H.handle_with_error program 88 | ;; 89 | -------------------------------------------------------------------------------- /lib/model/url.ml: -------------------------------------------------------------------------------- 1 | type scheme = 2 | | Http 3 | | Https 4 | | Ftp 5 | | Gemini 6 | | Other of string 7 | 8 | type t = 9 | { scheme : scheme 10 | ; host : string 11 | ; path : Path.t 12 | ; port : int option 13 | ; query : string list Key_value.t 14 | ; uri : Uri.t 15 | } 16 | 17 | let uri_to_rensai uri = 18 | let open Rensai.Ast in 19 | record 20 | [ "scheme", option string (uri |> Uri.scheme) 21 | ; "host", option string (uri |> Uri.host) 22 | ; "port", option int (uri |> Uri.port) 23 | ; "path", string (uri |> Uri.path) 24 | ; "query", list (pair string (list string)) (uri |> Uri.query) 25 | ] 26 | ;; 27 | 28 | let validate_scheme = function 29 | | "http" -> Http 30 | | "https" -> Https 31 | | "ftp" -> Ftp 32 | | "gemini" -> Gemini 33 | | x -> Other x 34 | ;; 35 | 36 | let make ~uri ~scheme ~port ~host ~query ~path () = 37 | { uri; scheme; port; host; query; path } 38 | ;; 39 | 40 | let from_string s = 41 | let uri = Uri.of_string s in 42 | let open Rensai.Validation in 43 | uri 44 | |> uri_to_rensai 45 | |> record (fun fields -> 46 | let open Record in 47 | let+ scheme = 48 | required 49 | fields 50 | "scheme" 51 | (string & String.is_not_blank & String.downcase $ validate_scheme) 52 | and+ host = required fields "host" (string & String.is_not_blank) 53 | and+ query = 54 | optional_or 55 | ~default:(Key_value.empty ()) 56 | fields 57 | "query" 58 | (Key_value.from_rensai (list_of string)) 59 | and+ port = optional fields "port" (int & Int.is_positive & Int.is_not_null) 60 | and+ path = required fields "path" Path.from_rensai in 61 | { uri; scheme; port; host; query; path }) 62 | ;; 63 | 64 | let from_rensai = Rensai.Validation.(string & from_string) 65 | 66 | let scheme_to_string = function 67 | | Http -> "http" 68 | | Https -> "https" 69 | | Ftp -> "ftp" 70 | | Gemini -> "gemini" 71 | | Other x -> x 72 | ;; 73 | 74 | let url_repr { host; path; _ } = 75 | Format.asprintf "%s%s" host (Path.to_string path) 76 | ;; 77 | 78 | let to_rensai ({ uri; scheme; port; host; query; path } as u) = 79 | let open Rensai.Ast in 80 | record 81 | [ "scheme", string @@ scheme_to_string scheme 82 | ; "port", option int port 83 | ; "host", string host 84 | ; "path", Path.to_rensai path 85 | ; "query", Key_value.to_rensai (list string) query 86 | ; "uri", uri_to_rensai uri 87 | ; "url", string @@ Uri.to_string uri 88 | ; "repr", string @@ url_repr u 89 | ] 90 | ;; 91 | 92 | let to_uri { uri; _ } = uri 93 | let to_compact_rensai { uri; _ } = Rensai.Ast.string (Uri.to_string uri) 94 | -------------------------------------------------------------------------------- /lib/core/path.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Relative of string list 3 | | Absolute of string list 4 | 5 | let pwd = Relative [] 6 | let root = Absolute [] 7 | let sep = Filename.dir_sep 8 | 9 | let equal a b = 10 | match a, b with 11 | | Relative a, Relative b | Absolute a, Absolute b -> 12 | List.equal String.equal a b 13 | | Relative _, _ | Absolute _, _ -> false 14 | ;; 15 | 16 | let on f = function 17 | | Relative l -> Relative (f l) 18 | | Absolute l -> Absolute (f l) 19 | ;; 20 | 21 | let from path ~into = on (fun list -> into :: list) path 22 | 23 | module Infix = struct 24 | let ( / ) l r = from l ~into:r 25 | let ( ~/ ) r = pwd / r 26 | end 27 | 28 | include Infix 29 | 30 | let concat_fragments fragments = 31 | fragments 32 | |> List.fold_left 33 | (fun (i, acc) fragment -> 34 | let new_acc = 35 | if Int.equal i 0 then fragment else fragment ^ sep ^ acc 36 | in 37 | succ i, new_acc) 38 | (0, "") 39 | |> snd 40 | ;; 41 | 42 | let to_string = function 43 | | Relative xs -> "./" ^ concat_fragments xs 44 | | Absolute xs -> "/" ^ concat_fragments xs 45 | ;; 46 | 47 | let extension = function 48 | | Relative [] | Absolute [] -> "" 49 | | Relative (x :: _) | Absolute (x :: _) -> Filename.extension x 50 | ;; 51 | 52 | let extension_opt path = 53 | let ext = extension path in 54 | if String.equal "" ext then None else Some ext 55 | ;; 56 | 57 | let parent = function 58 | | Relative [] | Absolute [] -> None 59 | | Absolute (_ :: xs) -> Some (Absolute xs) 60 | | Relative (_ :: xs) -> Some (Relative xs) 61 | ;; 62 | 63 | let from_rensai = 64 | let open Rensai.Validation in 65 | (string $ Stdlib.String.split_on_char '/') / list_of string 66 | $ function 67 | | "" :: xs -> Absolute (Stdlib.List.rev xs) 68 | | "." :: xs | xs -> Relative (Stdlib.List.rev xs) 69 | ;; 70 | 71 | let to_rensai path = 72 | let s = to_string path in 73 | Rensai.Ast.string s 74 | ;; 75 | 76 | let is_absolute = function 77 | | Absolute _ -> true 78 | | _ -> false 79 | ;; 80 | 81 | let is_relative = function 82 | | Relative _ -> true 83 | | _ -> false 84 | ;; 85 | 86 | let from_string x = 87 | match String.split_on_char '/' x with 88 | | "" :: xs -> Absolute (List.rev xs) 89 | | "." :: xs | xs -> Relative (List.rev xs) 90 | ;; 91 | 92 | let to_list = function 93 | | Absolute xs | Relative xs -> List.rev xs 94 | ;; 95 | 96 | let as_target = function 97 | | Absolute [] | Relative [] -> None 98 | | Absolute (target :: xs) | Relative (target :: xs) -> 99 | Some (List.rev xs, target) 100 | ;; 101 | -------------------------------------------------------------------------------- /lib/model/described_item.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { name : string 3 | ; description : string option 4 | ; counter : int 5 | } 6 | 7 | let make ?(counter = 0) ?description name = { name; description; counter } 8 | let can_be_erased { counter; _ } = counter <= 0 9 | let name { name; _ } = name 10 | let description { description; _ } = description 11 | let counter { counter; _ } = counter 12 | 13 | let from_rensai = 14 | let open Rensai.Validation in 15 | record (fun obj -> 16 | let open Record in 17 | let+ name = required obj "name" String.(string & is_not_blank & is_slug) 18 | and+ description = optional obj "description" string 19 | and+ counter = optional_or ~default:0 obj "counter" int in 20 | { name; description; counter }) 21 | ;; 22 | 23 | let to_rensai { name; description; counter } = 24 | let open Rensai.Ast in 25 | record 26 | [ "name", string name 27 | ; "description", option string description 28 | ; "counter", int counter 29 | ] 30 | ;; 31 | 32 | module Set = struct 33 | module S = Stdlib.Set.Make (struct 34 | type nonrec t = t 35 | 36 | let compare { name = a; _ } { name = b; _ } = String.compare a b 37 | end) 38 | 39 | type t = S.t 40 | 41 | let from_list = S.of_list 42 | let empty = S.empty 43 | 44 | let from_ast_list list = 45 | list 46 | |> List.filter_map (fun ast -> ast |> from_rensai |> Result.to_option) 47 | |> S.of_list 48 | ;; 49 | 50 | let to_list = S.to_list 51 | let dump items = items |> to_list |> Rensai.Lang.dump_list to_rensai 52 | let to_rensai set = set |> S.to_list |> Rensai.Ast.list to_rensai 53 | 54 | let from_rensai = 55 | let open Rensai.Validation in 56 | list_of from_rensai $ S.of_list 57 | ;; 58 | 59 | let push ({ description; _ } as item) set = 60 | match S.find_opt item set, description with 61 | | Some { description = None; _ }, _ | Some _, Some _ -> 62 | set |> S.remove item |> S.add item 63 | | None, _ -> set |> S.add item 64 | | Some _, None -> set 65 | ;; 66 | 67 | let find name set = S.find_opt { name; description = None; counter = 0 } set 68 | let remove name set = S.remove { name; description = None; counter = 0 } set 69 | 70 | let increase name set = 71 | match find name set with 72 | | None -> S.add { name; description = None; counter = 0 } set 73 | | Some item -> 74 | set |> remove name |> S.add { item with counter = succ item.counter } 75 | ;; 76 | 77 | let decrease name set = 78 | match find name set with 79 | | None -> S.add { name; description = None; counter = 0 } set 80 | | Some item -> 81 | set 82 | |> remove name 83 | |> S.add { item with counter = max (pred item.counter) 0 } 84 | ;; 85 | end 86 | -------------------------------------------------------------------------------- /lib/core/eff.mli: -------------------------------------------------------------------------------- 1 | (** This module offers a rather naive approach to abstracting the 2 | effects that can be envisaged in a program interpreted by the 3 | JSONRPC request server. 4 | 5 | There are several ways of describing effects abstraction in OCaml, 6 | and the most obvious is, of course, the use of User Defined 7 | Effects.{{:https://ocaml.org/manual/5.3/effects.html} See OCaml 8 | Manual}. But after several experiments, I found that I had 9 | relatively little need (if any) to explicitly control the 10 | continuation of the program. In fact, the only time I didn't need 11 | to control continuation was when dealing with errors. As a result, 12 | I prefer to use a {i more predictable} approach: modules, and only 13 | handle error cases with exceptions (user-defined-effects without 14 | continuation control). 15 | 16 | The main reason I wanted to abstract the effects was to make unit 17 | testing easier, and to make it easier to use the code in the 18 | Browser. *) 19 | 20 | (** {1 Handler definition} 21 | 22 | A Handler is described using a functor. *) 23 | 24 | module type HANDLER = Sigs.EFFECT_HANDLER 25 | 26 | (** A shortcut to define function that should be handled. *) 27 | type handler = (module HANDLER) 28 | 29 | (** Build an handler on top of a set of requirement. *) 30 | module Handler (_ : Sigs.EFFECT_REQUIREMENT) : HANDLER 31 | 32 | (** {1 Public API} 33 | 34 | However, even when using a functor, the aim is essentially to use 35 | functions that take handlers as arguments. This is generally 36 | possible because a handler does not introduce parameterized types. *) 37 | 38 | (** [raise (module Handler) error] throws [error] as an exception. *) 39 | val raise : handler -> Error.custom -> 'a 40 | 41 | (** Set the working directory of the session. *) 42 | val set_supervised_directory : handler -> Path.t option -> unit 43 | 44 | (** Get the working directory of the session. *) 45 | val get_supervised_directory : handler -> Path.t option 46 | 47 | (** [from_result (module Handler) callback res] handle error using 48 | effect from a result. *) 49 | val from_result : handler -> ('b -> Error.custom) -> ('a, 'b) result -> 'a 50 | 51 | (** {2 File management} *) 52 | 53 | val exists : handler -> Path.t -> bool 54 | val is_file : handler -> Path.t -> bool 55 | val is_dir : handler -> Path.t -> bool 56 | val read_file : handler -> Path.t -> string 57 | val create_dir : handler -> Path.t -> unit 58 | val write_file : handler -> Path.t -> string -> unit 59 | val append_to_file : handler -> Path.t -> string -> unit 60 | val delete : handler -> Path.t -> unit 61 | 62 | (** {2 Time management} *) 63 | 64 | val now : handler -> Datetime.t 65 | 66 | (** {1 Program Handler} *) 67 | 68 | (** [handle (module Handler) program] Interprets the [program] with the given 69 | handler.*) 70 | val handle : handler -> (handler -> 'a) -> ('a, Error.custom) result 71 | -------------------------------------------------------------------------------- /test/server/input_parser.ml: -------------------------------------------------------------------------------- 1 | let%expect_test "test-parser - 1" = 2 | let input = "Content-Length: 2\r\n\r\naa" in 3 | let source = Eio.Flow.string_source input in 4 | let () = 5 | match 6 | Eio.Buf_read.parse ~max_size:1024 Kohai_server.Server.input_parser source 7 | with 8 | | Ok s -> print_endline ("Ok: " ^ s) 9 | | Error (`Msg err) -> print_endline ("Error: " ^ err) 10 | in 11 | (); 12 | [%expect {| Ok: aa |}] 13 | ;; 14 | 15 | let%expect_test "test-parser - 2" = 16 | let body = "{foo}" in 17 | let obj = 18 | Kohai_core.Error.parse_error ~body () 19 | |> Kohai_core.Error.to_rensai 20 | |> Rensai.Json.to_yojson 21 | |> Yojson.Safe.to_string 22 | in 23 | let len = String.length obj in 24 | let input = Format.asprintf "Content-Length: %d\r\n\r\n%s" len obj in 25 | let source = Eio.Flow.string_source input in 26 | let () = 27 | match 28 | Eio.Buf_read.parse ~max_size:1024 Kohai_server.Server.input_parser source 29 | with 30 | | Ok s -> print_endline ("Ok: " ^ s) 31 | | Error (`Msg err) -> print_endline ("Error: " ^ err) 32 | in 33 | (); 34 | [%expect 35 | {| Ok: {"error":{"body":"{foo}","code":-32700,"data":null,"message":"Parse error"},"id":null,"jsonrpc":"2.0"} |}] 36 | ;; 37 | 38 | let%expect_test "test-parser - 3" = 39 | let body = "{foo}" in 40 | let obj = 41 | Kohai_core.Error.parse_error ~body () 42 | |> Kohai_core.Error.to_rensai 43 | |> Rensai.Json.to_yojson 44 | |> Yojson.Safe.to_string 45 | in 46 | let len = String.length obj in 47 | let input = Format.asprintf "Content-Length: %d\r\n\r\n%s " len obj in 48 | let source = Eio.Flow.string_source input in 49 | let () = 50 | match 51 | Eio.Buf_read.parse ~max_size:1024 Kohai_server.Server.input_parser source 52 | with 53 | | Ok s -> print_endline ("Ok: " ^ s) 54 | | Error (`Msg err) -> print_endline ("Error: " ^ err) 55 | in 56 | (); 57 | [%expect {| Error: Unexpected data after parsing (at offset 125) |}] 58 | ;; 59 | 60 | let%expect_test "test-parser - 4" = 61 | let input = Format.asprintf "Content" in 62 | let source = Eio.Flow.string_source input in 63 | let () = 64 | match 65 | Eio.Buf_read.parse ~max_size:1024 Kohai_server.Server.input_parser source 66 | with 67 | | Ok s -> print_endline ("Ok: " ^ s) 68 | | Error (`Msg err) -> print_endline ("Error: " ^ err) 69 | in 70 | (); 71 | [%expect {| Error: Unexpected end-of-file at offset 7 |}] 72 | ;; 73 | 74 | let%expect_test "test-parser - 5" = 75 | let input = Format.asprintf "Content-Length: 1000\r\n\r\nfoo" in 76 | let source = Eio.Flow.string_source input in 77 | let () = 78 | match 79 | Eio.Buf_read.parse ~max_size:1024 Kohai_server.Server.input_parser source 80 | with 81 | | Ok s -> print_endline ("Ok: " ^ s) 82 | | Error (`Msg err) -> print_endline ("Error: " ^ err) 83 | in 84 | (); 85 | [%expect {| Error: Unexpected end-of-file at offset 27 |}] 86 | ;; 87 | -------------------------------------------------------------------------------- /lib/interaction/action/transient_log.mli: -------------------------------------------------------------------------------- 1 | (** Operation related to transient logs. *) 2 | 3 | (** List all current transient logs. *) 4 | val all : (module Sigs.EFFECT_HANDLER) -> Kohai_model.Transient_log.t list 5 | 6 | (** List all current transient logs (and sort them). *) 7 | val list 8 | : (module Sigs.EFFECT_HANDLER) 9 | -> unit 10 | -> Kohai_model.Transient_log.t list 11 | 12 | (** Get a current log by index. *) 13 | val get 14 | : (module Sigs.EFFECT_HANDLER) 15 | -> int 16 | -> Kohai_model.Transient_log.t option 17 | 18 | (** Store missing artifacts (project and sector). *) 19 | val store_missing_artifacts 20 | : (module Sigs.EFFECT_HANDLER) 21 | -> project:string option 22 | -> sector:string 23 | -> unit 24 | 25 | (** Save a given transient log into a file. *) 26 | val save 27 | : (module Sigs.EFFECT_HANDLER) 28 | -> Path.t 29 | -> Kohai_model.Transient_log.t 30 | -> Kohai_model.Transient_log.result 31 | 32 | (** Record a new transient log. *) 33 | val record 34 | : (module Sigs.EFFECT_HANDLER) 35 | -> Kohai_model.Context.t 36 | -> date_query:Datetime.Query.t option 37 | -> project:string option 38 | -> sector:string 39 | -> label:string 40 | -> Kohai_model.Transient_log.result 41 | 42 | (** Stop recording of a transient log. *) 43 | val stop_record 44 | : (module Sigs.EFFECT_HANDLER) 45 | -> Kohai_model.Context.t 46 | -> index:int 47 | -> duration:int option 48 | -> Kohai_model.Transient_log.result 49 | 50 | (** Rewrite an existing transient log. *) 51 | val rewrite 52 | : (module Sigs.EFFECT_HANDLER) 53 | -> Kohai_model.Context.t 54 | -> index:int 55 | -> date_query:Datetime.Query.t option 56 | -> project:string option 57 | -> sector:string 58 | -> label:string 59 | -> Kohai_model.Transient_log.result 60 | 61 | (** Delete an existing transient log. *) 62 | val delete 63 | : (module Sigs.EFFECT_HANDLER) 64 | -> index:int 65 | -> Kohai_model.Transient_log.result 66 | 67 | (** Add metadata to a transient log *) 68 | val add_meta 69 | : (module Sigs.EFFECT_HANDLER) 70 | -> index:int 71 | -> key:string 72 | -> value:string 73 | -> Kohai_model.Transient_log.result 74 | 75 | (** Remove metadata to a transient log *) 76 | val remove_meta 77 | : (module Sigs.EFFECT_HANDLER) 78 | -> index:int 79 | -> key:string 80 | -> Kohai_model.Transient_log.result 81 | 82 | (** Add link to a transient log *) 83 | val add_link 84 | : (module Sigs.EFFECT_HANDLER) 85 | -> index:int 86 | -> key:string 87 | -> value:Kohai_model.Url.t 88 | -> Kohai_model.Transient_log.result 89 | 90 | (** Remove link to a transient log *) 91 | val remove_link 92 | : (module Sigs.EFFECT_HANDLER) 93 | -> index:int 94 | -> key:string 95 | -> Kohai_model.Transient_log.result 96 | 97 | (** Duplicate a transient log *) 98 | val duplicate 99 | : (module Sigs.EFFECT_HANDLER) 100 | -> index:int 101 | -> Kohai_model.Transient_log.result 102 | -------------------------------------------------------------------------------- /test/core/path_test.ml: -------------------------------------------------------------------------------- 1 | open Kohai_core 2 | 3 | let dump_str s = s |> Fmt.str "%a" Fmt.Dump.string |> print_endline 4 | let dump_path p = p |> Path.to_string |> dump_str 5 | let dump_opt o = o |> Fmt.str "%a" Fmt.Dump.(option string) |> print_endline 6 | 7 | let%expect_test "path building - 1" = 8 | let p = Path.(pwd) in 9 | dump_path p; 10 | [%expect {| "./" |}] 11 | ;; 12 | 13 | let%expect_test "path building - 2" = 14 | let p = Path.(root) in 15 | dump_path p; 16 | [%expect {| "/" |}] 17 | ;; 18 | 19 | let%expect_test "path building - 3" = 20 | let p = Path.(pwd / "foo") in 21 | dump_path p; 22 | [%expect {| "./foo" |}] 23 | ;; 24 | 25 | let%expect_test "path building - 4" = 26 | let p = Path.(pwd / "foo" / "bar" / "baz") in 27 | dump_path p; 28 | [%expect {| "./foo/bar/baz" |}] 29 | ;; 30 | 31 | let%expect_test "path building - 5" = 32 | let p = Path.(root / "foo" / "bar" / "baz") in 33 | dump_path p; 34 | [%expect {| "/foo/bar/baz" |}] 35 | ;; 36 | 37 | let%expect_test "extension - 1" = 38 | let s = Path.(pwd) |> Path.extension in 39 | dump_str s; 40 | [%expect {| "" |}] 41 | ;; 42 | 43 | let%expect_test "extension - 2" = 44 | let s = Path.(root) |> Path.extension in 45 | dump_str s; 46 | [%expect {| "" |}] 47 | ;; 48 | 49 | let%expect_test "extension - 3" = 50 | let s = Path.(pwd / "index.ml") |> Path.extension in 51 | dump_str s; 52 | [%expect {| ".ml" |}] 53 | ;; 54 | 55 | let%expect_test "extension - 5" = 56 | let s = Path.(pwd / "index/module.mli") |> Path.extension in 57 | dump_str s; 58 | [%expect {| ".mli" |}] 59 | ;; 60 | 61 | let%expect_test "extension_opt - 1" = 62 | let s = Path.(pwd) |> Path.extension_opt in 63 | dump_opt s; 64 | [%expect {| None |}] 65 | ;; 66 | 67 | let%expect_test "extension_opt - 2" = 68 | let s = Path.(root) |> Path.extension_opt in 69 | dump_opt s; 70 | [%expect {| None |}] 71 | ;; 72 | 73 | let%expect_test "extension_opt - 3" = 74 | let s = Path.(pwd / "index.ml") |> Path.extension_opt in 75 | dump_opt s; 76 | [%expect {| Some ".ml" |}] 77 | ;; 78 | 79 | let%expect_test "extension_opt - 5" = 80 | let s = Path.(pwd / "index/module.mli") |> Path.extension_opt in 81 | dump_opt s; 82 | [%expect {| Some ".mli" |}] 83 | ;; 84 | 85 | let%expect_test "from_string - 1" = 86 | let p = Path.from_string "./" in 87 | dump_path p; 88 | [%expect {| "./" |}] 89 | ;; 90 | 91 | let%expect_test "from_string - 2" = 92 | let p = Path.from_string "./foo/bar/baz" in 93 | dump_path p; 94 | [%expect {| "./foo/bar/baz" |}] 95 | ;; 96 | 97 | let%expect_test "from_string - 3" = 98 | let p = Path.from_string "foo/bar/baz" in 99 | dump_path p; 100 | [%expect {| "./foo/bar/baz" |}] 101 | ;; 102 | 103 | let%expect_test "from_string - 4" = 104 | let p = Path.from_string "/" in 105 | dump_path p; 106 | [%expect {| "/" |}] 107 | ;; 108 | 109 | let%expect_test "from_string - 5" = 110 | let p = Path.from_string "/foo/bar/baz" in 111 | dump_path p; 112 | [%expect {| "/foo/bar/baz" |}] 113 | ;; 114 | -------------------------------------------------------------------------------- /lib/rensai/kind.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Null 3 | | Unit 4 | | Bool 5 | | Char 6 | | Int 7 | | Int32 8 | | Int64 9 | | Float 10 | | String 11 | | Pair of t * t 12 | | List of t 13 | | Constr of string * t 14 | | Record 15 | | Any 16 | | Or of t * t 17 | | And of t * t 18 | 19 | let rec equal a b = 20 | match a, b with 21 | | Null, Null 22 | | Unit, Unit 23 | | Bool, Bool 24 | | Char, Char 25 | | Int, Int 26 | | Int32, Int32 27 | | Int64, Int64 28 | | Float, Float 29 | | String, String 30 | | Any, Any 31 | | Record, Record -> true 32 | | Pair (a, b), Pair (x, y) -> equal a x && equal b y 33 | | List a, List b -> equal a b 34 | | Constr (ka, va), Constr (kb, vb) -> String.equal ka kb && equal va vb 35 | | Or (aa, ba), Or (ab, bb) | And (aa, ba), And (ab, bb) -> 36 | equal aa ab && equal ba bb 37 | | Null, _ 38 | | Unit, _ 39 | | Bool, _ 40 | | Char, _ 41 | | Int, _ 42 | | Int32, _ 43 | | Int64, _ 44 | | Float, _ 45 | | String, _ 46 | | Pair (_, _), _ 47 | | List _, _ 48 | | Constr (_, _), _ 49 | | Record, _ 50 | | Any, _ 51 | | Or (_, _), _ 52 | | And (_, _), _ -> false 53 | ;; 54 | 55 | let from_list_with f = function 56 | | [] -> Any 57 | | x :: xs -> List.fold_left (fun comp kind -> f kind comp) x xs 58 | ;; 59 | 60 | let from_list = from_list_with (fun k c -> Or (k, c)) 61 | 62 | let rec classify = function 63 | | Ast.Null -> Null 64 | | Ast.Unit -> Unit 65 | | Ast.Bool _ -> Bool 66 | | Ast.Char _ -> Char 67 | | Ast.Int _ -> Int 68 | | Ast.Int32 _ -> Int32 69 | | Ast.Int64 _ -> Int64 70 | | Ast.Float _ -> Float 71 | | Ast.String _ -> String 72 | | Ast.Pair (a, b) -> Pair (classify a, classify b) 73 | | Ast.List xs -> List (reduce_row xs) 74 | | Ast.Constr (k, a) -> Constr (k, classify a) 75 | | Ast.Record _ -> Record 76 | 77 | and reduce_row expr = 78 | (* hehe the function is very complex in the O sense but... 79 | I go for an huge reducing instead of implementing [compare] 80 | for [Kind.t]... *) 81 | let rec aux acc = function 82 | | [] -> acc 83 | | x :: xs -> 84 | let k = classify x in 85 | if List.exists (equal k) acc then aux acc xs else aux (k :: acc) xs 86 | in 87 | expr |> aux [] |> from_list_with (fun k c -> And (k, c)) 88 | ;; 89 | 90 | module Infix = struct 91 | let ( || ) a b = Or (a, b) 92 | let ( && ) a b = And (a, b) 93 | end 94 | 95 | include Infix 96 | 97 | let rec pp st = function 98 | | Null -> Fmt.pf st "null" 99 | | Unit -> Fmt.pf st "unit" 100 | | Bool -> Fmt.pf st "bool" 101 | | Char -> Fmt.pf st "char" 102 | | Int -> Fmt.pf st "int" 103 | | Int32 -> Fmt.pf st "int32" 104 | | Int64 -> Fmt.pf st "int64" 105 | | Float -> Fmt.pf st "float" 106 | | String -> Fmt.pf st "string" 107 | | Pair (a, b) -> Fmt.Dump.pair pp pp st (a, b) 108 | | List xs -> Fmt.pf st "list<%a>" pp xs 109 | | Constr (k, value) -> Fmt.pf st "%s(%a)" k pp value 110 | | Record -> Fmt.pf st "?record" 111 | | Any -> Fmt.pf st "?any" 112 | | Or (a, b) -> Fmt.pair ~sep:(Fmt.any " |@, ") pp pp st (a, b) 113 | | And (a, b) -> Fmt.pair ~sep:(Fmt.any " &@, ") pp pp st (a, b) 114 | ;; 115 | -------------------------------------------------------------------------------- /lib/interaction/action/state.ml: -------------------------------------------------------------------------------- 1 | module S = Kohai_model.State 2 | module L = Kohai_model.Log 3 | 4 | let update_state f dir (module H : Eff.HANDLER) log = 5 | let state_file = Kohai_model.Resolver.state ~cwd:dir in 6 | state_file 7 | |> Eff.read_file (module H) 8 | |> S.from_string 9 | |> f log 10 | |> S.dump 11 | |> Eff.write_file (module H) state_file 12 | ;; 13 | 14 | let upgrade_state = 15 | update_state (fun log state -> 16 | let start_date = L.start_date log 17 | and end_date = L.end_date log 18 | and duration = L.duration log in 19 | state 20 | |> S.patch_date_boundaries start_date 21 | |> S.patch_date_boundaries end_date 22 | |> S.increase_duration duration 23 | |> S.increase_counter 1) 24 | ;; 25 | 26 | let downgrade_state = 27 | update_state (fun log state -> 28 | let duration = L.duration log in 29 | state |> S.decrease_duration duration |> S.decrease_counter 1) 30 | ;; 31 | 32 | let update_particular_state 33 | on_subject 34 | resolver 35 | upgrade 36 | increment 37 | dir 38 | (module H : Eff.HANDLER) 39 | log 40 | = 41 | match on_subject @@ L.sector_and_project log with 42 | | Some subject -> 43 | let _ = increment (module H : Eff.HANDLER) subject in 44 | let dir = Path.(resolver ~cwd:dir / subject) in 45 | upgrade dir (module H : Eff.HANDLER) log 46 | | None -> () 47 | ;; 48 | 49 | let update_sector_state = 50 | update_particular_state 51 | (fun (x, _) -> Some x) 52 | Kohai_model.Resolver.sector_folder 53 | ;; 54 | 55 | let update_project_state = 56 | update_particular_state snd Kohai_model.Resolver.project_folder 57 | ;; 58 | 59 | let upgrade_sector_state = update_sector_state upgrade_state Sector.increase 60 | let downgrade_sector_state = update_sector_state downgrade_state Sector.decrease 61 | let upgrade_project_state = update_project_state upgrade_state Project.increase 62 | 63 | let downgrade_project_state = 64 | update_project_state downgrade_state Project.decrease 65 | ;; 66 | 67 | let upgrade dir (module H : Eff.HANDLER) log = 68 | let () = upgrade_state dir (module H) log in 69 | let () = upgrade_sector_state dir (module H) log in 70 | upgrade_project_state dir (module H) log 71 | ;; 72 | 73 | let downgrade dir (module H : Eff.HANDLER) log = 74 | let () = downgrade_state dir (module H) log in 75 | let () = downgrade_sector_state dir (module H) log in 76 | downgrade_project_state dir (module H) log 77 | ;; 78 | 79 | let get_by_cwd (module H : Eff.HANDLER) dir = 80 | let file = Kohai_model.Resolver.state ~cwd:dir in 81 | file |> Eff.read_file (module H) |> S.from_string 82 | ;; 83 | 84 | let get (module H : Eff.HANDLER) () = 85 | let cwd = Global.ensure_supervision (module H) () in 86 | get_by_cwd (module H) cwd 87 | ;; 88 | 89 | let get_for_sector (module H : Eff.HANDLER) sector = 90 | let cwd = Global.ensure_supervision (module H) () in 91 | let sector = Path.(Kohai_model.Resolver.sector_folder ~cwd / sector) in 92 | get_by_cwd (module H) sector 93 | ;; 94 | 95 | let get_for_project (module H : Eff.HANDLER) project = 96 | let cwd = Global.ensure_supervision (module H) () in 97 | let project = Path.(Kohai_model.Resolver.project_folder ~cwd / project) in 98 | get_by_cwd (module H) project 99 | ;; 100 | -------------------------------------------------------------------------------- /lib/model/state.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { big_bang : Datetime.t option 3 | ; end_of_world : Datetime.t option 4 | ; number_of_logs : int 5 | ; duration : Duration.t 6 | } 7 | 8 | let big_bang_of { big_bang; _ } = big_bang 9 | let end_of_world_of { end_of_world; _ } = end_of_world 10 | let number_of_logs_of { number_of_logs; _ } = number_of_logs 11 | let duration_of { duration; _ } = duration 12 | 13 | let make 14 | ?big_bang 15 | ?end_of_world 16 | ?(number_of_logs = 0) 17 | ?(duration = Duration.zero) 18 | () 19 | = 20 | { big_bang; end_of_world; number_of_logs; duration } 21 | ;; 22 | 23 | let patch_date_boundaries datetime state = 24 | let big_bang = 25 | match state.big_bang with 26 | | None -> Some datetime 27 | | Some previous_datetime -> 28 | let dt = Datetime.min_of previous_datetime datetime in 29 | Some dt 30 | in 31 | let end_of_world = 32 | match state.end_of_world with 33 | | None -> Some datetime 34 | | Some previous_datetime -> 35 | let dt = Datetime.max_of previous_datetime datetime in 36 | Some dt 37 | in 38 | { state with big_bang; end_of_world } 39 | ;; 40 | 41 | let increase_duration amount state = 42 | { state with 43 | duration = amount |> Duration.add state.duration |> Duration.bound_positive 44 | } 45 | ;; 46 | 47 | let decrease_duration amount state = 48 | { state with 49 | duration = amount |> Duration.sub state.duration |> Duration.bound_positive 50 | } 51 | ;; 52 | 53 | let increase_counter amount state = 54 | { state with number_of_logs = state.number_of_logs + amount } 55 | ;; 56 | 57 | let decrease_counter amount state = 58 | { state with number_of_logs = max (state.number_of_logs - amount) 0 } 59 | ;; 60 | 61 | let big_bang () = 62 | { big_bang = None 63 | ; end_of_world = None 64 | ; duration = Duration.zero 65 | ; number_of_logs = 0 66 | } 67 | ;; 68 | 69 | let from_rensai = 70 | let open Rensai.Validation in 71 | record (fun fields -> 72 | let open Record in 73 | let+ big_bang = optional fields "big_bang" Datetime.from_rensai 74 | and+ end_of_world = optional fields "end_of_world" Datetime.from_rensai 75 | and+ number_of_logs = optional_or ~default:0 fields "number_of_logs" int 76 | and+ duration = 77 | optional_or 78 | ~default:Duration.zero 79 | fields 80 | "duration" 81 | (int $ Duration.from_int) 82 | in 83 | { big_bang; end_of_world; duration; number_of_logs }) 84 | / (null $ big_bang) 85 | ;; 86 | 87 | let to_compact_rensai { big_bang; end_of_world; duration; number_of_logs } = 88 | let open Rensai.Ast in 89 | record 90 | [ "big_bang", option Datetime.to_compact_rensai big_bang 91 | ; "end_of_world", option Datetime.to_compact_rensai end_of_world 92 | ; "duration", Duration.to_rensai duration 93 | ; "number_of_logs", int number_of_logs 94 | ] 95 | ;; 96 | 97 | let dump state = 98 | state |> to_compact_rensai |> Format.asprintf "%a" Rensai.Lang.pp 99 | ;; 100 | 101 | let from_string string = 102 | let lexbuf = Lexing.from_string string in 103 | match 104 | Option.bind (lexbuf |> Rensai.Lang.from_lexingbuf) (fun x -> 105 | x |> from_rensai |> Result.to_option) 106 | with 107 | | Some x -> x 108 | | None -> big_bang () 109 | ;; 110 | -------------------------------------------------------------------------------- /test/model/url_test.ml: -------------------------------------------------------------------------------- 1 | open Kohai_model 2 | 3 | let dump ?(should_fail = false) = function 4 | | Ok url when not should_fail -> 5 | url |> Format.asprintf "OK: %a" Rensai.Lang.pp |> print_endline 6 | | Ok url -> 7 | url 8 | |> Format.asprintf "ERROR: %a (should failed)" Rensai.Lang.pp 9 | |> print_endline 10 | | Error err -> 11 | let suff = if should_fail then "OK" else "ERROR" in 12 | err 13 | |> Format.asprintf 14 | "%s: %a (should failed)" 15 | suff 16 | Rensai.Validation.pp_value_error 17 | |> print_endline 18 | ;; 19 | 20 | let%expect_test "from_string - 1" = 21 | let url = "http://xvw.lol" in 22 | url |> Url.from_string |> Result.map Url.to_rensai |> dump; 23 | [%expect 24 | {| 25 | OK: ; 28 | url: "http://xvw.lol"> 29 | |}] 30 | ;; 31 | 32 | let%expect_test "from_string - 2" = 33 | let url = "http://xvw.lol/foo/bar" in 34 | url |> Url.from_string |> Result.map Url.to_rensai |> dump; 35 | [%expect 36 | {| 37 | OK: ; 42 | url: "http://xvw.lol/foo/bar"> 43 | |}] 44 | ;; 45 | 46 | let%expect_test "from_string - 3" = 47 | let url = "http://xvw.lol/foo/bar?foo=bar,baz&bar=foo" in 48 | url |> Url.from_string |> Result.map Url.to_rensai |> dump; 49 | [%expect 50 | {| 51 | OK: , ]; 54 | repr: "xvw.lol/foo/bar"; scheme: "http"; 55 | uri: 56 | ; 58 | url: "http://xvw.lol/foo/bar?foo=bar,baz&bar=foo"> 59 | |}] 60 | ;; 61 | 62 | let%expect_test "from_string - 4" = 63 | let url = "http://xvw.lol:8888/foo/bar?foo=bar,baz&bar=foo" in 64 | url |> Url.from_string |> Result.map Url.to_rensai |> dump; 65 | [%expect 66 | {| 67 | OK: , ]; 70 | repr: "xvw.lol/foo/bar"; scheme: "http"; 71 | uri: 72 | ; 74 | url: "http://xvw.lol:8888/foo/bar?foo=bar,baz&bar=foo"> 75 | |}] 76 | ;; 77 | 78 | let%expect_test "from_string - 5" = 79 | let url = "www.google.org" in 80 | url |> Url.from_string |> Result.map Url.to_rensai |> dump; 81 | [%expect 82 | {| 83 | ERROR: {message: "unexpected record"; 84 | where: 85 | [{message: "missing field"; 86 | field: "scheme"}; 87 | {message: "missing field"; 88 | field: "host"}]; 89 | value: 90 | {host = ; path = "www.google.org"; port = ; query = []; 91 | scheme = }} (should failed) 92 | |}] 93 | ;; 94 | -------------------------------------------------------------------------------- /test/model/described_item_test.ml: -------------------------------------------------------------------------------- 1 | open Kohai_model 2 | 3 | let dump x = 4 | x 5 | |> Described_item.Set.to_rensai 6 | |> Format.asprintf "%a" Rensai.Lang.pp 7 | |> print_endline 8 | ;; 9 | 10 | let dump_ok x = 11 | x 12 | |> Result.map Described_item.Set.to_rensai 13 | |> Format.asprintf "%a" (Rensai.Validation.pp_checked Rensai.Lang.pp) 14 | |> print_endline 15 | ;; 16 | 17 | let from_string subject = 18 | subject 19 | |> Lexing.from_string 20 | |> Rensai.Lang.from_lexingbuf_to_list 21 | |> Described_item.Set.from_ast_list 22 | ;; 23 | 24 | let a_sector_list = 25 | [ {||} 26 | ; {||} 27 | ] 28 | |> String.concat "\n" 29 | |> from_string 30 | ;; 31 | 32 | let%expect_test "Simply dump a list of sectors" = 33 | a_sector_list |> dump; 34 | [%expect 35 | {| 36 | [, 37 | ] 38 | |}] 39 | ;; 40 | 41 | let%expect_test "Push a new sector - 1" = 42 | let sector = Rensai.Ast.(record [ "name", string "art" ]) in 43 | let result = 44 | let open Rensai.Validation.Syntax in 45 | let+ sector = Described_item.from_rensai sector in 46 | Described_item.Set.push sector a_sector_list 47 | in 48 | dump_ok result; 49 | [%expect 50 | {| 51 | [, 52 | , 53 | ] 54 | |}] 55 | ;; 56 | 57 | let%expect_test "Push a new sector - 2" = 58 | let sector = 59 | Rensai.Ast.( 60 | record [ "name", string "art"; "description", string "A description" ]) 61 | in 62 | let result = 63 | let open Rensai.Validation.Syntax in 64 | let+ sector = Described_item.from_rensai sector in 65 | Described_item.Set.push sector a_sector_list 66 | in 67 | dump_ok result; 68 | [%expect 69 | {| 70 | [, 71 | , 72 | ] 73 | |}] 74 | ;; 75 | 76 | let%expect_test "Push a new sector - 3" = 77 | let sector = 78 | Rensai.Ast.( 79 | record 80 | [ "name", string "programming" 81 | ; "description", string "A programming description" 82 | ]) 83 | in 84 | let result = 85 | let open Rensai.Validation.Syntax in 86 | let+ sector = Described_item.from_rensai sector in 87 | Described_item.Set.push sector a_sector_list 88 | in 89 | dump_ok result; 90 | [%expect 91 | {| 92 | [, 93 | ] 94 | |}] 95 | ;; 96 | 97 | let%expect_test "Push a new sector - 4" = 98 | let sector = Rensai.Ast.(record [ "name", string "learning" ]) in 99 | let result = 100 | let open Rensai.Validation.Syntax in 101 | let+ sector = Described_item.from_rensai sector in 102 | Described_item.Set.push sector a_sector_list 103 | in 104 | dump_ok result; 105 | [%expect 106 | {| 107 | [, 108 | ] 109 | |}] 110 | ;; 111 | -------------------------------------------------------------------------------- /lib/rensai/ast.ml: -------------------------------------------------------------------------------- 1 | module S_map = Stdlib.Map.Make (String) 2 | 3 | type t = 4 | | Null 5 | | Unit 6 | | Bool of bool 7 | | Char of char 8 | | Int of int 9 | | Int32 of int32 10 | | Int64 of int64 11 | | Float of float 12 | | String of string 13 | | Pair of t * t 14 | | List of t list 15 | | Constr of string * t 16 | | Record of record 17 | 18 | and record = t S_map.t 19 | 20 | type 'a conv = 'a -> t 21 | 22 | let rec equal a b = 23 | match a, b with 24 | | Null, Null | Unit, Unit -> true 25 | | Bool a, Bool b -> Bool.equal a b 26 | | Char a, Char b -> Char.equal a b 27 | | Int a, Int b -> Int.equal a b 28 | | Int32 a, Int32 b -> Int32.equal a b 29 | | Int64 a, Int64 b -> Int64.equal a b 30 | | Float a, Float b -> Float.equal a b 31 | | String a, String b -> String.equal a b 32 | | Pair (a, b), Pair (x, y) -> equal a x && equal b y 33 | | List a, List b -> List.equal equal a b 34 | | Constr (a, va), Constr (b, vb) -> String.equal a b && equal va vb 35 | | Record a, Record b -> S_map.equal equal a b 36 | | Null, _ 37 | | Unit, _ 38 | | Bool _, _ 39 | | Char _, _ 40 | | Int _, _ 41 | | Int32 _, _ 42 | | Int64 _, _ 43 | | Float _, _ 44 | | String _, _ 45 | | Pair (_, _), _ 46 | | List _, _ 47 | | Constr (_, _), _ 48 | | Record _, _ -> false 49 | ;; 50 | 51 | let record_to_assoc = S_map.to_list 52 | let use f conv x = conv (f x) 53 | let replace x v = use (fun _ -> x) v 54 | let null _ = Null 55 | let unit _ = Unit 56 | let bool b = Bool b 57 | let int i = Int i 58 | let int32 i = Int32 i 59 | let int64 i = Int64 i 60 | let float f = Float f 61 | let string s = String s 62 | let char c = Char c 63 | let lpair a b = Pair (a, b) 64 | let pair f g (a, b) = Pair (f a, g b) 65 | let pair' f g a b = pair f g (a, b) 66 | let triple f g h (a, b, c) = pair f (pair g h) (a, (b, c)) 67 | let triple' f g h a b c = triple f g h (a, b, c) 68 | let quad f g h i (a, b, c, d) = pair f (pair g (pair h i)) (a, (b, (c, d))) 69 | let quad' f g h i a b c d = quad f g h i (a, b, c, d) 70 | let list f l = List (List.map f l) 71 | let hlist l = List l 72 | let lconstr k v = Constr (String.trim @@ String.lowercase_ascii k, v) 73 | 74 | let constr f x = 75 | let k, value = f x in 76 | Constr (String.trim @@ String.lowercase_ascii k, value) 77 | ;; 78 | 79 | let sum f x = constr f x 80 | let option some = Option.fold ~none:(null ()) ~some 81 | 82 | let either left right = 83 | constr (function 84 | | Either.Left x -> "left", left x 85 | | Either.Right x -> "right", right x) 86 | ;; 87 | 88 | let result ok error = 89 | constr (function 90 | | Ok x -> "ok", ok x 91 | | Error x -> "error", error x) 92 | ;; 93 | 94 | let record fields = 95 | let fields = S_map.of_list fields in 96 | Record fields 97 | ;; 98 | 99 | module Infix = struct 100 | let ( <$> ) = use 101 | end 102 | 103 | include Infix 104 | 105 | let rec pp st = function 106 | | Null -> Fmt.pf st "" 107 | | Unit -> Fmt.pf st "" 108 | | Bool x -> Fmt.bool st x 109 | | Char c -> Fmt.pf st "%C" c 110 | | Int i -> Fmt.int st i 111 | | Int32 i -> Fmt.int32 st i 112 | | Int64 i -> Fmt.int64 st i 113 | | Float f -> Fmt.float st f 114 | | String s -> Fmt.pf st "%S" s 115 | | Pair (a, b) -> Fmt.Dump.pair pp pp st (a, b) 116 | | List xs -> Fmt.Dump.list pp st xs 117 | | Constr (constr, value) -> Fmt.pf st "%s%a" constr (Fmt.parens pp) value 118 | | Record record -> 119 | let fields = 120 | Fmt.list ~sep:(Fmt.any ";@, ") (fun st (k, v) -> 121 | Fmt.pf st "@[<1>%s =@ %a@]" k pp v) 122 | in 123 | let fields = Fmt.using record_to_assoc fields in 124 | (Fmt.box ~indent:2 (Fmt.braces fields)) st record 125 | ;; 126 | -------------------------------------------------------------------------------- /lib/rensai/json.ml: -------------------------------------------------------------------------------- 1 | type yojson = 2 | [ `Null 3 | | `Bool of bool 4 | | `Int of int 5 | | `Intlit of string 6 | | `Float of float 7 | | `String of string 8 | | `Assoc of (string * yojson) list 9 | | `List of yojson list 10 | ] 11 | 12 | type ezjsonm = 13 | [ `Null 14 | | `Bool of bool 15 | | `Float of float 16 | | `String of string 17 | | `A of ezjsonm list 18 | | `O of (string * ezjsonm) list 19 | ] 20 | 21 | let rec to_ezjsonm = function 22 | | Ast.Null | Ast.Unit -> `Null 23 | | Ast.Bool b -> `Bool b 24 | | Ast.Int x -> `Float (float_of_int x) 25 | | Ast.Float x -> `Float x 26 | | Ast.Int32 x -> `String (Int32.to_string x ^ "l") 27 | | Ast.Int64 x -> `String (Int64.to_string x ^ "L") 28 | | Ast.Char x -> `String (String.make 1 x) 29 | | Ast.String x -> `String x 30 | | Ast.Pair (a, b) -> `O [ "fst", to_ezjsonm a; "snd", to_ezjsonm b ] 31 | | Ast.List xs -> `A (List.map to_ezjsonm xs) 32 | | Ast.Constr (k, v) -> `O [ "ctor", `String k; "value", to_ezjsonm v ] 33 | | Ast.Record record -> 34 | let record = Ast.record_to_assoc record in 35 | `O (List.map (fun (k, v) -> k, to_ezjsonm v) record) 36 | ;; 37 | 38 | let rec to_yojson = function 39 | | Ast.Null | Ast.Unit -> `Null 40 | | Ast.Bool b -> `Bool b 41 | | Ast.Int x -> `Int x 42 | | Ast.Float x -> `Float x 43 | | Ast.Int32 x -> `Intlit (Int32.to_string x) 44 | | Ast.Int64 x -> `Intlit (Int64.to_string x) 45 | | Ast.Char x -> `String (String.make 1 x) 46 | | Ast.String x -> `String x 47 | | Ast.Pair (a, b) -> `Assoc [ "fst", to_yojson a; "snd", to_yojson b ] 48 | | Ast.Constr (k, Ast.Null) | Ast.Constr (k, Ast.Unit) -> 49 | `Assoc [ "ctor", `String k ] 50 | | Ast.Constr (k, v) -> `Assoc [ "ctor", `String k; "value", to_yojson v ] 51 | | Ast.List xs -> `List (List.map to_yojson xs) 52 | | Ast.Record record -> 53 | let record = Ast.record_to_assoc record in 54 | `Assoc (List.map (fun (k, v) -> k, to_yojson v) record) 55 | ;; 56 | 57 | let as_int64 x = Scanf.sscanf_opt x "%LdL%!" Ast.int64 58 | let as_int32 x = Scanf.sscanf_opt x "%ldl%!" Ast.int32 59 | let as_int x = Scanf.sscanf_opt x "%dL%!" Ast.int 60 | 61 | let ( <|> ) a b = 62 | match a with 63 | | Some x -> Some x 64 | | None -> b 65 | ;; 66 | 67 | let infer_string s = 68 | match as_int64 s <|> as_int32 s <|> as_int s with 69 | | None -> Ast.string s 70 | | Some x -> x 71 | ;; 72 | 73 | let infer_float f = 74 | match Float.classify_float (fst (Float.modf f)) with 75 | | Float.FP_zero -> Ast.int (int_of_float f) 76 | | _ -> Ast.float f 77 | ;; 78 | 79 | let infer_record fix = function 80 | | [ ("fst", a); ("snd", b) ] | [ ("first", a); ("second", b) ] -> 81 | Ast.pair fix fix (a, b) 82 | | [ ("ctor", `String ctor); ("value", value) ] 83 | | [ ("constr", `String ctor); ("value", value) ] -> 84 | Ast.constr (fun () -> ctor, fix value) () 85 | | [ ("ctor", `String ctor) ] | [ ("constr", `String ctor) ] -> 86 | Ast.constr (fun () -> ctor, Ast.unit ()) () 87 | | fields -> Ast.record (List.map (fun (k, v) -> k, fix v) fields) 88 | ;; 89 | 90 | let rec from_yojson = function 91 | | `Null -> Ast.null () 92 | | `Bool b -> Ast.bool b 93 | | `Int x -> Ast.int x 94 | | `Intlit x -> infer_string x 95 | | `Float f -> infer_float f 96 | | `String s -> infer_string s 97 | | `List xs -> Ast.list from_yojson xs 98 | | `Assoc record -> infer_record from_yojson record 99 | ;; 100 | 101 | let rec from_ezjsonm = function 102 | | `Null -> Ast.null () 103 | | `Bool b -> Ast.bool b 104 | | `Float f -> infer_float f 105 | | `String s -> infer_string s 106 | | `A xs -> Ast.list from_ezjsonm xs 107 | | `O record -> infer_record from_ezjsonm record 108 | ;; 109 | -------------------------------------------------------------------------------- /test/core/datetime_query.ml: -------------------------------------------------------------------------------- 1 | open Kohai_core 2 | 3 | let current_time = 4 | "2025-02-18 10:00:00" 5 | |> Datetime.from_string 6 | (* Since it is a test, we can discard 7 | the error case *) 8 | |> Result.get_ok 9 | ;; 10 | 11 | let dump ?(should_fail = false) = function 12 | | Error _ when should_fail -> print_endline "OK: Parsing_failure" 13 | | Ok query when not should_fail -> 14 | Some query 15 | |> Datetime.Query.resolve current_time 16 | |> Format.asprintf "%a" (Datetime.pp ()) 17 | |> print_endline 18 | | Ok _ -> print_endline "FAILURE: Test should fail" 19 | | Error err -> 20 | err 21 | |> Format.asprintf "FAILURE: %a" Rensai.Validation.pp_value_error 22 | |> print_endline 23 | ;; 24 | 25 | let%expect_test "parse-failure - 1" = 26 | "foobar" |> Datetime.Query.from_string |> dump ~should_fail:true; 27 | [%expect {| OK: Parsing_failure |}] 28 | ;; 29 | 30 | let%expect_test "now - 1" = 31 | "now" |> Datetime.Query.from_string |> dump; 32 | [%expect {| 2025-02-18T10-00-00 |}] 33 | ;; 34 | 35 | let%expect_test "now - 2" = 36 | " now " |> Datetime.Query.from_string |> dump; 37 | [%expect {| 2025-02-18T10-00-00 |}] 38 | ;; 39 | 40 | let%expect_test "now - 3" = 41 | " NoW" |> Datetime.Query.from_string |> dump; 42 | [%expect {| 2025-02-18T10-00-00 |}] 43 | ;; 44 | 45 | let%expect_test "now - 4" = 46 | " NoW " |> Datetime.Query.from_string |> dump; 47 | [%expect {| 2025-02-18T10-00-00 |}] 48 | ;; 49 | 50 | let%expect_test "absolute - 1" = 51 | "2022-02-10" |> Datetime.Query.from_string |> dump; 52 | [%expect {| 2022-02-10T00-00-00 |}] 53 | ;; 54 | 55 | let%expect_test "absolute - 2" = 56 | "2022-02-10T10:15:30" |> Datetime.Query.from_string |> dump; 57 | [%expect {| 2022-02-10T10-15-30 |}] 58 | ;; 59 | 60 | let%expect_test "at - 1" = 61 | "12:18:37" |> Datetime.Query.from_string |> dump; 62 | [%expect {| 2025-02-18T12-18-37 |}] 63 | ;; 64 | 65 | let%expect_test "at - 2" = 66 | "at 12:18:37" |> Datetime.Query.from_string |> dump; 67 | [%expect {| 2025-02-18T12-18-37 |}] 68 | ;; 69 | 70 | let%expect_test "at - 3" = 71 | " AT 12 18-37 " |> Datetime.Query.from_string |> dump; 72 | [%expect {| 2025-02-18T12-18-37 |}] 73 | ;; 74 | 75 | let%expect_test "at - 4" = 76 | " AT 2:1:3 " |> Datetime.Query.from_string |> dump; 77 | [%expect {| 2025-02-18T02-01-03 |}] 78 | ;; 79 | 80 | let%expect_test "at - 5" = 81 | " AT 21:1:3 " |> Datetime.Query.from_string |> dump; 82 | [%expect {| 2025-02-18T21-01-03 |}] 83 | ;; 84 | 85 | let%expect_test "at - 6" = 86 | " AT 27:1:63 " |> Datetime.Query.from_string |> dump ~should_fail:true; 87 | [%expect {| OK: Parsing_failure |}] 88 | ;; 89 | 90 | let%expect_test "at - 7" = 91 | "12:18" |> Datetime.Query.from_string |> dump; 92 | [%expect {| 2025-02-18T12-18-00 |}] 93 | ;; 94 | 95 | let%expect_test "at - 8" = 96 | "12" |> Datetime.Query.from_string |> dump; 97 | [%expect {| 2025-02-18T12-00-00 |}] 98 | ;; 99 | 100 | let%expect_test "at - 9" = 101 | "12 " |> Datetime.Query.from_string |> dump; 102 | [%expect {| 2025-02-18T12-00-00 |}] 103 | ;; 104 | 105 | let%expect_test "at - 10" = 106 | "12h " |> Datetime.Query.from_string |> dump; 107 | [%expect {| 2025-02-18T12-00-00 |}] 108 | ;; 109 | 110 | let%expect_test "at - 11" = 111 | "22h43" |> Datetime.Query.from_string |> dump; 112 | [%expect {| 2025-02-18T22-43-00 |}] 113 | ;; 114 | 115 | let%expect_test "at - 12" = 116 | "at 15h59" |> Datetime.Query.from_string |> dump; 117 | [%expect {| 2025-02-18T15-59-00 |}] 118 | ;; 119 | 120 | let%expect_test "at - 13" = 121 | "at 15h59 12" |> Datetime.Query.from_string |> dump; 122 | [%expect {| 2025-02-18T15-59-12 |}] 123 | ;; 124 | 125 | let%expect_test "at - 14" = 126 | "at 15h59m12" |> Datetime.Query.from_string |> dump; 127 | [%expect {| 2025-02-18T15-59-12 |}] 128 | ;; 129 | -------------------------------------------------------------------------------- /bin/kohai.ml: -------------------------------------------------------------------------------- 1 | open Kohai_core 2 | open Kohai_server 3 | 4 | let bin = Sys.argv.(0) 5 | let version = "dev" 6 | 7 | module Make_handler 8 | (Env : sig 9 | val env : Eio_unix.Stdenv.base 10 | end) 11 | () = 12 | struct 13 | let env = Env.env 14 | 15 | include Kohai_core.Eff.Handler (struct 16 | let supervised_directory = ref None 17 | 18 | let path_to_eio path = 19 | let root = 20 | match Path.is_absolute path with 21 | | true -> Eio.Path.(Eio.Stdenv.fs env / "/") 22 | | false -> Eio.Stdenv.cwd env 23 | in 24 | List.fold_left Eio.Path.( / ) root (Path.to_list path) 25 | ;; 26 | 27 | let exists path = 28 | let p = path_to_eio path in 29 | match Eio.Path.kind ~follow:true p with 30 | | `Not_found -> false 31 | | _ -> true 32 | ;; 33 | 34 | let is_dir path = 35 | let p = path_to_eio path in 36 | Eio.Path.is_directory p 37 | ;; 38 | 39 | let is_file path = 40 | let p = path_to_eio path in 41 | Eio.Path.is_file p 42 | ;; 43 | 44 | let read_file path = 45 | let p = path_to_eio path in 46 | try Eio.Path.load p with 47 | | _ -> 48 | (* Maybe improve that case lol. *) 49 | "" 50 | ;; 51 | 52 | let create_dir path = 53 | let p = path_to_eio path in 54 | try Eio.Path.mkdir ~perm:0o755 p with 55 | | _ -> 56 | (* Maybe improve that case lol. *) 57 | () 58 | ;; 59 | 60 | let write_file path content = 61 | let p = path_to_eio path in 62 | try 63 | Eio.Path.save ~append:false ~create:(`Or_truncate 0o775) p content 64 | with 65 | | _ -> () 66 | ;; 67 | 68 | let append_to_file path content = 69 | let p = path_to_eio path in 70 | try 71 | Eio.Path.save ~append:true ~create:(`If_missing 0o775) p content 72 | with 73 | | _ -> () 74 | ;; 75 | 76 | let delete_file path = 77 | let p = path_to_eio path in 78 | try Eio.Path.unlink p with 79 | | _ -> () 80 | ;; 81 | 82 | let delete_dir ?(recursive = false) path = 83 | let p = path_to_eio path in 84 | try 85 | if recursive 86 | then Eio.Path.rmtree ~missing_ok:true p 87 | else Eio.Path.rmdir p 88 | with 89 | | _ -> () 90 | ;; 91 | 92 | let now () = Eio.Time.now env#clock 93 | 94 | let datetime_from_float time = 95 | let Unix.{ tm_sec; tm_min; tm_hour; tm_mday; tm_mon; tm_year; _ } = 96 | Unix.localtime time 97 | in 98 | let time = tm_hour, tm_min, tm_sec in 99 | Datetime.from_unix ~time ~year:tm_year ~month:tm_mon ~day:tm_mday () 100 | ;; 101 | 102 | let set_supervised_directory v = supervised_directory := v 103 | let get_supervised_directory () = !supervised_directory 104 | end) 105 | end 106 | 107 | let run () = 108 | Eio_main.run (fun env -> 109 | let module Handler = 110 | Make_handler 111 | (struct 112 | let env = env 113 | end) 114 | () 115 | in 116 | Server.run (module Handler) env) 117 | ;; 118 | 119 | let run_t = 120 | let open Cmdliner in 121 | let expr = Term.(const run $ const ()) in 122 | let doc = "Run the server (using stdin/stdout)" in 123 | let info = Cmd.info "run" ~doc in 124 | Cmd.v info expr 125 | ;; 126 | 127 | let all = 128 | let open Cmdliner in 129 | let doc = 130 | "Kohai is a very simple (but opinionated) timetracker for my personal usage" 131 | in 132 | let info = Cmd.info bin ~version ~doc in 133 | let default = Term.(ret (const (`Help (`Pager, None)))) in 134 | Cmd.group info ~default [ run_t ] 135 | ;; 136 | 137 | let () = exit @@ Cmdliner.Cmd.eval all 138 | -------------------------------------------------------------------------------- /lib/interaction/action/described_item.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | (** Returns the set of item. *) 3 | val list 4 | : (module Sigs.EFFECT_HANDLER) 5 | -> unit 6 | -> Kohai_model.Described_item.Set.t 7 | 8 | (** Smartly save into the item set. *) 9 | val save 10 | : (module Sigs.EFFECT_HANDLER) 11 | -> Kohai_model.Described_item.t 12 | -> Kohai_model.Described_item.Set.t 13 | 14 | (** Find by his name. *) 15 | val get 16 | : (module Sigs.EFFECT_HANDLER) 17 | -> string 18 | -> Kohai_model.Described_item.t option 19 | 20 | (** Delete by his name. *) 21 | val delete 22 | : (module Sigs.EFFECT_HANDLER) 23 | -> string 24 | -> Kohai_model.Described_item.Set.t 25 | 26 | (** Increase by name. *) 27 | val increase 28 | : (module Sigs.EFFECT_HANDLER) 29 | -> string 30 | -> Kohai_model.Described_item.Set.t 31 | 32 | (** Decrease by name. *) 33 | val decrease 34 | : (module Sigs.EFFECT_HANDLER) 35 | -> string 36 | -> Kohai_model.Described_item.Set.t 37 | 38 | (** Store missing key. *) 39 | val store_missing_key : (module Sigs.EFFECT_HANDLER) -> string -> unit 40 | 41 | (** Store missing key (if it exists). *) 42 | val may_store_missing_key 43 | : (module Sigs.EFFECT_HANDLER) 44 | -> string option 45 | -> unit 46 | end 47 | 48 | module Make (D : sig 49 | val resolver : cwd:Path.t -> Path.t 50 | end) : S = struct 51 | let list (module H : Eff.HANDLER) () = 52 | let cwd = Global.ensure_supervision (module H) () in 53 | let file = D.resolver ~cwd in 54 | let content = Eff.read_file (module H) file in 55 | let lexbuf = Lexing.from_string content in 56 | lexbuf 57 | |> Rensai.Lang.from_lexingbuf_to_list ~reverse:false 58 | |> Kohai_model.Described_item.Set.from_ast_list 59 | ;; 60 | 61 | let save (module H : Eff.HANDLER) item = 62 | let cwd = Global.ensure_supervision (module H) () in 63 | let file = D.resolver ~cwd in 64 | let items = list (module H : Eff.HANDLER) () in 65 | let items = Kohai_model.Described_item.Set.push item items in 66 | let content = Kohai_model.Described_item.Set.dump items in 67 | let () = Eff.write_file (module H) file content in 68 | items 69 | ;; 70 | 71 | let store_missing_key (module H : Eff.HANDLER) item = 72 | item |> Kohai_model.Described_item.make |> save (module H) |> ignore 73 | ;; 74 | 75 | let may_store_missing_key (module H : Eff.HANDLER) = function 76 | | None -> () 77 | | Some item -> store_missing_key (module H) item 78 | ;; 79 | 80 | let get (module H : Eff.HANDLER) item = 81 | let items = list (module H : Eff.HANDLER) () in 82 | Kohai_model.Described_item.Set.find item items 83 | ;; 84 | 85 | let delete (module H : Eff.HANDLER) item_name = 86 | let cwd = Global.ensure_supervision (module H) () in 87 | let file = D.resolver ~cwd in 88 | let items = list (module H : Eff.HANDLER) () in 89 | let item = Kohai_model.Described_item.Set.find item_name items in 90 | match item with 91 | | Some item when Kohai_model.Described_item.can_be_erased item -> 92 | let items = Kohai_model.Described_item.Set.remove item_name items in 93 | let content = Kohai_model.Described_item.Set.dump items in 94 | let () = Eff.write_file (module H) file content in 95 | items 96 | | None | Some _ -> items 97 | ;; 98 | 99 | let manip_counter f (module H : Eff.HANDLER) item_name = 100 | let cwd = Global.ensure_supervision (module H) () in 101 | let file = D.resolver ~cwd in 102 | let items = list (module H : Eff.HANDLER) () in 103 | let items = f item_name items in 104 | let content = Kohai_model.Described_item.Set.dump items in 105 | let () = Eff.write_file (module H) file content in 106 | items 107 | ;; 108 | 109 | let increase = manip_counter Kohai_model.Described_item.Set.increase 110 | let decrease = manip_counter Kohai_model.Described_item.Set.decrease 111 | end 112 | -------------------------------------------------------------------------------- /lib/interaction/action/transient_log.ml: -------------------------------------------------------------------------------- 1 | module TL = Kohai_model.Transient_log 2 | 3 | let all (module H : Eff.HANDLER) = 4 | let cwd = Global.ensure_supervision (module H) () in 5 | let file = Kohai_model.Resolver.transient_logs ~cwd in 6 | let content = Eff.read_file (module H) file in 7 | TL.from_file_content content 8 | ;; 9 | 10 | let list (module H : Eff.HANDLER) () = (module H) |> all |> TL.sort 11 | 12 | let get (module H : Eff.HANDLER) index = 13 | (module H) |> all |> List.find_opt (TL.has_index index) 14 | ;; 15 | 16 | let store_missing_artifacts (module H : Eff.HANDLER) ~project ~sector = 17 | Sector.store_missing_key (module H) sector; 18 | Project.may_store_missing_key (module H) project 19 | ;; 20 | 21 | let dump_transients (module H : Eff.HANDLER) ?transient transients file = 22 | let result = TL.to_result ?inserted:transient transients in 23 | let content = TL.dump result in 24 | let () = Eff.write_file (module H) file content in 25 | result 26 | ;; 27 | 28 | let update_by_index (module H : Eff.HANDLER) ~index f = 29 | let cwd = Global.ensure_supervision (module H) () in 30 | let file = Kohai_model.Resolver.transient_logs ~cwd in 31 | let transients = 32 | (module H) 33 | |> all 34 | |> List.map (fun tl -> if TL.has_index index tl then f tl else tl) 35 | in 36 | dump_transients (module H) transients file 37 | ;; 38 | 39 | let save (module H : Eff.HANDLER) file transient = 40 | let sector = TL.sector transient 41 | and project = TL.project transient in 42 | let () = store_missing_artifacts (module H) ~project ~sector in 43 | let transients = all (module H) in 44 | dump_transients (module H) ~transient transients file 45 | ;; 46 | 47 | let record (module H : Eff.HANDLER) ctx ~date_query ~project ~sector ~label = 48 | let cwd = Global.ensure_supervision (module H) () in 49 | let file = Kohai_model.Resolver.transient_logs ~cwd in 50 | let now = Kohai_model.Context.now ctx in 51 | let start_date = Datetime.Query.resolve now date_query in 52 | let transient = TL.make ~start_date ~project ~sector ~label () in 53 | save (module H) file transient 54 | ;; 55 | 56 | let rewrite 57 | (module H : Eff.HANDLER) 58 | ctx 59 | ~index 60 | ~date_query 61 | ~project 62 | ~sector 63 | ~label 64 | = 65 | let now = Kohai_model.Context.now ctx in 66 | let start_date = Datetime.Query.resolve now date_query in 67 | let transient = TL.make ~start_date ~project ~sector ~label () in 68 | update_by_index (module H) ~index (fun _ -> transient) 69 | ;; 70 | 71 | let stop_record (module H : Eff.HANDLER) ctx ~index ~duration = 72 | let now = Kohai_model.Context.now ctx in 73 | update_by_index 74 | (module H) 75 | ~index 76 | (fun tl -> TL.finalize_duration now tl duration) 77 | ;; 78 | 79 | let delete (module H : Eff.HANDLER) ~index = 80 | let cwd = Global.ensure_supervision (module H) () in 81 | let file = Kohai_model.Resolver.transient_logs ~cwd in 82 | let transients = 83 | (module H) |> all |> List.filter (fun tl -> not (TL.has_index index tl)) 84 | in 85 | dump_transients (module H) transients file 86 | ;; 87 | 88 | let add_kv f (module H : Eff.HANDLER) ~index ~key ~value = 89 | update_by_index (module H) ~index (f ~key ~value) 90 | ;; 91 | 92 | let remove_kv f (module H : Eff.HANDLER) ~index ~key = 93 | update_by_index (module H) ~index (f ~key) 94 | ;; 95 | 96 | let add_meta = add_kv TL.add_meta 97 | let remove_meta = remove_kv TL.remove_meta 98 | let add_link = add_kv TL.add_link 99 | let remove_link = remove_kv TL.remove_link 100 | 101 | let duplicate (module H : Eff.HANDLER) ~index = 102 | let cwd = Global.ensure_supervision (module H) () in 103 | let file = Kohai_model.Resolver.transient_logs ~cwd in 104 | match get (module H) index with 105 | | None -> Eff.raise (module H) (Error.no_related_transient_log ~index ()) 106 | | Some log -> 107 | let new_log = TL.duplicate log in 108 | save (module H) file new_log 109 | ;; 110 | -------------------------------------------------------------------------------- /lib/model/transient_log.mli: -------------------------------------------------------------------------------- 1 | (** Transient logs are logs that are stored temporarily before being 2 | reviewed and promoted to regular logs. (Allowing you to record 3 | only the minimum and then assign additional operations to them). *) 4 | 5 | (** {1 Types} *) 6 | 7 | (** Describing a transient log. *) 8 | type t 9 | 10 | (** Describing a result after inserting a new log. *) 11 | type result 12 | 13 | (** A type describing the operations that can be applied to transient 14 | logs. *) 15 | type operation = private 16 | | Record of 17 | { date_query : Datetime.Query.t option 18 | ; project : string option 19 | ; sector : string 20 | ; label : string 21 | } 22 | | Stop_recording of 23 | { index : int 24 | ; duration : int option 25 | } 26 | | Rewrite of 27 | { index : int 28 | ; date_query : Datetime.Query.t option 29 | ; project : string option 30 | ; sector : string 31 | ; label : string 32 | } 33 | | Delete of { index : int } 34 | | Add_meta of 35 | { index : int 36 | ; key : string 37 | ; value : string 38 | } 39 | | Remove_meta of 40 | { index : int 41 | ; key : string 42 | } 43 | | Add_link of 44 | { index : int 45 | ; key : string 46 | ; value : Url.t 47 | } 48 | | Remove_link of 49 | { index : int 50 | ; key : string 51 | } 52 | | Promote of { index : int } 53 | | Duplicate of { index : int } 54 | 55 | (** {1 API} *) 56 | 57 | (** Build a transient log. *) 58 | val make 59 | : ?meta:string Key_value.t 60 | -> ?links:Url.t Key_value.t 61 | -> ?duration:int 62 | -> start_date:Datetime.t 63 | -> project:string option 64 | -> sector:string 65 | -> label:string 66 | -> unit 67 | -> t 68 | 69 | val action_delete : int -> operation 70 | 71 | (** [has_index n log] Return [true] if the given log has the given index. *) 72 | val has_index : int -> t -> bool 73 | 74 | (** Converter of transient log to Rensai. *) 75 | val from_rensai : t Rensai.Validation.t 76 | 77 | (** Serialize a transient log. *) 78 | val to_rensai : t Rensai.Ast.conv 79 | 80 | (** Serialize a transient log with relative date. *) 81 | val list_to_rensai : (Datetime.t * t list) Rensai.Ast.conv 82 | 83 | (** Read a list of transient logs from a file content. *) 84 | val from_file_content : string -> t list 85 | 86 | (** Recompute the given log with a potential duration (or a 87 | datetime). *) 88 | val finalize_duration : Datetime.t -> t -> int option -> t 89 | 90 | (** compute a result from an inserted log and the full list of 91 | logs. *) 92 | val to_result : ?inserted:t -> t list -> result 93 | 94 | (** Properly sort and index a list of logs. *) 95 | val sort : t list -> t list 96 | 97 | (** Serialize an insertion result. *) 98 | val result_to_rensai : (Datetime.t * result) Rensai.Ast.conv 99 | 100 | (** Read an operation from a Rensai representation. *) 101 | val operation_from_rensai : operation Rensai.Validation.t 102 | 103 | (** Render a list of transient logs into a string to be stored in a file. *) 104 | val dump : result -> string 105 | 106 | (** Add complementary metadata. *) 107 | val add_meta : key:string -> value:string -> t -> t 108 | 109 | (** Remove complementary metadata. *) 110 | val remove_meta : key:string -> t -> t 111 | 112 | (** Add complementary link. *) 113 | val add_link : key:string -> value:Url.t -> t -> t 114 | 115 | (** Remove complementary link. *) 116 | val remove_link : key:string -> t -> t 117 | 118 | (** Duplicate a log *) 119 | val duplicate : t -> t 120 | 121 | (** {1 Accessors} *) 122 | 123 | val start_date : t -> Datetime.t 124 | val duration : t -> Duration.t option 125 | val project : t -> string option 126 | val sector : t -> string 127 | val label : t -> string 128 | val meta : t -> string Key_value.t 129 | val links : t -> Url.t Key_value.t 130 | val string_repr : t -> string 131 | 132 | (** {1 Result as a call-API} *) 133 | 134 | module Expanded : sig 135 | val as_list : Context.t -> t list Rensai.Ast.conv 136 | val as_result : Context.t -> result Rensai.Ast.conv 137 | end 138 | -------------------------------------------------------------------------------- /lib/rensai/sigs.mli: -------------------------------------------------------------------------------- 1 | (** {1 Inputs} *) 2 | 3 | module type DUMPABLE = sig 4 | type t 5 | 6 | val pp : Format.formatter -> t -> unit 7 | end 8 | 9 | module type EQUATABLE = sig 10 | include DUMPABLE 11 | 12 | val equal : t -> t -> bool 13 | end 14 | 15 | module type COMPARABLE = sig 16 | include DUMPABLE 17 | 18 | val compare : t -> t -> int 19 | end 20 | 21 | module type NUMBER = sig 22 | include COMPARABLE 23 | 24 | val one : t 25 | val zero : t 26 | end 27 | 28 | (** {1 Outputs} *) 29 | 30 | module type SIMPLE_VALIDATOR = sig 31 | type t 32 | type error 33 | 34 | (** [where ?message predicate x] ensure that [x] is satisfying 35 | [predicate]. [message] is used for error-reporting. *) 36 | val where 37 | : ?message:((Format.formatter -> t -> unit) -> t -> string) 38 | -> (t -> bool) 39 | -> t 40 | -> (t, error) result 41 | 42 | (** [unless ?message predicate x] ensure that [x] is not satisfying 43 | [predicate]. [message] is used for error-reporting. *) 44 | val unless 45 | : ?message:((Format.formatter -> t -> unit) -> t -> string) 46 | -> (t -> bool) 47 | -> t 48 | -> (t, error) result 49 | 50 | (** [refute ?message validator] invalid a validator. *) 51 | val refute 52 | : ?message:((Format.formatter -> t -> unit) -> t -> string) 53 | -> (t -> (t, error) result) 54 | -> t 55 | -> (t, error) result 56 | end 57 | 58 | module type EQUATABLE_VALIDATOR = sig 59 | type t 60 | type error 61 | 62 | (** [equal a b] ensure that [a] = [b]. *) 63 | val equal : t -> t -> (t, error) result 64 | 65 | (** [not_equal a b] ensure that [a] <> [b]. *) 66 | val not_equal : t -> t -> (t, error) result 67 | 68 | (** [one_of list x] ensure that [x] is present in [list]. *) 69 | val one_of : t list -> t -> (t, error) result 70 | end 71 | 72 | module type COMPARABLE_VALIDATOR = sig 73 | type t 74 | type error 75 | 76 | (** [greater ~than:a b] ensure that [a < b]. *) 77 | val greater : than:t -> t -> (t, error) result 78 | 79 | (** [greater_or_equal ~than:a b] ensure that [a <= b]. *) 80 | val greater_or_equal : than:t -> t -> (t, error) result 81 | 82 | (** [less ~than:a b] ensure that [a > b]. *) 83 | val less : than:t -> t -> (t, error) result 84 | 85 | (** [less_or_equal ~than:a b] ensure that [a >= b]. *) 86 | val less_or_equal : than:t -> t -> (t, error) result 87 | 88 | (** [in_range ~min ~max a] ensure that 89 | [a >= min] and [a < max], [a <- [min; max]]. *) 90 | val in_range : min:t -> max:t -> t -> (t, error) result 91 | 92 | (** [outside_range ~min ~max a] ensure that 93 | [a < min] and [a > max], [a <- [min; max]]. *) 94 | val outside_range : min:t -> max:t -> t -> (t, error) result 95 | end 96 | 97 | module type NUMBER_VALIDATOR = sig 98 | type t 99 | type error 100 | 101 | (** [is_null x] ensure that [x] is null. *) 102 | val is_null : t -> (t, error) result 103 | 104 | (** [is_null x] ensure that [x] is not null. *) 105 | val is_not_null : t -> (t, error) result 106 | 107 | (** [is_null x] ensure that [x] is positive. *) 108 | val is_positive : t -> (t, error) result 109 | 110 | (** [is_null x] ensure that [x] is negative. *) 111 | val is_negative : t -> (t, error) result 112 | end 113 | 114 | module type COMPLETE_VALIDATOR = sig 115 | type t 116 | type error 117 | 118 | (** @inline *) 119 | include SIMPLE_VALIDATOR with type t := t and type error := error 120 | 121 | (** @inline *) 122 | include EQUATABLE_VALIDATOR with type t := t and type error := error 123 | 124 | (** @inline *) 125 | include COMPARABLE_VALIDATOR with type t := t and type error := error 126 | end 127 | 128 | module type COMPLETE_NUMBER_VALIDATOR = sig 129 | type t 130 | type error 131 | 132 | (** @inline *) 133 | include SIMPLE_VALIDATOR with type t := t and type error := error 134 | 135 | (** @inline *) 136 | include EQUATABLE_VALIDATOR with type t := t and type error := error 137 | 138 | (** @inline *) 139 | include COMPARABLE_VALIDATOR with type t := t and type error := error 140 | 141 | (** @inline *) 142 | include NUMBER_VALIDATOR with type t := t and type error := error 143 | end 144 | -------------------------------------------------------------------------------- /lib/interaction/action/log.ml: -------------------------------------------------------------------------------- 1 | module L = Kohai_model.Log 2 | 3 | let get (module H : Eff.HANDLER) uuid = 4 | let cwd = Global.ensure_supervision (module H) () in 5 | let uuid = Uuid.to_string uuid in 6 | let file = Path.(Kohai_model.Resolver.all_logs ~cwd / (uuid ^ ".rens")) in 7 | file |> Eff.read_file (module H) |> L.from_file_content |> Result.to_option 8 | ;; 9 | 10 | let update_last_list f dir (module H : Eff.HANDLER) log = 11 | let log_file = Kohai_model.Resolver.last_logs ~cwd:dir in 12 | let set = 13 | log_file 14 | |> Eff.read_file (module H) 15 | |> Uuid.Set.from_file_content 16 | |> f log 17 | |> Uuid.Set.dump 18 | in 19 | Eff.write_file (module H) log_file set 20 | ;; 21 | 22 | let propagate_last_list dir (module H : Eff.HANDLER) = 23 | update_last_list 24 | (fun log set -> 25 | set 26 | |> Uuid.Set.to_list 27 | |> List.filter_map (get (module H)) 28 | |> L.truncate_list log) 29 | dir 30 | (module H) 31 | ;; 32 | 33 | let unpropagate_last_list = 34 | update_last_list (fun log set -> 35 | let id = L.id log in 36 | set |> Uuid.Set.remove id) 37 | ;; 38 | 39 | let update_set f dir (module H : Eff.HANDLER) log = 40 | let folder = Kohai_model.Resolver.logs ~cwd:dir in 41 | let log_id = L.id log in 42 | let file = L.find_file_by_month ~cwd:folder log in 43 | let set = 44 | file 45 | |> Eff.read_file (module H) 46 | |> Uuid.Set.from_file_content 47 | |> f ~id:log_id 48 | in 49 | let content = Uuid.Set.dump set in 50 | Eff.write_file (module H) file content 51 | ;; 52 | 53 | let unpropagate_from = update_set (fun ~id -> Uuid.Set.remove id) 54 | let propagate_into = update_set (fun ~id -> Uuid.Set.push id) 55 | 56 | let update_propagation f dir (module H : Eff.HANDLER) log = 57 | let sector, project = L.sector_and_project log in 58 | [ f dir; f Path.(Kohai_model.Resolver.sector_folder ~cwd:dir / sector) ] 59 | @ List.map 60 | (fun project -> 61 | f Path.(Kohai_model.Resolver.project_folder ~cwd:dir / project)) 62 | (Option.to_list project) 63 | |> List.iter (fun f -> f (module H : Eff.HANDLER) log) 64 | ;; 65 | 66 | let make_propagation logs list state (module H : Eff.HANDLER) dir log = 67 | [ update_propagation logs; update_propagation list; state ] 68 | |> List.iter (fun f -> f dir (module H : Eff.HANDLER) log) 69 | ;; 70 | 71 | let propagate = 72 | make_propagation propagate_into propagate_last_list State.upgrade 73 | ;; 74 | 75 | let unpropagate = 76 | make_propagation unpropagate_from unpropagate_last_list State.downgrade 77 | ;; 78 | 79 | let promote (module H : Eff.HANDLER) transient_log = 80 | let cwd = Global.ensure_supervision (module H) () in 81 | transient_log 82 | |> L.from_transient_log 83 | |> Option.map (fun log -> 84 | let log_file = L.find_file ~cwd:(Kohai_model.Resolver.all_logs ~cwd) log in 85 | let content = Rensai.Lang.dump L.to_rensai log in 86 | let () = Eff.write_file (module H) log_file content in 87 | propagate (module H) cwd log) 88 | ;; 89 | 90 | let unpromote (module H : Eff.HANDLER) uuid = 91 | let cwd = Global.ensure_supervision (module H) () in 92 | uuid 93 | |> get (module H) 94 | |> Option.map (fun log -> 95 | let log_cwd = Kohai_model.Resolver.all_logs ~cwd in 96 | let log_file = Kohai_model.Log.find_file ~cwd:log_cwd log in 97 | let transient = Kohai_model.Log.to_transient_log log in 98 | let () = unpropagate (module H) cwd log in 99 | let () = Eff.delete (module H) log_file in 100 | transient) 101 | ;; 102 | 103 | let last_by_cwd (module H : Eff.HANDLER) cwd = 104 | let file = Kohai_model.Resolver.last_logs ~cwd in 105 | file 106 | |> Eff.read_file (module H) 107 | |> Uuid.Set.from_file_content 108 | |> Uuid.Set.to_list 109 | |> List.filter_map (get (module H)) 110 | |> L.sort 111 | ;; 112 | 113 | let last (module H : Eff.HANDLER) () = 114 | let cwd = Global.ensure_supervision (module H) () in 115 | last_by_cwd (module H) cwd 116 | ;; 117 | 118 | let last_for_sector (module H : Eff.HANDLER) sector = 119 | let cwd = Global.ensure_supervision (module H) () in 120 | let sector = Path.(Kohai_model.Resolver.sector_folder ~cwd / sector) in 121 | last_by_cwd (module H) sector 122 | ;; 123 | 124 | let last_for_project (module H : Eff.HANDLER) project = 125 | let cwd = Global.ensure_supervision (module H) () in 126 | let project = Path.(Kohai_model.Resolver.project_folder ~cwd / project) in 127 | last_by_cwd (module H) project 128 | ;; 129 | -------------------------------------------------------------------------------- /test/rensai/kind_pretty_printer_test.ml: -------------------------------------------------------------------------------- 1 | let dump rensai_expr = 2 | rensai_expr 3 | |> Rensai.Kind.classify 4 | |> Format.asprintf "%a" Rensai.Kind.pp 5 | |> print_endline 6 | ;; 7 | 8 | open Rensai.Ast 9 | 10 | let%expect_test "pretty print kind of null" = 11 | let expr = null () in 12 | dump expr; 13 | [%expect {| null |}] 14 | ;; 15 | 16 | let%expect_test "pretty print kind of unit" = 17 | let expr = unit () in 18 | dump expr; 19 | [%expect {| unit |}] 20 | ;; 21 | 22 | let%expect_test "pretty print kind of false" = 23 | let expr = bool false in 24 | dump expr; 25 | [%expect {| bool |}] 26 | ;; 27 | 28 | let%expect_test "pretty print kind of true" = 29 | let expr = bool true in 30 | dump expr; 31 | [%expect {| bool |}] 32 | ;; 33 | 34 | let%expect_test "pretty print kind of a char" = 35 | let expr = char 'x' in 36 | dump expr; 37 | [%expect {| char |}] 38 | ;; 39 | 40 | let%expect_test "pretty print kind of an int" = 41 | let expr = int 42 in 42 | dump expr; 43 | [%expect {| int |}] 44 | ;; 45 | 46 | let%expect_test "pretty print kind of an int32" = 47 | let expr = int32 42l in 48 | dump expr; 49 | [%expect {| int32 |}] 50 | ;; 51 | 52 | let%expect_test "pretty print kind of an int64" = 53 | let expr = int64 42L in 54 | dump expr; 55 | [%expect {| int64 |}] 56 | ;; 57 | 58 | let%expect_test "pretty print kind of a float" = 59 | let expr = float 42.12 in 60 | dump expr; 61 | [%expect {| float |}] 62 | ;; 63 | 64 | let%expect_test "pretty print kind of a string" = 65 | let expr = string "foo" in 66 | dump expr; 67 | [%expect {| string |}] 68 | ;; 69 | 70 | let%expect_test "pretty print kind of a pair" = 71 | let expr = pair' int string 10 "foo" in 72 | dump expr; 73 | [%expect {| (int, string) |}] 74 | ;; 75 | 76 | let%expect_test "pretty print kind of an other pair" = 77 | let expr = quad' int string bool unit 10 "foo" true () in 78 | dump expr; 79 | [%expect {| (int, (string, (bool, unit))) |}] 80 | ;; 81 | 82 | let%expect_test "pretty print kind a regular list" = 83 | let expr = list int [ 1; 2; 3; 4 ] in 84 | dump expr; 85 | [%expect {| list |}] 86 | ;; 87 | 88 | let%expect_test "pretty print kind an other regular list" = 89 | let expr = hlist [ int 1; int 2; int 3 ] in 90 | dump expr; 91 | [%expect {| list |}] 92 | ;; 93 | 94 | let%expect_test "pretty print kind an irregular list" = 95 | let expr = hlist [ int 1; int 2; int 3; float 32.5; int64 4L; bool false ] in 96 | dump expr; 97 | [%expect 98 | {| 99 | list 101 | |}] 102 | ;; 103 | 104 | let%expect_test "pretty print kind a constructor" = 105 | let expr = 106 | constr 107 | (function 108 | | `Foo x -> "foo", int x) 109 | (`Foo 10) 110 | in 111 | dump expr; 112 | [%expect {| foo(int) |}] 113 | ;; 114 | 115 | let%expect_test "Avoid everything using the sad record type!" = 116 | let expr = 117 | record 118 | [ "age", option int (Some 42) 119 | ; "activated", either string int (Left "foo") 120 | ; ( "sub" 121 | , record 122 | [ "is_valid", result bool bool (Error false) 123 | ; ( "a_long_string" 124 | , string 125 | "Vivamus quis felis sit amet nunc pretium aliquet. \ 126 | Suspendisse a magna ut nisl sodales blandit sed et mi. \ 127 | Quisque fermentum hendrerit lectus ac pulvinar. Duis \ 128 | euismod magna et magna convallis viverra. Pellentesque \ 129 | laoreet luctus pellentesque. Sed sagittis viverra leo, quis \ 130 | auctor nisi cursus ac. Nam cursus urna et tincidunt \ 131 | gravida. Ut eget ipsum in massa sagittis vestibulum eget at \ 132 | est. Vestibulum bibendum mattis quam, sit amet tincidunt \ 133 | ligula. Aliquam at tempus augue. Aenean ac est urna. Nullam \ 134 | iaculis, dolor i" ) 135 | ; ( "another_random_list" 136 | , list 137 | (fun x -> 138 | record 139 | [ "x", string x 140 | ; "up", string (String.uppercase_ascii x) 141 | ]) 142 | (List.init 43 (fun i -> String.make i 'a')) ) 143 | ] ) 144 | ; "a_random_list", list int (List.init 320 Fun.id) 145 | ] 146 | in 147 | dump expr; 148 | [%expect {| ?record |}] 149 | ;; 150 | -------------------------------------------------------------------------------- /lib/core/error.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Parse_error of { body : string } 3 | | Invalid_request of 4 | { body : string 5 | ; error : Rensai.Validation.value_error 6 | } 7 | | Method_not_found of 8 | { body : string 9 | ; id : int option 10 | ; meth : string 11 | } 12 | | Invalid_params of 13 | { body : string 14 | ; id : int option 15 | ; error : Rensai.Validation.value_error 16 | } 17 | | Internal_error of 18 | { body : string 19 | ; id : int option 20 | ; message : string 21 | } 22 | | Custom_error of 23 | { body : string 24 | ; id : int option 25 | ; code : int 26 | ; message : string option 27 | } 28 | 29 | type custom = 30 | | Unknown_error of string 31 | | No_supervised_directory 32 | | Supervised_directory_error of string 33 | | Invalid_datetime of 34 | { value : float 35 | ; error : Rensai.Validation.value_error 36 | } 37 | | Resource_not_found of 38 | { index : string 39 | ; subject : string 40 | ; code : int 41 | } 42 | 43 | let parse_error ~body () = Parse_error { body } 44 | let invalid_request ~body ~error () = Invalid_request { body; error } 45 | let method_not_found ~body ?id ~meth () = Method_not_found { body; id; meth } 46 | let invalid_params ~body ?id ~error () = Invalid_params { body; id; error } 47 | let internal_error ~body ?id ~message () = Internal_error { body; id; message } 48 | 49 | let custom_error ?(with_offset = true) ~body ?id ?(code = 0) ?message () = 50 | Custom_error 51 | { body; id; code = (if with_offset then code + 32000 else code); message } 52 | ;; 53 | 54 | let invalid_datetime value error = Invalid_datetime { value; error } 55 | let unknown_error ~message () = Unknown_error message 56 | let no_supervised_directory () = No_supervised_directory 57 | let supervised_directory_error ~message () = Supervised_directory_error message 58 | 59 | let resource_not_found ~index ~subject ~code () = 60 | Resource_not_found { index; subject; code } 61 | ;; 62 | 63 | let no_related_transient_log ~index () = 64 | resource_not_found 65 | ~index:(string_of_int index) 66 | ~subject:"transient log" 67 | ~code:0 68 | () 69 | ;; 70 | 71 | let no_related_log ~uuid () = 72 | resource_not_found ~index:(Uuid.to_string uuid) ~subject:"log" ~code:1 () 73 | ;; 74 | 75 | let custom_to_jsonrpc ~body ?id = function 76 | | Unknown_error message -> custom_error ~body ?id ~code:99 ~message () 77 | | No_supervised_directory -> 78 | custom_error 79 | ~body 80 | ?id 81 | ~code:0 82 | ~message:"No supervised directory for the current session" 83 | () 84 | | Supervised_directory_error message -> 85 | custom_error ~body ?id ~code:1 ~message () 86 | | Invalid_datetime { value; error } -> 87 | custom_error 88 | ~body 89 | ?id 90 | ~code:2 91 | ~message: 92 | (Format.asprintf 93 | "%f is not a valid datetime for %a" 94 | value 95 | Rensai.Validation.pp_value_error 96 | error) 97 | () 98 | | Resource_not_found { index; subject; code } -> 99 | custom_error 100 | ~body 101 | ?id 102 | ~code:(10 + code) 103 | ~message:(Format.asprintf "[%s#%s] not found" subject index) 104 | () 105 | ;; 106 | 107 | let mk_error = Rensai.Validation.value_error_ast 108 | let mk_string = Rensai.Ast.string 109 | let opt_string = Option.map mk_string 110 | 111 | let result ?id ?data ~body ~code message = 112 | let open Rensai.Ast in 113 | record 114 | [ "jsonrpc", string "2.0" 115 | ; "id", option int id 116 | ; ( "error" 117 | , record 118 | [ "code", int (0 - abs code) 119 | ; "message", string message 120 | ; "data", option Fun.id data 121 | ; "body", string body 122 | ] ) 123 | ] 124 | ;; 125 | 126 | let jsonrpc_to_rensai = function 127 | | Parse_error { body } -> result ~body ~code:32700 "Parse error" 128 | | Invalid_request { body; error } -> 129 | result ~body ~code:32600 ~data:(mk_error error) "Invalid request" 130 | | Method_not_found { body; id; meth } -> 131 | result ~body ~code:32601 ?id ~data:(mk_string meth) "Method not found" 132 | | Invalid_params { body; id; error } -> 133 | result ~body ?id ~code:32602 ~data:(mk_error error) "Invalid params" 134 | | Internal_error { body; id; message } -> 135 | result ~body ?id ~code:32603 ~data:(mk_string message) "Internal error" 136 | | Custom_error { body; id; code; message } -> 137 | result ~body ?id ~code ?data:(opt_string message) "Server error" 138 | ;; 139 | 140 | let to_rensai = jsonrpc_to_rensai 141 | -------------------------------------------------------------------------------- /site-lisp/kohai.el: -------------------------------------------------------------------------------- 1 | ;;; kohai.el --- A strange timetracker -*- coding: utf-8; lexical-binding: t -*- 2 | 3 | ;; Copyright (C) since 2025 Xavier Van de Woestyne 4 | ;; Licensed under the MIT license. 5 | 6 | ;; Author: Xavier Van de Woestyne 7 | 8 | ;; This file is NOT part of GNU Emac 9 | 10 | ;; Maintainer: Xavier Van de Woestyne 11 | ;; Created: 24 January 2025 12 | ;; Keywords: tool timetracker productivity 13 | ;; URL: https://github.com/xvw/kohai 14 | ;; Package-Requires: ((emacs "29.1")) 15 | ;; Package-Version: 0.1 16 | ;; SPDX-License-Identifier: MIT 17 | 18 | ;;; Commentary: 19 | 20 | ;; A client for the Kohai server in order to manage timetracking from Emacs 21 | 22 | ;;; Code: 23 | 24 | (require 'cl-lib) 25 | (require 'jsonrpc) 26 | (require 'rensai-mode) 27 | (require 'kohai-core) 28 | (require 'kohai-req) 29 | (require 'kohai-sector) 30 | (require 'kohai-project) 31 | (require 'kohai-transient-log) 32 | (require 'kohai-transient) 33 | (require 'kohai-state) 34 | 35 | ;;; Features 36 | 37 | (defun kohai-set-supervised () 38 | "Set interactively the current supervised directory." 39 | (interactive) 40 | (kohai--ensure-connection) 41 | (let* ((directories 42 | (apply-partially #'completion-table-with-predicate 43 | #'completion-file-name-table 44 | #'file-directory-p 45 | 'strict)) 46 | (dir-completion (completion-table-in-turn directories)) 47 | (chosen-directory (completing-read "Supervised directory: " 48 | dir-completion)) 49 | (absolute-path (expand-file-name chosen-directory))) 50 | (kohai-req--supervised-set absolute-path) 51 | (setq kohai-supervised absolute-path) 52 | (customize-save-variable 'kohai-supervised absolute-path) 53 | (kohai--message-supervised absolute-path))) 54 | 55 | (defun kohai-get-supervised () 56 | "Display, in the minibuffer, the current supervised directory." 57 | (interactive) 58 | (kohai--ensure-connection) 59 | (let ((supervised (kohai-req--supervised-get))) 60 | (kohai--message-supervised supervised))) 61 | 62 | (defun kohai-list-sectors () 63 | "Fill the sector's buffer." 64 | (interactive) 65 | (kohai--ensure-supervision) 66 | (kohai-sector--list) 67 | (pop-to-buffer kohai-sectors-buffer-name)) 68 | 69 | (defun kohai-new-sector () 70 | "Save a new sector." 71 | (interactive) 72 | (kohai--ensure-supervision) 73 | (kohai-sector--new)) 74 | 75 | (defun kohai-edit-sector () 76 | "Edit sector's description." 77 | (interactive) 78 | (kohai--ensure-supervision) 79 | (let ((sector-name (kohai-sector--ac nil t))) 80 | (kohai-sector--update-desc sector-name) 81 | (pop-to-buffer kohai-sectors-buffer-name))) 82 | 83 | 84 | (defun kohai-list-projects () 85 | "Fill the project's buffer." 86 | (interactive) 87 | (kohai--ensure-supervision) 88 | (kohai-project--list) 89 | (pop-to-buffer kohai-projects-buffer-name)) 90 | 91 | (defun kohai-new-project () 92 | "Save a new project." 93 | (interactive) 94 | (kohai--ensure-supervision) 95 | (kohai-project--new)) 96 | 97 | (defun kohai-edit-project () 98 | "Edit project's description." 99 | (interactive) 100 | (kohai--ensure-supervision) 101 | (let ((project-name (kohai-project--ac nil t))) 102 | (kohai-project--update-desc project-name) 103 | (pop-to-buffer kohai-projects-buffer-name))) 104 | 105 | (defun kohai-list-transient-log () 106 | "Fill the transient-log's buffer." 107 | (interactive) 108 | (kohai--ensure-supervision) 109 | (kohai-transient-log--list) 110 | (pop-to-buffer kohai-transient-logs-buffer-name)) 111 | 112 | (defun kohai-record-transient-log () 113 | "Record a transient log." 114 | (interactive) 115 | (kohai--ensure-supervision) 116 | (kohai-transient-log--record) 117 | (pop-to-buffer kohai-transient-logs-buffer-name)) 118 | 119 | (defun kohai-get-state () 120 | "Display the current state of the supervised directory." 121 | (interactive) 122 | (kohai--ensure-supervision) 123 | (kohai-state--get)) 124 | 125 | (defun kohai-get-state-by-sector () 126 | "Display the current state of the supervised directory of a given sector." 127 | (interactive) 128 | (kohai--ensure-supervision) 129 | (kohai-state--get-by-sector)) 130 | 131 | (defun kohai-get-state-by-project () 132 | "Display the current state of the supervised directory of a given project." 133 | (interactive) 134 | (kohai--ensure-supervision) 135 | (kohai-state--get-by-project)) 136 | 137 | (defun kohai () 138 | "Launch Kohai." 139 | (interactive) 140 | (when (not kohai--connection) (kohai-req--make-connection)) 141 | (if (and kohai-supervised (not (string-blank-p kohai-supervised))) 142 | (progn (kohai-req--supervised-set kohai-supervised) 143 | (kohai--message-supervised kohai-supervised) 144 | (call-interactively #'kohai-transient--dashboard)) 145 | (call-interactively #'kohai-set-supervised))) 146 | 147 | (provide 'kohai) 148 | ;;; kohai.el ends here 149 | -------------------------------------------------------------------------------- /lib/model/log.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { start_date : Datetime.t 3 | ; duration : Duration.t 4 | ; project : string option 5 | ; sector : string 6 | ; label : string 7 | ; meta : string Key_value.t 8 | ; links : Url.t Key_value.t 9 | ; id : Uuid.t 10 | } 11 | 12 | let label { label; _ } = label 13 | let meta { meta; _ } = meta 14 | let links { links; _ } = links 15 | 16 | let make 17 | ~start_date 18 | ~duration 19 | ?project 20 | ~sector 21 | ~label 22 | ?(meta = Key_value.empty ()) 23 | ?(links = Key_value.empty ()) 24 | ~id 25 | () 26 | = 27 | { start_date; duration; project; sector; label; meta; links; id } 28 | ;; 29 | 30 | let id { id; _ } = id 31 | let sector_and_project { sector; project; _ } = sector, project 32 | let start_date { start_date; _ } = start_date 33 | let end_date { start_date; duration; _ } = Datetime.(start_date + dur duration) 34 | let duration { duration; _ } = duration 35 | 36 | let add_meta ~key ~value log = 37 | { log with meta = Key_value.add key value log.meta } 38 | ;; 39 | 40 | let add_link ~key ~value log = 41 | { log with links = Key_value.add key value log.links } 42 | ;; 43 | 44 | let remove_meta ~key log = { log with meta = Key_value.remove key log.meta } 45 | let remove_link ~key log = { log with links = Key_value.remove key log.links } 46 | 47 | let from_transient_log tl = 48 | tl 49 | |> Transient_log.duration 50 | |> Option.map (fun duration -> 51 | let start_date = Transient_log.start_date tl 52 | and project = Transient_log.project tl 53 | and sector = Transient_log.sector tl 54 | and label = Transient_log.label tl 55 | and meta = Transient_log.meta tl 56 | and links = Transient_log.links tl 57 | and id = Uuid.gen (Transient_log.string_repr tl) in 58 | { start_date; duration; project; sector; label; meta; links; id }) 59 | ;; 60 | 61 | let to_transient_log 62 | { start_date; project; sector; label; meta; links; duration; _ } 63 | = 64 | Transient_log.make 65 | ~meta 66 | ~duration:(Duration.to_int duration) 67 | ~links 68 | ~start_date 69 | ~project 70 | ~sector 71 | ~label 72 | () 73 | ;; 74 | 75 | let slug = Rensai.Validation.(string & String.is_non_empty_slug) 76 | let positive_int = Rensai.Validation.(int & Int.is_positive) 77 | 78 | let from_rensai = 79 | let open Rensai.Validation in 80 | record (fun b -> 81 | let open Record in 82 | let+ start_date = required b "start_date" Datetime.from_rensai 83 | and+ id = required b "id" Uuid.from_rensai 84 | and+ project = optional b "project" slug 85 | and+ duration = required b "duration" (positive_int $ Duration.from_int) 86 | and+ sector = required b "sector" slug 87 | and+ label = required b "label" (string & String.is_not_blank) 88 | and+ meta = 89 | optional_or 90 | ~default:(Key_value.empty ()) 91 | b 92 | "meta" 93 | (Key_value.from_rensai string) 94 | and+ links = 95 | optional_or 96 | ~default:(Key_value.empty ()) 97 | b 98 | "links" 99 | (Key_value.from_rensai Url.from_rensai) 100 | in 101 | { start_date; duration; project; sector; label; meta; links; id }) 102 | ;; 103 | 104 | let to_rensai_record 105 | { start_date; duration; project; sector; label; meta; links; id } 106 | = 107 | let open Rensai.Ast in 108 | [ "start_date", Datetime.to_compact_rensai start_date 109 | ; "id", Uuid.to_rensai id 110 | ; "duration", Duration.to_rensai duration 111 | ; "project", option string project 112 | ; "sector", string sector 113 | ; "label", string label 114 | ; "meta", Key_value.to_rensai string meta 115 | ; "links", Key_value.to_rensai Url.to_compact_rensai links 116 | ] 117 | ;; 118 | 119 | let to_rensai log = log |> to_rensai_record |> Rensai.Ast.record 120 | 121 | let duration_repr duration = 122 | duration |> Format.asprintf "%a" Duration.pp |> Rensai.Ast.string 123 | ;; 124 | 125 | let return_rensai (now, ({ start_date; duration; _ } as log)) = 126 | let open Rensai.Ast in 127 | record 128 | (("duration_repr", duration_repr duration) 129 | :: ( "start_date_repr" 130 | , string (Format.asprintf "%a" (Datetime.pp_relative now) start_date) ) 131 | :: to_rensai_record log) 132 | ;; 133 | 134 | let list_to_rensai (now, logs) = 135 | Rensai.Ast.list (fun x -> return_rensai (now, x)) logs 136 | ;; 137 | 138 | let from_file_content content = 139 | let lexbuf = Lexing.from_string content in 140 | lexbuf |> Rensai.Lang.from_lexingbuf_or_null |> from_rensai 141 | ;; 142 | 143 | let find_file_by_month ~cwd { start_date; _ } = 144 | Datetime.as_month_file ~ext:"rens" ~cwd start_date 145 | ;; 146 | 147 | let find_file ~cwd { id; _ } = 148 | let fragment = Uuid.to_string id ^ ".rens" in 149 | Path.(cwd / fragment) 150 | ;; 151 | 152 | let ord_log a b = 153 | let c = Datetime.compare b.start_date a.start_date in 154 | if Int.equal 0 c then Duration.compare b.duration a.duration else c 155 | ;; 156 | 157 | let sort list = list |> List.sort ord_log 158 | 159 | let truncate_list ?(len = 50) log list = 160 | log :: list |> sort |> List.take len |> List.map id |> Uuid.Set.from_list 161 | ;; 162 | 163 | module Expanded = struct 164 | let as_list ctx list = 165 | let now = Context.now ctx in 166 | list_to_rensai (now, list) 167 | ;; 168 | 169 | let as_single ctx result = 170 | let now = Context.now ctx in 171 | return_rensai (now, result) 172 | ;; 173 | 174 | let as_option ctx = Rensai.Ast.option (as_single ctx) 175 | end 176 | -------------------------------------------------------------------------------- /site-lisp/kohai-state.el: -------------------------------------------------------------------------------- 1 | ;;; kohai-core.el --- Display information about the current state of a Kohai directory -*- coding: utf-8; lexical-binding: t -*- 2 | 3 | ;; Copyright (C) since 2025 Xavier Van de Woestyne 4 | ;; Licensed under the MIT license. 5 | 6 | ;; Author: Xavier Van de Woestyne 7 | 8 | ;; This file is NOT part of GNU Emac 9 | 10 | ;; Maintainer: Xavier Van de Woestyne 11 | ;; Created: 13 February 2025 12 | ;; Keywords: tool timetracker productivity 13 | ;; URL: https://github.com/xvw/kohai 14 | ;; Package-Requires: ((emacs "29.1")) 15 | ;; Package-Version: 0.1 16 | ;; SPDX-License-Identifier: MIT 17 | 18 | ;;; Commentary: 19 | 20 | ;; Tool to deal with Kohai States 21 | 22 | ;;; Code: 23 | 24 | (require 'cl-lib) 25 | (require 'vtable) 26 | (require 'kohai-core) 27 | (require 'kohai-req) 28 | (require 'kohai-buffer) 29 | (require 'kohai-generic) 30 | (require 'kohai-sector) 31 | (require 'kohai-project) 32 | (require 'kohai-transient-log) 33 | 34 | (defun kohai-state--kill-buffer (&optional _) 35 | "Kill buffer related to state." 36 | (kohai-buffer--kill kohai-logs-buffer-name) 37 | (kohai-buffer--kill kohai-state-buffer-name)) 38 | 39 | (defun kohai-state--log-unpromote (uuid) 40 | "Unpromote the log referenced by UUID." 41 | (when (yes-or-no-p (format "Unpromote log %s?" uuid)) 42 | (let ((_ (kohai-req--log-unpromote uuid))) 43 | (kohai-state--kill-buffer) 44 | (kohai-transient-log--list) 45 | (pop-to-buffer kohai-transient-logs-buffer-name)))) 46 | 47 | (defun kohai-state--list-logs-vtable () 48 | "Create a vtable displaying logs." 49 | (lambda (logs) 50 | (make-vtable 51 | :divider-width kohai--vtable-default-divider 52 | :objects (append logs nil) 53 | :columns '("Sector" 54 | "Project" 55 | "Start date" 56 | "Duration" 57 | "Label") 58 | :getter (lambda (o column vtable) 59 | (pcase (vtable-column vtable column) 60 | ("Sector" (kohai--bold (cl-getf o :sector))) 61 | ("Project" (or (cl-getf o :project) "")) 62 | ("Start date" (cl-getf o :start_date_repr)) 63 | ("Duration" (cl-getf o :duration_repr)) 64 | ("Label" (cl-getf o :label)))) 65 | :actions '("u" (lambda (o) (kohai-state--log-unpromote (cl-getf o :id))) 66 | "q" (lambda (_) (kohai-state--kill-buffer)))))) 67 | 68 | (defun kohai-state--list-state-enum () 69 | "Create a vtable displaying state information." 70 | (lambda (state) 71 | (let ((big-bang (cl-getf state :big_bang)) 72 | (end-of-world (cl-getf state :end_of_world)) 73 | (number-of-logs (cl-getf state :number_of_logs)) 74 | (duration (cl-getf state :duration))) 75 | (make-vtable 76 | :divider-width kohai--vtable-default-divider 77 | :columns '("Key" "Value") 78 | :objects (list (list :key "Number of logs" :value number-of-logs) 79 | (list :key "Total duration" :value duration) 80 | (list :key "Start date" :value big-bang) 81 | (list :key "Last date" :value end-of-world)) 82 | :getter (lambda (o column vtable) 83 | (pcase (vtable-column vtable column) 84 | ("Key" (kohai--bold (cl-getf o :key))) 85 | ("Value" (cl-getf o :value)))) 86 | :actions '("q" (lambda (_) (kohai-state--kill-buffer))))))) 87 | 88 | (defun kohai-state--display-state (&optional state logs) 89 | "Display a list of LOGS based and a STATE." 90 | (let* ((current-state (or state (kohai-req--state-get))) 91 | (tail (or logs (kohai-req--log-tail))) 92 | (number-of-logs (or (cl-getf current-state :number_of_logs) 0))) 93 | (kohai--should-not-be-zero number-of-logs 94 | "There is no logs for the current state" 95 | (lambda () (kohai-state--kill-buffer))) 96 | (kohai-generic--vtable "logs" 97 | kohai-logs-buffer-name 98 | tail 99 | (kohai-state--list-logs-vtable)) 100 | (kohai-generic--vtable "state" 101 | kohai-state-buffer-name 102 | current-state 103 | (kohai-state--list-state-enum)))) 104 | 105 | (defun kohai-state--pop-with-side-window () 106 | "Pop the buffer for logs and side window." 107 | (display-buffer kohai-state-buffer-name 108 | '(display-buffer-in-side-window .((side . bottom)))) 109 | (pop-to-buffer kohai-logs-buffer-name)) 110 | 111 | (defun kohai-state--get () 112 | "Get the global state of a supervised directory." 113 | (kohai-state--display-state) 114 | (kohai-state--pop-with-side-window)) 115 | 116 | (defun kohai-state--get-by-sector () 117 | "Get the global state of a supervised directory for a given sector." 118 | (let* ((sector (kohai-sector--ac nil t nil)) 119 | (state (kohai-req--state-get-sector sector)) 120 | (tail (kohai-req--log-tail-sector sector))) 121 | (kohai-state--display-state state tail) 122 | (kohai-state--pop-with-side-window))) 123 | 124 | (defun kohai-state--get-by-project () 125 | "Get the global state of a supervised directory for a given project." 126 | (let* ((project (kohai-project--ac nil t nil)) 127 | (state (kohai-req--state-get-project project)) 128 | (tail (kohai-req--log-tail-project project))) 129 | (kohai-state--display-state state tail) 130 | (kohai-state--pop-with-side-window))) 131 | 132 | (provide 'kohai-state) 133 | ;;; kohai-state.el ends here 134 | -------------------------------------------------------------------------------- /site-lisp/kohai-generic.el: -------------------------------------------------------------------------------- 1 | ;;; kohai-generic.el --- Deal with generic items -*- coding: utf-8; lexical-binding: t -*- 2 | 3 | ;; Copyright (C) since 2025 Xavier Van de Woestyne 4 | ;; Licensed under the MIT license. 5 | 6 | ;; Author: Xavier Van de Woestyne 7 | 8 | ;; This file is NOT part of GNU Emac 9 | 10 | ;; Maintainer: Xavier Van de Woestyne 11 | ;; Created: 13 February 2025 12 | ;; Keywords: tool timetracker productivity 13 | ;; URL: https://github.com/xvw/kohai 14 | ;; Package-Requires: ((emacs "29.1")) 15 | ;; Package-Version: 0.1 16 | ;; SPDX-License-Identifier: MIT 17 | 18 | ;;; Commentary: 19 | 20 | ;;; Some generics utils to deal with generic items 21 | 22 | ;;; Code: 23 | 24 | (require 'vtable) 25 | (require 'kohai-core) 26 | (require 'kohai-req) 27 | (require 'kohai-buffer) 28 | 29 | (defun kohai-generic--vtable (key buffer entries vtable) 30 | "Fill a BUFFER with ENTRIES into a VTABLE (KEY is used for reporting)." 31 | (if (kohai--vector-empty-p entries) 32 | (progn (kohai-buffer--empty buffer t) 33 | (kohai--error-no-entries (format "%s list" key))) 34 | (kohai-buffer--truncate-with 35 | buffer (lambda (_buf) (funcall vtable entries))))) 36 | 37 | (defun kohai-generic--ditem-ac (key &optional entries not-empty default) 38 | "Get ENTRIES (dispatched on KEY) as a completion list. 39 | If NOT-EMPTY the list must be filled. DEFAULT is the default value." 40 | (let ((given-entries (or entries (kohai-req--described-item-list key)))) 41 | (when (and not-empty (kohai--vector-empty-p given-entries)) 42 | (kohai--error-no-entries key)) 43 | (let* ((formatted-entries 44 | (mapcar (lambda (entry) 45 | (let* ((name (cl-getf entry :name)) 46 | (desc (cl-getf entry :description)) 47 | (key (format "%s: %s" (kohai--bold name) desc))) 48 | (cons key name))) 49 | given-entries)) 50 | (selected (completing-read (format "%s: " (capitalize key)) 51 | formatted-entries 52 | nil nil default t))) 53 | (or (alist-get selected formatted-entries nil nil #'equal) selected)))) 54 | 55 | (defun kohai-generic--ditem-save (key buffer name desc) 56 | "Smartly save a ditem (with NAME and DESC) using KEY. 57 | Into BUFFER." 58 | (let ((entries (kohai-req--described-item-save key name desc))) 59 | (kohai--message-stored name key) 60 | (kohai-generic--ditem-list key buffer entries))) 61 | 62 | (defun kohai-generic--ditem-update-desc (key buffer name) 63 | "Update the description of an entry by his NAME using KEY. 64 | In BUFFER." 65 | (let ((entry (kohai-req--described-item-get key name))) 66 | (kohai--should-exists entry key) 67 | (let* ((old-desc (cl-getf entry :description)) 68 | (new-desc (read-string (format "New description (%s): " name) 69 | old-desc))) 70 | (kohai-generic--ditem-save key buffer name new-desc)))) 71 | 72 | (defun kohai-generic--ditem-list-vtable (key buffer) 73 | "Create the vtable displaying ENTRIES using KEY. 74 | In BUFFER, CREATE is used to create a new entry." 75 | (lambda (entries) 76 | (make-vtable :columns '("Name" "Description" "Deleteable") 77 | :divider-width kohai--vtable-default-divider 78 | :objects (append entries nil) 79 | :getter (lambda (o column vtable) 80 | (pcase (vtable-column vtable column) 81 | ("Name" (kohai--bold (cl-getf o :name))) 82 | ("Description" (or (cl-getf o :description) "")) 83 | ("Deleteable" 84 | (if (> (cl-getf o :counter) 0) "X" " ")))) 85 | :actions `("u" ,(lambda (o) 86 | (kohai-generic--ditem-update-desc 87 | key buffer (cl-getf o :name))) 88 | "d" ,(lambda (o) 89 | (kohai-generic--ditem-delete 90 | key buffer (cl-getf o :name))) 91 | "n" ,(lambda (_o) 92 | (kohai-generic--ditem-new key buffer)) 93 | "q" ,(lambda (_o) 94 | (kohai-buffer--kill buffer)))))) 95 | 96 | (defun kohai-generic--ditem-list (key buffer &optional given-entries) 97 | "Return the list of entries (or GIVEN-ENTRIES). 98 | In a dedicated BUFFER using KEY." 99 | (let ((entries (or given-entries (kohai-req--described-item-list key)))) 100 | (kohai-generic--vtable key 101 | buffer 102 | entries 103 | (kohai-generic--ditem-list-vtable key buffer)))) 104 | 105 | (defun kohai-generic--ditem-new (key buffer) 106 | "Save a generic item (defined by KEY) and switch to BUFFER." 107 | (let* ((prefix (capitalize key)) 108 | (name (read-string (format "%s name: " prefix))) 109 | (desc (read-string (format "%s description: " prefix)))) 110 | (kohai-generic--ditem-save key buffer name desc) 111 | (pop-to-buffer buffer))) 112 | 113 | (defun kohai-generic--ditem-delete (key buffer name) 114 | "Delete a generic item NAME (defined by KEY) and switch to BUFFER." 115 | (let ((entry (kohai-req--described-item-get key name))) 116 | (kohai--should-exists entry key) 117 | (kohai--should-be-eraseable entry) 118 | (when (y-or-n-p (format "Delete %s %s? " key name)) 119 | (let ((values (kohai-req--described-item-delete key name))) 120 | (kohai--message-deleted name key) 121 | (kohai-generic--ditem-list key buffer values))))) 122 | 123 | (provide 'kohai-generic) 124 | ;;; kohai-generic.el ends here 125 | -------------------------------------------------------------------------------- /test/server/util.mli: -------------------------------------------------------------------------------- 1 | val request_input : ?id:int -> ?params:string -> string -> string 2 | val request_dump : (Rensai.Ast.t, Kohai_core.Error.t) result -> string 3 | 4 | val print_result 5 | : ?should_fail:bool 6 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 7 | -> unit 8 | 9 | val step 10 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 11 | -> ?should_fail:bool 12 | -> id:int ref 13 | -> ((module Kohai_core.Sigs.EFFECT_HANDLER) 14 | -> id:int ref 15 | -> unit 16 | -> (Rensai.Ast.t, Kohai_core.Error.t) result) 17 | -> unit 18 | 19 | val call 20 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 21 | -> id:int ref 22 | -> ?params:Rensai.Ast.t 23 | -> string 24 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 25 | 26 | val call_supervise 27 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 28 | -> id:int ref 29 | -> path:string 30 | -> unit 31 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 32 | 33 | val call_supervise_get 34 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 35 | -> id:int ref 36 | -> unit 37 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 38 | 39 | val call_state_get 40 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 41 | -> id:int ref 42 | -> unit 43 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 44 | 45 | val call_state_get_for_sector 46 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 47 | -> id:int ref 48 | -> sector:string 49 | -> unit 50 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 51 | 52 | val call_state_get_for_project 53 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 54 | -> id:int ref 55 | -> project:string 56 | -> unit 57 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 58 | 59 | val call_sector_list 60 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 61 | -> id:int ref 62 | -> unit 63 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 64 | 65 | val call_sector_save 66 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 67 | -> id:int ref 68 | -> name:string 69 | -> ?desc:string 70 | -> unit 71 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 72 | 73 | val call_sector_delete 74 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 75 | -> id:int ref 76 | -> name:string 77 | -> unit 78 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 79 | 80 | val call_project_save 81 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 82 | -> id:int ref 83 | -> name:string 84 | -> ?desc:string 85 | -> unit 86 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 87 | 88 | val call_project_list 89 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 90 | -> id:int ref 91 | -> unit 92 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 93 | 94 | val call_project_delete 95 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 96 | -> id:int ref 97 | -> name:string 98 | -> unit 99 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 100 | 101 | val call_transient_log_list 102 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 103 | -> id:int ref 104 | -> unit 105 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 106 | 107 | val call_transient_log_record 108 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 109 | -> id:int ref 110 | -> ?date_query:Kohai_core.Datetime.Query.t 111 | -> ?project:string 112 | -> sector:string 113 | -> label:string 114 | -> unit 115 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 116 | 117 | val call_transient_log_rewrite 118 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 119 | -> id:int ref 120 | -> index:int 121 | -> ?date_query:Kohai_core.Datetime.Query.t 122 | -> ?project:string 123 | -> sector:string 124 | -> label:string 125 | -> unit 126 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 127 | 128 | val call_transient_log_stop_recording 129 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 130 | -> id:int ref 131 | -> index:int 132 | -> ?duration:int 133 | -> unit 134 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 135 | 136 | val call_transient_log_delete 137 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 138 | -> id:int ref 139 | -> index:int 140 | -> unit 141 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 142 | 143 | val call_transient_log_promote 144 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 145 | -> id:int ref 146 | -> index:int 147 | -> unit 148 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 149 | 150 | val call_transient_log_add_meta 151 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 152 | -> id:int ref 153 | -> index:int 154 | -> key:string 155 | -> value:string 156 | -> unit 157 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 158 | 159 | val call_transient_log_add_link 160 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 161 | -> id:int ref 162 | -> index:int 163 | -> key:string 164 | -> value:string 165 | -> unit 166 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 167 | 168 | val call_transient_log_remove_meta 169 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 170 | -> id:int ref 171 | -> index:int 172 | -> key:string 173 | -> unit 174 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 175 | 176 | val call_transient_log_remove_link 177 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 178 | -> id:int ref 179 | -> index:int 180 | -> key:string 181 | -> unit 182 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 183 | 184 | val call_log_last 185 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 186 | -> id:int ref 187 | -> unit 188 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 189 | 190 | val call_log_last_for_sector 191 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 192 | -> id:int ref 193 | -> sector:string 194 | -> unit 195 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 196 | 197 | val call_log_last_for_project 198 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 199 | -> id:int ref 200 | -> project:string 201 | -> unit 202 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 203 | 204 | val call_log_unpromote 205 | : (module Kohai_core.Sigs.EFFECT_HANDLER) 206 | -> id:int ref 207 | -> uuid:string 208 | -> unit 209 | -> (Rensai.Ast.t, Kohai_core.Error.t) result 210 | -------------------------------------------------------------------------------- /test/server/virtfs.ml: -------------------------------------------------------------------------------- 1 | open Kohai_core 2 | 3 | type 'a elt = 4 | { name : string 5 | ; mtime : int 6 | ; content : 'a 7 | } 8 | 9 | type item = 10 | | File of string elt 11 | | Directory of t elt 12 | 13 | and t = item list 14 | 15 | let name_of = function 16 | | File { name; _ } | Directory { name : string; _ } -> name 17 | ;; 18 | 19 | let mtime_of = function 20 | | File { mtime; _ } | Directory { mtime; _ } -> mtime 21 | ;; 22 | 23 | let has_name name elt = String.equal name (name_of elt) 24 | 25 | (* The goal of the comparison function is to be consistent when 26 | creating file system to preserve equality even if we traverse the 27 | full file-tree. *) 28 | let compare_item a b = 29 | let name x = String.lowercase_ascii @@ name_of x in 30 | match a, b with 31 | | File _, File _ | Directory _, Directory _ -> 32 | String.compare (name a) (name b) 33 | | File _, Directory _ -> 1 34 | | Directory _, File _ -> -1 35 | ;; 36 | 37 | let from_list_aux = List.sort compare_item 38 | let file ?(mtime = 0) ?(content = "") name = File { name; mtime; content } 39 | 40 | let dir ?mtime name children = 41 | let mtime = 42 | match mtime with 43 | | None -> 44 | List.fold_left (fun p child -> Int.max p (mtime_of child)) 0 children 45 | | Some x -> x 46 | in 47 | let content = from_list_aux children in 48 | Directory { name; mtime; content } 49 | ;; 50 | 51 | let from_list ?mtime children = [ dir ?mtime "" children ] 52 | 53 | let path_to_list p = 54 | if Path.is_relative p then Path.to_list p else "" :: Path.to_list p 55 | ;; 56 | 57 | let get fs path = 58 | let rec aux fs path = 59 | match fs, path with 60 | | x :: xs, [ p ] -> if has_name p x then Some x else aux xs path 61 | | (Directory { content; _ } as x) :: xs, p :: ps -> 62 | if has_name p x then aux content ps else aux xs path 63 | | _ :: xs, path -> aux xs path 64 | | [], _ -> None 65 | in 66 | aux fs (path_to_list path) 67 | ;; 68 | 69 | let extract_target path = 70 | path 71 | |> Path.as_target 72 | |> Option.map (fun (xs, target) -> 73 | (if Path.is_relative path then xs else "" :: xs), target) 74 | ;; 75 | 76 | let fold_callback acc = function 77 | | None -> from_list_aux acc 78 | | Some x -> from_list_aux (x :: acc) 79 | ;; 80 | 81 | let update fs path callback = 82 | match extract_target path with 83 | | None -> fs 84 | | Some (path, target) -> 85 | let rec aux acc fs path = 86 | match fs, path with 87 | | [], [] -> callback ~target ?previous:None () |> fold_callback acc 88 | | item :: fs_xs, [] -> 89 | if has_name target item 90 | then ( 91 | let new_acc = acc @ fs_xs in 92 | callback ~target ?previous:(Some item) () |> fold_callback new_acc) 93 | else aux (item :: acc) fs_xs [] 94 | | (Directory { name; content; _ } as cdir) :: fs_xs, fragment :: path_xs 95 | -> 96 | if has_name fragment cdir 97 | then ( 98 | let new_dir = dir name (aux [] content path_xs) in 99 | new_dir :: (acc @ fs_xs) |> from_list_aux) 100 | else aux (cdir :: acc) fs_xs path 101 | | [], fragment :: path_xs -> 102 | let new_dir = dir fragment (aux [] [] path_xs) in 103 | new_dir :: acc |> from_list_aux 104 | | x :: fs_xs, path -> aux (x :: acc) fs_xs path 105 | in 106 | aux [] fs path 107 | ;; 108 | 109 | let cat fs path = 110 | match get fs path with 111 | | None -> 112 | path 113 | |> Path.to_string 114 | |> Format.asprintf "cat: %s: No such file or directory" 115 | | Some (Directory _) -> 116 | path |> Path.to_string |> Format.asprintf "cat: %s: Is a directory" 117 | | Some (File { content; _ }) -> content 118 | ;; 119 | 120 | module Make (H : sig 121 | val fs : t 122 | val now : Datetime.t 123 | end) = 124 | struct 125 | let supervised_directory = ref None 126 | let fs = ref H.fs 127 | let time = ref H.now 128 | 129 | let datetime_from_float time = 130 | let Unix.{ tm_sec; tm_min; tm_hour; tm_mday; tm_mon; tm_year; _ } = 131 | Unix.gmtime time 132 | in 133 | let time = tm_hour, tm_min, tm_sec in 134 | Datetime.from_unix ~time ~year:tm_year ~month:tm_mon ~day:tm_mday () 135 | ;; 136 | 137 | let now () = !time |> Datetime.as_time 138 | let get_fs () = !fs 139 | let manip_time f = time := f !time 140 | 141 | let exists path = 142 | match get !fs path with 143 | | Some _ -> true 144 | | None -> false 145 | ;; 146 | 147 | let is_file path = 148 | match get !fs path with 149 | | Some (File _) -> true 150 | | None | Some _ -> false 151 | ;; 152 | 153 | let is_dir path = 154 | match get !fs path with 155 | | Some (Directory _) -> true 156 | | None | Some _ -> false 157 | ;; 158 | 159 | let read_file path = 160 | match get !fs path with 161 | | None | Some (Directory _) -> "" 162 | | Some (File { content; _ }) -> content 163 | ;; 164 | 165 | let create_dir path = 166 | let new_fs = 167 | update !fs path (fun ~target ?previous:_ () -> Some (dir target [])) 168 | in 169 | fs := new_fs 170 | ;; 171 | 172 | let write_file path content = 173 | let new_fs = 174 | update !fs path (fun ~target ?previous:_ () -> 175 | Some (file ~content target)) 176 | in 177 | fs := new_fs 178 | ;; 179 | 180 | let append_to_file path content = 181 | let new_fs = 182 | update !fs path (fun ~target ?previous () -> 183 | match previous with 184 | | Some (Directory _) -> None 185 | | Some (File { content = x; _ }) -> 186 | Some (file ~content:(content ^ x) target) 187 | | None -> Some (file ~content target)) 188 | in 189 | fs := new_fs 190 | ;; 191 | 192 | let delete_file path = 193 | let new_fs = update !fs path (fun ~target:_ ?previous:_ () -> None) in 194 | fs := new_fs 195 | ;; 196 | 197 | let delete_dir ?recursive:_ path = delete_file path 198 | let set_supervised_directory v = supervised_directory := v 199 | let get_supervised_directory () = !supervised_directory 200 | end 201 | --------------------------------------------------------------------------------