├── .dockerignore ├── .gitignore ├── CHANGES.md ├── Dockerfile ├── LICENSE ├── Makefile ├── README.md ├── cuekeeper.opam ├── dune-project ├── js ├── ck_animate.ml ├── ck_authn_RPC.ml ├── ck_js_utils.ml ├── ck_js_utils.mli ├── ck_modal.ml ├── ck_modal.mli ├── ck_panel.ml ├── ck_panel.mli ├── ck_template.ml ├── ck_template.mli ├── client.ml ├── dune └── pikaday.ml ├── lib ├── ck_client.ml ├── ck_client.mli ├── ck_clock.ml ├── ck_disk_node.ml ├── ck_disk_node.mli ├── ck_id.ml ├── ck_id.mli ├── ck_merge.ml ├── ck_merge.mli ├── ck_model.ml ├── ck_model.mli ├── ck_model_s.ml ├── ck_rev.ml ├── ck_rev.mli ├── ck_sigs.ml ├── ck_time.ml ├── ck_time.mli ├── ck_update.ml ├── ck_update.mli ├── ck_utils.ml ├── dune ├── init │ ├── ck-version │ ├── context │ │ ├── 139516f7-4c3e-47b8-98ce-0e273ea3ec5d │ │ ├── 4636d8cf-7c0d-47a8-b800-fdca7b3f68d6 │ │ ├── 855371a1-babe-4188-bb77-eea394927d7b │ │ ├── abae8e40-5d65-4f2d-afaa-a582ba2dabf2 │ │ ├── c6776794-d53e-460a-ada7-7e3b98c2f126 │ │ ├── c73ab810-4945-445b-93b3-d3048d478201 │ │ └── eea7d738-c781-4700-8594-667cd0d3fb41 │ └── db │ │ ├── 0cfe996c-afa9-4403-a5c3-c194114572f3 │ │ ├── 1a7c8ea2-18ac-41cb-8f79-3566e49445f4 │ │ ├── 1c6a6964-e6c8-499a-8841-8cb437e2930f │ │ ├── 1ec321bf-d65d-430d-86d2-30a722e8dbb6 │ │ ├── 26b4b45a-bfd4-459f-ae82-7db874629e4a │ │ ├── 5841e8a9-81c0-43ac-830f-5f94d5a58b03 │ │ ├── 6002ea71-6f1c-4ba9-8728-720f4b4c9845 │ │ ├── 60c0e3db-ab42-46d8-bdc6-518484cc250f │ │ ├── 931ab6e5-4db8-4370-a37b-5d7b6d858ba2 │ │ ├── 977fea84-925d-4de9-8c14-c16f145ed191 │ │ ├── 9a000050-4e81-4982-8d47-99230c4e1eb4 │ │ ├── ad8c5bb1-f6b7-4a57-b090-d6ef2e3326c1 │ │ └── af66bb30-5488-4b8b-a171-ba4a048d6fd1 └── utils │ ├── delta_RList.ml │ ├── delta_RList.mli │ ├── git_storage.ml │ ├── git_storage.mli │ ├── git_storage_s.ml │ ├── reactive_tree.ml │ ├── reactive_tree.mli │ ├── slow_set.ml │ └── slow_set.mli ├── resources ├── cache.manifest ├── css │ ├── foundation.css │ ├── foundation.min.css │ ├── normalize.css │ ├── pikaday.css │ └── style.css ├── ico │ ├── ck-alert.ico │ └── ck.ico └── js │ └── vendor │ ├── FileSaver.min.js │ └── pikaday.js ├── server ├── .gitignore ├── devices.ml ├── dune ├── main.ml └── server.ml ├── test.html └── tests ├── dune ├── server.ml ├── static.ml ├── test.ml └── test_net.ml /.dockerignore: -------------------------------------------------------------------------------- 1 | .git 2 | _build 3 | cuekeeper-bin* 4 | server/_build 5 | server/static.ml 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | .merlin 3 | cuekeeper-bin-* 4 | cuekeeper-bin-*.zip 5 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## v0.4 2 | 3 | - Upgrade to OCaml 4.07, Mirage 3.7.3 and Irmin 1.4. 4 | 5 | ## v0.3 6 | 7 | - CueKeeper now stores its data in standard Git format, rather than the old 8 | Irmin 0.10 custom format. This will (finally) allow upgrading to newer 9 | versions of Irmin in the future. 10 | 11 | When upgrading from an older release, you will see a migration box on the 12 | first run, showing the progress of the migration. On my machine, converting 13 | my CueKeeper history from 2015-03-09 to now (15,193 commits) took about 20 14 | minutes in Firefox. 15 | 16 | - Open all links in a new window. Mac users can't just middle-click links, 17 | because they only have one mouse button. If you don't like this behaviour, 18 | just edit the HTML file and remove the `` element. 19 | 20 | - Convert build system to dune and upgrade to newer versions of various 21 | packages. 22 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam:debian-12-ocaml-4.14@sha256:bc657956e4dfb5cd9b822594dfd894b293c7068aa69b6f0a5ad31638a02890bf 2 | #FROM ocurrent/opam:debian-12-ocaml-4.14 3 | # Make sure we're using opam-2.3: 4 | RUN sudo ln -sf /usr/bin/opam-2.3 /usr/bin/opam && opam option solver=builtin-0install 5 | RUN mkdir /home/opam/cuekeeper 6 | COPY --chown=opam cuekeeper.opam /home/opam/cuekeeper/ 7 | WORKDIR /home/opam/cuekeeper 8 | RUN opam pin add -yn cuekeeper.dev . 9 | RUN opam install -t --deps-only cuekeeper 10 | ENTRYPOINT ["opam", "exec", "--"] 11 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | #CAML_LD_LIBRARY_PATH = $(shell opam config var prefix)/lib/stublibs/ 2 | #export CAML_LD_LIBRARY_PATH 3 | 4 | # make JFLAGS="--pretty --noinline" 5 | JFLAGS = 6 | 7 | VERSION = dev 8 | RELEASE_DIR = cuekeeper-bin-${VERSION} 9 | MIRAGE_FLAGS = -t unix 10 | 11 | .PHONY: test client server 12 | 13 | all: 14 | dune build ./js/client.bc.js @runtest @install 15 | 16 | client-test: 17 | dune build ./js/client.bc.js @runtest 18 | 19 | client: 20 | dune build ./js/client.bc.js 21 | 22 | test: 23 | dune runtest 24 | 25 | slow_test: 26 | env CK_TEST_ITERS=10000 dune exec ./tests/test.exe 27 | 28 | release: 29 | rm -rf "${RELEASE_DIR}" 30 | mkdir "${RELEASE_DIR}" 31 | git archive HEAD --format=tar resources LICENSE | tar xf - -C "${RELEASE_DIR}" 32 | dune build --profile=release ./js/client.bc.js 33 | cp _build/default/js/client.bc.js "${RELEASE_DIR}/resources/js/cuekeeper.js" 34 | sed 's!_build/default/js/client.bc.js!resources/js/cuekeeper.js!' test.html > "${RELEASE_DIR}/index.html" 35 | sed '/^Installation/,/^Instructions/{/^Instructions/!d}' README.md > "${RELEASE_DIR}/README.md" 36 | zip -r "${RELEASE_DIR}.zip" ${RELEASE_DIR} 37 | rm -rf "${RELEASE_DIR}" 38 | 39 | docker-build: 40 | docker build -t cuekeeper . 41 | docker run --rm -v $(CURDIR):/home/opam/cuekeeper cuekeeper make 42 | 43 | server/conf/server.key: 44 | @echo Generating server key... 45 | mkdir -p server/conf 46 | openssl genpkey -out $@ -outform PEM -algorithm RSA -pkeyopt rsa_keygen_bits:4096 47 | 48 | server/conf/server.pem: server/conf/server.key 49 | @echo ">>> Generating server X.509 certificate." 50 | @echo ">>> Enter the server's full hostname as the 'Common Name' (e.g. cuekeeper.mynet)." 51 | @echo ">>> Everything else can be left blank." 52 | @echo 53 | @openssl req -new -x509 -key $< -out $@ -days 10000 54 | 55 | server: server/conf/server.pem 56 | rm -rf _build/static 57 | mkdir -p _build/static 58 | cp -r resources _build/static/ 59 | dune build --profile=release ./js/client.bc.js 60 | cp _build/default/js/client.bc.js _build/static/resources/js/cuekeeper.js 61 | sed 's!_build/default/js/client.bc.js!resources/js/cuekeeper.js!;s!var ck_use_server=false;!var ck_use_server=true;!' test.html > _build/static/index.html 62 | dune build ./server/main.exe 63 | 64 | clean: 65 | dune clean 66 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | CueKeeper 2 | ========= 3 | 4 | Copyright Thomas Leonard, 2025 5 | 6 | CueKeeper is a web-based [GTD][] system (a fancy TODO list) that runs entirely in your browser (the data is stored on your computer, in your browser). 7 | 8 | 9 | 10 | Installation 11 | ------------ 12 | 13 | Download the latest `cuekeeper-bin` zip from the [releases list][], e.g. 14 | 15 | https://github.com/talex5/cuekeeper/releases/download/v0.4/cuekeeper-bin-0.4.zip 16 | 17 | Extract it somewhere permanent (not your Downloads folder) and open the `index.html` file inside in a web browser. Most browsers will allow you to "pin" the tab so that it is always available. e.g. In Firefox, right-click on the browser tab and choose "Pin Tab" from the menu. The tab icon will go red when something becomes due. 18 | 19 | Instructions for using CueKeeper can be found here: 20 | 21 | http://roscidus.com/blog/blog/2015/04/28/cuekeeper-gitting-things-done-in-the-browser/ 22 | 23 | Upgrading: You can just unpack the new archive over the old one and refresh the browser tab. If you just get a blank window, you probably have another CueKeeper tab open somewhere and will need to close that first so it can update the database schema to the latest version. If upgrading from versions earlier than 0.3, you will need to upgrade to version 0.3 first (it will prompt you to do this if needed). 24 | 25 | Chromium note: If it says "The user denied permission to access the database." try turning off `Block third-party cookies` (I don't know why it thinks a local HTML file writing to a local database is a third-party cookie). Also, it seems that all `file://...` pages will see the same database on Chromium, whereas on Firefox each page gets its own one. 26 | 27 | Backups 28 | ------- 29 | 30 | All data will be stored locally in your web browser, so make sure you're backing up your browser's data! Also, the data will be stored based on the location of the `index.html` file - if you move the `cuekeeper` directory, you will get a fresh database (and it will look as if your data has gone - don't panic!). 31 | 32 | For example, I use Firefox on Linux. The data is stored at 33 | 34 | ~/.mozilla/firefox/XXX.default/storage/default/file++++home+user+cuekeeper+index.html/ 35 | 36 | 37 | Building (using Docker) 38 | ----------------------- 39 | 40 | The easiest way to build CueKeeper is using Docker: 41 | 42 | make docker-build 43 | 44 | Then load `test.html` in a browser to test locally (no server required). 45 | 46 | 47 | Building (without Docker) 48 | ------------------------- 49 | 50 | You'll need the [opam](http://opam.ocaml.org/) package manager. 51 | It should be available through your distribution, but you can use a [generic opam binary](http://tools.ocaml.org/opam.xml) if it's missing or too old (I use opam 2.2.1). 52 | Ensure you're using OCaml 4.14.2 (check with `ocaml -version`). If not, switch to that version: 53 | 54 | opam switch create 4.14.2 55 | 56 | Install the dependencies (`-t` includes the test dependencies too): 57 | 58 | opam install --deps-only -t . 59 | 60 | Build: 61 | 62 | make 63 | 64 | Load `test.html` in a browser to test locally (no server required). 65 | 66 | Note that this defaults to "dev" mode, where the Javascript generated will be very large (about 12 MB) and not optimised. 67 | To get a smaller file, use `dune build --profile=release ./js/client.bc.js` (should be about 1.3 MB). 68 | 69 | 70 | Running a server 71 | ---------------- 72 | 73 | While `test.html` can be opened directly in a browser, as above, you can also build a server. 74 | This allows you to sync between devices (e.g. a laptop and mobile phone). 75 | 76 | **Warning: This is a work-in-progress**: 77 | 78 | - The server does not yet persist the data itself 79 | (the client sends the whole history the first time it connects after the service is restarted). 80 | - You have to sync manually by clicking the `Sync` button - it does not send or fetch changes automatically. 81 | 82 | First, generate an access token (a *long* random string that grants access to the server). 83 | The `pwgen` command is useful for this: 84 | 85 | $ pwgen -s 32 1 86 | dtXZ7fQfX52VsnJNk22J6uKy8JSn6klb 87 | 88 | To avoid storing the secret itself, generate its SHA256 hash: 89 | 90 | $ echo -n dtXZ7fQfX52VsnJNk22J6uKy8JSn6klb | sha256sum 91 | 774400f3384a6f37cc2bc54b2fd0280193b613a5bc401c0e54fd17fe4ec19572 92 | 93 | Create a `devices` file with the hash(es) you generated above, e.g.: 94 | 95 | 774400f3384a6f37cc2bc54b2fd0280193b613a5bc401c0e54fd17fe4ec19572 Laptop 96 | 97 | The string at the end ("Laptop") is just used for logging. 98 | You can generate a different access token for each device you want to sync and list them all here, one per line. 99 | 100 | To build the server component: 101 | 102 | make server 103 | 104 | You will be prompted to create a self-signed X.509 certificate. Just enter your server's hostname 105 | as the "Common Name" (for testing, you could use "localhost" here and generate a proper one later). 106 | 107 | To run the server: 108 | 109 | dune exec -- cuekeeper --devices=./devices 110 | 111 | By default the server listens on TCP port 8443, but this can be changed by editing `server/main.ml`. 112 | 113 | Open the URL in a browser, e.g. 114 | 115 | https://localhost:8443/ 116 | 117 | You'll probably now get some scary-looking warning about the certificate not being trusted. 118 | To get rid of the warning, add your newly-generated server.pem as follows: 119 | 120 | In Firefox: 121 | 122 | 1. Firefox will say "This Connection is Untrusted". 123 | 2. Expand the **I Understand the Risks** section. 124 | 3. Click **Add Exception**, then **Confirm Security Exception** (and "Permanently store this exception"). 125 | 126 | In Chrome: 127 | 128 | 1. It will say "Your connection is not private" (in fact, the opposite is true; if encryption wasn't being used it wouldn't have complained at all). 129 | 2. Go to **Settings** -> **Show advanced settings**. 130 | 3. Click the **Manage certificates** button (in the HTTPS/SSL section). 131 | 4. In the **Authorities** tab, click **Import...** and select your `server/conf/server.pem` file. 132 | 5. Select **Trust this certificate for identifying websites**. 133 | 134 | Finally, you should be prompted for your access key. 135 | Paste in the token you generated above (e.g. `dtXZ7fQfX52VsnJNk22J6uKy8JSn6klb` in the example above - *not* the hash). 136 | 137 | 138 | Bugs 139 | ---- 140 | 141 | Please any send questions or comments to the mirage mailing list: 142 | 143 | http://lists.xenproject.org/cgi-bin/mailman/listinfo/mirageos-devel 144 | 145 | Bugs can be reported on the mailing list or as GitHub issues: 146 | 147 | https://github.com/talex5/cuekeeper/issues 148 | 149 | 150 | Conditions 151 | ---------- 152 | 153 | This library is free software; you can redistribute it and/or 154 | modify it under the terms of the GNU Lesser General Public 155 | License as published by the Free Software Foundation; either 156 | version 2.1 of the License, or (at your option) any later version. 157 | 158 | This library is distributed in the hope that it will be useful, 159 | but WITHOUT ANY WARRANTY; without even the implied warranty of 160 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 161 | Lesser General Public License for more details. 162 | 163 | You should have received a copy of the GNU Lesser General Public 164 | License along with this library; if not, write to the Free Software 165 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 166 | USA 167 | 168 | 169 | This project includes Foundation (http://foundation.zurb.com). These files 170 | are released under the MIT license. 171 | 172 | 173 | This project includes the Pikaday date picker (https://github.com/dbushell/Pikaday). 174 | These files are released under the BSD & MIT licenses. 175 | 176 | 177 | This project includes FileSaver.js (https://github.com/eligrey/FileSaver.js), which 178 | is released under a permissive license. 179 | 180 | 181 | Full details of all licenses can be found in the LICENSE file. 182 | 183 | 184 | [GTD]: https://en.wikipedia.org/wiki/Getting_Things_Done 185 | [mirage]: http://openmirage.org/ 186 | [releases list]: https://github.com/talex5/cuekeeper/releases 187 | -------------------------------------------------------------------------------- /cuekeeper.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "cuekeeper" 3 | synopsis: "Web-based GTD system with Git-based history" 4 | maintainer: "Thomas Leonard " 5 | authors: "Thomas Leonard " 6 | license: "GNU LESSER GENERAL PUBLIC LICENSE, v2.1" 7 | homepage: "https://github.com/talex5/cuekeeper" 8 | bug-reports: "https://github.com/talex5/cuekeeper/issues" 9 | depends: [ 10 | "ocaml" {>= "4.13"} 11 | "sexplib" {>= "v0.13.0"} 12 | "uuidm" {>= "0.9.7"} 13 | "irmin" {>= "2.10.0"} 14 | "irmin-git" 15 | "git" {>= "2.1.3"} 16 | "tyxml" {>= "4.6.0"} 17 | "reactiveData" {>= "0.2"} 18 | "js_of_ocaml" {>= "4.0.0" < "4.1.0"} 19 | "js_of_ocaml-tyxml" 20 | "omd" {>= "1.2.4" & < "2.0.0~"} 21 | "fmt" {>= "0.8.9"} 22 | "logs" 23 | "ounit" {with-test} 24 | "tar" {>= "2.0.0" & < "3.0.0"} 25 | "cohttp" {>= "4.0.0" & < "6.0.0"} 26 | "cohttp-lwt-unix" 27 | "cohttp-lwt-jsoo" 28 | "irmin-indexeddb" {>= "2.6"} 29 | "crunch" {build} 30 | "ppx_sexp_conv" 31 | "lwt" 32 | "tls-lwt" {>= "1.0.0"} 33 | "cstruct" {>= "4.0.0"} 34 | "ppx_deriving" 35 | "cmdliner" {>= "1.3.0"} 36 | "dune" {>= "3.2.0"} 37 | ] 38 | pin-depends: [ 39 | ["irmin-indexeddb.2.6.0" "git+https://github.com/talex5/irmin-indexeddb.git#b92cc751bc70d04c0447fab8cac259f36b2fd769"] 40 | ] 41 | build: [ 42 | [make "client"] 43 | [make "test"] {with-test} 44 | [make "slow_test"] {with-test} 45 | ] 46 | dev-repo: "git+https://github.com/talex5/cuekeeper.git" 47 | description: """ 48 | CueKeeper is a web-based GTD system (a fancy TODO list) that runs entirely in 49 | your browser (the data is stored on your computer, in your browser). It uses 50 | Irmin to keep a full history of all updates. 51 | """ 52 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.2) 2 | (name cuekeeper) 3 | -------------------------------------------------------------------------------- /js/ck_animate.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Js_of_ocaml 5 | open Js_of_ocaml_tyxml 6 | module Lwt_js = Js_of_ocaml_lwt.Lwt_js 7 | module Lwt_js_events = Js_of_ocaml_lwt.Lwt_js_events 8 | 9 | (* Ck_model gives us 1s for the whole fade-out, resize, fade-in sequence *) 10 | let fade_time = 0.33 11 | let resize_time = 0.33 12 | 13 | let scroll_time = 0.25 14 | 15 | (* (forces return type to be unit) *) 16 | let async : (unit -> unit Lwt.t) -> unit = Lwt_js_events.async 17 | 18 | let clamp lo hi v = 19 | min (max v lo) hi 20 | 21 | let request_animation_frame f = 22 | let callback = Js.wrap_callback (fun (_ : float) -> f ()) in 23 | ignore (Dom_html.window##requestAnimationFrame callback : Dom_html.animation_frame_request_id) 24 | 25 | (* Fade out, then animate max-height down to zero. Can't do this with CSS because of FF bug #830056. 26 | * [when_complete] is called on success (but not if cancelled). *) 27 | let fade_out ?when_complete elem = 28 | let cancelled = ref false in 29 | let start = Unix.gettimeofday () in 30 | let shrink_start = start +. resize_time in 31 | let full_height = float_of_int elem##.offsetHeight in 32 | let rec aux () = 33 | if not !cancelled then ( 34 | let t = Unix.gettimeofday () in 35 | let fade_frac = (t -. start) /. fade_time in 36 | let shrink_frac = (t -. shrink_start) /. resize_time in 37 | let o = max 0.0 (1. -. fade_frac) in 38 | let o = Printf.sprintf "%g" o in 39 | let h = full_height *. (1. -. shrink_frac) |> truncate in 40 | let h = max 0 h in 41 | elem##.style##.opacity := Js.string o |> Js.Optdef.return; 42 | elem##.style##.maxHeight := (Js.string (string_of_int h ^ "px")); 43 | if h > 0 then 44 | request_animation_frame aux 45 | else 46 | match when_complete with 47 | | None -> () 48 | | Some fn -> fn () 49 | ) in 50 | aux (); 51 | fun () -> 52 | cancelled := true; 53 | elem##.style##.opacity := Js.string "" |> Js.Optdef.return; 54 | elem##.style##.maxHeight := Js.string "" 55 | 56 | (* Runs in parallel with fade_out. 57 | * Wait for fade_time (original disappears), then expand this item as the other 58 | * one shrinks, then fade in. *) 59 | let fade_in_move ~full_height elem = 60 | let open Lwt in 61 | let cancelled = ref false in 62 | let start = Unix.gettimeofday () +. fade_time in 63 | let fade_start = start +. resize_time in 64 | let rec aux () = 65 | if not !cancelled then ( 66 | let t = Unix.gettimeofday () in 67 | let fade_frac = (t -. fade_start) /. fade_time in 68 | let grow_frac = (t -. start) /. resize_time in 69 | let o = fade_frac |> clamp 0.0 1.0 in 70 | let h = float_of_int full_height *. grow_frac |> truncate in 71 | let h = h |> clamp 0 full_height in 72 | let () = 73 | let elem = Tyxml_js.To_dom.of_element elem in 74 | let o = Printf.sprintf "%g" o in 75 | elem##.style##.opacity := Js.string o |> Js.Optdef.return; 76 | elem##.style##.maxHeight := (Js.string (string_of_int h ^ "px")) in 77 | if o < 1.0 then 78 | request_animation_frame aux 79 | ) in 80 | async (fun () -> Lwt_js.sleep fade_time >|= fun () -> 81 | (* By this time, we've had a chance to fill in the height of the removed item. *) 82 | aux () 83 | ); 84 | fun () -> 85 | cancelled := true; 86 | let elem = Tyxml_js.To_dom.of_element elem in 87 | elem##.style##.opacity := Js.string "" |> Js.Optdef.return; 88 | elem##.style##.maxHeight := Js.string "" 89 | 90 | let animate_scroll_to (target_x, target_y) = 91 | let start_x, start_y = Dom_html.getDocumentScroll () in 92 | if start_x <> target_x || start_y <> target_y then ( 93 | let start = Unix.gettimeofday () in 94 | let root = Dom_html.document##.documentElement in 95 | let rec aux () = 96 | let f = (Unix.gettimeofday () -. start) /. scroll_time |> min 1.0 in 97 | let dx = float_of_int (target_x - start_x) *. f in 98 | let dy = float_of_int (target_y - start_y) *. f in 99 | root##.scrollLeft := start_x + truncate dx; 100 | root##.scrollTop := start_y + truncate dy; 101 | if f < 1.0 then request_animation_frame aux in 102 | aux () 103 | ) 104 | 105 | (** Animate scrolling the window so that the range (top, bottom) is visible. 106 | * Also, ensure we're fully scrolled to the right. *) 107 | let scroll_to_show (top, bottom) = 108 | let vp_height = Dom_html.document##.documentElement##.clientHeight in 109 | let vp_width = Dom_html.document##.documentElement##.clientWidth in 110 | let full_width = Dom_html.document##.body##.offsetWidth in 111 | let region_height = (bottom - top + 2) in 112 | let region_height = min region_height vp_height in 113 | let _scroll_left, scroll_top = Dom_html.getDocumentScroll () in 114 | let target_y = 115 | if top < scroll_top then top 116 | else if top + region_height > scroll_top + vp_height then ( 117 | (* Put top + region_height at the bottom of the viewport *) 118 | top + region_height - vp_height 119 | ) else scroll_top in 120 | let target_x = full_width - vp_width in 121 | animate_scroll_to (target_x, target_y) 122 | -------------------------------------------------------------------------------- /js/ck_authn_RPC.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | (* RPC over XMLHttpRequest, getting the access token from the user if necessary. *) 5 | 6 | open Lwt.Infix 7 | open Js_of_ocaml 8 | 9 | module XHR = Cohttp_lwt_jsoo.Client 10 | 11 | let storage = 12 | lazy ( 13 | Js.Optdef.get (Dom_html.window##.localStorage) 14 | (fun () -> failwith "HTML 5 storage is not available") 15 | ) 16 | 17 | let token_key = Js.string "CueKeeper.auth.access_token" 18 | 19 | let set_token value = (Lazy.force storage)##setItem token_key value 20 | let remove_token () = (Lazy.force storage)##removeItem token_key 21 | let get_token () = 22 | let v = (Lazy.force storage)##getItem(token_key) in 23 | Js.Opt.map v Js.to_string 24 | |> Js.Opt.to_option 25 | 26 | let input_token () = 27 | Js.Opt.case (Dom_html.window##prompt (Js.string "Enter access token") (Js.string "")) 28 | (fun () -> `Cancelled_by_user) 29 | (fun s -> set_token s; `Ok) 30 | 31 | let rec with_token fn uri = 32 | match get_token () with 33 | | None -> 34 | begin match input_token () with 35 | | `Ok -> with_token fn uri 36 | | `Cancelled_by_user as c -> Lwt.return c 37 | end 38 | | Some access_token -> 39 | let uri = Uri.add_query_param uri ("token", [access_token]) in 40 | fn uri >>= function 41 | | (resp, _body) when resp.Cohttp.Response.status = `Unauthorized -> 42 | remove_token (); 43 | with_token fn uri 44 | | result -> Lwt.return (`Ok result) 45 | 46 | let get ?headers uri = with_token (XHR.get ?headers) uri 47 | let post ?body ?headers uri = with_token (XHR.post ?body ?headers) uri 48 | -------------------------------------------------------------------------------- /js/ck_js_utils.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Js_of_ocaml 5 | open Js_of_ocaml_tyxml 6 | module Lwt_js_events = Js_of_ocaml_lwt.Lwt_js_events 7 | 8 | let ignore_listener = ignore 9 | 10 | let inside elem child = 11 | let elem = (elem :> Dom.node Js.t) in 12 | let rec aux child = 13 | if elem == child then true 14 | else ( 15 | Js.Opt.case (child##.parentNode) 16 | (fun () -> false) 17 | aux 18 | ) in 19 | aux (child :> Dom.node Js.t) 20 | 21 | let keycode_escape = 27 22 | 23 | let pos_from_root (elem : #Dom_html.element Js.t) = 24 | let rec aux x y elem = 25 | let x = x + elem##.offsetLeft in 26 | let y = y + elem##.offsetTop in 27 | Js.Opt.case (elem##.offsetParent) 28 | (fun () -> (x, y)) 29 | (fun parent -> aux x y parent) in 30 | aux 0 0 (elem :> Dom_html.element Js.t) 31 | 32 | let async ~name (fn:unit -> unit Lwt.t) = 33 | Lwt_js_events.async (fun () -> 34 | Lwt.catch fn (fun ex -> 35 | Printf.printf "Async error in '%s'" name; 36 | Lwt.fail ex 37 | ) 38 | ) 39 | 40 | let auto_focus input = 41 | async ~name:"focus" (fun () -> 42 | let elem = Tyxml_js.To_dom.of_input input in 43 | elem##select; 44 | Lwt.return () 45 | ) 46 | 47 | class type blobPropertyBag = 48 | object 49 | method _type : Js.js_string Js.t Js.prop 50 | end 51 | 52 | let blob_constr : 53 | ( Js.js_string Js.t Js.js_array Js.t -> 54 | blobPropertyBag Js.t -> 55 | File.blob Js.t 56 | ) Js.constr 57 | = Js.Unsafe.global##._Blob 58 | 59 | let make_blob ~mime data = 60 | let ar = new%js Js.array_empty in 61 | Js.array_set ar 0 (Js.string data); 62 | let options : blobPropertyBag Js.t = Js.Unsafe.obj [||] in 63 | options##._type := Js.string mime; 64 | new%js blob_constr ar options 65 | 66 | let save_as blob name = 67 | let open Js in 68 | Unsafe.fun_call (Unsafe.global##.saveAs) [| 69 | Unsafe.inject blob; 70 | Unsafe.inject (string name) 71 | |] 72 | -------------------------------------------------------------------------------- /js/ck_js_utils.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Js_of_ocaml 5 | open Js_of_ocaml_tyxml 6 | 7 | val ignore_listener : Dom_html.event_listener_id -> unit 8 | (** Version of [ignore] restricted to event listeners. *) 9 | 10 | val inside : #Dom_html.element Js.t -> #Dom_html.element Js.t -> bool 11 | (** [inside parent child] is true if [child] or one of its ancestors is [parent]. *) 12 | 13 | val keycode_escape : int 14 | 15 | val pos_from_root : #Dom_html.element Js.t -> (int * int) 16 | (** Find the absolute position of an element. *) 17 | 18 | val async : name:string -> (unit -> unit Lwt.t) -> unit 19 | (** Wrapper for [Lwt_js_events.async] that logs exceptions with the given label. 20 | * Also, it forces the return type to be [unit Lwt.t]. *) 21 | 22 | val auto_focus : [< Html_types.input] Tyxml_js.Html5.elt -> unit 23 | (** [auto_focus i] gives [i] the focus after this turn (giving it a chance to be rendered first). *) 24 | 25 | val make_blob : mime:string -> string -> File.blob Js.t 26 | 27 | val save_as : File.blob Js.t -> string -> unit 28 | (** [save_as blob name] prompts the user to save the blob to a local file. *) 29 | -------------------------------------------------------------------------------- /js/ck_modal.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Js_of_ocaml 5 | open Ck_js_utils 6 | 7 | type t = { 8 | element : Dom_html.element Js.t; 9 | close : unit -> unit; 10 | } 11 | 12 | let current = ref None 13 | 14 | let close () = 15 | match !current with 16 | | None -> () 17 | | Some t -> 18 | current := None; 19 | t.close () 20 | 21 | let show ~close:c element = 22 | close (); 23 | current := Some { 24 | element = (element :> Dom_html.element Js.t); 25 | close = c; 26 | } 27 | 28 | (* Listen to global clicks and keypresses so we can close modals on click/escape *) 29 | let () = 30 | let click (ev:#Dom_html.mouseEvent Js.t) = 31 | match !current with 32 | | None -> Js._true 33 | | Some modal -> 34 | Js.Opt.case (ev##.target) 35 | (fun () -> Js._true) 36 | (fun target -> 37 | if target |> inside modal.element then ( 38 | (* Click inside modal - pass it on *) 39 | Js._true 40 | ) else ( 41 | (* Click outside modal; close the modal *) 42 | close (); 43 | Dom_html.stopPropagation ev; 44 | Js._false 45 | ) 46 | ) in 47 | let keyup ev = 48 | match !current with 49 | | Some _ when ev##.keyCode = keycode_escape -> 50 | close (); 51 | Dom_html.stopPropagation ev; 52 | Js._false 53 | | _ -> Js._true in 54 | Dom_html.addEventListener Dom_html.document Dom_html.Event.click (Dom.handler click) Js._true |> ignore_listener; 55 | Dom_html.addEventListener Dom_html.document Dom_html.Event.keypress (Dom.handler keyup) Js._true |> ignore_listener 56 | -------------------------------------------------------------------------------- /js/ck_modal.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | (** Manage modal elements. A modal element is automatically closed when: 5 | * - another modal is shown, 6 | * - escape is pressed, or 7 | * - the user clicks outside the modal element *) 8 | 9 | open Js_of_ocaml 10 | 11 | val show : close:(unit -> unit) -> #Dom_html.element Js.t -> unit 12 | (** Show a new modal (closing any currently-open one first). *) 13 | 14 | val close : unit -> unit 15 | (** Close any currently open modal. *) 16 | -------------------------------------------------------------------------------- /js/ck_panel.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Js_of_ocaml_tyxml.Tyxml_js 5 | module Tyxml_js = Js_of_ocaml_tyxml.Tyxml_js 6 | module Lwt_js_events = Js_of_ocaml_lwt.Lwt_js_events 7 | module Lwt_js = Js_of_ocaml_lwt.Lwt_js 8 | open Html5 9 | open Ck_utils 10 | open Lwt.Infix 11 | 12 | type t = { 13 | id : Ck_id.t; 14 | on_destroy : unit -> unit; 15 | set_closed : bool -> unit; 16 | element : [`Div] Html5.elt; 17 | } 18 | 19 | let async ~name (fn:unit -> unit Lwt.t) = 20 | Lwt_js_events.async (fun () -> 21 | Lwt.catch fn (fun ex -> 22 | Printf.printf "Async error in '%s'" name; 23 | Lwt.fail ex 24 | ) 25 | ) 26 | 27 | let current_highlight, set_highlight = React.S.create None 28 | 29 | (* Wrap contents in a panel with a close icon. *) 30 | let make ~id ~closed ~set_closed ~on_destroy ~title ~contents = 31 | let elem = ref None in 32 | let cl = 33 | let cancel_close = ref ignore in 34 | closed >>~= (fun closed -> 35 | !cancel_close (); 36 | begin match closed, !elem with 37 | | true, Some elem -> 38 | let elem = Tyxml_js.To_dom.of_element elem in 39 | cancel_close := Ck_animate.fade_out ~when_complete:on_destroy elem 40 | | _ -> () end; 41 | current_highlight |> React.S.map (fun highlight -> 42 | let matches = (highlight = Some id) in 43 | begin match matches, !elem with 44 | | true, Some elem -> 45 | let elem = To_dom.of_element elem in 46 | let _x, y = Ck_js_utils.pos_from_root elem in 47 | let height = elem##.clientHeight in 48 | Ck_animate.scroll_to_show (y, y + height); 49 | | _ -> () end; 50 | "ck-details" :: List.concat [ 51 | if matches then ["ck-highlight"] else []; 52 | if closed then ["closed"] else []; 53 | ] 54 | ) 55 | ) in 56 | let result = div ~a:[R.Html5.a_class cl] [ 57 | div ~a:[a_class ["ck-heading"]] [ 58 | (title :> Html_types.div_content_fun Tyxml_js.Html5.elt); 59 | a ~a:[a_onclick (fun _ -> set_closed true; true); a_class ["close"]] [entity "#215"]; 60 | ]; 61 | (contents :> Html_types.div_content_fun Html5.elt); 62 | ] in 63 | elem := Some result; 64 | { 65 | id; 66 | on_destroy; 67 | set_closed; 68 | element = result; 69 | } 70 | 71 | let highlight uuid = 72 | set_highlight (Some uuid); 73 | async ~name:"highlight" (fun () -> 74 | Lwt_js.sleep 2.0 >|= fun () -> 75 | if React.S.value current_highlight = Some uuid then set_highlight None 76 | ) 77 | 78 | let close t = t.set_closed true 79 | 80 | let element t = t.element 81 | -------------------------------------------------------------------------------- /js/ck_panel.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Js_of_ocaml_tyxml.Tyxml_js 5 | 6 | type t 7 | 8 | val make : 9 | id:Ck_id.t -> 10 | closed:bool React.S.t -> (* Becomes true when starting to close the box. *) 11 | set_closed:(bool -> unit) -> (* Set to true if the user clicks the close icon. *) 12 | on_destroy:(unit -> unit) -> (* Called when the fade-out is complete. *) 13 | title:[< Html_types.div_content_fun] Html5.elt -> 14 | contents:[< Html_types.div_content_fun] Html5.elt -> 15 | t 16 | 17 | val highlight : Ck_id.t -> unit 18 | val close : t -> unit 19 | val element : t -> [`Div] Html5.elt 20 | -------------------------------------------------------------------------------- /js/ck_template.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Ck_sigs 5 | open Js_of_ocaml_tyxml 6 | 7 | module Gui_tree_data : GUI_DATA 8 | 9 | module Make (M : Ck_model_s.MODEL with type gui_data = Gui_tree_data.t) : sig 10 | val make_top : M.t -> [> `Div ] Tyxml_js.Html5.elt list 11 | end 12 | -------------------------------------------------------------------------------- /js/client.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Lwt.Infix 5 | open Ck_utils 6 | open Js_of_ocaml 7 | open Js_of_ocaml_tyxml 8 | 9 | module Lwt_js = Js_of_ocaml_lwt.Lwt_js 10 | module Lwt_js_events = Js_of_ocaml_lwt.Lwt_js_events 11 | 12 | (* let () = Log.(set_log_level INFO) *) 13 | 14 | let () = Random.self_init () (* Random back-off for Safari bug work-around *) 15 | 16 | module Clock = struct 17 | let now = Unix.gettimeofday 18 | let async ~name fn = 19 | Lwt_js_events.async (fun () -> 20 | Lwt.catch fn (fun ex -> 21 | Printf.printf "Async error in '%s'" name; 22 | Lwt.fail ex 23 | ) 24 | ) 25 | let sleep = Lwt_js.sleep 26 | end 27 | 28 | module Store = Irmin_git.Generic(Irmin_indexeddb.Content_store_git)(Irmin_indexeddb.Branch_store) 29 | (Irmin.Contents.String)(Irmin.Path.String_list)(Irmin.Branch.String) 30 | module Git = Git_storage.Make(Store) 31 | module M = Ck_model.Make(Clock)(Git)(Ck_template.Gui_tree_data)(Ck_authn_RPC) 32 | module T = Ck_template.Make(M) 33 | 34 | let server = 35 | let use_server = Js.Unsafe.pure_js_expr "ck_use_server" |> Js.to_bool in 36 | if use_server then Some ( 37 | Js.to_string Dom_html.window##.location##.protocol ^ Js.to_string Dom_html.window##.location##.host 38 | |> Uri.of_string 39 | ) else None 40 | 41 | let start (main:#Dom.node Js.t) = 42 | Lwt.catch 43 | (fun () -> 44 | let config = Irmin_indexeddb.config "CueKeeper" in 45 | let task s = 46 | let date = Unix.time () |> Int64.of_float in 47 | Irmin.Info.v ~date ~author:"User" s in 48 | Store.Repo.v config >>= fun repo -> 49 | M.make ?server (Git.make repo task) >>= fun m -> 50 | let icon = 51 | let open Tyxml_js in 52 | let href = M.alert m >|~= (function 53 | | false -> "resources/ico/ck.ico" 54 | | true -> "resources/ico/ck-alert.ico" 55 | ) in 56 | R.Html5.link ~rel:(React.S.const [`Icon]) ~href ~a:[Html5.a_mime_type "image/ico"] () in 57 | Dom_html.document##.head##appendChild (Tyxml_js.To_dom.of_node icon) |> ignore; 58 | T.make_top m 59 | |> List.iter (fun child -> main##appendChild (Tyxml_js.To_dom.of_node child) |> ignore); 60 | Lwt.return () 61 | ) 62 | (fun ex -> 63 | let msg = 64 | match ex with 65 | | Irmin_indexeddb.Format_too_old `Irmin_0_10 -> 66 | "Please upgrade to CueKeeper 0.3 first. This will convert your old data to the standard Git format, \ 67 | which is the only format the current version of CueKeeper can read." 68 | | _ -> 69 | let msg = Printexc.to_string ex in 70 | if Regexp.string_match (Regexp.regexp_string "SecurityError:") msg 0 <> None then 71 | msg ^ " Ensure cookies are enabled (needed to access local storage)." 72 | else msg 73 | in 74 | let error = Tyxml_js.Html5.(div ~a:[a_class ["alert-box"; "alert"]] 75 | [txt msg]) in 76 | main##appendChild (Tyxml_js.To_dom.of_node error) |> ignore; 77 | raise ex 78 | ) 79 | 80 | let () = 81 | match Dom_html.tagged (Dom_html.getElementById "ck_main") with 82 | | Dom_html.Div d -> Lwt_js_events.async (fun () -> start d) 83 | | _ -> failwith "Bad tree element" 84 | -------------------------------------------------------------------------------- /js/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name client) 3 | (modes byte js) 4 | (preprocess (pps js_of_ocaml-ppx)) 5 | (libraries cuekeeper js_of_ocaml js_of_ocaml-tyxml js_of_ocaml-lwt 6 | cohttp-lwt-jsoo irmin-indexeddb omd irmin-git digestif.ocaml)) 7 | -------------------------------------------------------------------------------- /js/pikaday.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | (** Bindings for Pikadate. 5 | * See https://github.com/dbushell/Pikaday/ *) 6 | 7 | open Js_of_ocaml 8 | open Js_of_ocaml_tyxml.Tyxml_js 9 | 10 | class type pikaday = 11 | object 12 | method getDate : Js.date Js.t Js.Opt.t Js.meth 13 | end 14 | 15 | class type config = 16 | object 17 | method container : Dom_html.element Js.t Js.prop 18 | method onSelect : (pikaday, Js.date Js.t -> unit) Js.meth_callback Js.prop 19 | method defaultDate : Js.date Js.t Js.Optdef.t Js.prop 20 | method setDefaultDate : bool Js.t Js.prop 21 | end 22 | 23 | let make_config () : config Js.t = Js.Unsafe.obj [| |] 24 | 25 | let pikaday_constr : (config Js.t -> pikaday Js.t) Js.constr = Js.Unsafe.global##._Pikaday 26 | 27 | let to_user_date d = 28 | Ck_time.make 29 | ~year:d##getFullYear 30 | ~month:d##getMonth 31 | ~day:d##getDate 32 | 33 | let make ?(initial:Ck_time.user_date option) ~on_select () = 34 | let div = Html5.div [] in 35 | let elem = To_dom.of_div div in 36 | let config = make_config () in 37 | config##.container := elem; 38 | config##.onSelect := Js.wrap_callback (fun d -> 39 | on_select (to_user_date d) 40 | ); 41 | begin match (initial :> (int * int * int) option) with 42 | | Some (y, m, d) -> 43 | let js_date = new%js Js.date_day y m d in 44 | config##.defaultDate := Js.Optdef.return js_date; 45 | config##.setDefaultDate := Js._true; 46 | | None -> () end; 47 | let pd = new%js pikaday_constr config in 48 | (div, pd) 49 | 50 | let get_date (pd : #pikaday Js.t) = 51 | Js.Opt.case pd##getDate 52 | (fun () -> None) 53 | (fun d -> Some (to_user_date d)) 54 | -------------------------------------------------------------------------------- /lib/ck_client.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Lwt.Infix 5 | open Ck_utils 6 | open Ck_sigs 7 | 8 | let tracking_branch = "server" 9 | 10 | let (>>!=) x f = 11 | x >>= function 12 | | `Error _ as e -> Lwt.return e 13 | | `Ok y -> f y 14 | | `Cancelled_by_user as c -> Lwt.return c 15 | 16 | module Make(Clock : Ck_clock.S) 17 | (Git : Git_storage_s.S) 18 | (RPC : RPC) = struct 19 | type t = { 20 | master : Git.Branch.t; 21 | server_branch : Git.Branch.t; 22 | merge_from : Git.Commit.t -> unit or_error Lwt.t; 23 | base : Uri.t; 24 | sync_in_progress : bool React.S.t; 25 | set_sync_in_progress : bool -> unit; 26 | } 27 | 28 | let make ~master ~server_branch ~merge_from base = 29 | let sync_in_progress, set_sync_in_progress = React.S.create false in 30 | { 31 | master; server_branch; merge_from; base; 32 | sync_in_progress; set_sync_in_progress; 33 | } 34 | 35 | let get ~base path = 36 | RPC.get (Uri.with_path base path) >>= function 37 | | `Cancelled_by_user -> Lwt.return `Cancelled_by_user 38 | | `Ok (resp, body) -> 39 | match resp.Cohttp.Response.status with 40 | | `OK -> Cohttp_lwt.Body.to_string body >|= fun body -> `Ok body 41 | | code -> Lwt.return (error "Bad status code '%s' from server" (Cohttp.Code.string_of_status code)) 42 | 43 | let post ~base path body = 44 | let body = Cohttp_lwt.Body.of_string body in 45 | let headers = Cohttp.Header.init_with "Content-Type" "application/octet-stream" in 46 | RPC.post ~headers ~body (Uri.with_path base path) >>= function 47 | | `Cancelled_by_user -> Lwt.return `Cancelled_by_user 48 | | `Ok (resp, body) -> 49 | match resp.Cohttp.Response.status with 50 | | `OK -> Cohttp_lwt.Body.to_string body >|= fun body -> `Ok body 51 | | code -> Lwt.return (error "Bad status code '%s' from server" (Cohttp.Code.string_of_status code)) 52 | 53 | let fetch ~base ~server_branch = 54 | let path = 55 | match React.S.value (Git.Branch.head server_branch) with 56 | | Some last_known -> "fetch/" ^ Digestif.SHA1.to_hex (Git.Commit.id last_known) 57 | | None -> "fetch" in 58 | get ~base path >>!= function 59 | | "" -> 60 | Git.Branch.force server_branch None >|= fun () -> `Ok None 61 | | bundle -> 62 | Git.Branch.fetch_bundle server_branch bundle >>!= fun commit -> 63 | Lwt.return (`Ok (Some commit)) 64 | 65 | let pull t = 66 | fetch ~base:t.base ~server_branch:t.server_branch >>!= function 67 | | None -> Lwt.return (`Ok None) 68 | | Some commit -> 69 | (* If server_head isn't in the history of master, merge it now. *) 70 | t.merge_from commit >>!= fun () -> Lwt.return (`Ok (Some commit)) 71 | 72 | let push t server_head = 73 | match Git.Branch.head t.master |> React.S.value, server_head with 74 | | None, _ -> 75 | failwith "no master branch!" 76 | | Some new_head, Some server_head when Git.Commit.equal new_head server_head -> 77 | Lwt.return (`Ok ()) 78 | | Some new_head, _ -> 79 | Git.Commit.bundle ~tracking_branch new_head >>= function 80 | | None -> Lwt.return (`Ok ()) 81 | | Some bundle -> 82 | post ~base:t.base "push" bundle >>!= function 83 | | "ok" -> 84 | begin Git.Branch.fast_forward_to t.server_branch new_head >>= function 85 | | `Not_fast_forward -> 86 | Lwt.return (error "Push successful, but failed to fast-forward tracking branch - newer concurrent push?") 87 | | `Ok -> Lwt.return (`Ok ()) 88 | end 89 | | "not-fast-forward" -> Lwt.return `Concurrent_update 90 | | msg -> Lwt.return (error "Unexpected response '%s'" msg) 91 | 92 | let sync t = 93 | let rec aux () = 94 | pull t >>!= fun server_head -> 95 | (* Our master branch now includes [server_head] *) 96 | push t server_head >>= function 97 | | `Concurrent_update -> 98 | Printf.eprintf "Warning: Concurrent update during sync; retrying\n%!"; 99 | Clock.sleep 2.0 >>= aux 100 | | `Ok () | `Cancelled_by_user | `Error _ as r -> Lwt.return r in 101 | if React.S.value t.sync_in_progress then 102 | Lwt.return (`Error "Sync already in progress") 103 | else ( 104 | t.set_sync_in_progress true; 105 | Lwt.finalize aux (fun () -> t.set_sync_in_progress false; Lwt.return ()) 106 | ) 107 | 108 | let sync_in_progress t = t.sync_in_progress 109 | end 110 | -------------------------------------------------------------------------------- /lib/ck_client.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | (** Client-side code for syncing with a remote server. *) 5 | 6 | open Ck_sigs 7 | 8 | val tracking_branch : Git_storage_s.branch_name 9 | 10 | module Make(Clock : Ck_clock.S) 11 | (Git : Git_storage_s.S) 12 | (RPC : RPC) : sig 13 | type t 14 | 15 | val make : 16 | master:Git.Branch.t -> 17 | server_branch:Git.Branch.t -> 18 | merge_from:(Git.Commit.t -> unit or_error Lwt.t) -> 19 | Uri.t -> 20 | t 21 | (** Create a client for the server at the given URL. 22 | * Syncing will fetch changes into [server_branch] and then merge them into [master] 23 | * using [merge_from], before pushing [master] to the server. *) 24 | 25 | val fetch : base:Uri.t -> server_branch:Git.Branch.t -> Git.Commit.t option or_error_or_cancelled Lwt.t 26 | (* Fetch the current server head and store in [server_branch]. 27 | * Returns the [Commit.t] for the server's head. 28 | * Exposed to allow initialising the repository from the server on first use. *) 29 | 30 | val sync : t -> unit or_error_or_cancelled Lwt.t 31 | (** Sync with server. *) 32 | 33 | val sync_in_progress : t -> bool React.S.t 34 | (** True while we are syncing with the remote server. *) 35 | end 36 | -------------------------------------------------------------------------------- /lib/ck_clock.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | module type S = sig 5 | val now : unit -> float 6 | val async : name:string -> (unit -> unit Lwt.t) -> unit 7 | val sleep : float -> unit Lwt.t 8 | end 9 | -------------------------------------------------------------------------------- /lib/ck_disk_node.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Sexplib.Conv 5 | open Ck_utils 6 | 7 | type node_details = { 8 | parent : Ck_id.t option [@sexp.option]; 9 | name : string; 10 | description : string; 11 | ctime : float; 12 | contact : Ck_id.t option [@sexp.option]; 13 | conflicts : string list [@sexp.list]; 14 | } [@@deriving sexp] 15 | 16 | type astate = 17 | [ `Next 18 | | `Waiting 19 | | `Waiting_for_contact 20 | | `Waiting_until of Ck_time.user_date 21 | | `Future 22 | | `Done ] 23 | [@@deriving sexp] 24 | 25 | type action_details = { 26 | astarred : bool [@default false]; 27 | astate : astate; 28 | context : Ck_id.t option [@sexp.option]; 29 | repeat: Ck_time.repeat option [@sexp.option]; 30 | } [@@deriving sexp] 31 | 32 | type project_details = { 33 | pstarred : bool [@default false]; 34 | pstate : [ `Active | `SomedayMaybe | `Done ] 35 | } [@@deriving sexp] 36 | 37 | type apa = 38 | [ `Action of (action_details * node_details) 39 | | `Project of (project_details * node_details) 40 | | `Area of node_details ] 41 | [@@deriving sexp] 42 | 43 | type generic = 44 | [ apa 45 | | `Contact of node_details 46 | | `Context of node_details ] 47 | 48 | module Types = struct 49 | type action_node = action_details * node_details 50 | type project_node = project_details * node_details 51 | type area_node = node_details 52 | type contact_node = node_details 53 | type context_node = node_details 54 | 55 | type action = [`Action of action_node] 56 | type project = [`Project of project_node] 57 | type area = [`Area of area_node] 58 | type contact = [`Contact of contact_node] 59 | type context = [`Context of context_node] 60 | end 61 | 62 | let details = function 63 | | `Action (_, d) 64 | | `Project (_, d) 65 | | `Area d -> d 66 | | `Contact d -> d 67 | | `Context d -> d 68 | 69 | let ctime t = (details t).ctime 70 | let name t = (details t).name 71 | let description t = (details t).description 72 | let parent t = (details t).parent 73 | let contact t = (details t).contact 74 | let conflicts t = (details t).conflicts 75 | 76 | let of_string s = apa_of_sexp (Sexplib.Sexp.of_string s) 77 | let to_string t = Sexplib.Sexp.to_string (sexp_of_apa (t :> apa)) 78 | 79 | let contact_of_string s = `Contact (node_details_of_sexp (Sexplib.Sexp.of_string s)) 80 | let contact_to_string (`Contact t) = Sexplib.Sexp.to_string (sexp_of_node_details t) 81 | 82 | let context_of_string s = `Context (node_details_of_sexp (Sexplib.Sexp.of_string s)) 83 | let context_to_string (`Context t) = Sexplib.Sexp.to_string (sexp_of_node_details t) 84 | 85 | let make ~name ~description ~parent ~ctime ~contact = { 86 | name; 87 | description; 88 | parent; 89 | ctime; 90 | contact; 91 | conflicts = []; 92 | } 93 | 94 | let map_apa fn = function 95 | | `Action (x, d) -> `Action (x, fn d) 96 | | `Project (x, d) -> `Project (x, fn d) 97 | | `Area d -> `Area (fn d) 98 | 99 | let map_details fn = function 100 | | `Action _ | `Project _ | `Area _ as node -> map_apa fn node 101 | | `Contact d -> `Contact (fn d) 102 | | `Context d -> `Context (fn d) 103 | 104 | let with_name node name = node |> map_details (fun d -> {d with name}) 105 | let with_description node description = node |> map_details (fun d -> {d with description}) 106 | let with_parent node parent = node |> map_apa (fun d -> {d with parent}) 107 | let with_contact node contact = node |> map_apa (fun d -> {d with contact}) 108 | let equal = (=) 109 | 110 | let context (`Action (action_details, _)) = action_details.context 111 | let action_repeat (`Action ({ repeat; _ }, _)) = repeat 112 | let action_state (`Action ({ astate; _ }, _)) = astate 113 | let project_state (`Project ({ pstate; _ }, _)) = pstate 114 | let starred = function 115 | | `Project ({ pstarred; _ }, _ ) -> pstarred 116 | | `Action ({ astarred; _ }, _) -> astarred 117 | 118 | let with_repeat (`Action (a, details)) repeat = `Action ({a with repeat}, details) 119 | let with_astate (`Action (a, details)) astate = `Action ({a with astate}, details) 120 | let with_pstate (`Project (p, details)) pstate = `Project ({p with pstate}, details) 121 | 122 | let with_starred node s = 123 | match node with 124 | | `Action (a, d) -> `Action ({a with astarred = s}, d) 125 | | `Project (p, d) -> `Project ({p with pstarred = s}, d) 126 | 127 | let with_context (`Action (a, details)) context = `Action ({a with context}, details) 128 | 129 | let make_action ~state ?context ?contact ~name ~description ?parent ~ctime () = 130 | `Action ({ astate = state; astarred = false; context; repeat = None }, make ~name ~description ~parent ~ctime ~contact) 131 | 132 | let make_project ~state ?contact ~name ~description ?parent ~ctime () = 133 | `Project ({ pstate = state; pstarred = false }, make ~name ~description ~parent ~ctime ~contact) 134 | 135 | let make_area ?contact ~name ~description ?parent ~ctime () = 136 | `Area (make ~name ~description ~parent ~ctime ~contact) 137 | 138 | let make_contact ~name ~description ~ctime () = 139 | `Contact (make ~name ~description ~parent:None ~ctime ~contact:None) 140 | 141 | let make_context ~name ~description ~ctime () = 142 | `Context (make ~name ~description ~parent:None ~ctime ~contact:None) 143 | 144 | let is_done = function 145 | | `Action ({ astate; _}, _) -> astate = `Done 146 | | `Project ({ pstate; _}, _) -> pstate = `Done 147 | 148 | let as_project = function 149 | | `Action ({ astarred; _}, d) -> `Project ({pstate = `Active; pstarred = astarred}, d) 150 | | `Project _ as p -> p 151 | | `Area d -> `Project ({pstate = `Active; pstarred = false}, d) 152 | 153 | let as_area (`Project (_, d)) = `Area d 154 | 155 | let as_action = function 156 | | `Project ({ pstarred; _}, d) -> `Action ({astate = `Next; astarred = pstarred; context = None; repeat = None}, d) 157 | | `Action _ as a -> a 158 | | `Area d -> `Action ({astate = `Next; astarred = false; context = None; repeat = None}, d) 159 | 160 | let merge_detail ~log ~fmt ~base ~theirs ours = 161 | if base = theirs then ours 162 | else if base = ours then theirs 163 | else if theirs = ours then theirs 164 | else ( 165 | let keep, discard = 166 | if ours < theirs then ours, theirs 167 | else theirs, ours in 168 | Printf.sprintf "Discarded change %s -> %s" (fmt base) (fmt discard) |> log; 169 | keep 170 | ) 171 | 172 | let merge_description ~log ~base ~theirs ours = 173 | if base = theirs then ours 174 | else if base = ours then theirs 175 | else if theirs = ours then theirs 176 | else ( 177 | log "Conflicting descriptions; keeping both"; 178 | List.sort String.compare [ours; theirs] 179 | |> String.concat "\n\n----\n\n" 180 | ) 181 | 182 | (* Used for the (unlikely) case of a merge with no common ancestor *) 183 | let default_base = make ~name:"" ~description:"" ~parent:None ~ctime:0.0 ~contact:None 184 | 185 | let opt_uuid = function 186 | | None -> "(none)" 187 | | Some uuid -> Ck_id.to_string uuid 188 | let fmt_repeat = function 189 | | None -> "never" 190 | | Some repeat -> Ck_time.string_of_repeat repeat 191 | let str x = x 192 | let star = function 193 | | false -> "unstarred" 194 | | true -> "starred" 195 | let fmt_pstate = function 196 | | `Active -> "active" 197 | | `Done -> "done" 198 | | `SomedayMaybe -> "someday/maybe" 199 | let fmt_astate = function 200 | | `Next -> "next" 201 | | `Waiting -> "waiting" 202 | | `Waiting_for_contact -> "waiting for contact" 203 | | `Waiting_until date -> Printf.sprintf "waiting until %s" (Ck_time.string_of_user_date date) 204 | | `Future -> "future" 205 | | `Done -> "done" 206 | 207 | let dedup xs = 208 | let rec aux acc = function 209 | | [] -> acc 210 | | x :: ((y :: _) as rest) when x = y -> aux acc rest 211 | | x :: xs -> aux (x :: acc) xs in 212 | aux [] (List.sort String.compare xs) 213 | 214 | let merge_details ~log ~base ~theirs ours = 215 | let {parent; name; description; ctime; contact; conflicts} = ours in 216 | let parent = merge_detail ~log ~fmt:opt_uuid ~base:base.parent ~theirs:theirs.parent parent in 217 | let name = merge_detail ~log ~fmt:str ~base:base.name ~theirs:theirs.name name in 218 | let description = merge_description ~log ~base:base.description ~theirs:theirs.description description in 219 | let ctime = min (min base.ctime theirs.ctime) ctime in 220 | let contact = merge_detail ~log ~fmt:opt_uuid ~base:base.contact ~theirs:theirs.contact contact in 221 | let conflicts = dedup (conflicts @ theirs.conflicts) in 222 | {parent; name; description; ctime; contact; conflicts} 223 | 224 | let merge_project ~log ~base ~theirs ours = 225 | let `Project (base_prj, base_details) = base in 226 | let (their_prj, their_details) = theirs in 227 | let ({pstarred; pstate}, our_details) = ours in 228 | let prj = { 229 | pstarred = merge_detail ~log ~fmt:star ~base:base_prj.pstarred ~theirs:their_prj.pstarred pstarred; 230 | pstate = merge_detail ~log ~fmt:fmt_pstate ~base:base_prj.pstate ~theirs:their_prj.pstate pstate; 231 | } in 232 | `Project (prj, merge_details ~log ~base:base_details ~theirs:their_details our_details) 233 | 234 | (* If we decided the final state should be [`Waiting_for_contact] then make sure we pick the 235 | * contact from the same place. *) 236 | let merge_waiting_contact ~log ~theirs ours = 237 | let (their_act, their_details) = theirs in 238 | let (our_act, our_details) = ours in 239 | if their_details.contact = our_details.contact then their_details, our_details 240 | else match their_act.astate, our_act.astate with 241 | | `Waiting_for_contact, `Waiting_for_contact -> their_details, our_details (* Normal merge *) 242 | | `Waiting_for_contact, _ -> 243 | log "Different contacts; picking the one we were waiting for"; 244 | their_details, {our_details with contact = their_details.contact} 245 | | _, `Waiting_for_contact -> 246 | log "Different contacts; picking the one we were waiting for"; 247 | {their_details with contact = our_details.contact}, our_details 248 | | _ -> assert false 249 | 250 | let merge_action ~log ~base ~theirs ours = 251 | let `Action (base_act, base_details) = base in 252 | let (their_act, their_details) = theirs in 253 | let ({astarred; astate; context; repeat}, our_details) = ours in 254 | let repeat = merge_detail ~log ~fmt:fmt_repeat ~base:base_act.repeat ~theirs:their_act.repeat repeat in 255 | let astate = merge_detail ~log ~fmt:fmt_astate ~base:base_act.astate ~theirs:their_act.astate astate in 256 | let astate = 257 | match astate with 258 | | `Done when repeat <> None -> log "Set to repeat and marked done"; `Next 259 | | s -> s in 260 | let details = 261 | let their_details, our_details = 262 | match astate with 263 | | `Waiting_for_contact -> merge_waiting_contact ~log ~theirs ours 264 | | _ -> their_details, our_details in 265 | merge_details ~log ~base:base_details ~theirs:their_details our_details in 266 | let act = { 267 | astarred = merge_detail ~log ~fmt:star ~base:base_act.astarred ~theirs:their_act.astarred astarred; 268 | astate; 269 | context = merge_detail ~log ~fmt:opt_uuid ~base:base_act.context ~theirs:their_act.context context; 270 | repeat; 271 | } in 272 | `Action (act, details) 273 | 274 | let merge ?base ~theirs ours = 275 | let base = (base :> apa option) |> default (`Area default_base) in 276 | let theirs = (theirs :> apa) in 277 | let ours = (ours :> apa) in 278 | if base = theirs then ours 279 | else if base = ours then theirs 280 | else ( 281 | let conflicts = ref [] in 282 | let log msg = conflicts := msg :: !conflicts in 283 | let merged = 284 | match theirs, ours with 285 | | `Area theirs, `Area ours -> `Area (merge_details ~log ~base:(details base) ~theirs ours) 286 | | `Project theirs, `Project ours -> merge_project ~log ~base:(as_project base) ~theirs ours 287 | | `Action theirs, `Action ours -> merge_action ~log ~base:(as_action base) ~theirs ours 288 | | theirs, ours -> 289 | log "Type mismatch: converting to project"; 290 | let `Project theirs = as_project theirs in 291 | let `Project ours = as_project ours in 292 | merge_project ~log ~base:(as_project base) ~theirs ours 293 | in 294 | merged |> map_apa (fun d -> {d with conflicts = d.conflicts @ !conflicts}) 295 | ) 296 | 297 | let merge_context ?base ~theirs ours = 298 | let base = base |> default (`Context default_base) in 299 | if base = theirs then ours 300 | else if base = ours then theirs 301 | else ( 302 | let `Context base = base in 303 | let `Context theirs = theirs in 304 | let `Context ours = ours in 305 | let conflicts = ref [] in 306 | let log msg = conflicts := msg :: !conflicts in 307 | let merged = merge_details ~log ~base ~theirs ours in 308 | `Context {merged with conflicts = merged.conflicts @ !conflicts} 309 | ) 310 | 311 | let merge_contact ?base ~theirs ours = 312 | let base = base |> default (`Contact default_base) in 313 | if base = theirs then ours 314 | else if base = ours then theirs 315 | else ( 316 | let `Contact base = base in 317 | let `Contact theirs = theirs in 318 | let `Contact ours = ours in 319 | let conflicts = ref [] in 320 | let log msg = conflicts := msg :: !conflicts in 321 | let merged = merge_details ~log ~base ~theirs ours in 322 | `Contact {merged with conflicts = merged.conflicts @ !conflicts} 323 | ) 324 | 325 | let with_conflict msg node = node |> map_details (fun d -> {d with conflicts = msg :: d.conflicts}) 326 | let with_conflict : 'a. string -> ([< generic] as 'a) -> 'a = fun msg node -> Obj.magic (with_conflict msg node) 327 | 328 | let without_conflicts node = node |> map_details (fun d -> {d with conflicts = []}) 329 | let without_conflicts : 'a. ([< generic] as 'a) -> 'a = fun node -> Obj.magic (without_conflicts node) 330 | -------------------------------------------------------------------------------- /lib/ck_disk_node.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | (** The data that gets stored to disk (e.g. parent UUID), but not data we calculate on loading 5 | * (e.g. list of children). *) 6 | 7 | open Ck_sigs 8 | 9 | include DISK_NODE 10 | open Types 11 | 12 | val of_string : string -> [ area | project | action ] 13 | val to_string : [< area | project | action ] -> string 14 | 15 | val contact_of_string : string -> contact 16 | val contact_to_string : contact -> string 17 | 18 | val context_of_string : string -> context 19 | val context_to_string : context -> string 20 | 21 | val equal : ([< generic] as 'a) -> 'a -> bool 22 | 23 | val make_action : state:action_state -> ?context:Ck_id.t -> ?contact:Ck_id.t -> name:string -> description:string -> ?parent:Ck_id.t -> ctime:float -> unit -> [> action] 24 | val make_project : state:project_state -> ?contact:Ck_id.t -> name:string -> description:string -> ?parent:Ck_id.t -> ctime:float -> unit -> [> project] 25 | val make_area : ?contact:Ck_id.t -> name:string -> description:string -> ?parent:Ck_id.t -> ctime:float -> unit -> [> area] 26 | val make_contact : name:string -> description:string -> ctime:float -> unit -> contact 27 | val make_context : name:string -> description:string -> ctime:float -> unit -> context 28 | 29 | val with_name : generic -> string -> generic 30 | val with_description : generic -> string -> generic 31 | val with_parent : [< area | project | action] -> Ck_id.t option -> [area | project | action] 32 | val with_contact : [< area | project | action] -> Ck_id.t option -> [area | project | action] 33 | val with_repeat : action -> Ck_time.repeat option -> [> action] 34 | val with_astate : action -> action_state -> action 35 | val with_pstate : project -> [ `Active | `SomedayMaybe | `Done ] -> project 36 | val with_starred : [< project | action] -> bool -> [project | action] 37 | val with_context : action -> Ck_id.t option -> action 38 | 39 | val as_area : project -> area 40 | val as_project : [< area | action] -> project 41 | val as_action : project -> action 42 | 43 | val merge : ?base:[< area | project | action] -> theirs:[< area | project | action] -> [< area | project | action] -> 44 | [area | project | action] 45 | val merge_context : ?base:context -> theirs:context -> context -> context 46 | val merge_contact : ?base:contact -> theirs:contact -> contact -> contact 47 | val with_conflict : string -> ([< generic] as 'a) -> 'a 48 | val without_conflicts : ([< generic] as 'a) -> 'a 49 | 50 | val fmt_pstate : [< project_state] -> string 51 | val fmt_astate : [< action_state] -> string 52 | -------------------------------------------------------------------------------- /lib/ck_id.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Sexplib.Std 5 | 6 | type t = string [@@deriving sexp] 7 | 8 | let mint = 9 | let seed = Random.State.make_self_init () in 10 | let gen = Uuidm.v4_gen seed in 11 | fun () -> Uuidm.to_string (gen ()) 12 | 13 | let to_string t = t 14 | let of_string t = t 15 | let fmt () t = t 16 | let compare = String.compare 17 | 18 | module M = Map.Make(String) 19 | module S = Set.Make(String) 20 | -------------------------------------------------------------------------------- /lib/ck_id.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | type t = private string [@@deriving sexp] 5 | 6 | val mint : unit -> t 7 | val to_string : t -> string 8 | val of_string : string -> t 9 | val fmt : unit -> t -> string 10 | val compare : t -> t -> int 11 | 12 | module M : Map.S with type key = t 13 | module S : Set.S with type elt = t 14 | -------------------------------------------------------------------------------- /lib/ck_merge.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Ck_utils 5 | open Lwt.Infix 6 | 7 | module Make(Git : Git_storage_s.S) (R : Ck_rev.S with type commit = Git.Commit.t) = struct 8 | open R.Node.Types 9 | 10 | let ok x = Lwt.return (`Ok x) 11 | 12 | type 'a patch = 13 | [ `Add of 'a 14 | | `Remove of 'a 15 | | `Update of 'a * 'a ] Ck_id.M.t 16 | 17 | type diff = { 18 | nodes : [area | project | action] patch; 19 | contacts : contact patch; 20 | contexts : context patch; 21 | } 22 | 23 | module type KIND = sig 24 | type t 25 | type disk_t 26 | val dir : string 27 | val get : R.t -> Ck_id.t -> t option 28 | val to_disk : t -> disk_t 29 | val merge : ?base:disk_t -> theirs:disk_t -> disk_t -> disk_t 30 | val to_string : disk_t -> string 31 | val diff : diff -> t patch 32 | val with_conflict : string -> disk_t -> disk_t 33 | val equal : t -> t -> bool 34 | end 35 | 36 | module APA : KIND = struct 37 | type t = [area | project | action] 38 | type disk_t = [Ck_disk_node.Types.area | Ck_disk_node.Types.project | Ck_disk_node.Types.action] 39 | let dir = "db" 40 | let get = R.get 41 | let to_disk = R.apa_node 42 | let merge = Ck_disk_node.merge 43 | let to_string = Ck_disk_node.to_string 44 | let diff p = p.nodes 45 | let with_conflict = Ck_disk_node.with_conflict 46 | let equal = R.Node.equal 47 | end 48 | 49 | module Contact : KIND = struct 50 | type t = contact 51 | type disk_t = Ck_disk_node.Types.contact 52 | let dir = "contact" 53 | let get = R.get_contact 54 | let to_disk = R.contact_node 55 | let merge = Ck_disk_node.merge_contact 56 | let to_string = Ck_disk_node.contact_to_string 57 | let diff p = p.contacts 58 | let with_conflict = Ck_disk_node.with_conflict 59 | let equal = R.Node.equal 60 | end 61 | 62 | module Context : KIND = struct 63 | type t = context 64 | type disk_t = Ck_disk_node.Types.context 65 | let dir = "context" 66 | let get = R.get_context 67 | let to_disk = R.context_node 68 | let merge = Ck_disk_node.merge_context 69 | let to_string = Ck_disk_node.context_to_string 70 | let diff p = p.contexts 71 | let with_conflict = Ck_disk_node.with_conflict 72 | let equal = R.Node.equal 73 | end 74 | 75 | (* [diff_k base v] is a map with an entry for every changed node in base or v, saying how it changed. *) 76 | let diff_k base_nodes v_nodes = 77 | Ck_id.M.merge (fun _key o n -> 78 | match o, n with 79 | | None, None -> assert false 80 | | None, Some added -> Some (`Add added) 81 | | Some removed, None -> Some (`Remove removed) 82 | | Some old, Some current when R.Node.equal old current -> None 83 | | Some old, Some current -> Some (`Update (old, current)) 84 | ) base_nodes v_nodes 85 | 86 | (* [diff ~base_rev v] is a diff from [base_rev] to [v]. If [base_rev] isn't given 87 | * then we assume it was empty and only generate [`Add] patches. *) 88 | let diff ?base_rev v = 89 | let base_nodes, base_contacts, base_contexts = 90 | match base_rev with 91 | | None -> Ck_id.M.empty, Ck_id.M.empty, Ck_id.M.empty 92 | | Some base -> R.nodes base, R.contacts base, R.contexts base in 93 | let nodes = diff_k base_nodes (R.nodes v) in 94 | let contacts = diff_k base_contacts (R.contacts v) in 95 | let contexts = diff_k base_contexts (R.contexts v) in 96 | { nodes; contacts; contexts } 97 | 98 | (** [merge_k k ~their_changes ~our_changes stage] updates [stage], which initially contains 99 | * "their" state, to include the changes of kind [k] in [our_changes]. *) 100 | let merge_k (module K : KIND) ~their_changes ~our_changes ~stage = 101 | K.diff our_changes 102 | |> Ck_id.M.bindings 103 | |> Lwt_list.iter_s (fun (uuid, our_patch) -> 104 | let save x = K.to_string x |> Git.Staging.update stage [K.dir; Ck_id.to_string uuid] in 105 | let their_patch = 106 | try Some (Ck_id.M.find uuid (K.diff their_changes)) 107 | with Not_found -> None in 108 | match our_patch, their_patch with 109 | | (`Add node | `Update (_, node)), None -> 110 | (* The change was only on our side, so use it directly *) 111 | K.to_disk node |> save 112 | | `Update (_, ours), Some (`Remove _) -> 113 | K.to_disk ours 114 | |> K.with_conflict "Deleted and modified; keeping modified version" 115 | |> save 116 | | `Remove _, (None | Some (`Remove _)) -> 117 | Git.Staging.remove stage [K.dir; Ck_id.to_string uuid] 118 | | `Remove _, Some (`Update (_, theirs)) -> 119 | K.to_disk theirs 120 | |> K.with_conflict "Deleted and modified; keeping modified version" 121 | |> save 122 | | `Add ours, Some (`Add theirs) -> 123 | if K.equal ours theirs then Lwt.return () 124 | else K.merge ?base:None ~theirs:(K.to_disk theirs) (K.to_disk ours) |> save 125 | | `Update (base, ours), Some (`Update (_, theirs)) -> 126 | if K.equal ours theirs then Lwt.return () 127 | else K.merge ~base:(K.to_disk base) ~theirs:(K.to_disk theirs) (K.to_disk ours) |> save 128 | | `Add _, Some (`Update _ | `Remove _) 129 | | (`Update _ | `Remove _), Some (`Add _) -> 130 | (* Add implies it wasn't in the base, Update/Remove that it was *) 131 | assert false 132 | ) 133 | 134 | (* Used to check for cycles in the parent relation *) 135 | type rooted = Rooted | Checking 136 | 137 | type required = { 138 | required_contacts : Ck_id.S.t; 139 | required_contexts : Ck_id.S.t; 140 | } 141 | 142 | (* After merging the area/project/action nodes, find out which contacts 143 | * and contexts they refer to so that we don't delete them. 144 | * For example, one branch might delete a contact while another makes that 145 | * the contact for an action. 146 | * Also, fixup any invalid parent links. 147 | *) 148 | let scan_merged_nodes staging = 149 | let required_contacts = ref Ck_id.S.empty in 150 | let required_contexts = ref Ck_id.S.empty in 151 | let nodes = Hashtbl.create 100 in 152 | (* Load all the nodes into [nodes] *) 153 | Git.Staging.list staging [APA.dir] >>= 154 | Lwt_list.iter_s (fun uuid -> 155 | Git.Staging.read_exn staging [APA.dir; uuid] >|= fun node -> 156 | let uuid = Ck_id.of_string uuid in 157 | Ck_disk_node.of_string node |> Hashtbl.add nodes uuid 158 | ) >>= fun () -> 159 | let get uuid = 160 | try Some (Hashtbl.find nodes uuid) 161 | with Not_found -> None in 162 | (* Look up the parent node. [None] if there is no parent 163 | * or the parent is missing. *) 164 | let parent node = 165 | Ck_disk_node.parent node >>?= (fun uuid -> 166 | try Some (Hashtbl.find nodes uuid) 167 | with Not_found -> None 168 | ) in 169 | let to_clear = ref [] in 170 | let ignore_node : [< Ck_disk_node.generic] -> unit = ignore in 171 | let clear_parent ~msg uuid node = 172 | let node = 173 | Ck_disk_node.with_parent node None 174 | |> Ck_disk_node.with_conflict msg in 175 | Hashtbl.replace nodes uuid node; 176 | to_clear := (uuid, node) :: !to_clear; 177 | node in 178 | let rooted = Hashtbl.create 100 in 179 | (* Check that following the parent links from this node leads to a root. 180 | * If there's a cycle, break it. *) 181 | let rec ensure_rooted uuid node = 182 | try 183 | match Hashtbl.find rooted uuid with 184 | | Checking -> clear_parent ~msg:"Removed parent due to cycle" uuid node 185 | | Rooted -> node (* Already checked this one *) 186 | with Not_found -> 187 | match Ck_disk_node.parent node with 188 | | None -> 189 | Hashtbl.add rooted uuid Rooted; 190 | node 191 | | Some parent -> 192 | match get parent with 193 | | None -> 194 | (* Maybe prevent this case from happening? *) 195 | Hashtbl.replace rooted uuid Rooted; 196 | clear_parent ~msg:"Parent was deleted" uuid node 197 | | Some parent_node -> 198 | Hashtbl.add rooted uuid Checking; 199 | ensure_rooted parent parent_node |> ignore_node; 200 | Hashtbl.replace rooted uuid Rooted; 201 | node 202 | in 203 | (* Scan all nodes *) 204 | nodes |> Hashtbl.iter (fun uuid node -> 205 | (* Ensure reachable from root, breaking cycles if necessary *) 206 | let node = ensure_rooted uuid node in 207 | (* Note any required contact *) 208 | begin match Ck_disk_node.contact node with 209 | | None -> () 210 | | Some contact -> required_contacts := !required_contacts |> Ck_id.S.add contact 211 | end; 212 | (* Note any required context *) 213 | begin match node with 214 | | `Action _ as node -> 215 | begin match Ck_disk_node.context node with 216 | | None -> () 217 | | Some context -> required_contexts := !required_contexts |> Ck_id.S.add context end 218 | | _ -> () 219 | end; 220 | (* Check parent is of the right type *) 221 | match parent node, node with 222 | | Some `Action _, _ -> clear_parent ~msg:"Removed parent as it became an action" uuid node |> ignore_node 223 | | Some `Project _, `Area _ -> clear_parent ~msg:"Removed parent as it is not an area" uuid node |> ignore_node 224 | | _ -> () 225 | ); 226 | (* Apply all the changes now (since Hashtbl.iter isn't async). *) 227 | !to_clear |> Lwt_list.iter_s (fun (uuid, node) -> 228 | Ck_disk_node.to_string node 229 | |> Git.Staging.update staging [APA.dir; Ck_id.to_string uuid] 230 | ) >|= fun () -> 231 | { 232 | required_contacts = !required_contacts; 233 | required_contexts = !required_contexts; 234 | } 235 | 236 | (** If an node we require was deleted then bring it back. 237 | * This can only happen if it was deleted in one branch and untouched in the other. *) 238 | let keep (module K : KIND) ~base_rev required stage = 239 | let get uuid = K.get base_rev uuid >|?= K.to_disk in 240 | Ck_id.S.elements required 241 | |> Lwt_list.iter_s (fun uuid -> 242 | let path = [K.dir; Ck_id.to_string uuid] in 243 | Git.Staging.mem stage path >>= function 244 | | true -> Lwt.return () 245 | | false -> 246 | match get uuid with 247 | | None -> bug "Keep node '%a' doesn't exist in base!" Ck_id.fmt uuid 248 | | Some node -> 249 | node 250 | |> K.with_conflict "Deleted but also referenced; keeping" 251 | |> K.to_string 252 | |> Git.Staging.update stage path 253 | ) 254 | 255 | let stage_merge ?base ~theirs ours = 256 | let stage = Git.Commit.checkout theirs in 257 | let time = Ck_time.make ~year:2000 ~month:0 ~day:1 in 258 | begin match base with 259 | | None -> Lwt.return None 260 | | Some base -> R.make ~time base >|= fun r -> Some r 261 | end >>= fun base_rev -> 262 | R.make ~time theirs >>= fun their_rev -> 263 | R.make ~time ours >>= fun our_rev -> 264 | let their_changes = diff ?base_rev their_rev in 265 | let our_changes = diff ?base_rev our_rev in 266 | merge_k (module APA) ~their_changes ~our_changes ~stage >>= fun () -> 267 | (* Now we know which nodes we're keeping, break any invalid parent links. *) 268 | scan_merged_nodes stage >>= fun required -> 269 | merge_k (module Context) ~their_changes ~our_changes ~stage >>= fun () -> 270 | merge_k (module Contact) ~their_changes ~our_changes ~stage >>= fun () -> 271 | begin match base_rev with 272 | | None -> Lwt.return () (* If there's no base, there can't be anything in it to keep *) 273 | | Some base_rev -> 274 | keep (module Contact) ~base_rev required.required_contacts stage >>= fun () -> 275 | keep (module Context) ~base_rev required.required_contexts stage 276 | end >|= fun () -> stage 277 | 278 | let merge ?base ~theirs ours = 279 | match base with 280 | | Some base when Git.Commit.equal base theirs -> ok ours (* The common case *) 281 | | _ -> 282 | stage_merge ?base ~theirs ours >>= fun stage -> 283 | (* We could perhaps avoid a merge here if stage = theirs, but probably not worth it. *) 284 | Git.Commit.commit ~parents:[theirs; ours] stage ~msg:["Merge"] >>= ok 285 | 286 | let revert ~repo ~master log_entry = 287 | let open Git_storage_s in 288 | Git.Repository.commit repo log_entry.Log_entry.id >>= function 289 | | None -> Lwt.return (`Error "Commit to revert does not exist!") 290 | | Some commit -> 291 | let orig_summary = 292 | let msg = log_entry.Log_entry.msg in 293 | match String.index_opt msg '\n' with 294 | | None -> msg 295 | | Some i -> String.sub msg 0 i 296 | in 297 | let msg = [ 298 | Printf.sprintf "Revert \"%s\"" orig_summary; 299 | ""; 300 | Fmt.str "This reverts commit %a." Digestif.SHA1.pp log_entry.Log_entry.id 301 | ] in 302 | Git.Commit.parents commit >>= function 303 | | [] -> Lwt.return (`Error "Can't revert initial commit!") 304 | | _::_::_ -> Lwt.return (`Error "Can't revert merges, sorry") 305 | | [parent] -> 306 | stage_merge ~base:commit ~theirs:master parent >>= fun stage -> 307 | Git.Commit.commit ~parents:[master] stage ~msg >>= ok 308 | end 309 | -------------------------------------------------------------------------------- /lib/ck_merge.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | (** Merging two branches together. *) 5 | 6 | module Make (Git : Git_storage_s.S) (R : Ck_rev.S with type commit = Git.Commit.t) : sig 7 | (* [merge ?base ~theirs ours] merges changes from [base] to [ours] into [theirs] and 8 | * returns the resulting merge commit. *) 9 | val merge : ?base:Git.Commit.t -> theirs:Git.Commit.t -> Git.Commit.t -> 10 | [`Ok of Git.Commit.t | `Nothing_to_do] Lwt.t 11 | 12 | (** [revert ~master log_entry] returns a new commit on [master] which reverts the changes in [log_entry]. *) 13 | val revert : repo:Git.Repository.t -> master:Git.Commit.t -> Git_storage_s.Log_entry.t -> 14 | [`Ok of Git.Commit.t | `Nothing_to_do | `Error of string] Lwt.t 15 | end 16 | -------------------------------------------------------------------------------- /lib/ck_model.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | module Make (C : Ck_clock.S) (Git : Git_storage_s.S) (G : sig type t end) (RPC : Ck_sigs.RPC) : sig 5 | include Ck_model_s.MODEL with 6 | type gui_data = G.t 7 | 8 | val make : ?branch:string -> ?server:Uri.t -> Git.Repository.t -> t Lwt.t 9 | end 10 | -------------------------------------------------------------------------------- /lib/ck_model_s.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Ck_sigs 5 | 6 | module type MODEL = sig 7 | type t 8 | type gui_data 9 | 10 | type review_mode = [ `Done | `Waiting | `Future | `Areas | `Everything ] 11 | 12 | module Item : sig 13 | include DISK_NODE 14 | open Types 15 | 16 | val uuid : [< generic] -> Ck_id.t 17 | 18 | val is_due : Types.action -> bool 19 | (** Whether a [`Waiting_until] action is due. *) 20 | 21 | val contact_node : [< area | project | action] -> contact option 22 | end 23 | 24 | open Item.Types 25 | 26 | module Widget : sig 27 | (** An object visible on the screen. *) 28 | type t 29 | 30 | val item : t -> [ 31 | | `Item of [ area | project | action | contact | context ] React.S.t 32 | | `Group of string 33 | ] 34 | val children : t -> t ReactiveData.RList.t 35 | val state : t -> Slow_set.state React.S.t 36 | val gui_data : t -> gui_data option ref 37 | val unique : t -> bool 38 | (** Unique items occur at most once in the tree (and are often leaves). 39 | * Non-unique items are used for grouping, and are typically rendered as headings. *) 40 | 41 | type adder 42 | val adder : t -> adder option 43 | end 44 | 45 | type details = { 46 | details_item : [ area | project | action | contact | context ] option React.S.t; 47 | details_parent : [ area | project | action ] option React.S.t; 48 | details_context : context option option React.S.t; 49 | details_contact : contact option React.S.t option; 50 | details_children : Widget.t ReactiveData.RList.t; 51 | details_stop : stop; 52 | } 53 | 54 | val add_action : t -> state:action_state -> ?context:context -> ?contact:contact -> ?parent:[< area | project] -> 55 | name:string -> ?description:string -> unit -> [area | project | action] option Lwt.t 56 | val add_project : t -> ?state:project_state -> ?parent:[< area | project] -> name:string -> ?description:string -> unit -> [area | project | action] option Lwt.t 57 | val add_area : t -> ?parent:[< area] -> name:string -> ?description:string -> unit -> [area | project | action] option Lwt.t 58 | 59 | val add_contact : t -> name:string -> unit -> [> contact] option Lwt.t 60 | val set_contact : t -> [< area | project | action] -> contact option -> unit or_error Lwt.t 61 | 62 | val add_context : t -> name:string -> unit -> [> context] option Lwt.t 63 | val set_context : t -> action -> context -> unit or_error Lwt.t 64 | 65 | val add_child : t -> [< area | project | context] -> string -> [area | project | action] option Lwt.t 66 | val apply_adder : t -> Widget.adder -> string -> Item.generic option Lwt.t 67 | 68 | val clear_conflicts : t -> [< Item.generic] -> unit Lwt.t 69 | val delete : t -> [< Item.generic] -> unit or_error Lwt.t 70 | val delete_done : t -> unit Lwt.t 71 | 72 | val set_name : t -> [< Item.generic] -> string -> unit Lwt.t 73 | val set_description : t -> [< Item.generic] -> string -> unit Lwt.t 74 | val set_starred : t -> [< project | action] -> bool -> unit Lwt.t 75 | val set_action_state : t -> action -> [< action_state] -> unit Lwt.t 76 | val set_project_state : t -> project -> [ `Active | `SomedayMaybe | `Done ] -> unit Lwt.t 77 | val set_repeat : t -> action -> Ck_time.repeat option -> unit Lwt.t 78 | 79 | val convert_to_area : t -> project -> unit or_error Lwt.t 80 | val convert_to_project : t -> [< action | area] -> unit or_error Lwt.t 81 | val convert_to_action : t -> project -> unit or_error Lwt.t 82 | 83 | type candidate 84 | 85 | val candidate_parents_for : t -> [< area | project | action] -> candidate list 86 | (** Get the possible new parents for an item. *) 87 | 88 | val candidate_contacts_for : t -> [< area | project | action] -> candidate list 89 | (** Get the possible contacts for an action. *) 90 | 91 | val candidate_contexts_for : t -> action -> candidate list 92 | (** Get the possible contexts for an action. *) 93 | 94 | val candidate_label : candidate -> string 95 | val choose_candidate : candidate -> unit Lwt.t 96 | 97 | val server_head : t -> Digestif.SHA1.t option React.S.t 98 | (** The last commit we know the server has. *) 99 | 100 | val enable_log : t -> Git_storage_s.Log_entry.t Slow_set.item ReactiveData.RList.t Lwt.t 101 | val disable_log : t -> unit 102 | val revert : t -> Git_storage_s.Log_entry.t -> unit or_error Lwt.t 103 | 104 | val fix_head : t -> Git_storage_s.Log_entry.t option -> unit Lwt.t 105 | val fixed_head : t -> Git_storage_s.Log_entry.t option React.S.t 106 | 107 | type filter = (area * bool) list 108 | 109 | val set_mode : t -> [ `Process | `Work | `Contact | `Review | `Schedule ] -> unit 110 | val tree : t -> [ `Process of Widget.t ReactiveData.RList.t 111 | | `Work of filter React.S.t * Widget.t ReactiveData.RList.t 112 | | `Contact of Widget.t ReactiveData.RList.t 113 | | `Review of review_mode * Widget.t ReactiveData.RList.t 114 | | `Schedule of Widget.t ReactiveData.RList.t] React.S.t 115 | 116 | val set_review_mode : t -> review_mode -> unit 117 | 118 | val details : t -> [< Item.generic] -> details 119 | 120 | val alert : t -> bool React.S.t 121 | (** Alert the user that action is required (the Work view will show what) *) 122 | 123 | val export_tar : t -> string Lwt.t 124 | (** Export the current state as a tar file *) 125 | 126 | val search : t -> n:int -> (Item.generic -> 'a option) -> 'a Ck_utils.M.t 127 | (** [search t ~n test] finds up to [n] non-None results from [test item], which it calls 128 | * for all areas, projects, actions, contacts and contexts (until it has enough results). *) 129 | 130 | val set_hidden : t -> area -> bool -> unit 131 | (** Set whether to hide this top-level area in the work tab. *) 132 | 133 | module Client : sig 134 | type t 135 | 136 | val sync : t -> unit or_error_or_cancelled Lwt.t 137 | (** Sync with server. *) 138 | 139 | val sync_in_progress : t -> bool React.S.t 140 | (** True while we are syncing with the remote server. *) 141 | end 142 | 143 | val client : t -> Client.t option 144 | (** The client for syncing with our server, if any. *) 145 | end 146 | -------------------------------------------------------------------------------- /lib/ck_rev.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Lwt.Infix 5 | 6 | open Ck_utils 7 | 8 | let root_id = Ck_id.of_string "" (* Convenient magic value for hashtables *) 9 | 10 | module type S = sig 11 | include Ck_sigs.REV 12 | open Node.Types 13 | 14 | val make : time:Ck_time.user_date -> commit -> t Lwt.t 15 | val disk_node : [< Node.generic] -> Ck_disk_node.generic 16 | val apa_node : [< area | project | action] -> 17 | [ Ck_disk_node.Types.area | Ck_disk_node.Types.project | Ck_disk_node.Types.action ] 18 | 19 | val action_node : action -> Ck_disk_node.Types.action 20 | val project_node : project -> Ck_disk_node.Types.project 21 | val area_node : area -> Ck_disk_node.Types.area 22 | val context_node : context -> Ck_disk_node.Types.context 23 | val contact_node : contact -> Ck_disk_node.Types.contact 24 | end 25 | 26 | module Make(Git : Git_storage_s.S) = struct 27 | type commit = Git.Commit.t 28 | 29 | module Node = struct 30 | module Types = struct 31 | type rev = { 32 | commit : Git.Commit.t; 33 | mutable children : apa M.t Ck_id.M.t; 34 | contexts : context_node Ck_id.M.t ref; 35 | contacts : contact_node Ck_id.M.t ref; 36 | nodes_of_contact : (Ck_id.t, apa) Hashtbl.t; 37 | actions_of_context : (Ck_id.t, action) Hashtbl.t; 38 | apa_nodes : apa Ck_id.M.t ref; 39 | mutable alert : bool; 40 | mutable schedule : action list; 41 | mutable expires : Ck_time.user_date option; 42 | valid_from : Ck_time.user_date; 43 | mutable problems : 44 | ( [ `Action of action_node 45 | | `Project of project_node 46 | | `Area of area_node 47 | | `Contact of contact_node 48 | | `Context of context_node ] * Ck_sigs.problem 49 | ) list; 50 | } 51 | and 'a node_details = { 52 | rev : rev; 53 | uuid : Ck_id.t; 54 | disk_node : 'a; 55 | } 56 | and action_node = Ck_disk_node.Types.action_node node_details 57 | and project_node = Ck_disk_node.Types.project_node node_details 58 | and area_node = Ck_disk_node.Types.area_node node_details 59 | and context_node = Ck_disk_node.Types.context_node node_details 60 | and contact_node = Ck_disk_node.Types.contact_node node_details 61 | and apa = 62 | [ `Action of action_node 63 | | `Project of project_node 64 | | `Area of area_node ] 65 | and action = [`Action of action_node] 66 | and project = [`Project of project_node] 67 | and area = [`Area of area_node] 68 | and contact = [`Contact of contact_node] 69 | and context = [`Context of context_node] 70 | end 71 | 72 | open Types 73 | 74 | type generic = 75 | [ apa 76 | | `Contact of contact_node 77 | | `Context of context_node ] 78 | 79 | let apa_disk_node = function 80 | | `Action n -> `Action n.disk_node 81 | | `Project n -> `Project n.disk_node 82 | | `Area n -> `Area n.disk_node 83 | 84 | let disk_node = function 85 | | `Action n -> `Action n.disk_node 86 | | `Project n -> `Project n.disk_node 87 | | `Area n -> `Area n.disk_node 88 | | `Contact n -> `Contact n.disk_node 89 | | `Context n -> `Context n.disk_node 90 | 91 | let details = function 92 | | `Action n -> {n with disk_node = ()} 93 | | `Project n -> {n with disk_node = ()} 94 | | `Area n -> {n with disk_node = ()} 95 | | `Contact n -> {n with disk_node = ()} 96 | | `Context n -> {n with disk_node = ()} 97 | 98 | let rev n = (details n).rev 99 | let uuid n = (details n).uuid 100 | 101 | let contact t = Ck_disk_node.contact (apa_disk_node t) 102 | let parent t = Ck_disk_node.parent (apa_disk_node t) 103 | let name t = Ck_disk_node.name (disk_node t) 104 | let description t = Ck_disk_node.description (disk_node t) 105 | let ctime t = Ck_disk_node.ctime (disk_node t) 106 | let conflicts t = Ck_disk_node.conflicts (disk_node t) 107 | let action_state (`Action n) = Ck_disk_node.action_state (`Action n.disk_node) 108 | let action_repeat (`Action n) = Ck_disk_node.action_repeat (`Action n.disk_node) 109 | let context (`Action n) = Ck_disk_node.context (`Action n.disk_node) 110 | let project_state (`Project n) = Ck_disk_node.project_state (`Project n.disk_node) 111 | let starred = function 112 | | `Action n -> Ck_disk_node.starred (`Action n.disk_node) 113 | | `Project n -> Ck_disk_node.starred (`Project n.disk_node) 114 | let is_done = function 115 | | `Action n -> Ck_disk_node.is_done (`Action n.disk_node) 116 | | `Project n -> Ck_disk_node.is_done (`Project n.disk_node) 117 | 118 | let key node = (String.lowercase_ascii (name node), uuid node) 119 | 120 | let is_due action = 121 | match action_state action with 122 | | `Waiting_until time -> Ck_time.compare time (rev action).valid_from <= 0 123 | | _ -> false 124 | 125 | let node_due = function 126 | | `Action _ as action -> is_due action 127 | | _ -> false 128 | 129 | let equal a b = 130 | let a = (a :> generic) in 131 | let b = (b :> generic) in 132 | uuid a = uuid b && 133 | disk_node a = disk_node b && 134 | node_due a = node_due b (* Force the GUI to update when an item becomes due *) 135 | end 136 | 137 | open Node.Types 138 | 139 | type rev = Node.Types.rev 140 | type t = rev 141 | 142 | let equal a b = 143 | Git.Commit.equal a.commit b.commit && 144 | a.expires = b.expires 145 | 146 | let child_nodes node = 147 | let t = Node.rev node in 148 | let parent = Node.uuid node in 149 | try Ck_id.M.find parent t.children with Not_found -> M.empty 150 | 151 | let process_item ~now t node = 152 | begin match Node.contact node with 153 | | None -> () 154 | | Some c -> 155 | if not (Ck_id.M.mem c !(t.contacts)) then 156 | bug "Contact '%a' of '%s' not found!" Ck_id.fmt c (Node.name node); 157 | Hashtbl.add t.nodes_of_contact c node end; 158 | match node with 159 | | `Action _ as node -> 160 | begin match Node.context node with 161 | | None -> () 162 | | Some id -> 163 | if not (Ck_id.M.mem id !(t.contexts)) then 164 | bug "Context '%a' of '%s' not found!" Ck_id.fmt id (Node.name node); 165 | Hashtbl.add t.actions_of_context id node end; 166 | begin match Node.action_state node with 167 | | `Waiting_for_contact -> 168 | if Node.contact node = None then 169 | bug "Waiting_for_contact but no contact set on '%s'" (Node.name node) 170 | | `Waiting_until time -> 171 | t.schedule <- node :: t.schedule; 172 | if time <= now then t.alert <- true 173 | else ( 174 | match t.expires with 175 | | Some old_time when Ck_time.compare old_time time <= 0 -> () 176 | | _ -> t.expires <- Some time 177 | ) 178 | | _ -> () end 179 | | _ -> () 180 | 181 | type active = In_progress | Idle 182 | 183 | let is_area = function 184 | | `Area _ -> true 185 | | _ -> false 186 | 187 | let roots t = 188 | try Ck_id.M.find root_id t.children 189 | with Not_found -> M.empty 190 | 191 | let ensure_no_cycles t = 192 | let rec aux unseen nodes = 193 | M.fold (fun _key node unseen -> 194 | let unseen = unseen |> Ck_id.M.remove (Node.uuid node) in 195 | aux unseen (child_nodes node) 196 | ) nodes unseen in 197 | let unreachable = aux !(t.apa_nodes) (roots t) in 198 | if not (Ck_id.M.is_empty unreachable) then ( 199 | let _id, example = Ck_id.M.min_binding unreachable in 200 | bug "Node '%s' is not reachable from the root! (cycle in parent relation)" (Node.name example) 201 | ) 202 | 203 | let is_incomplete = function 204 | | `Area _ -> true 205 | | `Project _ | `Action _ as n -> not (Node.is_done n) 206 | 207 | let check_for_problems t = 208 | let add node msg = 209 | t.problems <- ((node :> Node.generic), msg) :: t.problems in 210 | let rec scan node = 211 | let bug problem = 212 | Ck_utils.bug "Bad item '%s': %s" (Node.name node) problem in 213 | let reduce_progress _ child acc = 214 | match scan child with 215 | | Idle -> acc 216 | | In_progress -> In_progress in 217 | if Node.conflicts node <> [] then add node `Unread_conflicts; 218 | let child_nodes = child_nodes node in 219 | match node with 220 | | `Project _ as node -> 221 | if (M.exists (fun _k -> is_area) child_nodes) then bug "Project with area child!"; 222 | if Node.project_state node = `Done && M.exists (fun _k -> is_incomplete) child_nodes then 223 | add node `Incomplete_child; 224 | let children_status = M.fold reduce_progress child_nodes Idle in 225 | begin match Node.project_state node, children_status with 226 | | `Active, Idle -> add node `No_next_action; Idle 227 | | `Active, In_progress -> In_progress 228 | | (`SomedayMaybe | `Done), _ -> Idle end 229 | | `Area _ -> 230 | M.fold reduce_progress child_nodes Idle 231 | | `Action _ as node -> 232 | if not (M.is_empty child_nodes) then bug "Action with children!"; 233 | begin match Node.action_state node with 234 | | `Next | `Waiting_for_contact | `Waiting_until _ | `Waiting -> In_progress 235 | | `Future -> Idle 236 | | `Done -> 237 | if Node.action_repeat node <> None then bug "Repeating action marked as done!"; 238 | Idle end 239 | in 240 | let check_contact node = 241 | if Node.conflicts node <> [] then add node `Unread_conflicts in 242 | let check_context node = 243 | if Node.conflicts node <> [] then add node `Unread_conflicts in 244 | roots t |> M.iter (fun _k n -> ignore (scan n)); 245 | !(t.contacts) |> Ck_id.M.iter (fun _k n -> check_contact (`Contact n)); 246 | !(t.contexts) |> Ck_id.M.iter (fun _k n -> check_context (`Context n)) 247 | 248 | let check_version tree = 249 | Git.Staging.read tree ["ck-version"] >|= function 250 | | None -> 251 | bug "'ck-version' file missing - repository is corrupted!" 252 | | Some v -> 253 | let v = String.trim v in 254 | if v <> "0.1" then 255 | bug "Unknown repository format version '%s' (expected 0.1) - please upgrade CueKeeper" v 256 | 257 | let make_no_cache ~time commit = 258 | let tree = Git.Commit.checkout commit in 259 | let contacts = ref Ck_id.M.empty in 260 | let contexts = ref Ck_id.M.empty in 261 | let children = Hashtbl.create 100 in 262 | let apa_nodes = ref Ck_id.M.empty in 263 | let nodes_of_contact = Hashtbl.create 10 in 264 | let actions_of_context = Hashtbl.create 10 in 265 | let t = { 266 | commit; contacts; apa_nodes; nodes_of_contact; children = Ck_id.M.empty; 267 | contexts; actions_of_context; 268 | schedule = []; alert = false; valid_from = time; expires = None; 269 | problems = []; 270 | } in 271 | check_version tree >>= fun () -> 272 | (* Load areas, projects and actions *) 273 | Git.Staging.list tree ["db"] >>= 274 | Lwt_list.iter_s (fun uuid -> 275 | Git.Staging.read_exn tree ["db"; uuid] >|= fun s -> 276 | let uuid = Ck_id.of_string uuid in 277 | let disk_node = Ck_disk_node.of_string s in 278 | let node = 279 | match disk_node with 280 | | `Action disk_node -> `Action {rev = t; uuid; disk_node} 281 | | `Project disk_node -> `Project {rev = t; uuid; disk_node} 282 | | `Area disk_node -> `Area {rev = t; uuid; disk_node} in 283 | apa_nodes := !apa_nodes |> Ck_id.M.add uuid node; 284 | let parent = Ck_disk_node.parent disk_node |> default root_id in 285 | let old_children = 286 | try Hashtbl.find children parent 287 | with Not_found -> [] in 288 | Hashtbl.replace children parent (uuid :: old_children); 289 | ) >>= fun () -> 290 | let apa_nodes = !apa_nodes in 291 | (* Load contacts *) 292 | Git.Staging.list tree ["contact"] >>= 293 | Lwt_list.iter_s (fun uuid -> 294 | Git.Staging.read_exn tree ["contact"; uuid] >|= fun s -> 295 | let uuid = Ck_id.of_string uuid in 296 | let `Contact disk_node = Ck_disk_node.contact_of_string s in 297 | let contact = {rev = t; uuid; disk_node} in 298 | contacts := !contacts |> Ck_id.M.add uuid contact; 299 | ) >>= fun () -> 300 | (* Load contexts *) 301 | Git.Staging.list tree ["context"] >>= 302 | Lwt_list.iter_s (fun uuid -> 303 | Git.Staging.read_exn tree ["context"; uuid] >|= fun s -> 304 | let uuid = Ck_id.of_string uuid in 305 | let `Context disk_node = Ck_disk_node.context_of_string s in 306 | let context = {rev = t; uuid; disk_node} in 307 | contexts := !contexts |> Ck_id.M.add uuid context; 308 | ) >>= fun () -> 309 | (* todo: reject cycles *) 310 | children |> Hashtbl.iter (fun parent children -> 311 | if parent <> root_id && not (Ck_id.M.mem parent apa_nodes) then ( 312 | bug "Parent UUID '%a' of child nodes %s missing!" Ck_id.fmt parent (String.concat ", " (List.map Ck_id.to_string children)) 313 | ) 314 | ); 315 | t.children <- 316 | Hashtbl.fold (fun uuid child_uuids acc -> 317 | let child_map = child_uuids |> List.fold_left (fun acc child_uuid -> 318 | let child = Ck_id.M.find child_uuid apa_nodes in 319 | process_item ~now:time t child; 320 | acc |> M.add (Node.key child) child 321 | ) M.empty in 322 | acc |> Ck_id.M.add uuid child_map 323 | ) children Ck_id.M.empty; 324 | ensure_no_cycles t; 325 | check_for_problems t; 326 | if t.problems <> [] then t.alert <- true; 327 | Lwt.return t 328 | 329 | let last = ref None 330 | let make ~time commit = 331 | let reload () = 332 | make_no_cache ~time commit >|= fun r -> 333 | last := Some r; 334 | r in 335 | match !last with 336 | | Some last when Git.Commit.equal last.commit commit -> 337 | begin match last.expires with 338 | | Some etime when time >= etime -> reload () 339 | | _ -> Lwt.return {last with valid_from = time} end 340 | | _ -> reload () 341 | 342 | let nodes t = !(t.apa_nodes) 343 | 344 | let get t uuid = 345 | try Some (Ck_id.M.find uuid !(t.apa_nodes)) 346 | with Not_found -> None 347 | 348 | let get_contact t uuid = 349 | try Some (`Contact (Ck_id.M.find uuid !(t.contacts))) 350 | with Not_found -> None 351 | 352 | let get_context t uuid = 353 | try Some (`Context (Ck_id.M.find uuid !(t.contexts))) 354 | with Not_found -> None 355 | 356 | let parent t node = Node.parent node >>?= get t 357 | 358 | let context (`Action node as action) = 359 | match Node.context action with 360 | | None -> None 361 | | Some id -> get_context node.rev id 362 | 363 | let commit t = t.commit 364 | let contacts t = !(t.contacts) |> Ck_id.M.map (fun c -> `Contact c) 365 | let contexts t = !(t.contexts) |> Ck_id.M.map (fun c -> `Context c) 366 | 367 | let nodes_of_contact (`Contact c) = 368 | Hashtbl.find_all c.rev.nodes_of_contact c.uuid 369 | 370 | let actions_of_context (`Context c) = 371 | Hashtbl.find_all c.rev.actions_of_context c.uuid 372 | 373 | let contact_for node = 374 | match Node.contact node with 375 | | None -> None 376 | | Some id -> get_contact (Node.rev node) id 377 | 378 | let disk_node = Node.disk_node 379 | let apa_node = Node.apa_disk_node 380 | let action_node (`Action n) = `Action n.disk_node 381 | let project_node (`Project n) = `Project n.disk_node 382 | let area_node (`Area n) = `Area n.disk_node 383 | let contact_node (`Contact n) = `Contact n.disk_node 384 | let context_node (`Context n) = `Context n.disk_node 385 | 386 | let due action = 387 | match Node.action_state action with 388 | | `Waiting_until time -> time 389 | | _ -> assert false 390 | 391 | let by_due_time a b = 392 | compare (due a) (due b) 393 | 394 | let schedule t = List.sort by_due_time t.schedule 395 | let alert t = t.alert 396 | let expires t = t.expires 397 | 398 | let problems t = List.rev (t.problems) 399 | end 400 | -------------------------------------------------------------------------------- /lib/ck_rev.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | (** A single revision in the Irmin history. *) 5 | 6 | open Ck_sigs 7 | 8 | module type S = sig 9 | include REV 10 | open Node.Types 11 | 12 | val make : time:Ck_time.user_date -> commit -> t Lwt.t 13 | val disk_node : [< Node.generic] -> Ck_disk_node.generic 14 | val apa_node : [< area | project | action] -> 15 | [ Ck_disk_node.Types.area | Ck_disk_node.Types.project | Ck_disk_node.Types.action ] 16 | 17 | val action_node : action -> Ck_disk_node.Types.action 18 | val project_node : project -> Ck_disk_node.Types.project 19 | val area_node : area -> Ck_disk_node.Types.area 20 | val context_node : context -> Ck_disk_node.Types.context 21 | val contact_node : contact -> Ck_disk_node.Types.contact 22 | end 23 | 24 | module Make(Git : Git_storage_s.S) : S with type commit = Git.Commit.t 25 | -------------------------------------------------------------------------------- /lib/ck_sigs.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Ck_utils 5 | 6 | type stop = unit -> unit 7 | type 'a or_error = [ `Ok of 'a | `Error of string ] 8 | type action_state = [ `Next | `Waiting | `Waiting_for_contact | `Waiting_until of Ck_time.user_date | `Future | `Done ] 9 | type project_state = [ `Active | `SomedayMaybe | `Done ] 10 | 11 | module type DISK_NODE = sig 12 | module Types : sig 13 | type action_node 14 | type project_node 15 | type area_node 16 | type contact_node 17 | type context_node 18 | 19 | type action = [`Action of action_node] 20 | type project = [`Project of project_node] 21 | type area = [`Area of area_node] 22 | type contact = [`Contact of contact_node] 23 | type context = [`Context of context_node] 24 | end 25 | open Types 26 | 27 | type generic = [ area | project | action | contact | context ] 28 | 29 | val parent : [< area | project | action ] -> Ck_id.t option 30 | val name : [< generic ] -> string 31 | val description : [< generic] -> string 32 | val ctime : [< generic ] -> float 33 | val conflicts : [< generic ] -> string list 34 | val starred : [< project | action] -> bool 35 | val action_state : action -> action_state 36 | val action_repeat : action -> Ck_time.repeat option 37 | val project_state : project -> project_state 38 | val is_done : [< project | action] -> bool 39 | val context : action -> Ck_id.t option 40 | val contact : [< area | project | action ] -> Ck_id.t option 41 | end 42 | 43 | module type EQ = sig 44 | type t 45 | val equal : t -> t -> bool 46 | end 47 | 48 | module type TREE_MODEL = sig 49 | module Sort_key : Slow_set.SORT_KEY 50 | 51 | module Item : sig 52 | (** The data part of a node (excluding the child nodes). 53 | * This is passed through. *) 54 | type generic 55 | val equal : generic -> generic -> bool 56 | val show : generic -> string 57 | end 58 | 59 | module Child_map : Map.S with type key = Sort_key.t 60 | (** Ordered list of child nodes. *) 61 | 62 | type t 63 | type group 64 | type adder 65 | val group_label : group -> string 66 | val adder : t -> adder option 67 | val item : t -> 68 | [ `UniqueItem of Ck_id.t * Item.generic (* ID is unique in tree *) 69 | | `GroupItem of Ck_id.t * Item.generic (* ID is unique within parent *) 70 | | `Group of group ] (* Label is unique within parent *) 71 | val children : t -> t Child_map.t 72 | end 73 | 74 | module type GUI_DATA = sig 75 | type t 76 | (** For extra data the GUI wants to attach to tree nodes. *) 77 | end 78 | 79 | type problem = 80 | [ `No_next_action 81 | | `Unread_conflicts 82 | | `Incomplete_child ] 83 | 84 | module type REV = sig 85 | type t 86 | 87 | module Node : sig 88 | include DISK_NODE 89 | val rev : [< generic] -> t 90 | 91 | val uuid : [< generic ] -> Ck_id.t 92 | 93 | val key : [< generic ] -> Sort_key.t 94 | (** A key for sorting by name. *) 95 | 96 | val equal : [< generic] -> [< generic] -> bool 97 | (** Note that the rev field is ignored, so nodes from different commits can 98 | * be equal. *) 99 | 100 | val is_due : Types.action -> bool 101 | (** [true] if this is a waiting action due at or before the time 102 | * this revision was loaded. *) 103 | end 104 | open Node.Types 105 | 106 | type commit 107 | 108 | val equal : t -> t -> bool 109 | val child_nodes : [< area | project | action ] -> [ area | project | action ] M.t 110 | 111 | val roots : t -> [ area | project | action ] M.t 112 | val commit : t -> commit 113 | 114 | val nodes : t -> [ area | project | action] Ck_id.M.t 115 | 116 | val contacts : t -> contact Ck_id.M.t 117 | val nodes_of_contact : contact -> [ area | project | action ] list 118 | val contact_for : [< area | project | action ] -> contact option 119 | 120 | val contexts : t -> context Ck_id.M.t 121 | val actions_of_context : context -> action list 122 | 123 | val get : t -> Ck_id.t -> [ area | project | action ] option 124 | val get_contact : t -> Ck_id.t -> [> contact] option 125 | val get_context : t -> Ck_id.t -> [> context] option 126 | 127 | val parent : t -> [< area | project | action] -> [ area | project | action ] option 128 | val context : action -> context option 129 | 130 | val schedule : t -> action list 131 | (** The ([`Waiting_until time] actions, earliest first. *) 132 | 133 | val problems : t -> (Node.generic * problem) list 134 | (** A list of nodes and problems to report. *) 135 | 136 | val alert : t -> bool 137 | (** Alert the user that action is required. 138 | * Currently, this is true when a [`Waiting_until] action is due, or 139 | * [problems t] is non-empty. *) 140 | 141 | val expires : t -> Ck_time.user_date option 142 | (** Will need to reload at this time (this is when the next scheduled action becomes due). *) 143 | end 144 | 145 | type 'a or_cancelled = 146 | [ `Ok of 'a 147 | | `Cancelled_by_user ] 148 | 149 | type 'a or_error_or_cancelled = 150 | [ `Ok of 'a 151 | | `Error of string 152 | | `Cancelled_by_user ] 153 | 154 | module type RPC = sig 155 | open Cohttp 156 | 157 | val get : 158 | ?headers:Cohttp.Header.t -> 159 | Uri.t -> (Response.t * Cohttp_lwt.Body.t) or_cancelled Lwt.t 160 | 161 | val post : 162 | ?body:Cohttp_lwt.Body.t -> 163 | ?headers:Cohttp.Header.t -> 164 | Uri.t -> (Response.t * Cohttp_lwt.Body.t) or_cancelled Lwt.t 165 | end 166 | -------------------------------------------------------------------------------- /lib/ck_time.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Sexplib.Conv 5 | open Unix 6 | 7 | type time_unit = 8 | | Day 9 | | Week 10 | | Month 11 | | Year 12 | [@@deriving sexp] 13 | 14 | type user_date = (int * int * int) [@@deriving sexp_of] 15 | 16 | let of_tm tm = 17 | (tm.tm_year + 1900, tm.tm_mon, tm.tm_mday) 18 | 19 | let mkt (y, m, d) = 20 | { 21 | tm_year = y - 1900; 22 | tm_mon = m; 23 | tm_mday = d; 24 | tm_hour = 0; 25 | tm_min = 0; 26 | tm_sec = 0; 27 | (* (these are ignored) *) 28 | tm_isdst = false; 29 | tm_wday = 0; 30 | tm_yday = 0; 31 | } |> mktime 32 | 33 | let tm_of user_date = mkt user_date |> snd 34 | 35 | let of_unix_time t = 36 | of_tm (localtime t) 37 | 38 | let unix_time_of d = 39 | mkt d |> fst 40 | 41 | let make ~year ~month ~day = 42 | mkt (year, month, day) 43 | |> snd 44 | |> of_tm 45 | 46 | let compare (ay, am, ad) (by, bm, bd) = 47 | match compare ay by with 48 | | 0 -> 49 | begin match compare am bm with 50 | | 0 -> compare ad bd 51 | | x -> x end 52 | | x -> x 53 | 54 | let string_of_time_unit = function 55 | | Day -> "day" 56 | | Week -> "week" 57 | | Month -> "month" 58 | | Year -> "year" 59 | 60 | let string_of_day = function 61 | | 0 -> "Sun" 62 | | 1 -> "Mon" 63 | | 2 -> "Tue" 64 | | 3 -> "Wed" 65 | | 4 -> "Thu" 66 | | 5 -> "Fri" 67 | | 6 -> "Sat" 68 | | _ -> "XXX" 69 | 70 | let string_of_unix_time date = 71 | let tm = localtime date in 72 | Printf.sprintf "%04d-%02d-%02d %02d:%02d (%s)" 73 | (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min (string_of_day tm.tm_wday) 74 | 75 | let string_of_user_date date = 76 | let tm = tm_of date in 77 | Printf.sprintf "%04d-%02d-%02d (%s)" 78 | (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday (string_of_day tm.tm_wday) 79 | 80 | let user_date_of_sexp = 81 | let open Sexplib.Type in function 82 | | Atom _ as x -> [%of_sexp: float] x |> of_unix_time (* Old format *) 83 | | List _ as x -> [%of_sexp: int * int * int] x 84 | 85 | type repeat = { 86 | repeat_n : int; 87 | repeat_unit : time_unit; 88 | repeat_from : user_date; 89 | } [@@deriving sexp] 90 | 91 | let make_repeat ~from:repeat_from repeat_n repeat_unit = 92 | assert (repeat_n > 0); 93 | { repeat_n; repeat_unit; repeat_from } 94 | 95 | let next_repeat ~now r = 96 | let n = r.repeat_n in 97 | assert (n > 0); 98 | let rec aux d = 99 | if compare d now > 0 then d 100 | else ( 101 | let (year, month, day) = d in 102 | let next_d = 103 | match r.repeat_unit with 104 | | Day -> make ~year ~month ~day:(day + n) 105 | | Week -> make ~year ~month ~day:(day + 7 * n) 106 | | Month -> 107 | let (new_y, new_m, new_d) as n = make ~year ~month:(month + n) ~day in 108 | (* If the day is different, the new month is shorter and we wrapped. 109 | * Go back to the last day of the previous month in that case. *) 110 | if new_d < day then make ~year:new_y ~month:new_m ~day:0 111 | else n 112 | 113 | | Year -> make ~year:(year + n) ~month ~day in 114 | aux next_d 115 | ) in 116 | aux r.repeat_from 117 | 118 | let string_of_repeat spec = 119 | let units = string_of_time_unit spec.repeat_unit in 120 | let freq = 121 | match spec.repeat_n with 122 | | 1 -> Printf.sprintf "every %s" units 123 | | n -> Printf.sprintf "every %d %ss" n units in 124 | freq ^ " from " ^ string_of_user_date spec.repeat_from 125 | -------------------------------------------------------------------------------- /lib/ck_time.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | type time_unit = 5 | | Day 6 | | Week 7 | | Month 8 | | Year 9 | [@@deriving sexp] 10 | 11 | (** A date as entered by the user, without timezone information. 12 | * 1st Jan 2015 is (2015, 0, 1) - months start at zero. *) 13 | type user_date = private (int * int * int) [@@deriving sexp] 14 | 15 | type repeat = private { 16 | repeat_n : int; 17 | repeat_unit : time_unit; 18 | repeat_from : user_date; 19 | } [@@deriving sexp] 20 | 21 | val make_repeat : from:user_date -> int -> time_unit -> repeat 22 | 23 | val of_tm : Unix.tm -> user_date 24 | val tm_of : user_date -> Unix.tm 25 | val of_unix_time : float -> user_date 26 | val unix_time_of : user_date -> float 27 | 28 | (** Create a [user_date]. 29 | * Note: months start from 0, not 1. 30 | * Values are normalised so that, e.g., 40 October is changed into 9 November. *) 31 | val make : year:int -> month:int -> day:int -> user_date 32 | 33 | val compare : user_date -> user_date -> int 34 | 35 | (** [next_repeat ~now r] gives the next time that [r.repeat_from] should be set to, 36 | * by moving [repeat_from] forward in steps of [repeat_n * repeat_unit] until it's 37 | * after [now]. *) 38 | val next_repeat : now:user_date -> repeat -> user_date 39 | 40 | val string_of_time_unit : time_unit -> string 41 | val string_of_unix_time : float -> string 42 | val string_of_user_date : user_date -> string 43 | val string_of_repeat : repeat -> string 44 | -------------------------------------------------------------------------------- /lib/ck_update.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Ck_utils 5 | open Lwt.Infix 6 | 7 | let async : (unit -> unit Lwt.t) -> unit = Lwt.async 8 | 9 | (* Annoyingly, if you suspend the computer during a Lwt_js.sleep then the time spent suspended isn't 10 | * counted and we wake up too late. As a work-around, we do a quick check every 10s. See: 11 | * http://stackoverflow.com/questions/29656686/how-to-wait-until-a-given-time-even-when-laptop-is-suspended 12 | *) 13 | let max_sleep_time = 10.0 14 | 15 | module Make(Git : Git_storage_s.S) (Clock : Ck_clock.S) (R : Ck_rev.S with type commit = Git.Commit.t) = struct 16 | open R.Node.Types 17 | 18 | module Merge = Ck_merge.Make(Git)(R) 19 | 20 | type t = { 21 | branch : Git.Branch.t; 22 | mutable fixed_head : float option; (* If [Some time], we are in "time-machine" mode, and not tracking [branch] *) 23 | mutable head : R.t; 24 | updated : unit Lwt_condition.t; 25 | mutex : Lwt_mutex.t; 26 | mutable update_signal : unit React.S.t; 27 | on_update : (R.t -> unit Lwt.t) Lwt.t; (* (a thread just to avoid a cycle at creation time) *) 28 | mutable alarm : unit Lwt.t; 29 | } 30 | 31 | let rec update_alarm t = 32 | Lwt.cancel (t.alarm); 33 | match R.expires t.head with 34 | | None -> () 35 | | Some _ when t.fixed_head <> None -> () (* Pointless in time-travel mode *) 36 | | Some date -> 37 | let time = Ck_time.unix_time_of date in 38 | let delay = min max_sleep_time (time -. Clock.now ()) in 39 | let sleeper = Clock.sleep delay in 40 | t.alarm <- sleeper; 41 | async (fun () -> 42 | Lwt.catch 43 | (fun () -> 44 | sleeper >>= fun () -> 45 | if Clock.now () >= time then ( 46 | Lwt_mutex.with_lock t.mutex (fun () -> 47 | update_head t (R.commit t.head) 48 | ) 49 | ) else ( 50 | update_alarm t; 51 | Lwt.return () 52 | ) 53 | ) 54 | (function 55 | | Lwt.Canceled -> Lwt.return () 56 | | ex -> raise ex 57 | ) 58 | ) 59 | and update_head t new_head = (* Call with mutex locked *) 60 | let time = 61 | match t.fixed_head with 62 | | None -> Clock.now () |> Ck_time.of_unix_time 63 | | Some time -> Ck_time.of_unix_time time in 64 | R.make ~time new_head >>= fun new_head -> 65 | t.head <- new_head; 66 | t.on_update >>= fun on_update -> 67 | on_update new_head >|= fun () -> 68 | Lwt_condition.broadcast t.updated (); 69 | update_alarm t 70 | 71 | type update_cb = R.t -> unit Lwt.t 72 | 73 | (* Must be called with t.mutex held *) 74 | let maybe_update_head t new_head = 75 | let old_head = R.commit t.head in 76 | match new_head with 77 | | None -> failwith "Branch has been deleted!" 78 | | Some new_head when Git.Commit.equal old_head new_head -> Lwt.return () 79 | | Some new_head -> update_head t new_head 80 | 81 | let make ~on_update branch = 82 | let mutex = Lwt_mutex.create () in 83 | match Git.Branch.head branch |> React.S.value with 84 | | None -> failwith "No commits on branch!" 85 | | Some initial_head -> 86 | let time = Clock.now () |> Ck_time.of_unix_time in 87 | R.make ~time initial_head >>= fun initial_head -> 88 | let updated = Lwt_condition.create () in 89 | let update_scheduled = ref false in 90 | let t = { 91 | branch; 92 | fixed_head = None; 93 | head = initial_head; 94 | updated; 95 | mutex; 96 | update_signal = React.S.const (); 97 | on_update; 98 | alarm = Lwt.return (); 99 | } in 100 | t.update_signal <- 101 | Git.Branch.head branch |> React.S.map (fun _ -> 102 | if not (!update_scheduled) then ( 103 | update_scheduled := true; 104 | async (fun () -> 105 | Lwt_mutex.with_lock mutex (fun () -> 106 | update_scheduled := false; 107 | if t.fixed_head = None then ( 108 | (* Head might have changed while we waited for the lock. *) 109 | React.S.value (Git.Branch.head branch) 110 | |> maybe_update_head t 111 | ) else Lwt.return () (* Fixed head - ignore updates *) 112 | ) 113 | ) 114 | ) 115 | ); 116 | update_alarm t; 117 | Lwt.return t 118 | 119 | let fix_head t = function 120 | | None -> 121 | Lwt_mutex.with_lock t.mutex (fun () -> 122 | t.fixed_head <- None; 123 | React.S.value (Git.Branch.head t.branch) 124 | |> maybe_update_head t 125 | ) 126 | | Some commit as new_head -> 127 | Lwt_mutex.with_lock t.mutex (fun () -> 128 | let info = Git.Commit.info commit in 129 | let time = Irmin.Info.date info |> Int64.to_float in 130 | t.fixed_head <- Some time; 131 | maybe_update_head t new_head 132 | ) 133 | 134 | let head t = t.head 135 | let fixed_head t = t.fixed_head <> None 136 | 137 | let branch_head t = 138 | match React.S.value (Git.Branch.head t.branch) with 139 | | None -> failwith "Branch has been deleted!" 140 | | Some commit -> commit 141 | 142 | let mem uuid rev = 143 | R.get rev uuid <> None 144 | 145 | let ff_master t commit = 146 | (* Check that the commit is readable *) 147 | let time = Clock.now () |> Ck_time.of_unix_time in 148 | Lwt.catch (fun () -> R.make ~time commit >|= ignore) 149 | (fun ex -> bug "Change generated an invalid commit:\n%s\n\nThis is a BUG. The invalid change has been discarded." 150 | (Printexc.to_string ex)) >>= fun () -> 151 | Lwt_mutex.with_lock t.mutex (fun () -> 152 | if R.commit t.head |> Git.Commit.equal commit then 153 | Lwt.return (`Ok, Lwt.return ()) 154 | else ( 155 | (* At this point, head cannot contain our commit because we haven't merged it yet, 156 | * and no updates can happen while we hold the lock. *) 157 | let updated = Lwt_condition.wait t.updated in 158 | Git.Branch.fast_forward_to t.branch commit >|= fun merge_result -> 159 | (* If `Ok, [updated] cannot have fired yet because we still hold the lock. When it does 160 | * fire next, it must contain our update. It must fire soon, as head has changed. *) 161 | if merge_result = `Ok then ( 162 | (* If we were on a fixed head then return to tracking master. Otherwise, the user won't 163 | * see the update. *) 164 | t.fixed_head <- None; 165 | ); 166 | (merge_result, updated) 167 | ) 168 | ) 169 | 170 | (* Branch from base, apply [fn branch] to it, then merge the result back to master. 171 | * Returns only once [on_update] has been run for the new revision. *) 172 | let merge_to_master t ~base ~msg fn = 173 | let base_commit = R.commit base in 174 | let view = Git.Commit.checkout base_commit in 175 | fn view >>= fun result -> 176 | Git.Commit.commit ~msg:[msg] view >>= fun pull_rq -> 177 | let rec aux () = 178 | (* Merge to branch tip, even if we're on a fixed head *) 179 | let old_head = branch_head t in 180 | Merge.merge ~base:base_commit ~theirs:old_head pull_rq >>= function 181 | | `Nothing_to_do -> 182 | (* Our change had no effect, so there's nothing to do. *) 183 | Lwt.return (Lwt.return ()) 184 | | `Ok merged -> 185 | ff_master t merged >>= function 186 | | `Ok, updated -> Lwt.return updated 187 | | `Not_fast_forward, _updated -> 188 | Printf.eprintf "Update while we were trying to merge - retrying...\n%!"; 189 | Clock.sleep 1.0 >>= fun () -> (* Might be a bug - avoid hanging the browser *) 190 | (* Possibly we should wait for branch_head to move, but this is a very unlikely case 191 | * so do a simple sleep-and-retry *) 192 | aux () 193 | in 194 | aux () >>= fun updated -> (* Changes have been committed. *) 195 | updated >>= fun () -> (* [on_update] has been called. *) 196 | Lwt.return result 197 | 198 | let revert t ~repo log_entry = 199 | Merge.revert ~repo ~master:(branch_head t) log_entry >>= function 200 | | `Nothing_to_do -> Lwt.return (`Ok ()) 201 | | `Error _ as e -> Lwt.return e 202 | | `Ok commit -> 203 | ff_master t commit >>= function 204 | | `Ok, updated -> updated >|= fun () -> `Ok () 205 | | `Not_fast_forward, _updated -> 206 | Lwt.return (error "Update while we were trying to revert - aborting") 207 | 208 | let sync t ~from:theirs = 209 | let ours = branch_head t in 210 | let ff commit = 211 | ff_master t commit >>= function 212 | | `Ok, updated -> updated >|= fun () -> `Ok () 213 | | `Not_fast_forward, _updated -> 214 | Lwt.return (error "Update while we were trying to sync - aborting") in 215 | let sync_with ~base = 216 | Merge.merge ?base ~theirs ours >>= function 217 | | `Nothing_to_do -> Lwt.return (`Ok ()) 218 | | `Ok merge -> ff merge in 219 | Git.Commit.lcas ours theirs >>= function 220 | | [] -> sync_with ~base:None 221 | | lcas -> 222 | if List.exists (Git.Commit.equal ours) lcas then ff theirs (* Trivial - we have no changes *) 223 | else sync_with ~base:(Some (List.hd lcas)) 224 | 225 | let create t ~base (node:[< Ck_disk_node.generic]) = 226 | let uuid = Ck_id.mint () in 227 | assert (not (mem uuid base)); 228 | begin match Ck_disk_node.parent node with 229 | | Some parent when not (mem parent base) -> 230 | bug "Parent '%a' does not exist!" Ck_id.fmt parent; 231 | | _ -> () end; 232 | let s = Ck_disk_node.to_string node in 233 | let msg = Printf.sprintf "Create %s" (Ck_disk_node.name node) in 234 | merge_to_master t ~base ~msg (fun view -> 235 | Git.Staging.update view ["db"; Ck_id.to_string uuid] s 236 | ) >|= fun () -> uuid 237 | 238 | let update t ~msg node new_disk_node = 239 | let base = R.Node.rev node in 240 | let uuid = R.Node.uuid node in 241 | merge_to_master t ~base ~msg (fun view -> 242 | match new_disk_node with 243 | | `Area _ | `Project _ | `Action _ as new_disk_node -> 244 | assert (mem uuid base); 245 | begin match Ck_disk_node.parent new_disk_node with 246 | | Some parent when not (mem parent base) -> 247 | bug "Parent '%a' does not exist!" Ck_id.fmt parent; 248 | | _ -> () end; 249 | let s = Ck_disk_node.to_string new_disk_node in 250 | Git.Staging.update view ["db"; Ck_id.to_string uuid] s 251 | | `Contact _ as new_disk_node -> 252 | assert (Ck_id.M.mem uuid (R.contacts base)); 253 | let s = Ck_disk_node.contact_to_string new_disk_node in 254 | Git.Staging.update view ["contact"; Ck_id.to_string uuid] s 255 | | `Context _ as new_disk_node -> 256 | assert (Ck_id.M.mem uuid (R.contexts base)); 257 | let s = Ck_disk_node.context_to_string new_disk_node in 258 | Git.Staging.update view ["context"; Ck_id.to_string uuid] s 259 | ) 260 | 261 | let delete t ?msg nodes = 262 | match nodes with 263 | | [] -> Lwt.return (`Ok ()) 264 | | x :: _ -> 265 | let base = R.Node.rev x in 266 | let msg = 267 | match msg with 268 | | None -> 269 | nodes 270 | |> List.map R.Node.name 271 | |> String.concat ", " 272 | |> Printf.sprintf "%s: deleted" 273 | | Some msg -> msg in 274 | let to_delete = nodes |> List.fold_left (fun acc node -> 275 | acc |> Ck_id.S.add (R.Node.uuid node) 276 | ) Ck_id.S.empty in 277 | (* We're trying to delete a node which is needed by each of [referrers]. Return one of them that 278 | * isn't also being deleted (if any) for the error message. *) 279 | let example_referrer referrers = 280 | try Some (referrers |> List.find (fun referrer -> not (Ck_id.S.mem (R.Node.uuid referrer) to_delete))) 281 | with Not_found -> None in 282 | let paths = nodes |> List.fold_left (fun acc node -> 283 | match acc with 284 | | `Error _ as e -> e 285 | | `Ok acc -> 286 | let uuid = R.Node.uuid node |> Ck_id.to_string in 287 | match node with 288 | | `Contact _ as node -> 289 | begin match example_referrer (R.nodes_of_contact node) with 290 | | None -> `Ok (["contact"; uuid] :: acc) 291 | | Some r -> 292 | error "Can't delete because referenced by '%s'" (R.Node.name r) 293 | end 294 | | `Context _ as node -> 295 | begin match example_referrer (R.actions_of_context node) with 296 | | None -> `Ok (["context"; uuid] :: acc) 297 | | Some r -> 298 | error "Can't delete because referenced by '%s'" (R.Node.name r) 299 | end 300 | | `Area _ | `Project _ | `Action _ as node -> 301 | match example_referrer (R.child_nodes node |> Ck_utils.M.bindings |> List.map snd) with 302 | | None -> `Ok (["db"; uuid] :: acc) 303 | | Some child -> 304 | error "Can't delete because of child '%s'" (R.Node.name child) 305 | ) (`Ok []) in 306 | match paths with 307 | | `Error _ as e -> Lwt.return e 308 | | `Ok paths -> 309 | merge_to_master ~base ~msg t (fun view -> 310 | paths |> Lwt_list.iter_s (Git.Staging.remove view) 311 | ) >|= fun () -> 312 | `Ok () 313 | 314 | let add t ~parent maker = 315 | let base, parent = 316 | match parent with 317 | | `Toplevel rev -> (rev, None) 318 | | `Node p -> (R.Node.rev p, Some (R.Node.uuid p)) in 319 | let disk_node = 320 | maker ?parent ~ctime:(Unix.gettimeofday ()) () in 321 | create t ~base disk_node 322 | 323 | let add_contact t ~base contact = 324 | let uuid = Ck_id.mint () in 325 | assert (not (Ck_id.M.mem uuid (R.contacts base))); 326 | let s = Ck_disk_node.contact_to_string contact in 327 | let msg = Printf.sprintf "Add contact %s" (Ck_disk_node.name contact) in 328 | merge_to_master t ~base ~msg (fun view -> 329 | Git.Staging.update view ["contact"; Ck_id.to_string uuid] s 330 | ) >|= fun () -> uuid 331 | 332 | let add_context t ~base context = 333 | let uuid = Ck_id.mint () in 334 | assert (not (Ck_id.M.mem uuid (R.contexts base))); 335 | let s = Ck_disk_node.context_to_string context in 336 | let msg = Printf.sprintf "Add context %s" (Ck_disk_node.name context) in 337 | merge_to_master t ~base ~msg (fun view -> 338 | Git.Staging.update view ["context"; Ck_id.to_string uuid] s 339 | ) >|= fun () -> uuid 340 | 341 | let clear_conflicts t node = 342 | let msg = Printf.sprintf "%s: clear conflicts" (R.Node.name node) in 343 | update t ~msg node (Ck_disk_node.without_conflicts (R.disk_node node)) 344 | 345 | let set_name t node name = 346 | let msg = Printf.sprintf "%s: rename to %s" (R.Node.name node) name in 347 | update t ~msg node (Ck_disk_node.with_name (R.disk_node node) name) 348 | 349 | let set_description t node v = 350 | let msg = Printf.sprintf "%s: update description" (R.Node.name node) in 351 | update t ~msg node (Ck_disk_node.with_description (R.disk_node node) v) 352 | 353 | let opt_name = function 354 | | None -> "unset" 355 | | Some n -> R.Node.name n 356 | 357 | let set_context t node context = 358 | let context_uuid = 359 | match context with 360 | | None -> None 361 | | Some context -> 362 | assert (R.Node.rev node == R.Node.rev context); 363 | Some (R.Node.uuid context) in 364 | let new_node = Ck_disk_node.with_context (R.action_node node) context_uuid in 365 | let msg = Printf.sprintf "%s: context now %s" (R.Node.name node) (opt_name context) in 366 | update t ~msg node new_node 367 | 368 | let set_contact t node contact = 369 | let contact_uuid = 370 | match contact with 371 | | None -> None 372 | | Some contact -> 373 | assert (R.Node.rev node == R.Node.rev contact); 374 | Some (R.Node.uuid contact) in 375 | let new_node = Ck_disk_node.with_contact (R.apa_node node) contact_uuid in 376 | let new_node = 377 | match new_node with 378 | | `Action _ as a when Ck_disk_node.action_state a = `Waiting_for_contact && contact_uuid = None -> 379 | let open Ck_disk_node.Types in 380 | (Ck_disk_node.with_astate a `Next :> [area | project | action]) 381 | | _ -> new_node in 382 | let msg = Printf.sprintf "%s: contact now %s" (R.Node.name node) (opt_name contact) in 383 | update t ~msg node new_node 384 | 385 | let set_action_state t node astate = 386 | let astate = (astate :> Ck_sigs.action_state) in 387 | let new_node = Ck_disk_node.with_astate (R.action_node node) astate in 388 | (* When setting a repeating action to wait until a date, record the new date as the repeat date too. *) 389 | let new_node = 390 | match astate with 391 | | `Waiting_until date -> 392 | begin match Ck_disk_node.action_repeat new_node with 393 | | None -> new_node 394 | | Some r -> 395 | let new_r = Ck_time.(make_repeat ~from:date r.repeat_n r.repeat_unit) in 396 | Ck_disk_node.with_repeat new_node (Some new_r) end 397 | | _ -> new_node in 398 | let msg = Printf.sprintf "%s: %s -> %s" 399 | (R.Node.name node) 400 | (Ck_disk_node.fmt_astate (R.Node.action_state node)) 401 | (Ck_disk_node.fmt_astate astate) in 402 | update t ~msg node new_node 403 | 404 | let set_repeat t node repeat = 405 | let open Ck_time in 406 | let new_node = Ck_disk_node.with_repeat (R.action_node node) repeat in 407 | let new_node = 408 | match repeat with 409 | | None -> new_node 410 | | Some r -> Ck_disk_node.with_astate new_node (`Waiting_until r.repeat_from) in 411 | let msg = Printf.sprintf "%s: repeat %s" 412 | (R.Node.name node) 413 | (match repeat with None -> "never" | Some r -> Ck_time.string_of_repeat r) in 414 | update t ~msg node new_node 415 | 416 | let set_waiting_for t node contact = 417 | assert (R.Node.rev node == R.Node.rev contact); 418 | let new_node = Ck_disk_node.with_astate (R.action_node node) `Waiting_for_contact in 419 | let new_node = Ck_disk_node.with_contact new_node (Some (R.Node.uuid contact)) in 420 | let msg = Printf.sprintf "%s: now waiting for %s" (R.Node.name node) (R.Node.name contact) in 421 | update t ~msg node new_node 422 | 423 | let set_project_state t node pstate = 424 | let new_node = Ck_disk_node.with_pstate (R.project_node node) pstate in 425 | let msg = Printf.sprintf "%s: %s -> %s" 426 | (R.Node.name node) 427 | (Ck_disk_node.fmt_pstate (R.Node.project_state node)) 428 | (Ck_disk_node.fmt_pstate pstate) in 429 | update t ~msg node new_node 430 | 431 | let set_starred t node s = 432 | let new_node = 433 | match node with 434 | | `Action _ as a -> Ck_disk_node.with_starred (R.action_node a) s 435 | | `Project _ as p -> Ck_disk_node.with_starred (R.project_node p) s in 436 | let action = if s then "Add" else "Remove" in 437 | let msg = Printf.sprintf "%s: %s star" (R.Node.name node) action in 438 | update t ~msg node new_node 439 | 440 | let set_pa_parent t node new_parent = 441 | assert (R.Node.rev node == R.Node.rev new_parent); 442 | let new_node = Ck_disk_node.with_parent (R.apa_node node) (Some (R.Node.uuid new_parent)) in 443 | let msg = Printf.sprintf "%s: move under %s" (R.Node.name node) (R.Node.name new_parent) in 444 | update t ~msg node new_node 445 | let set_a_parent = set_pa_parent 446 | 447 | let remove_parent t node = 448 | let new_node = Ck_disk_node.with_parent (R.apa_node node) None in 449 | let msg = Printf.sprintf "%s: unset parent" (R.Node.name node) in 450 | update t ~msg node new_node 451 | 452 | exception Found of [ area | project | action ] 453 | 454 | let is_area = function 455 | | `Area _ -> true 456 | | _ -> false 457 | 458 | let find_example_child pred node = 459 | try 460 | R.child_nodes node |> Ck_utils.M.iter (fun _ n -> if pred n then raise (Found n)); 461 | None 462 | with Found x -> Some x 463 | 464 | let convert_to_project t node = 465 | let new_details = 466 | match node with 467 | | `Action _ as a -> `Ok (Ck_disk_node.as_project (R.action_node a)) 468 | | `Area _ as a -> 469 | match find_example_child is_area node with 470 | | None -> `Ok (Ck_disk_node.as_project (R.area_node a)) 471 | | Some subarea -> 472 | error "Can't convert to a project because it has a sub-area (%s)" (R.Node.name subarea) 473 | in 474 | match new_details with 475 | | `Error _ as e -> Lwt.return e 476 | | `Ok new_details -> 477 | let msg = Printf.sprintf "Convert %s to project" (R.Node.name node) in 478 | update t ~msg node new_details >|= fun () -> 479 | `Ok () 480 | 481 | let convert_to_area t node = 482 | let new_details = Ck_disk_node.as_area (R.project_node node) in 483 | match R.parent (R.Node.rev node) node with 484 | | Some p when not (is_area p) -> 485 | Lwt.return (error "Can't convert to area because parent (%s) is not an area" (R.Node.name p)) 486 | | _ -> 487 | let msg = Printf.sprintf "Convert %s to area" (R.Node.name node) in 488 | update t ~msg node new_details >|= fun () -> 489 | `Ok () 490 | 491 | let convert_to_action t node = 492 | let new_details = Ck_disk_node.as_action (R.project_node node) in 493 | try 494 | let (_, child) = Ck_utils.M.min_binding (R.child_nodes node) in 495 | error "Can't convert to an action because it has a child (%s)" (R.Node.name child) |> Lwt.return 496 | with Not_found -> 497 | let msg = Printf.sprintf "Convert %s to action" (R.Node.name node) in 498 | update t ~msg node new_details >|= fun () -> 499 | `Ok () 500 | end 501 | -------------------------------------------------------------------------------- /lib/ck_update.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | (** Making changes to the store. *) 5 | 6 | open Ck_sigs 7 | 8 | module Make(Git : Git_storage_s.S) 9 | (Clock : Ck_clock.S) 10 | (R : Ck_rev.S with type commit = Git.Commit.t) : sig 11 | type t 12 | type update_cb = R.t -> unit Lwt.t 13 | 14 | open R.Node.Types 15 | 16 | val make : on_update:update_cb Lwt.t -> Git.Branch.t -> t Lwt.t 17 | (** Manage updates to this branch. 18 | * Calls [on_update] after the branch has changed (either due to the methods below or because 19 | * the store has been modified by another process. *) 20 | 21 | val head : t -> R.t 22 | (** The current head. Usually the branch tip, but can be different if [fix_head] is used. 23 | * Also, this is the cached version of the last state of the head. It is the version 24 | * passed to [on_update] and might lag the real head slightly. *) 25 | 26 | val fix_head : t -> Git.Commit.t option -> unit Lwt.t 27 | (** Set [head] to the given commit and pause tracking our branch. 28 | * Pass [None] to return to tracking the branch's head. 29 | * Modifications made via [t] will automatically resume tracking, but changes 30 | * made by other means will be ignored. *) 31 | 32 | val fixed_head : t -> bool 33 | 34 | val branch_head : t -> Git.Commit.t 35 | (** The current tip of the branch (whatever the setting of [fix_head]) *) 36 | 37 | (** Functions for making updates all work in the same way. 38 | * 1. Make a new branch from the commit that produced the source item. 39 | * 2. Commit the change to that branch (this should always succeed). 40 | * 3. Merge the new branch to master. 41 | * 4. Call the [on_update] function. 42 | * When they return, on_update has completed for the new revision. *) 43 | 44 | val add : t -> 45 | parent:[`Toplevel of R.t | `Node of [< area | project ]] -> 46 | (?parent:Ck_id.t -> ctime:float -> unit -> [ Ck_disk_node.Types.area | Ck_disk_node.Types.project | Ck_disk_node.Types.action]) -> 47 | Ck_id.t Lwt.t 48 | val add_contact : t -> base:R.t -> Ck_disk_node.Types.contact -> Ck_id.t Lwt.t 49 | val add_context : t -> base:R.t -> Ck_disk_node.Types.context -> Ck_id.t Lwt.t 50 | val delete : t -> ?msg:string -> [< R.Node.generic] list -> unit or_error Lwt.t 51 | val clear_conflicts : t -> [< R.Node.generic] -> unit Lwt.t 52 | 53 | val set_name : t -> [< R.Node.generic ] -> string -> unit Lwt.t 54 | val set_description : t -> [< R.Node.generic ] -> string -> unit Lwt.t 55 | val set_starred : t -> [< action | project] -> bool -> unit Lwt.t 56 | val set_action_state : t -> action -> [< action_state ] -> unit Lwt.t 57 | val set_repeat : t -> action -> Ck_time.repeat option -> unit Lwt.t 58 | val set_waiting_for : t -> action -> contact -> unit Lwt.t 59 | val set_project_state : t -> project -> [ `Active | `SomedayMaybe | `Done ] -> unit Lwt.t 60 | val set_context : t -> action -> context option -> unit Lwt.t 61 | val set_contact : t -> [< area | project | action] -> contact option -> unit Lwt.t 62 | 63 | val set_a_parent : t -> area -> area -> unit Lwt.t 64 | val set_pa_parent : t -> [< project | action] -> [< area | project] -> unit Lwt.t 65 | val remove_parent : t -> [< area | project | action] -> unit Lwt.t 66 | 67 | val convert_to_area : t -> project -> unit or_error Lwt.t 68 | val convert_to_project : t -> [< action | area] -> unit or_error Lwt.t 69 | val convert_to_action : t -> project -> unit or_error Lwt.t 70 | 71 | val revert : t -> repo:Git.Repository.t -> Git_storage_s.Log_entry.t -> unit or_error Lwt.t 72 | 73 | val sync : t -> from:Git.Commit.t -> unit or_error Lwt.t 74 | end 75 | -------------------------------------------------------------------------------- /lib/ck_utils.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | let (>>~=) x f = React.S.bind x f 5 | let (>|~=) x f = React.S.map ~eq:(==) f x 6 | 7 | let (>|?=) x f = 8 | match x with 9 | | None -> None 10 | | Some x -> Some (f x) 11 | 12 | let (>>?=) x f = 13 | match x with 14 | | None -> None 15 | | Some x -> f x 16 | 17 | let default d = function 18 | | None -> d 19 | | Some x -> x 20 | 21 | let bug fmt = 22 | let do_raise msg = raise @@ Failure msg in 23 | Printf.ksprintf do_raise fmt 24 | 25 | let error fmt = 26 | let ret msg = `Error msg in 27 | Printf.ksprintf ret fmt 28 | 29 | let (>>!=) x f = 30 | let open Lwt in 31 | x >>= function 32 | | `Error _ as e -> return e 33 | | `Ok y -> f y 34 | 35 | module StringMap = struct 36 | include Map.Make(String) 37 | let find_nf = find 38 | let find_safe key map = try find key map with Not_found -> bug "BUG: Key '%s' not found in StringMap!" key 39 | let find key map = try Some (find key map) with Not_found -> None 40 | let map_bindings fn map = fold (fun key value acc -> fn key value :: acc) map [] 41 | end 42 | 43 | module StringSet = Set.Make(String) 44 | 45 | module Sort_key = struct 46 | type t = string * Ck_id.t 47 | (* TODO: this is not UTF-8 aware; it will only sort ASCII strings correctly. *) 48 | let compare (a_name, a_id) (b_name, b_id) = 49 | match String.compare a_name b_name with 50 | | 0 -> compare a_id b_id 51 | | r -> r 52 | let id = snd 53 | let show = fst 54 | end 55 | module M = Map.Make(Sort_key) 56 | 57 | let rec filter_map fn = function 58 | | [] -> [] 59 | | (x::xs) -> 60 | match fn x with 61 | | None -> filter_map fn xs 62 | | Some y -> y :: filter_map fn xs 63 | 64 | let rlist_of ?init s = 65 | let init = 66 | match init with 67 | | None -> React.S.value s 68 | | Some v -> v in 69 | let changes = React.S.changes s |> React.E.map (fun x -> ReactiveData.RList.Set x) in 70 | ReactiveData.RList.from_event init changes 71 | 72 | (* Get the index of an item in an assoc list. *) 73 | let index_of key items = 74 | let rec aux i = function 75 | | [] -> None 76 | | (k, _v) :: _ when k = key -> Some i 77 | | _ :: xs -> aux (i + 1) xs in 78 | aux 0 items 79 | 80 | let tail s i = 81 | String.sub s i (String.length s - i) 82 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs unqualified) 2 | 3 | (library 4 | (wrapped false) 5 | (preprocess (pps ppx_sexp_conv)) 6 | (libraries sexplib lwt react reactiveData uuidm cohttp cohttp-lwt irmin tar unix) 7 | (name cuekeeper)) 8 | 9 | (data_only_dirs init) 10 | 11 | (rule 12 | (target ck_init.ml) 13 | (deps (source_tree init)) 14 | (action 15 | (run ocaml-crunch init -o ck_init.ml -m plain))) 16 | -------------------------------------------------------------------------------- /lib/init/ck-version: -------------------------------------------------------------------------------- 1 | 0.1 -------------------------------------------------------------------------------- /lib/init/context/139516f7-4c3e-47b8-98ce-0e273ea3ec5d: -------------------------------------------------------------------------------- 1 | ((name"In town")(description"")(ctime 1429362886.783)) -------------------------------------------------------------------------------- /lib/init/context/4636d8cf-7c0d-47a8-b800-fdca7b3f68d6: -------------------------------------------------------------------------------- 1 | ((name Email)(description"")(ctime 1429362869.32)) -------------------------------------------------------------------------------- /lib/init/context/855371a1-babe-4188-bb77-eea394927d7b: -------------------------------------------------------------------------------- 1 | ((name"At home")(description"")(ctime 1429362860.503)) -------------------------------------------------------------------------------- /lib/init/context/abae8e40-5d65-4f2d-afaa-a582ba2dabf2: -------------------------------------------------------------------------------- 1 | ((name Review)(description"")(ctime 1429371210.989)) -------------------------------------------------------------------------------- /lib/init/context/c6776794-d53e-460a-ada7-7e3b98c2f126: -------------------------------------------------------------------------------- 1 | ((name Reading)(description"Reading books, web-sites, etc.")(ctime 1429361903.226)) -------------------------------------------------------------------------------- /lib/init/context/c73ab810-4945-445b-93b3-d3048d478201: -------------------------------------------------------------------------------- 1 | ((name Writing)(description"")(ctime 1429362927.358)) -------------------------------------------------------------------------------- /lib/init/context/eea7d738-c781-4700-8594-667cd0d3fb41: -------------------------------------------------------------------------------- 1 | ((name Phone)(description"")(ctime 1429362871.23)) -------------------------------------------------------------------------------- /lib/init/db/0cfe996c-afa9-4403-a5c3-c194114572f3: -------------------------------------------------------------------------------- 1 | (Area((parent ad8c5bb1-f6b7-4a57-b090-d6ef2e3326c1)(name Friends)(description"")(ctime 1429361961.175))) -------------------------------------------------------------------------------- /lib/init/db/1a7c8ea2-18ac-41cb-8f79-3566e49445f4: -------------------------------------------------------------------------------- 1 | (Project(((pstarred false)(pstate Active))((parent 5841e8a9-81c0-43ac-830f-5f94d5a58b03)(name"Start using CueKeeper")(description"")(ctime 1429361902.021)))) -------------------------------------------------------------------------------- /lib/init/db/1c6a6964-e6c8-499a-8841-8cb437e2930f: -------------------------------------------------------------------------------- 1 | (Area((name Job)(description"Add work-related sub-areas here.")(ctime 1429361903.369))) -------------------------------------------------------------------------------- /lib/init/db/1ec321bf-d65d-430d-86d2-30a722e8dbb6: -------------------------------------------------------------------------------- 1 | (Area((parent ad8c5bb1-f6b7-4a57-b090-d6ef2e3326c1)(name Recreation)(description"")(ctime 1429387072.478))) -------------------------------------------------------------------------------- /lib/init/db/26b4b45a-bfd4-459f-ae82-7db874629e4a: -------------------------------------------------------------------------------- 1 | (Area((parent ad8c5bb1-f6b7-4a57-b090-d6ef2e3326c1)(name Home)(description"")(ctime 1429361974.687))) -------------------------------------------------------------------------------- /lib/init/db/5841e8a9-81c0-43ac-830f-5f94d5a58b03: -------------------------------------------------------------------------------- 1 | (Area((parent 1c6a6964-e6c8-499a-8841-8cb437e2930f)(name Admin)(description"")(ctime 1429362448.008))) -------------------------------------------------------------------------------- /lib/init/db/6002ea71-6f1c-4ba9-8728-720f4b4c9845: -------------------------------------------------------------------------------- 1 | (Action(((astarred false)(astate Next)(context c6776794-d53e-460a-ada7-7e3b98c2f126))((parent 1a7c8ea2-18ac-41cb-8f79-3566e49445f4)(name"Read wikipedia page on GTD")(description )(ctime 1429361903.3)))) -------------------------------------------------------------------------------- /lib/init/db/60c0e3db-ab42-46d8-bdc6-518484cc250f: -------------------------------------------------------------------------------- 1 | (Area((parent ad8c5bb1-f6b7-4a57-b090-d6ef2e3326c1)(name Family)(description"")(ctime 1429361948.76))) -------------------------------------------------------------------------------- /lib/init/db/931ab6e5-4db8-4370-a37b-5d7b6d858ba2: -------------------------------------------------------------------------------- 1 | (Area((parent ad8c5bb1-f6b7-4a57-b090-d6ef2e3326c1)(name Study)(description"")(ctime 1429362344.547))) -------------------------------------------------------------------------------- /lib/init/db/977fea84-925d-4de9-8c14-c16f145ed191: -------------------------------------------------------------------------------- 1 | (Area((parent ad8c5bb1-f6b7-4a57-b090-d6ef2e3326c1)(name Health)(description"")(ctime 1429361967.919))) -------------------------------------------------------------------------------- /lib/init/db/9a000050-4e81-4982-8d47-99230c4e1eb4: -------------------------------------------------------------------------------- 1 | (Area((parent ad8c5bb1-f6b7-4a57-b090-d6ef2e3326c1)(name Finances)(description"")(ctime 1429387065.472))) -------------------------------------------------------------------------------- /lib/init/db/ad8c5bb1-f6b7-4a57-b090-d6ef2e3326c1: -------------------------------------------------------------------------------- 1 | (Area((name Personal)(description"")(ctime 1429361901.891))) -------------------------------------------------------------------------------- /lib/init/db/af66bb30-5488-4b8b-a171-ba4a048d6fd1: -------------------------------------------------------------------------------- 1 | (Action(((astarred false)(astate(Waiting_until(2015 3 19)))(context abae8e40-5d65-4f2d-afaa-a582ba2dabf2)(repeat((repeat_n 1)(repeat_unit Week)(repeat_from(2015 3 19)))))((name"Weekly review")(description"- **Process** \n Empty inboxes, adding any actions to CueKeeper:\n - email inbox\n - paper inbox\n - *add your own here*\n- **Review/Done**\n - Admire done list, then delete all.\n- **Review/Waiting**\n - Any reminders needed?\n- **Review/Future**\n - Make any of these current?\n - Delete any that will never get done.\n- **Review/Areas**\n - Any areas that need new projects?\n- **Work**\n - Make sure each action is obvious (not vague).\n - Could it be started now? Set to **Waiting** if not.\n - List too long? Mark some actions as **Future**, or their projects as **Someday/Maybe**.")(ctime 1429371156.784)))) -------------------------------------------------------------------------------- /lib/utils/delta_RList.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Ck_sigs 5 | 6 | module Make (Key : Set.OrderedType) 7 | (Value : EQ) 8 | (M : Map.S with type key = Key.t) = struct 9 | (* Generate a patch from xs to ys *) 10 | let rec diff acc i xs ys = 11 | let open ReactiveData.RList in 12 | match xs, ys with 13 | | [], [] -> List.rev acc 14 | | _::xs, [] -> diff (R i :: acc) i xs [] 15 | | [], y::ys -> diff (I (i, snd y) :: acc) (i + 1) [] ys 16 | | x::xs, y::ys -> 17 | let d = Key.compare (fst x) (fst y) in 18 | if d < 0 then 19 | diff (R i :: acc) i xs (y::ys) 20 | else if d > 0 then 21 | diff (I (i, snd y) :: acc) (i + 1) (x::xs) ys 22 | else if Value.equal (snd x) (snd y) then 23 | diff acc (i + 1) xs ys 24 | else 25 | diff (U (i, snd y) :: acc) (i + 1) xs ys (* Same key, but value has changed. *) 26 | 27 | let make ?init s = 28 | let init = 29 | match init with 30 | | None -> React.S.value s 31 | | Some i -> i in 32 | let current = ref (M.bindings init) in 33 | let e = React.S.changes s 34 | |> React.E.map (fun new_set -> 35 | (* Calculate the changes need to update the current value to [new_s]. *) 36 | let new_list = M.bindings new_set in 37 | let patch = ReactiveData.RList.Patch (diff [] 0 !current new_list) in 38 | current := new_list; 39 | patch 40 | ) in 41 | ReactiveData.RList.from_event (List.map snd !current) e 42 | end 43 | -------------------------------------------------------------------------------- /lib/utils/delta_RList.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | (* Generates an RList from a signal of a set. 5 | * Unlike RList.make_from_s, this generates individual add and remove events 6 | * rather than replacing the whole list every time the signal changes. *) 7 | 8 | module Make (Key : Set.OrderedType) 9 | (Value : Ck_sigs.EQ) 10 | (M : Map.S with type key = Key.t) : sig 11 | (* If this can be called from a React update, you must provide the [init] field, 12 | * since [React.S.value input] won't be ready yet. *) 13 | val make : 14 | ?init:Value.t M.t -> 15 | Value.t M.t React.S.t -> 16 | Value.t ReactiveData.RList.t 17 | end 18 | -------------------------------------------------------------------------------- /lib/utils/git_storage.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard. 2 | * See the README file for details. *) 3 | 4 | open Lwt.Infix 5 | 6 | module IO = struct 7 | type in_channel = unit 8 | type out_channel = Buffer.t 9 | let really_input _ch _buf _pos _len = failwith "unused" 10 | let input = really_input 11 | let output = Buffer.add_subbytes 12 | let close_out _ = () 13 | end 14 | 15 | let option_map f = function 16 | | None -> None 17 | | Some x -> Some (f x) 18 | 19 | module T = Tar.Make(IO) 20 | 21 | module Make (I : Irmin.S 22 | with type key = string list 23 | and type contents = string 24 | and type hash = Digestif.SHA1.t 25 | and type branch = string 26 | and type step = string) = struct 27 | let bundle_t = Irmin.Type.pair I.Private.Slice.t I.Hash.t 28 | 29 | type repo = { 30 | r : I.Repo.t; 31 | info_maker : string -> Irmin.Info.t; 32 | } 33 | 34 | module Staging = struct 35 | type t = { 36 | repo : repo; 37 | parents : I.Commit.t list; 38 | mutable view : I.tree; 39 | } 40 | 41 | let create repo ~parents ~tree = 42 | {repo; parents; view = tree } 43 | 44 | let list t path = I.Tree.list t.view path >|= List.map fst 45 | let read t = I.Tree.find t.view 46 | let read_exn t = I.Tree.get t.view 47 | 48 | let update t k v = 49 | I.Tree.add t.view k v >|= fun v2 -> 50 | t.view <- v2 51 | 52 | let remove t k = 53 | I.Tree.remove t.view k >|= fun v2 -> 54 | t.view <- v2 55 | 56 | let mem t = I.Tree.mem t.view 57 | end 58 | 59 | module Commit = struct 60 | type t = { 61 | repo : repo; 62 | commit : I.Commit.t; 63 | } 64 | 65 | type id = I.Hash.t 66 | 67 | let v repo commit = { repo; commit } 68 | 69 | let id t = I.Commit.hash t.commit 70 | 71 | let equal a b = 72 | id a = id b 73 | 74 | let checkout t = 75 | let tree = I.Commit.tree t.commit in 76 | Staging.create t.repo ~parents:[t.commit] ~tree 77 | 78 | let commit ?parents staging ~msg = 79 | let repo = staging.Staging.repo in 80 | let parents = 81 | match parents with 82 | | Some parents -> List.map (fun t -> I.Commit.hash t.commit) parents 83 | | None -> List.map I.Commit.hash staging.Staging.parents 84 | in 85 | let info = 86 | match msg with 87 | | [] -> failwith "Empty commit message!" 88 | | [summary] -> repo.info_maker summary 89 | | summary :: body -> repo.info_maker (summary ^ "\n" ^ String.concat "\n" body) 90 | in 91 | I.Commit.v repo.r ~info ~parents staging.Staging.view >|= fun commit -> 92 | { repo; commit } 93 | 94 | module Top = Graph.Topological.Make_stable(struct 95 | type t = I.History.t 96 | let in_degree = I.History.in_degree 97 | let iter_succ = I.History.iter_succ 98 | let iter_vertex = I.History.iter_vertex 99 | module V = struct 100 | include I.History.V 101 | let compare a b = 102 | let ta = I.Commit.info a in 103 | let tb = I.Commit.info b in 104 | match Int64.compare (Irmin.Info.date ta) (Irmin.Info.date tb) with 105 | | 0 -> I.History.V.compare a b 106 | | r -> r 107 | end 108 | end) 109 | 110 | let history ?depth t = 111 | let open Git_storage_s in 112 | I.of_commit t.commit >>= I.history ?depth >>= fun history -> 113 | (* Set rank field according to topological order and build final result map *) 114 | let map = ref Log_entry_map.empty in 115 | let rank = ref 0 in 116 | history |> Top.iter (fun commit -> 117 | let info = I.Commit.info commit in 118 | incr rank; 119 | let msg = Irmin.Info.message info in 120 | let date = Irmin.Info.date info |> Int64.to_float in 121 | let id = I.Commit.hash commit in 122 | let entry = { Log_entry.date; rank = !rank; msg; id } in 123 | map := !map |> Log_entry_map.add entry entry 124 | ); 125 | Lwt.return !map 126 | 127 | let merge a b = 128 | I.of_commit a.commit >>= fun tmp -> 129 | let info () = a.repo.info_maker "Merge" in 130 | I.merge_with_commit tmp b.commit ~info >>= function 131 | | Ok () -> I.Head.get tmp >|= fun commit -> `Ok { a with commit } 132 | | Error (`Conflict _ as c) -> Lwt.return c 133 | 134 | let export_tar t = 135 | I.Commit.tree t.commit |> I.Tree.to_concrete >|= fun root -> 136 | let buf = Buffer.create 10240 in 137 | let files = ref [] in 138 | let rec scan ~path = function 139 | | `Contents (data, _metadata) -> 140 | let header = Tar.Header.make 141 | ~file_mode:0o644 142 | (String.concat "/" path) (String.length data |> Int64.of_int) in 143 | let write b = Buffer.add_string b data in 144 | files := (header, write) :: !files 145 | | `Tree items -> 146 | List.iter (fun (step, item) -> scan ~path:(path @ [step]) item) items 147 | in 148 | scan ~path:[] root; 149 | T.Archive.create_gen (Stream.of_list !files) buf; 150 | Buffer.contents buf 151 | 152 | let bundle_create t ~basis = 153 | I.Repo.export t.repo.r ~min:basis ~max:(`Max [t.commit]) >|= fun slice -> 154 | let b = Buffer.create 10240 in 155 | let encoder = Jsonm.encoder ~minify:true (`Buffer b) in 156 | Irmin.Type.encode_json bundle_t encoder (slice, I.Commit.hash t.commit); 157 | ignore @@ Jsonm.encode encoder `End; 158 | Some (Buffer.contents b) 159 | 160 | let hash_equal = Irmin.Type.(unstage (equal I.Hash.t)) 161 | 162 | let bundle ~tracking_branch t = 163 | let equal c1 c2 = 164 | hash_equal 165 | (I.Commit.hash c1) 166 | (I.Commit.hash c2) 167 | in 168 | I.of_branch t.repo.r tracking_branch >>= fun tracking_branch -> 169 | I.Head.find tracking_branch >>= function 170 | | Some old_head when equal old_head t.commit -> Lwt.return_none 171 | | Some old_head -> bundle_create t ~basis:[old_head] 172 | | None -> bundle_create t ~basis:[] 173 | 174 | let parents t = 175 | I.Commit.parents t.commit |> Lwt_list.map_s (fun hash -> 176 | I.Commit.of_hash t.repo.r hash >|= function 177 | | Some commit -> {t with commit} 178 | | None -> assert false 179 | ) 180 | 181 | let info t = 182 | I.Commit.info t.commit 183 | 184 | let lcas t other = 185 | I.of_commit t.commit >>= fun tmp -> 186 | I.lcas_with_commit tmp other.commit >|= function 187 | | Ok ids -> ids |> List.map (fun commit -> { t with commit }) 188 | | Error (`Max_depth_reached |`Too_many_lcas) -> assert false (* Can't happen *) 189 | end 190 | 191 | module Branch = struct 192 | type t = { 193 | repo : repo; 194 | store : I.t; 195 | head_id : Commit.id option ref; 196 | head : Commit.t option React.S.t; 197 | watch : I.watch; 198 | } 199 | 200 | let opt_commit_equal a b = 201 | match a, b with 202 | | Some a, Some b -> Commit.equal a b 203 | | None, None -> true 204 | | _ -> false 205 | 206 | let of_store ?if_new repo store = 207 | I.Head.find store >>= (function 208 | | Some commit -> Lwt.return_some (Commit.v repo commit) 209 | | None -> 210 | match if_new with 211 | | None -> Lwt.return_none 212 | | Some (lazy if_new) -> 213 | if_new >>= fun commit -> 214 | I.Head.test_and_set store ~test:None ~set:(Some commit.Commit.commit) >>= function 215 | | true -> Lwt.return_some commit 216 | | false -> 217 | Printf.eprintf "Warning: Concurrent attempt to initialise new branch; discarding our attempt\n%!"; 218 | I.Head.get store >|= fun commit -> Some (Commit.v repo commit) 219 | ) >>= fun initial_head -> 220 | let initial_head_commit = initial_head |> option_map (fun x -> x.Commit.commit) in 221 | let initial_head_id = initial_head |> option_map Commit.id in 222 | let head_id = ref initial_head_id in 223 | let head, set_head = React.S.create ~eq:opt_commit_equal initial_head in 224 | I.watch store ?init:initial_head_commit (fun _diff -> 225 | (* (ignore the commit ID in the update message; we want the latest) *) 226 | I.Head.find store >|= fun new_head -> 227 | let new_head_id = option_map I.Commit.hash new_head in 228 | if new_head_id <> !head_id then ( 229 | head_id := new_head_id; 230 | new_head |> option_map (Commit.v repo) |> set_head 231 | ) 232 | ) >>= fun watch -> 233 | Lwt.return { 234 | repo; 235 | store; 236 | head_id; 237 | head; 238 | watch; 239 | } 240 | 241 | let head t = t.head 242 | 243 | let fast_forward_to t commit = 244 | I.Head.fast_forward t.store commit.Commit.commit >|= function 245 | | Ok () | Error `No_change -> `Ok 246 | | Error `Rejected -> `Not_fast_forward (* (concurrent update) *) 247 | | Error (`Max_depth_reached | `Too_many_lcas) -> 248 | (* These shouldn't happen, because we didn't set any limits *) 249 | assert false 250 | 251 | let force t = function 252 | | Some commit -> I.Head.set t.store commit.Commit.commit 253 | | None -> 254 | match I.status t.store with 255 | | `Empty | `Commit _ -> assert false 256 | | `Branch branch_name -> I.Branch.remove t.repo.r branch_name 257 | 258 | let fetch_bundle tracking_branch bundle = 259 | let repo = tracking_branch.repo in 260 | let decoder = Jsonm.decoder (`String bundle) in 261 | match Irmin.Type.decode_json bundle_t decoder with 262 | | Error (`Msg m) -> Lwt.return (`Error (Fmt.str "Failed to decode slice JSON: %s" m)) 263 | | Ok (slice, head) -> 264 | (* Check whether we already have [head]. *) 265 | begin 266 | I.Commit.of_hash repo.r head >>= function 267 | | Some commit -> Lwt.return_ok commit 268 | | None -> 269 | (* If not, import the slice *) 270 | I.Repo.import tracking_branch.repo.r slice >>= function 271 | | Error (`Msg m) -> Lwt_result.fail (Fmt.str "Failed to import slice: %s" m) 272 | | Ok () -> 273 | I.Commit.of_hash repo.r head >>= function 274 | | Some commit -> Lwt_result.return commit 275 | | None -> Lwt_result.fail "Head commit not found after importing bundle!" 276 | end >>= function 277 | | Error m -> Lwt.return (`Error m) 278 | | Ok head -> 279 | I.Head.set tracking_branch.store head >|= fun () -> 280 | `Ok (Commit.v repo head) 281 | 282 | let release t = 283 | I.unwatch t.watch 284 | end 285 | 286 | module Repository = struct 287 | type t = repo 288 | 289 | let branch t ?if_new name = 290 | I.of_branch t.r name >>= Branch.of_store ?if_new t 291 | 292 | let branch_head t branch = 293 | I.Branch.find t.r branch >|= option_map I.Commit.hash 294 | 295 | let commit t id = 296 | I.Commit.of_hash t.r id >|= option_map (Commit.v t) 297 | 298 | let empty t = 299 | Staging.create t ~parents:[] ~tree:(I.Tree.empty ()) 300 | end 301 | 302 | let make r info_maker = {r; info_maker} 303 | end 304 | -------------------------------------------------------------------------------- /lib/utils/git_storage.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard. 2 | * See the README file for details. *) 3 | 4 | (** A Git-like storage abstraction over Irmin. *) 5 | 6 | module Make (I : Irmin.S 7 | with type key = string list 8 | and type contents = string 9 | and type hash = Digestif.SHA1.t 10 | and type branch = string 11 | and type step = string) : sig 12 | include Git_storage_s.S 13 | 14 | val make : I.Repo.t -> (string -> Irmin.Info.t) -> Repository.t 15 | end 16 | -------------------------------------------------------------------------------- /lib/utils/git_storage_s.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | type branch_name = string 5 | type bundle = string 6 | type path = string list 7 | 8 | module Log_entry = struct 9 | module Id = struct 10 | type t = Digestif.SHA1.t 11 | let compare = compare 12 | end 13 | type t = { 14 | id : Digestif.SHA1.t; 15 | rank : int; 16 | date : float; 17 | msg : string; 18 | } 19 | let compare b a = (* Newest first *) 20 | compare a.rank b.rank 21 | let id x = x.id 22 | let show x = x.msg 23 | let equal a b = 24 | Digestif.SHA1.equal a.id b.id 25 | end 26 | 27 | module Log_entry_map = Map.Make(Log_entry) 28 | 29 | module type S = sig 30 | module Staging : sig 31 | type t 32 | 33 | val list : t -> path -> string list Lwt.t 34 | val read : t -> path -> string option Lwt.t 35 | val read_exn : t -> path -> string Lwt.t 36 | val update : t -> path -> string -> unit Lwt.t 37 | val remove : t -> path -> unit Lwt.t 38 | val mem : t -> path -> bool Lwt.t 39 | end 40 | 41 | module Commit : sig 42 | type t 43 | 44 | val checkout : t -> Staging.t 45 | val commit : ?parents:t list -> Staging.t -> msg:string list -> t Lwt.t 46 | val merge : t -> t -> [ `Conflict of string | `Ok of t ] Lwt.t 47 | val equal : t -> t -> bool 48 | val history : ?depth:int -> t -> Log_entry.t Log_entry_map.t Lwt.t 49 | val export_tar : t -> string Lwt.t 50 | val parents : t -> t list Lwt.t 51 | val info : t -> Irmin.Info.t 52 | val lcas : t -> t -> t list Lwt.t 53 | (** Find the least common ancestor(s) of two commits. 54 | * This is used as the base when doing a 3-way merge. *) 55 | 56 | val bundle : tracking_branch:branch_name -> t -> bundle option Lwt.t 57 | (** Exports the given commit with full history, excluding anything 58 | * already in [tracking_branch]. The resulting bundle can be imported 59 | * into the remote repository that [tracking_branch] tracks. 60 | * If there is nothing to export, returns None. *) 61 | 62 | val id : t -> Digestif.SHA1.t 63 | end 64 | 65 | module Branch : sig 66 | type t 67 | 68 | val head : t -> Commit.t option React.S.t 69 | val fast_forward_to : t -> Commit.t -> [ `Ok | `Not_fast_forward ] Lwt.t 70 | 71 | val force : t -> Commit.t option -> unit Lwt.t 72 | (** Set the head of the branch to point at this commit. 73 | * If None, the branch is deleted. *) 74 | 75 | val fetch_bundle : t -> bundle -> Commit.t Ck_sigs.or_error Lwt.t 76 | (** Import the contents of the bundle into the repository, updating the branch to 77 | * point to the bundle's head (even if not a fast-forward). Returns the new head. *) 78 | 79 | val release : t -> unit Lwt.t 80 | (** Stop watching this branch for updates ([head] will no longer update and 81 | * [t] should not be used again). *) 82 | end 83 | 84 | module Repository : sig 85 | type t 86 | 87 | val branch : t -> ?if_new:(Commit.t Lwt.t Lazy.t) -> branch_name -> Branch.t Lwt.t 88 | (** Get the named branch. 89 | * If the branch does not exist yet, [if_new] is called to get the initial commit. *) 90 | 91 | val branch_head : t -> branch_name -> Digestif.SHA1.t option Lwt.t 92 | (** Check the current head of a branch. None if the branch doesn't exist. *) 93 | 94 | val commit : t -> Digestif.SHA1.t -> Commit.t option Lwt.t 95 | (** Look up a commit by its hash. *) 96 | 97 | val empty : t -> Staging.t 98 | (** Create an empty checkout with no parent. *) 99 | end 100 | end 101 | -------------------------------------------------------------------------------- /lib/utils/reactive_tree.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Ck_sigs 5 | 6 | (* Note on GC: 7 | * 8 | * Signals created using S.map, bind, etc, register a callback with the source 9 | * signal. We need to make sure this callback gets removed, otherwise we will 10 | * leak memory and waste time on pointless updates. 11 | * 12 | * In native code, the producer has a weak ref to the callback and will GC it 13 | * eventually (although this makes everything non-deterministic and still wastes 14 | * time before the GC occurs). 15 | * 16 | * In JavaScript, there are no weak refs and we always leak unless we call 17 | * [S.stop ~strong:true]. However, this not only unregisters the callback from 18 | * the source, but recursively stops the source too if it has no other handlers 19 | * (which we don't know in general). 20 | * 21 | * Therefore, we avoid these functions here and set the signal states manually. 22 | * Our source signal only has a reference to the tree as a whole. When a widget 23 | * is removed, it can therefore be GC'd (along with anything that depends on it). 24 | *) 25 | 26 | module Make (C : Ck_clock.S) (M : TREE_MODEL) (G : GUI_DATA) = struct 27 | module Slow = Slow_set.Make(C)(M.Sort_key)(M.Child_map) 28 | 29 | module Id = struct 30 | type t = 31 | | Root 32 | | Unique_item of Ck_id.t 33 | | Group_item of Ck_id.t * t (* Path of group relative to ancestor with UUID *) 34 | | Group of M.group * t (* Path of group relative to ancestor with UUID *) 35 | let compare = compare 36 | end 37 | 38 | module Id_map = Map.Make(Id) 39 | 40 | module W = struct 41 | type item = 42 | [ `Item of M.Item.generic React.S.t * (?step:React.step -> M.Item.generic -> unit) * bool (* (unique) *) 43 | | `Group of M.group ] 44 | 45 | type t = { 46 | item : item; 47 | children : t Slow_set.item ReactiveData.RList.t; 48 | set_child_widgets : ?step:React.step -> t M.Child_map.t -> unit; 49 | gui_data : G.t option ref; 50 | mutable adder : M.adder option; 51 | } 52 | 53 | let item t = 54 | match t.item with 55 | | `Item (item, _, _) -> `Item item 56 | | `Group gid -> `Group (M.group_label gid) 57 | 58 | let children t = t.children 59 | 60 | let equal a b = 61 | match a.item, b.item with 62 | | `Item _, `Item _ -> 63 | (* Delta wants to know when to send updates. In fact, widgets never update, 64 | * so we can just return true here. *) 65 | true 66 | | `Group a, `Group b -> a = b 67 | | _ -> false 68 | end 69 | 70 | module Widget = struct 71 | type t = W.t Slow_set.item 72 | type adder = M.adder 73 | 74 | let item t = W.item (Slow_set.data t) 75 | let children t = W.children (Slow_set.data t) 76 | let state = Slow_set.state 77 | let gui_data t = (Slow_set.data t).W.gui_data 78 | let unique (t:t) = 79 | match (Slow_set.data t).W.item with 80 | | `Item (_, _, unique) -> unique 81 | | `Group _ -> false 82 | 83 | let equal a b = 84 | W.equal (Slow_set.data a) (Slow_set.data b) 85 | 86 | let adder t = (Slow_set.data t).W.adder 87 | end 88 | 89 | module Delta = Delta_RList.Make(M.Sort_key)(Widget)(M.Child_map) 90 | 91 | let rec make_widget ~widgets ~get_child ~parent_id node : W.t = 92 | (* Printf.printf "make_widget(%s)\n" (M.Item.show (M.item node)); *) 93 | let item, id = 94 | match M.item node with 95 | | `UniqueItem (id, item) -> 96 | let item, set_item = React.S.create ~eq:M.Item.equal item in 97 | `Item (item, set_item, true), Id.Unique_item id 98 | | `GroupItem (id, item) -> 99 | let item, set_item = React.S.create ~eq:M.Item.equal item in 100 | `Item (item, set_item, false), Id.Group_item (id, parent_id) 101 | | `Group label as g -> g, (Id.Group (label, parent_id)) in 102 | let children, set_child_widgets = 103 | make_widgets ~get_child ~parent_id:id (M.children node) in 104 | let widget = { W. 105 | item; 106 | children; 107 | set_child_widgets; 108 | gui_data = ref None; 109 | adder = M.adder node; 110 | } in 111 | (* todo: check for duplicates? *) 112 | widgets := !widgets |> Id_map.add id widget; 113 | widget 114 | and make_widgets ~get_child ~parent_id nodes = 115 | let init_children = nodes |> M.Child_map.map (get_child ~parent_id) in 116 | let child_widgets, set_child_widgets = 117 | React.S.create ~eq:(M.Child_map.equal W.equal) init_children in 118 | let children = child_widgets 119 | |> Slow.make 120 | ~delay:1.0 121 | ~init:init_children 122 | ~eq:W.equal 123 | |> Delta.make in 124 | (children, set_child_widgets) 125 | 126 | type t = { 127 | widgets : W.t Id_map.t ref; 128 | root_widgets : Widget.t ReactiveData.RList.t; 129 | set_root_widgets : ?step:React.step -> W.t M.Child_map.t -> unit; 130 | } 131 | 132 | let update t ~old_widgets ~parent_id = 133 | let rec make_or_update ~parent_id node = 134 | let id, new_item = 135 | match M.item node with 136 | | `UniqueItem (id, new_item) -> (Id.Unique_item id, Some new_item) 137 | | `GroupItem (id, new_item) -> (Id.Group_item (id, parent_id), Some new_item) 138 | | `Group s -> (Id.Group (s, parent_id), None) in 139 | try 140 | let existing = Id_map.find id old_widgets in 141 | M.children node |> M.Child_map.map (make_or_update ~parent_id:id) |> existing.W.set_child_widgets; 142 | existing.W.adder <- M.adder node; 143 | t.widgets := !(t.widgets) |> Id_map.add id existing; 144 | begin match existing.W.item, new_item with 145 | | `Item (_, set_item, _), Some new_item -> set_item new_item 146 | | `Group _, None -> () 147 | | _ -> assert false end; 148 | existing 149 | with Not_found -> 150 | make_widget ~get_child:make_or_update ~widgets:t.widgets ~parent_id node 151 | in 152 | M.Child_map.map (make_or_update ~parent_id) 153 | 154 | let make nodes = 155 | let widgets = ref Id_map.empty in 156 | let rec get_child ~parent_id node = 157 | make_widget ~widgets ~get_child ~parent_id node in 158 | let root_widgets, set_root_widgets = make_widgets ~get_child ~parent_id:Id.Root nodes in 159 | { 160 | widgets; 161 | root_widgets; 162 | set_root_widgets; 163 | } 164 | 165 | let update t ~on_remove nodes = 166 | (* print_endline "\n== update ==\n"; *) 167 | let old_widgets = !(t.widgets) in 168 | t.widgets := Id_map.empty; 169 | update t ~old_widgets ~parent_id:Id.Root nodes |> t.set_root_widgets; 170 | 171 | old_widgets |> Id_map.iter (fun k old -> 172 | if not (Id_map.mem k !(t.widgets)) then ( 173 | match old.W.item with 174 | | `Group _ -> () 175 | | `Item (old_item, set_item, _) -> 176 | match on_remove (React.S.value old_item) with 177 | | None -> () 178 | | Some update -> set_item update 179 | ) 180 | ) 181 | 182 | let widgets t = t.root_widgets 183 | end 184 | -------------------------------------------------------------------------------- /lib/utils/reactive_tree.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | (** Converts a signal of a tree to a tree of signals. 5 | * 6 | * In particular, it gives a persistent identity to nodes, making animations 7 | * possible. 8 | * 9 | * The output signals will be automatically GC'd when the node is removed 10 | * from the tree, even on platform without weak refs. 11 | * 12 | * Updates are done by calling [update] rather than by passing a signal to 13 | * [make] to avoid resource leaks. 14 | *) 15 | 16 | open Ck_sigs 17 | 18 | module Make (C : Ck_clock.S) (M : TREE_MODEL) (G : GUI_DATA) : sig 19 | type t 20 | 21 | module Widget : sig 22 | (** An object visible on the screen. *) 23 | type t 24 | val item : t -> 25 | [ `Item of M.Item.generic React.S.t 26 | | `Group of string] 27 | val children : t -> t ReactiveData.RList.t 28 | val state : t -> Slow_set.state React.S.t 29 | val gui_data : t -> G.t option ref 30 | val unique : t -> bool 31 | (** Unique items occur at most once in the tree (and are often leaves). 32 | * Non-unique items are used for grouping, and are typically rendered as headings. *) 33 | 34 | type adder = M.adder 35 | val adder : t -> adder option 36 | end 37 | 38 | val make : M.t M.Child_map.t -> t 39 | 40 | (** Walk the new tree, updating the current RLists, creating new ones where necessary. 41 | * Widgets that are no longer present are removed from the output lists and [on_remove] 42 | * is called on each one. This is useful to provide one last update showing why the 43 | * item was removed as it fades out. 44 | *) 45 | val update : t -> on_remove:(M.Item.generic -> M.Item.generic option) -> M.t M.Child_map.t -> unit 46 | 47 | val widgets : t -> Widget.t ReactiveData.RList.t 48 | end 49 | -------------------------------------------------------------------------------- /lib/utils/slow_set.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Lwt.Infix 5 | 6 | type state = 7 | [ `New (* Recently added to the list *) 8 | | `Init (* New, but already present when the list was created *) 9 | | `Current (* Has been in the list for a while (fade-in done) *) 10 | | `Removed of float ] (* Time item was removed from input *) 11 | 12 | module type SORT_KEY = sig 13 | include Map.OrderedType 14 | module Id : Map.OrderedType 15 | val id : t -> Id.t 16 | val show : t -> string 17 | end 18 | 19 | type 'a item = { 20 | data : 'a; 21 | state : state React.S.t; 22 | set_state : state -> unit; 23 | } 24 | 25 | let data item = item.data 26 | let state item = item.state 27 | 28 | let make_item initial_state data = 29 | let state, set_state = React.S.create initial_state in 30 | {data; state; set_state} 31 | 32 | module Make (C : Ck_clock.S) (K : SORT_KEY) (M : Map.S with type key = K.t) = struct 33 | module Id_map = Map.Make(K.Id) 34 | 35 | let diff_old_new ~eq ~removed_by_id ~time key i_old i_new = 36 | match i_old, i_new with 37 | | None, None -> None 38 | | Some _, None -> 39 | removed_by_id := !removed_by_id |> Id_map.add (K.id key) key; 40 | Some (`Removed time) 41 | | None, Some n -> Some (`New n) 42 | | Some o, Some n when not (eq o n) -> Some (`Updated n) 43 | | Some _, Some _ -> None 44 | 45 | let merge_diff _key prev patch = 46 | match prev, patch with 47 | | prev, None -> prev 48 | | Some old as prev, Some ((`Removed _) as r) -> old.set_state r; prev 49 | | Some old, Some (`Updated data) -> Some {old with data} 50 | | None, Some (`New data) -> Some (make_item `New data) 51 | | None, Some (`Renamed data) -> Some (make_item `Current data) 52 | | Some old, Some (`New data | `Renamed data) -> old.set_state `Current; Some {old with data} 53 | | Some _, Some `Drop -> None 54 | | None, Some (`Updated _ | `Removed _ | `Drop) -> assert false 55 | 56 | let adjacent current current_k old_k = 57 | let before_old, _, after_old = M.split old_k current in 58 | try 59 | let (adj_key, _) = 60 | if K.compare current_k old_k < 0 then M.max_binding before_old 61 | else M.min_binding after_old in 62 | K.compare adj_key current_k = 0 63 | with Not_found -> false 64 | 65 | (* Modify the diff: 66 | * - If a New item has the same ID as a Removed one then 67 | * - If it's next to the old one, turn the pair into a `Drop, `Rename pair. 68 | * - Otherwise, into a `Remove, `New pair. 69 | *) 70 | let detect_moves ~input ~removed_by_id diff = 71 | let renamed_src = ref [] in 72 | let diff = diff 73 | |> M.mapi (fun k v -> 74 | match v with 75 | | (`New data) as p -> 76 | begin try 77 | let src_key = Id_map.find (K.id k) removed_by_id in 78 | if adjacent input k src_key then ( 79 | renamed_src := src_key :: !renamed_src; `Renamed data 80 | ) else p 81 | with Not_found -> p end 82 | | p -> p 83 | ) 84 | |> ref in 85 | !renamed_src |> List.iter (fun src_key -> 86 | diff := !diff |> M.add src_key `Drop 87 | ); 88 | !diff 89 | 90 | let make ~delay ~eq ?init input = 91 | let init = 92 | match init with 93 | | None -> React.S.value input 94 | | Some i -> i in 95 | 96 | let out_item_eq a b = eq a.data b.data in 97 | 98 | let output, set_output = 99 | init 100 | |> M.map (make_item `Init) 101 | |> React.S.create ~eq:(M.equal out_item_eq) in 102 | 103 | (* Called [delay] after some items have been added or removed. 104 | * Update their status if appropriate. *) 105 | let check start delayed = 106 | let m = ref (React.S.value output) in 107 | delayed |> M.iter (fun k -> function 108 | | `Drop | `Renamed _ | `Updated _ -> () 109 | | `New _ -> 110 | begin try 111 | let item = M.find k !m in 112 | begin match React.S.value item.state with 113 | | `New | `Init -> item.set_state `Current 114 | | `Current | `Removed _ -> () end 115 | with Not_found -> 116 | (* Can happen if we add and remove quickly and the remove callback 117 | * arrives first. *) 118 | () 119 | end 120 | | `Removed _ -> 121 | try 122 | let item = M.find k !m in 123 | match React.S.value item.state with 124 | | `Removed t when t = start -> m := !m |> M.remove k 125 | | `New | `Init | `Current | `Removed _ -> () 126 | with Not_found -> 127 | (* Can happen if we add/remove/add/remove in quick succession, with same 128 | * start times. *) 129 | () 130 | ); 131 | set_output !m in 132 | 133 | let () = 134 | (* Change everything to `Current after a bit *) 135 | let time = C.now () in 136 | let diff = init |> M.map (fun item -> `New item) in 137 | C.async ~name:"set_state init" (fun () -> 138 | C.sleep delay >|= fun () -> 139 | check time diff 140 | ) in 141 | 142 | let keep_me = 143 | input |> React.S.diff (fun s_new s_old -> 144 | let time = C.now () in 145 | let removed_by_id = ref Id_map.empty in 146 | let diff = 147 | M.merge (diff_old_new ~eq ~removed_by_id ~time) s_old s_new 148 | |> detect_moves ~input:s_new ~removed_by_id:!removed_by_id in 149 | 150 | if not (M.is_empty diff) then ( 151 | M.merge merge_diff (React.S.value output) diff 152 | |> set_output; 153 | C.async ~name:"slow_set" (fun () -> 154 | C.sleep delay >|= fun () -> 155 | check time diff 156 | ) 157 | ) 158 | ) in 159 | React.S.retain output (fun () -> ignore keep_me) |> ignore; 160 | 161 | output 162 | end 163 | -------------------------------------------------------------------------------- /lib/utils/slow_set.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | type state = 5 | [ `New (* Recently added to the list *) 6 | | `Init (* New, but already present when the list was created *) 7 | | `Current (* Has been in the list for a while (fade-in done) *) 8 | | `Removed of float ] (* Time item was removed from input *) 9 | 10 | type 'a item 11 | 12 | val data : 'a item -> 'a 13 | val state : 'a item -> state React.S.t 14 | 15 | module type SORT_KEY = sig 16 | include Map.OrderedType 17 | module Id : Map.OrderedType 18 | val id : t -> Id.t 19 | val show : t -> string (* For debugging *) 20 | end 21 | 22 | module Make (C : Ck_clock.S) (K : SORT_KEY) (M : Map.S with type key = K.t) : sig 23 | val make : 24 | delay : float -> 25 | eq : ('a -> 'a -> bool) -> 26 | ?init : 'a M.t -> 27 | 'a M.t React.S.t -> 28 | 'a item M.t React.S.t 29 | end 30 | -------------------------------------------------------------------------------- /resources/cache.manifest: -------------------------------------------------------------------------------- 1 | CACHE MANIFEST 2 | resources/css/normalize.css 3 | resources/css/foundation.css 4 | resources/css/style.css 5 | resources/css/pikaday.css 6 | resources/js/vendor/pikaday.js 7 | resources/js/vendor/FileSaver.min.js 8 | resources/js/cuekeeper.js 9 | resources/ico/ck.ico 10 | resources/ico/ck-alert.ico 11 | -------------------------------------------------------------------------------- /resources/css/foundation.min.css: -------------------------------------------------------------------------------- 1 | meta.foundation-version{font-family:"/5.5.1/"}meta.foundation-mq-small{font-family:"/only screen/";width:0}meta.foundation-mq-small-only{font-family:"/only screen and (max-width: 40em)/";width:0}meta.foundation-mq-medium{font-family:"/only screen and (min-width:40.063em)/";width:40.063em}meta.foundation-mq-medium-only{font-family:"/only screen and (min-width:40.063em) and (max-width:64em)/";width:40.063em}meta.foundation-mq-large{font-family:"/only screen and (min-width:64.063em)/";width:64.063em}meta.foundation-mq-large-only{font-family:"/only screen and (min-width:64.063em) and (max-width:90em)/";width:64.063em}meta.foundation-mq-xlarge{font-family:"/only screen and (min-width:90.063em)/";width:90.063em}meta.foundation-mq-xlarge-only{font-family:"/only screen and (min-width:90.063em) and (max-width:120em)/";width:90.063em}meta.foundation-mq-xxlarge{font-family:"/only screen and (min-width:120.063em)/";width:120.063em}meta.foundation-data-attribute-namespace{font-family:false}html,body{height:100%}*,*:before,*:after{-webkit-box-sizing:border-box;-moz-box-sizing:border-box;box-sizing:border-box}html,body{font-size:100%}body{background:#fff;color:#222;padding:0;margin:0;font-family:"Helvetica Neue",Helvetica,Roboto,Arial,sans-serif;font-weight:normal;font-style:normal;line-height:1.5;position:relative;cursor:auto}a:hover{cursor:pointer}img{max-width:100%;height:auto}img{-ms-interpolation-mode:bicubic}#map_canvas img,#map_canvas embed,#map_canvas object,.map_canvas img,.map_canvas embed,.map_canvas object{max-width:none !important}.left{float:left !important}.right{float:right !important}.clearfix:before,.clearfix:after{content:" ";display:table}.clearfix:after{clear:both}.hide{display:none}.invisible{visibility:hidden}.antialiased{-webkit-font-smoothing:antialiased;-moz-osx-font-smoothing:grayscale}img{display:inline-block;vertical-align:middle}textarea{height:auto;min-height:50px}select{width:100%}.row{width:100%;margin-left:auto;margin-right:auto;margin-top:0;margin-bottom:0;max-width:62.5em}.row:before,.row:after{content:" ";display:table}.row:after{clear:both}.row.collapse>.column,.row.collapse>.columns{padding-left:0;padding-right:0}.row.collapse .row{margin-left:0;margin-right:0}.row .row{width:auto;margin-left:-0.9375em;margin-right:-0.9375em;margin-top:0;margin-bottom:0;max-width:none}.row .row:before,.row .row:after{content:" ";display:table}.row .row:after{clear:both}.row .row.collapse{width:auto;margin:0;max-width:none}.row .row.collapse:before,.row .row.collapse:after{content:" ";display:table}.row .row.collapse:after{clear:both}.column,.columns{padding-left:0.9375em;padding-right:0.9375em;width:100%;float:left}[class*="column"]+[class*="column"]:last-child{float:right}[class*="column"]+[class*="column"].end{float:left}@media only screen{.small-push-0{position:relative;left:0%;right:auto}.small-pull-0{position:relative;right:0%;left:auto}.small-push-1{position:relative;left:8.33333%;right:auto}.small-pull-1{position:relative;right:8.33333%;left:auto}.small-push-2{position:relative;left:16.66667%;right:auto}.small-pull-2{position:relative;right:16.66667%;left:auto}.small-push-3{position:relative;left:25%;right:auto}.small-pull-3{position:relative;right:25%;left:auto}.small-push-4{position:relative;left:33.33333%;right:auto}.small-pull-4{position:relative;right:33.33333%;left:auto}.small-push-5{position:relative;left:41.66667%;right:auto}.small-pull-5{position:relative;right:41.66667%;left:auto}.small-push-6{position:relative;left:50%;right:auto}.small-pull-6{position:relative;right:50%;left:auto}.small-push-7{position:relative;left:58.33333%;right:auto}.small-pull-7{position:relative;right:58.33333%;left:auto}.small-push-8{position:relative;left:66.66667%;right:auto}.small-pull-8{position:relative;right:66.66667%;left:auto}.small-push-9{position:relative;left:75%;right:auto}.small-pull-9{position:relative;right:75%;left:auto}.small-push-10{position:relative;left:83.33333%;right:auto}.small-pull-10{position:relative;right:83.33333%;left:auto}.small-push-11{position:relative;left:91.66667%;right:auto}.small-pull-11{position:relative;right:91.66667%;left:auto}.column,.columns{position:relative;padding-left:0.9375em;padding-right:0.9375em;float:left}.small-1{width:8.33333%}.small-2{width:16.66667%}.small-3{width:25%}.small-4{width:33.33333%}.small-5{width:41.66667%}.small-6{width:50%}.small-7{width:58.33333%}.small-8{width:66.66667%}.small-9{width:75%}.small-10{width:83.33333%}.small-11{width:91.66667%}.small-12{width:100%}.small-offset-0{margin-left:0% !important}.small-offset-1{margin-left:8.33333% !important}.small-offset-2{margin-left:16.66667% !important}.small-offset-3{margin-left:25% !important}.small-offset-4{margin-left:33.33333% !important}.small-offset-5{margin-left:41.66667% !important}.small-offset-6{margin-left:50% !important}.small-offset-7{margin-left:58.33333% !important}.small-offset-8{margin-left:66.66667% !important}.small-offset-9{margin-left:75% !important}.small-offset-10{margin-left:83.33333% !important}.small-offset-11{margin-left:91.66667% !important}.small-reset-order{margin-left:0;margin-right:0;left:auto;right:auto;float:left}.column.small-centered,.columns.small-centered{margin-left:auto;margin-right:auto;float:none}.column.small-uncentered,.columns.small-uncentered{margin-left:0;margin-right:0;float:left}.column.small-centered:last-child,.columns.small-centered:last-child{float:none}.column.small-uncentered:last-child,.columns.small-uncentered:last-child{float:left}.column.small-uncentered.opposite,.columns.small-uncentered.opposite{float:right}.row.small-collapse>.column,.row.small-collapse>.columns{padding-left:0;padding-right:0}.row.small-collapse .row{margin-left:0;margin-right:0}.row.small-uncollapse>.column,.row.small-uncollapse>.columns{padding-left:0.9375em;padding-right:0.9375em;float:left}}@media only screen and (min-width: 40.063em){.medium-push-0{position:relative;left:0%;right:auto}.medium-pull-0{position:relative;right:0%;left:auto}.medium-push-1{position:relative;left:8.33333%;right:auto}.medium-pull-1{position:relative;right:8.33333%;left:auto}.medium-push-2{position:relative;left:16.66667%;right:auto}.medium-pull-2{position:relative;right:16.66667%;left:auto}.medium-push-3{position:relative;left:25%;right:auto}.medium-pull-3{position:relative;right:25%;left:auto}.medium-push-4{position:relative;left:33.33333%;right:auto}.medium-pull-4{position:relative;right:33.33333%;left:auto}.medium-push-5{position:relative;left:41.66667%;right:auto}.medium-pull-5{position:relative;right:41.66667%;left:auto}.medium-push-6{position:relative;left:50%;right:auto}.medium-pull-6{position:relative;right:50%;left:auto}.medium-push-7{position:relative;left:58.33333%;right:auto}.medium-pull-7{position:relative;right:58.33333%;left:auto}.medium-push-8{position:relative;left:66.66667%;right:auto}.medium-pull-8{position:relative;right:66.66667%;left:auto}.medium-push-9{position:relative;left:75%;right:auto}.medium-pull-9{position:relative;right:75%;left:auto}.medium-push-10{position:relative;left:83.33333%;right:auto}.medium-pull-10{position:relative;right:83.33333%;left:auto}.medium-push-11{position:relative;left:91.66667%;right:auto}.medium-pull-11{position:relative;right:91.66667%;left:auto}.column,.columns{position:relative;padding-left:0.9375em;padding-right:0.9375em;float:left}.medium-1{width:8.33333%}.medium-2{width:16.66667%}.medium-3{width:25%}.medium-4{width:33.33333%}.medium-5{width:41.66667%}.medium-6{width:50%}.medium-7{width:58.33333%}.medium-8{width:66.66667%}.medium-9{width:75%}.medium-10{width:83.33333%}.medium-11{width:91.66667%}.medium-12{width:100%}.medium-offset-0{margin-left:0% !important}.medium-offset-1{margin-left:8.33333% !important}.medium-offset-2{margin-left:16.66667% !important}.medium-offset-3{margin-left:25% !important}.medium-offset-4{margin-left:33.33333% !important}.medium-offset-5{margin-left:41.66667% !important}.medium-offset-6{margin-left:50% !important}.medium-offset-7{margin-left:58.33333% !important}.medium-offset-8{margin-left:66.66667% !important}.medium-offset-9{margin-left:75% !important}.medium-offset-10{margin-left:83.33333% !important}.medium-offset-11{margin-left:91.66667% !important}.medium-reset-order{margin-left:0;margin-right:0;left:auto;right:auto;float:left}.column.medium-centered,.columns.medium-centered{margin-left:auto;margin-right:auto;float:none}.column.medium-uncentered,.columns.medium-uncentered{margin-left:0;margin-right:0;float:left}.column.medium-centered:last-child,.columns.medium-centered:last-child{float:none}.column.medium-uncentered:last-child,.columns.medium-uncentered:last-child{float:left}.column.medium-uncentered.opposite,.columns.medium-uncentered.opposite{float:right}.row.medium-collapse>.column,.row.medium-collapse>.columns{padding-left:0;padding-right:0}.row.medium-collapse .row{margin-left:0;margin-right:0}.row.medium-uncollapse>.column,.row.medium-uncollapse>.columns{padding-left:0.9375em;padding-right:0.9375em;float:left}.push-0{position:relative;left:0%;right:auto}.pull-0{position:relative;right:0%;left:auto}.push-1{position:relative;left:8.33333%;right:auto}.pull-1{position:relative;right:8.33333%;left:auto}.push-2{position:relative;left:16.66667%;right:auto}.pull-2{position:relative;right:16.66667%;left:auto}.push-3{position:relative;left:25%;right:auto}.pull-3{position:relative;right:25%;left:auto}.push-4{position:relative;left:33.33333%;right:auto}.pull-4{position:relative;right:33.33333%;left:auto}.push-5{position:relative;left:41.66667%;right:auto}.pull-5{position:relative;right:41.66667%;left:auto}.push-6{position:relative;left:50%;right:auto}.pull-6{position:relative;right:50%;left:auto}.push-7{position:relative;left:58.33333%;right:auto}.pull-7{position:relative;right:58.33333%;left:auto}.push-8{position:relative;left:66.66667%;right:auto}.pull-8{position:relative;right:66.66667%;left:auto}.push-9{position:relative;left:75%;right:auto}.pull-9{position:relative;right:75%;left:auto}.push-10{position:relative;left:83.33333%;right:auto}.pull-10{position:relative;right:83.33333%;left:auto}.push-11{position:relative;left:91.66667%;right:auto}.pull-11{position:relative;right:91.66667%;left:auto}}@media only screen and (min-width: 64.063em){.large-push-0{position:relative;left:0%;right:auto}.large-pull-0{position:relative;right:0%;left:auto}.large-push-1{position:relative;left:8.33333%;right:auto}.large-pull-1{position:relative;right:8.33333%;left:auto}.large-push-2{position:relative;left:16.66667%;right:auto}.large-pull-2{position:relative;right:16.66667%;left:auto}.large-push-3{position:relative;left:25%;right:auto}.large-pull-3{position:relative;right:25%;left:auto}.large-push-4{position:relative;left:33.33333%;right:auto}.large-pull-4{position:relative;right:33.33333%;left:auto}.large-push-5{position:relative;left:41.66667%;right:auto}.large-pull-5{position:relative;right:41.66667%;left:auto}.large-push-6{position:relative;left:50%;right:auto}.large-pull-6{position:relative;right:50%;left:auto}.large-push-7{position:relative;left:58.33333%;right:auto}.large-pull-7{position:relative;right:58.33333%;left:auto}.large-push-8{position:relative;left:66.66667%;right:auto}.large-pull-8{position:relative;right:66.66667%;left:auto}.large-push-9{position:relative;left:75%;right:auto}.large-pull-9{position:relative;right:75%;left:auto}.large-push-10{position:relative;left:83.33333%;right:auto}.large-pull-10{position:relative;right:83.33333%;left:auto}.large-push-11{position:relative;left:91.66667%;right:auto}.large-pull-11{position:relative;right:91.66667%;left:auto}.column,.columns{position:relative;padding-left:0.9375em;padding-right:0.9375em;float:left}.large-1{width:8.33333%}.large-2{width:16.66667%}.large-3{width:25%}.large-4{width:33.33333%}.large-5{width:41.66667%}.large-6{width:50%}.large-7{width:58.33333%}.large-8{width:66.66667%}.large-9{width:75%}.large-10{width:83.33333%}.large-11{width:91.66667%}.large-12{width:100%}.large-offset-0{margin-left:0% !important}.large-offset-1{margin-left:8.33333% !important}.large-offset-2{margin-left:16.66667% !important}.large-offset-3{margin-left:25% !important}.large-offset-4{margin-left:33.33333% !important}.large-offset-5{margin-left:41.66667% !important}.large-offset-6{margin-left:50% !important}.large-offset-7{margin-left:58.33333% !important}.large-offset-8{margin-left:66.66667% !important}.large-offset-9{margin-left:75% !important}.large-offset-10{margin-left:83.33333% !important}.large-offset-11{margin-left:91.66667% !important}.large-reset-order{margin-left:0;margin-right:0;left:auto;right:auto;float:left}.column.large-centered,.columns.large-centered{margin-left:auto;margin-right:auto;float:none}.column.large-uncentered,.columns.large-uncentered{margin-left:0;margin-right:0;float:left}.column.large-centered:last-child,.columns.large-centered:last-child{float:none}.column.large-uncentered:last-child,.columns.large-uncentered:last-child{float:left}.column.large-uncentered.opposite,.columns.large-uncentered.opposite{float:right}.row.large-collapse>.column,.row.large-collapse>.columns{padding-left:0;padding-right:0}.row.large-collapse .row{margin-left:0;margin-right:0}.row.large-uncollapse>.column,.row.large-uncollapse>.columns{padding-left:0.9375em;padding-right:0.9375em;float:left}.push-0{position:relative;left:0%;right:auto}.pull-0{position:relative;right:0%;left:auto}.push-1{position:relative;left:8.33333%;right:auto}.pull-1{position:relative;right:8.33333%;left:auto}.push-2{position:relative;left:16.66667%;right:auto}.pull-2{position:relative;right:16.66667%;left:auto}.push-3{position:relative;left:25%;right:auto}.pull-3{position:relative;right:25%;left:auto}.push-4{position:relative;left:33.33333%;right:auto}.pull-4{position:relative;right:33.33333%;left:auto}.push-5{position:relative;left:41.66667%;right:auto}.pull-5{position:relative;right:41.66667%;left:auto}.push-6{position:relative;left:50%;right:auto}.pull-6{position:relative;right:50%;left:auto}.push-7{position:relative;left:58.33333%;right:auto}.pull-7{position:relative;right:58.33333%;left:auto}.push-8{position:relative;left:66.66667%;right:auto}.pull-8{position:relative;right:66.66667%;left:auto}.push-9{position:relative;left:75%;right:auto}.pull-9{position:relative;right:75%;left:auto}.push-10{position:relative;left:83.33333%;right:auto}.pull-10{position:relative;right:83.33333%;left:auto}.push-11{position:relative;left:91.66667%;right:auto}.pull-11{position:relative;right:91.66667%;left:auto}}.dropdown.button,button.dropdown{position:relative;outline:none;padding-right:3.5625rem}.dropdown.button::after,button.dropdown::after{position:absolute;content:"";width:0;height:0;display:block;border-style:solid;border-color:#fff transparent transparent transparent;top:50%}.dropdown.button::after,button.dropdown::after{border-width:0.375rem;right:1.40625rem;margin-top:-0.15625rem}.dropdown.button::after,button.dropdown::after{border-color:#fff transparent transparent transparent}.dropdown.button.tiny,button.dropdown.tiny{padding-right:2.625rem}.dropdown.button.tiny:after,button.dropdown.tiny:after{border-width:0.375rem;right:1.125rem;margin-top:-0.125rem}.dropdown.button.tiny::after,button.dropdown.tiny::after{border-color:#fff transparent transparent transparent}.dropdown.button.small,button.dropdown.small{padding-right:3.0625rem}.dropdown.button.small::after,button.dropdown.small::after{border-width:0.4375rem;right:1.3125rem;margin-top:-0.15625rem}.dropdown.button.small::after,button.dropdown.small::after{border-color:#fff transparent transparent transparent}.dropdown.button.large,button.dropdown.large{padding-right:3.625rem}.dropdown.button.large::after,button.dropdown.large::after{border-width:0.3125rem;right:1.71875rem;margin-top:-0.15625rem}.dropdown.button.large::after,button.dropdown.large::after{border-color:#fff transparent transparent transparent}.dropdown.button.secondary:after,button.dropdown.secondary:after{border-color:#333 transparent transparent transparent}.sub-nav{display:block;width:auto;overflow:hidden;margin-bottom:-0.25rem 0 1.125rem;padding-top:0.25rem}.sub-nav dt{text-transform:uppercase}.sub-nav dt,.sub-nav dd,.sub-nav li{float:left;margin-left:1rem;margin-bottom:0;font-family:"Helvetica Neue",Helvetica,Roboto,Arial,sans-serif;font-weight:normal;font-size:0.875rem;color:#999}.sub-nav dt a,.sub-nav dd a,.sub-nav li a{text-decoration:none;color:#999;padding:0.1875rem 1rem}.sub-nav dt a:hover,.sub-nav dd a:hover,.sub-nav li a:hover{color:#737373}.sub-nav dt.active a,.sub-nav dd.active a,.sub-nav li.active a{border-radius:3px;font-weight:normal;background:#2ba6cb;padding:0.1875rem 1rem;cursor:default;color:#fff}.sub-nav dt.active a:hover,.sub-nav dd.active a:hover,.sub-nav li.active a:hover{background:#258faf} 2 | -------------------------------------------------------------------------------- /resources/css/normalize.css: -------------------------------------------------------------------------------- 1 | /*! normalize.css v3.0.2 | MIT License | git.io/normalize */ 2 | 3 | /** 4 | * 1. Set default font family to sans-serif. 5 | * 2. Prevent iOS text size adjust after orientation change, without disabling 6 | * user zoom. 7 | */ 8 | 9 | html { 10 | font-family: sans-serif; /* 1 */ 11 | -ms-text-size-adjust: 100%; /* 2 */ 12 | -webkit-text-size-adjust: 100%; /* 2 */ 13 | } 14 | 15 | /** 16 | * Remove default margin. 17 | */ 18 | 19 | body { 20 | margin: 0; 21 | } 22 | 23 | /* HTML5 display definitions 24 | ========================================================================== */ 25 | 26 | /** 27 | * Correct `block` display not defined for any HTML5 element in IE 8/9. 28 | * Correct `block` display not defined for `details` or `summary` in IE 10/11 29 | * and Firefox. 30 | * Correct `block` display not defined for `main` in IE 11. 31 | */ 32 | 33 | article, 34 | aside, 35 | details, 36 | figcaption, 37 | figure, 38 | footer, 39 | header, 40 | hgroup, 41 | main, 42 | menu, 43 | nav, 44 | section, 45 | summary { 46 | display: block; 47 | } 48 | 49 | /** 50 | * 1. Correct `inline-block` display not defined in IE 8/9. 51 | * 2. Normalize vertical alignment of `progress` in Chrome, Firefox, and Opera. 52 | */ 53 | 54 | audio, 55 | canvas, 56 | progress, 57 | video { 58 | display: inline-block; /* 1 */ 59 | vertical-align: baseline; /* 2 */ 60 | } 61 | 62 | /** 63 | * Prevent modern browsers from displaying `audio` without controls. 64 | * Remove excess height in iOS 5 devices. 65 | */ 66 | 67 | audio:not([controls]) { 68 | display: none; 69 | height: 0; 70 | } 71 | 72 | /** 73 | * Address `[hidden]` styling not present in IE 8/9/10. 74 | * Hide the `template` element in IE 8/9/11, Safari, and Firefox < 22. 75 | */ 76 | 77 | [hidden], 78 | template { 79 | display: none; 80 | } 81 | 82 | /* Links 83 | ========================================================================== */ 84 | 85 | /** 86 | * Remove the gray background color from active links in IE 10. 87 | */ 88 | 89 | a { 90 | background-color: transparent; 91 | } 92 | 93 | /** 94 | * Improve readability when focused and also mouse hovered in all browsers. 95 | */ 96 | 97 | a:active, 98 | a:hover { 99 | outline: 0; 100 | } 101 | 102 | /* Text-level semantics 103 | ========================================================================== */ 104 | 105 | /** 106 | * Address styling not present in IE 8/9/10/11, Safari, and Chrome. 107 | */ 108 | 109 | abbr[title] { 110 | border-bottom: 1px dotted; 111 | } 112 | 113 | /** 114 | * Address style set to `bolder` in Firefox 4+, Safari, and Chrome. 115 | */ 116 | 117 | b, 118 | strong { 119 | font-weight: bold; 120 | } 121 | 122 | /** 123 | * Address styling not present in Safari and Chrome. 124 | */ 125 | 126 | dfn { 127 | font-style: italic; 128 | } 129 | 130 | /** 131 | * Address variable `h1` font-size and margin within `section` and `article` 132 | * contexts in Firefox 4+, Safari, and Chrome. 133 | */ 134 | 135 | h1 { 136 | font-size: 2em; 137 | margin: 0.67em 0; 138 | } 139 | 140 | /** 141 | * Address styling not present in IE 8/9. 142 | */ 143 | 144 | mark { 145 | background: #ff0; 146 | color: #000; 147 | } 148 | 149 | /** 150 | * Address inconsistent and variable font size in all browsers. 151 | */ 152 | 153 | small { 154 | font-size: 80%; 155 | } 156 | 157 | /** 158 | * Prevent `sub` and `sup` affecting `line-height` in all browsers. 159 | */ 160 | 161 | sub, 162 | sup { 163 | font-size: 75%; 164 | line-height: 0; 165 | position: relative; 166 | vertical-align: baseline; 167 | } 168 | 169 | sup { 170 | top: -0.5em; 171 | } 172 | 173 | sub { 174 | bottom: -0.25em; 175 | } 176 | 177 | /* Embedded content 178 | ========================================================================== */ 179 | 180 | /** 181 | * Remove border when inside `a` element in IE 8/9/10. 182 | */ 183 | 184 | img { 185 | border: 0; 186 | } 187 | 188 | /** 189 | * Correct overflow not hidden in IE 9/10/11. 190 | */ 191 | 192 | svg:not(:root) { 193 | overflow: hidden; 194 | } 195 | 196 | /* Grouping content 197 | ========================================================================== */ 198 | 199 | /** 200 | * Address margin not present in IE 8/9 and Safari. 201 | */ 202 | 203 | figure { 204 | margin: 1em 40px; 205 | } 206 | 207 | /** 208 | * Address differences between Firefox and other browsers. 209 | */ 210 | 211 | hr { 212 | -moz-box-sizing: content-box; 213 | box-sizing: content-box; 214 | height: 0; 215 | } 216 | 217 | /** 218 | * Contain overflow in all browsers. 219 | */ 220 | 221 | pre { 222 | overflow: auto; 223 | } 224 | 225 | /** 226 | * Address odd `em`-unit font size rendering in all browsers. 227 | */ 228 | 229 | code, 230 | kbd, 231 | pre, 232 | samp { 233 | font-family: monospace, monospace; 234 | font-size: 1em; 235 | } 236 | 237 | /* Forms 238 | ========================================================================== */ 239 | 240 | /** 241 | * Known limitation: by default, Chrome and Safari on OS X allow very limited 242 | * styling of `select`, unless a `border` property is set. 243 | */ 244 | 245 | /** 246 | * 1. Correct color not being inherited. 247 | * Known issue: affects color of disabled elements. 248 | * 2. Correct font properties not being inherited. 249 | * 3. Address margins set differently in Firefox 4+, Safari, and Chrome. 250 | */ 251 | 252 | button, 253 | input, 254 | optgroup, 255 | select, 256 | textarea { 257 | color: inherit; /* 1 */ 258 | font: inherit; /* 2 */ 259 | margin: 0; /* 3 */ 260 | } 261 | 262 | /** 263 | * Address `overflow` set to `hidden` in IE 8/9/10/11. 264 | */ 265 | 266 | button { 267 | overflow: visible; 268 | } 269 | 270 | /** 271 | * Address inconsistent `text-transform` inheritance for `button` and `select`. 272 | * All other form control elements do not inherit `text-transform` values. 273 | * Correct `button` style inheritance in Firefox, IE 8/9/10/11, and Opera. 274 | * Correct `select` style inheritance in Firefox. 275 | */ 276 | 277 | button, 278 | select { 279 | text-transform: none; 280 | } 281 | 282 | /** 283 | * 1. Avoid the WebKit bug in Android 4.0.* where (2) destroys native `audio` 284 | * and `video` controls. 285 | * 2. Correct inability to style clickable `input` types in iOS. 286 | * 3. Improve usability and consistency of cursor style between image-type 287 | * `input` and others. 288 | */ 289 | 290 | button, 291 | html input[type="button"], /* 1 */ 292 | input[type="reset"], 293 | input[type="submit"] { 294 | -webkit-appearance: button; /* 2 */ 295 | cursor: pointer; /* 3 */ 296 | } 297 | 298 | /** 299 | * Re-set default cursor for disabled elements. 300 | */ 301 | 302 | button[disabled], 303 | html input[disabled] { 304 | cursor: default; 305 | } 306 | 307 | /** 308 | * Remove inner padding and border in Firefox 4+. 309 | */ 310 | 311 | button::-moz-focus-inner, 312 | input::-moz-focus-inner { 313 | border: 0; 314 | padding: 0; 315 | } 316 | 317 | /** 318 | * Address Firefox 4+ setting `line-height` on `input` using `!important` in 319 | * the UA stylesheet. 320 | */ 321 | 322 | input { 323 | line-height: normal; 324 | } 325 | 326 | /** 327 | * It's recommended that you don't attempt to style these elements. 328 | * Firefox's implementation doesn't respect box-sizing, padding, or width. 329 | * 330 | * 1. Address box sizing set to `content-box` in IE 8/9/10. 331 | * 2. Remove excess padding in IE 8/9/10. 332 | */ 333 | 334 | input[type="checkbox"], 335 | input[type="radio"] { 336 | box-sizing: border-box; /* 1 */ 337 | padding: 0; /* 2 */ 338 | } 339 | 340 | /** 341 | * Fix the cursor style for Chrome's increment/decrement buttons. For certain 342 | * `font-size` values of the `input`, it causes the cursor style of the 343 | * decrement button to change from `default` to `text`. 344 | */ 345 | 346 | input[type="number"]::-webkit-inner-spin-button, 347 | input[type="number"]::-webkit-outer-spin-button { 348 | height: auto; 349 | } 350 | 351 | /** 352 | * 1. Address `appearance` set to `searchfield` in Safari and Chrome. 353 | * 2. Address `box-sizing` set to `border-box` in Safari and Chrome 354 | * (include `-moz` to future-proof). 355 | */ 356 | 357 | input[type="search"] { 358 | -webkit-appearance: textfield; /* 1 */ 359 | -moz-box-sizing: content-box; 360 | -webkit-box-sizing: content-box; /* 2 */ 361 | box-sizing: content-box; 362 | } 363 | 364 | /** 365 | * Remove inner padding and search cancel button in Safari and Chrome on OS X. 366 | * Safari (but not Chrome) clips the cancel button when the search input has 367 | * padding (and `textfield` appearance). 368 | */ 369 | 370 | input[type="search"]::-webkit-search-cancel-button, 371 | input[type="search"]::-webkit-search-decoration { 372 | -webkit-appearance: none; 373 | } 374 | 375 | /** 376 | * Define consistent border, margin, and padding. 377 | */ 378 | 379 | fieldset { 380 | border: 1px solid #c0c0c0; 381 | margin: 0 2px; 382 | padding: 0.35em 0.625em 0.75em; 383 | } 384 | 385 | /** 386 | * 1. Correct `color` not being inherited in IE 8/9/10/11. 387 | * 2. Remove padding so people aren't caught out if they zero out fieldsets. 388 | */ 389 | 390 | legend { 391 | border: 0; /* 1 */ 392 | padding: 0; /* 2 */ 393 | } 394 | 395 | /** 396 | * Remove default vertical scrollbar in IE 8/9/10/11. 397 | */ 398 | 399 | textarea { 400 | overflow: auto; 401 | } 402 | 403 | /** 404 | * Don't inherit the `font-weight` (applied by a rule above). 405 | * NOTE: the default cannot safely be changed in Chrome and Safari on OS X. 406 | */ 407 | 408 | optgroup { 409 | font-weight: bold; 410 | } 411 | 412 | /* Tables 413 | ========================================================================== */ 414 | 415 | /** 416 | * Remove most spacing between table cells. 417 | */ 418 | 419 | table { 420 | border-collapse: collapse; 421 | border-spacing: 0; 422 | } 423 | 424 | td, 425 | th { 426 | padding: 0; 427 | } 428 | -------------------------------------------------------------------------------- /resources/css/pikaday.css: -------------------------------------------------------------------------------- 1 | @charset "UTF-8"; 2 | 3 | /*! 4 | * Pikaday 5 | * Copyright © 2014 David Bushell | BSD & MIT license | http://dbushell.com/ 6 | */ 7 | 8 | .pika-single { 9 | z-index: 9999; 10 | display: block; 11 | position: relative; 12 | color: #333; 13 | background: #fff; 14 | border: 1px solid #ccc; 15 | border-bottom-color: #bbb; 16 | font-family: "Helvetica Neue", Helvetica, Arial, sans-serif; 17 | } 18 | 19 | /* 20 | clear child float (pika-lendar), using the famous micro clearfix hack 21 | http://nicolasgallagher.com/micro-clearfix-hack/ 22 | */ 23 | .pika-single:before, 24 | .pika-single:after { 25 | content: " "; 26 | display: table; 27 | } 28 | .pika-single:after { clear: both } 29 | .pika-single { *zoom: 1 } 30 | 31 | .pika-single.is-hidden { 32 | display: none; 33 | } 34 | 35 | .pika-single.is-bound { 36 | position: absolute; 37 | box-shadow: 0 5px 15px -5px rgba(0,0,0,.5); 38 | } 39 | 40 | .pika-lendar { 41 | float: left; 42 | width: 240px; 43 | margin: 8px; 44 | } 45 | 46 | .pika-title { 47 | position: relative; 48 | text-align: center; 49 | } 50 | 51 | .pika-label { 52 | display: inline-block; 53 | *display: inline; 54 | position: relative; 55 | z-index: 9999; 56 | overflow: hidden; 57 | margin: 0; 58 | padding: 5px 3px; 59 | font-size: 14px; 60 | line-height: 20px; 61 | font-weight: bold; 62 | background-color: #fff; 63 | } 64 | .pika-title select { 65 | cursor: pointer; 66 | position: absolute; 67 | z-index: 9998; 68 | margin: 0; 69 | left: 0; 70 | top: 5px; 71 | filter: alpha(opacity=0); 72 | opacity: 0; 73 | } 74 | 75 | .pika-prev, 76 | .pika-next { 77 | display: block; 78 | cursor: pointer; 79 | position: relative; 80 | outline: none; 81 | border: 0; 82 | padding: 0; 83 | width: 20px; 84 | height: 30px; 85 | /* hide text using text-indent trick, using width value (it's enough) */ 86 | text-indent: 20px; 87 | white-space: nowrap; 88 | overflow: hidden; 89 | background-color: transparent; 90 | background-position: center center; 91 | background-repeat: no-repeat; 92 | background-size: 75% 75%; 93 | opacity: .5; 94 | *position: absolute; 95 | *top: 0; 96 | } 97 | 98 | .pika-prev:hover, 99 | .pika-next:hover { 100 | opacity: 1; 101 | } 102 | 103 | .pika-prev, 104 | .is-rtl .pika-next { 105 | float: left; 106 | background-image: url('data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAABQAAAAeCAYAAAAsEj5rAAAAUklEQVR42u3VMQoAIBADQf8Pgj+OD9hG2CtONJB2ymQkKe0HbwAP0xucDiQWARITIDEBEnMgMQ8S8+AqBIl6kKgHiXqQqAeJepBo/z38J/U0uAHlaBkBl9I4GwAAAABJRU5ErkJggg=='); 107 | *left: 0; 108 | } 109 | 110 | .pika-next, 111 | .is-rtl .pika-prev { 112 | float: right; 113 | background-image: url('data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAABQAAAAeCAYAAAAsEj5rAAAAU0lEQVR42u3VOwoAMAgE0dwfAnNjU26bYkBCFGwfiL9VVWoO+BJ4Gf3gtsEKKoFBNTCoCAYVwaAiGNQGMUHMkjGbgjk2mIONuXo0nC8XnCf1JXgArVIZAQh5TKYAAAAASUVORK5CYII='); 114 | *right: 0; 115 | } 116 | 117 | .pika-prev.is-disabled, 118 | .pika-next.is-disabled { 119 | cursor: default; 120 | opacity: .2; 121 | } 122 | 123 | .pika-select { 124 | display: inline-block; 125 | *display: inline; 126 | } 127 | 128 | .pika-table { 129 | width: 100%; 130 | border-collapse: collapse; 131 | border-spacing: 0; 132 | border: 0; 133 | } 134 | 135 | .pika-table th, 136 | .pika-table td { 137 | width: 14.285714285714286%; 138 | padding: 0; 139 | } 140 | 141 | .pika-table th { 142 | color: #999; 143 | font-size: 12px; 144 | line-height: 25px; 145 | font-weight: bold; 146 | text-align: center; 147 | } 148 | 149 | .pika-button { 150 | cursor: pointer; 151 | display: block; 152 | box-sizing: border-box; 153 | -moz-box-sizing: border-box; 154 | outline: none; 155 | border: 0; 156 | margin: 0; 157 | width: 100%; 158 | padding: 5px; 159 | color: #666; 160 | font-size: 12px; 161 | line-height: 15px; 162 | text-align: right; 163 | background: #f5f5f5; 164 | } 165 | 166 | .pika-week { 167 | font-size: 11px; 168 | color: #999; 169 | } 170 | 171 | .is-today .pika-button { 172 | color: #33aaff; 173 | font-weight: bold; 174 | } 175 | 176 | .is-selected .pika-button { 177 | color: #fff; 178 | font-weight: bold; 179 | background: #33aaff; 180 | box-shadow: inset 0 1px 3px #178fe5; 181 | border-radius: 3px; 182 | } 183 | 184 | .is-disabled .pika-button { 185 | pointer-events: none; 186 | cursor: default; 187 | color: #999; 188 | opacity: .3; 189 | } 190 | 191 | .pika-button:hover { 192 | color: #fff !important; 193 | background: #ff8000 !important; 194 | box-shadow: none !important; 195 | border-radius: 3px !important; 196 | } 197 | 198 | /* styling for abbr */ 199 | .pika-table abbr { 200 | border-bottom: none; 201 | cursor: help; 202 | } 203 | 204 | -------------------------------------------------------------------------------- /resources/ico/ck-alert.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/talex5/cuekeeper/1e525d0748fb43f21cf52bcdedb6823893c22244/resources/ico/ck-alert.ico -------------------------------------------------------------------------------- /resources/ico/ck.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/talex5/cuekeeper/1e525d0748fb43f21cf52bcdedb6823893c22244/resources/ico/ck.ico -------------------------------------------------------------------------------- /resources/js/vendor/FileSaver.min.js: -------------------------------------------------------------------------------- 1 | /*! @source http://purl.eligrey.com/github/FileSaver.js/blob/master/FileSaver.js */ 2 | var saveAs=saveAs||"undefined"!=typeof navigator&&navigator.msSaveOrOpenBlob&&navigator.msSaveOrOpenBlob.bind(navigator)||function(e){"use strict";if("undefined"==typeof navigator||!/MSIE [1-9]\./.test(navigator.userAgent)){var t=e.document,n=function(){return e.URL||e.webkitURL||e},o=t.createElementNS("http://www.w3.org/1999/xhtml","a"),r="download"in o,i=function(n){var o=t.createEvent("MouseEvents");o.initMouseEvent("click",!0,!1,e,0,0,0,0,0,!1,!1,!1,!1,0,null),n.dispatchEvent(o)},a=e.webkitRequestFileSystem,c=e.requestFileSystem||a||e.mozRequestFileSystem,s=function(t){(e.setImmediate||e.setTimeout)(function(){throw t},0)},u="application/octet-stream",f=0,d=500,l=function(t){var o=function(){"string"==typeof t?n().revokeObjectURL(t):t.remove()};e.chrome?o():setTimeout(o,d)},v=function(e,t,n){t=[].concat(t);for(var o=t.length;o--;){var r=e["on"+t[o]];if("function"==typeof r)try{r.call(e,n||e)}catch(i){s(i)}}},p=function(t,s){var d,p,w,y=this,m=t.type,S=!1,h=function(){v(y,"writestart progress write writeend".split(" "))},O=function(){if((S||!d)&&(d=n().createObjectURL(t)),p)p.location.href=d;else{var o=e.open(d,"_blank");void 0==o&&"undefined"!=typeof safari&&(e.location.href=d)}y.readyState=y.DONE,h(),l(d)},b=function(e){return function(){return y.readyState!==y.DONE?e.apply(this,arguments):void 0}},g={create:!0,exclusive:!1};return y.readyState=y.INIT,s||(s="download"),r?(d=n().createObjectURL(t),o.href=d,o.download=s,i(o),y.readyState=y.DONE,h(),void l(d)):(/^\s*(?:text\/(?:plain|xml)|application\/xml|\S*\/\S*\+xml)\s*;.*charset\s*=\s*utf-8/i.test(t.type)&&(t=new Blob(["",t],{type:t.type})),e.chrome&&m&&m!==u&&(w=t.slice||t.webkitSlice,t=w.call(t,0,t.size,u),S=!0),a&&"download"!==s&&(s+=".download"),(m===u||a)&&(p=e),c?(f+=t.size,void c(e.TEMPORARY,f,b(function(e){e.root.getDirectory("saved",g,b(function(e){var n=function(){e.getFile(s,g,b(function(e){e.createWriter(b(function(n){n.onwriteend=function(t){p.location.href=e.toURL(),y.readyState=y.DONE,v(y,"writeend",t),l(e)},n.onerror=function(){var e=n.error;e.code!==e.ABORT_ERR&&O()},"writestart progress write abort".split(" ").forEach(function(e){n["on"+e]=y["on"+e]}),n.write(t),y.abort=function(){n.abort(),y.readyState=y.DONE},y.readyState=y.WRITING}),O)}),O)};e.getFile(s,{create:!1},b(function(e){e.remove(),n()}),b(function(e){e.code===e.NOT_FOUND_ERR?n():O()}))}),O)}),O)):void O())},w=p.prototype,y=function(e,t){return new p(e,t)};return w.abort=function(){var e=this;e.readyState=e.DONE,v(e,"abort")},w.readyState=w.INIT=0,w.WRITING=1,w.DONE=2,w.error=w.onwritestart=w.onprogress=w.onwrite=w.onabort=w.onerror=w.onwriteend=null,y}}("undefined"!=typeof self&&self||"undefined"!=typeof window&&window||this.content);"undefined"!=typeof module&&module.exports?module.exports.saveAs=saveAs:"undefined"!=typeof define&&null!==define&&null!=define.amd&&define([],function(){return saveAs}); -------------------------------------------------------------------------------- /server/.gitignore: -------------------------------------------------------------------------------- 1 | conf 2 | -------------------------------------------------------------------------------- /server/devices.ml: -------------------------------------------------------------------------------- 1 | module M = Map.Make(String) 2 | 3 | type t = string M.t 4 | 5 | let of_file path = 6 | let ch = open_in path in 7 | let t = ref M.empty in 8 | try 9 | while true do 10 | match String.trim (input_line ch) with 11 | | "" -> () 12 | | line -> 13 | let i = String.index line ' ' in 14 | let hash = String.sub line 0 i in 15 | let label = String.sub line (i + 1) (String.length line - i - 1) in 16 | t := M.add hash label !t 17 | done; 18 | assert false 19 | with End_of_file -> 20 | close_in ch; 21 | !t 22 | 23 | let lookup t hash = M.find_opt hash t 24 | -------------------------------------------------------------------------------- /server/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name cuekeeper) 4 | (libraries lwt.unix cohttp-lwt-unix irmin-git irmin.mem logs.fmt re cmdliner)) 5 | -------------------------------------------------------------------------------- /server/main.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2025, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Lwt.Infix 5 | 6 | let src = Logs.Src.create "cuekeeper-server" ~doc:"CueKeeper server" 7 | module Log = (val Logs.src_log src : Logs.LOG) 8 | 9 | let port = 8443 10 | 11 | module No_sync (G : Git.S) = struct 12 | (* We don't use Git's sync, but it requires us to provide this module anyway. 13 | From [Irmin_git], but not exposed. *) 14 | 15 | type hash = G.hash 16 | type store = G.t 17 | 18 | type error = 19 | [ `Not_found | `Msg of string | `Exn of exn | `Cycle | `Invalid_flow ] 20 | 21 | let pp_error _ _ = assert false 22 | 23 | let fetch ?push_stdout:_ ?push_stderr:_ ?threads:_ ~ctx:_ _ _ ?version:_ 24 | ?capabilities:_ ?deepen:_ _ = 25 | assert false 26 | 27 | let push ~ctx:_ _ _ ?version:_ ?capabilities:_ _ = assert false 28 | end 29 | 30 | module Store = Irmin_git.Make(Irmin_git.Mem)(No_sync(Irmin_git.Mem)) 31 | (Irmin.Contents.String)(Irmin.Path.String_list)(Irmin.Branch.String) 32 | 33 | module Http_server = Cohttp_lwt_unix.Server 34 | 35 | module Server = Server.Make(Store)(Http_server) 36 | 37 | (* We store the hash rather than the original to avoid storing the secret. *) 38 | let user_of_token devices token = 39 | let hashed = Digestif.SHA256.digest_string token |> Digestif.SHA256.to_hex in 40 | let device = Devices.lookup devices hashed in 41 | if device = None then Log.warn (fun f -> f "Invalid access token used (hash = %S)" hashed); 42 | device 43 | 44 | let handle_request ~server ~devices s conn_id request body = 45 | (* Instead of handing the Git store directly to [Server.handle_request], wrap it in a function 46 | * that authenticates the request first, so it can't use it without checking. *) 47 | let get_db () = 48 | let uri = Cohttp.Request.uri request in 49 | match Uri.get_query_param uri "token" with 50 | | None -> Error (Http_server.respond_error ~status:`Bad_request ~body:"Missing access token" ()) 51 | | Some token -> 52 | match user_of_token devices token with 53 | | None -> Error (Http_server.respond_error ~status:`Unauthorized ~body:"Invalid access token" ()) 54 | | Some user -> 55 | Log.info (fun f -> f "Handling request for %S" user); 56 | Ok s in 57 | Server.handle_request server get_db conn_id request body 58 | 59 | let main devices_file static_files tls_dir = 60 | let devices = Devices.of_file devices_file in 61 | let server = Server.make ~static_files in 62 | Lwt_main.run begin 63 | Store.Repo.v (Irmin_mem.config ()) >>= Store.master >>= fun s -> 64 | let mode = 65 | `TLS ( 66 | `Crt_file_path (Filename.concat tls_dir "server.pem"), 67 | `Key_file_path (Filename.concat tls_dir "server.key"), `No_password, 68 | `Port port 69 | ) 70 | in 71 | Log.app (fun f -> f "Server available at https://127.0.0.1:%d" port); 72 | Http_server.create ~mode (Http_server.make ~callback:(handle_request ~server ~devices s) ()) 73 | end 74 | 75 | open Cmdliner 76 | 77 | let ( $ ) = Term.( $ ) 78 | 79 | let devices = 80 | let doc = "List of devices, one per line in the form: SHA1 LABEL" in 81 | Arg.(required @@ opt (some file) None @@ info ["devices"] ~docv:"DEVICES" ~doc) 82 | 83 | let static_files = 84 | let doc = "Directory with the JavaScript and other resources" in 85 | Arg.(value @@ opt dir "_build/static" @@ info ["static-files"] ~docv:"DIR" ~doc) 86 | 87 | let tls_config = 88 | let doc = "Directory with the server.pem" in 89 | Arg.(value @@ opt dir "server/conf" @@ info ["tls-config"] ~docv:"DIR" ~doc) 90 | 91 | let cmd = Term.const main $ devices $ static_files $ tls_config 92 | 93 | let () = 94 | Logs.set_level (Some Info); 95 | Logs.set_reporter (Logs_fmt.reporter ()); 96 | let info = Cmd.info "cuekeeper" in 97 | exit (Cmd.eval @@ Cmd.v info cmd) 98 | -------------------------------------------------------------------------------- /server/server.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Lwt.Infix 5 | 6 | let src = Logs.Src.create "cuekeeper" ~doc:"CueKeeper server" 7 | module Log = (val Logs.src_log src : Logs.LOG) 8 | 9 | let load path = 10 | let ch = open_in_bin path in 11 | let len = in_channel_length ch in 12 | let data = really_input_string ch len in 13 | close_in ch; 14 | data 15 | 16 | let resource_paths = [ 17 | "index.html"; 18 | "resources/cache.manifest"; 19 | "resources/css/foundation.css"; 20 | "resources/css/foundation.min.css"; 21 | "resources/css/normalize.css"; 22 | "resources/css/pikaday.css"; 23 | "resources/css/style.css"; 24 | "resources/ico/ck-alert.ico"; 25 | "resources/ico/ck.ico"; 26 | "resources/js/cuekeeper.js"; 27 | "resources/js/vendor"; 28 | "resources/js/vendor/FileSaver.min.js"; 29 | "resources/js/vendor/pikaday.js"; 30 | ] 31 | 32 | module Make (Store:Irmin.S with type branch = string and type hash = Digestif.SHA1.t) (S:Cohttp_lwt.S.Server) = struct 33 | type t = { 34 | static_files : string; 35 | } 36 | 37 | let make ~static_files = { static_files } 38 | 39 | let bundle_t = Irmin.Type.pair Store.Private.Slice.t Store.Hash.t 40 | 41 | let show_head = function 42 | | None -> "(none)" 43 | | Some head -> String.sub (Fmt.to_to_string Store.Commit.pp_hash head) 0 6 44 | 45 | let respond_static t segments = 46 | let path = String.concat "/" segments in 47 | if List.mem path resource_paths then ( 48 | let body = load (Filename.concat t.static_files path) in 49 | let headers = 50 | if Filename.check_suffix path ".html" then 51 | Cohttp.Header.init_with "Content-Type" "text/html" 52 | else if Filename.check_suffix path ".manifest" then 53 | Cohttp.Header.init_with "Content-Type" "text/cache-manifest" 54 | else 55 | Cohttp.Header.init () in 56 | S.respond_string ~headers ~status:`OK ~body () 57 | ) else S.respond_not_found () 58 | 59 | (* Split a URI into a list of path segments *) 60 | let split_path uri = 61 | let path = Uri.path uri in 62 | let rec aux = function 63 | | [] | [""] -> [] 64 | | hd::tl -> hd :: aux tl 65 | in 66 | List.filter (fun e -> e <> "") 67 | (aux (Re.Str.(split_delim (regexp_string "/") path))) 68 | 69 | let hash_equal = Irmin.Type.unstage (Irmin.Type.equal Store.Hash.t) 70 | 71 | (* Import bundle from client into store. *) 72 | let accept_push s body = 73 | let headers = Cohttp.Header.init_with "Content-Type" "application/octet-stream" in 74 | match s () with 75 | | Error resp -> resp 76 | | Ok s -> 77 | Cohttp_lwt.Body.to_string body >>= fun body -> 78 | let decoder = Jsonm.decoder (`String body) in 79 | match Irmin.Type.decode_json bundle_t decoder with 80 | | Error (`Msg m) -> 81 | let msg = Fmt.str "Failed to decode slice JSON: %s" m in 82 | Log.warn (fun f -> f "%s" msg); 83 | S.respond_string ~headers ~status:`Bad_request ~body:msg () 84 | | Ok (slice, head) -> 85 | Store.Head.find s >>= function 86 | | Some server_head when hash_equal (Store.Commit.hash server_head) head -> 87 | S.respond_string ~headers ~status:`OK ~body:"ok" () 88 | | server_head -> 89 | Store.Repo.import (Store.repo s) slice >>= function 90 | | Error (`Msg m) -> 91 | let msg = Fmt.str "Failed to import slice: %s" m in 92 | Log.warn (fun f -> f "%s" msg); 93 | S.respond_string ~headers ~status:`Bad_request ~body:msg () 94 | | Ok () -> 95 | Store.Commit.of_hash (Store.repo s) head >>= function 96 | | None -> 97 | let msg = "New head not found after import!" in 98 | Log.warn (fun f -> f "%s" msg); 99 | S.respond_string ~headers ~status:`Bad_request ~body:msg () 100 | | Some head -> 101 | Store.Head.fast_forward s head >>= function 102 | | Error (`Max_depth_reached | `Too_many_lcas) -> assert false 103 | | Error `Rejected -> 104 | let msg = Printf.sprintf "Non-fast-forward push attempted: %s -> %s" 105 | (show_head server_head) (show_head (Some head)) in 106 | Log.warn (fun f -> f "%s" msg); 107 | S.respond_string ~headers ~status:`OK ~body:"not-fast-forward" () 108 | | Ok () | Error `No_change -> 109 | Log.info (fun f -> f "Update master %s -> %s" (show_head server_head) (show_head (Some head))); 110 | S.respond_string ~headers ~status:`OK ~body:"ok" () 111 | 112 | (* Export changes in the store since [last_known] to a bundle for the client. *) 113 | let fetch s last_known = 114 | let headers = Cohttp.Header.init_with "Content-Type" "application/octet-stream" in 115 | match s () with 116 | | Error resp -> resp 117 | | Ok s -> 118 | Store.Head.find s >>= function 119 | | None -> S.respond_string ~headers ~status:`OK ~body:"" () 120 | | Some head -> 121 | begin match last_known with 122 | | None -> Lwt.return [] 123 | | Some c -> 124 | Store.Commit.of_hash (Store.repo s) c >|= function 125 | | None -> [] 126 | | Some c -> [c] 127 | end >>= fun basis -> 128 | Store.Repo.export (Store.repo s) ~min:basis ~max:(`Max [head]) >>= fun slice -> 129 | let b = Buffer.create 10240 in 130 | let encoder = Jsonm.encoder ~minify:true (`Buffer b) in 131 | Irmin.Type.encode_json bundle_t encoder (slice, Store.Commit.hash head); 132 | ignore @@ Jsonm.encode encoder `End; 133 | let body = Buffer.contents b in 134 | S.respond_string ~headers ~status:`OK ~body () 135 | 136 | let handle_request t s (_io_conn, http_conn) request body = 137 | Lwt.catch (fun () -> 138 | let uri = Cohttp.Request.uri request in 139 | Log.info (fun f -> f "%s: %s %s" 140 | (Cohttp.Connection.to_string http_conn) 141 | (Cohttp.Request.meth request |> Cohttp.Code.string_of_method) 142 | (Uri.to_string uri)); 143 | match Cohttp.Request.meth request, split_path uri with 144 | | `GET, ["fetch"] -> fetch s None 145 | | `GET, ["fetch"; last_known] -> 146 | begin match Irmin.Type.of_string Store.Hash.t last_known with 147 | | Ok hash -> fetch s (Some hash) 148 | | Error (`Msg m) -> 149 | Log.warn (fun f -> f "Invalid hash %S: %s" last_known m); 150 | S.respond_error ~status:`Bad_request ~body:"Invalid hash" () 151 | end 152 | | `POST, ["push"] -> accept_push s body 153 | | `GET, ([] | [""]) -> respond_static t ["index.html"] 154 | | `GET, segments -> respond_static t segments 155 | | _ -> S.respond_error ~status:`Method_not_allowed ~body:"Invalid request" () 156 | ) (fun ex -> 157 | Log.warn (fun f -> f "Unhandled exception processing HTTP request: %s" (Printexc.to_string ex)); 158 | Lwt.fail ex 159 | ) 160 | end 161 | -------------------------------------------------------------------------------- /test.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | CueKeeper 13 | 14 | 15 |
16 | 17 | 18 | 19 | 20 | 21 | 22 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (modes byte) 4 | (libraries cuekeeper lwt.unix oUnit irmin fmt.tty logs.fmt irmin.mem cohttp-lwt-unix)) 5 | -------------------------------------------------------------------------------- /tests/server.ml: -------------------------------------------------------------------------------- 1 | ../server/server.ml -------------------------------------------------------------------------------- /tests/static.ml: -------------------------------------------------------------------------------- 1 | let read path = 2 | Some ("contents of " ^ path) 3 | -------------------------------------------------------------------------------- /tests/test_net.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2015, Thomas Leonard 2 | * See the README file for details. *) 3 | 4 | open Lwt.Infix 5 | 6 | let client = Logs.Src.create "client-net" ~doc:"CueKeeper test client" 7 | module Client_log = (val Logs.src_log client : Logs.LOG) 8 | 9 | let server = Logs.Src.create "server-net" ~doc:"CueKeeper test server" 10 | module Server_log = (val Logs.src_log server : Logs.LOG) 11 | 12 | module Make(Clock : Ck_clock.S) = struct 13 | type listener = (ic:Lwt_io.input_channel -> oc:Lwt_io.output_channel -> unit) 14 | let ignore_listener : listener = fun ~ic:_ ~oc:_ -> () 15 | let listener = ref ignore_listener 16 | 17 | module Test_network(Log : Logs.LOG) = struct 18 | type error = unit 19 | let pp_error f () = Format.pp_print_string f "error" 20 | 21 | module IO = struct 22 | include Lwt 23 | 24 | type error = unit 25 | let pp_error f () = Format.pp_print_string f "IO error" 26 | 27 | type ic = Lwt_io.input_channel 28 | type oc = Lwt_io.output_channel 29 | type conn = unit 30 | 31 | let iter = Lwt_list.iter_s 32 | let flush = Lwt_io.flush 33 | 34 | let read ic n = 35 | Lwt_io.read ~count:n ic >|= fun d -> 36 | Log.debug (fun f -> f "<<< %S" d); 37 | d 38 | 39 | let read_line ic = 40 | Lwt.catch 41 | (fun () -> Lwt_io.read_line ic >|= fun line -> 42 | Log.info (fun f -> f "<<< %S" line); 43 | Some line 44 | ) 45 | (function 46 | | End_of_file -> Lwt.return None 47 | | ex -> raise ex 48 | ) 49 | let write = Lwt_io.write 50 | 51 | let catch f = f () >|= fun x -> Ok x 52 | end 53 | 54 | type ctx = unit 55 | 56 | let sexp_of_ctx _ = failwith "sexp_of_ctx" 57 | let default_ctx = () 58 | let close_in ch = Lwt.async (fun () -> Lwt_io.close ch) 59 | let close_out ch = Lwt.async (fun () -> Lwt_io.close ch) 60 | let close ic oc = 61 | close_in ic; 62 | close_out oc 63 | 64 | let connect_uri ~ctx:_ uri = 65 | Log.info (fun f -> f "connect(%a)" Uri.pp uri); 66 | let ic_req, oc_req = Lwt_io.pipe () in 67 | let ic_resp, oc_resp = Lwt_io.pipe () in 68 | !listener ~ic:ic_req ~oc:oc_resp; 69 | Lwt.return ((), ic_resp, oc_req) 70 | end 71 | 72 | module CNet = Test_network(Client_log) 73 | module SNet = Test_network(Server_log) 74 | 75 | module Server = Cohttp_lwt.Make_server(SNet.IO) 76 | module Client = struct 77 | module C = Cohttp_lwt.Make_client(CNet.IO)(CNet) 78 | let get ?headers uri = C.get ?headers uri >|= fun r -> `Ok r 79 | let post ?body ?headers uri = C.post ?body ?headers uri >|= fun r -> `Ok r 80 | end 81 | end 82 | --------------------------------------------------------------------------------