├── 0 ├── dune ├── dune-workspace └── test.ml ├── 1 ├── dune ├── dune-workspace └── test.ml ├── 2 ├── dune ├── dune-workspace └── test.ml ├── 3 ├── dune ├── dune-workspace └── test.ml ├── 4 ├── dune ├── dune-workspace └── test.ml ├── 5 ├── dune ├── dune-workspace └── test.ml ├── 6 ├── dune ├── dune-workspace └── test.ml ├── 7 ├── .ocamlformat ├── dune ├── dune-workspace ├── lrcp.ml ├── lrcp.mli └── test.ml ├── 8 ├── .ocamlformat ├── dune ├── dune-workspace ├── isl.ml ├── isl.mli └── test.ml ├── 9 ├── .ocamlformat ├── dune ├── dune-workspace ├── job_id.ml ├── job_id.mli ├── json.ml ├── json.mli ├── main.ml ├── protocol.ml ├── q.ml ├── q.mli ├── reporter.ml └── reporter.mli ├── 10 ├── .ocamlformat ├── dune ├── dune-workspace ├── reporter.ml ├── reporter.mli └── test.ml ├── 11 ├── .ocamlformat ├── dune ├── dune-workspace ├── reporter.ml ├── reporter.mli └── test.ml ├── .gitignore └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | .vscode 3 | _opam -------------------------------------------------------------------------------- /0/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries eio eio_main)) 4 | -------------------------------------------------------------------------------- /0/dune-workspace: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) -------------------------------------------------------------------------------- /0/test.ml: -------------------------------------------------------------------------------- 1 | 2 | open Eio 3 | 4 | (* 0: Smoke Test 5 | 6 | Deep inside Initrode Global's enterprise management framework lies a component 7 | that writes data to a server and expects to read the same data back. (Think of 8 | it as a kind of distributed system delay-line memory). We need you to write the 9 | server to echo the data back. 10 | 11 | Accept TCP connections. 12 | 13 | Whenever you receive data from a client, send it back unmodified. 14 | 15 | Make sure you don't mangle binary data, and that you can handle at least 5 16 | simultaneous clients. 17 | 18 | Once the client has finished sending data to you it shuts down its sending side. 19 | Once you've reached end-of-file on your receiving side, and sent back all the 20 | data you've received, close the socket so that the client knows you've finished. 21 | (This point trips up a lot of proxy software, such as ngrok; if you're using a 22 | proxy and you can't work out why you're failing the check, try hosting your 23 | server in the cloud instead). 24 | 25 | Your program will implement the TCP Echo Service from RFC 862. 26 | *) 27 | 28 | let handler flow _ = 29 | (* well, at least this is straightforward. what we receive is sent back *) 30 | Eio.Flow.copy flow flow 31 | 32 | let () = 33 | Eio_main.run @@ fun env -> 34 | Switch.run @@ fun sw -> 35 | let net = Stdenv.net env in 36 | let socket = Net.listen 37 | ~reuse_addr:true ~backlog:10 ~sw net 38 | (`Tcp (Net.Ipaddr.V6.any, 10000)) 39 | in 40 | while true do 41 | Net.accept_fork ~sw socket ~on_error:raise handler 42 | done 43 | -------------------------------------------------------------------------------- /1/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries eio eio_main yojson zarith)) 4 | -------------------------------------------------------------------------------- /1/dune-workspace: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) -------------------------------------------------------------------------------- /1/test.ml: -------------------------------------------------------------------------------- 1 | open Eio 2 | 3 | (* 1: Prime Time 4 | 5 | To keep costs down, a hot new government department is contracting out its 6 | mission-critical primality testing to the lowest bidder. (That's you). 7 | 8 | Officials have devised a JSON-based request-response protocol. Each request is 9 | a single line containing a JSON object, terminated by a newline character 10 | ('\n', or ASCII 10). Each request begets a response, which is also a single 11 | line containing a JSON object, terminated by a newline character. 12 | 13 | After connecting, a client may send multiple requests in a single session. 14 | Each request should be handled in order. 15 | 16 | A conforming request object has the required field method, which must always 17 | contain the string "isPrime", and the required field number, which must contain 18 | a number. Any JSON number is a valid number, including floating-point values. 19 | 20 | (...) 21 | *) 22 | 23 | 24 | (* this API has to support arbitrarily large integers, so the zarith library 25 | has to be used. opening the Z module shadows most integer operations so 26 | it's mostly transparent. *) 27 | let is_prime n = 28 | let open Z in 29 | let rec no_divisors m = 30 | m * m > n || (n mod m != Z.zero && no_divisors (m + Z.one)) 31 | in 32 | n >= Z.of_int 2 && no_divisors (Z.of_int 2) 33 | 34 | (* check if a number is prime and respond using the specified format *) 35 | let respond ~flow number = 36 | let response = 37 | Fmt.str 38 | {|{"method":"isPrime","prime":%b}%s|} 39 | (is_prime number) "\n" 40 | in 41 | Flow.copy_string response flow 42 | 43 | 44 | exception Break 45 | 46 | (* parse the json and checks that we are indeed requesting the correct method. 47 | the `yojson` library is used for that purpose. *) 48 | let handle_line ~flow line = 49 | let req = Yojson.Safe.from_string line in 50 | let open Yojson.Safe.Util in 51 | let meth = req |> member "method" |> to_string in 52 | let number = 53 | match req |> member "number" with 54 | | `Int n -> Z.of_int n 55 | | `Intlit s -> Z.of_string s 56 | | `Float _ -> Z.zero 57 | | _ -> raise Break 58 | in 59 | match meth with 60 | | "isPrime" -> respond ~flow number 61 | | _ -> raise Break 62 | 63 | (* the connection handler simply read lines and handle them as long as data 64 | is available. on exceptions, a malformed response is sent and the connection 65 | is closed *) 66 | let handler flow _ = 67 | let buffered_reader = Buf_read.of_flow ~max_size:1_000_000 flow in 68 | let rec loop () = 69 | match Buf_read.line buffered_reader with 70 | | line -> handle_line ~flow line |> ignore; loop () 71 | | exception End_of_file -> () 72 | in 73 | try loop () with 74 | | Yojson.Json_error _ 75 | | Yojson.Safe.Util.Type_error _ 76 | | Break -> 77 | Eio.Flow.copy_string "\n" flow 78 | 79 | let () = 80 | Eio_main.run @@ fun env -> 81 | Switch.run @@ fun sw -> 82 | let net = Stdenv.net env in 83 | let socket = Net.listen 84 | ~reuse_addr:true ~backlog:10 ~sw net 85 | (`Tcp (Net.Ipaddr.V6.any, 10000)) 86 | in 87 | while true do 88 | Net.accept_fork ~sw socket ~on_error:raise handler 89 | done 90 | -------------------------------------------------------------------------------- /10/.ocamlformat: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TheLortex/protocaml/2d1c38692aaf4ff007f2cd16fecf22bb5764842f/10/.ocamlformat -------------------------------------------------------------------------------- /10/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries eio eio_main fpath fmt.tty)) 4 | -------------------------------------------------------------------------------- /10/dune-workspace: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) -------------------------------------------------------------------------------- /10/reporter.ml: -------------------------------------------------------------------------------- 1 | let c = Mtime_clock.counter () 2 | 3 | let reporter ppf = 4 | let report _src level ~over k msgf = 5 | let k _ = 6 | over (); 7 | k () 8 | in 9 | let with_stamp h _tags k ppf fmt = 10 | Format.kfprintf k ppf 11 | ("%a[%a] @[" ^^ fmt ^^ "@]@.") 12 | Logs.pp_header (level, h) Mtime.Span.pp (Mtime_clock.count c) 13 | in 14 | msgf @@ fun ?header ?tags fmt -> with_stamp header tags k ppf fmt 15 | in 16 | { Logs.report } 17 | 18 | let init () = 19 | Fmt_tty.setup_std_outputs (); 20 | Logs.set_level (Some Error); 21 | Logs.set_reporter (reporter Format.std_formatter) -------------------------------------------------------------------------------- /10/reporter.mli: -------------------------------------------------------------------------------- 1 | val init : unit -> unit 2 | -------------------------------------------------------------------------------- /10/test.ml: -------------------------------------------------------------------------------- 1 | open Eio 2 | 3 | module Command = struct 4 | type t = 5 | | Help 6 | | Get of { file : Fpath.t; revision : string option } 7 | | List of { path : Fpath.t } 8 | | Put of { file : Fpath.t; content : string } 9 | 10 | let filename_is_valid v = 11 | (not (Astring.String.is_infix ~affix:"//" v)) 12 | && v.[0] = '/' 13 | && String.for_all 14 | (function 15 | | '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '_' | '-' | '/' | '.' -> 16 | true 17 | | _ -> false) 18 | v 19 | 20 | let content_is_valid v = 21 | String.for_all 22 | (fun c -> Astring.Char.Ascii.(is_print c) || c = '\n' || c = '\t') 23 | v 24 | 25 | let parse i = 26 | let s = Buf_read.line i in 27 | Logs.info (fun f -> f "<<%s" s); 28 | match String.split_on_char ' ' s with 29 | | [] -> Error "Provide a command" 30 | | command :: rest -> ( 31 | match (String.uppercase_ascii command, rest) with 32 | | "HELP", _ -> Ok Help 33 | | "GET", [ file ] -> Ok (Get { file = Fpath.v file; revision = None }) 34 | | "GET", [ file; revision ] -> 35 | Ok (Get { file = Fpath.v file; revision = Some revision }) 36 | | "PUT", [ file; length ] -> ( 37 | match int_of_string_opt length with 38 | | Some length -> 39 | if filename_is_valid file then ( 40 | let content = Buf_read.take length i in 41 | Logs.info (fun f -> f "<<%S" content); 42 | if content_is_valid content then 43 | Ok (Put { file = Fpath.v file; content }) 44 | else Error "invalid content") 45 | else Error "invalid file name" 46 | | None -> Error "Invalid length") 47 | | "LIST", [ path ] -> Ok (List { path = Fpath.v path }) 48 | | _ -> Error "Invalid command") 49 | end 50 | 51 | module Response = struct 52 | type t = 53 | | Err of string 54 | | OkGet of { content : string } 55 | | OkPut of { revision : string } 56 | | OkList of (string * string) list 57 | | OkHelp 58 | 59 | let serialize_response s = 60 | let open Buf_write in 61 | function 62 | | Err str -> 63 | string s "ERR "; 64 | string s str; 65 | char s '\n' 66 | | OkGet { content } -> 67 | string s "OK "; 68 | string s (string_of_int (String.length content)); 69 | char s '\n'; 70 | string s content 71 | | OkList lst -> 72 | string s "OK "; 73 | string s (List.length lst |> string_of_int); 74 | string s "\n"; 75 | List.iter 76 | (fun (a, b) -> 77 | string s a; 78 | char s ' '; 79 | string s b; 80 | char s '\n') 81 | lst 82 | | OkPut { revision } -> 83 | string s "OK "; 84 | string s revision; 85 | char s '\n' 86 | | OkHelp -> string s "OK usage: HELP|GET|PUT|LIST\n" 87 | end 88 | 89 | type entry = { name : string; node : node } 90 | and node = File of (string, string) Hashtbl.t | Dir of entry list ref 91 | 92 | let list_node_info v = 93 | match v.node with 94 | | File l -> (v.name, "r" ^ (Hashtbl.length l |> string_of_int)) 95 | | Dir _ -> (v.name ^ "/", "DIR") 96 | 97 | let find root path = 98 | if Fpath.is_abs path then 99 | let segs = Fpath.segs path |> List.filter (fun v -> v <> "") in 100 | let rec loop root segs = 101 | match (segs, root) with 102 | | [], _ -> Ok root 103 | | _, File _ -> Error "not found" 104 | | a :: b, Dir entries -> ( 105 | match List.find_opt (fun x -> x.name = a) !entries with 106 | | None -> Error "not found" 107 | | Some v -> loop v.node b) 108 | in 109 | loop root segs 110 | else Error "invalid path" 111 | 112 | let ls root path = 113 | let open Response in 114 | match find root path with 115 | | Error "invalid path" -> Error "illegal dir name" 116 | | Error "not found" -> Ok (OkList []) 117 | | Error v -> Error v 118 | | Ok (Dir entries) -> 119 | Ok 120 | (OkList 121 | (List.map list_node_info !entries 122 | |> List.sort_uniq (fun (a, _) (b, _) -> String.compare a b))) 123 | | Ok (File _) -> Ok (OkList []) 124 | 125 | let last_revision_content v = 126 | Hashtbl.find v ("r" ^ (Hashtbl.length v |> string_of_int)) 127 | 128 | let get root path revision = 129 | let open Response in 130 | match (find root path, revision) with 131 | | Error "invalid path", _ -> Error "illegal file name" 132 | | Error "not found", _ -> Error "no such file" 133 | | Error v, _ -> Error v 134 | | Ok (Dir _), _ -> Error "found a directory" 135 | | Ok (File hsh), Some revision -> ( 136 | match Hashtbl.find_opt hsh revision with 137 | | None -> Error "no such revision" 138 | | Some v -> Ok (OkGet { content = v })) 139 | | Ok (File hsh), None -> Ok (OkGet { content = last_revision_content hsh }) 140 | 141 | let is_dir = function Dir _ -> true | _ -> false 142 | 143 | let mkfile root path content = 144 | let open Response in 145 | let name = Fpath.basename path in 146 | let segs = Fpath.segs (Fpath.parent path) |> List.filter (fun v -> v <> "") in 147 | let rec loop root segs = 148 | match (segs, root) with 149 | | [], File _ -> Error "internal" 150 | | [], Dir entries -> 151 | let file = Hashtbl.create 1 in 152 | Hashtbl.add file "r1" content; 153 | entries := { name; node = File file } :: !entries; 154 | Ok (OkPut { revision = "r1" }) 155 | | _ :: _, File _ -> Error "internal" 156 | | a :: rest, Dir entries -> ( 157 | match List.find_opt (fun e -> e.name = a && is_dir e.node) !entries with 158 | | None -> 159 | let node = Dir (ref []) in 160 | let new_entry = { name = a; node } in 161 | entries := new_entry :: !entries; 162 | loop node rest 163 | | Some entry -> loop entry.node rest) 164 | in 165 | loop root segs 166 | 167 | let put root path content = 168 | match find root path with 169 | | Error "invalid path" -> Error "invalid file name" 170 | | Error "not found" -> mkfile root path content 171 | | Error v -> Error v 172 | | Ok (Dir _) -> Error "is directory" 173 | | Ok (File hsh) -> 174 | let old_content = last_revision_content hsh in 175 | if old_content = content then 176 | let len = Hashtbl.length hsh in 177 | let rev = "r" ^ string_of_int len in 178 | Ok (OkPut { revision = rev }) 179 | else 180 | let len = Hashtbl.length hsh in 181 | let rev = "r" ^ string_of_int (len + 1) in 182 | Hashtbl.add hsh rev content; 183 | Ok (OkPut { revision = rev }) 184 | 185 | let execute state = 186 | let open Response in 187 | function 188 | | Command.Help -> Ok OkHelp 189 | | List { path } -> ls state path 190 | | Get { file; revision } -> get state file revision 191 | | Put { file; content } -> put state file content 192 | 193 | let root = Dir (ref []) 194 | 195 | let handler flow _ = 196 | let input = Buf_read.of_flow ~max_size:10_000_000 flow in 197 | try 198 | Buf_write.with_flow flow (fun write -> 199 | while true do 200 | Logs.info (fun f -> f "< v | Error msg -> Err msg in 205 | Response.serialize_response write resp; 206 | Buf_write.flush write 207 | done) 208 | with End_of_file | Eio.Net.Connection_reset _ -> () 209 | 210 | let () = 211 | Reporter.init (); 212 | Logs.set_level (Some Info); 213 | Eio_linux.run ~queue_depth:2000 @@ fun env -> 214 | Switch.run @@ fun sw -> 215 | let net = Stdenv.net env in 216 | let socket = 217 | Net.listen ~reuse_addr:true ~backlog:10 ~sw net 218 | (`Tcp (Net.Ipaddr.V6.any, 10001)) 219 | in 220 | while true do 221 | Net.accept_fork ~sw socket ~on_error:raise handler 222 | done 223 | -------------------------------------------------------------------------------- /11/.ocamlformat: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TheLortex/protocaml/2d1c38692aaf4ff007f2cd16fecf22bb5764842f/11/.ocamlformat -------------------------------------------------------------------------------- /11/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries eio eio_main fpath fmt.tty)) 4 | -------------------------------------------------------------------------------- /11/dune-workspace: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) -------------------------------------------------------------------------------- /11/reporter.ml: -------------------------------------------------------------------------------- 1 | let c = Mtime_clock.counter () 2 | 3 | let reporter ppf = 4 | let report _src level ~over k msgf = 5 | let k _ = 6 | over (); 7 | k () 8 | in 9 | let with_stamp h _tags k ppf fmt = 10 | Format.kfprintf k ppf 11 | ("%a[%a] @[" ^^ fmt ^^ "@]@.") 12 | Logs.pp_header (level, h) Mtime.Span.pp (Mtime_clock.count c) 13 | in 14 | msgf @@ fun ?header ?tags fmt -> with_stamp header tags k ppf fmt 15 | in 16 | { Logs.report } 17 | 18 | let init () = 19 | Fmt_tty.setup_std_outputs (); 20 | Logs.set_level (Some Error); 21 | Logs.set_reporter (reporter Format.std_formatter) -------------------------------------------------------------------------------- /11/reporter.mli: -------------------------------------------------------------------------------- 1 | val init : unit -> unit 2 | -------------------------------------------------------------------------------- /11/test.ml: -------------------------------------------------------------------------------- 1 | open Eio 2 | 3 | module Protocol = struct 4 | type range = { species : string; min : int; max : int } 5 | type action = Cull | Conserve 6 | type population = { species : string; count : int } 7 | type site_visit = { site : int; populations : population list } 8 | 9 | let pp_population f { species; count } = 10 | Fmt.pf f "{species=%s,count=%d}" species count 11 | 12 | let pp_range f { species; min; max } = 13 | Fmt.pf f "{species=%s,min=%d,max=%d}" species min max 14 | 15 | type 'a message = 16 | | Hello : { protocol : string; version : int } -> 'a message 17 | | Error : { message : string } -> [< `To_client | `To_server ] message 18 | | OK : [ `From_server ] message 19 | | DialAuthority : { site : int } -> [ `To_server ] message 20 | | TargetPopulations : { 21 | site : int; 22 | populations : range list; 23 | } 24 | -> [ `From_server ] message 25 | | CreatePolicy : { 26 | species : string; 27 | action : action; 28 | } 29 | -> [ `To_server ] message 30 | | DeletePolicy : { policy : int } -> [ `To_server ] message 31 | | PolicyResult : { policy : int } -> [ `From_server ] message 32 | | SiteVisit : site_visit -> [ `From_client ] message 33 | 34 | let to_string : type a. a message -> string = function 35 | | Hello { protocol; version } -> 36 | Fmt.str "Hello{protocol=%s;version=%d}" protocol version 37 | | Error { message } -> "Error: " ^ message 38 | | OK -> "OK" 39 | | DialAuthority { site } -> Fmt.str "Dial{site=%d}" site 40 | | TargetPopulations { site; populations } -> 41 | Fmt.str "TargetPopulations{site=%d,populations=%a}" site 42 | (Fmt.list pp_range) populations 43 | | CreatePolicy { species; action } -> 44 | Fmt.str "CreatePolicy{species=%s,action=%s}" species 45 | (match action with Cull -> "cull" | Conserve -> "conserve") 46 | | DeletePolicy { policy } -> Fmt.str "DeletePolicy{policy=%d}" policy 47 | | PolicyResult { policy } -> Fmt.str "PolicyResult{policy=%d}" policy 48 | | SiteVisit { site; populations } -> 49 | Fmt.str "SiteVisit{site=%d,populations=%a}" site 50 | (Fmt.list pp_population) populations 51 | 52 | module Parse = struct 53 | open Buf_read.Syntax 54 | 55 | let u8 = 56 | let+ c = Buf_read.any_char in 57 | Char.code c 58 | 59 | let u32 = 60 | let+ c = Buf_read.take 4 in 61 | String.get_int32_be c 0 |> Int32.to_int 62 | 63 | let list parser = 64 | let rec parse acc = function 65 | | 0 -> Buf_read.return (List.rev acc) 66 | | n -> 67 | let* v = parser in 68 | parse (v :: acc) (n - 1) 69 | in 70 | let* sz = u32 in 71 | parse [] sz 72 | 73 | let string = 74 | let* sz = u32 in 75 | Buf_read.take sz 76 | end 77 | 78 | module Ser = struct 79 | open Buf_write 80 | 81 | let string f s = 82 | let sz = String.length s in 83 | BE.uint32 f (Int32.of_int sz); 84 | string f s 85 | 86 | let u32 f u = BE.uint32 f (Int32.of_int u) 87 | let action f = function Cull -> uint8 f 0x90 | Conserve -> uint8 f 0xa0 88 | end 89 | 90 | let parse_range b = 91 | let species = Parse.string b in 92 | let min = Parse.u32 b in 93 | let max = Parse.u32 b in 94 | { species; min; max } 95 | 96 | let parse_population b = 97 | let species = Parse.string b in 98 | let count = Parse.u32 b in 99 | { species; count } 100 | 101 | let checksum_correct buffer = 102 | let v = ref 0 in 103 | for i = 0 to Cstruct.length buffer - 1 do 104 | v := !v + Cstruct.get_uint8 buffer i 105 | done; 106 | !v mod 256 = 0 107 | 108 | type 'a input = 109 | | From_client : int -> [ `From_client ] input 110 | | From_server : int -> [ `From_server ] input 111 | 112 | type 'a output = 113 | | To_client : int -> [ `To_client ] output 114 | | To_server : int -> [ `To_server ] output 115 | 116 | let get : type a. a input -> Buf_read.t -> a message = 117 | fun kind b -> 118 | Buf_read.ensure b 5; 119 | (* id and length *) 120 | let length = Cstruct.BE.get_uint32 (Buf_read.peek b) 1 |> Int32.to_int in 121 | if length < 5 || length >= 1000000 then failwith "invalid length"; 122 | Buf_read.ensure b length; 123 | if not (checksum_correct (Cstruct.sub (Buf_read.peek b) 0 length)) then 124 | failwith "invalid checksum" 125 | else 126 | let id = Parse.u8 b in 127 | let _ = Parse.u32 b in 128 | let content = 129 | Buf_read.take (length - 4 - 1 - 1) b |> Buf_read.of_string 130 | in 131 | let _ = Parse.u8 b in 132 | let (msg : a message) = 133 | match (id, kind) with 134 | | 0x50, _ -> 135 | let protocol = Parse.string content in 136 | let version = Parse.u32 content in 137 | Hello { protocol; version } 138 | | 0x52, From_server _ -> OK 139 | | 0x54, From_server _ -> 140 | let site = Parse.u32 content in 141 | let populations = Parse.list parse_range content in 142 | TargetPopulations { site; populations } 143 | | 0x57, From_server _ -> 144 | let policy = Parse.u32 content in 145 | PolicyResult { policy } 146 | | 0x58, From_client _ -> 147 | let site = Parse.u32 content in 148 | let populations = Parse.list parse_population content in 149 | SiteVisit { site; populations } 150 | | _ -> failwith "unknown message code" 151 | in 152 | (match kind with 153 | | From_server i -> Logs.info (fun f -> f "%10d <== %s" i (to_string msg)) 154 | | From_client i -> Logs.info (fun f -> f "%5d <-- %s" i (to_string msg))); 155 | if Buf_read.at_end_of_input content then msg 156 | else failwith "not at end of input for content" 157 | 158 | let compute_checksum ~id ~message ~len = 159 | let v = id + len + (len lsr 8) + (len lsr 16) + (len lsr 24) in 160 | let tot = String.fold_left (fun v c -> v + Char.code c) v message in 161 | (256 - (tot mod 256)) mod 256 162 | 163 | let send : type a. a output -> Buf_write.t -> a message -> unit = 164 | fun kind b msg -> 165 | let id, message = 166 | let b = Buf_write.create 128 in 167 | (* todo write message *) 168 | let id = 169 | match (msg, kind) with 170 | | Hello { protocol; version }, (To_client _ | To_server _) -> 171 | Ser.string b protocol; 172 | Ser.u32 b version; 173 | 0x50 174 | | Error { message }, (To_client _ | To_server _) -> 175 | Ser.string b message; 176 | 0x51 177 | | DialAuthority { site }, To_server _ -> 178 | Ser.u32 b site; 179 | 0x53 180 | | CreatePolicy { action; species }, To_server _ -> 181 | Ser.string b species; 182 | Ser.action b action; 183 | 0x55 184 | | DeletePolicy { policy }, To_server _ -> 185 | Ser.u32 b policy; 186 | 0x56 187 | | OK, _ -> . 188 | | TargetPopulations _, _ -> . 189 | | PolicyResult _, _ -> . 190 | | SiteVisit _, _ -> . 191 | in 192 | (id, Buf_write.serialize_to_string b) 193 | in 194 | let len = String.length message + 4 + 1 + 1 in 195 | let checksum = compute_checksum ~id ~message ~len in 196 | Buf_write.uint8 b id; 197 | Buf_write.BE.uint32 b (Int32.of_int len); 198 | Buf_write.string b message; 199 | Buf_write.uint8 b checksum; 200 | Buf_write.flush b; 201 | match kind with 202 | | To_server i -> Logs.info (fun f -> f "%10d ==> %s" i (to_string msg)) 203 | | To_client i -> Logs.info (fun f -> f "%5d --> %s" i (to_string msg)) 204 | 205 | let send_flow a flow msg = Buf_write.with_flow flow @@ fun b -> send a b msg 206 | end 207 | 208 | type policy = Nothing | Cull of int | Conserve of int 209 | 210 | type authority = { 211 | populations_mutex : Eio.Mutex.t; 212 | populations : (string, Protocol.range * policy) Hashtbl.t; 213 | flow : Eio.Flow.two_way; 214 | input : Eio.Buf_read.t; 215 | id : int; 216 | } 217 | 218 | type authority_state = (int, authority Eio.Promise.t) Hashtbl.t 219 | 220 | let authorities : authority_state = Hashtbl.create 100 221 | 222 | let expect_hello v i = 223 | match Protocol.get v i with 224 | | Protocol.Hello { protocol = "pestcontrol"; version = 1 } -> () 225 | | Hello _ -> failwith "unexpected hello content" 226 | | _ -> failwith "unexpected message instead of hello" 227 | 228 | let expect_site_visit v i = 229 | match Protocol.get v i with 230 | | Protocol.SiteVisit e -> e 231 | | _ -> failwith "unexpected message instead of site visit" 232 | 233 | let expect_ok v i = 234 | match Protocol.get v i with 235 | | Protocol.OK -> () 236 | | _ -> failwith "unexpected message instead of ok" 237 | 238 | let expect_populations v i = 239 | match Protocol.get v i with 240 | | Protocol.TargetPopulations e -> e.populations 241 | | _ -> failwith "unexpected message instead of target populations" 242 | 243 | let expect_policy_result v i = 244 | match Protocol.get v i with 245 | | Protocol.PolicyResult { policy } -> policy 246 | | _ -> failwith "unexpected message instead of policy result" 247 | 248 | let send_hello v f = 249 | Protocol.send_flow v f (Hello { protocol = "pestcontrol"; version = 1 }) 250 | 251 | let get_authority ~connect site = 252 | try Eio.Promise.await (Hashtbl.find authorities site) 253 | with Not_found -> 254 | let promise, resolve = Eio.Promise.create () in 255 | Hashtbl.replace authorities site promise; 256 | let flow = (connect () :> Eio.Flow.two_way) in 257 | let input = Buf_read.of_flow ~max_size:100000 flow in 258 | send_hello (To_server site) flow; 259 | expect_hello (From_server site) input; 260 | Protocol.send_flow (To_server site) flow (DialAuthority { site }); 261 | let populations = 262 | expect_populations (From_server site) input 263 | |> List.map (fun (pop : Protocol.range) -> (pop.species, (pop, Nothing))) 264 | |> List.to_seq |> Hashtbl.of_seq 265 | in 266 | let v = 267 | { 268 | populations; 269 | flow; 270 | input; 271 | id = site; 272 | populations_mutex = Mutex.create (); 273 | } 274 | in 275 | Promise.resolve resolve v; 276 | v 277 | 278 | let handle_site_visit ~connect (site_visit : Protocol.site_visit) = 279 | let counts = 280 | let v = Hashtbl.create 100 in 281 | site_visit.populations 282 | |> List.map (fun (v : Protocol.population) -> (v.species, v.count)) 283 | |> List.to_seq 284 | |> Seq.iter (fun (a, b) -> 285 | match Hashtbl.find_opt v a with 286 | | None -> Hashtbl.add v a b 287 | | Some b' when b = b' -> () 288 | | _ -> failwith "inconsistent readings"); 289 | v 290 | in 291 | let { populations; flow; input; id; populations_mutex } = 292 | get_authority ~connect site_visit.site 293 | in 294 | Mutex.use_rw ~protect:false populations_mutex @@ fun () -> 295 | Hashtbl.iter 296 | (fun _ ({ Protocol.min; max; species }, current_policy) -> 297 | let count = Hashtbl.find_opt counts species |> Option.value ~default:0 in 298 | let target_policy = 299 | if min <= count && count <= max then None 300 | else if count < min then Some Protocol.Conserve 301 | else Some Protocol.Cull 302 | in 303 | let to_delete = 304 | match (target_policy, current_policy) with 305 | | None, Nothing -> None 306 | | Some Protocol.Conserve, Conserve _ -> None 307 | | Some Protocol.Cull, Cull _ -> None 308 | | _, (Cull p | Conserve p) -> Some p 309 | | _, Nothing -> None 310 | in 311 | let to_add = 312 | match (target_policy, current_policy) with 313 | | None, Nothing -> None 314 | | Some Protocol.Conserve, Conserve _ -> None 315 | | Some Protocol.Cull, Cull _ -> None 316 | | Some target, _ -> Some target 317 | | None, _ -> None 318 | in 319 | (match to_delete with 320 | | Some policy -> 321 | Protocol.send_flow (To_server id) flow (DeletePolicy { policy }); 322 | expect_ok (From_server id) input 323 | | None -> ()); 324 | let state = 325 | match (to_add, target_policy, current_policy) with 326 | | Some target, _, _ -> ( 327 | Protocol.send_flow (To_server id) flow 328 | (CreatePolicy { species; action = target }); 329 | let p = expect_policy_result (From_server id) input in 330 | match target with Protocol.Cull -> Cull p | Conserve -> Conserve p) 331 | | None, None, _ -> Nothing 332 | | None, Some Protocol.Conserve, Conserve v -> Conserve v 333 | | None, Some Protocol.Cull, Cull v -> Cull v 334 | | _ -> failwith "programming error" 335 | in 336 | Hashtbl.replace populations species ({ Protocol.min; max; species }, state)) 337 | populations 338 | 339 | let handler ~connect flow s = 340 | let id = match s with `Tcp (_, port) -> port | _ -> -1 in 341 | let input = Buf_read.of_flow ~max_size:10_000_000 flow in 342 | try 343 | try 344 | send_hello (To_client id) flow; 345 | expect_hello (From_client id) input; 346 | while true do 347 | let site_visit = expect_site_visit (From_client id) input in 348 | handle_site_visit ~connect site_visit 349 | done 350 | with Failure message -> 351 | Protocol.send_flow (To_client id) flow (Error { message }); 352 | Eio.Flow.shutdown flow `All 353 | with 354 | | End_of_file -> 355 | Logs.info (fun f -> f "EOF"); 356 | Protocol.send_flow (To_client id) flow (Error { message = "EOF" }) 357 | | Eio.Net.Connection_reset _ -> Logs.info (fun f -> f "%d: disconnected" id) 358 | 359 | let () = 360 | Reporter.init (); 361 | Logs.set_level (Some Info); 362 | Eio_linux.run ~queue_depth:2000 @@ fun env -> 363 | Switch.run @@ fun sw -> 364 | let net = Stdenv.net env in 365 | let socket = 366 | Net.listen ~reuse_addr:true ~backlog:10 ~sw net 367 | (`Tcp (Net.Ipaddr.V6.any, 10001)) 368 | in 369 | let remote = 370 | Net.getaddrinfo_stream net "pestcontrol.protohackers.com" 371 | |> List.find_map (function 372 | | `Tcp (ip, _) -> Some (`Tcp (ip, 20547)) 373 | | _ -> None) 374 | |> Option.get 375 | in 376 | let connect () = Net.connect ~sw net remote in 377 | while true do 378 | Net.accept_fork ~sw socket ~on_error:raise (handler ~connect) 379 | done 380 | -------------------------------------------------------------------------------- /2/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries eio eio_main)) 4 | -------------------------------------------------------------------------------- /2/dune-workspace: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) -------------------------------------------------------------------------------- /2/test.ml: -------------------------------------------------------------------------------- 1 | 2 | open Eio 3 | 4 | (* 2: Means to an End 5 | 6 | Your friendly neighbourhood investment bank is having trouble analysing historical price data. They need you to build a TCP server that will let clients insert and query timestamped prices. 7 | Overview 8 | 9 | Clients will connect to your server using TCP. Each client tracks the price of a different asset. Clients send messages to the server that either insert or query the prices. 10 | 11 | Each connection from a client is a separate session. Each session's data represents a different asset, so each session can only query the data supplied by itself. 12 | *) 13 | 14 | module Database : sig 15 | (* this module wraps the database implementation *) 16 | 17 | type t 18 | (* the type for a database state *) 19 | 20 | val v : unit -> t 21 | (* create a new database *) 22 | 23 | val insert : t -> timestamp:int -> int -> t 24 | (* insert into the database *) 25 | 26 | val query : t -> min:int -> max:int -> int 27 | (* query the mean value from the database*) 28 | 29 | end = struct 30 | 31 | module M = Map.Make(Int) 32 | 33 | type t = int M.t 34 | 35 | let v () = M.empty 36 | 37 | let insert t ~timestamp v = M.add timestamp v t 38 | 39 | let query t ~min ~max = 40 | let sum = ref 0 in 41 | let count = ref 0 in 42 | M.iter 43 | (fun k v -> 44 | if k >= min && k <= max then 45 | (sum := !sum + v; 46 | count := !count + 1)) t; 47 | if !count > 0 then 48 | !sum / !count 49 | else 50 | 0 51 | 52 | end 53 | 54 | (* the kind of messages that we can receive *) 55 | type message = 56 | | Insert of { timestamp: int; price: int } 57 | | Query of { mintime: int; maxtime: int } 58 | 59 | (* the state transition depending on the message *) 60 | let handle_message db = function 61 | | Insert { timestamp; price } -> 62 | Database.insert db ~timestamp price, None 63 | | Query { mintime; maxtime } -> 64 | db, Some (Database.query db ~min:mintime ~max:maxtime) 65 | 66 | (* a parser for messages *) 67 | let message_reader = 68 | let open Buf_read in 69 | let open Buf_read.Syntax in 70 | let+ ((c, n1), n2) = any_char <*> take 4 <*> take 4 in 71 | let n1 = String.get_int32_be n1 0 |> Int32.to_int in 72 | let n2 = String.get_int32_be n2 0 |> Int32.to_int in 73 | match c with 74 | | 'Q' -> Query { mintime = n1; maxtime = n2 } 75 | | 'I' -> Insert { timestamp = n1; price = n2 } 76 | | _ -> failwith "parse error" 77 | 78 | (* this loops over requests, keeping the state of the db around, closes the 79 | connection when something fails *) 80 | let handler flow _ = 81 | let buffered_reader = Buf_read.of_flow ~max_size:1_000_000 flow in 82 | let rec loop db = 83 | match message_reader buffered_reader |> handle_message db with 84 | | db, None -> loop db 85 | | db, Some mean -> 86 | let message = Bytes.create 4 in 87 | Bytes.set_int32_be message 0 (Int32.of_int mean); 88 | Flow.copy_string (Bytes.to_string message) flow; 89 | loop db 90 | | exception End_of_file 91 | | exception Failure _ -> () 92 | in 93 | loop (Database.v ()) 94 | 95 | let () = 96 | Eio_main.run @@ fun env -> 97 | Switch.run @@ fun sw -> 98 | let net = Stdenv.net env in 99 | let socket = Net.listen 100 | ~reuse_addr:true ~backlog:10 ~sw net 101 | (`Tcp (Net.Ipaddr.V6.any, 10000)) 102 | in 103 | while true do 104 | Net.accept_fork ~sw socket ~on_error:raise handler 105 | done 106 | -------------------------------------------------------------------------------- /3/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries eio eio_main astring)) 4 | -------------------------------------------------------------------------------- /3/dune-workspace: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) -------------------------------------------------------------------------------- /3/test.ml: -------------------------------------------------------------------------------- 1 | 2 | open Eio 3 | 4 | (* 3: Budget Chat 5 | 6 | Modern messaging software uses too many computing resources, so we're going back to basics. Budget Chat is a simple TCP-based chat room protocol. 7 | 8 | Each message is a single line of ASCII text terminated by a newline character ('\n', or ASCII 10). Clients can send multiple messages per connection. Servers may optionally strip trailing whitespace, such as carriage return characters ('\r', or ASCII 13). All messages are raw ASCII text, not wrapped up in JSON or any other format. 9 | *) 10 | 11 | module Name : sig 12 | (* Abstract names with an enforced policy *) 13 | 14 | type t 15 | 16 | val of_string_exn : string -> t 17 | (* checks that the name is alphanumerical, between 1 and 32 characters. 18 | an exception is raised if it doesn't respect the rules *) 19 | 20 | val to_string : t -> string 21 | 22 | val compare : t -> t -> int 23 | 24 | val pp : t Fmt.t 25 | end = struct 26 | type t = string 27 | 28 | let of_string_exn name = 29 | let open Astring in 30 | let len = String.length name in 31 | if not 32 | (String.for_all Char.Ascii.is_alphanum name 33 | && len > 0 34 | && len < 32) 35 | then 36 | raise (Invalid_argument "name is wrong") 37 | else 38 | name 39 | 40 | let to_string name = name 41 | 42 | let compare = String.compare 43 | 44 | let pp = Fmt.string 45 | 46 | end 47 | 48 | module Room : sig 49 | (* state for the chat room *) 50 | 51 | type t 52 | 53 | val v : unit -> t 54 | (* create a new chat room*) 55 | 56 | type handle 57 | 58 | val add : t -> Name.t -> handle 59 | (* register a new user and obtain a handle *) 60 | 61 | val read : t -> handle -> string 62 | (* check if the corresponding user has messages. blocks if it doesn't *) 63 | 64 | val write : t -> handle -> string -> unit 65 | (* write a message to user users *) 66 | 67 | val remove : t -> handle -> unit 68 | (* remove user from the room *) 69 | 70 | end = struct 71 | 72 | module UserMap = Map.Make(Int) 73 | 74 | type t = { 75 | mutable users: (string Eio.Stream.t * Name.t) UserMap.t; 76 | mutable index: int; 77 | } 78 | 79 | let v () = { 80 | users = UserMap.empty; 81 | index = 0 82 | } 83 | 84 | let broadcast t ?except message = 85 | UserMap.iter 86 | (fun _ (stream, name) -> 87 | if Some name <> except then 88 | Eio.Stream.add stream message) 89 | t.users 90 | 91 | let users t = 92 | UserMap.bindings t.users |> List.map (fun (_, (_, n)) -> n) 93 | 94 | type handle = int 95 | 96 | let add t name = 97 | let handle = t.index in 98 | t.index <- t.index + 1; 99 | broadcast t (Fmt.str "* %a has entered the room\n" Name.pp name); 100 | let stream = Eio.Stream.create max_int in 101 | let users_str = users t |> List.map Name.to_string |> String.concat ", " in 102 | Eio.Stream.add stream (Fmt.str "* The room contains: %s\n" users_str); 103 | t.users <- UserMap.add handle (stream, name) t.users; 104 | handle 105 | 106 | let remove t handle = 107 | let (_, name) = UserMap.find handle t.users in 108 | broadcast t (Fmt.str "* %a has left the room\n" Name.pp name); 109 | t.users <- UserMap.remove handle t.users 110 | 111 | let read t handle = 112 | let (s, _) = UserMap.find handle t.users in 113 | Eio.Stream.take s 114 | 115 | let write t handle msg = 116 | let (_, name) = UserMap.find handle t.users in 117 | let msg_fmt = Fmt.str "[%a] %s\n" Name.pp name msg in 118 | broadcast t ~except:name msg_fmt 119 | 120 | 121 | end 122 | 123 | (* for each user, we ask who they are, then the name is registered in the room 124 | and the handle is used to send and receive messages. this Room abstraction 125 | enables separating the networking from the business logic. *) 126 | let handler ~room flow _ = 127 | let reader = Buf_read.of_flow ~max_size:1_000_000 flow in 128 | Flow.copy_string "Hey, who are you?\n" flow; 129 | let name = Buf_read.line reader |> Name.of_string_exn in 130 | let handle = Room.add room name in 131 | try 132 | (* two concurrent tasks: *) 133 | Fiber.first 134 | (* - reading messages that the user would like to send *) 135 | (fun () -> 136 | while true do 137 | let s = Buf_read.line reader in 138 | Room.write room handle s 139 | done) 140 | (* - sending messages that the user has received *) 141 | (fun () -> 142 | while true do 143 | let s = Room.read room handle in 144 | Eio.Flow.copy_string s flow 145 | done) 146 | 147 | with 148 | | End_of_file -> 149 | Room.remove room handle 150 | 151 | let () = 152 | Eio_main.run @@ fun env -> 153 | Switch.run @@ fun sw -> 154 | let net = Stdenv.net env in 155 | let socket = Net.listen 156 | ~reuse_addr:true ~backlog:10 ~sw net 157 | (`Tcp (Net.Ipaddr.V6.any, 10000)) 158 | in 159 | let room = Room.v () in 160 | while true do 161 | Net.accept_fork ~sw socket ~on_error:ignore (handler ~room) 162 | done 163 | -------------------------------------------------------------------------------- /4/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries eio eio_main astring)) 4 | -------------------------------------------------------------------------------- /4/dune-workspace: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) -------------------------------------------------------------------------------- /4/test.ml: -------------------------------------------------------------------------------- 1 | 2 | open Eio 3 | open Astring 4 | 5 | (* 4: Unusual Database Program 6 | 7 | It's your first day on the job. Your predecessor, Ken, left in mysterious circumstances, but not before coming up with a protocol for the new key-value database. You have some doubts about Ken's motivations, but there's no time for questions! Let's implement his protocol. 8 | 9 | Ken's strange database is a key-value store accessed over UDP. Since UDP does not provide retransmission of dropped packets, and neither does Ken's protocol, clients have to be careful not to send requests too fast, and have to accept that some requests or responses may be dropped. 10 | 11 | Each request, and each response, is a single UDP packet. 12 | 13 | There are only two types of request: insert and retrieve. Insert allows a client to insert a value for a key, and retrieve allows a client to retrieve the value for a key. 14 | *) 15 | 16 | type state = (string, string) Hashtbl.t 17 | 18 | let state = Hashtbl.create 100 19 | 20 | let buffer = Cstruct.create_unsafe 10000 21 | 22 | let handle socket = 23 | let (from, len) = Net.recv socket buffer in 24 | 25 | let respond response = 26 | Net.send socket from (Cstruct.of_string response) 27 | in 28 | 29 | let message = Cstruct.to_string ~len buffer in 30 | match String.cut ~sep:"=" message with 31 | | None when message = "version" -> respond "version=Protocaml v0.42" 32 | | None -> 33 | let value = Hashtbl.find_opt state message |> Option.value ~default:"" in 34 | respond (message ^ "=" ^ value) 35 | | Some (key, value) -> Hashtbl.replace state key value 36 | 37 | let () = 38 | Eio_main.run @@ fun env -> 39 | Switch.run @@ fun sw -> 40 | let net = Stdenv.net env in 41 | let socket = Net.datagram_socket ~sw net (`Udp (Net.Ipaddr.V6.any, 10000)) in 42 | while true do 43 | handle socket 44 | done 45 | -------------------------------------------------------------------------------- /5/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries eio eio_main astring)) 4 | -------------------------------------------------------------------------------- /5/dune-workspace: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) -------------------------------------------------------------------------------- /5/test.ml: -------------------------------------------------------------------------------- 1 | open Eio 2 | 3 | let is_boguscoin str = 4 | let l = String.length str in 5 | l >= 26 && l <= 35 && str.[0] = '7' 6 | 7 | let tony = "7YWHMfk9JZe0LM0g1ZauHuiSxhI" 8 | 9 | let rewrite s input output = 10 | let reader = Buf_read.of_flow ~max_size:1_000_000 input in 11 | try 12 | while true do 13 | (* for each line, we split into words and map those that matches the 14 | boguscoin spec. The tricky part when using the buffered reader is to 15 | know whether the last line before EOF is actually ending with a \n. *) 16 | let line = Buf_read.take_while (fun c -> c <> '\n') reader in 17 | let at_end_of_input = Buf_read.at_end_of_input reader in 18 | Printf.printf "|%s %S (%b)\n%!" s line at_end_of_input; 19 | (* the message is transformed word by word*) 20 | let line = 21 | String.split_on_char ' ' line 22 | |> List.map (fun l -> if is_boguscoin l then tony else l) 23 | |> String.concat " " 24 | in 25 | Printf.printf "|%s %S\n%!" s line; 26 | if at_end_of_input then 27 | begin 28 | Flow.copy_string line output; 29 | raise End_of_file 30 | end 31 | else 32 | begin 33 | Buf_read.char '\n' reader; 34 | Flow.copy_string (line ^ "\n") output 35 | end 36 | done 37 | with 38 | | End_of_file -> () 39 | 40 | let handler ~sw net flow _ = 41 | let upstream = 42 | Net.connect ~sw net 43 | (`Tcp (Eio_unix.Ipaddr.of_unix 44 | (Unix.inet_addr_of_string "206.189.113.124"), 45 | 16963)) 46 | in 47 | Fiber.both 48 | (fun () -> 49 | rewrite "<<" upstream flow; 50 | Printf.printf "end from upstream \n%!"; 51 | Flow.shutdown flow `All) 52 | (fun () -> 53 | rewrite ">>" flow upstream; 54 | Printf.printf "end from client \n%!"; 55 | Flow.shutdown upstream `All) 56 | 57 | let () = 58 | Eio_main.run @@ fun env -> 59 | Switch.run @@ fun sw -> 60 | let net = Stdenv.net env in 61 | let socket = Net.listen 62 | ~reuse_addr:true ~backlog:10 ~sw net 63 | (`Tcp (Net.Ipaddr.V6.any, 10000)) 64 | in 65 | while true do 66 | Net.accept_fork ~sw socket ~on_error:ignore (handler ~sw net) 67 | done 68 | -------------------------------------------------------------------------------- /6/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries eio eio_main astring logs logs.fmt)) 4 | -------------------------------------------------------------------------------- /6/dune-workspace: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) -------------------------------------------------------------------------------- /6/test.ml: -------------------------------------------------------------------------------- 1 | open Eio 2 | 3 | 4 | type camera = {road: int; mile: int; limit: int} 5 | 6 | type dispatcher = { roads: int list} 7 | 8 | type ticket = {plate: string; road: int; mile1: int; timestamp1: int; mile2: int; timestamp2: int; speed: int} 9 | 10 | type client_message = 11 | | Plate of {plate: string; timestamp: int} 12 | | WantHeartbeat of {interval: int} 13 | | IAmCamera of camera 14 | | IAmDispatcher of dispatcher 15 | 16 | type server_message = 17 | | Error of {msg: string} 18 | | Ticket of ticket 19 | | Heartbeat 20 | 21 | module Parse = struct 22 | 23 | open Buf_read.Syntax 24 | 25 | let u8 = 26 | let+ c = Buf_read.any_char in 27 | Char.code c 28 | 29 | let u16 = 30 | let+ c = Buf_read.take 2 in 31 | String.get_uint16_be c 0 32 | 33 | let u32 = 34 | let+ c = Buf_read.take 4 in 35 | String.get_int32_be c 0 |> Int32.to_int 36 | 37 | let list parser = 38 | let rec parse acc = 39 | function 40 | | 0 -> Buf_read.return (List.rev acc) 41 | | n -> 42 | let* v = parser in 43 | parse (v::acc) (n-1) 44 | in 45 | let* sz = u8 in 46 | parse [] sz 47 | 48 | let string = 49 | let* sz = u8 in 50 | Buf_read.take sz 51 | 52 | let client_message = 53 | let open Buf_read.Syntax in 54 | let* msg_type = u8 in 55 | match msg_type with 56 | | 0x20 -> 57 | let* plate = string in 58 | let+ timestamp = u32 in 59 | Plate { plate; timestamp } 60 | | 0x40 -> 61 | let+ interval = u32 in 62 | WantHeartbeat { interval } 63 | | 0x80 -> 64 | let* road = u16 in 65 | let* mile = u16 in 66 | let+ limit = u16 in 67 | IAmCamera {road; mile; limit} 68 | | 0x81 -> 69 | let+ roads = (list u16) in 70 | IAmDispatcher { roads } 71 | | _ -> failwith "parse error" 72 | 73 | end 74 | 75 | module Serialize = struct 76 | 77 | open Buf_write 78 | 79 | 80 | let string w str = 81 | let len = String.length str in 82 | char w (Char.chr len); 83 | string w str 84 | 85 | let u8 w v = char w (Char.chr v) 86 | 87 | let u16 w v = BE.uint16 w v 88 | 89 | let u32 w v = BE.uint32 w (Int32.of_int v) 90 | 91 | let server_message w = 92 | function 93 | | Error {msg} -> 94 | u8 w (0x10); 95 | string w msg 96 | 97 | | Ticket {plate; road; mile1; timestamp1; mile2; timestamp2; speed} -> 98 | u8 w (0x21); 99 | string w plate; 100 | u16 w road; 101 | u16 w mile1; 102 | u32 w timestamp1; 103 | u16 w mile2; 104 | u32 w timestamp2; 105 | u16 w speed 106 | 107 | | Heartbeat -> 108 | u8 w (0x41) 109 | 110 | 111 | let to_flow srz flow = 112 | Switch.run @@ fun sw -> 113 | let w = Buf_write.create ~sw 1000 in 114 | srz w; 115 | let msg = Buf_write.serialize_to_string w in 116 | Flow.copy_string msg flow 117 | end 118 | 119 | type plate = string 120 | 121 | type plate_info = { 122 | plate: string; 123 | timestamp: int; 124 | mile: int; 125 | limit: int; 126 | road: int; 127 | } 128 | 129 | 130 | let dispatchers = Hashtbl.create 10 131 | 132 | let get_or_create_dispatcher road = 133 | match Hashtbl.find_opt dispatchers road with 134 | | Some v -> v 135 | | None -> 136 | let v = Stream.create max_int in 137 | Hashtbl.add dispatchers road v; 138 | v 139 | 140 | let spawn_heartbeat ~v ~sw ~clock flow interval = 141 | if interval > 0 then 142 | (Logs.debug (fun f -> f "[%d] H %d" v interval); 143 | Eio.Fiber.fork ~sw @@ fun () -> 144 | let t = ref (Time.now clock) in 145 | while true do 146 | let next = !t +. (Float.of_int interval) *. 0.1 in 147 | let now = Time.now clock in 148 | (if (next > now) then 149 | if (next > now +. 0.01) then 150 | Time.sleep_until clock next 151 | else 152 | () 153 | else 154 | Logs.err (fun f -> f "[%d] Heartbeat lag" v)); 155 | t := next; 156 | Logs.debug (fun f -> f "[%d] H %d" v interval); 157 | Serialize.(to_flow (fun w -> server_message w Heartbeat)) flow ; 158 | Logs.debug (fun f -> f "[%d] HOK" v) 159 | done) 160 | 161 | let error flow msg = 162 | Serialize.(to_flow (fun w -> server_message w (Error { msg }))) flow 163 | 164 | let camera ~clock ~v ~sw ~flow p ({road; mile; limit} : camera) = 165 | while true do 166 | match Parse.client_message p with 167 | | WantHeartbeat {interval} -> spawn_heartbeat ~clock ~v ~sw flow interval 168 | | Plate { plate; timestamp } -> 169 | Logs.info (fun f -> f "<%d> Plate: %s %d %d" road plate timestamp mile); 170 | let stream = get_or_create_dispatcher road in 171 | Stream.add stream { limit; plate; timestamp; mile; road } 172 | | _ -> error flow "cam: illegal message" 173 | done 174 | 175 | let dispatcher_input ~clock ~v ~sw ~flow p = 176 | while true do 177 | match Parse.client_message p with 178 | | WantHeartbeat {interval} -> spawn_heartbeat ~clock ~v ~sw flow interval 179 | | _ -> error flow "disp: illegal message" 180 | done 181 | 182 | type flash = { 183 | mile: int; 184 | timestamp: int; 185 | road: int; 186 | } 187 | 188 | type controller_state = { 189 | flashes: (plate, flash list) Hashtbl.t; 190 | last_ticket: (plate * int, unit) Hashtbl.t; 191 | } 192 | 193 | let day ts = ts / 86400 194 | 195 | let is_overspeed ~already_fined (plate_info: plate_info) {mile; timestamp; road} = 196 | Fiber.yield (); 197 | if plate_info.road <> road then None 198 | else 199 | if already_fined (day plate_info.timestamp) || already_fined (day timestamp) then 200 | None 201 | else 202 | let distance = Int.abs (plate_info.mile - mile) in 203 | let timedelta = Int.abs (plate_info.timestamp - timestamp) in 204 | (* miles * seconds / hour > seconds * miles / hour *) 205 | if distance * 3600 > timedelta * plate_info.limit then 206 | let speed = 100 * distance * 3600 / timedelta in 207 | let mile1, timestamp1, mile2, timestamp2 = 208 | if plate_info.timestamp < timestamp then 209 | plate_info.mile, plate_info.timestamp, mile, timestamp 210 | else 211 | mile, timestamp, plate_info.mile, plate_info.timestamp 212 | in 213 | Logs.info (fun f -> f "<%d> Ticket: %s %d" road plate_info.plate speed); 214 | Some { 215 | plate = plate_info.plate; 216 | road = plate_info.road; 217 | mile1; 218 | timestamp1; 219 | mile2; 220 | timestamp2; 221 | speed 222 | } 223 | else 224 | None 225 | 226 | 227 | let find_ticket { flashes; last_ticket } plate_info = 228 | match Hashtbl.find_opt flashes plate_info.plate with 229 | | Some o -> 230 | let already_fined day = 231 | Hashtbl.mem last_ticket (plate_info.plate, day) 232 | in 233 | List.find_map (is_overspeed ~already_fined plate_info) o 234 | | None -> None 235 | 236 | let update controller_state plate_info = 237 | let ticket = find_ticket controller_state plate_info in 238 | let st = 239 | Hashtbl.find_opt controller_state.flashes plate_info.plate 240 | |> Option.value ~default:[] 241 | in 242 | Hashtbl.replace 243 | controller_state.flashes 244 | plate_info.plate 245 | ({ mile = plate_info.mile; timestamp = plate_info.timestamp; road = plate_info.road } :: st); 246 | (match ticket with 247 | | Some ticket -> 248 | ( 249 | Hashtbl.replace controller_state.last_ticket (plate_info.plate, day (ticket.timestamp1)) (); 250 | Hashtbl.replace controller_state.last_ticket (plate_info.plate, day (ticket.timestamp2)) ()) 251 | | None ->()); 252 | ticket 253 | 254 | 255 | let dispatcher_workers_state = Hashtbl.create 10 256 | 257 | let get_or_create_state road = 258 | match Hashtbl.find_opt dispatcher_workers_state road with 259 | | Some v -> v 260 | | None -> 261 | let v = {flashes = Hashtbl.create 0; last_ticket = Hashtbl.create 0} in 262 | Hashtbl.add dispatcher_workers_state road v; 263 | v 264 | 265 | let worker ~flow p road stream = 266 | let controller_state = get_or_create_state road in 267 | while true do 268 | let plate = Stream.take stream in 269 | match update controller_state plate with 270 | | None -> () 271 | | Some t -> 272 | Serialize.(to_flow (fun w -> server_message w (Ticket t))) flow 273 | done 274 | 275 | 276 | let dispatcher_output ~flow p { roads } = 277 | List.map (fun i () -> worker ~flow p i (get_or_create_dispatcher i)) roads 278 | |> Fiber.all 279 | 280 | let c = ref 0 281 | 282 | let handler ~clock ~sw:_ _net flow _ = 283 | let v = !c in 284 | incr c; 285 | Logs.info (fun f -> f "[%d] New connection" v); 286 | try 287 | Eio.Switch.run @@ fun sw -> 288 | let p = Buf_read.of_flow ~max_size:100000 flow in 289 | while true do 290 | match Parse.client_message p with 291 | | IAmCamera c -> 292 | Logs.info (fun f -> f "[%d] Camera: %d %d %d" v c.road c.limit c.mile); 293 | camera ~clock ~v ~flow ~sw p c 294 | | IAmDispatcher d -> 295 | Logs.info (fun f -> f "[%d] Dispatcher: %d %a" v (List.length d.roads) Fmt.(list int) d.roads); 296 | Fiber.both 297 | (fun () -> dispatcher_input ~clock ~v ~flow ~sw p) 298 | (fun () -> dispatcher_output ~flow p d) 299 | | WantHeartbeat { interval } -> spawn_heartbeat ~clock ~v ~sw flow interval 300 | | _ -> Flow.shutdown flow `All 301 | done 302 | with 303 | | Eio.Net.Connection_reset _ -> 304 | Logs.info (fun f -> f "[%d] Connection reset" v) 305 | | End_of_file -> 306 | (Flow.shutdown flow `All; 307 | Logs.info (fun f -> f "[%d] EOF" v)) 308 | | Failure msg -> 309 | error flow msg 310 | 311 | 312 | 313 | let c = Mtime_clock.counter () 314 | 315 | let reporter ppf = 316 | let report src level ~over k msgf = 317 | let k _ = over (); k () in 318 | let with_stamp h tags k ppf fmt = 319 | Format.kfprintf k ppf ("%a[%a] @[" ^^ fmt ^^ "@]@.") 320 | Logs.pp_header (level, h) Mtime.Span.pp (Mtime_clock.count c) 321 | in 322 | msgf @@ fun ?header ?tags fmt -> with_stamp header tags k ppf fmt 323 | in 324 | { Logs.report = report } 325 | 326 | let () = 327 | Logs.set_level (Some Info); 328 | Logs.set_reporter (reporter (Format.std_formatter)); 329 | Eio_linux.run ~queue_depth:300 @@ fun env -> 330 | Switch.run @@ fun sw -> 331 | let net = Stdenv.net env in 332 | let clock = Stdenv.clock env in 333 | let socket = Net.listen 334 | ~reuse_addr:true ~backlog:1000 ~sw net 335 | (`Tcp (Net.Ipaddr.V6.any, 10000)) 336 | in 337 | while true do 338 | Logs.debug (fun f -> f "W"); 339 | Net.accept_fork ~sw socket ~on_error:raise (handler ~clock ~sw net) 340 | done 341 | -------------------------------------------------------------------------------- /7/.ocamlformat: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TheLortex/protocaml/2d1c38692aaf4ff007f2cd16fecf22bb5764842f/7/.ocamlformat -------------------------------------------------------------------------------- /7/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries eio eio_main astring logs logs.fmt fmt.tty)) 4 | -------------------------------------------------------------------------------- /7/dune-workspace: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) -------------------------------------------------------------------------------- /7/lrcp.ml: -------------------------------------------------------------------------------- 1 | open Eio 2 | 3 | module Session : sig 4 | type t 5 | 6 | val of_string : string -> t 7 | val to_string : t -> string 8 | end = struct 9 | type t = int 10 | 11 | let of_string = int_of_string 12 | let to_string = string_of_int 13 | end 14 | 15 | module Frame = struct 16 | type t = 17 | | Connect of Session.t 18 | | Data of (Session.t * int * Cstruct.t) 19 | | Ack of (Session.t * int) 20 | | Close of Session.t 21 | 22 | let take_next_part = 23 | let open Eio.Buf_read.Syntax in 24 | let open Eio.Buf_read in 25 | let* v = take_while1 (( <> ) '/') in 26 | let+ () = char '/' in 27 | v 28 | 29 | let take_message = 30 | let open Eio.Buf_read.Syntax in 31 | let open Eio.Buf_read in 32 | let+ message = take_all in 33 | let open Astring in 34 | let len = String.length message in 35 | if message.[len - 1] = '/' then Cstruct.of_string ~len:(len - 1) message 36 | else failwith "parse error" 37 | 38 | let parser = 39 | let open Eio.Buf_read.Syntax in 40 | let open Eio.Buf_read in 41 | let* () = char '/' in 42 | let* typ' = take_next_part in 43 | let* session = take_next_part in 44 | let session = Session.of_string session in 45 | match typ' with 46 | | "connect" -> return (Connect session) 47 | | "close" -> return (Close session) 48 | | "data" -> 49 | let* pos = take_next_part in 50 | let pos = int_of_string pos in 51 | let* message = take_message in 52 | return (Data (session, pos, message)) 53 | | "ack" -> 54 | let* len = take_next_part in 55 | let len = int_of_string len in 56 | return (Ack (session, len)) 57 | | _ -> failwith "unknown message type" 58 | 59 | let parser_opt b = try Some (parser b) with Failure _ -> None 60 | 61 | let type_to_string = function 62 | | Connect _ -> "connect" 63 | | Close _ -> "close" 64 | | Data _ -> "data" 65 | | Ack _ -> "ack" 66 | 67 | let session = function 68 | | Connect session | Close session | Data (session, _, _) | Ack (session, _) 69 | -> 70 | session 71 | 72 | let serializer b pkt = 73 | let open Eio.Buf_write in 74 | char b '/'; 75 | string b (type_to_string pkt); 76 | char b '/'; 77 | string b (Session.to_string (session pkt)); 78 | char b '/'; 79 | match pkt with 80 | | Connect _ | Close _ -> () 81 | | Data (_, pos, msg) -> 82 | string b (string_of_int pos); 83 | char b '/'; 84 | cstruct b msg; 85 | char b '/' 86 | | Ack (_, len) -> 87 | string b (string_of_int len); 88 | char b '/' 89 | end 90 | 91 | module Encoding = struct 92 | let unescape message = 93 | let len = Cstruct.length message in 94 | let pos = ref 0 in 95 | let esc = ref false in 96 | for i = 0 to len - 1 do 97 | match (!esc, Cstruct.get message i) with 98 | | true, (('\\' | '/') as c) -> 99 | Cstruct.set_char message !pos c; 100 | esc := false; 101 | incr pos 102 | | true, _ -> failwith "calling the police" 103 | | _, '\\' -> esc := true 104 | | _, '/' -> failwith "calling the police" 105 | | _, c -> 106 | Cstruct.set_char message !pos c; 107 | incr pos 108 | done; 109 | (* escape eof *) 110 | if !pos < len then Cstruct.sub message 0 !pos else message 111 | 112 | let escape_slice_map ~max_size message fn = 113 | let len = Cstruct.length message in 114 | let pos = ref 0 in 115 | let buf_pos = ref 0 in 116 | let buf = Cstruct.create_unsafe max_size in 117 | for i = 0 to len - 1 do 118 | (match Cstruct.get message i with 119 | | ('/' | '\\') as c -> 120 | Cstruct.set_char buf !buf_pos '\\'; 121 | incr buf_pos; 122 | Cstruct.set_char buf !buf_pos c; 123 | incr buf_pos 124 | | c -> 125 | Cstruct.set_char buf !buf_pos c; 126 | incr buf_pos); 127 | if !buf_pos >= max_size - 1 then ( 128 | fn (i + 1 - !pos) (Cstruct.sub buf 0 !buf_pos); 129 | pos := i + 1; 130 | buf_pos := 0) 131 | done; 132 | if !buf_pos > 0 then fn (len - !pos) (Cstruct.sub buf 0 !buf_pos) 133 | end 134 | 135 | let () = 136 | (* a small test *) 137 | let msg = Cstruct.of_string "111\\///222\\333345" in 138 | Encoding.escape_slice_map ~max_size:5 msg (fun len slice -> 139 | Printf.printf "%d %s\n" len (Cstruct.to_string slice)) 140 | 141 | let max_buf_size = 1000 142 | 143 | module Dispatcher : sig 144 | type t 145 | (** The dispatcher is in charge of UDP socket. It receives messages and 146 | dispatch them to the appropriate listener (either session or new 147 | connection). *) 148 | 149 | val make : Net.datagram_socket -> t 150 | val send : t -> Net.Sockaddr.datagram -> Frame.t -> unit 151 | val recv : t -> Session.t -> Frame.t 152 | val connect : t -> Session.t * Net.Sockaddr.datagram 153 | end = struct 154 | type t = { 155 | socket : Net.datagram_socket; 156 | listeners : (Session.t, Frame.t Stream.t) Hashtbl.t; 157 | default : (Session.t * Net.Sockaddr.datagram) Stream.t; 158 | receiving : Semaphore.t; 159 | } 160 | 161 | let make socket = 162 | { 163 | socket; 164 | listeners = Hashtbl.create 1; 165 | default = Stream.create max_int; 166 | receiving = Semaphore.make 1; 167 | } 168 | 169 | let send t datagram msg = 170 | let w = Buf_write.create max_buf_size in 171 | Frame.serializer w msg; 172 | let cs = Buf_write.serialize_to_cstruct w in 173 | Logs.debug (fun f -> f "<-- %s" (Cstruct.to_string cs)); 174 | Eio.Net.send t.socket datagram cs 175 | 176 | let rec dispatch_packets t = 177 | let recv_buffer = Cstruct.create_unsafe max_buf_size in 178 | let datagram, len = 179 | Semaphore.acquire t.receiving; 180 | Fun.protect ~finally:(fun () -> Semaphore.release t.receiving) 181 | @@ fun () -> Eio.Net.recv t.socket recv_buffer 182 | in 183 | Logs.debug (fun f -> 184 | f "--> %s" (Cstruct.sub recv_buffer 0 len |> Cstruct.to_string)); 185 | let r = 186 | try 187 | Buf_read.of_flow ~max_size:max_buf_size 188 | (Flow.cstruct_source [ Cstruct.sub recv_buffer 0 len ]) 189 | |> Frame.parser_opt 190 | with End_of_file -> None 191 | in 192 | Option.iter 193 | (fun packet -> 194 | let session = Frame.session packet in 195 | match (Hashtbl.find_opt t.listeners session, packet) with 196 | | None, Frame.Connect _ -> Stream.add t.default (session, datagram) 197 | | Some stream, _ -> Stream.add stream packet 198 | | None, Frame.Ack (session, _) -> send t datagram (Frame.Close session) 199 | | _ -> ()) 200 | r; 201 | dispatch_packets t 202 | 203 | let recv t target = 204 | let stream = 205 | match Hashtbl.find_opt t.listeners target with 206 | | None -> 207 | let stream = Stream.create max_int in 208 | Hashtbl.add t.listeners target stream; 209 | stream 210 | | Some s -> s 211 | in 212 | Fiber.first (fun () -> Stream.take stream) (fun () -> dispatch_packets t) 213 | 214 | let connect t = 215 | Fiber.first (fun () -> Stream.take t.default) (fun () -> dispatch_packets t) 216 | end 217 | 218 | type conn_state = { 219 | mutable closed : bool; 220 | mutable send_pos : int; 221 | mutable send_ack : int; 222 | mutable recv_pos : int; 223 | msg : Cstruct.t Stream.t; 224 | mutable extra : Cstruct.t; 225 | } 226 | 227 | let max_header_size = 1 + 4 + 1 + 10 + 1 + 10 + 1 + 1 228 | 229 | let connection ~sw dispatcher (session, datagram) = 230 | let state = 231 | { 232 | closed = false; 233 | send_pos = 0; 234 | send_ack = 0; 235 | recv_pos = 0; 236 | msg = Stream.create max_int; 237 | extra = Cstruct.empty; 238 | } 239 | in 240 | Fiber.fork ~sw (fun () -> 241 | while true do 242 | match Dispatcher.recv dispatcher session with 243 | | Frame.Connect _ -> 244 | (* they don't know we're connected *) 245 | Dispatcher.send dispatcher datagram (Frame.Ack (session, 0)) 246 | | Data (_, pos, msg) when state.recv_pos = pos -> ( 247 | try 248 | let msg = Encoding.unescape msg in 249 | let len = Cstruct.length msg in 250 | state.recv_pos <- len + state.recv_pos; 251 | Dispatcher.send dispatcher datagram 252 | (Frame.Ack (session, state.recv_pos)); 253 | Stream.add state.msg msg 254 | with Failure _ -> ()) 255 | | Data _ -> 256 | Dispatcher.send dispatcher datagram 257 | (Frame.Ack (session, state.recv_pos)) 258 | | Ack (_, len) when len > state.send_ack && len <= state.send_pos -> 259 | state.send_ack <- len 260 | | Ack (_, len) when len > state.send_pos || state.closed -> 261 | state.closed <- true; 262 | Dispatcher.send dispatcher datagram (Frame.Close session) 263 | | Ack _ -> () 264 | | Close _ -> 265 | state.closed <- true; 266 | Dispatcher.send dispatcher datagram (Frame.Close session) 267 | done); 268 | (object (self) 269 | inherit Flow.sink 270 | inherit Flow.source 271 | method close = () 272 | 273 | method copy src = 274 | let msg = Cstruct.create_unsafe max_buf_size in 275 | try 276 | while true do 277 | let len = src#read_into msg in 278 | Encoding.escape_slice_map 279 | ~max_size:(max_buf_size - max_header_size) 280 | (Cstruct.sub msg 0 len) 281 | @@ fun buf_len buf -> 282 | Logs.debug (fun f -> f "<== %s" (Cstruct.to_string buf)); 283 | let pos = state.send_pos in 284 | let target = state.send_pos + buf_len in 285 | state.send_pos <- target; 286 | let message = Frame.Data (session, pos, buf) in 287 | Dispatcher.send dispatcher datagram message; 288 | (* copy buffer before queuing for retransmit *) 289 | let buf = Cstruct.append buf Cstruct.empty in 290 | Fiber.fork ~sw (fun () -> 291 | Eio_unix.sleep 3.0; 292 | while state.send_ack < target && not state.closed do 293 | Logs.debug (fun f -> f "<-- [RETRANSMISSION]"); 294 | Dispatcher.send dispatcher datagram 295 | (Frame.Data (session, pos, buf)); 296 | Eio_unix.sleep 3.0 297 | done) 298 | done 299 | with End_of_file -> () 300 | 301 | method read_into cstruct = 302 | let l0 = Cstruct.length cstruct in 303 | let buf = 304 | if Cstruct.length state.extra > 0 then ( 305 | let buf = state.extra in 306 | state.extra <- Cstruct.empty; 307 | buf) 308 | else Stream.take state.msg 309 | in 310 | if Cstruct.length buf == 0 then self#read_into cstruct 311 | else 312 | let l1 = Cstruct.length buf in 313 | let len = 314 | (* target buffer can contain everything *) 315 | if l0 >= l1 then ( 316 | Cstruct.blit buf 0 cstruct 0 l1; 317 | l1) 318 | else ( 319 | (* l0 < l1: we have to split the buffer and save the extra data *) 320 | Cstruct.blit buf 0 cstruct 0 l0; 321 | state.extra <- Cstruct.sub buf l0 (l1 - l0); 322 | l0) 323 | in 324 | Logs.debug (fun f -> 325 | f "%d/%d ==> %s" l0 l1 326 | (Cstruct.to_string (Cstruct.sub cstruct 0 len))); 327 | len 328 | 329 | method shutdown cmd = () 330 | end 331 | :> < Net.stream_socket ; Flow.close >) 332 | 333 | let listen socket = 334 | object (self) 335 | inherit Net.listening_socket 336 | val dispatcher = Dispatcher.make socket 337 | 338 | method accept ~sw = 339 | let session, datagram = Dispatcher.connect dispatcher in 340 | Dispatcher.send dispatcher datagram (Frame.Ack (session, 0)); 341 | let c = connection ~sw dispatcher (session, datagram) in 342 | Switch.on_release sw (fun () -> c#close); 343 | (c, `Unix "") 344 | 345 | method close = () 346 | end 347 | -------------------------------------------------------------------------------- /7/lrcp.mli: -------------------------------------------------------------------------------- 1 | val listen : Eio.Net.datagram_socket -> Eio.Net.listening_socket 2 | -------------------------------------------------------------------------------- /7/test.ml: -------------------------------------------------------------------------------- 1 | open Eio 2 | 3 | let handler ~clock ~sw flow _ = 4 | Logs.info (fun f -> f "New connection!"); 5 | (try 6 | let buf = Buf_read.of_flow ~max_size:200000 flow in 7 | while true do 8 | let line = Buf_read.line buf in 9 | Logs.info (fun f -> f ">>> %s" line); 10 | let rev = 11 | line |> String.to_seq |> List.of_seq |> List.cons '\n' |> List.rev 12 | |> List.to_seq |> String.of_seq 13 | in 14 | Logs.info (fun f -> f "<<< %s" rev); 15 | Flow.copy_string rev flow 16 | done 17 | with End_of_file -> ()); 18 | Logs.info (fun f -> f "The end") 19 | 20 | let c = Mtime_clock.counter () 21 | 22 | let reporter ppf = 23 | let report src level ~over k msgf = 24 | let k _ = 25 | over (); 26 | k () 27 | in 28 | let with_stamp h tags k ppf fmt = 29 | Format.kfprintf k ppf 30 | ("%a[%a] @[" ^^ fmt ^^ "@]@.") 31 | Logs.pp_header (level, h) Mtime.Span.pp (Mtime_clock.count c) 32 | in 33 | msgf @@ fun ?header ?tags fmt -> with_stamp header tags k ppf fmt 34 | in 35 | { Logs.report } 36 | 37 | let () = 38 | Fmt_tty.setup_std_outputs (); 39 | Logs.set_level (Some Info); 40 | Logs.set_reporter (reporter Format.std_formatter); 41 | Eio_linux.run ~queue_depth:300 @@ fun env -> 42 | Switch.run @@ fun sw -> 43 | let net = Stdenv.net env in 44 | let clock = Stdenv.clock env in 45 | let socket = Net.datagram_socket ~sw net (`Udp (Net.Ipaddr.V6.any, 10000)) in 46 | let lrcp = Lrcp.listen (socket :> Net.datagram_socket) in 47 | while true do 48 | Net.accept_fork ~sw lrcp ~on_error:raise (handler ~clock ~sw) 49 | done 50 | -------------------------------------------------------------------------------- /8/.ocamlformat: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TheLortex/protocaml/2d1c38692aaf4ff007f2cd16fecf22bb5764842f/8/.ocamlformat -------------------------------------------------------------------------------- /8/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries eio eio_main astring logs logs.fmt fmt.tty)) 4 | -------------------------------------------------------------------------------- /8/dune-workspace: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) -------------------------------------------------------------------------------- /8/isl.ml: -------------------------------------------------------------------------------- 1 | open Eio 2 | 3 | type cipher = Rev | Xor of int | Xorpos | Add of int | Addpos 4 | 5 | let reverse_bits v = 6 | let res = ref 0 in 7 | for i = 0 to 7 do 8 | if v land (1 lsl i) > 0 then res := (2 * !res) + 1 else res := 2 * !res 9 | done; 10 | !res 11 | 12 | let reverse_bits = Array.init 256 reverse_bits 13 | 14 | let () = 15 | assert (reverse_bits.(0) = 0); 16 | assert (reverse_bits.(255) = 255); 17 | assert (reverse_bits.(1) = 128); 18 | assert (reverse_bits.(2) = 64); 19 | assert (reverse_bits.(3) = 128 + 64) 20 | 21 | let rec parse_cipher b acc = 22 | let next = Buf_read.any_char b in 23 | match next with 24 | | '\000' -> List.rev acc 25 | | c -> 26 | let next = 27 | match c with 28 | | '\001' -> Rev 29 | | '\002' -> Xor (Buf_read.any_char b |> Char.code) 30 | | '\003' -> Xorpos 31 | | '\004' -> Add (Buf_read.any_char b |> Char.code) 32 | | '\005' -> Addpos 33 | | _ -> failwith "unk" 34 | in 35 | parse_cipher b (next :: acc) 36 | 37 | let pmod a n = ((a mod n) + n) mod n 38 | 39 | let encode_instr ~pos c = function 40 | | Rev -> reverse_bits.(pmod c 256) 41 | | Xor n -> c lxor n 42 | | Xorpos -> c lxor pos 43 | | Add n -> c + n 44 | | Addpos -> c + pos 45 | 46 | let rec encode ~pos c = function 47 | | [] -> c 48 | | instr :: next -> encode ~pos (encode_instr ~pos c instr) next 49 | 50 | let decode_instr ~pos c = function 51 | | Rev -> reverse_bits.(pmod c 256) 52 | | Xor n -> c lxor n 53 | | Xorpos -> c lxor pos 54 | | Add n -> c - n 55 | | Addpos -> c - pos 56 | 57 | let rec decode ~pos c = function 58 | | [] -> c 59 | | instr :: next -> 60 | let d = decode ~pos c next in 61 | decode_instr ~pos d instr 62 | 63 | let check_valid_cipher cipher = 64 | List.init 256 Fun.id 65 | |> List.exists (fun c -> pmod (decode ~pos:127 c cipher) 256 <> c) 66 | 67 | let () = 68 | assert (not (check_valid_cipher [])); 69 | assert (not (check_valid_cipher [ Xor 0 ])); 70 | assert (not (check_valid_cipher [ Xor 2; Xor 2 ])); 71 | assert (not (check_valid_cipher [ Rev; Rev ])) 72 | 73 | let server flow = 74 | let b = Buf_read.of_flow ~max_size:1500 flow in 75 | let cipher = parse_cipher b [] in 76 | if not (check_valid_cipher cipher) then failwith "Invalid cipher" 77 | else 78 | let pos_in = ref 0 in 79 | let pos_out = ref 0 in 80 | let encode c = 81 | let c = Char.chr (pmod (encode ~pos:!pos_out (Char.code c) cipher) 256) in 82 | incr pos_out; 83 | c 84 | in 85 | let decode c = 86 | let c = Char.chr (pmod (decode ~pos:!pos_in (Char.code c) cipher) 256) in 87 | incr pos_in; 88 | c 89 | in 90 | object 91 | inherit Eio.Flow.two_way 92 | method shutdown = flow#shutdown 93 | 94 | method read_into cstruct = 95 | let l = flow#read_into cstruct in 96 | for i = 0 to l - 1 do 97 | Cstruct.set_char cstruct i (decode (Cstruct.get_char cstruct i)) 98 | done; 99 | l 100 | 101 | method copy src = 102 | let msg = Cstruct.create_unsafe 1500 in 103 | try 104 | while true do 105 | let len = src#read_into msg in 106 | let cst = Cstruct.sub msg 0 len in 107 | let data = Cstruct.map encode cst in 108 | flow#write [ data ] 109 | done 110 | with End_of_file -> () 111 | end 112 | -------------------------------------------------------------------------------- /8/isl.mli: -------------------------------------------------------------------------------- 1 | val server : Eio.Flow.two_way -> Eio.Flow.two_way 2 | -------------------------------------------------------------------------------- /8/test.ml: -------------------------------------------------------------------------------- 1 | open Eio 2 | 3 | module Toys = struct 4 | type t = { quantity : int; name : string } 5 | 6 | let of_string x = 7 | match String.split_on_char ' ' x with 8 | | [] | [ _ ] -> assert false 9 | | quantity :: name -> 10 | assert (quantity.[String.length quantity - 1] = 'x'); 11 | { 12 | quantity = 13 | int_of_string (String.sub quantity 0 (String.length quantity - 1)); 14 | name = String.concat " " name; 15 | } 16 | 17 | let to_string x = Fmt.str "%dx %s" x.quantity x.name 18 | let compare a b = Int.compare a.quantity b.quantity 19 | end 20 | 21 | let handler ~clock ~sw flow _ = 22 | Logs.info (fun f -> f "New connection!"); 23 | (try 24 | let buf = Buf_read.of_flow ~max_size:200000 flow in 25 | while true do 26 | let line = Buf_read.line buf in 27 | Logs.info (fun f -> f ">>> %s" line); 28 | 29 | let toys_req = 30 | line |> String.split_on_char ',' |> List.map Toys.of_string 31 | |> List.sort Toys.compare |> List.rev 32 | in 33 | let rev = List.hd toys_req |> Toys.to_string in 34 | Logs.info (fun f -> f "<<< %s" rev); 35 | Flow.copy_string (rev ^ "\n") flow 36 | done 37 | with End_of_file -> ()); 38 | Logs.info (fun f -> f "The end") 39 | 40 | let c = Mtime_clock.counter () 41 | 42 | let reporter ppf = 43 | let report src level ~over k msgf = 44 | let k _ = 45 | over (); 46 | k () 47 | in 48 | let with_stamp h tags k ppf fmt = 49 | Format.kfprintf k ppf 50 | ("%a[%a] @[" ^^ fmt ^^ "@]@.") 51 | Logs.pp_header (level, h) Mtime.Span.pp (Mtime_clock.count c) 52 | in 53 | msgf @@ fun ?header ?tags fmt -> with_stamp header tags k ppf fmt 54 | in 55 | { Logs.report } 56 | 57 | let () = 58 | Fmt_tty.setup_std_outputs (); 59 | Logs.set_level (Some Info); 60 | Logs.set_reporter (reporter Format.std_formatter); 61 | Eio_linux.run ~queue_depth:300 @@ fun env -> 62 | Switch.run @@ fun sw -> 63 | let net = Stdenv.net env in 64 | let clock = Stdenv.clock env in 65 | let socket = 66 | Net.listen ~backlog:10 ~reuse_addr:true ~sw net 67 | (`Tcp (Net.Ipaddr.V6.any, 10000)) 68 | in 69 | while true do 70 | Net.accept_fork ~sw socket ~on_error:raise (fun flow s -> 71 | try 72 | let secure_flow = Isl.server flow in 73 | handler ~clock ~sw secure_flow s 74 | with Failure msg -> 75 | Logs.err (fun f -> f "==> %s" msg); 76 | Eio.Flow.shutdown flow `All) 77 | done 78 | -------------------------------------------------------------------------------- /9/.ocamlformat: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/TheLortex/protocaml/2d1c38692aaf4ff007f2cd16fecf22bb5764842f/9/.ocamlformat -------------------------------------------------------------------------------- /9/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries eio eio_main astring logs logs.fmt fmt.tty yojson psq)) 4 | -------------------------------------------------------------------------------- /9/dune-workspace: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) -------------------------------------------------------------------------------- /9/job_id.ml: -------------------------------------------------------------------------------- 1 | type t = int 2 | 3 | let compare = Int.compare 4 | let id = ref 0 5 | 6 | let next () = 7 | let v = !id in 8 | incr id; 9 | v 10 | 11 | let to_int = Fun.id 12 | let of_int = Fun.id 13 | -------------------------------------------------------------------------------- /9/job_id.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val compare : t -> t -> int 4 | val next : unit -> t 5 | val to_int : t -> int 6 | val of_int : int -> t 7 | -------------------------------------------------------------------------------- /9/json.ml: -------------------------------------------------------------------------------- 1 | open Yojson.Safe.Util 2 | open Protocol 3 | 4 | let id_to_json ({ id } : id) : Yojson.Safe.t = 5 | `Assoc [ ("id", `Int (Job_id.to_int id)) ] 6 | 7 | let id_of_json json = { id = member "id" json |> to_int |> Job_id.of_int } 8 | let unit_to_json () = `Assoc [] 9 | 10 | let get_response_to_json ({ id; job; pri; queue } : get_response) : 11 | Yojson.Safe.t = 12 | `Assoc 13 | [ 14 | ("id", `Int (Job_id.to_int id)); 15 | ("job", job); 16 | ("pri", `Int pri); 17 | ("queue", `String queue); 18 | ] 19 | 20 | let put_of_json json = 21 | { 22 | job = member "job" json; 23 | pri = member "pri" json |> to_int; 24 | queue = member "queue" json |> to_string; 25 | } 26 | 27 | let get_of_json json = 28 | { 29 | queues = member "queues" json |> to_list |> List.map to_string; 30 | wait = 31 | (try member "wait" json |> to_bool 32 | with Yojson.Safe.Util.Type_error _ -> false); 33 | } 34 | 35 | let request_of_json : Yojson.Safe.t -> any_request = 36 | fun json -> 37 | match member "request" json |> to_string with 38 | | "put" -> U (Put (put_of_json json)) 39 | | "get" -> U (Get (get_of_json json)) 40 | | "delete" -> U (Delete (id_of_json json)) 41 | | "abort" -> U (Abort (id_of_json json)) 42 | | _ -> raise (Yojson.Json_error "request member") 43 | 44 | let response_to_json body_to_json = function 45 | | Ok i -> 46 | Yojson.Safe.Util.combine (body_to_json i) 47 | (`Assoc [ ("status", `String "ok") ]) 48 | | NoJob -> `Assoc [ ("status", `String "no-job") ] 49 | | Error msg -> `Assoc [ ("status", `String "error"); ("error", `String msg) ] 50 | 51 | let serializer_of_request : type a. a request -> a -> Yojson.Safe.t = function 52 | | Put _ -> id_to_json 53 | | Get _ -> get_response_to_json 54 | | Delete _ -> unit_to_json 55 | | Abort _ -> unit_to_json 56 | -------------------------------------------------------------------------------- /9/json.mli: -------------------------------------------------------------------------------- 1 | val unit_to_json : unit -> Yojson.Safe.t 2 | val request_of_json : Yojson.Safe.t -> Protocol.any_request 3 | 4 | val response_to_json : 5 | ('a -> Yojson.Safe.t) -> 'a Protocol.status -> Yojson.Safe.t 6 | 7 | val serializer_of_request : 'a Protocol.request -> 'a -> Yojson.Safe.t 8 | -------------------------------------------------------------------------------- /9/main.ml: -------------------------------------------------------------------------------- 1 | open Eio 2 | open Protocol 3 | 4 | type state = (Job_id.t, get_response) Hashtbl.t 5 | 6 | let handle_next_request : type a. state -> a request -> a status = 7 | fun pending -> function 8 | | Put { queue; job; pri } -> 9 | let id = Q.put ~name:queue job pri in 10 | Ok { id } 11 | | Get { queues; wait = false } -> ( 12 | match Q.get_opt queues with 13 | | Some v -> 14 | Hashtbl.add pending v.id v; 15 | Ok v 16 | | None -> NoJob) 17 | | Get { queues; wait = true } -> 18 | let v = Q.get_wait queues in 19 | Hashtbl.add pending v.id v; 20 | Ok v 21 | | Delete { id } -> if Q.delete id then Ok () else NoJob 22 | | Abort { id } -> ( 23 | if 24 | (* check that job is not deleted from another client *) 25 | not (Q.is_pending id) 26 | then NoJob 27 | else 28 | match Hashtbl.find_opt pending id with 29 | | None -> NoJob 30 | | Some v -> 31 | Hashtbl.remove pending v.id; 32 | Q.put_back v; 33 | Ok ()) 34 | 35 | let handler ~clock ~sw flow _ = 36 | Logs.info (fun f -> f "New connection!"); 37 | let buf_read = Buf_read.of_flow ~max_size:1_000_000 flow in 38 | let state = Hashtbl.create 10 in 39 | try 40 | while true do 41 | let line = Buf_read.line buf_read in 42 | Logs.info (fun f -> f "<-- %s" line); 43 | let response = 44 | try 45 | let json = Yojson.Safe.from_string line in 46 | let (U request) = Json.request_of_json json in 47 | let response = handle_next_request state request in 48 | let serializer = Json.serializer_of_request request in 49 | Json.response_to_json serializer response 50 | with exn -> 51 | Json.response_to_json Json.unit_to_json 52 | (Error (Printexc.to_string exn)) 53 | in 54 | let res = Yojson.Safe.to_string response in 55 | Logs.info (fun f -> f "--> %s" res); 56 | Eio.Flow.copy_string (res ^ "\n") flow 57 | done 58 | with End_of_file | Eio.Net.Connection_reset _ -> 59 | Hashtbl.iter 60 | (fun id v -> handle_next_request state (Abort { id }) |> ignore) 61 | state; 62 | Logs.info (fun f -> f "The end") 63 | 64 | let () = 65 | Reporter.init (); 66 | Eio_linux.run ~queue_depth:2000 @@ fun env -> 67 | Switch.run @@ fun sw -> 68 | let net = Stdenv.net env in 69 | let clock = Stdenv.clock env in 70 | let socket = 71 | Net.listen ~backlog:10 ~reuse_addr:true ~sw net 72 | (`Tcp (Net.Ipaddr.V6.any, 10000)) 73 | in 74 | while true do 75 | Net.accept_fork ~sw socket ~on_error:raise (fun flow s -> 76 | try handler ~clock ~sw flow s 77 | with Failure msg -> 78 | Logs.err (fun f -> f "==> %s" msg); 79 | Eio.Flow.shutdown flow `All) 80 | done 81 | -------------------------------------------------------------------------------- /9/protocol.ml: -------------------------------------------------------------------------------- 1 | 2 | type put = { job : Yojson.Safe.t; pri : int; queue : string } 3 | type id = { id : Job_id.t } 4 | type get = { queues : string list; wait : bool } 5 | 6 | type get_response = { 7 | id : Job_id.t; 8 | job : Yojson.Safe.t; 9 | pri : int; 10 | queue : string; 11 | } 12 | 13 | type 'a request = 14 | | Put : put -> id request 15 | | Get : get -> get_response request 16 | | Delete : id -> unit request 17 | | Abort : id -> unit request 18 | 19 | type any_request = U : 'a request -> any_request 20 | type 'a status = Ok of 'a | Error of string | NoJob 21 | -------------------------------------------------------------------------------- /9/q.ml: -------------------------------------------------------------------------------- 1 | module Entry = struct 2 | type t = { job : Yojson.Safe.t; id : Job_id.t } 3 | 4 | let compare a b = Job_id.compare a.id b.id 5 | end 6 | 7 | module Prio = struct 8 | type t = int 9 | 10 | let compare a b = -Int.compare a b 11 | end 12 | 13 | module Psq = Psq.Make (Entry) (Prio) 14 | 15 | type q = { mutable q : Psq.t; cond : Eio.Condition.t; name : string } 16 | 17 | type t = { 18 | queues : (string, q) Hashtbl.t; 19 | id_to_q : (Job_id.t, q) Hashtbl.t; 20 | pending : (Job_id.t, unit) Hashtbl.t; 21 | } 22 | 23 | let st = 24 | { 25 | queues = Hashtbl.create 10; 26 | id_to_q = Hashtbl.create 10; 27 | pending = Hashtbl.create 10; 28 | } 29 | 30 | let get_or_create id = 31 | match Hashtbl.find_opt st.queues id with 32 | | Some q -> q 33 | | None -> 34 | let q = { q = Psq.empty; cond = Eio.Condition.create (); name = id } in 35 | Hashtbl.add st.queues id q; 36 | q 37 | 38 | let put ~name job pri = 39 | let id = Job_id.next () in 40 | let v = get_or_create name in 41 | v.q <- Psq.add { id; job } pri v.q; 42 | Hashtbl.add st.id_to_q id v; 43 | Eio.Condition.broadcast v.cond; 44 | id 45 | 46 | let put_back (job : Protocol.get_response) = 47 | let v = get_or_create job.queue in 48 | v.q <- Psq.add { id = job.id; job = job.job } job.pri v.q; 49 | Hashtbl.add st.id_to_q job.id v; 50 | Hashtbl.remove st.pending job.id; 51 | Eio.Condition.broadcast v.cond 52 | 53 | let delete job_id = 54 | if Hashtbl.mem st.pending job_id then ( 55 | Hashtbl.remove st.pending job_id; 56 | true) 57 | else 58 | try 59 | let v = Hashtbl.find st.id_to_q job_id in 60 | v.q <- Psq.remove { id = job_id; job = `Assoc [] } v.q; 61 | Hashtbl.remove st.id_to_q job_id; 62 | true 63 | with Not_found -> false 64 | 65 | let ( let+ ) a b = Option.map b a 66 | 67 | let get_opt queues = 68 | let+ res = 69 | List.to_seq queues 70 | |> Seq.filter_map (fun queue -> 71 | let v = get_or_create queue in 72 | let+ entry, pri = Psq.min v.q in 73 | { Protocol.job = entry.job; id = entry.id; pri; queue }) 74 | |> Seq.fold_left 75 | (fun (res : Protocol.get_response option) (v : Protocol.get_response) -> 76 | match res with Some v1 when v1.pri > v.pri -> Some v1 | _ -> Some v) 77 | None 78 | in 79 | let v = get_or_create res.queue in 80 | v.q <- Psq.rest v.q |> Option.get; 81 | Hashtbl.remove st.id_to_q res.id; 82 | Hashtbl.add st.pending res.id (); 83 | res 84 | 85 | let rec get_wait queues = 86 | match get_opt queues with 87 | | Some v -> v 88 | | None -> 89 | let queues' = List.map get_or_create queues in 90 | Eio.Fiber.any 91 | (List.map (fun v () -> Eio.Condition.await_no_mutex v.cond) queues'); 92 | get_wait queues 93 | 94 | let is_pending job = Hashtbl.mem st.pending job 95 | -------------------------------------------------------------------------------- /9/q.mli: -------------------------------------------------------------------------------- 1 | val put : name:string -> Yojson.Safe.t -> int -> Job_id.t 2 | val put_back : Protocol.get_response -> unit 3 | val delete : Job_id.t -> bool 4 | val get_opt : string list -> Protocol.get_response option 5 | val get_wait : string list -> Protocol.get_response 6 | val is_pending : Job_id.t -> bool -------------------------------------------------------------------------------- /9/reporter.ml: -------------------------------------------------------------------------------- 1 | let c = Mtime_clock.counter () 2 | 3 | let reporter ppf = 4 | let report src level ~over k msgf = 5 | let k _ = 6 | over (); 7 | k () 8 | in 9 | let with_stamp h tags k ppf fmt = 10 | Format.kfprintf k ppf 11 | ("%a[%a] @[" ^^ fmt ^^ "@]@.") 12 | Logs.pp_header (level, h) Mtime.Span.pp (Mtime_clock.count c) 13 | in 14 | msgf @@ fun ?header ?tags fmt -> with_stamp header tags k ppf fmt 15 | in 16 | { Logs.report } 17 | 18 | let init () = 19 | Fmt_tty.setup_std_outputs (); 20 | Logs.set_level (Some Error); 21 | Logs.set_reporter (reporter Format.std_formatter) -------------------------------------------------------------------------------- /9/reporter.mli: -------------------------------------------------------------------------------- 1 | val init : unit -> unit 2 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## ProtOCaml 2 | 3 | The website: https://protohackers.com/ 4 | 5 | ### Installation 6 | 7 | Install OCaml 5: https://discuss.ocaml.org/t/ocaml-5-0-0-first-beta-release/10623 8 | 9 | Install dependencies: `opam install eio yojson zarith astring` 10 | 11 | ### Running the thing 12 | 13 | In one of these folders, run `dune build` 14 | --------------------------------------------------------------------------------