├── .gitignore ├── .hgignore ├── .vscode └── tasks.json ├── Makefile ├── NOTES.org ├── README.org ├── TODO.org ├── exercises ├── Makefile ├── ex1.ml ├── ex2.ml ├── ex3.ml ├── ex4.ml ├── ex5.ml ├── ex6.ml ├── import.ml ├── jbuild └── main.ml ├── jbuild-workspace.here ├── shared ├── Makefile ├── command_common.ml ├── command_common.mli ├── generator.ml ├── generator.mli ├── import.ml ├── jbuild ├── protocol.ml ├── server.ml ├── server.mli ├── state.ml ├── state.mli ├── tutorial_shared.ml ├── viewer.ml └── viewer.mli └── solutions ├── Makefile ├── ex1.ml ├── ex2.ml ├── ex3.ml ├── ex4.ml ├── ex5.ml ├── ex6.ml ├── generic_flatten.ml ├── import.ml ├── jbuild ├── main.ml └── scratch.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | .merlin 3 | -------------------------------------------------------------------------------- /.hgignore: -------------------------------------------------------------------------------- 1 | syntax: glob 2 | *~ 3 | _build 4 | \#*\# 5 | .\#* 6 | *.orig 7 | .merlin -------------------------------------------------------------------------------- /.vscode/tasks.json: -------------------------------------------------------------------------------- 1 | { 2 | // See https://go.microsoft.com/fwlink/?LinkId=733558 3 | // for the documentation about the tasks.json format 4 | "version": "2.0.0", 5 | "tasks": [ 6 | { 7 | "taskName": "build", 8 | "command": "jbuilder build protocol.bc --dev", 9 | "type": "shell" 10 | } 11 | ] 12 | } -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all 2 | all: 3 | @jbuilder build --dev solutions/main.exe exercises/main.exe 4 | -------------------------------------------------------------------------------- /NOTES.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Tutorial Notes 2 | 3 | * Problems 4 | 5 | - start with something that doesn't require maps; say, a small 6 | fixed universe of hosts. This isn't going to use incremental in 7 | an especially interesting way, but it's a good place to start. 8 | 9 | - Maybe even have an open universe of hosts, but have part of the 10 | query be to select which hosts you actually look at. That's 11 | static enough to avoid maps. You'll need an imperatively managed 12 | table of data on the outside, though. 13 | 14 | - Various queries to push the model more, in particular: 15 | 16 | - find set of checks of a certain kind that failed (filter_map) 17 | 18 | - find set of stale nodes (clock + filter_map') 19 | 20 | - Rank queries? (nth-worst host?, median host?) 21 | 22 | - Merging examples? Drop rates on hosts with most highly loaded 23 | switches? 24 | 25 | * Other Thoughts 26 | 27 | - Benchmarks! Make sure that we have all-at-once computations for each 28 | of these. 29 | 30 | * Next Steps 31 | 32 | - Talk to Dlo and Perl about useful queries to implement. 33 | 34 | 35 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | #+TITLE: On-line Applications with Incremental 2 | 3 | This repo is the basis of a tutorial that was given at CUFP 2017. The 4 | tutorial shows you how to use Incremental, a library for building 5 | efficient on-line algorithms, for writing a simple monitoring system, 6 | similar in spirit to NagiOS. 7 | 8 | The repo is organized into three directories: 9 | 10 | - /shared/, containing a library to be used in writing tutorial 11 | examples. This provides the basic data model for our monitoring 12 | application, a server which will provide the data, and a basic 13 | non-incremental client for displaying views of that data stream. 14 | 15 | - /exercises/, which contains exercise descriptions, and is where 16 | you'll develop your own solutions. 17 | 18 | - /solutions/, similar to exercises, but containing our answers to the 19 | problems. 20 | 21 | In order to complete the tutorial, there are some opam packages you'll 22 | need to install; in particular: 23 | 24 | - async 25 | - incremental 26 | - sexp_pretty 27 | - incr_map 28 | 29 | You'll also probably benefit from having these packages installed, 30 | though they're not strictly necessary: 31 | 32 | - ocp-indent 33 | - merlin 34 | - utop 35 | 36 | A final note: if you don't have an editor that's nicely set up to work 37 | with OCaml, we recommend Visual Studio Code, which is quite easy to 38 | set up. In particular, Merlin and ocp-indent work correctly pretty 39 | much out of the box. Having good auto-completion and type-throwback 40 | will make this tutorial more rewarding. 41 | 42 | If you're an emacs or vim-user, you can try opam's user-setup package, 43 | which can do a decent job of configuring both emacs and vim for use 44 | with Merlin and ocp-indent. 45 | -------------------------------------------------------------------------------- /TODO.org: -------------------------------------------------------------------------------- 1 | * TODO Fix infinite loop when host# is too large 2 | 3 | Right now, if you pick a very large number of hosts, the loop that 4 | generates hosts will just loop forever, since there's a finite 5 | universe that's available. 6 | 7 | * TODO Adjust stats so smaller number of hosts have failures. 8 | 9 | The views that you get when you subscribe to the data stream are 10 | kinda too big now, if you look, for example, at the hosts with 11 | failures. We should make the arrival rate of failures smaller, so we 12 | don't just got a big constant fraction with failures. 13 | 14 | * TODO replaying the sequence will make lots of things look stale 15 | 16 | Since we replay the sequence upon start up of the client, lots of 17 | checks will initially look stale (compared to [Time.now ()]) until 18 | the client has caught up with the stream. If we exposed a notion of 19 | [`Caught_up] in the sequence, we could silence this noise. It's 20 | probably not worth it though. 21 | 22 | yminsky: You can just not display things until time has roughly 23 | caught up with real-time, e.g., within a second. 24 | 25 | * TODO Have a prominent link to the most-up-to-date documentation of Incremental, Core etc 26 | -------------------------------------------------------------------------------- /exercises/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all 2 | all: 3 | @echo jbuilder: Entering directory \`$(abspath $(dir $(lastword $(PWD))))\' 4 | @jbuilder build --dev main.exe 5 | -------------------------------------------------------------------------------- /exercises/ex1.ml: -------------------------------------------------------------------------------- 1 | (* Let's start with something very simple. Take a look at the 2 | functions in [Simple]. Your goal is to write incremental verisons 3 | of these same functions. 4 | 5 | You can run this implementation as follows. 6 | {v 7 | ./_build/default/exercises/main.exe ex1 simple 8 | v} 9 | 10 | Note that we don't expect a practical performance improvement here. 11 | the goal is just to get a sense of how to use the Incremental 12 | primitives. 13 | 14 | {v 15 | ./_build/default/exercises/main.exe ex1 incremental 16 | v} 17 | *) 18 | 19 | 20 | open! Core 21 | open! Import 22 | open! Incr.Let_syntax 23 | 24 | type what_to_show = Volume | Footprint 25 | 26 | module Simple = struct 27 | 28 | let metric what ~w ~h ~d = 29 | match what with 30 | | Volume -> w * h * d 31 | | Footprint -> w * d 32 | ;; 33 | 34 | let run () = 35 | let height = ref 50 in 36 | let width = ref 120 in 37 | let depth = ref 250 in 38 | let what = ref Footprint in 39 | (* This is an all-at-once computation *) 40 | let compute () = 41 | printf "%d\n" (metric !what ~w:!width ~h:!height ~d:!depth) 42 | in 43 | compute (); 44 | height := 150; 45 | width := 90; 46 | compute (); 47 | what := Volume; 48 | compute (); 49 | ;; 50 | 51 | end 52 | 53 | module Incremental = struct 54 | 55 | (* This should return the result as an incremental. 56 | 57 | Note, it's worth thinking about what the incremental graph looks 58 | like. E.g. if [watch=Footprint] then a change to [h] should not 59 | cause this node to refire. *) 60 | let metric (what:what_to_show Incr.t) ~(w:int Incr.t) ~(h: int Incr.t) ~(d:int Incr.t) 61 | : int Incr.t 62 | = 63 | ignore what; ignore w; ignore h; ignore d; 64 | failwith "implement me!" 65 | ;; 66 | 67 | (* The structure of [run] should follow that of [simple_run] above 68 | closely, except: 69 | 70 | - OCaml references should be replaced with [Incr.Var.t]'s 71 | - [metric] should be called just once 72 | - An observer should be created based on the result of [metric] 73 | - [Incr.stabilize] needs to be called as part of [compute] 74 | - [compute] should then get its value using [Incr.Observer.value_exn]. 75 | *) 76 | let run () : unit = 77 | failwith "implement me!" 78 | ;; 79 | 80 | end 81 | 82 | (* From here on is the declaration of the command-line interface, 83 | which you can mostly ignore for the purposes of the tutorial. *) 84 | let command = 85 | let cmd ~summary run = Command.basic' ~summary (Command.Param.return run) in 86 | Command.group ~summary:"Exercise 1" 87 | [ "simple" , cmd ~summary:"all-at-once implementation" Simple.run 88 | ; "incremental" , cmd ~summary:"incremental implementation" Incremental.run 89 | ] 90 | -------------------------------------------------------------------------------- /exercises/ex2.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Now it's time look at a more real-world example! 3 | 4 | For the rest of this tutorial we are going to work on an 5 | application that monitors the state and the health of a collection 6 | of machines, e.g. all boxes in a datacenter. 7 | 8 | To understand the setup, take a look at [shared/protocol.ml] which 9 | contain the protocol that the client receives from the server. 10 | 11 | You do not need to look at [shared/server.ml] or 12 | [shared/generator.ml] in any detail. 13 | 14 | As a first simple query, we would like to report the ratio 15 | [passed/total], where [passed] is the number of notifications of 16 | checks that have passed, and [total] is the total number of check 17 | notifications, including both passes and failures. 18 | 19 | As before, we provide an implementation that doesn't use 20 | [Incremental], which tracks [passed] and [total] using references, 21 | and computes the ratio directly each time. 22 | 23 | You can run this implementation as follows. 24 | 25 | {v 26 | ./_build/default/exercises/main.exe server -port 8080 & 27 | ./_build/default/exercises/main.exe ex2 simple -port 8080 28 | v} 29 | 30 | The goal of this exercise is to write your own version that uses 31 | [Incremental]. The idea is to track [passed] and [total] as 32 | incremental values, and have the ratio be an [Incremental] 33 | computation on top of those values. Note that this is no faster 34 | than the original. The goal here is only to see how to set things 35 | up. 36 | 37 | {v 38 | ./_build/default/exercises/main.exe ex2 incremental -port 8080 39 | v} 40 | 41 | *) 42 | 43 | open! Core 44 | open! Async 45 | open! Import 46 | 47 | let print_passed_ratio passed_ratio = 48 | printf "passed_ratio: %.2F\n" passed_ratio 49 | 50 | module Simple = struct 51 | 52 | let passed_ratio ~total ~passed = 53 | passed // total 54 | 55 | let process_events (pipe : Event.t Pipe.Reader.t) = 56 | let total = ref 0 in 57 | let passed = ref 0 in 58 | let viewer = Viewer.create ~print:print_passed_ratio in 59 | Pipe.iter pipe ~f:(fun event -> 60 | match event.ev with 61 | | Host_info _ | Check (Register _) | Check (Unregister _) -> return () 62 | | Check (Report { outcome; _ }) -> 63 | begin match outcome with 64 | | Passed -> incr passed; incr total 65 | | Failed _ -> incr total 66 | end; 67 | let result = passed_ratio ~total:(!total) ~passed:(!passed) in 68 | Viewer.update viewer result; 69 | return () 70 | ) 71 | end 72 | 73 | module Incremental = struct 74 | 75 | (* Do an incremental version of the passed_ratio computation *) 76 | let passed_ratio ~(total: int Incr.t) ~(passed: int Incr.t) : float Incr.t = 77 | ignore total; ignore passed; 78 | failwith "implement me" 79 | ;; 80 | 81 | (* Do an incremental version of process events, that uses 82 | incremental variables instead of references. *) 83 | let process_events (pipe : Event.t Pipe.Reader.t) = 84 | ignore pipe; 85 | failwith "implement me" 86 | ;; 87 | end 88 | 89 | (* From here on in is just command-line specification. *) 90 | let build_command ~summary process_events = 91 | Command.async' ~summary 92 | (let open Command.Let_syntax in 93 | [%map_open 94 | let (host, port) = Command_common.host_and_port_param in 95 | fun () -> 96 | Command_common.connect_and_process_events 97 | ~process_events ~host ~port 98 | ]) 99 | 100 | let simple = 101 | build_command ~summary:"Simple, all-at-once implementation" 102 | Simple.process_events 103 | 104 | let incremental = 105 | build_command ~summary:"Incremental implementation" 106 | Incremental.process_events 107 | 108 | let command = 109 | Command.group ~summary:"Exercise 2" 110 | [ "simple", simple 111 | ; "incremental", incremental 112 | ] 113 | -------------------------------------------------------------------------------- /exercises/ex3.ml: -------------------------------------------------------------------------------- 1 | (* Now we want to look at more interesting queries. For this exercise, 2 | we'll display a per-host count of the number of checks that are 3 | currently failing, including only nodes that have a least one failure. 4 | *) 5 | 6 | open! Core 7 | open! Async 8 | open! Import 9 | 10 | let print_failure_counts c = 11 | print_s [%sexp (c : int Host.Name.Map.t)] 12 | 13 | module Simple = struct 14 | 15 | let count_failures (s:State.t) = 16 | Map.filter_map s.hosts ~f:(fun (_,checks) -> 17 | let count = 18 | Map.count checks ~f:(fun (_,check_opt) -> 19 | match check_opt with 20 | | None | Some Passed -> false 21 | | Some (Failed _) -> true) 22 | in 23 | if count = 0 then None else Some count 24 | ) 25 | 26 | let process_events (events : Event.t Pipe.Reader.t) = 27 | let viewer = Viewer.create ~print:print_failure_counts in 28 | let state = ref State.empty in 29 | Pipe.iter' events ~f:(fun eventq -> 30 | Queue.iter eventq ~f:(fun event -> 31 | state := State.update !state event); 32 | let failures = Viewer.compute viewer (fun () -> count_failures !state) in 33 | Viewer.update viewer failures; 34 | return () 35 | ) 36 | end 37 | 38 | 39 | module Incremental = struct 40 | 41 | (* In this version, we'll need to replace [Map.filter_map] with 42 | [Incr_map.filter_mapi]. (It's [filter_mapi] instead of [filter_map] only 43 | because [Incr_map] happens not to have a [filter_map] function. *) 44 | 45 | let count_failures (s:State.t Incr.t) : int Host.Name.Map.t Incr.t = 46 | ignore s; 47 | failwith "implement me!" 48 | 49 | (* The structure of process_events will be fairly similar to the 50 | corresponding function in exercise 2 *) 51 | 52 | let process_events (events : Event.t Pipe.Reader.t) : unit Deferred.t = 53 | ignore events; 54 | failwith "implement me!" 55 | 56 | end 57 | 58 | 59 | 60 | (* Command line setup *) 61 | 62 | let build_command ~summary process_events = 63 | Command.async' ~summary 64 | (let open Command.Let_syntax in 65 | [%map_open 66 | let (host, port) = Command_common.host_and_port_param in 67 | fun () -> 68 | Command_common.connect_and_process_events 69 | ~process_events ~host ~port 70 | ]) 71 | 72 | let simple = 73 | build_command ~summary:"Simple, all-at-once implementation" 74 | Simple.process_events 75 | 76 | let incremental = 77 | build_command ~summary:"Incremental implementation" 78 | Incremental.process_events 79 | 80 | let command = 81 | Command.group ~summary:"Exercise 3" 82 | [ "simple", simple 83 | ; "incremental", incremental 84 | ] 85 | -------------------------------------------------------------------------------- /exercises/ex4.ml: -------------------------------------------------------------------------------- 1 | (* In this exercise, we'll compute the set of stale checks for each 2 | host. Specifically, a check is considered stale if it hasn't been 3 | updated for the last X seconds, for a configured threshold X. 4 | 5 | The all-at-once implementation below should give you a sense of 6 | what the semantics should be, but implementing this efficiently and 7 | incrementally is non-trivial. In particular, if you just use the 8 | current time in a naive way, then you'll have to do work linear in 9 | the number of hosts every time you refresh the computation. 10 | 11 | To do this efficiently, you'll want to use Incremental's support 12 | for time. You'll want to make use of [Incr.advance_clock] and 13 | [Incr.at]. 14 | *) 15 | 16 | open! Core 17 | open! Async 18 | open! Import 19 | 20 | type result = Time.t Check.Name.Map.t Host.Name.Map.t 21 | [@@deriving sexp] 22 | 23 | let print_result x = 24 | print_s [%sexp (x : result)] 25 | 26 | module Simple = struct 27 | let stale_checks (s:State.t) ~(thresh:Time.Span.t) : result = 28 | Map.filter_map s.hosts ~f:(fun (_,check) -> 29 | let map = 30 | Map.filter_map check ~f:(fun (when_registered,_) -> 31 | if Time.Span.(<) (Time.diff s.time when_registered) thresh 32 | then None 33 | else Some when_registered 34 | ) 35 | in 36 | if Map.is_empty map then None else Some map) 37 | 38 | let process_events 39 | ~(thresh:Time.Span.t) 40 | (events : Event.t Pipe.Reader.t) 41 | = 42 | let viewer = Viewer.create ~print:print_result in 43 | let state = ref State.empty in 44 | Pipe.iter' events ~f:(fun eventq -> 45 | state := Queue.fold eventq ~init:!state ~f:State.update; 46 | let stale_checks = Viewer.compute viewer (fun () -> stale_checks ~thresh !state) in 47 | Viewer.update viewer stale_checks; 48 | return () 49 | ) 50 | end 51 | 52 | module Incremental = struct 53 | 54 | let stale_checks (s:State.t Incr.t) ~(thresh:Time.Span.t) : result Incr.t = 55 | ignore s; ignore thresh; 56 | failwith "Implement me!" 57 | 58 | let process_events 59 | ~(thresh:Time.Span.t) 60 | (events : Event.t Pipe.Reader.t) 61 | : unit Deferred.t 62 | = 63 | ignore events; ignore thresh; 64 | assert false 65 | end 66 | 67 | 68 | let command = 69 | let cmd summary process_events = 70 | Command.async' ~summary 71 | (let open Command.Let_syntax in 72 | [%map_open 73 | let (host, port) = Command_common.host_and_port_param 74 | and thresh = flag "-thresh" (optional_with_default (Time.Span.of_sec 1.) time_span) 75 | ~doc:"Threshold for determing when a host is stale" 76 | in 77 | fun () -> 78 | Command_common.connect_and_process_events ~host ~port 79 | ~process_events:(process_events ~thresh) 80 | ]) 81 | in 82 | Command.group ~summary:"Exercise 4" 83 | [ "simple" , cmd "all-at-once implementation" Simple.process_events 84 | ; "incremental" , cmd "incremental implementation" Incremental.process_events 85 | ] 86 | -------------------------------------------------------------------------------- /exercises/ex5.ml: -------------------------------------------------------------------------------- 1 | (* Compute the nth stalest checks *) 2 | 3 | open! Core 4 | open! Async 5 | open! Import 6 | 7 | (* Note that this is sorted first by time, then by host name *) 8 | module Time_and_host = struct 9 | include Tuple.Make (Time) (Host.Name) 10 | include Tuple.Comparable (Time) (Host.Name) 11 | include Tuple.Sexpable (Time) (Host.Name) 12 | end 13 | 14 | type result = Check.Name.t Time_and_host.Map.t 15 | [@@deriving sexp] 16 | 17 | let print_result x = 18 | print_s [%sexp (x : result)] 19 | 20 | (** Returns the single stalest check from the map of checks *) 21 | let stalest_check (checks : State.checks) = 22 | match Map.to_alist checks with 23 | | [] -> None 24 | | (check,(time,_)) :: rest -> 25 | let (time,check) = 26 | List.fold rest ~init:(time,check) 27 | ~f:(fun ((oldest_time,_) as acc) (check,(time,_)) -> 28 | if time < oldest_time then (time,check) else acc) 29 | in 30 | Some (time,check) 31 | 32 | module Simple = struct 33 | 34 | let hosts_by_staleness (s:State.t) : result = 35 | List.filter_map (Map.to_alist s.hosts) ~f:(fun (host,(_,checks)) -> 36 | match stalest_check checks with 37 | | None -> None 38 | | Some (time,check) -> 39 | Some ((time,host),check)) 40 | |> List.fold ~init:Time_and_host.Map.empty 41 | ~f:(fun acc (key,data) -> Map.add acc ~key ~data) 42 | 43 | let stalest (s:State.t) ~max_count : result = 44 | let result = hosts_by_staleness s in 45 | if Map.length result <= max_count then result 46 | else 47 | Map.to_sequence result 48 | |> (fun s -> Sequence.take s max_count) 49 | |> Sequence.fold ~init:Time_and_host.Map.empty ~f:(fun acc (key,data) -> 50 | Map.add acc ~key ~data) 51 | 52 | let process_events 53 | ~(max_count:int) 54 | (events : Event.t Pipe.Reader.t) 55 | = 56 | let viewer = Viewer.create ~print:print_result in 57 | let state = ref State.empty in 58 | Pipe.iter' events ~f:(fun eventq -> 59 | state := Queue.fold eventq ~init:!state ~f:State.update; 60 | let stalest = Viewer.compute viewer (fun () -> stalest !state ~max_count) in 61 | Viewer.update viewer stalest; 62 | return () 63 | ) 64 | end 65 | 66 | module Incremental = struct 67 | 68 | let stalest (s:State.t Incr.t) ~(max_count:int) : result Incr.t = 69 | ignore s; ignore max_count; 70 | failwith "Implement me!" 71 | 72 | let process_events 73 | ~(max_count:int) 74 | (events : Event.t Pipe.Reader.t) 75 | : unit Deferred.t 76 | = 77 | ignore events; ignore max_count; 78 | failwith "Implement me!" 79 | 80 | end 81 | 82 | 83 | let command = 84 | let cmd summary process_events = 85 | Command.async' ~summary 86 | (let open Command.Let_syntax in 87 | [%map_open 88 | let (host, port) = Command_common.host_and_port_param 89 | and max_count = flag "-max-count" (optional_with_default 10 int) 90 | ~doc:"The number of hosts to show" 91 | in 92 | fun () -> 93 | Command_common.connect_and_process_events ~host ~port 94 | ~process_events:(process_events ~max_count) 95 | ]) 96 | in 97 | Command.group ~summary:"Exercise 5" 98 | [ "simple" , cmd "all-at-once implementation" Simple.process_events 99 | ; "incremental" , cmd "incremental implementation" Incremental.process_events 100 | ] 101 | -------------------------------------------------------------------------------- /exercises/ex6.ml: -------------------------------------------------------------------------------- 1 | (* Similarly to exercise 3, we want to display information about failed checks. 2 | 3 | This time we'd like to display the descriptions of all tests that 4 | are currently failing. 5 | 6 | The tricky bit however comes from how we want to represent this: 7 | 8 | You could imagine having a 9 | {v 10 | string Check.Name.t Host.Name.t Map.t Incr.t 11 | v} 12 | 13 | to represent this, i.e. the outer map (keyed by hostname) 14 | contains a map from check name to description. 15 | 16 | But for the purpose of this exercise, let's represent this as a 17 | /flat/ map of type 18 | 19 | {v 20 | string (Check_name.t * Host.Name.t) Map.t Incr.t 21 | v} 22 | 23 | *) 24 | 25 | open! Core 26 | open! Async 27 | open! Import 28 | 29 | let print_failure_descriptions c = 30 | print_s [%sexp (c : (Host.Name.t * Check.Name.t, string) Map.Poly.t)] 31 | 32 | module Simple = struct 33 | 34 | let failed_checks (state : State.t) () = 35 | Map.fold ~init:Map.Poly.empty state.hosts ~f:(fun ~key:host_info ~data:(_,checks) acc -> 36 | Map.fold checks ~init:acc ~f:(fun ~key:check_name ~data:(_,outcome) acc -> 37 | match (outcome : Protocol.Check.Outcome.t option) with 38 | | None | Some Passed -> acc 39 | | Some (Failed description) -> 40 | Map.add acc ~key:(host_info, check_name) ~data:description 41 | )) 42 | 43 | let process_events (events : Event.t Pipe.Reader.t) = 44 | let viewer = Viewer.create ~print:print_failure_descriptions in 45 | let state = ref State.empty in 46 | Pipe.iter' events ~f:(fun eventq -> 47 | Queue.iter eventq ~f:(fun event -> 48 | state := State.update !state event); 49 | let update = Viewer.compute viewer (failed_checks !state) in 50 | Viewer.update viewer update; 51 | return () 52 | ) 53 | end 54 | 55 | 56 | module Incremental = struct 57 | open! Incr.Let_syntax 58 | 59 | (* First, let's write a helper function that applies [f] 60 | incrementally to [inc] but keeps track of the input and output of 61 | the last time [f] ran. You will need to use a [ref] here. *) 62 | let diff_map (inc : 'a Incr.t) ~(f : old:('a * 'b) option -> 'a -> 'b) : 'b Incr.t = 63 | ignore (inc, f); 64 | failwith "Implement me" 65 | 66 | (* Next, let's write the function to flatten [State.t Incr.t] into a 67 | map keyed by [Host.Name.t * Check.Name.t]. (Incr_map has a 68 | [flatten] function built in, but we want to ignore that and write 69 | this from first principals.) 70 | 71 | The basic idea is to use [diff_map] to find all the keys that 72 | were added, removed or changed between the old and current input, 73 | and apply those changes to the old output to get the new output. 74 | 75 | Check out [Map.symmetric diff] for an efficient way of 76 | calculating diffs between maps. The goal here is to be 77 | incremental with respect to both the innter and outer map. *) 78 | let flatten_maps 79 | (mm : State.t Incr.t) 80 | : (Host.Name.t * Check.Name.t,Time.t * Check.Outcome.t option,_) Map.t Incr.t 81 | = 82 | ignore mm; 83 | failwith "implement me" 84 | 85 | 86 | (* Use [flatten_maps] here to compute the final result. *) 87 | let failed_checks (s:State.t Incr.t) : (Host.Name.t * Check.Name.t, string) Map.Poly.t Incr.t = 88 | ignore s; 89 | failwith "implement me" 90 | 91 | (* The structure of process_events will be fairly similar to the 92 | corresponding function in exercise 3 *) 93 | let process_events (events : Event.t Pipe.Reader.t) : unit Deferred.t = 94 | ignore events; 95 | failwith "implement me" 96 | 97 | end 98 | 99 | 100 | 101 | (* Command line setup *) 102 | 103 | let build_command ~summary process_events = 104 | Command.async' ~summary 105 | (let open Command.Let_syntax in 106 | [%map_open 107 | let (host, port) = Command_common.host_and_port_param in 108 | fun () -> 109 | Command_common.connect_and_process_events 110 | ~process_events ~host ~port 111 | ]) 112 | 113 | let simple = 114 | build_command ~summary:"Simple, all-at-once implementation" 115 | Simple.process_events 116 | 117 | let incremental = 118 | build_command ~summary:"Incremental implementation" 119 | Incremental.process_events 120 | 121 | let command = 122 | Command.group ~summary:"Exercise 6" 123 | [ "simple", simple 124 | ; "incremental", incremental 125 | ] 126 | -------------------------------------------------------------------------------- /exercises/import.ml: -------------------------------------------------------------------------------- 1 | include Tutorial_shared 2 | -------------------------------------------------------------------------------- /exercises/jbuild: -------------------------------------------------------------------------------- 1 | ;; -*- scheme -*- 2 | 3 | (jbuild_version 1) 4 | 5 | (executables 6 | ((names (main)) 7 | (libraries (tutorial_shared)) 8 | (preprocess (pps (ppx_jane))) 9 | )) 10 | 11 | -------------------------------------------------------------------------------- /exercises/main.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | let () = 5 | Command.group 6 | ~summary:"Command line API" 7 | [ "server", Server.command 8 | ; "ex1", Ex1.command 9 | ; "ex2", Ex2.command 10 | ; "ex3", Ex3.command 11 | ; "ex4", Ex4.command 12 | ; "ex5", Ex5.command 13 | ; "ex6", Ex6.command 14 | ] 15 | |> Command.run 16 | -------------------------------------------------------------------------------- /jbuild-workspace.here: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yminsky/incremental-tutorial/756dfe36ec1b0a102128b3fa78a6c6762bdab90a/jbuild-workspace.here -------------------------------------------------------------------------------- /shared/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all 2 | all: 3 | @echo jbuilder: Entering directory \`$(abspath $(dir $(lastword $(PWD))))\' 4 | @jbuilder build --dev tutorial_shared.cmxa 5 | -------------------------------------------------------------------------------- /shared/command_common.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | let host_and_port_param = 5 | let open Command.Let_syntax in 6 | [%map_open 7 | let port = 8 | flag "port" (required int) ~doc:"INT port to connect to server" 9 | and host = 10 | flag "host" (optional_with_default "127.0.0.1" string) 11 | ~doc:" host name (default:localhost)" 12 | in 13 | (host, port)] 14 | 15 | let connect_and_process_events ~process_events ~host ~port = 16 | Log.Global.info "Starting client"; 17 | let%bind (_socket, reader, writer) = 18 | Tcp.connect (Tcp.to_host_and_port host port) 19 | in 20 | Log.Global.info "Connected to %s:%d" host port; 21 | Rpc.Connection.with_close reader writer 22 | ~connection_state:(fun _ -> ()) 23 | ~on_handshake_error:`Raise 24 | ~dispatch_queries:(fun conn -> 25 | let%bind (pipe, _metadata) = Rpc.Pipe_rpc.dispatch_exn Protocol.events conn () in 26 | let%bind () = process_events pipe in 27 | Log.Global.error "Event pipe closed. Exiting"; 28 | Deferred.unit 29 | ) 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /shared/command_common.mli: -------------------------------------------------------------------------------- 1 | (** Utilities for creating simple command-line tools *) 2 | 3 | open! Core 4 | open! Async 5 | 6 | (** Adds -host and -port command line arguments, with the host 7 | defaulting to 127.0.0.1. *) 8 | val host_and_port_param : (string * int) Command.Param.t 9 | 10 | (** Loop that requests a stream of events from the tutorial server, 11 | calling [process_events] to handle those events, and shutting the 12 | connection down when the deferred returned by [process_events] 13 | becomes determined. *) 14 | val connect_and_process_events 15 | : process_events:(Protocol.Event.t Pipe.Reader.t -> unit Deferred.t) 16 | -> host:string 17 | -> port:int 18 | -> unit Deferred.t 19 | -------------------------------------------------------------------------------- /shared/generator.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Protocol 3 | 4 | let rselect rs ar = 5 | Array.get ar (Random.State.int rs (Array.length ar)) 6 | 7 | module Check_type = struct 8 | type t = 9 | | Temp 10 | | Free_space 11 | | Packet_drops 12 | [@@deriving sexp, enumerate] 13 | 14 | let to_check_name t = 15 | Check.Name.of_string 16 | (match t with 17 | | Temp -> "temp" 18 | | Free_space -> "free-space" 19 | | Packet_drops -> "packet-drops") 20 | end 21 | 22 | let host_kinds = [| "www"; "ws"; "grid"; "lb" |] 23 | 24 | let domain = [| "cs.oxford.uk"; "oxford.uk" |] 25 | 26 | let random_host rs = 27 | let id = Random.State.int rs 1000 in 28 | Host.Name.of_string 29 | (rselect rs host_kinds ^ Int.to_string id ^ "." ^ rselect rs domain) 30 | 31 | let random_ip rs = 32 | let byte () = Random.State.int rs 256 in 33 | Unix.Inet_addr.of_string 34 | (sprintf "%d.%d.%d.%d" (byte ()) (byte ()) (byte ()) (byte ())) 35 | 36 | (** Note that this won't terminate if n is too big! *) 37 | let random_host_set rs n = 38 | let rec loop set = 39 | if Set.length set = n then set 40 | else loop (Set.add set (random_host rs)) 41 | in 42 | loop Host.Name.Set.empty 43 | 44 | module State = struct 45 | type t = { hosts : Host.Name.Set.t 46 | ; active : (Host.Info.t * (Time.t * Check.Outcome.t) Check.Name.Map.t) 47 | Host.Name.Map.t 48 | ; time: Time.t 49 | } 50 | 51 | let activate t rs host = 52 | let info : Host.Info.t = 53 | { name = host 54 | ; address = random_ip rs 55 | ; boot_time = t.time 56 | } 57 | in 58 | let active = 59 | Map.add t.active ~key:host ~data:(info,Check.Name.Map.empty) 60 | in 61 | ({ t with active }, info) 62 | 63 | let activate_pct t rs pct = 64 | Set.fold t.hosts ~init:t ~f:(fun t host -> 65 | if Random.State.float rs 1. < pct then fst (activate t rs host) else t) 66 | 67 | let create rs time ~num_hosts ~pct_initially_active = 68 | let hosts = random_host_set rs num_hosts in 69 | activate_pct 70 | { hosts; active = Host.Name.Map.empty; time } rs 71 | pct_initially_active 72 | 73 | let snapshot t : Event.t Sequence.t = 74 | let open Sequence.Let_syntax in 75 | let%bind (host,(info,checks)) = Map.to_sequence t.active in 76 | let%bind (check,(when_checked,outcome)) = Map.to_sequence checks in 77 | Sequence.of_list 78 | [ Event.create t.time (Host_info info) 79 | ; Event.create t.time (Check (Register { host; check })) 80 | ; Event.create t.time (Check (Report {host; check; when_checked; outcome})) 81 | ] 82 | 83 | let chooser rs options = 84 | let options = List.map options ~f:(fun (w,v) -> (Int.to_float w,v)) in 85 | let total_weight = List.map ~f:fst options |> List.fold ~init:0. ~f:(+.) in 86 | let choices = Array.of_list options in 87 | (fun () -> 88 | let rec find i x_remaining = 89 | if i = Array.length choices - 1 then snd choices.(i) 90 | else 91 | let current_prob = fst choices.(i) in 92 | if x_remaining <= current_prob then snd choices.(i) 93 | else find (i+1) (x_remaining -. current_prob) 94 | in 95 | find 0 (Random.State.float rs total_weight)) 96 | 97 | let equiprobable l = List.map ~f:(fun x -> (1,x)) l 98 | 99 | type update_type = Activate_host | Check_success | Check_fail 100 | 101 | let next_event t ~time_scale rs = 102 | let choose_host = chooser rs (equiprobable (Set.to_list t.hosts)) in 103 | let choose_check = chooser rs (equiprobable (Check_type.all : Check_type.t list)) in 104 | let update_type = 105 | chooser rs 106 | [ 20 , Activate_host 107 | ; 90 , Check_success 108 | ; 8 , Check_fail 109 | ] 110 | in 111 | (fun t -> 112 | let time_delta = 113 | Random.State.float rs (Time.Span.to_sec time_scale) 114 | |> Time.Span.of_sec 115 | in 116 | let t = 117 | { t with 118 | time = Time.add t.time time_delta 119 | } 120 | in 121 | let change_check outcome = 122 | let host = choose_host () in 123 | match Map.find t.active host with 124 | | None -> (t,[]) 125 | | Some (info,checks) -> 126 | let check_type = choose_check () in 127 | let outcome = outcome check_type in 128 | let check = Check_type.to_check_name check_type in 129 | let when_checked = t.time in 130 | let register = 131 | if Map.mem checks check then [] 132 | else [Event.create t.time (Check (Register { host; check }))] 133 | in 134 | let checks = Map.add checks ~key:check ~data:(when_checked,outcome) in 135 | let active = Map.add t.active ~key:host ~data:(info,checks) in 136 | let report = [ Event.create t.time 137 | (Check (Report { host; check; when_checked; outcome }))] 138 | in 139 | ({ t with active}, register @ report) 140 | in 141 | match update_type () with 142 | | Activate_host -> 143 | let host = choose_host () in 144 | (match Map.find t.active host with 145 | | Some _ -> (t,[]) 146 | | None -> 147 | let (t,info) = activate t rs host in 148 | let events = [ Event.create t.time (Host_info info) ] in 149 | (t,events) 150 | ) 151 | | Check_success -> change_check (fun _ -> Passed) 152 | | Check_fail -> change_check (fun _ -> Failed "Aaaargh!") 153 | ) 154 | 155 | end 156 | 157 | let sequence rs time ~num_hosts ~pct_initially_active ~time_scale = 158 | let state = State.create rs time ~num_hosts ~pct_initially_active in 159 | let next_event = State.next_event state ~time_scale rs in 160 | Sequence.append 161 | (Sequence.map (State.snapshot state) ~f:(fun ev -> (time,ev))) 162 | (Sequence.join 163 | (Sequence.unfold ~init:state ~f:(fun s -> 164 | let (s',evs) = next_event s in 165 | let evs = List.map evs ~f:(fun ev -> (s'.time,ev)) in 166 | Some (Sequence.of_list evs, s')))) 167 | 168 | 169 | let stream rs time ~num_hosts ~pct_initially_active ~time_scale = 170 | let sequence = ref (sequence rs time ~num_hosts ~pct_initially_active ~time_scale) in 171 | stage (fun () -> 172 | match Sequence.next !sequence with 173 | | None -> assert false 174 | | Some (x,sequence') -> 175 | sequence := sequence'; 176 | x) 177 | -------------------------------------------------------------------------------- /shared/generator.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Protocol 3 | 4 | (** Create a deterministic, infinite sequence of events *) 5 | val stream 6 | : Random.State.t 7 | -> Time.t 8 | -> num_hosts:int 9 | -> pct_initially_active:float 10 | -> time_scale:Time.Span.t 11 | -> (unit -> Time.t * Event.t) Staged.t 12 | -------------------------------------------------------------------------------- /shared/import.ml: -------------------------------------------------------------------------------- 1 | module Incr = Incremental_lib.Incremental.Make () 2 | module Incr_map = Incr_map.Make (Incr) 3 | include Protocol 4 | 5 | let print_s (sexp : Core.Sexp.t) : unit = 6 | let module Sexp_pp = Sexp_pretty.Pretty_print in 7 | Sexp_pp.pp_out_channel Sexp_pp.Config.default stdout sexp 8 | -------------------------------------------------------------------------------- /shared/jbuild: -------------------------------------------------------------------------------- 1 | ;; -*- scheme -*- 2 | 3 | (jbuild_version 1) 4 | 5 | (library 6 | ((name tutorial_shared) 7 | (libraries 8 | ( 9 | async 10 | core 11 | incr_map 12 | incremental_kernel 13 | incremental 14 | sexp_pretty 15 | )) 16 | (preprocess (pps (ppx_jane))) 17 | )) 18 | 19 | -------------------------------------------------------------------------------- /shared/protocol.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | module Host = struct 4 | module Name : Identifiable = String 5 | module Info = struct 6 | type t = 7 | { name : Name.t 8 | ; address : Unix.Inet_addr.Blocking_sexp.t 9 | ; boot_time : Time.t 10 | } 11 | [@@deriving sexp, bin_io] 12 | end 13 | end 14 | 15 | module Check = struct 16 | module Name : Identifiable = String 17 | module Outcome = struct 18 | type t = Passed | Failed of string 19 | [@@deriving sexp, bin_io] 20 | end 21 | 22 | module Event = struct 23 | type t = 24 | | Register of 25 | { host : Host.Name.t 26 | ; check : Name.t } 27 | | Unregister of 28 | { host : Host.Name.t 29 | ; check : Name.t } 30 | | Report of 31 | { host : Host.Name.t 32 | ; check : Name.t 33 | ; when_checked : Time.t 34 | ; outcome : Outcome.t } 35 | [@@deriving sexp, bin_io] 36 | end 37 | end 38 | 39 | module Event = struct 40 | type event = 41 | | Check of Check.Event.t 42 | | Host_info of Host.Info.t 43 | [@@deriving sexp, bin_io] 44 | 45 | type t = { time: Time.t; ev: event } 46 | [@@deriving sexp, bin_io] 47 | 48 | let create time ev = { time; ev } 49 | end 50 | 51 | let events = 52 | Async.Rpc.Pipe_rpc.create () 53 | ~name:"events" 54 | ~version:0 (* Unversioned *) 55 | ~bin_query:[%bin_type_class: unit] 56 | ~bin_response:[%bin_type_class: Event.t] 57 | ~bin_error:[%bin_type_class: unit] 58 | -------------------------------------------------------------------------------- /shared/server.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | open! Import 4 | 5 | let events_impl ~(make_stream:unit -> (unit -> (Time.t * Event.t)) Staged.t) ~stats = 6 | Rpc.Pipe_rpc.implement Protocol.events (fun addr () -> 7 | Log.Global.info !"Client connected on %{sexp:Socket.Address.Inet.t}" addr; 8 | let next = unstage (make_stream ()) in 9 | let (r,w) = Pipe.create () in 10 | let log msg = 11 | Log.Global.info 12 | !"%{sexp:Socket.Address.Inet.t}: %s" addr msg 13 | in 14 | let started_at = Time_ns.now () in 15 | let events_written = ref 0 in 16 | begin 17 | if stats then 18 | Clock.every (Time.Span.of_sec 1.) ~stop:(Pipe.closed w) 19 | (fun () -> 20 | let sec_since_start = 21 | Time_ns.diff (Time_ns.now ()) started_at 22 | |> Time_ns.Span.to_sec 23 | in 24 | log (sprintf "Total-events: %d Events/sec %.3f%!" 25 | !events_written 26 | (Float.of_int !events_written /. sec_since_start))) 27 | end; 28 | let rec write () = 29 | let (time,event) = next () in 30 | if Pipe.is_closed w then ( 31 | log "Client disconnected!"; 32 | Deferred.unit 33 | ) else ( 34 | let%bind () = at time in 35 | let%bind () = Pipe.write_if_open w event in 36 | incr events_written; 37 | write () 38 | ) 39 | in 40 | don't_wait_for (write ()); 41 | return (Ok r)) 42 | 43 | let implementations ~make_stream ~stats = 44 | Rpc.Implementations.create_exn 45 | ~implementations:[events_impl ~make_stream ~stats] 46 | ~on_unknown_rpc:`Raise 47 | 48 | let serve ~make_stream ~port ~stats = 49 | let%bind _tcp_server = 50 | Tcp.Server.create 51 | ~on_handler_error:`Ignore 52 | (Tcp.on_port port) 53 | (fun addr r w -> 54 | Rpc.Connection.server_with_close r w 55 | ~connection_state:(fun _ -> addr) 56 | ~on_handshake_error:`Raise 57 | ~implementations:(implementations ~make_stream ~stats) 58 | ) 59 | in 60 | Log.Global.info "Server started"; 61 | Deferred.unit 62 | 63 | let go ~port ~num_hosts ~time_scale ~stats = 64 | let make_stream = 65 | let time = Time.now () in 66 | let rs = Random.State.make_self_init () in 67 | (fun () -> 68 | Generator.stream 69 | (Random.State.copy rs) 70 | time 71 | ~num_hosts 72 | ~pct_initially_active:0.20 73 | ~time_scale 74 | ) 75 | in 76 | let%bind () = serve ~make_stream ~port ~stats in 77 | Deferred.never () 78 | 79 | let command = 80 | let open Command.Let_syntax in 81 | Command.async' 82 | ~summary:"start server" 83 | [%map_open 84 | let port = 85 | flag "port" (required int) ~doc:"PORT port to listen for clients" 86 | and num_hosts = 87 | flag "hosts" (optional_with_default 1000 int) 88 | ~doc:"N number of hosts to simulate" 89 | and time_scale = 90 | flag "time-scale" (optional_with_default (Time.Span.of_sec 0.01) time_span) 91 | ~doc:"maximum time to the next event" 92 | and stats = 93 | flag "print-stats" no_arg ~doc:" Print stats about event generation per client." 94 | in 95 | fun () -> 96 | go ~port ~num_hosts ~time_scale ~stats 97 | ] 98 | -------------------------------------------------------------------------------- /shared/server.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | val command : Command.t 4 | -------------------------------------------------------------------------------- /shared/state.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Protocol 3 | 4 | type checks = (Time.t * Check.Outcome.t option) Check.Name.Map.t 5 | [@@deriving sexp] 6 | 7 | type t = { time: Time.t 8 | ; hosts: (Host.Info.t * checks) Host.Name.Map.t 9 | } 10 | [@@deriving sexp, fields] 11 | 12 | let empty = { time = Time.epoch 13 | ; hosts = Host.Name.Map.empty 14 | } 15 | 16 | let update (t:t) (ev:Event.t) : t = 17 | let change_host host ~f : t = 18 | let hosts = 19 | Map.change t.hosts host ~f:(function 20 | | None -> None 21 | | Some (hi, checks) -> Some (hi, f hi checks)) 22 | in 23 | { time = ev.time; hosts } 24 | in 25 | match ev.ev with 26 | | Host_info hi -> 27 | let hosts = 28 | Map.change t.hosts hi.name ~f:(function 29 | | None -> Some (hi,Check.Name.Map.empty) 30 | | Some (_,checks) -> Some (hi,checks)) 31 | in 32 | { time = ev.time; hosts } 33 | | Check (Register {host;check}) -> 34 | change_host host ~f:(fun hi checks -> 35 | Map.add checks ~key:check ~data:(hi.boot_time,None)) 36 | | Check (Unregister {host; check}) -> 37 | change_host host ~f:(fun _hi checks -> 38 | Map.remove checks check) 39 | | Check (Report {host; check; when_checked; outcome }) -> 40 | change_host host ~f:(fun _hi checks -> 41 | Map.add checks ~key:check ~data:(when_checked, Some outcome)) 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | -------------------------------------------------------------------------------- /shared/state.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Protocol 3 | 4 | type checks = (Time.t * Check.Outcome.t option) Check.Name.Map.t 5 | [@@deriving sexp] 6 | 7 | type t = { time: Time.t 8 | ; hosts: (Host.Info.t * checks) Host.Name.Map.t 9 | } 10 | [@@deriving sexp, fields] 11 | 12 | val empty : t 13 | val update : t -> Event.t -> t 14 | -------------------------------------------------------------------------------- /shared/tutorial_shared.ml: -------------------------------------------------------------------------------- 1 | include Import 2 | module Command_common = Command_common 3 | module Generator = Generator 4 | module Protocol = Protocol 5 | module Server = Server 6 | module State = State 7 | module Viewer = Viewer 8 | -------------------------------------------------------------------------------- /shared/viewer.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Async 3 | 4 | let update_interval = Time.Span.of_sec 0.3 5 | 6 | type 'a t = { mutable data : 'a option 7 | ; mutable total_events : int 8 | ; mutable last_refresh : Time_ns.t 9 | ; compute_times : Time.Span.t Queue.t 10 | } 11 | 12 | let get_and_clear_avg_compute_time t = 13 | let sum = Queue.sum (module Time.Span) ~f:Fn.id t.compute_times in 14 | let length = Queue.length t.compute_times in 15 | let rval = Time.Span.scale sum (1. /. Float.of_int length) in 16 | Queue.clear t.compute_times; 17 | rval 18 | 19 | let create ~print = 20 | let t = 21 | { data = None 22 | ; total_events = 0 23 | ; last_refresh = Time_ns.now () 24 | ; compute_times = Queue.create () 25 | } 26 | in 27 | let started_at = Time_ns.now () in 28 | Clock.every' update_interval (fun () -> 29 | match t.data with 30 | | None -> return () 31 | | Some data -> 32 | let%map (_:int) = Sys.command "clear" in 33 | let now = Time_ns.now () in 34 | let diff = Time_ns.diff now started_at |> Time_ns.Span.to_sec in 35 | let avg_compute_time = get_and_clear_avg_compute_time t in 36 | Core.printf !"Total events seen by viewer: %d\t\tper sec %.3f\t\tavg time: %s\n\n%!" 37 | t.total_events 38 | (Float.of_int t.total_events /. diff) 39 | (Time.Span.to_string avg_compute_time) 40 | ; 41 | printf "------------------------------\n\n%!"; 42 | print data; 43 | t.last_refresh <- now; 44 | ); 45 | t 46 | 47 | let update t data = 48 | t.total_events <- t.total_events + 1; 49 | t.data <- Some data 50 | 51 | let compute t f = 52 | let start = Time.now () in 53 | let rval = f () in 54 | let stop = Time.now () in 55 | Queue.enqueue t.compute_times (Time.diff stop start); 56 | rval 57 | 58 | -------------------------------------------------------------------------------- /shared/viewer.mli: -------------------------------------------------------------------------------- 1 | (** A simple way of viewing results in a terminal. *) 2 | open! Core 3 | 4 | type 'display_state t 5 | 6 | val create : print:('display_state -> unit) -> 'display_state t 7 | 8 | (** To register a new value to be printed *) 9 | val update : 'display_state t -> 'display_state -> unit 10 | 11 | (** Used to register the computation phase *) 12 | val compute : _ t -> (unit -> 'a) -> 'a 13 | -------------------------------------------------------------------------------- /solutions/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all 2 | all: 3 | @echo jbuilder: Entering directory \`$(abspath $(dir $(lastword $(PWD))))\' 4 | @jbuilder build --dev main.exe 5 | -------------------------------------------------------------------------------- /solutions/ex1.ml: -------------------------------------------------------------------------------- 1 | (* Let's start with something very simple. Take a look at the 2 | functions in [Simple]. Your goal is to write incremental verisons 3 | of these same functions. 4 | 5 | Note that we don't expect a practical performance improvement here. 6 | the goal is just to get a sense of how to use the Incremental 7 | primitives. 8 | *) 9 | 10 | open! Core 11 | open! Import 12 | open! Incr.Let_syntax 13 | 14 | type what_to_show = Volume | Footprint 15 | 16 | module Simple = struct 17 | 18 | let metric what ~w ~h ~d = 19 | match what with 20 | | Volume -> w * h * d 21 | | Footprint -> w * d 22 | ;; 23 | 24 | let run () = 25 | let height = ref 50 in 26 | let width = ref 120 in 27 | let depth = ref 250 in 28 | let what = ref Footprint in 29 | (* This is an all-at-once computation *) 30 | let compute () = 31 | printf "%d\n" (metric !what ~w:!width ~h:!height ~d:!depth) 32 | in 33 | compute (); 34 | height := 150; 35 | width := 90; 36 | compute (); 37 | what := Volume; 38 | compute (); 39 | ;; 40 | 41 | end 42 | 43 | module Incremental = struct 44 | 45 | (* This should return the result as an incremental. 46 | 47 | Note, it's worth thinking about what the incremental graph looks 48 | like. E.g. if [watch=Footprint] then a change to [h] should not 49 | cause this node to refire. *) 50 | let metric (what:what_to_show Incr.t) ~(w:int Incr.t) ~(h: int Incr.t) ~(d:int Incr.t) 51 | : int Incr.t 52 | = 53 | match%bind what with 54 | | Volume -> 55 | let%map w = w and h = h and d = d in 56 | w * h * d 57 | | Footprint -> 58 | let%map w = w and d = d in 59 | w * d 60 | ;; 61 | 62 | (* The structure of [run] should follow that of [simple_run] above 63 | closely, except: 64 | 65 | - OCaml references should be replaced with [Incr.Var.t]'s 66 | - [f] should be called just once 67 | - An observer should be created based on the result of [f] 68 | - [Incr.stabilize] needs to be called as part of [compute] 69 | - [compute] should then get its value using [Incr.Observer.value_exn]. 70 | *) 71 | let run () : unit = 72 | let (!) = Incr.Var.watch in 73 | let (:=) = Incr.Var.set in 74 | let height = Incr.Var.create 50 in 75 | let width = Incr.Var.create 120 in 76 | let depth = Incr.Var.create 250 in 77 | let what = Incr.Var.create Footprint in 78 | (* This is an all-at-once computation *) 79 | let result = 80 | metric !what ~w:!width ~h:!height ~d:!depth |> Incr.observe 81 | in 82 | let compute () = 83 | Incr.stabilize (); 84 | printf "%d\n" (Incr.Observer.value_exn result) 85 | in 86 | compute (); 87 | height := 150; 88 | width := 90; 89 | compute (); 90 | what := Volume; 91 | compute (); 92 | ;; 93 | 94 | end 95 | 96 | (* From here on is the declaration of the command-line interface, 97 | which you can mostly ignore for the purposes of the tutorial. *) 98 | let command = 99 | let cmd ~summary run = Command.basic' ~summary (Command.Param.return run) in 100 | Command.group ~summary:"Exercise 1" 101 | [ "simple" , cmd ~summary:"all-at-once implementation" Simple.run 102 | ; "incremental" , cmd ~summary:"incremental implementation" Incremental.run 103 | ] 104 | -------------------------------------------------------------------------------- /solutions/ex2.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Now it's time look at a more real-world example! 3 | 4 | For the rest of this tutorial we are going to work on an 5 | application that monitors the state and the health of a collection 6 | of machines, e.g. all boxes in a datacenter. 7 | 8 | To understand the setup, take a look at [shared/protocol.ml] which 9 | contain the protocol that the client receives from the server. 10 | 11 | You do not need to look at [shared/server.ml] or 12 | [shared/generator.ml] in any detail. 13 | 14 | As a first simple query, we would like to report the ratio 15 | [passed/total], where [passed] is the number of notifications of 16 | checks that have passed, and [total] is the total number of check 17 | notifications, including both passes and failures. 18 | 19 | As before, we provide an implementation that doesn't use 20 | [Incremental], which tracks [passed] and [total] using references, 21 | and computes the ratio directly each time. 22 | 23 | You can run this implementation as follows. 24 | 25 | {v 26 | ./_build/default/exercises/main.exe server -port 8080 & 27 | ./_build/default/exercises/main.exe ex2 simple -port 8080 28 | v} 29 | 30 | The goal of this exercise is to write your own version that uses 31 | [Incremental]. The idea is to track [passed] and [total] as 32 | incremental values, and have the ratio be an [Incremental] 33 | computation on top of those values. Note that this is no faster 34 | than the original. The goal here is only to see how to set things 35 | up. 36 | 37 | {v 38 | ./_build/default/exercises/main.exe ex2 incremental -port 8080 39 | v} 40 | 41 | *) 42 | 43 | open! Core 44 | open! Async 45 | open! Import 46 | 47 | let print_passed_ratio passed_ratio = 48 | printf "passed_ratio: %.2F\n" passed_ratio 49 | 50 | module Simple = struct 51 | 52 | let passed_ratio ~total ~passed = 53 | passed // total 54 | 55 | let process_events (pipe : Event.t Pipe.Reader.t) = 56 | let total = ref 0 in 57 | let passed = ref 0 in 58 | let viewer = Viewer.create ~print:print_passed_ratio in 59 | Pipe.iter pipe ~f:(fun event -> 60 | match event.ev with 61 | | Host_info _ | Check (Register _) | Check (Unregister _) -> return () 62 | | Check (Report { outcome; _ }) -> 63 | begin match outcome with 64 | | Passed -> incr passed; incr total 65 | | Failed _ -> incr total 66 | end; 67 | let result = passed_ratio ~total:(!total) ~passed:(!passed) in 68 | Viewer.update viewer result; 69 | return () 70 | ) 71 | end 72 | 73 | module Incremental = struct 74 | 75 | let passed_ratio ~(total: int Incr.t) ~(passed: int Incr.t) : float Incr.t = 76 | let open Incr.Let_syntax in 77 | let%map passed = passed and total = total in 78 | passed // total 79 | ;; 80 | 81 | let process_events (pipe : Event.t Pipe.Reader.t) = 82 | let total = Incr.Var.create 0 in 83 | let passed = Incr.Var.create 0 in 84 | let viewer = Viewer.create ~print:print_passed_ratio in 85 | let result = 86 | let (!) = Incr.Var.watch in 87 | passed_ratio ~total:!total ~passed:!passed 88 | |> Incr.observe 89 | in 90 | Incr.Observer.on_update_exn result ~f:(function 91 | | Initialized x | Changed (_,x) -> Viewer.update viewer x 92 | | Invalidated -> assert false 93 | ); 94 | Pipe.iter' pipe ~f:(fun eventq -> 95 | Queue.iter eventq ~f:(fun event -> 96 | match event.ev with 97 | | Host_info _ | Check (Register _) | Check (Unregister _) -> () 98 | | Check (Report { outcome; _ }) -> 99 | let incr i = Incr.Var.set i (1 + Incr.Var.value i) in 100 | begin match outcome with 101 | | Passed -> incr passed; incr total 102 | | Failed _ -> incr total 103 | end); 104 | Incr.stabilize (); 105 | return () 106 | ) 107 | ;; 108 | end 109 | 110 | (* From here on in is just command-line specification. *) 111 | let build_command ~summary process_events = 112 | Command.async' ~summary 113 | (let open Command.Let_syntax in 114 | [%map_open 115 | let (host, port) = Command_common.host_and_port_param in 116 | fun () -> 117 | Command_common.connect_and_process_events 118 | ~process_events ~host ~port 119 | ]) 120 | 121 | let simple = 122 | build_command ~summary:"Simple, all-at-once implementation" 123 | Simple.process_events 124 | 125 | let incremental = 126 | build_command ~summary:"Incremental implementation" 127 | Incremental.process_events 128 | 129 | let command = 130 | Command.group ~summary:"Exercise 2" 131 | [ "simple", simple 132 | ; "incremental", incremental 133 | ] 134 | -------------------------------------------------------------------------------- /solutions/ex3.ml: -------------------------------------------------------------------------------- 1 | (* Now we want to look at more interesting queries. For this exercise, 2 | we'll display a per-host count of the number of checks that are 3 | currently failing, including only nodes that have a least one failure. 4 | *) 5 | 6 | open! Core 7 | open! Async 8 | open! Import 9 | 10 | let print_failure_counts c = 11 | print_s [%sexp (c : int Host.Name.Map.t)] 12 | 13 | module Simple = struct 14 | 15 | let count_failures (s:State.t) = 16 | Map.filter_map s.hosts ~f:(fun (_,checks) -> 17 | let count = 18 | Map.count checks ~f:(fun (_,check_opt) -> 19 | match check_opt with 20 | | None | Some Passed -> false 21 | | Some (Failed _) -> true) 22 | in 23 | if count <= 1 then None else Some count 24 | ) 25 | 26 | let process_events (events : Event.t Pipe.Reader.t) = 27 | let viewer = Viewer.create ~print:print_failure_counts in 28 | let state = ref State.empty in 29 | Pipe.iter' events ~f:(fun eventq -> 30 | state := Queue.fold eventq ~init:!state ~f:State.update; 31 | let failures = Viewer.compute viewer (fun () -> count_failures !state) in 32 | Viewer.update viewer failures; 33 | return () 34 | ) 35 | end 36 | 37 | 38 | module Incremental = struct 39 | 40 | let count_failures (s:State.t Incr.t) : int Host.Name.Map.t Incr.t = 41 | let open Incr.Let_syntax in 42 | Incr_map.filter_mapi (s >>| State.hosts) ~f:(fun ~key:_ ~data:(_,checks) -> 43 | let count = 44 | Map.count checks ~f:(fun (_,check_opt) -> 45 | match check_opt with 46 | | None | Some Passed -> false 47 | | Some (Failed _) -> true) 48 | in 49 | if count <= 1 then None else Some count 50 | ) 51 | 52 | let process_events (events : Event.t Pipe.Reader.t) : unit Deferred.t = 53 | let viewer = Viewer.create ~print:print_failure_counts in 54 | let state = Incr.Var.create State.empty in 55 | let result = Incr.observe (count_failures (Incr.Var.watch state)) in 56 | Incr.Observer.on_update_exn result ~f:(fun update -> 57 | match update with 58 | | Initialized x | Changed (_,x) -> Viewer.update viewer x 59 | | Invalidated -> assert false 60 | ); 61 | Pipe.iter' events ~f:(fun eventq -> 62 | Incr.Var.set state 63 | (Queue.fold eventq ~init:(Incr.Var.value state) ~f:State.update); 64 | Viewer.compute viewer Incr.stabilize; 65 | Deferred.return () 66 | ) 67 | end 68 | 69 | (* Command line setup *) 70 | 71 | let build_command ~summary process_events = 72 | Command.async' ~summary 73 | (let open Command.Let_syntax in 74 | [%map_open 75 | let (host, port) = Command_common.host_and_port_param in 76 | fun () -> 77 | Command_common.connect_and_process_events 78 | ~process_events ~host ~port 79 | ]) 80 | 81 | let simple = 82 | build_command ~summary:"Simple, all-at-once implementation" 83 | Simple.process_events 84 | 85 | let incremental = 86 | build_command ~summary:"Incremental implementation" 87 | Incremental.process_events 88 | 89 | let command = 90 | Command.group ~summary:"Exercise 3" 91 | [ "simple", simple 92 | ; "incremental", incremental 93 | ] 94 | -------------------------------------------------------------------------------- /solutions/ex4.ml: -------------------------------------------------------------------------------- 1 | (* In this exercise, we'll compute the set of stale checks for each 2 | host. Specifically, a check is considered stale if it hasn't been 3 | updated for the last X seconds, for a configured threshold X. 4 | 5 | The all-at-once implementation below should give you a sense of 6 | what the semantics should be, but implementing this efficiently and 7 | incrementally is non-trivial. In particular, if you just use the 8 | current time in a naive way, then you'll have to do work linear in 9 | the number of hosts every time you refresh the computation. 10 | 11 | To do this efficiently, you'll want to use Incremental's support 12 | for time. You'll want to make use of [Incr.advance_clock] and 13 | [Incr.at]. 14 | *) 15 | 16 | open! Core 17 | open! Async 18 | open! Import 19 | 20 | type result = Time.t Check.Name.Map.t Host.Name.Map.t 21 | [@@deriving sexp] 22 | 23 | let print_result x = 24 | print_s [%sexp (x : result)] 25 | 26 | module Simple = struct 27 | let stale_checks (s:State.t) ~(thresh:Time.Span.t) : result = 28 | Map.filter_map s.hosts ~f:(fun (_,check) -> 29 | let map = 30 | Map.filter_map check ~f:(fun (when_registered,_) -> 31 | if Time.Span.(<) (Time.diff s.time when_registered) thresh 32 | then None 33 | else Some when_registered 34 | ) 35 | in 36 | if Map.is_empty map then None else Some map) 37 | 38 | let process_events 39 | ~(thresh:Time.Span.t) 40 | (events : Event.t Pipe.Reader.t) 41 | = 42 | let viewer = Viewer.create ~print:print_result in 43 | let state = ref State.empty in 44 | Pipe.iter' events ~f:(fun eventq -> 45 | state := Queue.fold eventq ~init:!state ~f:State.update; 46 | let stale_checks = Viewer.compute viewer (fun () -> stale_checks ~thresh !state) in 47 | Viewer.update viewer stale_checks; 48 | return () 49 | ) 50 | end 51 | 52 | module Incremental = struct 53 | 54 | let stale_checks (s:State.t Incr.t) ~(thresh:Time.Span.t) : result Incr.t = 55 | let open Incr.Let_syntax in 56 | Incr_map.filter_mapi' (s >>| State.hosts) ~f:(fun ~key:_ ~data -> 57 | let%map map = 58 | Incr_map.filter_mapi' (data >>| snd) ~f:(fun ~key:_ ~data -> 59 | let%bind (time,_) = data in 60 | match%map Incr.at (Time.add time thresh) with 61 | | Before -> None 62 | | After -> Some time 63 | ) 64 | in 65 | if Map.is_empty map then None else Some map 66 | ) 67 | 68 | let process_events 69 | ~(thresh:Time.Span.t) 70 | (events : Event.t Pipe.Reader.t) 71 | : unit Deferred.t 72 | = 73 | let module Var = Incr.Var in 74 | let viewer = Viewer.create ~print:print_result in 75 | let state = Incr.Var.create State.empty in 76 | let result = Incr.observe (stale_checks ~thresh (Incr.Var.watch state)) in 77 | Incr.Observer.on_update_exn result ~f:(function 78 | | Initialized x | Changed (_,x) -> Viewer.update viewer x 79 | | Invalidated -> assert false 80 | ); 81 | Pipe.iter' events ~f:(fun eventq -> 82 | Incr.Var.set state 83 | (Queue.fold eventq ~init:(Var.value state) ~f:State.update); 84 | Incr.advance_clock ~to_:(Incr.Var.value state).time; 85 | Viewer.compute viewer Incr.stabilize; 86 | return () 87 | ) 88 | end 89 | 90 | 91 | let command = 92 | let cmd summary process_events = 93 | Command.async' ~summary 94 | (let open Command.Let_syntax in 95 | [%map_open 96 | let (host, port) = Command_common.host_and_port_param 97 | and thresh = flag "-thresh" (optional_with_default (Time.Span.of_sec 1.) time_span) 98 | ~doc:"Threshold for determing when a host is stale" 99 | in 100 | fun () -> 101 | Command_common.connect_and_process_events ~host ~port 102 | ~process_events:(process_events ~thresh) 103 | ]) 104 | in 105 | Command.group ~summary:"Exercise 4" 106 | [ "simple" , cmd "all-at-once implementation" Simple.process_events 107 | ; "incremental" , cmd "incremental implementation" Incremental.process_events 108 | ] 109 | -------------------------------------------------------------------------------- /solutions/ex5.ml: -------------------------------------------------------------------------------- 1 | (* Compute the nth stalest checks *) 2 | 3 | open! Core 4 | open! Async 5 | open! Import 6 | 7 | (* Note that this is sorted first by time, then by host name *) 8 | module Time_and_host = struct 9 | include Tuple.Make (Time) (Host.Name) 10 | include Tuple.Comparable (Time) (Host.Name) 11 | include Tuple.Sexpable (Time) (Host.Name) 12 | end 13 | 14 | type result = Check.Name.t Time_and_host.Map.t 15 | [@@deriving sexp] 16 | 17 | let print_result x = 18 | print_s [%sexp (x : result)] 19 | 20 | (** Returns the single stalest check from the map of checks *) 21 | let stalest_check (checks : State.checks) = 22 | match Map.to_alist checks with 23 | | [] -> None 24 | | (check,(time,_)) :: rest -> 25 | let (time,check) = 26 | List.fold rest ~init:(time,check) 27 | ~f:(fun ((oldest_time,_) as acc) (check,(time,_)) -> 28 | if time < oldest_time then (time,check) else acc) 29 | in 30 | Some (time,check) 31 | 32 | module Simple = struct 33 | 34 | let hosts_by_staleness (s:State.t) : result = 35 | List.filter_map (Map.to_alist s.hosts) ~f:(fun (host,(_,checks)) -> 36 | match stalest_check checks with 37 | | None -> None 38 | | Some (time,check) -> 39 | Some ((time,host),check)) 40 | |> List.fold ~init:Time_and_host.Map.empty 41 | ~f:(fun acc (key,data) -> Map.add acc ~key ~data) 42 | 43 | let stalest (s:State.t) ~max_count : result = 44 | let result = hosts_by_staleness s in 45 | if Map.length result <= max_count then result 46 | else 47 | Map.to_sequence result 48 | |> (fun s -> Sequence.take s max_count) 49 | |> Sequence.fold ~init:Time_and_host.Map.empty ~f:(fun acc (key,data) -> 50 | Map.add acc ~key ~data) 51 | 52 | let process_events ~(max_count:int) (events : Event.t Pipe.Reader.t) = 53 | let viewer = Viewer.create ~print:print_result in 54 | let state = ref State.empty in 55 | Pipe.iter' events ~f:(fun eventq -> 56 | state := Queue.fold eventq ~init:!state ~f:State.update; 57 | let stalest = Viewer.compute viewer (fun () -> stalest !state ~max_count) in 58 | Viewer.update viewer stalest; 59 | return () 60 | ) 61 | end 62 | 63 | module Incremental = struct 64 | 65 | let hosts_by_staleness (s:State.t Incr.t ) : result Incr.t = 66 | let open Incr.Let_syntax in 67 | Incr_map.unordered_fold (s >>| State.hosts) ~init:Time_and_host.Map.empty 68 | ~f:(fun ~key:host ~data:(_,checks) acc -> 69 | match stalest_check checks with 70 | | None -> acc 71 | | Some (time,check) -> 72 | Map.add acc ~key:(time,host) ~data:check) 73 | ~f_inverse:(fun ~key:host ~data:(_,checks) acc -> 74 | match stalest_check checks with 75 | | None -> acc 76 | | Some (time,_) -> 77 | Map.remove acc (time,host)) 78 | 79 | let stalest (s:State.t Incr.t) ~(max_count:int) : result Incr.t = 80 | let open Incr.Let_syntax in 81 | let%map result = hosts_by_staleness s in 82 | if Map.length result <= max_count then result 83 | else 84 | Map.to_sequence result 85 | |> (fun s -> Sequence.take s max_count) 86 | |> Sequence.fold ~init:Time_and_host.Map.empty ~f:(fun acc (key,data) -> 87 | Map.add acc ~key ~data) 88 | 89 | let process_events ~(max_count:int) (events : Event.t Pipe.Reader.t) = 90 | let module Var = Incr.Var in 91 | let viewer = Viewer.create ~print:print_result in 92 | let state = Incr.Var.create State.empty in 93 | let result = Incr.observe (stalest ~max_count (Incr.Var.watch state)) in 94 | Incr.Observer.on_update_exn result ~f:(function 95 | | Initialized x | Changed (_,x) -> Viewer.update viewer x 96 | | Invalidated -> assert false 97 | ); 98 | Pipe.iter' events ~f:(fun eventq -> 99 | Incr.Var.set state 100 | (Queue.fold eventq ~init:(Var.value state) ~f:State.update); 101 | Viewer.compute viewer Incr.stabilize; 102 | return () 103 | ) 104 | 105 | end 106 | 107 | 108 | let command = 109 | let cmd summary process_events = 110 | Command.async' ~summary 111 | (let open Command.Let_syntax in 112 | [%map_open 113 | let (host, port) = Command_common.host_and_port_param 114 | and max_count = flag "-max-count" (optional_with_default 10 int) 115 | ~doc:"The number of hosts to show" 116 | in 117 | fun () -> 118 | Command_common.connect_and_process_events ~host ~port 119 | ~process_events:(process_events ~max_count) 120 | ]) 121 | in 122 | Command.group ~summary:"Exercise 5" 123 | [ "simple" , cmd "all-at-once implementation" Simple.process_events 124 | ; "incremental" , cmd "incremental implementation" Incremental.process_events 125 | ] 126 | -------------------------------------------------------------------------------- /solutions/ex6.ml: -------------------------------------------------------------------------------- 1 | (* Similarly to exercise 3, we want to display information about failed checks. 2 | 3 | This time we'd like to display the descriptions of all tests that 4 | are currently failing. 5 | 6 | The tricky bit however comes from how we want to represent this: 7 | 8 | You could imagine having a 9 | 10 | {v 11 | string Check.Name.t Host.Name.t Map.t Incr.t 12 | v} 13 | 14 | to represent this, i.e. the outer map (keyed by hostname) 15 | contains a map from check name to description. 16 | 17 | But for the purpose of this exercise, let's represent this as a 18 | /flat/ map of type 19 | 20 | {v 21 | string (Check_name.t * Host.Name.t) Map.t Incr.t 22 | v} 23 | 24 | 25 | *) 26 | 27 | open! Core 28 | open! Async 29 | open! Import 30 | 31 | let print_failure_descriptions c = 32 | print_s [%sexp (c : (Host.Name.t * Check.Name.t, string) Map.Poly.t)] 33 | 34 | module Simple = struct 35 | 36 | let failed_checks (state : State.t) () = 37 | Map.fold ~init:Map.Poly.empty state.hosts ~f:(fun ~key:host_info ~data:(_,checks) acc -> 38 | Map.fold checks ~init:acc ~f:(fun ~key:check_name ~data:(_,outcome) acc -> 39 | match (outcome : Protocol.Check.Outcome.t option) with 40 | | None | Some Passed -> acc 41 | | Some (Failed description) -> 42 | Map.add acc ~key:(host_info, check_name) ~data:description 43 | )) 44 | 45 | let process_events (events : Event.t Pipe.Reader.t) = 46 | let viewer = Viewer.create ~print:print_failure_descriptions in 47 | let state = ref State.empty in 48 | Pipe.iter' events ~f:(fun eventq -> 49 | Queue.iter eventq ~f:(fun event -> 50 | state := State.update !state event); 51 | let update = Viewer.compute viewer (failed_checks !state) in 52 | Viewer.update viewer update; 53 | return () 54 | ) 55 | end 56 | 57 | 58 | module Incremental = struct 59 | open! Incr.Let_syntax 60 | 61 | (* First, let's write a helper function that applies [f] 62 | incrementally to [inc] but keeps track of the input and output of 63 | the last time [f] ran. You will need to use a [ref] here. *) 64 | let diff_map i ~f = 65 | let old = ref None in 66 | let%map a = i in 67 | let b = f ~old:!old a in 68 | old := Some (a, b); 69 | b 70 | 71 | (* Next, let's write the function to flatten [State.t Incr.t] into a 72 | map keyed by [Host.Name.t * Check.Name.t]. (Incr_map has a 73 | [flatten] function built in, but we want to ignore that and write 74 | this from first principals.) 75 | 76 | The basic idea is to use [diff_map] to find all the keys that 77 | were added, removed or changed between the old and current input, 78 | and apply those changes to the old output to get the new output. 79 | 80 | Check out [Map.symmetric diff] for an efficient way of 81 | calculating diffs between maps. *) 82 | let flatten_maps 83 | (mm : State.t Incr.t) 84 | : (Host.Name.t * Check.Name.t,Time.t * Check.Outcome.t option,_) Map.t Incr.t 85 | = 86 | diff_map (mm >>| State.hosts) ~f:(fun ~old input -> 87 | match old with 88 | | None -> 89 | Map.fold input ~init:Map.Poly.empty ~f:(fun ~key:key1 ~data:(_,data) acc -> 90 | Map.fold data ~init:acc ~f:(fun ~key:key2 ~data acc -> 91 | Map.add acc ~key:(key1, key2) ~data)) 92 | | Some (old_input, old_output) -> 93 | let changes = 94 | Sequence.bind 95 | (Map.symmetric_diff ~data_equal:phys_equal old_input input) 96 | ~f:(function 97 | | (key1, `Left (_, m)) -> 98 | Sequence.map (Map.to_sequence m) 99 | ~f:(fun (key2,_) -> `Remove (key1,key2)) 100 | | (key1, `Right (_,m)) -> 101 | Sequence.map (Map.to_sequence m) 102 | ~f:(fun (key2,data) -> `Add ((key1,key2),data)) 103 | | (key1, `Unequal ((_,m1),(_,m2))) -> 104 | Map.symmetric_diff 105 | ~data_equal:(fun (t1,_) (t2,_) -> Time.equal t1 t2) 106 | m1 m2 107 | |> Sequence.bind ~f:(function 108 | | (key2, `Left _) -> Sequence.singleton (`Remove (key1,key2)) 109 | | (key2, `Right d) -> Sequence.singleton (`Add ((key1,key2),d)) 110 | | (key2, `Unequal (_,d2)) -> 111 | Sequence.of_list [`Remove (key1,key2); `Add ((key1,key2),d2)]) 112 | ) 113 | in 114 | Sequence.fold changes ~init:old_output ~f:(fun acc change -> 115 | match change with 116 | | `Add (key,data) -> Map.add acc ~key ~data 117 | | `Remove key -> Map.remove acc key) 118 | ) 119 | 120 | (* Use [flatten_maps] here to compute the final result. *) 121 | let failed_checks (s:State.t Incr.t) : (Host.Name.t * Check.Name.t, string) Map.Poly.t Incr.t = 122 | Incr_map.filter_mapi (flatten_maps s) ~f:(fun ~key:_ ~data:(_,check_opt) -> 123 | match check_opt with 124 | | None | Some Passed -> None 125 | | Some (Failed desc) -> Some desc 126 | ) 127 | 128 | (* The structure of process_events will be fairly similar to the 129 | corresponding function in exercise 3 *) 130 | 131 | let process_events (events : Event.t Pipe.Reader.t) : unit Deferred.t = 132 | let viewer = Viewer.create ~print:print_failure_descriptions in 133 | let state = Incr.Var.create State.empty in 134 | let result = Incr.observe (failed_checks (Incr.Var.watch state)) in 135 | Incr.Observer.on_update_exn result ~f:(fun update -> 136 | match update with 137 | | Initialized x | Changed (_,x) -> Viewer.update viewer x 138 | | Invalidated -> assert false 139 | ); 140 | Pipe.iter' events ~f:(fun eventq -> 141 | Incr.Var.set state (Queue.fold eventq ~init:(Incr.Var.value state) ~f:State.update); 142 | Viewer.compute viewer Incr.stabilize; 143 | Deferred.return () 144 | ) 145 | 146 | end 147 | 148 | 149 | 150 | (* Command line setup *) 151 | 152 | let build_command ~summary process_events = 153 | Command.async' ~summary 154 | (let open Command.Let_syntax in 155 | [%map_open 156 | let (host, port) = Command_common.host_and_port_param in 157 | fun () -> 158 | Command_common.connect_and_process_events 159 | ~process_events ~host ~port 160 | ]) 161 | 162 | let simple = 163 | build_command ~summary:"Simple, all-at-once implementation" 164 | Simple.process_events 165 | 166 | let incremental = 167 | build_command ~summary:"Incremental implementation" 168 | Incremental.process_events 169 | 170 | let command = 171 | Command.group ~summary:"Exercise 6" 172 | [ "simple", simple 173 | ; "incremental", incremental 174 | ] 175 | -------------------------------------------------------------------------------- /solutions/generic_flatten.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | open Incr.Let_syntax 4 | 5 | let diff_map i ~f = 6 | let old = ref None in 7 | let%map a = i in 8 | let b = f ~old:!old a in 9 | old := Some (a, b); 10 | b 11 | 12 | let flatten_maps 13 | (type key1) (type key2) 14 | (mm : (key1, (key2,'data, _) Map.t, _) Map.t Incr.t) 15 | ~(empty : ((key1 * key2), _,_) Map.t) 16 | ~(data_equal: 'data -> 'data -> bool) 17 | : (key1 * key2,'data,_) Map.t Incr.t 18 | = 19 | diff_map mm ~f:(fun ~old input -> 20 | match old with 21 | | None -> 22 | Map.fold input ~init:empty ~f:(fun ~key:key1 ~data acc -> 23 | Map.fold data ~init:acc ~f:(fun ~key:key2 ~data acc -> 24 | Map.add acc ~key:(key1, key2) ~data)) 25 | | Some (old_input, old_output) -> 26 | let changes = 27 | Sequence.bind 28 | (Map.symmetric_diff ~data_equal:phys_equal old_input input) 29 | ~f:(function 30 | | (key1, `Left m) -> 31 | Sequence.map (Map.to_sequence m) 32 | ~f:(fun (key2,_) -> `Remove (key1,key2)) 33 | | (key1, `Right m) -> 34 | Sequence.map (Map.to_sequence m) 35 | ~f:(fun (key2,data) -> `Add ((key1,key2),data)) 36 | | (key1, `Unequal (m1,m2)) -> 37 | Map.symmetric_diff ~data_equal m1 m2 38 | |> Sequence.bind ~f:(function 39 | | (key2, `Left _) -> Sequence.singleton (`Remove (key1,key2)) 40 | | (key2, `Right d) -> Sequence.singleton (`Add ((key1,key2),d)) 41 | | (key2, `Unequal (_,d2)) -> 42 | Sequence.of_list [`Remove (key1,key2); `Add ((key1,key2),d2)]) 43 | ) 44 | in 45 | Sequence.fold changes ~init:old_output ~f:(fun acc change -> 46 | match change with 47 | | `Add (key,data) -> Map.add acc ~key ~data 48 | | `Remove key -> Map.remove acc key) 49 | ) 50 | 51 | let failed_checks (state : State.t Incr.t) = 52 | Incr_map.mapi' state ~f:(fun ~key:_ ~data -> 53 | Incr_map.filter_mapi (data >>| snd) ~f:(fun ~key:_ ~data:(_,check) -> 54 | match check with 55 | | Some (Failed s) -> Some s 56 | | Some Passed | None -> None)) 57 | |> flatten_maps ~empty:Map.Poly.empty ~data_equal:String.equal 58 | -------------------------------------------------------------------------------- /solutions/import.ml: -------------------------------------------------------------------------------- 1 | include Tutorial_shared 2 | -------------------------------------------------------------------------------- /solutions/jbuild: -------------------------------------------------------------------------------- 1 | ;; -*- scheme -*- 2 | 3 | (jbuild_version 1) 4 | 5 | (executables 6 | ((names (main)) 7 | (libraries 8 | (tutorial_shared)) 9 | (preprocess (pps (ppx_jane))) 10 | )) 11 | 12 | -------------------------------------------------------------------------------- /solutions/main.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | let () = 5 | Command.group 6 | ~summary:"Command line API" 7 | [ "server", Server.command 8 | ; "ex1", Ex1.command 9 | ; "ex2", Ex2.command 10 | ; "ex3", Ex3.command 11 | ; "ex4", Ex4.command 12 | ; "ex5", Ex5.command 13 | ; "ex6", Ex6.command 14 | ] 15 | |> Command.run 16 | -------------------------------------------------------------------------------- /solutions/scratch.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | open! Incr.Let_syntax 4 | 5 | (* For playing with examples that don't fit anywhere else. *) 6 | --------------------------------------------------------------------------------