├── .gitignore ├── .ocamlformat ├── README.md ├── TODO.md ├── config.ml ├── create.sh ├── dune-project ├── http_mirage_client.ml ├── http_mirage_client.mli ├── irmin_io.ml ├── irmin_io.mli ├── matches.ml ├── matches.mli ├── schedule.ml ├── schedule.mli ├── slack_api.ml ├── slack_api.mli └── unikernel.ml /.gitignore: -------------------------------------------------------------------------------- 1 | nix_deployment/* 2 | config 3 | _build/ 4 | .merlin 5 | mirage/ 6 | **/Makefile 7 | duniverse/* 8 | dist/* 9 | dev/ 10 | dune-workspace 11 | dune.config 12 | dune.build 13 | dune 14 | config_env.sh 15 | notes.txt 16 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.24.1 2 | parse-docstrings=true 3 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Coffeeeeee 2 | 3 | Coffee is good. And colleagues are the best. 4 | 5 | ## What this unikernel does 6 | 7 | It sends a message to your Slack channel `$CHANNEL` every other Monday to ask who wants to have a coffee chat this week. It then sends another message on Tuesday containing the necessary info for this week's coffee chats: everyone who's opted in (by reacting to the first message) is randomly matched with someone else who has opted in. The unikernel is smarter than purely random though: it tries to avoid repeats with past matches. 8 | 9 | ## How to build this unikernel 10 | 11 | If you have the right env variables (notice: if they're stored in a file called `config_env.sh`, they'll be set automatically), you can build this coffee chat unikernel via `create.sh unikernel coffee `. 12 | 13 | ## Accessibility 14 | 15 | This bot is currently badly designed in terms of accessibility: the way to interact with the bot, is to react to a Slack message. Not every Slack user can react to a Slack message though. There's an item on the TODO list to improve accessibility (it's marked as highest priority). It's highly appreciated, if anyone wants to pick it up and open a PR! In the meanwhile, the workaround is that users who can't react to Slack messages, can use a bot that reacts for them. For that, open an issue, so that your bot's ID will be turned into your Slack ID when parsing the reactions. Then, you can run the following `curl` command to opt-in: 16 | 17 | ``` 18 | curl -d "channel=" -d "name=hand" -d "timestamp=" -H "Authorization: Bearer " -X POST https://slack.com/api/reactions.add 19 | ``` 20 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | # TODO 2 | 3 | - (highest priority): make the bot sustainably accessible (currently, accessibility is only given via a "small hack"). 4 | concretely, add communication with the bot: 5 | - [join]: triggers opting in. it's the same as reacting to the opt-in message 6 | - [leave]: triggers opting back out again (i.e. one has opted in, but wants to opt-out again). it's the same as un-reacting to the opt-int message 7 | - [status]: shows the current status of the bot; i.e. 8 | - "next opt-in message will be on ..." 9 | - "we're currently in opt-in phase. so far, the people who have opted in are ..." 10 | - new feature: write a private message to each matched couple/triple proposing a time for their chat 11 | - new feature: avoid matching two people at the same office 12 | - use upstream `httpaf` (it's released now) instead of "vendoring" it into http_mirage_client.{ml,mli} 13 | - improve `create.sh`. to start with, write it in OCaml 14 | - have a look at the TODOs and FIXMEs in the code 15 | - improve the logging and error messages and make them more coherent 16 | -------------------------------------------------------------------------------- /config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | type http_client = HTTP_client 4 | 5 | let http_client = typ HTTP_client 6 | 7 | let token = 8 | let doc = Key.Arg.info ~doc:"slack bot token" [ "token" ] in 9 | Key.(create "token" Arg.(required string doc)) 10 | 11 | let remote = 12 | let doc = Key.Arg.info ~doc:"Remote Git repository." [ "r"; "remote" ] in 13 | Key.(create "remote" Arg.(required string doc)) 14 | 15 | let num_iter = 16 | let doc = 17 | Key.Arg.info ~doc:"Number of iterations to find matches." [ "num-iter" ] 18 | in 19 | Key.(create "num-iter" Arg.(required int doc)) 20 | 21 | let channel = 22 | let doc = 23 | Key.Arg.info ~doc:"ID of the channel to send the messages to" [ "channel" ] 24 | in 25 | Key.(create "channel" Arg.(required string doc)) 26 | 27 | let ssh_key = 28 | let doc = 29 | Key.Arg.info ~doc:"Private ssh key (rsa: or ed25519:)." 30 | [ "ssh-key" ] 31 | in 32 | Key.(create "ssh-key" Arg.(opt (some string) None doc)) 33 | 34 | let ssh_authenticator = 35 | let doc = 36 | Key.Arg.info ~doc:"SSH host key authenticator." [ "ssh-authenticator" ] 37 | in 38 | Key.(create "ssh_authenticator" Arg.(opt (some string) None doc)) 39 | 40 | let tls_authenticator = 41 | let doc = 42 | Key.Arg.info ~doc:"TLS host authenticator." [ "tls-authenticator" ] 43 | in 44 | Key.(create "https_authenticator" Arg.(opt (some string) None doc)) 45 | 46 | let nameservers = 47 | let doc = Key.Arg.info ~doc:"Nameserver." [ "nameserver" ] in 48 | Key.(create "nameserver" Arg.(opt_all string doc)) 49 | 50 | let bot_id = 51 | let doc = Key.Arg.info ~doc:"ID of coffee bot." [ "bot-id" ] in 52 | Key.(create "bot-id" Arg.(required string doc)) 53 | 54 | let curl_user_id = 55 | let doc = 56 | Key.Arg.info 57 | ~doc: 58 | "User ID of a user who can only react to a Slack message via an http \ 59 | request. That user can use the bot itself to react. The bot ID will \ 60 | be turned into the user's ID." 61 | [ "curl-user-id" ] 62 | in 63 | Key.(create "curl-user-id" Arg.(opt (some string) None doc)) 64 | 65 | let test = 66 | let doc = 67 | Key.Arg.info 68 | ~doc: 69 | "Send opt-in message directly and then wait for one min to fetch \ 70 | reactions and to send matches (as opposed to waiting for Monday and \ 71 | Tuesday)." 72 | [ "test" ] 73 | in 74 | Key.(create "test" Arg.(required bool doc)) 75 | 76 | let client = 77 | let packages = 78 | [ 79 | package "cohttp-mirage"; 80 | package "duration"; 81 | package "yojson"; 82 | package "ptime"; 83 | (* package "irmin"; *) 84 | (* package "irmin-mirage"; *) 85 | package "irmin-mirage-git"; 86 | (* package "git-mirage"; *) 87 | (* package "git-cohttp-mirage"; *) 88 | package ~sublibs:[] "ppx_deriving"; 89 | package ~sublibs:[] "ppx_deriving_yojson"; 90 | ] 91 | in 92 | main 93 | ~keys: 94 | [ 95 | key token; 96 | key channel; 97 | key remote; 98 | key num_iter; 99 | key nameservers; 100 | key curl_user_id; 101 | key bot_id; 102 | key test; 103 | ] 104 | ~packages "Unikernel.Client" 105 | @@ http_client @-> time @-> pclock @-> random @-> git_client @-> job 106 | 107 | let http_client = 108 | let connect _ modname = function 109 | | [ _time; _pclock; _tcpv4v6; ctx ] -> 110 | Fmt.str {ocaml|%s.connect %s|ocaml} modname ctx 111 | | _ -> assert false 112 | in 113 | let packages = [ package "httpaf"; package "h2"; package "paf" ] in 114 | impl ~packages ~connect "Http_mirage_client.Make" 115 | (time @-> pclock @-> tcpv4v6 @-> git_client @-> http_client) 116 | 117 | let stack = generic_stackv4v6 default_network 118 | let dns = generic_dns_client ~nameservers stack 119 | 120 | let git, http = 121 | let happy_eyeballs = 122 | git_happy_eyeballs stack dns (generic_happy_eyeballs stack dns) 123 | in 124 | let tcp = tcpv4v6_of_stackv4v6 stack in 125 | ( merge_git_clients 126 | (git_tcp tcp happy_eyeballs) 127 | (merge_git_clients 128 | (git_ssh ~key:ssh_key ~authenticator:ssh_authenticator tcp 129 | happy_eyeballs) 130 | (git_http ~authenticator:tls_authenticator tcp happy_eyeballs)), 131 | http_client $ default_time $ default_posix_clock 132 | $ tcpv4v6_of_stackv4v6 stack $ happy_eyeballs ) 133 | 134 | let () = 135 | let job = 136 | [ 137 | client $ http $ default_time $ default_posix_clock $ default_random $ git; 138 | ] 139 | in 140 | register "coffee-chats" job 141 | -------------------------------------------------------------------------------- /create.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -euo pipefail 3 | 4 | mirage_stuff () { 5 | mirage config -t "$TARGET" --dhcp "$DHCP" --token "$COFFEE_TOKEN" --ssh-key "$SSH" --channel "$CHANNEL" --remote "$REMOTE" --num-iter "$NUM_ITER" --test "$IS_TEST" --curl-user-id "$CURL_USER_ID" --bot-id "$COFFEE_ID" 6 | make depend 7 | sed -i 's/main)/main) (preprocess (pps ppx_deriving_yojson))/g' dune.build # currently, the mirage config doesn't add ppxs to dune.build 8 | mirage build 9 | } 10 | 11 | unikernel () { 12 | eval "$(opam env)" 13 | source ./config_env.sh 14 | case $1 in 15 | test) 16 | export CHANNEL=$TEST_CHANNEL 17 | export REMOTE=$TEST_REMOTE 18 | export NUM_ITER=1000 19 | export IS_TEST="true" 20 | ;; 21 | coffee) 22 | export CHANNEL=$COFFEE_CHANNEL 23 | export REMOTE=$COFFEE_REMOTE 24 | export NUM_ITER=100000000 25 | export IS_TEST="false" 26 | ;; 27 | *) 28 | echo "Do you want a real coffee or a test coffee?" 29 | exit 1 30 | esac 31 | case $2 in 32 | unix) 33 | export TARGET="unix" 34 | export DHCP="false" 35 | mirage_stuff 36 | ;; 37 | hvt) 38 | export TARGET="hvt" 39 | export DHCP="false" 40 | mirage_stuff 41 | ;; 42 | virtio) 43 | export TARGET="virtio" 44 | export DHCP="true" 45 | mirage_stuff 46 | "$VIRTIO_MKIMAGE" -f tar -- dist/disk.raw.tar.gz dist/coffee-chats.virtio 47 | ;; 48 | *) 49 | echo "What's the target for your coffee? Mug or glass?" 50 | esac 51 | } 52 | 53 | network () { 54 | sudo ip tuntap add tap0 mode tap # add a new network interface called tap0 55 | sudo ip addr add 10.0.0.1/24 dev tap0 # assign IP 10.0.0.1/24 to network interface tap0 56 | sudo ip link set tap0 up # enable network interface tap0 57 | sudo iptables -I FORWARD -i tap0 -o wlp0s20f3 -j ACCEPT # add rule to forward chain to forward all packets from tap0 to wifi interface 58 | sudo iptables -I FORWARD -i wlp0s20f3 -o tap0 -m state --state ESTABLISHED,RELATED -j ACCEPT # add rule to forward chain to forward all packets from wifi interface to tap0 59 | sudo iptables -t nat -A POSTROUTING -o wlp0s20f3 -j MASQUERADE # tweak the target IP of response package from unikernel IP to hostsystem IP: "masquerading" 60 | } 61 | 62 | case $1 in 63 | unikernel) 64 | unikernel "$2" "$3";; 65 | network) 66 | network;; 67 | spawn_hvt) 68 | eval "$(opam env)" 69 | solo5-hvt --net:service=tap0 dist/coffee-chats.hvt --ipv4=10.0.0.2/24 --ipv4-gateway=10.0.0.1;; 70 | *) 71 | echo "try $./create.sh unikernel test unix" 72 | exit 1 73 | esac 74 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | 3 | (name slack_bot) 4 | 5 | (authors 6 | "Gargi Sharma " 7 | "Sonja Heinze ") 8 | 9 | (package 10 | (name slack_bot)) 11 | -------------------------------------------------------------------------------- /http_mirage_client.ml: -------------------------------------------------------------------------------- 1 | let http_scheme = Mimic.make ~name:"http-scheme" 2 | let http_port = Mimic.make ~name:"http-port" 3 | let http_hostname = Mimic.make ~name:"http-hostname" 4 | let http_sleep = Mimic.make ~name:"http-sleep" 5 | let tls_config = Mimic.make ~name:"tls-config" 6 | 7 | open Lwt.Infix 8 | 9 | module type S = sig 10 | val connect : Mimic.ctx -> Mimic.ctx Lwt.t 11 | val alpn_protocol : Mimic.flow -> string option 12 | val authenticator : (X509.Authenticator.t, [> `Msg of string ]) result 13 | end 14 | 15 | module Make 16 | (Time : Mirage_time.S) 17 | (Pclock : Mirage_clock.PCLOCK) 18 | (TCP : Tcpip.Tcp.S) 19 | (Happy_eyeballs : Mimic_happy_eyeballs.S with type flow = TCP.flow) : S = 20 | struct 21 | module TCP = struct 22 | include TCP 23 | 24 | type endpoint = Happy_eyeballs.t * string * int 25 | 26 | type nonrec write_error = 27 | [ `Write of write_error | `Connect of string | `Closed ] 28 | 29 | let pp_write_error ppf = function 30 | | `Connect err -> Fmt.string ppf err 31 | | `Write err -> pp_write_error ppf err 32 | | `Closed as err -> pp_write_error ppf err 33 | 34 | let write flow cs = 35 | let open Lwt.Infix in 36 | write flow cs >>= function 37 | | Ok _ as v -> Lwt.return v 38 | | Error err -> Lwt.return_error (`Write err) 39 | 40 | let writev flow css = 41 | writev flow css >>= function 42 | | Ok _ as v -> Lwt.return v 43 | | Error err -> Lwt.return_error (`Write err) 44 | 45 | let connect (happy_eyeballs, hostname, port) = 46 | Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function 47 | | Error (`Msg err) -> Lwt.return_error (`Connect err) 48 | | Ok ((_ipaddr, _port), flow) -> Lwt.return_ok flow 49 | end 50 | 51 | let tcp_edn, _tcp_protocol = Mimic.register ~name:"tcp" (module TCP) 52 | 53 | module TLS = struct 54 | type endpoint = Happy_eyeballs.t * Tls.Config.client * string * int 55 | 56 | include Tls_mirage.Make (TCP) 57 | 58 | let connect (happy_eyeballs, cfg, hostname, port) = 59 | let peer_name = 60 | Result.( 61 | to_option (bind (Domain_name.of_string hostname) Domain_name.host)) 62 | in 63 | Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function 64 | | Ok ((_ipaddr, _port), flow) -> client_of_flow cfg ?host:peer_name flow 65 | | Error (`Msg err) -> Lwt.return_error (`Write (`Connect err)) 66 | end 67 | 68 | let tls_edn, tls_protocol = Mimic.register ~name:"tls" (module TLS) 69 | 70 | let connect ctx = 71 | let k0 happy_eyeballs http_scheme http_hostname http_port = 72 | match http_scheme with 73 | | "http" -> Lwt.return_some (happy_eyeballs, http_hostname, http_port) 74 | | _ -> Lwt.return_none 75 | in 76 | let k1 happy_eyeballs http_scheme http_hostname http_port tls_config = 77 | match http_scheme with 78 | | "https" -> 79 | Lwt.return_some (happy_eyeballs, tls_config, http_hostname, http_port) 80 | | _ -> Lwt.return_none 81 | in 82 | let ctx = 83 | Mimic.fold tcp_edn 84 | Mimic.Fun. 85 | [ 86 | req Happy_eyeballs.happy_eyeballs; 87 | req http_scheme; 88 | req http_hostname; 89 | dft http_port 80; 90 | ] 91 | ~k:k0 ctx 92 | in 93 | let ctx = 94 | Mimic.fold tls_edn 95 | Mimic.Fun. 96 | [ 97 | req Happy_eyeballs.happy_eyeballs; 98 | req http_scheme; 99 | req http_hostname; 100 | dft http_port 443; 101 | req tls_config; 102 | ] 103 | ~k:k1 ctx 104 | in 105 | Lwt.return (Mimic.add http_sleep Time.sleep_ns ctx) 106 | 107 | let alpn_protocol flow = 108 | let module M = (val Mimic.repr tls_protocol) in 109 | match flow with 110 | | M.T flow -> ( 111 | match TLS.epoch flow with 112 | | Ok { Tls.Core.alpn_protocol; _ } -> alpn_protocol 113 | | Error _ -> None) 114 | | _ -> None 115 | 116 | let authenticator = 117 | let module V = Ca_certs_nss.Make (Pclock) in 118 | V.authenticator () 119 | end 120 | 121 | module Version = Httpaf.Version 122 | module Status = H2.Status 123 | module Headers = H2.Headers 124 | 125 | type response = { 126 | version : Version.t; 127 | status : Status.t; 128 | reason : string; 129 | headers : Headers.t; 130 | } 131 | 132 | module HTTP_1_1 = struct 133 | include Httpaf.Client_connection 134 | 135 | let yield_reader _ = assert false 136 | 137 | let next_read_operation t = 138 | (next_read_operation t :> [ `Close | `Read | `Yield ]) 139 | end 140 | 141 | let add_authentication ~add headers = function 142 | | None -> headers 143 | | Some (user, pass) -> 144 | let data = Base64.encode_string (user ^ ":" ^ pass) in 145 | add headers "authorization" ("Basic " ^ data) 146 | 147 | let prepare_http_1_1_headers headers host user_pass body_length = 148 | let headers = Httpaf.Headers.of_list headers in 149 | let add = Httpaf.Headers.add_unless_exists in 150 | let headers = add headers "user-agent" "http-mirage-client/%%VERSION%%" in 151 | let headers = add headers "host" host in 152 | let headers = add headers "connection" "close" in 153 | let headers = 154 | match body_length with 155 | | None -> headers 156 | | Some v -> add headers "content-length" (string_of_int v) 157 | in 158 | add_authentication ~add headers user_pass 159 | 160 | let single_http_1_1_request ~sleep ?config flow user_pass host meth path headers 161 | body = 162 | let body_length = Option.map String.length body in 163 | let headers = prepare_http_1_1_headers headers host user_pass body_length in 164 | let req = Httpaf.Request.create ~headers meth path in 165 | let finished, notify_finished = Lwt.wait () in 166 | let wakeup = 167 | let w = ref false in 168 | fun v -> 169 | if not !w then Lwt.wakeup_later notify_finished v; 170 | w := true 171 | in 172 | let response_handler response body = 173 | let buf = Buffer.create 0x100 in 174 | let rec on_eof () = 175 | let response = 176 | { 177 | version = response.Httpaf.Response.version; 178 | status = (response.Httpaf.Response.status :> H2.Status.t); 179 | reason = response.Httpaf.Response.reason; 180 | headers = 181 | H2.Headers.of_list 182 | (Httpaf.Headers.to_list response.Httpaf.Response.headers); 183 | } 184 | in 185 | wakeup (Ok (response, Some (Buffer.contents buf))) 186 | and on_read ba ~off ~len = 187 | Buffer.add_string buf (Bigstringaf.substring ~off ~len ba); 188 | Httpaf.Body.schedule_read body ~on_read ~on_eof 189 | in 190 | let on_eof () = 191 | let response = 192 | { 193 | version = response.Httpaf.Response.version; 194 | status = (response.Httpaf.Response.status :> H2.Status.t); 195 | reason = response.Httpaf.Response.reason; 196 | headers = 197 | H2.Headers.of_list 198 | (Httpaf.Headers.to_list response.Httpaf.Response.headers); 199 | } 200 | in 201 | wakeup (Ok (response, None)) 202 | in 203 | Httpaf.Body.schedule_read body ~on_read ~on_eof 204 | in 205 | let error_handler e = 206 | let err = 207 | match e with 208 | | `Malformed_response x -> Error (`Msg ("Malformed response: " ^ x)) 209 | | `Invalid_response_body_length _ -> 210 | Error (`Msg "Invalid response body length") 211 | | `Exn e -> Error (`Msg ("Exception here: " ^ Printexc.to_string e)) 212 | in 213 | wakeup err 214 | in 215 | let request_body, conn = 216 | Httpaf.Client_connection.request ?config req ~error_handler 217 | ~response_handler 218 | in 219 | Lwt.async (fun () -> Paf.run (module HTTP_1_1) ~sleep conn flow); 220 | Option.iter (Httpaf.Body.write_string request_body) body; 221 | Httpaf.Body.close_writer request_body; 222 | finished 223 | 224 | let prepare_h2_headers headers host user_pass body_length = 225 | let headers = H2.Headers.of_list headers in 226 | let add hdr = H2.Headers.add_unless_exists hdr ?sensitive:None in 227 | let headers = add headers ":authority" host in 228 | let headers = 229 | add headers "content-length" 230 | (string_of_int (Option.value ~default:0 body_length)) 231 | in 232 | add_authentication ~add headers user_pass 233 | 234 | let single_h2_request ~sleep ?config ~scheme flow user_pass host meth path 235 | headers body = 236 | let body_length = Option.map String.length body in 237 | let headers = prepare_h2_headers headers host user_pass body_length in 238 | let req = H2.Request.create ~scheme ~headers meth path in 239 | let finished, notify_finished = Lwt.wait () in 240 | let wakeup = 241 | let w = ref false in 242 | fun v -> 243 | if not !w then Lwt.wakeup_later notify_finished v; 244 | w := true 245 | in 246 | let response_handler response response_body = 247 | let buf = Buffer.create 0x100 in 248 | let rec on_eof () = 249 | let response = 250 | { 251 | version = { major = 2; minor = 0 }; 252 | status = response.H2.Response.status; 253 | reason = ""; 254 | headers = response.H2.Response.headers; 255 | } 256 | in 257 | wakeup (Ok (response, Some (Buffer.contents buf))) 258 | and on_read ba ~off ~len = 259 | Buffer.add_string buf (Bigstringaf.substring ~off ~len ba); 260 | H2.Body.Reader.schedule_read response_body ~on_read ~on_eof 261 | in 262 | let on_eof () = 263 | let response = 264 | { 265 | version = { major = 2; minor = 0 }; 266 | status = response.H2.Response.status; 267 | reason = ""; 268 | headers = response.H2.Response.headers; 269 | } 270 | in 271 | wakeup (Ok (response, None)) 272 | in 273 | H2.Body.Reader.schedule_read response_body ~on_read ~on_eof 274 | in 275 | let error_handler e = 276 | let err = 277 | match e with 278 | | `Malformed_response x -> Error (`Msg ("Malformed response: " ^ x)) 279 | | `Invalid_response_body_length _ -> 280 | Error (`Msg "Invalid response body length") 281 | | `Protocol_error (err, msg) -> 282 | let kerr _ = Error (`Msg (Format.flush_str_formatter ())) in 283 | Format.kfprintf kerr Format.str_formatter "%a: %s" 284 | H2.Error_code.pp_hum err msg 285 | | `Exn e -> Error (`Msg ("Exception here: " ^ Printexc.to_string e)) 286 | in 287 | wakeup err 288 | in 289 | let conn = 290 | H2.Client_connection.create ?config ?push_handler:None ~error_handler 291 | in 292 | let request_body = 293 | H2.Client_connection.request conn req ~error_handler ~response_handler 294 | in 295 | Lwt.async (fun () -> Paf.run (module H2.Client_connection) ~sleep conn flow); 296 | Option.iter (H2.Body.Writer.write_string request_body) body; 297 | H2.Body.Writer.close request_body; 298 | finished >|= fun v -> 299 | H2.Client_connection.shutdown conn; 300 | v 301 | 302 | let decode_uri ~ctx uri = 303 | let ( >>= ) = Result.bind in 304 | match String.split_on_char '/' uri with 305 | | proto :: "" :: user_pass_host_port :: path -> 306 | (if String.equal proto "http:" then 307 | Ok ("http", Mimic.add http_scheme "http" ctx) 308 | else if String.equal proto "https:" then 309 | Ok ("https", Mimic.add http_scheme "https" ctx) 310 | else Error (`Msg "Couldn't decode user and password")) 311 | >>= fun (scheme, ctx) -> 312 | let decode_user_pass up = 313 | match String.split_on_char ':' up with 314 | | [ user; pass ] -> Ok (user, pass) 315 | | _ -> Error (`Msg "Couldn't decode user and password") 316 | in 317 | (match String.split_on_char '@' user_pass_host_port with 318 | | [ host_port ] -> Ok (None, host_port) 319 | | [ user_pass; host_port ] -> 320 | decode_user_pass user_pass >>= fun up -> Ok (Some up, host_port) 321 | | _ -> Error (`Msg "Couldn't decode URI")) 322 | >>= fun (user_pass, host_port) -> 323 | (match String.split_on_char ':' host_port with 324 | | [] -> Error (`Msg "Empty host & port") 325 | | [ hostname ] -> Ok (hostname, Mimic.add http_hostname hostname ctx) 326 | | hd :: tl -> ( 327 | let port, hostname = 328 | match List.rev (hd :: tl) with 329 | | hd :: tl -> (hd, String.concat ":" (List.rev tl)) 330 | | _ -> assert false 331 | in 332 | try 333 | Ok 334 | ( hostname, 335 | Mimic.add http_hostname hostname 336 | (Mimic.add http_port (int_of_string port) ctx) ) 337 | with Failure _ -> Error (`Msg "Couldn't decode port"))) 338 | >>= fun (hostname, ctx) -> 339 | Ok (ctx, scheme, hostname, user_pass, "/" ^ String.concat "/" path) 340 | | _ -> Error (`Msg "Couldn't decode URI on top") 341 | 342 | let ( >>? ) = Lwt_result.bind 343 | 344 | let alpn_protocol_of_string = function 345 | | "http/1.1" -> Some `HTTP_1_1 346 | | "h2" -> Some `H2 347 | | _ -> None 348 | 349 | let single_request ~ctx ~alpn_protocol ?config cfg ~meth ~headers ?body uri = 350 | let sleep = Option.get (Mimic.get http_sleep ctx) in 351 | Lwt.return (decode_uri ~ctx uri) 352 | >>? fun (ctx, scheme, host, user_pass, path) -> 353 | let ctx = 354 | match Lazy.force cfg with 355 | | Ok (`Custom cfg) -> Mimic.add tls_config cfg ctx 356 | | Ok (`Default cfg) -> ( 357 | match Result.bind (Domain_name.of_string host) Domain_name.host with 358 | | Ok peer -> Mimic.add tls_config (Tls.Config.peer cfg peer) ctx 359 | | Error _ -> Mimic.add tls_config cfg ctx) 360 | | Error _ -> ctx 361 | in 362 | Mimic.resolve ctx >>? fun flow -> 363 | (match (Option.bind (alpn_protocol flow) alpn_protocol_of_string, config) with 364 | | (Some `HTTP_1_1 | None), Some (`HTTP_1_1 config) -> 365 | single_http_1_1_request ~sleep ~config flow user_pass host meth path 366 | headers body 367 | | (Some `HTTP_1_1 | None), None -> 368 | single_http_1_1_request ~sleep flow user_pass host meth path headers body 369 | | (Some `H2 | None), Some (`H2 config) -> 370 | single_h2_request ~sleep ~config ~scheme flow user_pass host meth path 371 | headers body 372 | | Some `H2, None -> 373 | single_h2_request ~sleep ~scheme flow user_pass host meth path headers 374 | body 375 | | Some `H2, Some (`HTTP_1_1 _) -> 376 | single_h2_request ~sleep ~scheme flow user_pass host meth path headers 377 | body 378 | | Some `HTTP_1_1, Some (`H2 _) -> 379 | single_http_1_1_request ~sleep flow user_pass host meth path headers body) 380 | >>= fun r -> 381 | Mimic.close flow >|= fun () -> r 382 | 383 | let tls_config ?tls_config ?config authenticator = 384 | lazy 385 | (match tls_config with 386 | | Some cfg -> Ok (`Custom cfg) 387 | | None -> 388 | let alpn_protocols = 389 | match config with 390 | | None -> [ "h2"; "http/1.1" ] 391 | | Some (`H2 _) -> [ "h2" ] 392 | | Some (`HTTP_1_1 _) -> [ "http/1.1" ] 393 | in 394 | Result.map 395 | (fun authenticator -> 396 | `Default (Tls.Config.client ~alpn_protocols ~authenticator ())) 397 | authenticator) 398 | 399 | let resolve_location ~uri ~location = 400 | match String.split_on_char '/' location with 401 | | "http:" :: "" :: _ -> Ok location 402 | | "https:" :: "" :: _ -> Ok location 403 | | "" :: "" :: _ -> 404 | let schema = String.sub uri 0 (String.index uri '/') in 405 | Ok (schema ^ location) 406 | | "" :: _ -> ( 407 | match String.split_on_char '/' uri with 408 | | schema :: "" :: user_pass_host_port :: _ -> 409 | Ok (String.concat "/" [ schema; ""; user_pass_host_port ^ location ]) 410 | | _ -> Error (`Msg ("expected an absolute uri, got: " ^ uri))) 411 | | _ -> Error (`Msg ("unknown location (relative path): " ^ location)) 412 | 413 | let one_request ?config ?tls_config:cfg ~ctx ~alpn_protocol ~authenticator 414 | ?(meth = `GET) ?(headers = []) ?body ?(max_redirect = 5) 415 | ?(follow_redirect = true) uri = 416 | let tls_config = tls_config ?tls_config:cfg ?config authenticator in 417 | if not follow_redirect then 418 | single_request ~ctx ~alpn_protocol ?config tls_config ~meth ~headers ?body 419 | uri 420 | else 421 | let rec follow_redirect count uri = 422 | if count = 0 then Lwt.return_error (`Msg "Redirect limit exceeded") 423 | else 424 | single_request ~ctx ~alpn_protocol ?config tls_config ~meth ~headers 425 | ?body uri 426 | >>? fun (resp, body) -> 427 | if Status.is_redirection resp.status then 428 | match Headers.get resp.headers "location" with 429 | | Some location -> 430 | Lwt.return (resolve_location ~uri ~location) >>? fun uri -> 431 | follow_redirect (pred count) uri 432 | | None -> Lwt.return_ok (resp, body) 433 | else Lwt.return_ok (resp, body) 434 | in 435 | follow_redirect max_redirect uri 436 | -------------------------------------------------------------------------------- /http_mirage_client.mli: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | val connect : Mimic.ctx -> Mimic.ctx Lwt.t 3 | val alpn_protocol : Mimic.flow -> string option 4 | val authenticator : (X509.Authenticator.t, [> `Msg of string ]) result 5 | end 6 | 7 | module Make 8 | (Time : Mirage_time.S) 9 | (Pclock : Mirage_clock.PCLOCK) 10 | (TCP : Tcpip.Tcp.S) 11 | (Happy_eyeballs : Mimic_happy_eyeballs.S with type flow = TCP.flow) : S 12 | 13 | module Version = Httpaf.Version 14 | module Status = H2.Status 15 | module Headers = H2.Headers 16 | 17 | type response = { 18 | version : Version.t; 19 | status : Status.t; 20 | reason : string; 21 | headers : Headers.t; 22 | } 23 | 24 | val one_request : 25 | ?config:[ `H2 of H2.Config.t | `HTTP_1_1 of Httpaf.Config.t ] -> 26 | ?tls_config:Tls.Config.client -> 27 | ctx:Mimic.ctx -> 28 | alpn_protocol:(Mimic.flow -> string option) -> 29 | authenticator:(X509.Authenticator.t, [> `Msg of string ]) result -> 30 | ?meth:Httpaf.Method.t -> 31 | ?headers:(string * string) list -> 32 | ?body:string -> 33 | ?max_redirect:int -> 34 | ?follow_redirect:bool -> 35 | string -> 36 | (response * string option, [> Mimic.error ]) result Lwt.t 37 | -------------------------------------------------------------------------------- /irmin_io.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Lwt.Syntax 3 | module Store = Irmin_mirage_git.Mem.KV.Make (Irmin.Contents.String) 4 | module Sync = Irmin.Sync.Make (Store) 5 | 6 | type t = { branch : Store.t; remote : Irmin.remote } 7 | 8 | let connect_store ~git_ctx = 9 | let config = Irmin_git.config "." in 10 | let remote, branch = 11 | match String.split_on_char '#' (Key_gen.remote ()) with 12 | | [ remote; branch ] -> (remote, branch) 13 | | _ -> (Key_gen.remote (), "main") 14 | in 15 | Store.Repo.v config >>= fun repository -> 16 | Store.of_branch repository branch >>= fun active_branch -> 17 | Lwt.return 18 | { branch = active_branch; remote = Store.remote ~ctx:git_ctx remote } 19 | 20 | let pull { branch; remote } = 21 | Sync.pull branch remote `Set >>= function 22 | | Error err -> 23 | Fmt.failwith "Couldn't pull from irmin store: %a\n%!" Sync.pp_pull_error 24 | err 25 | | Ok (`Empty | `Head _) -> Lwt.return () 26 | 27 | let push { branch; remote } = 28 | Sync.push branch remote >>= function 29 | | Ok `Empty -> 30 | print_endline "Pushing to upstream irmin was possibly useless."; 31 | Lwt.return_ok () 32 | | Ok (`Head _commit1) -> 33 | print_endline "Pushed something probably useful to upstream irmin"; 34 | Lwt.return_ok () 35 | | Error err -> 36 | Format.eprintf ">>> %a.\n%!" Sync.pp_push_error err; 37 | Lwt.return_error (Rresult.R.msgf "%a" Sync.pp_push_error err) 38 | 39 | let update_db ~dir ~content ~irmin ~info = 40 | let* () = Store.set_exn irmin.branch dir content ~info in 41 | push irmin 42 | 43 | let info message () = 44 | Store.Info.v ~author:"Sonja Heinze & Gargi Sharma & Enguerrand Decorne" 45 | ~message 0L 46 | 47 | let write_matches ~epoch our_match irmin = 48 | let content = Yojson.Safe.to_string (Matches.to_db_entry our_match) in 49 | let (year, month, day), _ = Ptime.to_date_time epoch in 50 | let message = Printf.sprintf "Matches %i/%i/%i" day month year in 51 | let epoch_s = Ptime.to_rfc3339 epoch in 52 | update_db ~dir:[ "matches"; epoch_s ] ~content ~irmin ~info:(info message) 53 | 54 | let write_timestamp ~ts irmin = 55 | let message = "last opt-in message's timestamp" in 56 | update_db ~dir:[ "last_timestamp" ] ~content:ts ~irmin ~info:(info message) 57 | 58 | let read_matches { branch; _ } = 59 | let* epoch_list = 60 | Store.list branch [ "matches" ] >|= List.map (fun (step, _) -> step) 61 | in 62 | let* matches_json = 63 | Lwt_list.map_s 64 | (fun epoch -> Store.get branch [ "matches"; epoch ]) 65 | epoch_list 66 | in 67 | let matches = 68 | List.map 69 | (fun s -> Matches.of_db_entry @@ Yojson.Safe.from_string s) 70 | matches_json 71 | in 72 | Lwt.return (List.combine epoch_list matches) 73 | 74 | let read_timestamp { branch; _ } = Store.get branch [ "last_timestamp" ] 75 | -------------------------------------------------------------------------------- /irmin_io.mli: -------------------------------------------------------------------------------- 1 | type t 2 | (* Represents a full Irmin db: in-memory store plus remote counter-part *) 3 | 4 | val connect_store : git_ctx:Mimic.ctx -> t Lwt.t 5 | (** Connects to the db *) 6 | 7 | val pull : t -> unit Lwt.t 8 | (** Pulls the db data from the persistent remote Irmin store into the in-memory 9 | store *) 10 | 11 | val write_matches : 12 | epoch:Ptime.t -> Matches.t -> t -> (unit, [> Rresult.R.msg ]) result Lwt.t 13 | (** Writes an [epoch] -> [matches] entry to the in-memory Irmin store; pushes 14 | the in-memory store to the remote store. *) 15 | 16 | val read_matches : t -> (string * Matches.t) list Lwt.t 17 | (** Reads all matches in history from the in-memory store. The output list 18 | contains one item per past coffee round. Each round is represented as a pair 19 | (epoch, matches). *) 20 | 21 | val write_timestamp : ts:string -> t -> (unit, [> Rresult.R.msg ]) result Lwt.t 22 | (** Writes a timestamp to the in-memory Irmin store; pushes the in-memory store 23 | to the remote store. This functionality is meant to store the timestamp of 24 | the last slack opt-in message, which is needed to query reactions to that 25 | message later *) 26 | 27 | val read_timestamp : t -> string Lwt.t 28 | (** Reads the last timestamp in the in-memory Irmin store. That timestamp is 29 | meant to be the timestamp of the last opt-in slack message. *) 30 | -------------------------------------------------------------------------------- /matches.ml: -------------------------------------------------------------------------------- 1 | type t = string list list [@@deriving yojson] 2 | type db_entry = { matched : t } [@@deriving yojson] 3 | 4 | let upcast matches = { matched = matches } 5 | let downcast { matched = matches } = matches 6 | let to_db_entry matches = db_entry_to_yojson @@ upcast matches 7 | 8 | let of_db_entry entry = 9 | match db_entry_of_yojson entry with 10 | | Ok res -> downcast res 11 | | Error e -> 12 | Printf.eprintf "Data base entry couldn't be parsed: %s\n%!" e; 13 | exit 1 14 | 15 | module Score_machine = struct 16 | type t = (string * string, int) Hashtbl.t 17 | 18 | let order_pair uid1 uid2 = if uid1 < uid2 then (uid1, uid2) else (uid2, uid1) 19 | 20 | let update_key uid1 uid2 tbl value = 21 | let pair = order_pair uid1 uid2 in 22 | match Hashtbl.find_opt tbl pair with 23 | | Some num_matches -> Hashtbl.replace tbl pair (num_matches + value) 24 | | None -> Hashtbl.add tbl pair value 25 | 26 | let get_score uid1 uid2 tbl = 27 | let pair = order_pair uid1 uid2 in 28 | match Hashtbl.find_opt tbl pair with 29 | | Some num_matches -> num_matches 30 | | None -> 0 31 | 32 | let single_match_score ~current_time epoch = 33 | let value, _, _ = Ptime.of_rfc3339 epoch |> Result.get_ok in 34 | let value = Ptime.to_float_s value in 35 | let day = 86400. in 36 | (* TODO: the scores should depend on the number of people opting in: 37 | if very few people are opting in, the most important is to avoid repeats from last week. *) 38 | if (current_time -. value) /. day <= 9. then 50 39 | else if (current_time -. value) /. day <= 16. then 5 40 | else if (current_time -. value) /. day <= 28. then 3 41 | else if (current_time -. value) /. day <= 56. then 2 42 | else 0 43 | 44 | (* TODO: make the following two functions somehow reasonable!!!! xD *) 45 | let get ~current_time ~old_matches = 46 | let tbl = Hashtbl.create 256 in 47 | List.iter 48 | (fun (epoch, matches) -> 49 | let value = single_match_score ~current_time epoch in 50 | List.iter 51 | (fun current_match -> 52 | match List.length current_match with 53 | | 2 -> 54 | update_key (List.nth current_match 0) (List.nth current_match 1) 55 | tbl value 56 | | 3 -> 57 | update_key (List.nth current_match 0) (List.nth current_match 1) 58 | tbl value; 59 | update_key (List.nth current_match 1) (List.nth current_match 2) 60 | tbl value; 61 | update_key (List.nth current_match 0) (List.nth current_match 2) 62 | tbl value 63 | | _ -> 64 | Printf.printf 65 | "The match in the db with epoch %s is neither a pair nor a \ 66 | triple. It has been ignored.\n\ 67 | %!" 68 | epoch) 69 | matches) 70 | old_matches; 71 | tbl 72 | 73 | let compute ~score_machine:tbl matches = 74 | List.fold_left 75 | (fun score current_match -> 76 | let pair_score = 77 | match List.length current_match with 78 | | 2 -> 79 | get_score (List.nth current_match 0) (List.nth current_match 1) 80 | tbl 81 | | 3 -> 82 | get_score (List.nth current_match 0) (List.nth current_match 1) 83 | tbl 84 | + get_score (List.nth current_match 1) (List.nth current_match 2) 85 | tbl 86 | + get_score (List.nth current_match 0) (List.nth current_match 2) 87 | tbl 88 | | _ -> failwith "not accounted for!" 89 | in 90 | score + pair_score) 91 | 0 matches 92 | end 93 | 94 | let to_string (matches_list : t) = 95 | List.map (List.map (fun member -> "<@" ^ member ^ ">")) matches_list 96 | |> List.fold_left 97 | (fun acc current_match -> 98 | acc ^ String.concat " with " current_match ^ "\n") 99 | "" 100 | 101 | let shuffle ~get_random_int list = 102 | let nd = 103 | List.map 104 | (fun c -> 105 | let random = get_random_int () in 106 | (random, c)) 107 | list 108 | in 109 | let sond = List.sort compare nd in 110 | List.map snd sond 111 | 112 | let rec pair_up acc members = 113 | match members with 114 | | [] -> acc 115 | | [ last ] -> ( 116 | (* if we want to avoid triples: 117 | match acc with 118 | | [] -> [ [ last ] ] 119 | | fst :: tl -> 120 | [ last; List.nth fst 0 ] :: [ last; List.nth fst 1 ] :: tl) 121 | (* [fst] being of length 2 is an invariant of [pair_up] *) 122 | *) 123 | match acc with [] -> [ [ last ] ] | fst :: tl -> (last :: fst) :: tl) 124 | | f :: s :: tl -> pair_up ([ f; s ] :: acc) tl 125 | 126 | let generate ~num_iter ~get_random_int ~score_machine ~opt_ins : t Lwt.t = 127 | match opt_ins with 128 | | [] -> Lwt.return [ [] ] 129 | | [ only_member ] -> Lwt.return [ [ only_member ] ] 130 | | [ first; second ] -> Lwt.return [ [ first; second ] ] 131 | | opt_ins -> 132 | let rec loop i best_match best_score = 133 | if i = num_iter then 134 | let _ = Printf.printf "\n Number iterations: %d \n%!" i in 135 | best_match 136 | else 137 | let new_match = opt_ins |> shuffle ~get_random_int |> pair_up [] in 138 | let new_score = Score_machine.compute ~score_machine new_match in 139 | match new_score with 140 | | 0 -> 141 | let _ = Printf.printf "\n Number iterations: %d \n%!" i in 142 | new_match 143 | | _ -> 144 | if new_score < best_score then loop (i + 1) new_match new_score 145 | else loop (i + 1) best_match best_score 146 | in 147 | let first_match = opt_ins |> shuffle ~get_random_int |> pair_up [] in 148 | Lwt.return 149 | (loop 1 first_match (Score_machine.compute ~score_machine first_match)) 150 | -------------------------------------------------------------------------------- /matches.mli: -------------------------------------------------------------------------------- 1 | type t 2 | (** A value of type [t] contains the combination of all matches of one coffee 3 | chat round *) 4 | 5 | val to_string : t -> string 6 | val to_db_entry : t -> Yojson.Safe.t 7 | val of_db_entry : Yojson.Safe.t -> t 8 | 9 | module Score_machine : sig 10 | type matches 11 | 12 | type t 13 | (** Used to compute a "score" for a potential new match, based on all matches 14 | in the past. Scores are then minimized to avoid repeating the same 15 | matches. *) 16 | 17 | val get : current_time:float -> old_matches:(string * matches) list -> t 18 | (** Get a score machine instance *) 19 | 20 | val compute : score_machine:t -> matches -> int 21 | (** Given a score machine instance and a combination of matches, compute the 22 | score of that combination of matches. The higher the score, the more and 23 | most recent are the repeats with past matches; i.e. the higher the score, 24 | the worst. *) 25 | end 26 | with type matches := t 27 | 28 | val generate : 29 | num_iter:int -> 30 | get_random_int:(unit -> int) -> 31 | score_machine:Score_machine.t -> 32 | opt_ins:string list -> 33 | t Lwt.t 34 | (** Generates [num_iter] combinations of matches between all [opt_ins] and 35 | chooses the combination with the lowest score, i.e. the one with the least 36 | (and least recent) repeats of past matches. *) 37 | -------------------------------------------------------------------------------- /schedule.ml: -------------------------------------------------------------------------------- 1 | module Weekday = struct 2 | type t = [ `Mon | `Tue | `Wed | `Thu | `Fri | `Sat | `Sun ] 3 | type span = int 4 | 5 | let to_int = function 6 | | `Mon -> 0 7 | | `Tue -> 1 8 | | `Wed -> 2 9 | | `Thu -> 3 10 | | `Fri -> 4 11 | | `Sat -> 5 12 | | `Sun -> 6 13 | 14 | let span_between ~allow_zero first last = 15 | let first = to_int first in 16 | let last = to_int last in 17 | if last > first then last - first 18 | else if first = last && allow_zero then 0 19 | else 7 - first + last 20 | 21 | let span_to_secs span = span * 24 * 60 * 60 22 | end 23 | 24 | module Daytime = struct 25 | type t = int * int * int 26 | 27 | let time_to_secs (h, min, sec) = sec + (min * 60) + (h * 60 * 60) 28 | 29 | let span_between start_time end_time = 30 | time_to_secs end_time - time_to_secs start_time 31 | end 32 | 33 | module Sleep (Time : Mirage_time.S) = struct 34 | let secs_till schedule_day schedule_time = 35 | let now = Pclock.now_d_ps () |> Ptime.v in 36 | let _, (current_time, _) = Ptime.to_date_time now in 37 | let secs_till_schedule_time = 38 | Daytime.span_between current_time schedule_time 39 | in 40 | let allow_zero = secs_till_schedule_time > 0 in 41 | let today = Ptime.weekday now in 42 | let days_till_schedule_day = 43 | Weekday.(span_between ~allow_zero today schedule_day) 44 | in 45 | Weekday.span_to_secs days_till_schedule_day + secs_till_schedule_time 46 | 47 | let sleep_till day time = 48 | let nsecs_to_sleep = 49 | secs_till day time |> Int64.of_int |> Int64.mul 1_000_000_000L 50 | in 51 | Time.sleep_ns nsecs_to_sleep 52 | 53 | let sleep_for_ns = Time.sleep_ns 54 | end 55 | -------------------------------------------------------------------------------- /schedule.mli: -------------------------------------------------------------------------------- 1 | module Weekday : sig 2 | type t = [ `Fri | `Mon | `Sat | `Sun | `Thu | `Tue | `Wed ] 3 | type span = int 4 | 5 | val span_between : allow_zero:bool -> t -> t -> int 6 | (** Exposed for testing purposes*) 7 | end 8 | 9 | module Daytime : sig 10 | type t = int * int * int 11 | (** The format of [t] is (hour, minutes, seconds) *) 12 | 13 | val span_between : t -> t -> int 14 | (** Exposed for testing purposes. [span_between] is negative if the start_time 15 | is already past the end_time *) 16 | end 17 | 18 | module Sleep (Time : Mirage_time.S) : sig 19 | val secs_till : Weekday.t -> Daytime.t -> int 20 | (** Exposed for testing purposes*) 21 | 22 | val sleep_for_ns : int64 -> unit Lwt.t 23 | 24 | val sleep_till : Weekday.t -> Daytime.t -> unit Lwt.t 25 | (** [sleep_till day time] makes the OS sleep for the number of seconds left 26 | until the most proximate moment in which it is weekday [day] at [time] 27 | o'clock. [time] is in UTC. *) 28 | end 29 | -------------------------------------------------------------------------------- /slack_api.ml: -------------------------------------------------------------------------------- 1 | open Yojson.Safe 2 | open Yojson.Safe.Util 3 | 4 | type http_ctx = { 5 | ctx : Mimic.ctx; 6 | alpn_protocol : Mimic.flow -> string option; 7 | authenticator : (X509.Authenticator.t, [ `Msg of string ]) result; 8 | channel : string; 9 | token : string; 10 | } 11 | 12 | open Lwt.Infix 13 | 14 | let post_request ~http_ctx:{ ctx; alpn_protocol; authenticator; channel; token } 15 | text = 16 | let uri = "https://slack.com/api/chat.postMessage" in 17 | let headers = 18 | [ 19 | ("Content-type", "application/json"); ("Authorization", "Bearer " ^ token); 20 | ] 21 | in 22 | let unserialized_body = 23 | `Assoc [ ("channel", `String channel); ("text", `String text) ] 24 | in 25 | let body = Yojson.Basic.to_string unserialized_body in 26 | let http_config = Httpaf.Config.default in 27 | let config = `HTTP_1_1 http_config in 28 | Http_mirage_client.one_request ~meth:`POST ~config ~headers ~body ~ctx 29 | ~alpn_protocol ~authenticator uri 30 | 31 | let get_request 32 | ~http_ctx:{ ctx; alpn_protocol; authenticator; channel = _; token } uri = 33 | let headers = [ ("Authorization", "Bearer " ^ token) ] in 34 | let http_config = Httpaf.Config.default in 35 | let config = `HTTP_1_1 http_config in 36 | Http_mirage_client.one_request ~meth:`GET ~config ~headers ~ctx ~alpn_protocol 37 | ~authenticator uri 38 | 39 | let write_matches ~http_ctx matches = 40 | let msg = 41 | ":coffee: *Virtual Coffee* :coffee:\n :camel: Matches this week:\n" 42 | ^ Matches.to_string matches 43 | ^ "\n\ 44 | \ :sheepy: :sheepy: :sheepy: :sheepy: :sheepy: :sheepy: :sheepy: \ 45 | :sheepy: :mirageos: :sheepy:\n\ 46 | Note: I don't initiate a conversation. So, please, don't forget to \ 47 | reach out to your coffee-chat partner(s):writing_hand:\n\ 48 | \ Have some nice coffee chats! \n" 49 | in 50 | post_request ~http_ctx msg >|= function 51 | | Error err -> Error (Fmt.str "%a" Mimic.pp_error err) 52 | | Ok (rsp, body) -> ( 53 | match body with 54 | | None -> Error "Http request to send opt in message returned no body" 55 | | Some body when H2.Status.is_successful rsp.status -> ( 56 | try Ok (from_string body) with Yojson.Json_error err -> Error err) 57 | | _ -> Error (Fmt.str "Error code: %i" (H2.Status.to_code rsp.status))) 58 | 59 | let parse_response resp = 60 | try 61 | Ok 62 | (let msg = from_string resp |> Util.(member "message") in 63 | match Util.member "reactions" msg with 64 | | `Null -> 65 | (* TODO: when there's 0 or no reactions, send a message along the lines of "No/only one opt-in this time. Do we want to pause the coffee-chats for some time?" instead 66 | of the usual slack message to the channel *) 67 | [] 68 | | json -> ( 69 | let reactions = Util.to_list json in 70 | let original = 71 | List.sort_uniq String.compare 72 | (List.map Util.to_string 73 | (List.map Util.(member "users") reactions |> Util.flatten)) 74 | in 75 | match Key_gen.curl_user_id () with 76 | | None -> original 77 | | Some curl_user_id -> 78 | let bot_id = Key_gen.bot_id () in 79 | List.map 80 | (fun id -> if String.equal id bot_id then curl_user_id else id) 81 | original)) 82 | with Yojson.Json_error err -> Error err 83 | 84 | let get_reactions ~timestamp ~http_ctx = 85 | let uri = 86 | Format.sprintf "https://slack.com/api/reactions.get?channel=%s×tamp=%s" 87 | http_ctx.channel timestamp 88 | in 89 | get_request ~http_ctx uri >|= function 90 | | Error err -> Error (Fmt.str "%a" Mimic.pp_error err) 91 | | Ok (rsp, body) -> ( 92 | match body with 93 | | None -> Error "Http request to send opt in message returned no body" 94 | | Some body when H2.Status.is_successful rsp.status -> parse_response body 95 | | _ -> Error (Fmt.str "Error code: %i" (H2.Status.to_code rsp.status))) 96 | 97 | let parse_ts resp = from_string resp |> member "ts" |> to_string 98 | 99 | let write_opt_in_message ~http_ctx = 100 | let text = 101 | ":coffee: *Virtual Coffee* :coffee:\n\ 102 | \ Hi everyone,\n\ 103 | \ Who wants to have a coffee-chat this week? To opt in, react to this \ 104 | message, for example with a :raised_hand::skin-tone-4:" 105 | in 106 | post_request ~http_ctx text >|= function 107 | | Error err -> Error (Fmt.str "%a" Mimic.pp_error err) 108 | | Ok (rsp, body) -> ( 109 | match body with 110 | | None -> Error "Http request to send opt in message returned no body" 111 | | Some body when H2.Status.is_successful rsp.status -> ( 112 | try Ok (parse_ts body) with Yojson.Json_error err -> Error err) 113 | | _ -> Error (Fmt.str "Error code: %i" (H2.Status.to_code rsp.status))) 114 | -------------------------------------------------------------------------------- /slack_api.mli: -------------------------------------------------------------------------------- 1 | type http_ctx = { 2 | ctx : Mimic.ctx; 3 | alpn_protocol : Mimic.flow -> string option; 4 | authenticator : (X509.Authenticator.t, [ `Msg of string ]) result; 5 | channel : string; 6 | token : string; 7 | } 8 | 9 | val write_opt_in_message : http_ctx:http_ctx -> (string, string) result Lwt.t 10 | (** Writes the opt-in message to the slack channel in [http_ctx]. In case of 11 | success, the returned string represents the timestamp of the message. *) 12 | 13 | val get_reactions : 14 | timestamp:string -> http_ctx:http_ctx -> (string list, string) result Lwt.t 15 | (** Given a [timestamp], [get_reactions] fetches the list of slack user ids of 16 | the folks who've reacted to the message sent at the time of the timestamp 17 | (in the channel in [http_ctx]) *) 18 | 19 | val write_matches : 20 | http_ctx:http_ctx -> Matches.t -> (Yojson.Safe.t, string) result Lwt.t 21 | (** Writes a message containing the matches to the slack channel in [http_ctx] *) 22 | -------------------------------------------------------------------------------- /unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Syntax 2 | 3 | let write_matches_to_irmin_and_slack ~get_current_time ~http_ctx matches irmin = 4 | let* result = Slack_api.write_matches ~http_ctx matches in 5 | match result with 6 | | Ok _ -> 7 | let epoch = get_current_time () in 8 | let* res = Irmin_io.write_matches ~epoch matches irmin in 9 | let () = 10 | match res with 11 | | Ok () -> Format.printf "Updating db should have worked!\n%!" 12 | | Error (`Msg e) -> Format.eprintf "Error trying to update db: %s\n%!" e 13 | in 14 | Lwt.return () 15 | | Error e -> 16 | Format.printf "Http Request to write to slack failed with error : %s\n%!" 17 | e; 18 | Lwt.return () 19 | 20 | let write_opt_in_to_irmin_and_slack ~http_ctx irmin = 21 | let* result = Slack_api.write_opt_in_message ~http_ctx in 22 | match result with 23 | | Ok ts -> 24 | let* res = Irmin_io.write_timestamp ~ts irmin in 25 | let () = 26 | match res with 27 | | Ok () -> Format.printf "Updating db should have worked!\n%!" 28 | | Error (`Msg e) -> Format.eprintf "Error trying to update db: %s\n%!" e 29 | in 30 | Lwt.return () 31 | | Error e -> 32 | Format.printf "Http Request to write to slack failed with error : %s\n%!" 33 | e; 34 | Lwt.return () 35 | 36 | let rec main ~clock ~sleep_till ~sleep_for_ns ~get_current_time ~get_random_int 37 | ~git_ctx ~http_ctx ~num_iter ~irmin = 38 | let is_test = Key_gen.test () in 39 | let* () = if is_test then Lwt.return () else sleep_till `Mon (08, 30, 0) in 40 | let* () = write_opt_in_to_irmin_and_slack ~http_ctx irmin in 41 | let* () = 42 | if is_test then sleep_for_ns 60000000000L else sleep_till `Tue (08, 30, 0) 43 | in 44 | let* opt_ins = 45 | let* timestamp = Irmin_io.read_timestamp irmin in 46 | let+ reactions = Slack_api.get_reactions ~timestamp ~http_ctx in 47 | match reactions with 48 | | Error e -> 49 | Printf.eprintf "Error trying to fetch opt-ins: %s\n%!" e; 50 | [] 51 | | Ok opt_ins -> opt_ins 52 | in 53 | let* score_machine = 54 | let+ old_matches = Irmin_io.read_matches irmin in 55 | let current_time = get_current_time () |> Ptime.to_float_s in 56 | Matches.Score_machine.get ~current_time ~old_matches 57 | in 58 | let* new_matches = 59 | Matches.generate ~num_iter ~get_random_int ~score_machine ~opt_ins 60 | in 61 | let* () = 62 | write_matches_to_irmin_and_slack ~get_current_time ~http_ctx new_matches 63 | irmin 64 | in 65 | let* () = 66 | if is_test then Lwt.return () 67 | else 68 | let min_in_ns = 60000000000L in 69 | let week_in_ns = Int64.mul min_in_ns (Int64.of_int (60 * 24 * 7)) in 70 | sleep_for_ns week_in_ns 71 | in 72 | Format.printf "I've just slept for a week\n%!"; 73 | main ~clock ~sleep_till ~sleep_for_ns ~get_current_time ~get_random_int 74 | ~http_ctx ~git_ctx ~num_iter ~irmin 75 | 76 | module Client 77 | (HTTP : Http_mirage_client.S) 78 | (Time : Mirage_time.S) 79 | (Clock : Mirage_clock.PCLOCK) 80 | (Random : Mirage_random.S) (_ : sig end) = 81 | struct 82 | let start ctx _time clock _random git_ctx = 83 | (* let () = Logs.set_level (Some Debug) in *) 84 | let http_ctx = 85 | { 86 | Slack_api.ctx; 87 | alpn_protocol = HTTP.alpn_protocol; 88 | authenticator = HTTP.authenticator; 89 | channel = Key_gen.channel (); 90 | token = Key_gen.token (); 91 | } 92 | in 93 | let num_iter = Key_gen.num_iter () in 94 | let sleep_till, sleep_for_ns = 95 | let module Schedule = Schedule.Sleep (Time) in 96 | (Schedule.sleep_till, Schedule.sleep_for_ns) 97 | in 98 | let get_current_time () = Clock.now_d_ps clock |> Ptime.v in 99 | let get_random_int () = 100 | (*FIXME??: why 4 and why 0? *) 101 | Cstruct.HE.get_uint32 (Random.generate 4) 0 |> Int32.to_int |> abs 102 | in 103 | let* irmin = Irmin_io.connect_store ~git_ctx in 104 | let* () = Irmin_io.pull irmin in 105 | main ~clock ~sleep_till ~sleep_for_ns ~get_current_time ~get_random_int 106 | ~http_ctx ~git_ctx ~num_iter ~irmin 107 | end 108 | --------------------------------------------------------------------------------