├── devkit.ml ├── dune-project ├── .gitignore ├── ocamlnet_lite ├── dune ├── netaux.mli ├── netbuffer.mli ├── netaux.ml ├── netsys_types.mli ├── netsys_types.ml ├── netstring_str.mli ├── netbuffer.ml ├── netstring_tstring.mli ├── netstring_tstring.ml └── netencoding.mli ├── digest_auth.mli ├── possibly_otel.stub.ml ├── .build.sh ├── lwt_flag.ml ├── exn_lwt.ml ├── possibly_otel.mli ├── lwt_flag.mli ├── appveyor.yml ├── .build-devkit.sh ├── factor.ml ├── memory_gperftools.ml ├── memory_jemalloc.ml ├── reader.mli ├── mVar.ml ├── mVar.mli ├── mtq.mli ├── test_httpev.ml ├── test_gzip.ml ├── mtq.ml ├── unsafeBitSet.mli ├── idn.mli ├── .github └── workflows │ └── makefile.yml ├── possibly_otel.real.ml ├── Makefile ├── signal.mli ├── htmlStream.mli ├── devkit.opam ├── systemd.mli ├── files.mli ├── unsafeBitSet.ml ├── pid.mli ├── gzip_io.ml ├── bit_struct_list.mli ├── control.ml ├── persist.ml ├── control.mli ├── exn.ml ├── lwt_util.mli ├── logstash.mli ├── dune ├── fastBase64.ml ├── prelude.ml ├── reader.ml ├── extThread.mli ├── htmlStream.ml ├── systemd.ml ├── static_config.mli ├── files.ml ├── logger.ml ├── pid.ml ├── var.mli ├── network.mli ├── lwt_engines.ml ├── lwt_util.ml ├── devkit_ragel.ml.rl ├── prelude.mli ├── bit_struct_list.ml ├── extEnum.mli ├── parallel.mli ├── lwt_mark.mli ├── extEnum_merge.mli ├── extArg.ml ├── signal.ml ├── digest_auth.ml ├── htmlStream_ragel.ml.rl ├── README.md ├── cache.mli ├── daemon.ml ├── stage_merge.ml ├── extThread.ml ├── extEnum.ml ├── network.ml ├── memory.ml ├── httpev_common.ml ├── static_config.ml ├── var.ml ├── log.ml ├── lwt_mark.ml └── idn.ml /devkit.ml: -------------------------------------------------------------------------------- 1 | 2 | include Devkit_core 3 | include Prelude 4 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | (name devkit) 3 | (implicit_transitive_deps false) 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _opam 2 | _build 3 | /stage_merge.byte 4 | 5 | .exrc 6 | .merlin 7 | TAGS 8 | 9 | *.install 10 | -------------------------------------------------------------------------------- /ocamlnet_lite/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ocamlnet_lite) 3 | (public_name devkit.ocamlnet_lite) 4 | (libraries 5 | extlib ; just for Array.create 6 | pcre2 7 | str)) 8 | -------------------------------------------------------------------------------- /digest_auth.mli: -------------------------------------------------------------------------------- 1 | 2 | type t 3 | val init : realm:string -> user:string -> password:string -> unit -> t 4 | val check : t -> Httpev_common.request -> [`Ok | `Unauthorized of (string * string)] 5 | -------------------------------------------------------------------------------- /possibly_otel.stub.ml: -------------------------------------------------------------------------------- 1 | module Traceparent = struct 2 | let name = "traceparent" 3 | 4 | let get_ambient ?explicit_span:_ () = None 5 | end 6 | 7 | 8 | let enter_manual_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ?data name = 9 | Trace_core.enter_manual_toplevel_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ?data name 10 | -------------------------------------------------------------------------------- /.build.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # 4 | # Generate steps for devkit pipeline 5 | # 6 | 7 | set -e -u 8 | 9 | { 10 | cat << EOF 11 | steps: 12 | - label: "Build devkit" 13 | agents: 14 | linux: "true" 15 | command: 16 | - "./.build-devkit.sh" 17 | EOF 18 | } | buildkite-agent pipeline upload 19 | -------------------------------------------------------------------------------- /ocamlnet_lite/netaux.mli: -------------------------------------------------------------------------------- 1 | (** Internal auxiliary functions 2 | * 3 | * This is an internal module. 4 | *) 5 | 6 | (* Auxiliary stuff *) 7 | 8 | module ArrayAux : sig 9 | val int_blit : int array -> int -> int array -> int -> int -> unit 10 | (** A specialisation of [Array.blit] for int arrays. 11 | * (Performance reasons.) 12 | *) 13 | end 14 | -------------------------------------------------------------------------------- /lwt_flag.ml: -------------------------------------------------------------------------------- 1 | 2 | module C = Lwt_condition 3 | 4 | type 'a t = { cond : 'a C.t; mutable waiter : 'a Lwt.t } 5 | 6 | let create () = 7 | let cond = C.create () in 8 | { cond; waiter = C.wait cond } 9 | 10 | let signal { cond; _ } x = C.signal cond x 11 | 12 | let wait fl = 13 | let%lwt r = fl.waiter in 14 | fl.waiter <- C.wait fl.cond; 15 | Lwt.return r 16 | -------------------------------------------------------------------------------- /exn_lwt.ml: -------------------------------------------------------------------------------- 1 | (** 2 | Dealing with Lwt exceptions 3 | *) 4 | 5 | open Printf 6 | 7 | let catch f x = Lwt.try_bind (fun () -> f x) Lwt.return_some (fun _exn -> Lwt.return_none) 8 | let map f x = Lwt.try_bind (fun () -> f x) (fun r -> Lwt.return (`Ok r)) (fun exn -> Lwt.return (`Exn exn)) 9 | 10 | let fail = Exn.fail 11 | 12 | let invalid_arg fmt = ksprintf Stdlib.invalid_arg fmt 13 | -------------------------------------------------------------------------------- /possibly_otel.mli: -------------------------------------------------------------------------------- 1 | module Otrace := Trace_core 2 | 3 | module Traceparent : sig 4 | val name : string 5 | val get_ambient : ?explicit_span:Trace_core.explicit_span -> unit -> string option 6 | end 7 | 8 | val enter_manual_span : 9 | __FUNCTION__:string -> 10 | __FILE__:string -> 11 | __LINE__:int -> 12 | ?data:(unit -> (string * Otrace.user_data) list) -> 13 | string -> 14 | Trace_core.explicit_span 15 | -------------------------------------------------------------------------------- /lwt_flag.mli: -------------------------------------------------------------------------------- 1 | (** Simple wrapper over Lwt_condition, starts to wait again on condvar right after current [wait] was finished, to not lose signals. 2 | Usable when there is one thread that waits for "flag". 3 | "Multiple waiters" semantics is not defined here ( <-> Lwt_condition.broadcast), don't use it. 4 | *) 5 | 6 | type 'a t 7 | val create : unit -> 'a t 8 | val signal : 'a t -> 'a -> unit 9 | val wait : 'a t -> 'a Lwt.t 10 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | platform: 2 | - x86 3 | 4 | environment: 5 | FORK_USER: ocaml 6 | FORK_BRANCH: master 7 | OPAM_SWITCH: 4.05.0+mingw64c 8 | CYG_ROOT: C:\cygwin64 9 | 10 | install: 11 | - ps: iex ((new-object net.webclient).DownloadString("https://raw.githubusercontent.com/$env:FORK_USER/ocaml-ci-scripts/$env:FORK_BRANCH/appveyor-install.ps1")) 12 | 13 | build_script: 14 | - call %CYG_ROOT%\bin\bash.exe -l %APPVEYOR_BUILD_FOLDER%\appveyor-opam.sh 15 | -------------------------------------------------------------------------------- /.build-devkit.sh: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env bash 2 | set -e -u 3 | 4 | . /shared/ci-utils/opam-setup.sh 5 | 6 | echo "-- install and upgrade opam deps" 7 | 8 | cmd opam uninstall devkit 9 | cmd opam upgrade --fixup 10 | cmd opam install --with-doc --deps-only ./devkit.opam 11 | 12 | echo "+++ build" 13 | 14 | make BUILDFLAGS="-tag warn_error_A,warn_error_d" distclean lib test doc 15 | 16 | if [ "$BUILDKITE" = "true" ]; then 17 | echo "--- build doc" 18 | mkdir _build/output/ 19 | mv _build/default/_doc/_html _build/output/ocamldoc 20 | buildkite-agent meta-data set "DOC_PATH" "_build/output/" 21 | fi 22 | -------------------------------------------------------------------------------- /factor.ml: -------------------------------------------------------------------------------- 1 | (** *) 2 | 3 | module Int = struct 4 | type t = int 5 | let compare (x:int) y = compare x y 6 | let equal (x:int) y = x = y 7 | external to_int : t -> int = "%identity" 8 | external of_int : int -> t = "%identity" 9 | let of_string = int_of_string 10 | let to_string = string_of_int 11 | let add = (+) 12 | let zero = 0 13 | let mul = ( * ) 14 | let neg = (~-) 15 | let min (x : int) y = if x < y then x else y 16 | let max (x : int) y = if x > y then x else y 17 | end 18 | 19 | module Float = struct 20 | type t = float 21 | let compare (x:float) y = compare x y 22 | let equal (x:float) y = x = y 23 | end 24 | 25 | -------------------------------------------------------------------------------- /memory_gperftools.ml: -------------------------------------------------------------------------------- 1 | (** Memory reporting for gperftools, call [setup] in every binary linked with gperftools *) 2 | 3 | open Devkit_core 4 | 5 | let show_crt_info () = 6 | let bytes = Action.bytes_string in 7 | let p x = try bytes @@ Gperftools.get_numeric_property x with _ -> "?" in 8 | Printf.sprintf "MALLOC: size %s, used %s, free %s" 9 | (p "generic.heap_size") (p "generic.current_allocated_bytes") (p "tcmalloc.pageheap_free_bytes") 10 | 11 | let setup () = 12 | Gperftools.set_memory_release_rate 10.; 13 | Memory.show_crt_info := show_crt_info; 14 | Memory.malloc_release := Gperftools.release_free_memory; 15 | () 16 | -------------------------------------------------------------------------------- /memory_jemalloc.ml: -------------------------------------------------------------------------------- 1 | (** Memory reporting for jemalloc, call [setup] in every binary linked with jemalloc *) 2 | 3 | open Devkit_core 4 | open Jemalloc 5 | 6 | let show_crt_info () = 7 | let b = Action.bytes_string in 8 | try 9 | let memory = get_memory_stats () in 10 | Printf.sprintf "MALLOC: size %s, used %s, heap %s, free %s" (b memory.mapped) (b memory.active) (b memory.allocated) (b (memory.mapped - memory.active)) 11 | with exn -> 12 | Printf.sprintf "MALLOC:? (error %s)" (Exn.to_string exn) 13 | 14 | let setup () = 15 | Memory.show_crt_info := show_crt_info; 16 | Memory.malloc_release := release_free_memory; 17 | () 18 | -------------------------------------------------------------------------------- /ocamlnet_lite/netbuffer.mli: -------------------------------------------------------------------------------- 1 | (** A Netbuffer.t is a buffer that can grow and shrink dynamically. *) 2 | 3 | type t 4 | 5 | val create : int -> t 6 | (** Creates a netbuffer which allocates initially this number of bytes. 7 | * The logical length is zero. 8 | *) 9 | 10 | val to_tstring_poly : t -> 's Netstring_tstring.tstring_kind -> 's 11 | (** Return the buffer in the format as selected by the arg *) 12 | 13 | (** {2 Appending strings} *) 14 | 15 | val add_string : t -> string -> unit 16 | (** [add_string nb s]: Adds a copy of the string [s] to the logical end of 17 | * the netbuffer [nb]. If necessary, [nb] grows. 18 | *) 19 | 20 | -------------------------------------------------------------------------------- /reader.mli: -------------------------------------------------------------------------------- 1 | (** Simple string reader *) 2 | 3 | type t 4 | 5 | exception EOS 6 | exception Not_equal of string 7 | 8 | val init : string -> t 9 | val eos : t -> bool 10 | 11 | (** post-condition: [eos] is true *) 12 | val rest : t -> string 13 | val till : t -> string -> string 14 | val try_till : t -> string -> string 15 | val tillc : t -> char -> string 16 | val try_tillc : t -> char -> string 17 | val take : t -> int -> string 18 | val try_take : t -> int -> string 19 | val is_const : t -> string -> bool 20 | val const : t -> string -> unit 21 | val try_const : t -> string -> unit 22 | val while_ : t -> (char -> bool) -> string 23 | val skipc : t -> char -> unit 24 | -------------------------------------------------------------------------------- /mVar.ml: -------------------------------------------------------------------------------- 1 | 2 | open ExtThread 3 | 4 | type 'a t = { mutex : Mutex.t; cond : Condition.t; mutable v : 'a option; } 5 | 6 | let create () = { mutex = Mutex.create (); cond = Condition.create (); v = None; } 7 | 8 | let set t x = locked t.mutex (fun () -> t.v <- Some x; Condition.signal t.cond) 9 | let clear t = locked t.mutex (fun () -> t.v <- None) 10 | 11 | let rec wait t = 12 | match t.v with 13 | | None -> Condition.wait t.cond t.mutex; wait t 14 | | Some x -> x 15 | 16 | let get t = locked t.mutex (fun () -> wait t) 17 | let grab t = locked t.mutex (fun () -> let x = wait t in t.v <- None; x) 18 | 19 | let try_get t = locked t.mutex (fun () -> t.v) 20 | let try_grab t = locked t.mutex (fun () -> let x = t.v in t.v <- None; x) 21 | 22 | -------------------------------------------------------------------------------- /mVar.mli: -------------------------------------------------------------------------------- 1 | (** Variable shared between threads *) 2 | 3 | type 'a t 4 | 5 | (** Create *) 6 | val create : unit -> 'a t 7 | 8 | (** Set the variable (overwriting previous value if any) and return immediately *) 9 | val set : 'a t -> 'a -> unit 10 | 11 | (** Unset the variable *) 12 | val clear : 'a t -> unit 13 | 14 | (** Get value (block until it is available) *) 15 | val get : 'a t -> 'a 16 | 17 | (** Get value (block until it is available) and unset *) 18 | val grab : 'a t -> 'a 19 | 20 | (** Get value immediately without blocking 21 | @return None if value was not set *) 22 | val try_get : 'a t -> 'a option 23 | 24 | (** Grab value immediately without blocking 25 | @return None if value was not set *) 26 | val try_grab : 'a t -> 'a option 27 | 28 | -------------------------------------------------------------------------------- /mtq.mli: -------------------------------------------------------------------------------- 1 | (** Queue shared between multiple threads *) 2 | 3 | type 'a t 4 | 5 | (** Create queue *) 6 | val create : unit -> 'a t 7 | 8 | (** Put item into the queue and return immediately *) 9 | val put : 'a t -> 'a -> unit 10 | 11 | (** Get item from the queue (will block while queue is empty) *) 12 | val get : 'a t -> 'a 13 | 14 | (** Peek the item (leaving it in the queue) *) 15 | val peek : 'a t -> 'a 16 | 17 | (** Drop item from the queue if present *) 18 | val junk : 'a t -> unit 19 | 20 | (** Get item from the queue without blocking 21 | @return None immediately if queue is empty *) 22 | val try_get : 'a t -> 'a option 23 | 24 | (** Get the length of the queue *) 25 | val length : 'a t -> int 26 | 27 | (** Remove all elements from the queue *) 28 | val clear : 'a t -> unit 29 | 30 | -------------------------------------------------------------------------------- /test_httpev.ml: -------------------------------------------------------------------------------- 1 | (** Bare-bones httpev server example *) 2 | 3 | open Printf 4 | open Devkit 5 | 6 | let log = Httpev.Hidden.log 7 | 8 | let http_handle _st req k_http = 9 | let module Arg = Httpev.Args(struct let req = req end) in 10 | match req.Httpev.path with 11 | | "/hello" -> 12 | let name = Option.default "world" (Arg.get "name") in 13 | k_http @@ Httpev.serve_text req (sprintf "Hello, %s!" name) 14 | | _ -> 15 | log #warn "not found : %s" (Httpev.show_request req); 16 | k_http @@ Httpev.not_found 17 | 18 | let run http_port = 19 | let main () = 20 | let http_config = { Httpev.default with 21 | Httpev.events = Async.Ev.init (); 22 | connection = ADDR_INET (Unix.inet_addr_any, http_port); 23 | max_request_size = 128 * 1024; 24 | } in 25 | Httpev.server http_config http_handle; 26 | in 27 | Action.log main () 28 | -------------------------------------------------------------------------------- /test_gzip.ml: -------------------------------------------------------------------------------- 1 | open ExtLib 2 | open Devkit 3 | 4 | let max_u32 = 4*1024*1024*1024 5 | 6 | let test len = 7 | let data = String.make len 'a' in 8 | let oc = Gzip_io.output (IO.output_string ()) in 9 | IO.nwrite_string oc data; 10 | let compressed = IO.close_out oc in 11 | let ic = Gzip_io.input (IO.input_string compressed) in 12 | let data = IO.read_all ic in 13 | IO.close_in ic; 14 | Memory.reclaim (); 15 | Log.main #info "original length %d compressed length %d uncompressed length %d" len (String.length compressed) (String.length data); 16 | if len <> String.length data then failwith @@ Printf.sprintf "test %d failed" len; 17 | (* let io = Gzip_io.output_ch (Out_channel.open_bin "tempfile.gz") in 18 | IO.nwrite_string io data; 19 | IO.close_out io; *) 20 | String.iter (fun c -> if c <> 'a' then failwith @@ Printf.sprintf "test %d failed" len) data 21 | 22 | let () = 23 | [ 0; 1; 1023; 1024; 1025; max_u32-1; max_u32; max_u32+1 ] |> List.iter test 24 | -------------------------------------------------------------------------------- /ocamlnet_lite/netaux.ml: -------------------------------------------------------------------------------- 1 | module ArrayAux = struct 2 | let int_blit_ref = 3 | ref 4 | (fun (src:int array) srcpos dest destpos len -> 5 | (* A specialised version of Array.blit for int arrays. 6 | * Faster than the polymorphic Array.blit for 7 | * various reasons. 8 | *) 9 | if (len < 0 || srcpos < 0 || 10 | srcpos+len > Array.length src || 11 | destpos < 0 || 12 | destpos+len > Array.length dest) then 13 | invalid_arg "Netaux.ArrayAux.int_blit"; 14 | if src != dest || destpos <= srcpos then ( 15 | for i = 0 to len-1 do 16 | Array.unsafe_set 17 | dest 18 | (destpos+i) 19 | (Array.unsafe_get src (srcpos+i)) 20 | done 21 | ) else ( 22 | for i = len-1 downto 0 do 23 | Array.unsafe_set 24 | dest 25 | (destpos+i) 26 | (Array.unsafe_get src (srcpos+i)) 27 | done 28 | ) 29 | ) 30 | 31 | let int_blit src srcpos dest destpos len = 32 | !int_blit_ref src srcpos dest destpos len 33 | 34 | end 35 | -------------------------------------------------------------------------------- /mtq.ml: -------------------------------------------------------------------------------- 1 | 2 | (* ExtThread.locked, duplicated to break internal circular dependency in ExtThread *) 3 | let locked mutex f = Mutex.lock mutex; Std.finally (fun () -> Mutex.unlock mutex) f () 4 | 5 | type 'a t = { mutex : Mutex.t; cond : Condition.t; q : 'a Queue.t; } 6 | 7 | let create () = { mutex = Mutex.create (); cond = Condition.create (); q = Queue.create (); } 8 | 9 | let put q v = locked q.mutex (fun () -> Queue.push v q.q; Condition.signal q.cond) 10 | 11 | let get q = locked q.mutex (fun () -> 12 | while Queue.is_empty q.q do Condition.wait q.cond q.mutex done; 13 | Queue.pop q.q) 14 | 15 | let peek q = locked q.mutex (fun () -> 16 | while Queue.is_empty q.q do Condition.wait q.cond q.mutex done; 17 | Queue.peek q.q) 18 | 19 | let junk q = locked q.mutex (fun () -> 20 | let _ = Exn.catch Queue.pop q.q in ()) 21 | 22 | let try_get q = locked q.mutex (fun () -> Exn.catch Queue.pop q.q) 23 | 24 | let length q = locked q.mutex (fun () -> Queue.length q.q) 25 | 26 | let clear q = locked q.mutex (fun () -> Queue.clear q.q) 27 | 28 | -------------------------------------------------------------------------------- /unsafeBitSet.mli: -------------------------------------------------------------------------------- 1 | (* 2 | This is reduced copy of ExtLib.BitSet with removed safety checks and auto-resize code to get some more speed of it. 3 | It is about 15% faster than the original implementation. 4 | 5 | Update 2: converted to bigarray 6 | *) 7 | 8 | type t 9 | 10 | val create : int -> t 11 | (** Create an empty bitset with an initial size (in number of bits). *) 12 | 13 | val copy : t -> t 14 | (** Copy a bitset : further modifications of first one will not affect the 15 | copy. *) 16 | 17 | val set : t -> int -> unit 18 | (** [set s n] sets the nth-bit in the bitset [s] to true. *) 19 | 20 | val unset : t -> int -> unit 21 | (** [unset s n] sets the nth-bit in the bitset [s] to false. *) 22 | 23 | val put : t -> bool -> int -> unit 24 | (** [put s v n] sets the nth-bit in the bitset [s] to [v]. *) 25 | 26 | val toggle : t -> int -> unit 27 | (** [toggle s n] changes the nth-bit value in the bitset [s]. *) 28 | 29 | val is_set : t -> int -> bool 30 | (** [is_set s n] returns true if nth-bit in the bitset [s] is set, 31 | or false otherwise. *) 32 | -------------------------------------------------------------------------------- /idn.mli: -------------------------------------------------------------------------------- 1 | (** Punycode & IDN *) 2 | 3 | module type CONV = 4 | sig 5 | val upoints : string -> int array 6 | val ustring : int array -> string 7 | end 8 | 9 | module Make(CONV : CONV) : 10 | sig 11 | exception Bad_input 12 | exception Overflow 13 | 14 | (** {1 punycode conversion} *) 15 | 16 | val encode : string -> string 17 | val decode : string -> string 18 | 19 | (** {1 IDN conversion} *) 20 | 21 | val encode_domain : string -> string 22 | val decode_domain : string -> string 23 | 24 | val self_test : unit -> unit 25 | end 26 | 27 | (* 28 | 29 | module CONV_Netconversion = 30 | struct 31 | let upoints s = Netconversion.uarray_of_ustring `Enc_utf8 s 32 | let ustring a = Netconversion.ustring_of_uarray `Enc_utf8 a 33 | end 34 | 35 | module CONV_Camomile = 36 | struct 37 | open CamomileLibraryDefault 38 | let upoints s = Array.init (Camomile.UTF8.length s) (fun i -> Camomile.UChar.uint_code (Camomile.UTF8.get s i)) 39 | let ustring a = Camomile.UTF8.init (Array.length a) (fun i -> Camomile.UChar.chr_of_uint a.(i)) 40 | end 41 | 42 | *) 43 | -------------------------------------------------------------------------------- /.github/workflows/makefile.yml: -------------------------------------------------------------------------------- 1 | name: devkit 2 | 3 | on: 4 | push: 5 | branches: [ master ] 6 | pull_request: 7 | branches: [ master ] 8 | workflow_dispatch: 9 | 10 | jobs: 11 | build: 12 | 13 | strategy: 14 | matrix: 15 | ocaml-version: 16 | - 4.14 17 | - 5.2 18 | 19 | runs-on: ubuntu-22.04 20 | 21 | steps: 22 | - name: Checkout code 23 | uses: actions/checkout@v4 24 | 25 | - name: Update apt 26 | run: sudo apt-get update 27 | 28 | - name: Set up OCaml ${{ matrix.ocaml-version }} 29 | uses: ocaml/setup-ocaml@v3 30 | with: 31 | ocaml-compiler: ${{ matrix.ocaml-version }} 32 | dune-cache: true 33 | allow-prerelease-opam: true 34 | 35 | - name: Install OCaml deps 36 | run: opam install . --deps-only --with-test 37 | 38 | - name: Pin libevent 39 | run: opam pin add libevent --dev 40 | 41 | - name: Build 42 | run: opam exec -- dune build --profile=release 43 | 44 | - name: Test 45 | run: opam exec -- dune runtest --profile=release 46 | -------------------------------------------------------------------------------- /possibly_otel.real.ml: -------------------------------------------------------------------------------- 1 | open Opentelemetry 2 | 3 | let (let*) o f = Option.map f o 4 | 5 | module Traceparent = struct 6 | let name = Trace_context.Traceparent.name 7 | 8 | let get_ambient ?explicit_span () = 9 | let* Scope.{ trace_id; span_id; _ } = Scope.get_ambient_scope () in 10 | let span_id = match explicit_span with 11 | | Some {Trace_core.span; _} -> Opentelemetry_trace.Internal.otel_of_otrace span 12 | | None -> span_id 13 | in 14 | Trace_context.Traceparent.to_value ~trace_id ~parent_id:span_id () 15 | end 16 | 17 | let enter_manual_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ?data name = 18 | match Scope.get_ambient_scope () with 19 | | None -> 20 | Trace_core.enter_manual_toplevel_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ?data name 21 | | Some Scope.{ span_id; _ } -> 22 | let otrace_espan = Trace_core.{ 23 | span = Opentelemetry_trace.Internal.otrace_of_otel span_id; 24 | meta = Trace_core.Meta_map.empty 25 | } in 26 | Trace_core.enter_manual_sub_span ~parent:otrace_espan ~__FUNCTION__ ~__FILE__ ~__LINE__ ?data name 27 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | .PHONY: build lib doc clean install uninstall test gen gen_ragel gen_metaocaml archive 3 | 4 | OCAMLBUILD=ocamlbuild -use-ocamlfind -no-links -j 0 5 | 6 | target: build 7 | 8 | gen_ragel: devkit_ragel.ml htmlStream_ragel.ml 9 | 10 | gen_metaocaml: 11 | OCAMLFIND_TOOLCHAIN=metaocaml ocamlfind ocamlc -linkpkg -package extlib stage_merge.ml -o stage_merge.byte 12 | rm stage_merge.cm* 13 | ./stage_merge.byte > extEnum_merge.ml 14 | ocamlfind ocamlc -package extlib -i extEnum_merge.ml > extEnum_merge.mli 15 | 16 | %.ml: %.ml.rl 17 | ragel -O -F1 $< -o $@ 18 | 19 | build: lib 20 | 21 | lib: 22 | dune build $(DUNEFLAGS) 23 | 24 | top: 25 | dune utop $(DUNEFLAGS) 26 | 27 | test: 28 | dune runtest $(DUNEFLAGS) 29 | 30 | doc: 31 | dune build $(DUNEFLAGS) @doc 32 | 33 | install: lib 34 | dune install 35 | 36 | uninstall: 37 | dune uninstall 38 | 39 | reinstall: uninstall install 40 | 41 | clean: 42 | dune clean 43 | 44 | distclean: clean 45 | 46 | VERSION=$(shell git describe --tag --always) 47 | NAME=devkit-$(VERSION) 48 | 49 | archive: 50 | git archive --prefix=$(NAME)/ HEAD | bzip2 > $(NAME).tbz 51 | -------------------------------------------------------------------------------- /signal.mli: -------------------------------------------------------------------------------- 1 | (** Signal handling *) 2 | 3 | (** {2 libevent + signalfd} 4 | 5 | explicit interface (for compatibility) 6 | *) 7 | 8 | type t 9 | val init : Async.Ev.event_base -> t 10 | val stop : t -> unit 11 | 12 | (** {2 generic registration} *) 13 | 14 | val is_safe_output : unit -> bool 15 | 16 | (** add signal handler for specified signals *) 17 | val set : int list -> (int -> unit) -> unit 18 | val set1 : int -> (unit -> unit) -> unit 19 | val set_verbose : int list -> string -> (unit -> unit) -> unit 20 | val set_exit : (unit -> unit) -> unit 21 | val set_reload : (unit -> unit) -> unit 22 | 23 | (** replace signal handler for specified signals *) 24 | val replace : int list -> (int -> unit) -> unit 25 | 26 | (** setup "standard" signal driver, deadlock-friendly, default *) 27 | val setup_sys : unit -> unit 28 | 29 | (** setup signals via libevent (signalfd), requires event loop *) 30 | val setup_libevent : t -> unit 31 | 32 | val setup_libevent_ : Async.Ev.event_base -> unit 33 | val setup_libevent' : t -> unit 34 | 35 | (** setup signals via lwt, requires {!Lwt_main.run} *) 36 | val setup_lwt : unit -> unit 37 | 38 | type state 39 | val save : unit -> state 40 | val restore : state -> unit 41 | -------------------------------------------------------------------------------- /htmlStream.mli: -------------------------------------------------------------------------------- 1 | (** HTML scanner *) 2 | 3 | module Raw = HtmlStream_ragel.Raw 4 | 5 | type elem = 6 | | Tag of (string * (string * Raw.t) list) 7 | | Script of ((string * Raw.t) list * string) (** attributes and contents. TODO investigate script contents encoding *) 8 | | Style of ((string * Raw.t) list * string) 9 | | Text of Raw.t 10 | | Close of string 11 | 12 | type ctx 13 | 14 | val init : unit -> ctx 15 | val get_lnum : ctx -> int 16 | 17 | (** 18 | Scan string for html tags. 19 | NB 20 | 1. self-closing tags (e.g. []) will result in two tags generated [] (except for []) 21 | 2. unfinished tags at the end of input are ignored 22 | *) 23 | val parse : ?ctx:ctx -> (elem -> unit) -> string -> unit 24 | 25 | (** @return html string for [elem] *) 26 | val show_raw : elem -> string 27 | 28 | (** @return html string for [elem] using single quote for attributes *) 29 | val show_raw' : elem -> string 30 | 31 | val attrs_include : (string * Raw.t) list -> (string * string) list -> bool 32 | val tag : string -> ?a:(string * string) list -> elem -> bool 33 | val close : string -> elem -> bool 34 | 35 | (** extract text from the list elements *) 36 | val make_text : ?br:bool -> elem list -> Raw.t 37 | -------------------------------------------------------------------------------- /devkit.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "igor@ahrefs.com" 3 | authors: "Ahrefs " 4 | license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" 5 | homepage: "https://github.com/ahrefs/devkit" 6 | dev-repo: "git+https://github.com/ahrefs/devkit.git" 7 | bug-reports: "https://github.com/ahrefs/devkit/issues" 8 | synopsis: "Development kit - general purpose library" 9 | build: [ 10 | ["dune" "subst"] {dev} 11 | ["dune" "build" "-p" name "-j" jobs "@install" "@runtest"{with-test} "@doc"{with-doc}] 12 | ] 13 | depends: [ 14 | "ocaml" {>= "4.05.0"} 15 | "dune" {>= "2.0"} 16 | ("extlib" {>= "1.7.1"} | "extlib-compat" {>= "1.7.1"}) 17 | "ounit2" 18 | "camlzip" 19 | "libevent" {>= "0.8.0"} 20 | "ocurl" {>= "0.7.2"} 21 | "pcre2" {>= "8.0.3"} 22 | "trace" {>= "0.4"} 23 | "extunix" {>= "0.1.4"} 24 | "lwt" {>= "5.7.0"} 25 | "lwt_ppx" 26 | "base-bytes" 27 | "base-unix" 28 | "base-threads" 29 | "stdlib-shims" 30 | "yojson" {>= "1.6.0"} 31 | "odoc" {with-doc} 32 | ] 33 | depopts: [ 34 | "gperftools" 35 | "jemalloc" 36 | "opentelemetry" 37 | ] 38 | conflicts: [ 39 | "jemalloc" {< "0.2"} 40 | "opentelemetry" {< "0.6"} 41 | ] 42 | available: arch != "arm32" & arch != "x86_32" 43 | -------------------------------------------------------------------------------- /systemd.mli: -------------------------------------------------------------------------------- 1 | (** 2 | Misc utils for systemd. 3 | *) 4 | 5 | (** Subset of [sd-daemon] in ocaml. 6 | 7 | The following functionalities are provided: 8 | - File descriptor passing for socket-based activation 9 | - Detection of systemd boots 10 | *) 11 | module Daemon : sig 12 | 13 | (** [true] if the system was booted with systemd. *) 14 | val booted : bool 15 | 16 | (** 17 | Returns file descriptors that have been passed by systemd. 18 | 19 | This function call ensures that the [FD_CLOEXEC] flag is set for 20 | the passed file descriptors, to make sure they are not passed on 21 | to child processes. If [FD_CLOEXEC] shall not be set, the caller 22 | needs to unset it after this call for all file descriptors that 23 | are used. 24 | *) 25 | val listen_fds : unit -> Unix.file_descr list 26 | 27 | (** Same as {!listen_fds} but return lwt file descriptors. *) 28 | val listen_fds_lwt : unit -> Lwt_unix.file_descr list 29 | 30 | (** Similar to {!Daemon.get_args} but without the foregound and pidfile 31 | option. *) 32 | val get_args : unit -> (string * Arg.spec * string) list 33 | 34 | (** Similar to {!Daemon.manage} but sets to run in the foreground. *) 35 | val manage : unit -> unit 36 | end 37 | -------------------------------------------------------------------------------- /files.mli: -------------------------------------------------------------------------------- 1 | (** File system *) 2 | 3 | val enum_dir : Unix.dir_handle -> string Enum.t 4 | val with_readdir : string -> (Unix.dir_handle -> 'a) -> 'a 5 | 6 | (** [f fd path rel] gets invoked for each file under [dirname] where 7 | [fd] is a read-only [Unix.file_descr], [path] is full path and [rel] - path relative to [dirname] *) 8 | val iter_names : string -> (Unix.file_descr -> string -> string -> unit) -> unit 9 | 10 | (** [iter_names_q dirname (fun [path] [rel] -> ...)] *) 11 | val iter_names_q : string -> (string -> string -> unit) -> unit 12 | 13 | (** [iter_files dirname (fun [path] [ic] -> ...)] *) 14 | val iter_files : string -> (string -> in_channel -> unit) -> unit 15 | 16 | val open_out_append_bin : string -> out_channel 17 | val open_out_append_text : string -> out_channel 18 | 19 | (** [save_as filename ?mode f] is similar to 20 | [Control.with_open_file_bin] except that writing is done to a 21 | temporary file that will be renamed to [filename] after [f] has 22 | succesfully terminated. Therefore this guarantee that either 23 | [filename] will not be modified or will contain whatever [f] was 24 | writing to it as a side-effect. 25 | 26 | FIXME windows *) 27 | val save_as : string -> ?mode:Unix.file_perm -> (out_channel -> unit) -> unit 28 | -------------------------------------------------------------------------------- /unsafeBitSet.ml: -------------------------------------------------------------------------------- 1 | open Bigarray 2 | module Bytes = Array1 3 | 4 | let bget t pos = int_of_char @@ Bytes.unsafe_get t pos 5 | let bset t pos c = Bytes.unsafe_set t pos (Char.unsafe_chr c) 6 | 7 | type t = (char, int8_unsigned_elt, c_layout) Bytes.t 8 | 9 | let int_size = 7 (* value used to round up index *) 10 | let log_int_size = 3 (* number of shifts *) 11 | 12 | let create n = 13 | let size = (n+int_size) lsr log_int_size in 14 | let b = Bytes.create Char C_layout size in 15 | Bytes.fill b '\x00'; 16 | b 17 | 18 | let copy t = 19 | let b = Bytes.create Char C_layout (Bytes.dim t) in 20 | Bytes.blit t b; 21 | b 22 | 23 | let set t x = 24 | let pos = x lsr log_int_size and delta = x land int_size in 25 | bset t pos ((bget t pos) lor (1 lsl delta)) 26 | 27 | let unset t x = 28 | let pos = x lsr log_int_size and delta = x land int_size in 29 | bset t pos ((bget t pos) land (0xFF lxor (1 lsl delta))) 30 | 31 | let toggle t x = 32 | let pos = x lsr log_int_size and delta = x land int_size in 33 | bset t pos ((bget t pos) lxor (1 lsl delta)) 34 | 35 | let put t = function 36 | | true -> set t 37 | | false -> unset t 38 | 39 | let is_set t x = 40 | let pos = x lsr log_int_size and delta = x land int_size in 41 | 0 <> (((bget t pos) lsr delta) land 1) 42 | -------------------------------------------------------------------------------- /pid.mli: -------------------------------------------------------------------------------- 1 | (** Unique process identification *) 2 | 3 | type t = { 4 | host : string; (** machine hostname (no spaces allowed) *) 5 | id : int; (** process id *) 6 | name : string; (** application id (no spaces allowed), for information. *) 7 | stamp : int; (** stamp for uniqueness to guard against pid reuse *) 8 | } 9 | 10 | (** dummy instance, use sparingly *) 11 | val dummy : t 12 | 13 | (** @return pretty-printed pid (human readable) *) 14 | val show : t -> string 15 | 16 | (** @return machine hostname *) 17 | val host : t -> string 18 | 19 | (** @return application name *) 20 | val name : t -> string 21 | 22 | (** @return string representation of pid, can be read back by [parse_pid_exn] *) 23 | val to_string : t -> string 24 | 25 | val make : id:int -> host:string -> stamp:int -> string -> t 26 | 27 | val compare : t -> t -> int 28 | val equal : t -> t -> bool 29 | 30 | val parse_exn : string -> t 31 | 32 | (** {1 Current process identifier} *) 33 | 34 | val sanitize_name : string -> string 35 | val set_name : string -> unit 36 | val self : unit -> t 37 | val self_name : unit -> string 38 | val self_as : string -> t 39 | val show_self : unit -> string 40 | 41 | (** call this to update Pid.self after fork *) 42 | val update : unit -> unit 43 | 44 | (**/**) 45 | 46 | val set_fake : t -> unit 47 | -------------------------------------------------------------------------------- /ocamlnet_lite/netsys_types.mli: -------------------------------------------------------------------------------- 1 | (* $Id$ *) 2 | 3 | (** Types for all Netsys modules *) 4 | 5 | (** {2 Bytes and characters} *) 6 | 7 | (** Remember that up to OCaml-4.01 there was only the [string] type, 8 | and strings were mutable (although frequently used as if there were 9 | immutable). Since OCaml-4.02 there is the immutable [string] and 10 | the mutable [bytes] type. 11 | 12 | The general strategy for switching to the string/bytes scheme is 13 | to replace [string] everywhere with [bytes], and to provide 14 | additional functions taking strings as input or output where it 15 | makes sense. There are exceptions, though, e.g. when the string 16 | acts as a key in a data structure. 17 | 18 | The type name "string" also occurs in function names (e.g. 19 | "get_string") and in variant names (e.g. [String_case]). As we 20 | want to be backward compatible, we keep the old names for functions 21 | on [bytes], and mark them as deprecated. 22 | *) 23 | 24 | type tbuffer = [ `Bytes of Bytes.t | `String of Bytes.t ] 25 | (** A tagged buffer. Note that the [`String] case is deprecated, and only 26 | provided for backward compatibility. 27 | *) 28 | 29 | type tstring = [ `Bytes of Bytes.t | `String of string ] 30 | (** A tagged string which is considered as immutable. See also the 31 | support module {!Netstring_tstring}. 32 | *) 33 | -------------------------------------------------------------------------------- /ocamlnet_lite/netsys_types.ml: -------------------------------------------------------------------------------- 1 | (* WARNING! THIS IS A COPY OF NETSYS_TYPES.MLI! *) 2 | 3 | (** Types for all Netsys modules *) 4 | 5 | (** {2 Bytes and characters} *) 6 | 7 | (** Remember that up to OCaml-4.01 there was only the [string] type, 8 | and strings were mutable (although frequently used as if there were 9 | immutable). Since OCaml-4.02 there is the immutable [string] and 10 | the mutable [bytes] type. 11 | 12 | The general strategy for switching to the string/bytes scheme is 13 | to replace [string] everywhere with [bytes], and to provide 14 | additional functions taking strings as input or output where it 15 | makes sense. There are exceptions, though, e.g. when the string 16 | acts as a key in a data structure. 17 | 18 | The type name "string" also occurs in function names (e.g. 19 | "get_string") and in variant names (e.g. [String_case]). As we 20 | want to be backward compatible, we keep the old names for functions 21 | on [bytes], and mark them as deprecated. 22 | *) 23 | 24 | type tbuffer = [ `Bytes of Bytes.t | `String of Bytes.t ] 25 | (** A tagged buffer. Note that the [`String] case is deprecated, and only 26 | provided for backward compatibility. 27 | *) 28 | 29 | type tstring = [ `Bytes of Bytes.t | `String of string ] 30 | (** A tagged string which is considered as immutable. See also the 31 | support module {!Netstring_tstring}. 32 | *) 33 | -------------------------------------------------------------------------------- /gzip_io.ml: -------------------------------------------------------------------------------- 1 | (** gzip IO *) 2 | 3 | let input io = 4 | let iz = Gzip_stream.open_in io in 5 | IO.create_in 6 | ~read:(fun () -> Gzip_stream.input_char iz) 7 | ~input:(Gzip_stream.input iz) 8 | ~close:(fun () -> Gzip_stream.close_in iz) 9 | 10 | let output io = 11 | let oz = Gzip_stream.open_out io in 12 | IO.create_out 13 | ~write:(Gzip_stream.output_char oz) 14 | ~output:(fun s o l -> Gzip_stream.output oz s o l; l) 15 | ~flush:(fun () -> IO.flush io) 16 | ~close:(fun () -> Gzip_stream.close_out oz) 17 | 18 | let input_ch ch = input (IO.input_channel ch) 19 | let output_ch ch = output (IO.output_channel ch) 20 | 21 | (* 22 | let pipe_in f = 23 | bracket (Filename.open_temp_file ~mode:[Open_binary] "gzip_io" "gz") 24 | (fun (tmpname,ch) -> close_out_noerr ch; Sys.remove tmpname) 25 | (fun (tmpname,ch) -> 26 | bracket (output_ch ch) (suppress IO.close_out) (fun out -> 27 | f out; 28 | IO.close_out out; 29 | Std.input_file ~bin:true tmpname 30 | ) 31 | ) 32 | *) 33 | 34 | let string s = 35 | let out = output (IO.output_string ()) in 36 | IO.nwrite out (Bytes.unsafe_of_string s); (* IO wrong type *) 37 | IO.close_out out 38 | 39 | let to_string s = 40 | let inp = input (IO.input_string s) in 41 | let out = IO.output_string () in 42 | try 43 | while true do 44 | IO.write out (IO.read inp) 45 | done; 46 | assert false 47 | with IO.No_more_input -> 48 | IO.close_in inp; 49 | IO.close_out out 50 | -------------------------------------------------------------------------------- /bit_struct_list.mli: -------------------------------------------------------------------------------- 1 | (** Packed representation for list of integers of fixed bit length *) 2 | 3 | module type S = sig 4 | (** number of bits to represent each item *) 5 | val item_bits : int 6 | val pp : int -> string 7 | end 8 | 9 | module Make(S: S) : sig 10 | type t 11 | val of_list : int list -> t 12 | (** [of_list l] converts a list of int values [l], into a bit structure list. *) 13 | 14 | val to_list : t -> int list 15 | (** [to_list b] converts [b] into a list of int values. *) 16 | 17 | val project : t -> string 18 | (** [project b] returns an internal string representation of [b]. *) 19 | 20 | val inject : string -> t 21 | (** [inject s] initializes a bit list with an internal string representation [s], previously returned by [project]. *) 22 | 23 | val iter : (int -> unit) -> t -> unit 24 | (** [iter f b] applies function [f] in turn to each item in [b]. *) 25 | 26 | val iterwhile : (int -> bool) -> t -> bool 27 | (** [iterwhile f b] applies function [f] in turn to each item in [b] until [f] returns [false]. *) 28 | 29 | val fold_left : ('a -> int -> 'a) -> 'a -> t -> 'a 30 | (** [fold_left f a b] applies function [f] in turn to each item in [b] 31 | and passes the result of previous step, similarly to {!List.fold_left}. *) 32 | 33 | val exists : (int -> bool) -> t -> bool 34 | (** [exists p b] checks if at least one element of [b] satisfies the predicate [p]. *) 35 | 36 | val pp : t -> string 37 | (** [pp b] returns a pretty-print string using [S.pp] for each item of [b]. *) 38 | end 39 | -------------------------------------------------------------------------------- /control.ml: -------------------------------------------------------------------------------- 1 | let bracket resource destroy k = Std.finally (fun () -> destroy resource) k resource 2 | 3 | let wrapped acc result k = 4 | let r = ref None in 5 | let () = Std.finally (fun () -> r := Some (result acc)) k acc in 6 | match !r with 7 | | None -> assert false 8 | | Some x -> x 9 | 10 | let with_open_in_txt name = bracket (open_in name) close_in_noerr 11 | let with_open_out_txt name = bracket (open_out name) close_out_noerr 12 | let with_open_in_bin name = bracket (open_in_bin name) close_in_noerr 13 | let with_open_out_bin name = bracket (open_out_bin name) close_out_noerr 14 | let with_open_out_temp_file ?temp_dir ~mode = bracket (Filename.open_temp_file ~mode ?temp_dir "dvkt" "tmp") (fun (_,ch) -> close_out_noerr ch) 15 | let with_open_out_temp_bin k = with_open_out_temp_file ~mode:[Open_binary] k 16 | let with_open_out_temp_txt k = with_open_out_temp_file ~mode:[Open_text] k 17 | 18 | let wrapped_output io = wrapped io IO.close_out 19 | let wrapped_outs k = wrapped_output (IO.output_string ()) k 20 | let with_input io = bracket io IO.close_in 21 | let with_input_bin name k = with_open_in_bin name (fun ch -> k (IO.input_channel ch)) 22 | let with_input_txt name k = with_open_in_txt name (fun ch -> k (IO.input_channel ch)) 23 | let with_output io = bracket io IO.close_out 24 | let with_output_bin name k = with_open_out_bin name (fun ch -> bracket (IO.output_channel ch) IO.flush k) 25 | let with_output_txt name k = with_open_out_txt name (fun ch -> bracket (IO.output_channel ch) IO.flush k) 26 | 27 | let with_opendir dir = bracket (Unix.opendir dir) Unix.closedir 28 | -------------------------------------------------------------------------------- /persist.ml: -------------------------------------------------------------------------------- 1 | (** Safe marshalling *) 2 | 3 | open Control 4 | open ExtLib 5 | 6 | module type Value = 7 | sig 8 | type value 9 | val tag : string 10 | end 11 | 12 | exception Error 13 | 14 | module Marshal(V : Value) = 15 | struct 16 | 17 | type t = V.value 18 | 19 | let to_channel ch ?(flags=[]) x = 20 | output_string ch V.tag; 21 | Marshal.to_channel ch (x:t) flags 22 | 23 | let from_channel ch = 24 | let s = Bytes.create (String.length V.tag) in 25 | really_input ch s 0 (String.length V.tag); 26 | if Bytes.unsafe_to_string s <> V.tag then raise Error; 27 | (Marshal.from_channel ch : t) 28 | 29 | let to_string ?(flags=[]) x = V.tag ^ Marshal.to_string (x:t) flags 30 | 31 | (** @param also - additional tags allowed (for backward compatibility) *) 32 | let from_string_ext also s = 33 | let tag = String.slice s ~last:(String.length V.tag) in 34 | if tag <> V.tag && List.for_all ((<>) tag) also then raise Error; 35 | (Marshal.from_string s (String.length V.tag) : t) 36 | 37 | let from_string s = from_string_ext [] s 38 | 39 | let to_file_exn name ?mode ?(flags=[]) x = 40 | Files.save_as name ?mode (fun ch -> to_channel ch ~flags x) 41 | 42 | let from_file name = 43 | with_open_in_bin name from_channel 44 | 45 | end 46 | 47 | module type Value_ext = 48 | sig 49 | type value 50 | val tag : string 51 | val also : string list 52 | end 53 | 54 | module Marshal_ext(V:Value_ext) = 55 | struct 56 | let () = 57 | List.iter (fun tag -> assert String.(length tag = length V.tag)) V.also 58 | 59 | include Marshal(V) 60 | 61 | let from_string s = from_string_ext V.also s 62 | 63 | end 64 | -------------------------------------------------------------------------------- /control.mli: -------------------------------------------------------------------------------- 1 | (** Control flow *) 2 | 3 | (** [bracket resource destroy k] 4 | @return [k resource] and guarantee that [resource] is [destroy]'ed at the end. *) 5 | val bracket : 'a -> ('a -> unit) -> ('a -> 'b) -> 'b 6 | 7 | (** [wrapped acc result k] 8 | 9 | Computation [k] accumulates result into resource [acc] which 10 | is guaranteed to be released at the end. Rarely useful (e.g. {!IO.output_string}) 11 | @return [result acc] *) 12 | val wrapped : 'a -> ('a -> 'b) -> ('a -> unit) -> 'b 13 | 14 | 15 | (** File IO *) 16 | 17 | (** Protected file IO, stdlib interface *) 18 | 19 | val with_open_in_bin : string -> (in_channel -> 'a) -> 'a 20 | val with_open_in_txt : string -> (in_channel -> 'a) -> 'a 21 | 22 | val with_open_out_bin : string -> (out_channel -> 'a) -> 'a 23 | val with_open_out_txt : string -> (out_channel -> 'a) -> 'a 24 | 25 | val with_open_out_temp_file : ?temp_dir:string -> mode:open_flag list -> (string * out_channel -> 'a) -> 'a 26 | val with_open_out_temp_bin : (string * out_channel -> 'a) -> 'a 27 | val with_open_out_temp_txt : (string * out_channel -> 'a) -> 'a 28 | 29 | (** Protected file IO, extlib interface *) 30 | 31 | val wrapped_output : 'a IO.output -> ('a IO.output -> unit) -> 'a 32 | val wrapped_outs : (string IO.output -> unit) -> string 33 | 34 | val with_input : IO.input -> (IO.input -> 'a) -> 'a 35 | val with_input_bin : string -> (IO.input -> 'a) -> 'a 36 | val with_input_txt : string -> (IO.input -> 'a) -> 'a 37 | 38 | val with_output : unit IO.output -> (unit IO.output -> 'a) -> 'a 39 | val with_output_bin : string -> (unit IO.output -> 'a) -> 'a 40 | val with_output_txt : string -> (unit IO.output -> 'a) -> 'a 41 | 42 | 43 | (** Misc. *) 44 | 45 | val with_opendir : string -> (Unix.dir_handle -> 'b) -> 'b 46 | -------------------------------------------------------------------------------- /exn.ml: -------------------------------------------------------------------------------- 1 | (** 2 | Dealing with exceptions 3 | *) 4 | 5 | open Printf 6 | open ExtLib 7 | 8 | type 'a result = [ `Ok of 'a | `Exn of exn ] 9 | 10 | let catch f x = try Some (f x) with _ -> None 11 | let default def f x = try f x with _ -> def 12 | let suppress f x = try f x with _ -> () 13 | let map f x = try `Ok (f x) with exn -> `Exn exn 14 | 15 | let to_string exn = 16 | match exn with 17 | | Unix.Unix_error (e,f,s) -> sprintf "Unix_error %s(%s) %s" f s (Unix.error_message e) 18 | | Curl.CurlException (_,n,s) -> sprintf "Curl.CurlException(%u,%s)" n s 19 | | Pcre2.Error err -> sprintf "Pcre2.Error(%s)" 20 | begin match err with 21 | | Partial -> "Partial" 22 | | BadPattern(m,p) -> sprintf "BadPattern(%s,%i)" m p 23 | | BadUTF -> "BadUTF" 24 | | BadUTFOffset -> "BadUTFOffset" 25 | | MatchLimit -> "MatchLimit" 26 | | DepthLimit -> "DepthLimit" 27 | | InternalError s -> sprintf "InternalError(%s)" s 28 | | _ -> Printexc.to_string exn 29 | end 30 | | exn -> Printexc.to_string exn 31 | 32 | let str = to_string 33 | 34 | (** 35 | The original backtrace is captured via `Printexc.get_raw_backtrace ()`. 36 | However, note that this backtrace might not correspond to the provided `exn` 37 | if another exception was raised before `fail` is called. 38 | *) 39 | let fail ?exn fmt = 40 | let fails s = 41 | match exn with 42 | | None -> failwith s 43 | | Some original_exn -> 44 | let orig_bt = Printexc.get_raw_backtrace () in 45 | let exn = Failure (s ^ " : " ^ to_string original_exn) in 46 | Printexc.raise_with_backtrace exn orig_bt 47 | in 48 | ksprintf fails fmt 49 | 50 | let invalid_arg fmt = ksprintf invalid_arg fmt 51 | 52 | let get_backtrace () = String.nsplit (Printexc.get_backtrace ()) "\n" 53 | -------------------------------------------------------------------------------- /lwt_util.mli: -------------------------------------------------------------------------------- 1 | (** Various utilities for use with Lwt. *) 2 | 3 | val with_count : int ref -> 'a Lwt.t -> 'a Lwt.t 4 | 5 | val timely : Time.t -> ('a -> unit Lwt.t) -> ('a -> unit Lwt.t) 6 | 7 | (** [timely_loop' ?immediate period f] run f every period seconds; run immediately if immediate is true. *) 8 | val timely_loop' : ?immediate:bool -> Time.t -> (unit -> unit Lwt.t) -> unit Lwt.t 9 | 10 | (** [timely_loop' ?immediate ?wait period f] run f every period seconds; run immediately if immediate is true; stop when wait thread terminates. *) 11 | val timely_loop : ?immediate:bool -> ?wait:unit Lwt.t -> Time.t -> (unit -> unit Lwt.t) -> unit Lwt.t 12 | 13 | (** [ensure_order t1 t2] cancel t1 when t2 terminates. *) 14 | val ensure_order : 'a Lwt.t -> 'b Lwt.t -> 'b Lwt.t 15 | 16 | (** [suppress_exn name cleanup t] wait for t to terminate, suppress any exception, and call cleanup () afterwards. *) 17 | val suppress_exn : string -> (unit -> 'a Lwt.t) -> unit Lwt.t -> 'a Lwt.t 18 | 19 | val action : string -> ('a -> 'b Lwt.t) -> 'a -> 'b Lwt.t 20 | 21 | val action_do : string -> (unit -> 'a Lwt.t) -> 'a Lwt.t 22 | 23 | (** same as [Lwt.async] but also cancels task on {!Daemon.ShouldExit} *) 24 | val async : (unit -> unit Lwt.t) -> unit 25 | 26 | (** [idle_check ~interval] is a pair [(stamp,wait)] where you use 27 | [stamp: unit -> unit] to indicate activity, and [wait : unit Lwt.t] is a 28 | promise that resolves if there's been no calls to [stamp] during an 29 | [interval]. 30 | 31 | This is typically used to manage a background task (e.g., periodically 32 | fetching data from a remote source) based on whether there is ongoing 33 | activity (e.g., whether the data is being used in the UI). *) 34 | val idle_check : interval:Time.duration -> ((unit -> unit) * unit Lwt.t) 35 | -------------------------------------------------------------------------------- /logstash.mli: -------------------------------------------------------------------------------- 1 | type json = [ `Float of float | `Int of int | `String of string ] 2 | 3 | (** Export counters registered with {!Var} as logstash events *) 4 | val get : unit -> [> `Assoc of (string * [> json ]) list ] list 5 | 6 | (** Setup periodic saving of counters as logstash json rows along the logfile *) 7 | val setup : ?pause:Time.t -> Libevent.event_base -> unit 8 | val setup_lwt : ?pause:Time.t -> unit -> unit 9 | 10 | type logger = < 11 | event : (string * Yojson.Safe.t) list -> unit; (** write event manually *) 12 | write : unit -> unit; (** write Var counters explicitly *) 13 | reload : unit -> unit; (** reopen output file *) 14 | flush : unit -> unit; (** force flush *) 15 | > 16 | 17 | (* Setup logger for a stream of events *) 18 | val log : ?autoflush:float -> ?verbose:bool -> ?add_timestamp_only:bool -> ?name:string -> unit -> logger 19 | 20 | val setup_error_log : unit -> unit 21 | 22 | (** Counters with arbitrary attributes *) 23 | module Dyn : sig 24 | type t = private (string * json) list 25 | val make : ?attrs:(string * json) list -> string -> t 26 | (* val add : t -> ?attrs:(string * string) list -> Var.t -> unit *) 27 | (* val set : t -> ?attrs:(string * string) list -> Var.t -> unit *) 28 | val set_count : t -> (string * json) list -> int -> unit 29 | val set_bytes : t -> (string * json) list -> int -> unit 30 | val set_time : t -> (string * json) list -> Time.t -> unit 31 | val add_count : t -> (string * json) list -> int -> unit 32 | val add_bytes : t -> (string * json) list -> int -> unit 33 | val add_time : t -> (string * json) list -> Time.t -> unit 34 | end 35 | 36 | (** Log events related to the life of the program: 37 | - [start] 38 | - [signal.stop] 39 | - [exit] 40 | *) 41 | val lifetime : ?extra:string -> events:logger -> version:string -> unit -> unit 42 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name devkit) 3 | (libraries 4 | (re_export devkit_core)) 5 | (modules devkit)) 6 | 7 | (library 8 | (name devkit_core) 9 | (public_name devkit.core) 10 | (libraries 11 | threads.posix ; must come first 12 | curl 13 | curl.lwt 14 | extlib 15 | extunix 16 | libevent 17 | lwt 18 | lwt.unix 19 | ocamlnet_lite 20 | pcre2 21 | stdlib-shims 22 | str 23 | trace.core 24 | unix 25 | yojson 26 | (select 27 | possibly_otel.ml 28 | from 29 | (opentelemetry opentelemetry.trace -> possibly_otel.real.ml) 30 | ( -> possibly_otel.stub.ml)) 31 | zip) 32 | (modules :standard \ 33 | devkit 34 | stage_merge 35 | memory_gperftools 36 | memory_jemalloc 37 | test 38 | test_gzip 39 | test_httpev) 40 | (preprocess 41 | (per_module 42 | ((pps lwt_ppx) 43 | httpev 44 | logstash 45 | lwt_flag 46 | lwt_util 47 | parallel 48 | web)) 49 | )) 50 | 51 | (library 52 | (name devkit_gperftools) 53 | (public_name devkit.gperftools) 54 | (optional) 55 | (libraries 56 | devkit_core 57 | gperftools) 58 | (modules memory_gperftools)) 59 | 60 | (library 61 | (name devkit_jemalloc) 62 | (public_name devkit.jemalloc) 63 | (optional) 64 | (libraries 65 | devkit_core 66 | jemalloc) 67 | (modules memory_jemalloc)) 68 | 69 | (executable 70 | (name test) 71 | (libraries lwt lwt.unix devkit extlib extunix libevent ocamlnet_lite ounit2 unix yojson) 72 | (modules test test_httpev)) 73 | 74 | ; uses 8GB+ RAM, so do not run as part of test suite 75 | (executable 76 | (name test_gzip) 77 | (libraries devkit extlib) 78 | (modules test_gzip)) 79 | 80 | (rule 81 | (alias runtest) 82 | (action (run ./test.exe))) 83 | -------------------------------------------------------------------------------- /fastBase64.ml: -------------------------------------------------------------------------------- 1 | 2 | exception Invalid_char 3 | exception Invalid_table 4 | 5 | let chars = [| 6 | 'A';'B';'C';'D';'E';'F';'G';'H';'I';'J';'K';'L';'M';'N';'O';'P'; 7 | 'Q';'R';'S';'T';'U';'V';'W';'X';'Y';'Z';'a';'b';'c';'d';'e';'f'; 8 | 'g';'h';'i';'j';'k';'l';'m';'n';'o';'p';'q';'r';'s';'t';'u';'v'; 9 | 'w';'x';'y';'z';'0';'1';'2';'3';'4';'5';'6';'7';'8';'9';'+';'/' 10 | |] 11 | 12 | let make_decoding_table tbl = 13 | if Array.length tbl <> 64 then raise Invalid_table; 14 | let d = Array.make 256 (-1) in 15 | for i = 0 to 63 do 16 | Array.unsafe_set d (Char.code (Array.unsafe_get tbl i)) i; 17 | done; 18 | d 19 | 20 | let inv_chars = make_decoding_table chars 21 | 22 | let str_decode ?(relaxed=false) ?(tbl=inv_chars) s = 23 | if Array.length tbl <> 256 then raise Invalid_table; 24 | let data = ref 0 in 25 | let count = ref 0 in 26 | let pos = ref 0 in 27 | let fail = ref false in 28 | let invalid_char = 29 | match relaxed with 30 | | true -> (fun () -> fail := true) 31 | | false -> (fun () -> raise Invalid_char) 32 | in 33 | let rec fetch () = 34 | if !fail then '?' else 35 | if !count >= 8 then begin 36 | count := !count - 8; 37 | let d = (!data asr !count) land 0xFF in 38 | Char.unsafe_chr d 39 | end else 40 | let c = Char.code (String.unsafe_get s !pos) in 41 | match Array.unsafe_get tbl c with 42 | | -1 -> invalid_char (); '?' 43 | | c -> 44 | data := (!data lsl 6) lor c; 45 | incr pos; 46 | count := !count + 6; 47 | fetch () 48 | in 49 | let n = String.length s in 50 | let len = 51 | if n < 4 then n * 6 / 8 else 52 | match s.[n-1], s.[n-2] with 53 | | '=', '=' -> if n mod 4 <> 0 then invalid_char (); (n - 2) * 6 / 8 54 | | '=', _ -> if n mod 4 <> 0 then invalid_char (); (n - 1) * 6 / 8 55 | | _, _ -> n * 6 / 8 56 | in 57 | ExtString.String.init len (fun _ -> fetch ()) 58 | -------------------------------------------------------------------------------- /prelude.ml: -------------------------------------------------------------------------------- 1 | (** Useful shortcuts *) 2 | 3 | module U = ExtUnix.Specific 4 | module Enum = ExtEnum 5 | 6 | let ($) f g = fun x -> f (g x) 7 | let ($$) f g = fun x y -> f (g x) (g y) 8 | let (!!) = Lazy.force 9 | 10 | module F1 = struct 11 | let (@@) f g = fun x -> f @@ g @@ x 12 | let (|>) f g = fun x -> x |> f |> g 13 | end 14 | 15 | external id : 'a -> 'a = "%identity" 16 | external identity : 'a -> 'a = "%identity" 17 | let flip f x y = f y x 18 | let some x = Some x 19 | let const x = fun () -> x 20 | 21 | let apply2 f = fun (x,y) -> f x, f y 22 | 23 | let printfn fmt = Printf.ksprintf print_endline fmt 24 | let eprintfn fmt = Printf.ksprintf prerr_endline fmt 25 | 26 | let curry f a b = f (a, b) 27 | let uncurry f (a,b) = f a b 28 | 29 | module Fresh(T : sig type t val compare : t -> t -> int end)() = 30 | struct 31 | type t = T.t 32 | let inject = id 33 | let project = id 34 | let inject_list = id 35 | let project_list = id 36 | let compare = T.compare 37 | let equal a b = T.compare a b = 0 38 | let map f x = inject @@ f @@ project x 39 | let map2 f x y = inject @@ f (project x) (project y) 40 | end 41 | 42 | let (+=) a b = a := !a + b 43 | let (-=) a b = a := !a - b 44 | let tuck l x = l := x :: !l 45 | let cons l x = x :: l 46 | 47 | let round f = 48 | let bot = floor f in 49 | if f -. bot < 0.5 then bot else bot +. 1. 50 | 51 | let atoi name v = try int_of_string v with _ -> Exn.fail "%s %S not integer" name v 52 | 53 | let call_me_maybe f x = 54 | match f with 55 | | None -> () 56 | | Some f -> f x 57 | 58 | (* 59 | If libev backend is available, do nothing (lwt uses it as default). 60 | Otherwise, prefer poll over select, because select can only monitor fds up to 1024, 61 | and poll is guaranteed to be available without the fd limitation. 62 | *) 63 | let () = 64 | if not (Lwt_config._HAVE_LIBEV && Lwt_config.libev_default) then begin 65 | Lwt_engine.set @@ new Lwt_engines.poll 66 | end 67 | -------------------------------------------------------------------------------- /reader.ml: -------------------------------------------------------------------------------- 1 | 2 | open ExtLib 3 | open String 4 | 5 | (* invariant: 0 <= pos <= String.length s *) 6 | type t = { s : string; mutable pos : int; } 7 | 8 | exception EOS 9 | exception Not_equal of string 10 | 11 | let init s = { s; pos = 0; } 12 | 13 | let left t = length t.s - t.pos 14 | let eos t = left t = 0 15 | 16 | let rest t = 17 | let s = sub t.s t.pos (left t) in 18 | t.pos <- length t.s; 19 | s 20 | 21 | let till t sep = 22 | try 23 | let i = find_from t.s t.pos sep in 24 | let s = sub t.s t.pos (i - t.pos) in 25 | t.pos <- i + length sep; 26 | s 27 | with 28 | Invalid_string -> raise EOS 29 | 30 | let try_till t sub = try till t sub with EOS -> rest t 31 | 32 | let tillc t c = 33 | try 34 | let i = index_from t.s t.pos c in 35 | let s = sub t.s t.pos (i - t.pos) in 36 | t.pos <- i + 1; 37 | s 38 | with 39 | Invalid_string -> raise EOS 40 | 41 | let try_tillc t c = try tillc t c with EOS -> rest t 42 | 43 | let extract t n = 44 | let s = sub t.s t.pos n in 45 | t.pos <- t.pos + n; 46 | s 47 | 48 | let take t n = 49 | if n > left t then raise EOS; 50 | extract t n 51 | 52 | let while_ t p = 53 | let rec loop t p i = 54 | if i = length t.s then rest t else 55 | if p @@ String.unsafe_get t.s i then loop t p (i+1) 56 | else extract t (i - t.pos) 57 | in 58 | loop t p t.pos 59 | 60 | let skipc t c = 61 | if t.pos = length t.s then raise EOS; 62 | if String.unsafe_get t.s t.pos = c then t.pos <- t.pos + 1 else raise (Not_equal (String.make 1 c)) 63 | 64 | let try_take t n = take t (min n (left t)) 65 | 66 | let is_const t s = length s <= left t && sub t.s t.pos (length s) = s 67 | 68 | let const t s = 69 | if length s > left t then raise EOS; 70 | if sub t.s t.pos (length s) <> s then raise (Not_equal s); 71 | t.pos <- t.pos + length s 72 | 73 | let try_const t s = 74 | let s = if length s <= left t then s else sub s 0 (left t) in 75 | const t s 76 | -------------------------------------------------------------------------------- /extThread.mli: -------------------------------------------------------------------------------- 1 | (** Thread utilities *) 2 | 3 | val locked : Mutex.t -> (unit -> 'a) -> 'a 4 | 5 | type 'a t 6 | val detach : ('a -> 'b) -> 'a -> 'b t 7 | val join : 'a t -> 'a Exn.result 8 | val join_exn : 'a t -> 'a 9 | 10 | (** parallel Array.map *) 11 | val map : ('a -> 'b) -> 'a array -> 'b array 12 | 13 | (** parallel map with the specified number of workers, default=8 *) 14 | val mapn : ?n:int -> ('a -> 'b) -> 'a list -> 'b Exn.result list 15 | 16 | module LockMutex : sig 17 | type t 18 | val create : unit -> t 19 | val locked : t -> (unit -> 'a) -> 'a 20 | end 21 | 22 | (** 23 | Communication from worker threads to the main event loop 24 | *) 25 | module Async_fin : sig 26 | 27 | type t 28 | 29 | (** @return if OS has necessary support for this module *) 30 | val is_available : unit -> bool 31 | 32 | val setup : Libevent.event_base -> t 33 | 34 | (** Destructor. All queued events are lost *) 35 | val shutdown : t -> unit 36 | 37 | (** Arrange for callback to be executed in libevent loop, callback should not throw (exceptions are reported and ignored) *) 38 | val callback : t -> (unit -> unit) -> unit 39 | 40 | end 41 | 42 | (** Create new thread wrapped in {!Action.log} *) 43 | val log_create : ?name:string -> ('a -> unit) -> 'a -> Thread.t 44 | 45 | (** run [f] in thread periodically once in [delay] seconds. 46 | @param f returns [false] to stop the thread, [true] otherwise 47 | @param now default [false] 48 | *) 49 | val run_periodic : delay:float -> ?now:bool -> (unit -> bool) -> unit 50 | 51 | module type WorkerT = sig 52 | type task 53 | type result 54 | end 55 | 56 | module type Workers = sig 57 | type task 58 | type result 59 | type t 60 | val create : (task -> result) -> int -> t 61 | val perform : t -> ?autoexit:bool -> task Enum.t -> (result -> unit) -> unit 62 | val stop : ?wait:int -> t -> unit 63 | end 64 | 65 | (** Thread workers *) 66 | module Workers(T:WorkerT) : Workers 67 | with type task = T.task 68 | and type result = T.result 69 | 70 | module Pool : sig 71 | type t 72 | val create : int -> t 73 | val status : t -> string 74 | val put : t -> (unit -> unit) -> unit 75 | val wait_blocked : ?n:int -> t -> unit 76 | end 77 | -------------------------------------------------------------------------------- /ocamlnet_lite/netstring_str.mli: -------------------------------------------------------------------------------- 1 | type regexp 2 | (** The type of regular expressions *) 3 | 4 | type split_result = Str.split_result = 5 | | Text of string 6 | | Delim of string (** Here we keep compatibility with [Str] *) 7 | 8 | type result 9 | (** The type of matching results *) 10 | 11 | val regexp : string -> regexp 12 | (** Parses a regexp *) 13 | 14 | val search_forward : regexp -> string -> int -> int * result 15 | (** Searches a match of the string with the regexp, starting at 16 | * the position and in forward direction. 17 | * Raises [Not_found] if no match could be found. 18 | * Returns [(p,r)] when a match at position [p] is found, 19 | * described by [r]. 20 | *) 21 | 22 | val quote_set : string -> string 23 | (** Returns a regexp (as string) that matches any of the characters in 24 | the argument. The argument must be non-empty 25 | *) 26 | 27 | val matched_string : result -> string -> string 28 | (** Extracts the matched part from the string. The string argument 29 | * must be the same string passed to [string_match] or the search 30 | * functions, and the result argument must be the corresponding 31 | * result. 32 | *) 33 | 34 | val match_beginning : result -> int 35 | (** Returns the position where the matched part begins *) 36 | 37 | val match_end : result -> int 38 | (** Returns the position where the matched part ends *) 39 | 40 | val matched_group : result -> int -> string -> string 41 | (** Extracts the substring the nth group matches from the whole 42 | * string. The string argument 43 | * must be the same string passed to [string_match] or the search 44 | * functions, and the result argument must be the corresponding 45 | * result. 46 | *) 47 | 48 | val full_split : regexp -> string -> split_result list 49 | (** Like [split_delim], but returns the delimiters in the result *) 50 | 51 | val global_substitute : 52 | regexp -> (result -> string -> string) -> string -> string 53 | (** [global_substitute re subst s]: Applies the substitution function 54 | * [subst] to all matchings of [re] in [s], and returns the 55 | * transformed string. [subst] is called with the current [result] 56 | * of the match and the whole string [s]. 57 | *) 58 | -------------------------------------------------------------------------------- /htmlStream.ml: -------------------------------------------------------------------------------- 1 | (** Stream of html elements *) 2 | 3 | open Printf 4 | open ExtLib 5 | 6 | include HtmlStream_ragel 7 | 8 | let show_attrs_quote c a = 9 | List.map (fun (k,v) -> sprintf " %s=%c%s%c" k c (Raw.project v) c) a |> String.concat "" 10 | 11 | let show_raw_quote c elem = 12 | match elem with 13 | | Tag (name,attrs) -> sprintf "<%s%s>" name (show_attrs_quote c attrs) 14 | | Text t -> Raw.project t 15 | | Close name -> Printf.sprintf "" name 16 | | Script (attrs, s) -> sprintf "%s" (show_attrs_quote c attrs) s 17 | | Style (attrs, s) -> sprintf "%s" (show_attrs_quote c attrs) s 18 | 19 | let show_raw' = show_raw_quote '\'' 20 | let show_raw = show_raw_quote '"' 21 | 22 | let attrs_include attrs a = 23 | let a = 24 | if a |> List.exists (fun (_,v) -> String.contains v ' ') then 25 | a |> List.map (fun (k,v) -> Stre.nsplitc v ' ' |> List.map (fun s -> k,s)) |> List.flatten 26 | else 27 | a 28 | in 29 | match a with 30 | | [] -> true 31 | | _ -> 32 | let attrs = List.map (fun (k,v) -> (k, Stre.nsplitc (Raw.project v) ' ')) attrs in 33 | try 34 | List.for_all (fun (k,v) -> List.mem v (List.assoc k attrs)) a 35 | with 36 | Not_found -> false 37 | 38 | let tag name ?(a=[]) = function 39 | | Tag (name',attrs) when name = name' -> attrs_include attrs a 40 | | _ -> false 41 | 42 | let close name = function Close name' when name = name' -> true | _ -> false 43 | 44 | let to_text ?(br=false) ?(strip=false) = function 45 | | Tag ("br",_) when br -> Some (Raw.inject "\n") 46 | | Tag _ -> None 47 | | Text x -> Some (if strip then Raw.inject (String.strip (Raw.project x)) else x) 48 | | Script _ 49 | | Style _ 50 | | Close _ -> None 51 | 52 | (* let make_text l = wrapped_outs (fun out -> List.iter (Option.may (IO.nwrite out) $ Option.map Raw.project $ to_text) l) *) 53 | let make_text ?br l = 54 | let fold e = 55 | let b = Buffer.create 10 in 56 | let (_:bool) = Enum.fold (fun s bos -> if not bos && s <> "\n" then Buffer.add_char b ' '; Buffer.add_string b s; s = "\n") true e in 57 | Buffer.contents b 58 | in 59 | List.enum l |> Enum.filter_map (to_text ?br ~strip:true) |> 60 | Enum.map Raw.project |> fold |> Raw.inject 61 | -------------------------------------------------------------------------------- /systemd.ml: -------------------------------------------------------------------------------- 1 | open ExtLib 2 | 3 | let log = Log.from "systemd" 4 | 5 | module Daemon = struct 6 | 7 | (* https://github.com/systemd/systemd/blob/cb3108669d623afe58a36077e36ae4c66ff7d1c3/src/systemd/sd-daemon.h#L56 *) 8 | (* The first passed file descriptor is fd 3. *) 9 | let sd_listen_fds_start = 3 10 | 11 | let booted = 12 | (* https://github.com/systemd/systemd/blob/cb31086/src/libsystemd/sd-daemon/sd-daemon.c#L607 *) 13 | try 14 | Unix.access "/run/systemd/system/" Unix.[F_OK]; 15 | true 16 | with Unix.Unix_error _ -> 17 | false 18 | 19 | let listen_pid = 20 | Option.map int_of_string (Sys.getenv_opt "LISTEN_PID") 21 | 22 | let listen_fds () : Unix.file_descr list = 23 | (* https://github.com/systemd/systemd/blob/cb31086/src/libsystemd/sd-daemon/sd-daemon.c#L42-L90 *) 24 | match booted with 25 | | false -> 26 | log#debug "listen_fds: not booted with systemd"; 27 | [] 28 | | true -> 29 | match listen_pid with 30 | | None -> 31 | log#debug "listen_fds: no LISTEN_PID"; 32 | [] 33 | | Some listen_pid -> 34 | let self_pid = Unix.getpid () in 35 | match listen_pid = self_pid with 36 | | false -> 37 | log#warn "listen_fds: LISTEN_PID %d and process pid %d are not equal, ignoring" listen_pid self_pid; 38 | [] 39 | | true -> 40 | let listen_fds = Option.map int_of_string (Sys.getenv_opt "LISTEN_FDS") in 41 | match listen_fds with 42 | | None -> 43 | log#warn "listen_fds: LISTEN_PID, but no LISTEN_FDS"; 44 | [] 45 | | Some n when n <= 0 -> 46 | log#warn "listen_fds: LISTEN_FDS %d is not positive" n; 47 | [] 48 | | Some n -> 49 | let fds = List.init n (fun x -> ExtUnix.All.file_descr_of_int (x + sd_listen_fds_start)) in 50 | List.iter Unix.set_close_on_exec fds; 51 | fds 52 | 53 | let listen_fds_lwt () = 54 | List.map Lwt_unix.of_unix_file_descr (listen_fds ()) 55 | 56 | let get_args () = 57 | [ 58 | ("-loglevel", Arg.String Log.set_loglevels, " ([=]debug|info|warn|error[,])+"); 59 | ExtArg.may_str "logfile" Daemon.logfile " Log file"; 60 | ] 61 | 62 | let manage () = 63 | Daemon.foreground := true; 64 | Daemon.pidfile := None; 65 | Daemon.runas := None; 66 | 67 | Daemon.manage () 68 | end 69 | -------------------------------------------------------------------------------- /static_config.mli: -------------------------------------------------------------------------------- 1 | (** Static mapping of simple config format. 2 | 3 | Format is simple key-value pairs. Key must start with a letter and may include letters, numbers and underscore. 4 | Lines starting with '#' are treated as comments, i.e. ignored. 5 | Value can be arbitrary - there are several ways to represent them : 6 | 7 | * if the value doesn't contain any spaces, just write out the value directly 8 | 9 | = 10 | 11 | * if the value is single-line, wrap it with any symbol ( can be a quote, a doublequote or 12 | any other character that doesn't occur in the value itself) 13 | 14 | := 15 | 16 | * multi-line symbols are written verbatim prefixed with the number of lines occupied 17 | 18 | : 19 | 20 | 21 | [...] 22 | 23 | 24 | 25 | Example usage: 26 | 27 | module CONF = struct 28 | open Static_config 29 | 30 | (* fresh new group *) 31 | let root = new_root () 32 | let save = save root 33 | let load = load root 34 | 35 | (* values stored *) 36 | let last_id = int root "last_id" 0 37 | let last_key = string root "last_key" "" 38 | end 39 | 40 | or as an object: 41 | 42 | let simple_config filename = 43 | let open Static_config in 44 | let root = new_root () in 45 | let port = int root "port" 8080 in 46 | object 47 | inherit base root filename 48 | method port = port 49 | end 50 | 51 | let conf = simple_config "some.config" in (* get's loaded here *) 52 | conf#port#set 8081; 53 | conf#save () 54 | 55 | *) 56 | 57 | exception Error of string 58 | 59 | type 'a value = < get : 'a; set : 'a -> unit; dirty : bool; > 60 | type group 61 | 62 | val group : group -> string -> group 63 | 64 | val new_root : unit -> group 65 | 66 | val int : group -> string -> int -> int value 67 | val long : group -> string -> int64 -> int64 value 68 | val string : group -> string -> string -> string value 69 | val float : group -> string -> float -> float value 70 | val bool : group -> string -> bool -> bool value 71 | 72 | val show : ?all:bool -> group -> string 73 | val read : group -> string -> unit 74 | 75 | val reset : group -> unit 76 | val load : group -> string -> unit 77 | val save : ?all:bool -> group -> string -> unit 78 | 79 | class base : group -> string -> object method load : unit -> unit method save : unit -> unit end 80 | -------------------------------------------------------------------------------- /files.ml: -------------------------------------------------------------------------------- 1 | open Prelude 2 | open Control 3 | 4 | let enum_dir d = Enum.from (fun () -> try Unix.readdir d with End_of_file -> raise Enum.No_more_elements) 5 | let with_readdir dirname = bracket (Unix.opendir dirname) Unix.closedir 6 | 7 | let iter_names dirname f = 8 | let rec loop path rel = 9 | with_readdir path (fun d -> 10 | enum_dir d |> 11 | Enum.iter (function 12 | | "." | ".." -> () 13 | | name -> 14 | let path = Filename.concat path name in 15 | match try Some (Unix.openfile path [Unix.O_RDONLY] 0) with _ -> None with 16 | | None -> () 17 | | Some fd -> 18 | bracket fd (Exn.suppress Unix.close) (fun fd -> 19 | let rel = Filename.concat rel name in 20 | match (Unix.fstat fd).Unix.st_kind with 21 | | Unix.S_REG -> f fd path rel 22 | | Unix.S_DIR -> loop path rel 23 | | _ -> () 24 | ) 25 | ) 26 | ) 27 | in loop dirname "" 28 | 29 | let iter_names_q dirname f = 30 | let rec loop path rel = 31 | with_readdir path (fun d -> 32 | enum_dir d |> 33 | Enum.iter (function 34 | | "." | ".." -> () 35 | | name -> 36 | let path = Filename.concat path name in 37 | let rel = Filename.concat rel name in 38 | match try Some (Unix.stat path).Unix.st_kind with _ -> None with 39 | | Some Unix.S_REG -> f path rel 40 | | Some Unix.S_DIR -> loop path rel 41 | | _ -> () 42 | ) 43 | ) 44 | in loop dirname "" 45 | 46 | let iter_files dirname f = 47 | iter_names dirname (fun fd path _ -> 48 | bracket (Unix.in_channel_of_descr fd) close_in_noerr (fun ch -> f path ch)) 49 | 50 | let open_out_append_text = open_out_gen [Open_wronly;Open_append;Open_creat;Open_text] 0o644 51 | let open_out_append_bin = open_out_gen [Open_wronly;Open_append;Open_creat;Open_binary] 0o644 52 | 53 | (* 54 | let () = 55 | iter_files "/etc" (fun s _ -> print_endline s) 56 | *) 57 | 58 | let save_as name ?(mode=0o644) f = 59 | (* not using make_temp_file cause same dir is needed for atomic rename *) 60 | let temp = Printf.sprintf "%s.save.%d.tmp" name (U.gettid ()) in 61 | bracket (Unix.openfile temp [Unix.O_WRONLY;Unix.O_CREAT] mode) Unix.close begin fun fd -> 62 | try 63 | let ch = Unix.out_channel_of_descr fd in 64 | (* Unix.fchmod fd mode; *) 65 | f ch; 66 | flush ch; 67 | U.fsync fd; 68 | Unix.rename temp name 69 | with 70 | exn -> Exn.suppress Unix.unlink temp; raise exn 71 | end 72 | -------------------------------------------------------------------------------- /logger.ml: -------------------------------------------------------------------------------- 1 | 2 | open Printf 3 | 4 | type level = [`Debug | `Info | `Warn | `Error | `Nothing] 5 | type facil = { name : string; mutable show : int; } 6 | let int_level = function 7 | | `Debug -> 0 8 | | `Info -> 1 9 | | `Warn -> 2 10 | | `Error -> 3 11 | | `Nothing -> 100 12 | let set_filter facil level = facil.show <- int_level level 13 | let get_level facil = match facil.show with 14 | | 0 -> `Debug 15 | | 1 -> `Info 16 | | 2 -> `Warn 17 | | x when x = 100 -> `Nothing 18 | | _ -> `Error (* ! *) 19 | let allowed facil level = level <> `Nothing && int_level level >= facil.show 20 | 21 | let string_level = function 22 | | `Debug -> "debug" 23 | | `Info -> "info" 24 | | `Warn -> "warn" 25 | | `Error -> "error" 26 | | `Nothing -> "nothing" 27 | 28 | let level = function 29 | | "info" -> `Info 30 | | "debug" -> `Debug 31 | | "warn" -> `Warn 32 | | "error" -> `Error 33 | | "nothing" -> `Nothing 34 | | s -> Exn.fail "unrecognized level %s" s 35 | 36 | module type Target = 37 | sig 38 | val format : level -> facil -> string -> string 39 | val output : level -> facil -> string -> unit 40 | end 41 | 42 | module type Put = sig 43 | val put : level -> facil -> string -> unit 44 | end 45 | 46 | module PutSimple(T : Target) : Put = 47 | struct 48 | 49 | let put level facil str = 50 | if allowed facil level then 51 | T.output level facil (T.format level facil str) 52 | 53 | end 54 | 55 | module PutLimited(T : Target) : Put = 56 | struct 57 | 58 | let last = ref (`Debug,"") 59 | let n = ref 0 60 | 61 | (** FIXME not thread safe *) 62 | let put level facil str = 63 | match allowed facil level with 64 | | false -> () 65 | | true -> 66 | let this = (level,str) in 67 | if !last = this then 68 | incr n 69 | else 70 | begin 71 | if !n <> 0 then 72 | begin 73 | T.output level facil (sprintf 74 | "last message repeated %u times, suppressed\n" !n); 75 | n := 0 76 | end; 77 | last := this; 78 | T.output level facil (T.format level facil str); 79 | end 80 | 81 | end 82 | 83 | module Make(T : Put) = struct 84 | 85 | let debug_s = T.put `Debug 86 | let info_s = T.put `Info 87 | let warn_s = T.put `Warn 88 | let error_s = T.put `Error 89 | let put_s = T.put 90 | 91 | let debug f fmt = ksprintf (debug_s f) fmt 92 | let info f fmt = ksprintf (info_s f) fmt 93 | let warn f fmt = ksprintf (warn_s f) fmt 94 | let error f fmt = ksprintf (error_s f) fmt 95 | 96 | end 97 | -------------------------------------------------------------------------------- /pid.ml: -------------------------------------------------------------------------------- 1 | open ExtLib 2 | open Printf 3 | 4 | type t = { host : string; id : int; name : string; stamp : int; } 5 | 6 | let dummy = { host="*"; id=0; name="*"; stamp=0; } 7 | 8 | let show { id; name; host; stamp=_; } = sprintf "%u:%s@%s" id name host 9 | let to_string { id; name; host; stamp; } = sprintf "%u:%u:%s@%s" stamp id name host 10 | let compare (pid1:t) pid2 = compare pid1 pid2 11 | let equal pid1 pid2 = 0 = compare pid1 pid2 12 | let name { name; _ } = name 13 | let host { host; _ } = host 14 | 15 | let get_name s = try fst @@ String.split s "." with _ -> s 16 | let validate_name descr s = 17 | try Scanf.sscanf s "%_[a-zA-Z0-9_.-]%!" () with _ -> Exn.fail "Pid.self: bad %s %S" descr s 18 | let sanitize_name = String.map (function 'a'..'z' | 'A'..'Z' | '0'..'9' | '_' | '-' | '.' as c -> c | _ -> '_') 19 | 20 | let parse_exn s = 21 | (* cf self_pid *) 22 | Scanf.sscanf s "%u:%u:%[a-zA-Z0-9_.-]@@%[a-zA-Z0-9_.-]%!" (fun stamp id name host -> 23 | if host = "" then Exn.fail "empty hostname"; 24 | if name = "" then Exn.fail "empty name"; 25 | { id; host=String.lowercase_ascii host; name=get_name @@ String.lowercase_ascii name; stamp; }) 26 | 27 | let make ~id ~host ~stamp name = 28 | validate_name "name" name; 29 | validate_name "host" host; 30 | { id; host; stamp; name } 31 | 32 | let new_self name stamp = 33 | let id = Unix.getpid () in 34 | let host = String.lowercase_ascii @@ Unix.gethostname () in 35 | (* cf parse_exn *) 36 | validate_name "host" host; 37 | validate_name "name" name; 38 | { host; id; name = get_name @@ String.lowercase_ascii name; stamp; } 39 | 40 | let self = ref @@ dummy 41 | let self_s = ref @@ "" 42 | 43 | let assign_self t = 44 | self := t; 45 | self_s := show t 46 | 47 | let update_self name fresh = assign_self @@ new_self name (if fresh then Time.(int @@ now ()) else (!self).stamp) 48 | 49 | let () = update_self (sanitize_name @@ Filename.basename Sys.executable_name) true 50 | 51 | let fake_id = ref false 52 | 53 | let set_name name = 54 | validate_name "name" name; 55 | update_self name !fake_id; 56 | fake_id := false 57 | 58 | let update () = 59 | match !fake_id with 60 | | true -> () 61 | | false -> 62 | match (!self).id = Unix.getpid () with 63 | | true -> () 64 | | false -> (* fork *) 65 | update_self (!self.name) true 66 | 67 | let set_fake t = 68 | assign_self t; 69 | fake_id := true 70 | 71 | let self () = !self 72 | let self_name () = name @@ self () 73 | let show_self () = !self_s 74 | let self_as name = set_name name; self () 75 | -------------------------------------------------------------------------------- /var.mli: -------------------------------------------------------------------------------- 1 | (** 2 | Global register for various types of counters. 3 | {!Logstash} module will send all [Var] counters to logstash automatically. 4 | Counters must be mononotonically increasing for logstash to send correct deltas to Elasticsearch. 5 | *) 6 | 7 | type attributes = (string * string) list 8 | type t = Time of Time.t | Count of int | Bytes of int 9 | 10 | val show_a : (string * string) list -> string 11 | val is_in_families : string -> bool 12 | 13 | (** [new typ type ?attr key] registers new [type] of counters with designated [attr]ibutes and [key] name *) 14 | class typ : string -> ?attr:attributes -> string -> 15 | object 16 | method ref : 'a. 'a -> ('a -> t) -> string -> 'a ref 17 | method get_count : string -> (unit -> int option) -> unit 18 | method get_bytes : string -> (unit -> int option) -> unit 19 | method get_time : string -> (unit -> Time.t option) -> unit 20 | method count : string -> int ref 21 | method bytes : string -> int ref 22 | method time : string -> float ref 23 | method unregister : unit -> unit 24 | method get : (string * t) list 25 | method show : string 26 | end 27 | 28 | (** [cc pp type ?attr key] new set of counters with designated [type], [attr]ibutes and [key] name 29 | 30 | Logstash events will have attributes as follows : 31 | * all of [attr] key value pairs (if given) 32 | * class=[type] 33 | * [key]=X where X is value inserted into [CC] 34 | 35 | Guidelines for picking names : 36 | keep number of different [key] names low (makes ES happy), 37 | uniqueness of events is primarily provided by [class]. 38 | 39 | Bad example : 40 | let pages = new Var.cc "tool.pages" "pages" 41 | let index = new Var.cc "tool.index" "index" 42 | let count = new Var.cc "tool.count" "count" 43 | 44 | Better : 45 | let pages = new Var.cc "tool.pages" "kind" 46 | let pages = new Var.cc "tool.index" "kind" 47 | let pages = new Var.cc "tool.count" "kind" 48 | *) 49 | val cc : ('a -> string) -> string -> ?attr:attributes -> string -> 'a Cache.Count.t 50 | 51 | (** [cc pp type ?attr key] new set of counters with designated [type], [attr]ibutes and [key] name, treated as milliseconds *) 52 | val cc_ms : ('a -> string) -> string -> ?attr:attributes -> string -> 'a Cache.Count.t 53 | 54 | (* val show : unit -> string *) 55 | (** callback takes attributes and value *) 56 | val iter : (attributes -> t -> unit) -> unit 57 | 58 | (** [list_stats filter] 59 | 60 | @return a list containing a printed line for each counter whose type is in [filter]. 61 | *) 62 | val list_stats : string list -> string list 63 | -------------------------------------------------------------------------------- /network.mli: -------------------------------------------------------------------------------- 1 | (** Manipulating network addresses *) 2 | 3 | type ipv4 4 | type ipv4_cidr 5 | 6 | exception Parse_ipv4 of string 7 | 8 | val ipv4_null : ipv4 9 | val bytes_of_ipv4 : ipv4 -> int * int * int * int 10 | val string_of_ipv4 : ipv4 -> string 11 | 12 | (** @raise Parse_ipv4 if input is not an IP *) 13 | val ipv4_of_string_exn : string -> ipv4 14 | 15 | (** @return ip 0.0.0.0 when input is not an IP *) 16 | val ipv4_of_string_null : string -> ipv4 17 | 18 | val ipv4_of_int32 : int32 -> ipv4 19 | val int32_of_ipv4 : ipv4 -> int32 20 | val is_ipv4_slow : string -> bool 21 | val is_ipv4 : string -> bool 22 | val ipv4_of_int : int -> ipv4 23 | val int_of_ipv4 : ipv4 -> int 24 | val class_c : ipv4 -> ipv4 25 | val ipv4_to_yojson : ipv4 -> Yojson.Safe.t 26 | val ipv4_of_yojson : Yojson.Safe.t -> (ipv4, string) result 27 | 28 | module IPv4 : sig 29 | type t = ipv4 30 | val equal : t -> t -> bool 31 | val compare : t -> t -> int 32 | val null : t 33 | val to_bytes : t -> int * int * int * int 34 | val to_string : t -> string 35 | val of_string_exn : string -> t 36 | val of_string_null : string -> t 37 | val of_int32 : int32 -> t 38 | val to_int32 : t -> int32 39 | val of_int : int -> t 40 | val to_int : t -> int 41 | val class_c : t -> t 42 | end 43 | 44 | (** accepts addr/n notation or single ip *) 45 | val cidr_of_string_exn : string -> ipv4_cidr 46 | val string_of_cidr : ipv4_cidr -> string 47 | val range_of_cidr : ipv4_cidr -> ipv4 * ipv4 48 | val prefix_of_cidr : ipv4_cidr -> ipv4 49 | val ipv4_matches : ipv4 -> ipv4_cidr -> bool 50 | val is_ipv4_special : ipv4 -> bool 51 | val special_cidr : ipv4_cidr list 52 | 53 | (** @return ip address of this machine on private network, with 127.0.0.1 as a fallback, NB ipv4 only *) 54 | val private_ipv4_network_ip : unit -> Unix.inet_addr 55 | 56 | val public_ipv4_network_ip : unit -> Unix.inet_addr option 57 | val public_ipv4_network_ip_exn : unit -> Unix.inet_addr 58 | 59 | (** @return interfaces and associated ip addresses of this machine on public network. NB ipv4 only *) 60 | val public_ipv4_network_ips : unit -> (string * Unix.inet_addr) list 61 | 62 | (** @return interfaces and associated ip addresses of this machine on private network. NB ipv4 only *) 63 | val private_ipv4_network_ips : unit -> (string * Unix.inet_addr) list 64 | 65 | val private_network_ip : unit -> Unix.inet_addr [@@ocaml.deprecated "use private_ipv4_network_ip instead"] 66 | val public_network_ips : unit -> (string * Unix.inet_addr) list [@@ocaml.deprecated "use public_ipv4_network_ips instead"] 67 | val private_network_ips : unit -> (string * Unix.inet_addr) list [@@ocaml.deprecated "use private_ipv4_network_ips instead"] 68 | -------------------------------------------------------------------------------- /lwt_engines.ml: -------------------------------------------------------------------------------- 1 | open ExtLib 2 | 3 | module U = ExtUnix.Specific 4 | module Ev = Libevent 5 | 6 | class poll = 7 | let readmask = U.Poll.(pollin + pollerr + pollhup + pollpri + pollrdhup) in 8 | let writemask = U.Poll.(pollout + pollerr + pollhup) in 9 | let convert (fd,i,o) = fd, U.Poll.((if i then pollin else none) + (if o then pollout else none)) in 10 | object 11 | val mutable buffer = [||] 12 | inherit Lwt_engine.poll_based 13 | method poll fds timeout = 14 | (* 15 | let show = Stre.list (fun (fd,i,o) -> sprintf "%d%s%s" (U.int_of_file_descr fd) (if i then "r" else "") (if o then "w" else "")) in 16 | log #info "lwt poll %f %s" timeout (show fds); 17 | *) 18 | let nfds = List.length fds in 19 | if nfds <= Array.length buffer && nfds * 2 > Array.length buffer then 20 | begin 21 | List.iteri (fun i x -> buffer.(i) <- convert x) fds; 22 | end 23 | else 24 | buffer <- Array.of_list @@ List.map convert fds; 25 | 26 | let timeout = if timeout < 0. then - 1. /. 1000. else timeout in 27 | 28 | let l = U.poll buffer ~n:nfds timeout |> List.map (fun (fd,f) -> fd, U.Poll.is_inter f readmask, U.Poll.is_inter f writemask) in 29 | (* log #info "lwt poll done %s" (show l); *) 30 | l 31 | end 32 | 33 | (** libevent-based engine for lwt *) 34 | class libevent = 35 | let once_block = Ev.[ONCE] in 36 | let once_nonblock = Ev.[ONCE;NONBLOCK] in 37 | object(self) 38 | inherit Lwt_engine.abstract 39 | 40 | val events_ = Ev.init () 41 | val mutable pid = Unix.getpid () 42 | method events = 43 | if Unix.getpid () <> pid then (pid <- Unix.getpid (); Ev.reinit events_); 44 | events_ 45 | 46 | method private cleanup = Ev.free events_ 47 | 48 | method iter block = 49 | try 50 | Ev.(loops self#events (if block then once_block else once_nonblock)) 51 | with 52 | exn -> Exn.fail ~exn "Lwt_engines.libevent#iter" 53 | 54 | method private register_readable fd f = 55 | let ev = Ev.create () in 56 | Ev.set self#events ev fd [Ev.READ] ~persist:true (fun _ _ -> f ()); 57 | Ev.add ev None; 58 | lazy (Ev.del ev) 59 | 60 | method private register_writable fd f = 61 | let ev = Ev.create () in 62 | Ev.set self#events ev fd [Ev.WRITE] ~persist:true (fun _ _ -> f ()); 63 | Ev.add ev None; 64 | lazy (Ev.del ev) 65 | 66 | method private register_timer delay repeat f = 67 | let ev = Ev.create () in 68 | let stop = ref false in 69 | Ev.set_timer self#events ev ~persist:false begin fun () -> 70 | if not !stop then f (); 71 | if repeat && not !stop then Ev.add ev (Some delay); 72 | end; 73 | Ev.add ev (Some delay); 74 | lazy (stop := true; Ev.del ev) 75 | 76 | end 77 | -------------------------------------------------------------------------------- /lwt_util.ml: -------------------------------------------------------------------------------- 1 | 2 | let log = Log.from "lwt_util" 3 | 4 | let with_count nr lwt = incr nr; (lwt)[%lwt.finally decr nr; Lwt.return_unit] 5 | 6 | let timely period f = 7 | assert (period > 0.); 8 | let next = ref (Time.get () +. period) in 9 | (fun x -> if Time.get () > !next then (next := Time.get () +. period; f x) else Lwt.return_unit) 10 | 11 | let timely_loop' ?(immediate=false) period f = 12 | let rec loop () = 13 | let%lwt () = 14 | try%lwt 15 | let%lwt () = f () in 16 | let%lwt () = Lwt_unix.sleep period in 17 | Lwt.return_unit 18 | with 19 | | Lwt.Canceled as exn -> 20 | log #info ~exn "timely_loop_lwt"; 21 | raise exn 22 | | exn -> 23 | log #error ~exn "timely_loop_lwt"; 24 | Lwt.return_unit 25 | in 26 | loop () 27 | in 28 | let%lwt () = if immediate then Lwt.return_unit else Lwt_unix.sleep period in 29 | loop () 30 | 31 | (* run f every period seconds; run immediately if immediate is true; stop when wait thread terminates *) 32 | let timely_loop ?immediate ?(wait=Daemon.wait_exit ()) period f = Lwt.pick [ wait; timely_loop' ?immediate period f; ] 33 | 34 | (* cancel t1 when t2 terminates; join so that cancelling the resulting promise cancels both t1 and t2 *) 35 | let ensure_order t1 t2 = 36 | let ignore t = let%lwt _ = t in Lwt.return_unit in 37 | let%lwt () = Lwt.join [ ignore t1; (ignore t2) [%finally Lwt.wrap1 Lwt.cancel t1; ]; ] in 38 | t2 39 | 40 | (* wait for t to terminate, suppress any exception, and call cleanup () afterwards *) 41 | let suppress_exn name cleanup t = 42 | log #info "%s started" name; 43 | let%lwt () = 44 | try%lwt 45 | let%lwt () = t in 46 | log #info "%s done" name; 47 | Lwt.return_unit 48 | with exn -> 49 | log #error ~exn "%s" name; 50 | Lwt.return_unit 51 | in 52 | cleanup () 53 | 54 | let action name f x = 55 | log #info "action %s started" name; 56 | match%lwt f x with 57 | | exception exn -> log #error ~exn "action %s aborted" name; Lwt.reraise exn 58 | | x -> log #info "action %s done" name; Lwt.return x 59 | 60 | let action_do name f = action name f () 61 | 62 | let async f = Lwt.async Daemon.(fun () -> try%lwt unless_exit (f ()) with ShouldExit -> Lwt.return_unit) 63 | 64 | let idle_check ~interval = 65 | let timestamp = ref (Time.now ()) in 66 | let stamp () = timestamp := Time.now () in 67 | let rec wait () = 68 | let idle = Time.ago !timestamp in 69 | if idle > interval then 70 | Lwt.return_unit 71 | else begin 72 | let%lwt () = Lwt_unix.sleep (interval -. idle) in 73 | wait () 74 | end 75 | in 76 | (stamp, wait ()) 77 | -------------------------------------------------------------------------------- /devkit_ragel.ml.rl: -------------------------------------------------------------------------------- 1 | 2 | %%{ 3 | machine ipv4; 4 | octet = digit{1,3} >{ n := 0; } ${ n := 10 * !n + (Char.code fc - Char.code '0') } ; 5 | main := octet %{ set () } '.' octet %{ set () } '.' octet %{ set () } '.' octet %{ set () } ; 6 | write data; 7 | }%% 8 | 9 | exception Parse_ipv4 of string 10 | 11 | let parse_ipv4 data = 12 | let cs = ref 0 and p = ref 0 and pe = ref (String.length data) and eof = ref (String.length data) in 13 | let n = ref 0 in 14 | let ip = ref 0l in 15 | let set () = 16 | if !n > 255 then raise (Parse_ipv4 data); 17 | ip := Int32.logor (Int32.shift_left !ip 8) (Int32.of_int !n) 18 | in 19 | %%write init; 20 | %%write exec; 21 | if !cs >= ipv4_first_final then !ip else raise (Parse_ipv4 data) 22 | 23 | let is_ipv4_slow data = 24 | let cs = ref 0 and p = ref 0 and pe = ref (String.length data) and eof = ref (String.length data) in 25 | let n = ref 0 in 26 | let set () = if !n > 255 then raise Not_found in 27 | %%write init; 28 | try 29 | %%write exec; 30 | !cs >= ipv4_first_final 31 | with Not_found -> false 32 | 33 | %%{ 34 | machine is_ipv4; 35 | octet = ('2' ([0-4] digit | '5' [0-5]) | [01]? digit{1,2}) ; 36 | main := octet '.' octet '.' octet '.' octet ; 37 | write data; 38 | }%% 39 | 40 | let is_ipv4 data = 41 | let cs = ref 0 and p = ref 0 and pe = ref (String.length data) in 42 | %%write init; 43 | %%write exec; 44 | !cs >= is_ipv4_first_final 45 | 46 | %%{ 47 | machine compact_duration; 48 | action second { f := !f +. (float(!fn) /. (10. ** float(!fna))); t := !t + !n; fn := 0; fna := 0; } 49 | action millisecond { f := !f +. (float(!n) /. 1_000.) +. (float(!fn) /. (1000. *. 10. ** float(!fna))); fn := 0; fna := 0; } 50 | action nanosecond { f := !f +. float(!n) /. 1_000_000_000.; } 51 | num = digit+ >{ n := 0; } ${ n := 10 * !n + (Char.code fc - Char.code '0') }; 52 | frac = '.' digit{,3} >{ fn := 0; fna := 0 } ${ fn := 10 * !fn + (Char.code fc - Char.code '0') ; fna := !fna + 1; }; 53 | main := 54 | (num 'd' %{ t := !t + !n*24*60*60;} )? 55 | (num 'h' %{ t := !t + !n*60*60; } )? 56 | (num 'm' %{ t := !t + !n*60; } )? 57 | ((num frac?'s' %second )? (num frac? 'm' 's' %millisecond )? (num 'n' 's' %nanosecond )? | (num frac? %second )?); 58 | write data; 59 | }%% 60 | 61 | exception Parse_compact_duration of string 62 | 63 | let parse_compact_duration data = 64 | if data = "" then raise (Parse_compact_duration data); 65 | let cs = ref 0 and p = ref 0 and pe = ref (String.length data) and eof = ref (String.length data) in 66 | let n = ref 0 and f = ref 0. and fna = ref 0 and fn = ref 0 in 67 | let t = ref 0 in 68 | %%write init; 69 | %%write exec; 70 | if !cs >= compact_duration_first_final then float !t +. !f else raise (Parse_compact_duration data); 71 | -------------------------------------------------------------------------------- /prelude.mli: -------------------------------------------------------------------------------- 1 | (** Useful shortcuts *) 2 | 3 | module U = ExtUnix.Specific 4 | module Enum = ExtEnum 5 | 6 | (** function composition : [f $ g] is equivalent to [(fun x -> f (g x))] *) 7 | val ( $ ) : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b 8 | 9 | (** 2-function composition : [f $$ g] is equivalent to [(fun x y -> f (g x) (g y))] *) 10 | val ( $$ ) : ('a -> 'a -> 'b) -> ('c -> 'a) -> 'c -> 'c -> 'b 11 | 12 | (** 1-argument function composition combinators that allow quickly switching to or from point-free chained function pipeline 13 | e.g. [let inc s = string_of_int @@ (+) 1 @@ int_of_string s] vs [let inc = F1.(string_of_int @@ (+) 1 @@ int_of_string)] 14 | and similarly [let inc = F1.(int_of_string |> (+) 1 |> string_of_int)] 15 | *) 16 | module F1 : sig 17 | val ( @@ ) : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b 18 | val ( |> ) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c 19 | end 20 | 21 | (** identity *) 22 | val id : 'a -> 'a 23 | 24 | (** idem *) 25 | val identity : 'a -> 'a 26 | 27 | (** reverse arguments, [flip f x y] is equivalent to [f y x] *) 28 | val flip : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c 29 | 30 | (** map over 2-tuple *) 31 | val apply2 : ('a -> 'b) -> 'a * 'a -> 'b * 'b 32 | 33 | (** [some x] is equivalent to [Some x] *) 34 | val some : 'a -> 'a option 35 | 36 | (** @return function returning given value *) 37 | val const : 'a -> (unit -> 'a) 38 | 39 | (** @return curried version from function of tuple *) 40 | val curry : ('a * 'b -> 'c) -> ('a -> 'b -> 'c) 41 | 42 | (** @return function of tuple from curried function *) 43 | val uncurry : ('a -> 'b -> 'c) -> ('a * 'b -> 'c) 44 | 45 | (** [Lazy.force] *) 46 | val ( !! ) : 'a Lazy.t -> 'a 47 | 48 | (** printf to stdout with newline *) 49 | val printfn : ('a, unit, string, unit) format4 -> 'a 50 | 51 | (** printf to stderr with newline *) 52 | val eprintfn : ('a, unit, string, unit) format4 -> 'a 53 | 54 | (** abstract type generator *) 55 | module Fresh(T : sig type t val compare : t -> t -> int end)() : 56 | sig 57 | type t 58 | val inject : T.t -> t 59 | val project : t -> T.t 60 | val inject_list : T.t list -> t list 61 | val project_list : t list -> T.t list 62 | val compare : t -> t -> int 63 | val equal : t -> t -> bool 64 | val map : (T.t -> T.t) -> t -> t 65 | val map2 : (T.t -> T.t -> T.t) -> t -> t -> t 66 | end 67 | 68 | val tuck : 'a list ref -> 'a -> unit 69 | val cons : 'a list -> 'a -> 'a list 70 | 71 | val ( += ) : int ref -> int -> unit 72 | val ( -= ) : int ref -> int -> unit 73 | 74 | val round : float -> float 75 | 76 | (** [atoi name value] 77 | @return integer of string [value] 78 | @raise Failure if [value] is not an integer (with [name] and [value] in exception message) 79 | *) 80 | val atoi : string -> string -> int 81 | 82 | val call_me_maybe : ('a -> unit) option -> 'a -> unit 83 | -------------------------------------------------------------------------------- /bit_struct_list.ml: -------------------------------------------------------------------------------- 1 | open ExtLib 2 | 3 | module type S = sig 4 | val item_bits : int 5 | val pp : int -> string 6 | end 7 | 8 | module Make(S: S) = struct 9 | type t = string 10 | (* the first rem_bits_width bits store the number of remaining unoccupied bits in the last byte *) 11 | let rem_bits_width = 3 (* 3 for 8-bit chars *) 12 | let byte_bits = 1 lsl rem_bits_width 13 | let rem_bits_mask = (1 lsl rem_bits_width) - 1 14 | let item_mask = (1 lsl S.item_bits) - 1 15 | let byte_mask = (1 lsl byte_bits) - 1 16 | 17 | let get_remaining_bits s = Char.code s.[0] land rem_bits_mask 18 | 19 | let iterwhile f s = 20 | let rec iterwhile' f remainder sb rb i last_i s = (* remainder from the previous byte; starting bit; remaining unoccupied bits; current index in the string; last index *) 21 | match i, sb + S.item_bits, sb with 22 | | i, sb', _ when i = last_i && sb' > byte_bits - rb -> true 23 | | _, sb', sb when sb < 0 -> if f @@ ((Char.code s.[i] lsl -sb) lor remainder) land item_mask then iterwhile' f 0 sb' rb i last_i s else false 24 | | _, sb', _ when sb' <= byte_bits -> if f @@ (Char.code s.[i] lsr sb) land item_mask then iterwhile' f 0 sb' rb i last_i s else false 25 | | _ (* sb' > byte_bits *) -> iterwhile' f (Char.code s.[i] lsr sb) (sb - byte_bits) rb (i + 1) last_i s 26 | in 27 | iterwhile' f 0 rem_bits_width (get_remaining_bits s) 0 (String.length s - 1) s 28 | 29 | let iter f s = ignore @@ iterwhile (fun x -> f x; true) s 30 | let exists f s = iterwhile (fun x -> not @@ f x) s 31 | let fold_left f a s = let a = ref a in iter (fun x -> a := f !a x) s; !a 32 | 33 | let to_list v = List.rev @@ fold_left (fun l x -> x::l) [] v 34 | let of_list l = 35 | let s_bits = rem_bits_width + (List.length l) * S.item_bits in 36 | let s_len = (s_bits + byte_bits - 1) / byte_bits in 37 | let rb = byte_bits - (s_bits - 1) mod byte_bits - 1 in 38 | let s = Bytes.make s_len '\x00' in 39 | Bytes.set s 0 (Char.chr rb); 40 | ignore @@ List.fold_left begin fun (i,rb) x -> 41 | assert (x land lnot item_mask = 0); 42 | match rb - S.item_bits with 43 | | rb' when rb' >= 0 -> 44 | Bytes.set s i (Char.chr @@ Char.code (Bytes.get s i) lor (x lsl (byte_bits - rb))); 45 | (i,rb') 46 | | rb' -> 47 | let w = x lsl (byte_bits - rb) in 48 | Bytes.set s (i+1) (Char.chr @@ w lsr byte_bits); 49 | Bytes.set s i (Char.chr @@ Char.code (Bytes.get s i) lor (w land byte_mask)); 50 | (i + 1, rb' + byte_bits) 51 | end (0, byte_bits - rem_bits_width) l; 52 | Bytes.unsafe_to_string s 53 | 54 | let project = Prelude.id 55 | let inject = function 56 | | "" -> Log.main #warn "Bit_struct_list.inject error: empty bit string"; of_list [] 57 | | s -> s 58 | 59 | let pp v = "[" ^ (String.concat "; " @@ List.map (fun x -> "\"" ^ (S.pp x) ^ "\"") @@ to_list v) ^ "]" 60 | end 61 | -------------------------------------------------------------------------------- /extEnum.mli: -------------------------------------------------------------------------------- 1 | (** Extensions to Enum *) 2 | 3 | include module type of Enum with type 'a t = 'a Enum.t 4 | 5 | (** same as {!Enum.find}, but found element is peeked, not junked *) 6 | val find_peek : ('a -> bool) -> 'a t -> 'a 7 | 8 | (** @return enum that indefinitely runs over given (non-empty) list *) 9 | val list_loop : 'a list -> 'a t 10 | 11 | (** @return enum over [DynArray] slice (default: whole array) *) 12 | val of_dynarray : ?start:int -> ?n:int -> 'a DynArray.t -> 'a Enum.t 13 | 14 | (** [take n e] @return enum consuming first [n] elements of [e] *) 15 | val take : int -> 'a t -> 'a t 16 | 17 | (** merge two enums of same type *) 18 | val align : ('a -> 'a -> int) -> 'a t -> 'a t -> 'a t 19 | 20 | (** @param multi repeat input value from the left enum multiple times to output as many pairs as there are matching equal consecutive values in the right enum *) 21 | val join : ?left:bool -> ?right:bool -> ?multi:bool -> ('a -> 'b -> int) -> 'a t -> 'b t -> ('a option * 'b option) t 22 | val join_assoc : ?left:bool -> ?right:bool -> ?multi:bool -> ('a -> 'a -> int) -> ('a * 'b) t -> ('a * 'c) t -> ('a * 'b option * 'c option) t 23 | 24 | include module type of ExtEnum_merge 25 | 26 | (** merge two enums of different types *) 27 | val merge : ('a -> 'b -> int) -> 'a t -> 'b t -> ('a option * 'b option) t 28 | 29 | (** merge two enums over key-value pairs *) 30 | val merge_assoc : ('a -> 'a -> int) -> ('a * 'b) t -> ('a * 'c) t -> ('a * 'b option * 'c option) t 31 | 32 | (** [group equal fold zero e] 33 | accumulates elements of [e] with [fold], first element is [fold]ed with [zero], 34 | at each subsequent step [equal] is checked, and new accumulator is started once it returns [false] 35 | *) 36 | val group : ('acc -> 'a -> bool) -> ('acc -> 'a -> 'acc) -> 'acc -> 'a t -> 'acc t 37 | 38 | (** [group_assoc equal fold zero e] 39 | accumulates (with [fold]) values in [e] with matching key as determined by comparison function [equal], 40 | first value is [fold]ed with [zero], e.g.: 41 | 42 | [List.of_enum @@ Enum.group_assoc (=) (+) 0 @@ List.enum \["a",1; "a",2; "b",3; "b",4; "a", 1; "a", 10\] = \["a", 3; "b", 7; "a", 11; \] ] 43 | *) 44 | val group_assoc : ('a -> 'a -> bool) -> ('b -> 'c -> 'b) -> 'b -> ('a * 'c) t -> ('a * 'b) t 45 | 46 | (** [uniq f e] replaces every consecuitive sequence of elements from [e] comparing equal 47 | by the given comparison function [f] with the first element from that sequence *) 48 | val uniq : ('a -> 'a -> bool) -> 'a t -> 'a t 49 | 50 | (** [count_unique f e] replaces every consecutive sequence of elements from [e] comparing equal 51 | by the given comparison function [f] with the first element from that sequence and the number of duplicates *) 52 | val count_unique : ('a -> 'a -> bool) -> 'a t -> ('a * int) t 53 | 54 | (** [sub e f] extracts a subenum (consecutive sequence of the elements from [e]) that map to the same value of [f] *) 55 | val sub : ?eq:('b -> 'b -> bool) -> 'a t -> ('a -> 'b) -> ('b * 'a t) option 56 | 57 | (** [iter_while f e] calls [f] for each element of [e] until it returns [false] or [e] is exhausted *) 58 | val iter_while : ('a -> bool) -> 'a t -> unit 59 | -------------------------------------------------------------------------------- /parallel.mli: -------------------------------------------------------------------------------- 1 | (** Parallel *) 2 | 3 | type revive_mode = 4 | | Never (** never revive worker *) 5 | | On_failure (** revive when worker exits with non-zero code *) 6 | | Always (** revive worker regardless of exit code *) 7 | 8 | (** Invoke function in a forked process and return result *) 9 | val invoke : ('a -> 'b) -> 'a -> unit -> 'b 10 | 11 | (** Launch function for each element of the list in the forked process. 12 | Does not wait for children to finish - returns immediately. *) 13 | val launch_forks : ('a -> unit) -> 'a list -> unit 14 | 15 | (** Launch forks for each element of the list and wait for all workers to finish. 16 | Pass exit signals to the workers, see {!Forks.stop} for the description of [wait_stop] parameter. 17 | @param revive to keep workers running (restarting with same param if exited) [default: Never] 18 | *) 19 | val run_forks : ?wait_stop:int -> ?revive:revive_mode -> ?wait:int -> ?workers:int -> ('a -> unit) -> 'a list -> unit 20 | 21 | (** Same as [run_forks] but do not fork for one worker *) 22 | val run_forks' : ('a -> unit) -> 'a list -> unit 23 | 24 | (** Process list with specified number of workers. 25 | Pass exit signals to the workers, see {!Forks.stop} for the description of [wait_stop] parameter. 26 | *) 27 | val run_workers : int -> ?wait_stop:int -> ('a -> unit) -> 'a list -> unit 28 | 29 | (** Process enum with specified number of workers, collect results via provided callback. 30 | Pass exit signals to the workers, see {!Forks.stop} for the description of [wait_stop] parameter. 31 | *) 32 | val run_workers_enum : int -> ?wait_stop:int -> ('a -> 'b) -> ('b -> unit) -> 'a Enum.t -> unit 33 | 34 | module type WorkerT = sig 35 | type task 36 | type result 37 | end 38 | 39 | module type Workers = sig 40 | 41 | type task 42 | type result 43 | type t 44 | 45 | (** [create f n] starts [n] parallel workers waiting for tasks *) 46 | val create : (task -> result) -> int -> t 47 | 48 | (** [perform workers tasks f] distributes [tasks] to all [workers] in parallel, 49 | collecting results with [f] and returns when all [tasks] are finished *) 50 | val perform : t -> ?autoexit:bool -> task Enum.t -> (result -> unit) -> unit 51 | 52 | (** [stop ?wait workers] kills worker processes with SIGTERM 53 | is [wait] is specified it will wait for at most [wait] seconds before killing with SIGKILL, 54 | otherwise it will wait indefinitely 55 | @param autoexit determines whether workers will exit once there are no more tasks, it means [perform] shouldn't be called again 56 | for this instance 57 | *) 58 | val stop : ?wait:int -> t -> unit 59 | 60 | end (* Workers *) 61 | 62 | (* 63 | val create : ('a -> 'b) -> int -> ('a,'b) t 64 | val perform : ('a,'b) t -> 'a Enum.t -> ('b -> unit) -> unit 65 | *) 66 | 67 | (** Forked workers *) 68 | module Forks(T:WorkerT) : Workers 69 | with type task = T.task 70 | and type result = T.result 71 | 72 | module Services : sig 73 | type t 74 | 75 | val start : int -> (int -> unit Lwt.t) -> t Lwt.t 76 | 77 | val rolling_restart : ?wait:int -> timeout:float -> t -> unit Lwt.t 78 | 79 | val stop : timeout:float -> t -> unit Lwt.t 80 | end 81 | -------------------------------------------------------------------------------- /ocamlnet_lite/netbuffer.ml: -------------------------------------------------------------------------------- 1 | type t = { 2 | mutable buffer : Bytes.t; 3 | mutable buffer_length : int; (* = String.length buffer *) 4 | mutable length : int; 5 | create_length : int; 6 | } 7 | 8 | (* To help the garbage collector: 9 | * The 'buffer' has a minimum length of 31 bytes. This minimum can still 10 | * be stored in the minor heap. 11 | * The 'buffer' has a length which is always near a multiple of two. This 12 | * limits the number of different bucket sizes, and simplifies reallocation 13 | * of freed memory. 14 | *) 15 | 16 | (* Optimal string length: 17 | * Every string takes: 1 word for the header, enough words for the 18 | * contents + 1 Null byte (for C compatibility). 19 | * If the buffer grows, it is best to use a new string length such 20 | * that the number of words is exactly twice as large as for the previous 21 | * string. 22 | * n: length of the previous string in bytes 23 | * w: storage size of the previous string in words 24 | * n': length of the new string in bytes 25 | * w' = 2*w: storage size of the new string in words 26 | * 27 | * w = (n+1) / word_length + 1 28 | * [it is assumed that (n+1) is always a multiple of word_length] 29 | * 30 | * n' = (2*w - 1) * word_length - 1 31 | * 32 | * n' = [2 * ( [n+1] / word_length + 1) - 1] * word_length - 1 33 | * = ... 34 | * = (2*n + 2) + word_length - 1 35 | * = 2 * n + word_length + 1 36 | * 37 | * n'+1 is again a multiple of word_length: 38 | * n'+1 = 2*n + 2 + word_length 39 | * = 2*(n+1) + word_length 40 | * = a multiple of word_length because n+1 is a multiple of word_length 41 | *) 42 | 43 | let word_length = Sys.word_size / 8 (* in bytes *) 44 | 45 | let create n = 46 | let bl = max n 31 in 47 | { 48 | buffer = Bytes.create bl; 49 | buffer_length = bl; 50 | length = 0; 51 | create_length = n; 52 | } 53 | 54 | let contents b = Bytes.sub_string b.buffer 0 b.length 55 | let to_bytes b = Bytes.sub b.buffer 0 b.length 56 | 57 | let to_tstring_poly : type s. t -> s Netstring_tstring.tstring_kind -> s = 58 | fun b kind -> 59 | match kind with 60 | | Netstring_tstring.String_kind -> contents b 61 | | Netstring_tstring.Bytes_kind -> to_bytes b 62 | 63 | let alloc_space b n = 64 | let rec new_size s = 65 | if s >= n then s else new_size ((2 * s) + word_length + 1) 66 | in 67 | let size = min (new_size b.buffer_length) Sys.max_string_length in 68 | if size < n then failwith "Netbuffer: string too large"; 69 | let buffer' = Bytes.create size in 70 | Bytes.blit b.buffer 0 buffer' 0 b.length; 71 | b.buffer <- buffer'; 72 | b.buffer_length <- size 73 | 74 | let ensure_space b n = 75 | (* Ensure that there are n bytes space in b *) 76 | if n > b.buffer_length then alloc_space b n 77 | 78 | let add_internal blit b s k l = 79 | ensure_space b (l + b.length); 80 | blit s k b.buffer b.length l; 81 | b.length <- b.length + l 82 | 83 | let add_substring b s k l = 84 | if k < 0 || l < 0 || k > String.length s - l then 85 | invalid_arg "Netbuffer.add_substring"; 86 | add_internal Bytes.blit_string b s k l 87 | 88 | let add_string b s = add_substring b s 0 (String.length s) 89 | -------------------------------------------------------------------------------- /lwt_mark.mli: -------------------------------------------------------------------------------- 1 | (** This module uses Lwt thread storage to give threads "marks", which store thread id (some unique int, autogenerated), 2 | name (given by user, see [name] and [ignore_result]), parent thread name, and few (currently 10, may be changed) last log messages 3 | that was output from this thread using [Log] module. 4 | 5 | Thread mark is removed when the thread terminates. 6 | 7 | [summary ()] is the way to inspect current marks. 8 | 9 | Marking must be initialized ([init ()]) to work with marks. When marking is not initialized, most of functions behave as no-op, 10 | this is implemented by checking [internal_flag : bool ref], so it's cheap. There is no way to disable marking. 11 | 12 | There are no "links from current thread mark to parent thread mark" ( = no "call stack"), as it may grow infinitely in a perfectly 13 | working code that uses constant memory otherwise. 14 | 15 | Most of strings (names, logs) are lazy (internally), as their evaluation is needed only when one inspects current threads state. 16 | Functions that take strings wrap them with [Lazy.from_val]. 17 | *) 18 | 19 | (** Enables thread marking. Use before calling other functions of this module. *) 20 | val init : unit -> unit 21 | 22 | val is_enabled : unit -> bool 23 | 24 | (** [name n cont] creates new lwt thread [cont ()] marked with name [n]. Usage: 25 | 26 | let myfunc () = 27 | Lwt_mark.name "myfunc" @@ fun () -> 28 | 29 | *) 30 | val name : string -> (unit -> 'a Lwt.t) -> 'a Lwt.t 31 | 32 | (** [status lazy_name ?dump cont] 33 | 34 | Usage: 35 | 36 | lwt was_read = 37 | Lwt_mark.status (lazy (sprintf "reading %i bytes" to_read)) ~dump:string_of_int @@ fun () -> 38 | Lwt_unix.read fd buf ofs to_read 39 | in 40 | 41 | Start/exit of thread [cont ()] will be logged to parent thread's last logs. 42 | 43 | [lazy_name] must be able to be evaluated into a meaningful thread name when it is forced, no matter when (before thread startup, during 44 | thread execution, after thread exit). 45 | 46 | Use [?dump] argument when you need to log return value of the thread. 47 | 48 | Internally [status] works like [name], but statuses are groupped and displayed by [summary] in the section of thread that created them. 49 | *) 50 | val status : string Lazy.t -> ?dump:('a -> string) -> (unit -> 'a Lwt.t) -> 'a Lwt.t 51 | val status_s : string -> ?dump:('a -> string) -> (unit -> 'a Lwt.t) -> 'a Lwt.t 52 | 53 | (** [async ?log name run_thread] works like [name] + [Lwt.async run_thread], but thread is marked as "background" (just for display 54 | purposes). Pass [~log] to log thread failure with devkit logger (level = warn). *) 55 | val async : ?log:Log.logger -> string -> (unit -> unit Lwt.t) -> unit 56 | 57 | (** Adds line to current thread's last logs. 58 | When marking is enabled, but current thread is not marked/named, line is added to special "" thread logs. *) 59 | val log : string -> unit 60 | val log_l : string Lazy.t -> unit 61 | val log_f : ('a, unit, string, unit) format4 -> 'a 62 | 63 | (** Human-readable marks summary: current running threads, their last logs and statuses. *) 64 | val summary : unit -> string 65 | -------------------------------------------------------------------------------- /ocamlnet_lite/netstring_tstring.mli: -------------------------------------------------------------------------------- 1 | (** Support module for tagged strings *) 2 | 3 | open Netsys_types 4 | 5 | (** GADT for encoding the string type (string/bytes/bigarray) *) 6 | type _ tstring_kind = 7 | | String_kind : string tstring_kind 8 | | Bytes_kind : Bytes.t tstring_kind 9 | 10 | type 't tstring_ops = { 11 | kind : 't tstring_kind option; 12 | length : 't -> int; 13 | get : 't -> int -> char; 14 | unsafe_get : 't -> int -> char; 15 | unsafe_get3 : 't -> int -> int; 16 | (** get 3 chars packed into one int 17 | (first char shifted by 16 bits, second char shifted by 8 bits, 18 | third char unshifted) *) 19 | copy : 't -> 't; 20 | string : 't -> string; (** if possible this function does not make a copy *) 21 | bytes : 't -> Bytes.t; (** if possible this function does not make a copy *) 22 | sub : 't -> int -> int -> 't; 23 | substring : 't -> int -> int -> string; 24 | subbytes : 't -> int -> int -> Bytes.t; 25 | subpoly : 'u. 'u tstring_kind -> 't -> int -> int -> 'u; 26 | blit_to_bytes : 't -> int -> Bytes.t -> int -> int -> unit; 27 | index_from : 't -> int -> char -> int; 28 | index_from3 : 't -> int -> int -> char -> char -> char -> int; 29 | (** finds any of three chars. The second int is the search radius *) 30 | rindex_from : 't -> int -> char -> int; 31 | rindex_from3 : 't -> int -> int -> char -> char -> char -> int; 32 | (** finds any of three chars. The second int is the search radius *) 33 | } 34 | (** Operations to call on strings *) 35 | 36 | (** GADT for hiding the type parameter *) 37 | type tstring_ops_box = 38 | | Tstring_ops_box : 't tstring_kind * 't tstring_ops -> tstring_ops_box 39 | 40 | (** GADT for hiding the type parameter *) 41 | type tstring_box = 42 | | Tstring_box : 't tstring_kind * 't tstring_ops * 't -> tstring_box 43 | 44 | (** GADT for hiding the type parameter. Warning: This GADT does not permit you 45 | to recover the kind of string 46 | *) 47 | type tstring_polybox = 48 | | Tstring_polybox : 't tstring_ops * 't -> tstring_polybox 49 | 50 | val string_ops : string tstring_ops 51 | (** Implementation of the operations for [string] *) 52 | 53 | val bytes_ops : Bytes.t tstring_ops 54 | (** Implementation of the operations for [bytes] *) 55 | 56 | val ops_of_tstring : tstring -> tstring_ops_box 57 | (** Create a [Tstring_ops_box] *) 58 | 59 | type 'a with_fun = { with_fun : 's. 's tstring_ops -> 's -> 'a } 60 | (** A polymorphic function for strings *) 61 | 62 | val with_tstring : 'a with_fun -> tstring -> 'a 63 | (** [with_tstring f ts]: Calls [f.with_fun] with the right implementation of 64 | the [tstring_ops] argument 65 | *) 66 | 67 | val length_tstring : tstring -> int 68 | (** Get the length of a tagged string *) 69 | 70 | val tstring_of_tbuffer : tbuffer -> tstring 71 | (** Get the tagged string of a tagged buffer *) 72 | 73 | val polymorph_string_transformation : 74 | (string -> string) -> 's tstring_ops -> 't tstring_kind -> 's -> 't 75 | (** [polymorph_string_transformation f ops kind s]: Converts [s] to a 76 | string, runs [f] on this string, and converts the result to the 77 | type demanded by [kind] 78 | *) 79 | 80 | (**/**) 81 | 82 | val bytes_subpoly : 'u tstring_kind -> Bytes.t -> int -> int -> 'u 83 | -------------------------------------------------------------------------------- /extEnum_merge.mli: -------------------------------------------------------------------------------- 1 | val join_inner_by : 2 | ('a -> 'b -> int) -> 3 | ('c -> 'a) -> ('d -> 'b) -> 'c Enum.t -> 'd Enum.t -> ('c * 'd) Enum.t 4 | val join_inner_by_key : 5 | ('a -> 'a -> int) -> 6 | ('b -> 'a) -> 'b Enum.t -> 'b Enum.t -> ('b * 'b) Enum.t 7 | val join_left_by : 8 | ('a -> 'b -> int) -> 9 | ('c -> 'a) -> 10 | ('d -> 'b) -> 'c Enum.t -> 'd Enum.t -> ('c * 'd option) Enum.t 11 | val join_left_by_key : 12 | ('a -> 'a -> int) -> 13 | ('b -> 'a) -> 'b Enum.t -> 'b Enum.t -> ('b * 'b option) Enum.t 14 | val join_right_by : 15 | ('a -> 'b -> int) -> 16 | ('c -> 'a) -> 17 | ('d -> 'b) -> 'c Enum.t -> 'd Enum.t -> ('c option * 'd) Enum.t 18 | val join_right_by_key : 19 | ('a -> 'a -> int) -> 20 | ('b -> 'a) -> 'b Enum.t -> 'b Enum.t -> ('b option * 'b) Enum.t 21 | val join_full_by : 22 | ('a -> 'b -> int) -> 23 | ('c -> 'a) -> 24 | ('d -> 'b) -> 25 | 'c Enum.t -> 26 | 'd Enum.t -> [> `Both of 'c * 'd | `Left of 'c | `Right of 'd ] Enum.t 27 | val join_full_by_key : 28 | ('a -> 'a -> int) -> 29 | ('b -> 'a) -> 30 | 'b Enum.t -> 31 | 'b Enum.t -> [> `Both of 'b * 'b | `Left of 'b | `Right of 'b ] Enum.t 32 | val join_inner_multi_by : 33 | ('a -> 'b -> int) -> 34 | ('c -> 'a) -> ('d -> 'b) -> 'c Enum.t -> 'd Enum.t -> ('c * 'd) Enum.t 35 | val join_inner_multi_by_key : 36 | ('a -> 'a -> int) -> 37 | ('b -> 'a) -> 'b Enum.t -> 'b Enum.t -> ('b * 'b) Enum.t 38 | val join_left_multi_by : 39 | ('a -> 'b -> int) -> 40 | ('c -> 'a) -> 41 | ('d -> 'b) -> 'c Enum.t -> 'd Enum.t -> ('c * 'd option) Enum.t 42 | val join_left_multi_by_key : 43 | ('a -> 'a -> int) -> 44 | ('b -> 'a) -> 'b Enum.t -> 'b Enum.t -> ('b * 'b option) Enum.t 45 | val join_right_multi_by : 46 | ('a -> 'b -> int) -> 47 | ('c -> 'a) -> 48 | ('d -> 'b) -> 'c Enum.t -> 'd Enum.t -> ('c option * 'd) Enum.t 49 | val join_right_multi_by_key : 50 | ('a -> 'a -> int) -> 51 | ('b -> 'a) -> 'b Enum.t -> 'b Enum.t -> ('b option * 'b) Enum.t 52 | val join_full_multi_by : 53 | ('a -> 'b -> int) -> 54 | ('c -> 'a) -> 55 | ('d -> 'b) -> 56 | 'c Enum.t -> 57 | 'd Enum.t -> [> `Both of 'c * 'd | `Left of 'c | `Right of 'd ] Enum.t 58 | val join_full_multi_by_key : 59 | ('a -> 'a -> int) -> 60 | ('b -> 'a) -> 61 | 'b Enum.t -> 62 | 'b Enum.t -> [> `Both of 'b * 'b | `Left of 'b | `Right of 'b ] Enum.t 63 | val join_assoc_inner : 64 | ('a -> 'b -> int) -> 65 | ('a * 'c) Enum.t -> ('b * 'd) Enum.t -> ('a * 'c * 'd) Enum.t 66 | val join_assoc_left : 67 | ('a -> 'b -> int) -> 68 | ('a * 'c) Enum.t -> ('b * 'd) Enum.t -> ('a * 'c * 'd option) Enum.t 69 | val join_assoc_right : 70 | ('a -> 'a -> int) -> 71 | ('a * 'b) Enum.t -> ('a * 'c) Enum.t -> ('a * 'b option * 'c) Enum.t 72 | val join_assoc_full : 73 | ('a -> 'a -> int) -> 74 | ('a * 'b) Enum.t -> 75 | ('a * 'c) Enum.t -> 76 | ('a * [> `Both of 'b * 'c | `Left of 'b | `Right of 'c ]) Enum.t 77 | val join_assoc_inner_multi : 78 | ('a -> 'b -> int) -> 79 | ('a * 'c) Enum.t -> ('b * 'd) Enum.t -> ('a * 'c * 'd) Enum.t 80 | val join_assoc_left_multi : 81 | ('a -> 'b -> int) -> 82 | ('a * 'c) Enum.t -> ('b * 'd) Enum.t -> ('a * 'c * 'd option) Enum.t 83 | val join_assoc_right_multi : 84 | ('a -> 'a -> int) -> 85 | ('a * 'b) Enum.t -> ('a * 'c) Enum.t -> ('a * 'b option * 'c) Enum.t 86 | val join_assoc_full_multi : 87 | ('a -> 'a -> int) -> 88 | ('a * 'b) Enum.t -> 89 | ('a * 'c) Enum.t -> 90 | ('a * [> `Both of 'b * 'c | `Left of 'b | `Right of 'c ]) Enum.t 91 | val merge : 92 | ('a -> 'b -> int) -> 93 | 'a Enum.t -> 'b Enum.t -> ('a option * 'b option) Enum.t 94 | val merge_assoc : 95 | ('a -> 'a -> int) -> 96 | ('a * 'b) Enum.t -> ('a * 'c) Enum.t -> ('a * 'b option * 'c option) Enum.t 97 | -------------------------------------------------------------------------------- /extArg.ml: -------------------------------------------------------------------------------- 1 | 2 | open Printf 3 | 4 | open Prelude 5 | 6 | include Arg 7 | 8 | let describe t name = function 9 | | "" -> sprintf "<%s> %s" t name 10 | | s when s.[0] = ' ' -> sprintf "<%s>%s" t s 11 | | s -> s 12 | 13 | let make_arg x = 14 | fun name var desc -> 15 | "-"^name, 16 | x#store var, 17 | sprintf "%s (default: %s)" (describe x#kind name desc) (x#show var) 18 | 19 | let test_int f = object 20 | method store v = Arg.Int (fun x -> if not (f x) then Exn.fail "Bad value %d" x; v := x) 21 | method kind = "int" 22 | method show v = string_of_int !v 23 | end 24 | 25 | let int = object 26 | method store v = Arg.Set_int v 27 | method kind = "int" 28 | method show v = string_of_int !v 29 | end 30 | 31 | let float = object 32 | method store v = Arg.Set_float v 33 | method kind = "float" 34 | method show v = string_of_float !v 35 | end 36 | 37 | let string = object 38 | method store v = Arg.Set_string v 39 | method kind = "string" 40 | method show v = !v 41 | end 42 | 43 | let duration = object 44 | method store v = Arg.String (fun s -> v := Time.of_compact_duration s) 45 | method kind = "duration" 46 | method show v = Time.compact_duration !v 47 | end 48 | 49 | let int_option = object 50 | method store v = Arg.Int (fun x -> v := Some x) 51 | method kind = "int" 52 | method show v = Option.map_default string_of_int "none" !v 53 | end 54 | 55 | let float_option = object 56 | method store v = Arg.Float (fun x -> v := Some x) 57 | method kind = "float" 58 | method show v = Option.map_default string_of_float "none" !v 59 | end 60 | 61 | let str_option = object 62 | method store v = Arg.String (fun x -> v := Some x) 63 | method kind = "string" 64 | method show v = Option.map_default id "none" !v 65 | end 66 | 67 | let int = make_arg int 68 | let float = make_arg float 69 | let str = make_arg string 70 | let duration = make_arg duration 71 | let may_int = make_arg int_option 72 | let may_float = make_arg float_option 73 | let may_str = make_arg str_option 74 | let positive_int = make_arg (test_int (fun x -> x > 0)) 75 | 76 | let bool name var desc = 77 | "-"^name, 78 | Arg.Set var, 79 | (if desc = "" then sprintf " enable %s" name else if desc.[0] <> ' ' then " " ^ desc else desc) 80 | 81 | let usage_header = "Available options are:" 82 | 83 | let align ?(sep="#") args = 84 | let open ExtString in 85 | let convert ~sub ~by (a, b, doc) = 86 | let (doc:doc) = 87 | try 88 | if doc = "" || doc.[0] = ' ' then doc else 89 | let (left, right) = String.split doc by in 90 | (Stre.replace_all ~str:left ~sub ~by) ^ " " ^ right 91 | with Invalid_string -> doc 92 | in 93 | (a, b, doc) 94 | in 95 | args |> 96 | List.map (convert ~sub:" " ~by:sep) |> 97 | align |> 98 | List.map (convert ~sub:sep ~by:" ") 99 | 100 | let parse ?f args = 101 | let f = Option.default (fun s -> Exn.fail "unrecognized argument %S, try \"-help\"" s) f in 102 | parse (align args) f usage_header 103 | 104 | let usage args = Arg.usage (align args) usage_header 105 | 106 | (* 107 | "-"^name, 108 | Arg.Set_int var, 109 | sprintf "%s (default: %i)" (describe "int" name desc) !var 110 | *) 111 | 112 | (* 113 | let arg_str name ?desc var = 114 | "-"^name, 115 | Arg.Set_string var, 116 | sprintf "%s (default: %s)" (describe "string" name desc) !var 117 | *) 118 | 119 | let two_strings k = 120 | (let old = ref "" in 121 | Arg.Tuple [ 122 | Arg.String (fun x -> old := x); 123 | Arg.String (fun s -> k !old s) 124 | ]) 125 | 126 | let rest () = 127 | let n = Array.length Sys.argv in 128 | if !Arg.current >= n then 129 | [] 130 | else 131 | Array.to_list @@ Array.sub Sys.argv (!Arg.current+1) (Array.length Sys.argv - !Arg.current - 1) 132 | -------------------------------------------------------------------------------- /signal.ml: -------------------------------------------------------------------------------- 1 | (** Signal handling *) 2 | 3 | open ExtLib 4 | module U = ExtUnix.All 5 | module Ev = Async.Ev 6 | 7 | let log = Log.from "signal" 8 | 9 | (** {2 libevent + signalfd} *) 10 | 11 | type t = { ev : Ev.event; fd : Unix.file_descr; h : (int, (int -> unit)) Hashtbl.t; mutable active : bool; } 12 | 13 | let init events = 14 | let fd = U.signalfd ~sigs:[] ~flags:[] () in 15 | Unix.set_nonblock fd; 16 | let t = { ev = Ev.create (); fd = fd; h = Hashtbl.create 1; active = true; } in 17 | Ev.set events t.ev t.fd ~persist:true [Ev.READ] (fun _ _ -> 18 | try (* references to t keep it alive with ev *) 19 | let ssi = U.signalfd_read t.fd in 20 | let signo = U.ssi_signo_sys ssi in 21 | match Hashtbl.find_option t.h signo with 22 | | None -> Exn.fail "no handler for %d" signo 23 | | Some f -> f signo 24 | with exn -> log #warn ~exn "signal handler" 25 | ); 26 | Ev.add t.ev None; 27 | t 28 | 29 | let stop t = 30 | match t.active with 31 | | false -> () 32 | | true -> 33 | Ev.del t.ev; 34 | Hashtbl.clear t.h; 35 | Unix.close t.fd; 36 | t.active <- false 37 | 38 | let handle t sigs f = 39 | List.iter (fun signo -> Hashtbl.replace t.h signo f) sigs; 40 | let sigs = List.of_enum (Hashtbl.keys t.h) in 41 | let (_:int list) = Unix.sigprocmask Unix.SIG_BLOCK sigs in 42 | let _ = U.signalfd ~fd:t.fd ~sigs ~flags:[] () in 43 | () 44 | 45 | (** {2 Lwt} *) 46 | 47 | let h_lwt = Hashtbl.create 10 48 | 49 | let lwt_handle sigs f = 50 | sigs |> List.iter begin fun signo -> 51 | Option.may Lwt_unix.disable_signal_handler @@ Hashtbl.find_option h_lwt signo; 52 | let sig_id = Lwt_unix.on_signal signo (fun (_:int) -> f ()) in 53 | Hashtbl.replace h_lwt signo sig_id 54 | end 55 | 56 | (** {2 generic registration} *) 57 | 58 | let install_sys signo f = Sys.set_signal signo (Sys.Signal_handle f) 59 | let install_libevent t signo f = handle t [signo] f 60 | let install_lwt signo f = lwt_handle [signo] (fun () -> f signo) 61 | 62 | let h = Hashtbl.create 10 63 | let verbose = ref false 64 | let do_install = ref install_sys 65 | let is_safe_output () = !verbose 66 | 67 | let set sigs f = 68 | sigs |> List.iter begin fun signo -> 69 | let f = 70 | match Hashtbl.find_option h signo with 71 | | None -> f 72 | | Some g -> (fun n -> g n; f n) 73 | in 74 | Hashtbl.replace h signo f; !do_install signo f 75 | end 76 | 77 | let set1 signal f = set [signal] (fun _ -> f ()) 78 | 79 | type state = (int, int -> unit) Hashtbl.t 80 | let save () = Hashtbl.copy h 81 | let restore x = 82 | Hashtbl.clear h; 83 | Hashtbl.iter (Hashtbl.add h) x 84 | 85 | let replace sigs f = 86 | sigs |> List.iter (fun signo -> Hashtbl.replace h signo f; !do_install signo f) 87 | 88 | let reinstall () = Hashtbl.iter !do_install h 89 | 90 | let wrap name f = 91 | begin fun n -> 92 | if !verbose then log #info "Received signal %i (%s)..." n name; 93 | (try f () with exn -> if !verbose then log #warn ~exn "Signal handler failed"); 94 | if !verbose then log #info "Signal handler done."; 95 | end 96 | 97 | let set_verbose sigs name f = set sigs (wrap name f) 98 | let set_exit = set_verbose [Sys.sigterm; Sys.sigint] "exit" 99 | let set_reload = set_verbose [Sys.sighup] "reload" 100 | 101 | let setup_sys () = 102 | verbose := false; (* potential deadlock *) 103 | do_install := install_sys; 104 | reinstall () 105 | 106 | let setup_libevent' t = 107 | verbose := true; 108 | do_install := (install_libevent t); 109 | reinstall () 110 | 111 | let setup_libevent = setup_libevent' 112 | let setup_libevent_ events = setup_libevent' @@ init events 113 | 114 | let setup_lwt () = 115 | verbose := true; 116 | do_install := install_lwt; 117 | reinstall () 118 | -------------------------------------------------------------------------------- /digest_auth.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Prelude 3 | open Httpev_common 4 | 5 | type t = { mutable stamp : Time.t; mutable index : int; realm : string; user : string; password : string; } 6 | 7 | type digest_request = { 8 | name:string; 9 | crealm:string; 10 | nonce:string; 11 | uri:string; 12 | qop:[`Auth | `Authi | `Unknown]; 13 | nc:string; 14 | cnonce:string; 15 | response:string; 16 | opaque:string; 17 | } 18 | 19 | module Parse = struct (* awful *) 20 | 21 | let appendlst lst elem = 22 | lst := List.append !lst [elem] 23 | 24 | let appendstr str elem = 25 | str := ((!str) ^ elem) 26 | 27 | let lowparse elem curstr curlist = 28 | if elem = ',' then begin 29 | if (String.length !curstr) > 0 then begin 30 | appendlst curlist !curstr ; end; 31 | curstr:=""; 32 | end else if (elem <> ' ')&&(elem <> '"')&&(elem<>'\n')&&(elem<>'\r') then appendstr curstr (Char.escaped elem) 33 | 34 | let make_tuple a b = (a,b) 35 | 36 | let highparse str curlist = 37 | let first_equal = try String.index str '='with Not_found -> Exn.fail "symbol = not found in %s" str in 38 | appendlst curlist (make_tuple (String.sub str 0 first_equal) (String.sub str (first_equal+1) (String.length(str)-1-first_equal))) 39 | 40 | let digest_request_from_string s = 41 | if String.length s < 6 then Exn.fail "Digest string too short"; 42 | let s1 = String.sub s 0 6 in 43 | if String.lowercase_ascii s1 <> "digest" then Exn.fail "Authorization fail - non-digest trying to connect"; 44 | let str = String.sub s 6 ((String.length s) - 6) in 45 | let tmpstr = ref "" in 46 | let a = str^"," in 47 | let tmplist = ref [] in 48 | String.iter (fun a -> lowparse a tmpstr tmplist) a; 49 | let resultlist = ref [] in 50 | List.iter (fun a -> highparse a resultlist) !tmplist; 51 | let get k = try List.assoc k !resultlist with Not_found -> "" in 52 | { 53 | name = get "username"; 54 | crealm = get "realm"; 55 | nonce = get "nonce"; 56 | uri = get "uri"; 57 | qop = (match get "qop" with "auth" -> `Auth | "auth-int" -> `Authi | _ -> `Unknown); 58 | nc = get "nc"; 59 | cnonce = get "cnonce"; 60 | response = get "response"; 61 | opaque = get "opaque"; 62 | } 63 | 64 | let _string_from_digest_request p = 65 | let s = "Digest username=\""^p.name^"\", realm=\""^p.crealm^"\", nonce=\""^p.nonce^"\", uri=\""^p.uri^"\", qop=" in 66 | let a = match p.qop with 67 | | `Auth -> s^"auth" 68 | | `Authi -> s^"auth-int" 69 | | `Unknown -> s^"unknown" in 70 | let a2 = a^", nc="^p.nc^", cnonce=\""^p.cnonce^"\", response=\""^p.response^"\", opaque=\""^p.opaque^"\"" in 71 | a2 72 | 73 | end (* Parse *) 74 | 75 | let md5_hex_string = Digest.(to_hex $ string) 76 | let hash l = md5_hex_string @@ String.concat ":" l 77 | 78 | let digest_opaque = md5_hex_string @@ Action.random_bytes 64 79 | 80 | let init ~realm ~user ~password () = { realm; user; password; stamp = Time.now (); index = 1; } 81 | 82 | let check t req = 83 | if Time.now () -. t.stamp > 300. then 84 | begin 85 | t.stamp <- Time.now (); 86 | t.index <- t.index + 1; 87 | end; 88 | let nonce = hash [Unix.string_of_inet_addr @@ client_ip req; string_of_float t.stamp; string_of_int t.index] in 89 | try 90 | let dig = List.assoc "authorization" req.headers |> Parse.digest_request_from_string in 91 | match dig.nonce = nonce with 92 | | false -> raise Not_found 93 | | true -> (* Nonce is ok, checking another params *) 94 | let ha1 = hash [t.user; t.realm; t.password] in 95 | let ha2 = hash [show_method req.meth; dig.uri] in 96 | let response = 97 | match dig.qop with 98 | | `Authi |`Auth -> hash [ha1; dig.nonce; dig.nc; dig.cnonce; "auth"; ha2] 99 | | `Unknown -> hash [ha1; dig.nonce; ha2] 100 | in 101 | if dig.opaque <> digest_opaque || dig.response <> response then raise Not_found; 102 | `Ok 103 | with 104 | | _ -> 105 | let v = sprintf "Digest realm=\"%s\", qop=\"auth\", nonce=\"%s\", opaque=\"%s\"" t.realm nonce digest_opaque in 106 | `Unauthorized ("WWW-Authenticate", v) 107 | -------------------------------------------------------------------------------- /htmlStream_ragel.ml.rl: -------------------------------------------------------------------------------- 1 | [@@@ocaml.warning "-38-32"] 2 | 3 | module Raw = struct 4 | include Prelude.Fresh(String)() 5 | let length x = String.length @@ project x 6 | let is_empty x = "" = project x 7 | end 8 | 9 | type elem = 10 | | Tag of (string * (string * Raw.t) list) 11 | | Script of ((string * Raw.t) list * string) (* attributes and contents. TODO investigate script contents encoding *) 12 | | Style of ((string * Raw.t) list * string) 13 | | Text of Raw.t 14 | | Close of string 15 | 16 | type ctx = { mutable lnum : int } 17 | 18 | let get_lnum ctx = ctx.lnum 19 | 20 | let init () = { lnum = 1 } 21 | 22 | %%{ 23 | machine htmlstream; 24 | 25 | action mark { mark := !p } 26 | action mark_end { mark_end := !p } 27 | action tag { tag := String.lowercase_ascii @@ sub (); attrs := []; } 28 | action close_tag { call @@ Close (String.lowercase_ascii @@ sub ()) } 29 | action directive { directive := String.lowercase_ascii @@ sub (); attrs := []; } 30 | action text { call @@ Text (Raw.inject @@ sub ()) } 31 | action key { key := String.lowercase_ascii @@ sub () } 32 | action store_attr { attrs := (!key, Raw.inject (if !mark < 0 then "" else sub())) :: !attrs } 33 | action tag_done { 34 | match !tag with 35 | | "script" -> fhold; fgoto in_script; 36 | | "style" -> fhold; fgoto in_style; 37 | | "title" -> fhold; fgoto in_title; 38 | | "" -> () 39 | | _ -> call @@ Tag (!tag, List.rev !attrs) 40 | } 41 | action tag_done_2 { call @@ Tag (!tag, List.rev !attrs); if !tag <> "a" then call (Close !tag) } 42 | action directive_done { (* printfn "directive %s" !directive; *) } 43 | 44 | action garbage_tag { (*printfn "GARBAGE %S" (current ()); *) fhold; fgoto garbage_tag;} 45 | 46 | count_newlines = ('\n' >{ ctx.lnum <- ctx.lnum + 1 } | ^'\n'+)**; 47 | 48 | wsp = 0..32; 49 | ident = alnum | '-' | [_:.] ; 50 | 51 | in_script := (count_newlines | any* >mark %mark_end :>> ('<' wsp* '/' wsp* 'script'i wsp* '>' >{call @@ Script (List.rev !attrs, sub ())} @{fgoto main;})); 52 | in_style := (count_newlines | any* >mark %mark_end :>> ('<' wsp* '/' wsp* 'style'i wsp* '>' >{call @@ Style (List.rev !attrs, sub ())} @{fgoto main;})); 53 | in_title := (count_newlines | any* >mark %mark_end :>> ('<' wsp* '/' wsp* 'title'i wsp* '>' >{ 54 | call @@ Tag ("title", List.rev !attrs); 55 | call @@ Text (Raw.inject (sub ())); 56 | call @@ Close ("title"); 57 | } @{fgoto main;})); 58 | 59 | garbage_tag := (count_newlines | ^'>'* '>' @tag_done @{ fgoto main; }); 60 | 61 | literal = ( "'" ^"'"* >mark %mark_end "'" | '"' ^'"'* >mark %mark_end '"' | ^(wsp|'"'|"'"|'>')+ >mark %mark_end); 62 | tag_attrs = (wsp+ | ident+ >mark %key wsp* ('=' wsp* literal)? %store_attr )**; 63 | close_tag = '/' wsp* ident* >mark %close_tag <: ^'>'* '>'; 64 | open_tag = ident+ >mark %tag <: wsp* tag_attrs ('/' wsp* '>' %tag_done_2 | '>' %tag_done); 65 | directive = ('!'|'?') (alnum ident+) >mark %directive <: wsp* tag_attrs '?'? '>' %directive_done; 66 | comment = "!--" any* :>> "-->"; 67 | # reset tag so that garbage_tag will not generate duplicate tag with tag_done 68 | tag = '<' wsp* <: (close_tag | open_tag | directive | comment) @lerr(garbage_tag) >{ tag := "" }; 69 | main := (((tag | ^'<' >mark ^'<'* %text ) )** | count_newlines); 70 | 71 | write data; 72 | }%% 73 | 74 | (** scan [data] for html tags and invoke [call] for every element *) 75 | let parse ?(ctx=init ()) call data = 76 | let cs = ref 0 in 77 | let mark = ref (-1) in 78 | let mark_end = ref (-1) in 79 | let tag = ref "" and key = ref "" and attrs = ref [] and directive = ref "" in 80 | (* let substr data ofs len = try String.sub data ofs len with exn -> Prelude.printfn "%S %d %d %d" data (String.length data) ofs len; raise exn in *) 81 | let substr = String.sub in 82 | %%write init; 83 | let eof = ref (String.length data) in 84 | let p = ref 0 in 85 | let pe = ref (String.length data) in 86 | let sub () = 87 | assert (!mark >= 0); 88 | if !mark_end < 0 then mark_end := !p; 89 | let s = if !mark_end <= !mark then "" else substr data !mark (!mark_end - !mark) in 90 | mark := -1; 91 | mark_end := -1; 92 | s 93 | in 94 | %%write exec; 95 | (* FIXME ? *) 96 | (* if !eof <> -1 && !cs < htmlstream_first_final then Exn.fail "not parsed"; *) 97 | () 98 | 99 | (* vim: ft=ocaml 100 | *) 101 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | devkit 2 | ====== 3 | 4 | [![Build Status](https://github.com/ahrefs/devkit/actions/workflows/makefile.yml/badge.svg)](https://github.com/ahrefs/devkit/actions/workflows/makefile.yml) 5 | 6 | General purpose OCaml library (development kit) 7 | Copyright (c) 2009 Ahrefs 8 | Released under the terms of LGPL-2.1 with OCaml linking exception. 9 | 10 | Usage 11 | ----- 12 | 13 | ```sh 14 | opam install devkit 15 | ``` 16 | 17 | ### Tracing 18 | 19 | Devkit's `Web` module includes both simple, configurable, local tracing support, as well as [distributed tracing][] support via OpenTelemetry. 20 | 21 | To use local tracing, we use the mechanism provided by [`ocaml-trace`][]: by default, the tracing calls in devkit are a no-op; but if the top-level application containing devkit installs and configures a "tracing backend" at runtime, then devkit's web-requests will each produce timed traces. 22 | 23 | > As an example, using `trace-tef` as a backend to produce a `json` file: 24 | > 25 | > ```ocaml 26 | > open Devkit 27 | > 28 | > let run () = 29 | > let resp = Web.http_request `GET "http://icanhazip.com" in 30 | > (* ... *) 31 | > 32 | > let () = 33 | > Trace_tef.with_setup ~out:(`File "trace.json") () @@ fun () -> 34 | > run () 35 | > ``` 36 | 37 | For distributed traces, you'll both need to configure an OpenTelemetry backend for `ocaml-trace` at runtime (to collect devkit's own traces); and you will most likely also want to ensure your own application's traces (using either `ocaml-trace` or the full `ocaml-opentelemetry`) are properly configured to correctly appear as the _parent_ of devkit's traces. 38 | 39 | Configuring an OpenTelemetry backend for the traces themselves is as simple wrapping your top-level application in a call to `Opentelemetry_trace.`[`setup_with_otel_backend`][] or the like. That will configure both OpenTelemetry's collector and the `ocaml-trace` backend. 40 | 41 | Then, to ensure that parentage is correctly propagated across your distributed architecture, devkit can produce a W3C Trace Context [`traceparent`] HTTP header. To ensure that it produces the _correct_ `traceparent`, however, we depend upon 'ambient context'. For this to function properly, you'll need to follow the [detailed instructions in the `ocaml-ambient-context` documentation][ambient-context installation]. 42 | 43 | Once thus configured, devkit will check `Opentelemetry.Scope.`[`get_ambient_scope`][] before each HTTP request, and use the ambient tracing-span as the parent of the web-request's span; which will itself then be propagated to the remote service via the `traceparent` HTTP header. 44 | 45 | > As an example, if your top-level application is using Lwt, and using cohttp as the OpenTelemetry backend: 46 | > 47 | > ```ocaml 48 | > open Devkit 49 | > 50 | > let run () = 51 | > let* resp = Web.http_request_lwt `GET "http://icanhazip.com" in 52 | > (* ... *) 53 | > 54 | > let () = 55 | > Ambient_context.set_storage_provider (Ambient_context_lwt.storage ()) ; 56 | > Opentelemetry_trace.setup_with_otel_backend 57 | > (Opentelemetry_client_cohttp_lwt.create_backend ()) 58 | > @@ fun () -> 59 | > Lwt_main.run @@ fun () -> 60 | > run () 61 | > ``` 62 | 63 | [distributed tracing]: "OpenTelemetry: Traces" 64 | [`ocaml-trace`]: "Simon Cruanes' ocaml-trace library" 65 | [`setup_with_otel_backend`]: "ocaml-opentelemetry: Opentelemetry_trace.setup_with_otel_backend" 66 | [`traceparent`]: "W3C Trace Context specification: § 3.2 Traceparent header" 67 | [ambient-context installation]: "ocaml-ambient-context: Installation (as a top-level application)" 68 | [`get_ambient_scope`]: 69 | 70 | Development 71 | ----------- 72 | 73 | Install OCaml dependencies in your current / global switch: 74 | 75 | opam install . --deps-only 76 | 77 | Or to install them in a new, directory-local switch: 78 | 79 | opam switch create . --deps-only --no-install 80 | opam install . --deps-only --with-test 81 | 82 | External dependencies: 83 | 84 | opam list -s -e --resolve=devkit 85 | 86 | To update ragel-generated code: 87 | 88 | aptitude install ragel 89 | make -B gen_ragel 90 | 91 | To update metaocaml-generated code: 92 | 93 | opam exec --switch=4.07.1+BER -- make gen_metaocaml 94 | -------------------------------------------------------------------------------- /cache.mli: -------------------------------------------------------------------------------- 1 | (** Various types of in-memory caches *) 2 | 3 | module type Lock = sig 4 | type t 5 | val create : unit -> t 6 | val locked : t -> (unit -> 'a) -> 'a 7 | end 8 | 9 | (** see also {!ExtThread.LockMutex} *) 10 | module NoLock : Lock 11 | 12 | module TimeLimited2(E : Set.OrderedType)(Lock : Lock) : sig 13 | type t 14 | type time = int64 15 | val create : Time.t -> t 16 | val add : t -> E.t -> unit 17 | val get : t -> E.t -> (E.t * time) option 18 | val count : t -> int 19 | val iter : t -> (E.t -> unit) -> unit 20 | end 21 | 22 | module LRU(K : Hashtbl.HashedType) : sig 23 | type 'v t 24 | val create : int -> 'v t 25 | val put : 'v t -> K.t -> 'v -> unit 26 | val put_evicted : 'v t -> K.t -> 'v -> (K.t * 'v) option 27 | val get : 'v t -> K.t -> 'v 28 | val get_evicted : 'v t -> K.t -> ('v * (K.t * 'v) option) 29 | val find : 'v t -> K.t -> 'v 30 | val replace : 'v t -> K.t -> 'v -> unit 31 | val remove : 'v t -> K.t -> unit 32 | val miss : 'v t -> int 33 | val hit : 'v t -> int 34 | val mem : 'v t -> K.t -> bool 35 | val size : 'v t -> int 36 | val iter : (K.t -> 'v -> unit) -> 'v t -> unit 37 | val lru_free : 'v t -> int 38 | val lfu_free : 'v t -> int 39 | end 40 | 41 | (** Count elements *) 42 | module Count : sig 43 | type 'a t 44 | val create : unit -> 'a t 45 | val of_list : ('a * int) list -> 'a t 46 | val of_enum : ('a * int) Enum.t -> 'a t 47 | val clear : 'a t -> unit 48 | val add : 'a t -> 'a -> unit 49 | val plus : 'a t -> 'a -> int -> unit 50 | val del : 'a t -> 'a -> unit 51 | val minus : 'a t -> 'a -> int -> unit 52 | val enum : 'a t -> ('a * int) Enum.t 53 | val iter : 'a t -> ('a -> int -> unit) -> unit 54 | val fold : 'a t -> ('a -> int -> 'b -> 'b) -> 'b -> 'b 55 | 56 | (** number of times given element was seen *) 57 | val count : 'a t -> 'a -> int 58 | val count_all : 'a t -> int 59 | 60 | (** number of distinct elements *) 61 | val size : 'a t -> int 62 | val show : 'a t -> ?sep:string -> ('a -> string) -> string 63 | val show_sorted : 'a t -> ?limit:int -> ?sep:string -> ('a -> string) -> string 64 | val stats : 'a t -> ?cmp:('a -> 'a -> int) -> ('a -> string) -> string 65 | val report : 'a t -> ?limit:int -> ?cmp:('a -> 'a -> int) -> ?sep:string -> ('a -> string) -> string 66 | val distrib : float t -> float array 67 | val show_distrib : ?sep:string -> float t -> string 68 | val names : 'a t -> 'a list 69 | end 70 | 71 | module Group : sig 72 | type ('a,'b) t 73 | val by : ('a -> 'b) -> ('a,'b) t 74 | val add : ('a,'b) t -> 'a -> unit 75 | val get : ('a,'b) t -> 'b -> 'a list 76 | val iter : ('a,'b) t -> ('b -> 'a list -> unit) -> unit 77 | val keys : ('a,'b) t -> 'b Enum.t 78 | end 79 | 80 | val group_fst : ('a * 'b) Enum.t -> ('a * 'b list) Enum.t 81 | 82 | (** One-to-one associations *) 83 | module Assoc : sig 84 | type ('a,'b) t 85 | val create : unit -> ('a,'b) t 86 | 87 | (** Add association, assert on duplicate key *) 88 | val add : ('a,'b) t -> 'a -> 'b -> unit 89 | 90 | (** Get associated value, @raise Not_found if key is not present *) 91 | val get : ('a,'b) t -> 'a -> 'b 92 | 93 | (** Get associated value *) 94 | val try_get : ('a,'b) t -> 'a -> 'b option 95 | 96 | (** Delete association, assert if key is not present, @return associated value *) 97 | val del : ('a,'b) t -> 'a -> 'b 98 | 99 | (** Delete association, assert if key is not present *) 100 | val remove : ('a,'b) t -> 'a -> unit 101 | val size : ('a,'b) t -> int 102 | 103 | val fold: ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c 104 | end 105 | 106 | module Lists : sig 107 | type ('a,'b) t 108 | val create : unit -> ('a,'b) t 109 | val add : ('a,'b) t -> 'a -> 'b -> unit 110 | val get : ('a,'b) t -> 'a -> 'b list 111 | val set : ('a,'b) t -> 'a -> 'b list -> unit 112 | val enum : ('a,'b) t -> ('a * 'b list) Enum.t 113 | val clear : ('a, 'b) t -> unit 114 | val count_keys : ('a, 'b) t -> int 115 | val count_all : ('a, 'b) t -> int 116 | end 117 | 118 | class ['a] cache : ('a list -> unit) -> limit:int -> 119 | object 120 | val mutable l : 'a list 121 | method add : 'a -> unit 122 | method clear : unit 123 | method dump : unit 124 | method get : 'a list 125 | method name : string 126 | method size : int 127 | method to_list : 'a list 128 | end 129 | 130 | type 'a reused 131 | val reuse : (unit -> 'a) -> ('a -> unit) -> 'a reused 132 | val use : 'a reused -> 'a 133 | val recycle : 'a reused -> 'a -> unit 134 | 135 | module Reuse(T : sig type t val create : unit -> t val reset : t -> unit end) : sig 136 | type t = T.t 137 | val get : unit -> t 138 | val release : t -> unit 139 | end 140 | -------------------------------------------------------------------------------- /daemon.ml: -------------------------------------------------------------------------------- 1 | (** daemon utilities *) 2 | 3 | module U = ExtUnix.Specific 4 | 5 | let log = Log.from "daemon" 6 | 7 | let logfile = ref None 8 | let pidfile = ref None 9 | let runas = ref None 10 | let foreground = ref false 11 | 12 | let managed = ref false 13 | 14 | (** global flag indicating that process should exit, 15 | [manage] will automatically set this flag on SIGTERM unless default signal handling is overriden 16 | *) 17 | let should_exit_ = ref false 18 | 19 | (** [should_exit_lwt] usage is discouraged. 20 | Use [wait_exit] instead, which makes it harder to ignore "should exit" state and loop infinitely 21 | *) 22 | let (should_exit_lwt,signal_exit_lwt) = Lwt.wait () 23 | let should_exit () = !should_exit_ 24 | let should_run () = not !should_exit_ 25 | 26 | (** exception to be raised by functions that wish to signal premature termination due to [!should_exit = true] *) 27 | exception ShouldExit 28 | 29 | let signal_exit = 30 | let do_lwt = lazy ( 31 | (* we can't use Lwt's wakeup_later because it doesn't always "later", it 32 | soemtimes behaves the same as plain wakeup *) 33 | Lwt.dont_wait 34 | (fun () -> 35 | Lwt.bind 36 | (Lwt.pause ()) 37 | (fun () -> Lwt.wakeup signal_exit_lwt (); Lwt.return_unit)) 38 | (fun exc -> log#error "signal exit: error at wakeup: %s" (Printexc.to_string exc)) 39 | ) 40 | in 41 | (* nearly-invariant: should_exit_ = (Lwt.state should_exit_lwt = Lwt.Return) *) 42 | fun () -> should_exit_ := true; Lazy.force do_lwt 43 | 44 | (** @raise ShouldExit if [should_exit] condition is set, otherwise do nothing *) 45 | let break () = if !should_exit_ then raise ShouldExit 46 | 47 | (** wait until [should_exit] is set and raise [ShouldExit] *) 48 | let wait_exit = 49 | (* NOTE 50 | Bind to should_exit_lwt only once, because every bind will create an immutable waiter on 51 | should_exit_lwt's sleeper, that is only removed after should_exit_lwt thread terminates. 52 | *) 53 | let thread = lazy (Lwt.bind should_exit_lwt (fun () -> raise ShouldExit)) in 54 | fun () -> Lazy.force thread 55 | 56 | (** [break_lwt = Lwt.wrap break] *) 57 | let break_lwt () = Lwt.wrap break 58 | 59 | (** [unless_exit x] resolves promise [x] or raises [ShouldExit] *) 60 | let unless_exit x = Lwt.pick [wait_exit (); x] 61 | 62 | let get_args () = 63 | [ 64 | ("-loglevel", Arg.String Log.set_loglevels, " ([=]debug|info|warn|error[,])+"); 65 | ExtArg.may_str "logfile" logfile " Log file"; 66 | ExtArg.may_str "pidfile" pidfile " PID file"; 67 | "-runas", 68 | Arg.String (fun name -> try runas := Some (Unix.getpwnam name) with exn -> Exn.fail ~exn "runas: unknown user %s" name), 69 | " run as specified user"; 70 | "-fg", Arg.Set foreground, " Stay in foreground"; 71 | ] 72 | 73 | let args = get_args () 74 | 75 | let install_signal_handlers () = 76 | let unix_stderr s = 77 | let s = Log.State.format_simple `Info log#facility s in 78 | try 79 | let (_:int) = Unix.write_substring Unix.stderr s 0 (String.length s) in () 80 | with _ -> 81 | () (* do not fail, can be ENOSPC *) 82 | in 83 | Signal.set [Sys.sigpipe] ignore; 84 | Signal.set_verbose [Sys.sigusr1] "reopen log" (fun () -> Log.reopen !logfile); 85 | Signal.set_verbose [Sys.sigusr2] "memory reclaim and stats" begin fun () -> 86 | match Signal.is_safe_output () with 87 | | true -> Memory.log_stats (); Memory.reclaim () 88 | | false -> 89 | (* output directly to fd to prevent deadlock, but breaks buffering *) 90 | Memory.get_stats () |> List.iter unix_stderr; 91 | Memory.reclaim_s () |> unix_stderr 92 | end; 93 | Signal.set_exit signal_exit 94 | 95 | let manage () = 96 | match !managed with 97 | | true -> () (* be smart *) 98 | | false -> 99 | (* 100 | this will fail if files don't exists :( 101 | (* fail before fork if something is wrong *) 102 | Option.may (fun path -> Unix.(access path [R_OK;W_OK])) !logfile; 103 | Option.may (fun path -> Unix.(access path [R_OK;W_OK])) !pidfile; 104 | *) 105 | Option.may Nix.check_pidfile !pidfile; (* check pidfile before fork to fail early *) 106 | if not !foreground then Nix.daemonize (); 107 | begin match !runas with 108 | | None -> () 109 | | Some pw -> 110 | let uid = pw.Unix.pw_uid and gid = pw.Unix.pw_gid in 111 | U.setreuid uid uid; 112 | U.setregid gid gid; 113 | end; 114 | Log.reopen !logfile; (* immediately after fork *) 115 | Log.read_env_config (); 116 | Option.may Nix.manage_pidfile !pidfile; (* write pidfile after fork! *) 117 | if Option.is_some !logfile then 118 | begin 119 | log #info "run: %s" Nix.cmdline; 120 | log #info "GC settings: %s" (Action.gc_settings ()); 121 | end; 122 | install_signal_handlers (); 123 | Nix.raise_limits (); 124 | managed := true; 125 | () 126 | -------------------------------------------------------------------------------- /stage_merge.ml: -------------------------------------------------------------------------------- 1 | open Enum 2 | 3 | type ('a,'b) value = Left of 'a | Right of 'b | Both of ('a * 'b) 4 | 5 | let stage_merge compare ~left ~right ~multi return key1 key2 v1 v2 = 6 | let multi_ret next found ret = 7 | match left, multi with 8 | | true, true -> .< if not .~found then .~ret else .~next () >. 9 | | true, false -> ret 10 | | false, _ -> .< .~next () >. 11 | in 12 | .< fun e1 e2 -> 13 | let _found = ref false in 14 | let rec next () = 15 | let _prev_found = .~(if multi && left then .< let prev = !_found in _found := false; prev>. else .< false >.) in 16 | match peek e1, peek e2 with 17 | | None, None -> raise No_more_elements 18 | | Some x, None -> junk e1; .~(let ret = return (key1 ..) (Left (v1 ..)) in multi_ret .. .<_prev_found>. ret) 19 | | None, Some y -> junk e2; .~(if right then return (key2 ..) (Right (v2 ..)) else .< raise No_more_elements >.) 20 | | Some x, Some y -> 21 | let k1 = .~(key1 ..) in 22 | let k2 = .~(key2 ..) in 23 | match .~compare k1 k2 with 24 | | 0 -> .~(if not multi then .< junk e1 >. else if left then .< _found := true >. else .< () >.); junk e2; .~(return .. (Both (v1 .., v2 ..))) 25 | | n when n < 0 -> junk e1; .~(let ret = return .. (Left (v1 ..)) in multi_ret .. .<_prev_found>. ret) 26 | | _ (* n > 0 *) -> junk e2; .~(if right then return .. (Right (v2 ..)) else .< next () >.) 27 | in 28 | from next 29 | >. 30 | 31 | (* helpers *) 32 | 33 | let lift f x = .. (* csp *) 34 | let fst_ x = .. 35 | let snd_ x = .. 36 | let some x = .. 37 | 38 | let id x = x 39 | let same f x = f x x 40 | let ($) f g = fun x -> f @@ g x 41 | 42 | let print_code code = 43 | let open Format in 44 | format_code std_formatter (close_code code); 45 | pp_print_newline std_formatter (); 46 | pp_print_newline std_formatter () 47 | 48 | (* generate *) 49 | 50 | let wrap ret v1 v2 = 51 | fun k v -> 52 | let v = match v with Left x -> Left (v1 x) | Right x -> Right (v2 x) | Both (x,y) -> Both (v1 x, v2 y) in 53 | ret k v 54 | 55 | let ret_pair _k v = match v with Left x -> .< .~x, None >. | Right x -> .< None, .~x >. | Both (x,y) -> .<.~x, .~y >. 56 | let ret_assoc k v = match v with Left x -> .<.~k, .~x, None>. | Right x -> .<.~k, None, .~x>. | Both (x,y) -> .<.~k, .~x, .~y>. 57 | let ret_full _k v = match v with Left x -> .< `Left .~x >. | Right x -> .< `Right .~x >. | Both (x,y) -> .< `Both (.~x, .~y) >. 58 | let ret_add_key f k v = .< .~k, .~(f k v) >. 59 | 60 | let () = 61 | print_endline "[@@@ocaml.warning \"-27-39\"]"; 62 | print_endline "" 63 | 64 | let () = 65 | let bool k = k false; k true in 66 | bool @@ fun assoc -> bool @@ fun multi -> bool @@ fun right -> bool @@ fun left -> bool @@ fun by -> 67 | match by, assoc with 68 | | true, true -> () (* assoc doesn't need `by`, has explicit key already *) 69 | | false, false -> () (* we don't want non-`by` variants, except for assoc which has explicit key *) 70 | | _ -> 71 | let dir = 72 | match left, right with 73 | | true, true -> "full" 74 | | true, false -> "left" 75 | | false, true -> "right" 76 | | false, false -> "inner" 77 | in 78 | let str b name = if b then name else "" in 79 | let name = String.concat "_" @@ List.filter ((<>) "") @@ ["join"; str assoc "assoc"; dir; str multi "multi"; str by "by"] in 80 | Printf.printf "let %s =\n" name; 81 | let stage cmp ret k1 k2 v = stage_merge cmp ~left ~right ~multi ret k1 k2 v v in 82 | let gen key v ret = 83 | if by then 84 | print_code .< fun cmp k1 k2 -> .~(stage .. ret (fun x -> ..) (fun x -> ..) v) >. 85 | else 86 | print_code .< fun cmp -> .~(stage .. ret key key v) >. 87 | in 88 | let gen v1 v2 = 89 | match assoc, left && right with 90 | | false, false -> gen id id (wrap ret_pair v1 v2) 91 | | false, true -> gen id id ret_full 92 | | true, false -> gen fst_ snd_ (wrap ret_assoc v1 v2) 93 | | true, true -> gen fst_ snd_ (ret_add_key @@ ret_full) 94 | in 95 | begin match left, right with 96 | | true, true -> gen id id 97 | | true, false -> gen id some 98 | | false, true -> gen some id 99 | | false, false -> gen id id 100 | end; 101 | if by then Printf.printf "let %s_key cmp k = %s cmp k k\n\n" name name 102 | 103 | let stage_full_merge return key v = .< fun cmp -> .~(stage_merge .. ~left:true ~right:true ~multi:false return key key v v) >. 104 | 105 | let () = 106 | print_endline "let merge ="; 107 | print_code @@ stage_full_merge (wrap ret_pair some some) id id 108 | 109 | let () = 110 | print_endline "let merge_assoc ="; 111 | print_code @@ stage_full_merge (wrap ret_assoc some some) fst_ snd_ 112 | 113 | (* 114 | let () = 115 | print_endline "let merge_by ="; 116 | print_code @@ .< fun compare key1 key2 -> .~(stage_full_merge (ret_pair some some) (fun x -> ..) (fun x -> ..)) compare >. 117 | *) 118 | -------------------------------------------------------------------------------- /extThread.ml: -------------------------------------------------------------------------------- 1 | let log = Log.self 2 | 3 | type 'a t = [ `Exn of exn | `None | `Ok of 'a ] ref * Thread.t 4 | let detach f x = 5 | let result = ref `None in 6 | result, Thread.create (fun () -> result := Exn.map f x) () 7 | let join (result,thread) = Thread.join thread; match !result with `None -> assert false | (`Ok _ | `Exn _ as x) -> x 8 | let join_exn t = match join t with `Ok x -> x | `Exn exn -> raise exn 9 | let map f a = Array.map join_exn @@ Array.map (detach f) a 10 | let mapn ?(n=8) f l = 11 | assert (n > 0); 12 | Action.distribute n l |> map (List.map @@ Exn.map f) |> Action.undistribute 13 | 14 | let locked mutex f = Mutex.lock mutex; Std.finally (fun () -> Mutex.unlock mutex) f () 15 | 16 | module LockMutex = struct 17 | type t = Mutex.t 18 | let create = Mutex.create 19 | let locked = locked 20 | end 21 | 22 | module Async_fin = struct 23 | 24 | open Async 25 | module U = ExtUnix.All 26 | 27 | type t = { q : (unit -> unit) Mtq.t; evfd : Unix.file_descr; } 28 | 29 | let is_available () = ExtUnix.Config.have `EVENTFD 30 | 31 | let setup events = 32 | let fin = { q = Mtq.create (); evfd = U.eventfd 0; } in 33 | let rec loop () = 34 | match Mtq.try_get fin.q with 35 | | None -> () 36 | | Some f -> begin try f () with exn -> log #warn ~exn "fin loop" end; loop () 37 | in 38 | let reset fd = 39 | try 40 | ignore (U.eventfd_read fd) 41 | with 42 | | Unix.Unix_error (Unix.EAGAIN, _, _) -> () 43 | | exn -> log #warn ~exn "fin reset"; () 44 | in 45 | setup_simple_event events fin.evfd [Ev.READ] begin fun _ fd _ -> reset fd; loop () end; 46 | fin 47 | 48 | let shutdown { q; evfd } = Mtq.clear q; Unix.close evfd 49 | 50 | let callback fin f = 51 | Mtq.put fin.q f; 52 | U.eventfd_write fin.evfd 1L 53 | 54 | end 55 | 56 | let log_create ?name f x = Thread.create (fun () -> Action.log ?name f x) () 57 | 58 | let run_periodic ~delay ?(now=false) f = 59 | let (_:Thread.t) = Thread.create begin fun () -> 60 | if not now then Nix.sleep delay; 61 | while try f () with exn -> Log.self #warn ~exn "ExtThread.run_periodic"; true do 62 | Nix.sleep delay 63 | done 64 | end () 65 | in 66 | () 67 | 68 | module type WorkerT = sig 69 | type task 70 | type result 71 | end 72 | 73 | module type Workers = sig 74 | type task 75 | type result 76 | type t 77 | val create : (task -> result) -> int -> t 78 | val perform : t -> ?autoexit:bool -> task Enum.t -> (result -> unit) -> unit 79 | val stop : ?wait:int -> t -> unit 80 | end 81 | 82 | module Workers(T:WorkerT) = 83 | struct 84 | 85 | type task = T.task 86 | type result = T.result 87 | type t = task Mtq.t * result Mtq.t * int 88 | 89 | let worker qi f qo = 90 | while true do 91 | Mtq.put qo (f (Mtq.get qi)) 92 | done 93 | 94 | let stop ?wait:_ (qi,_,_) = Mtq.clear qi 95 | 96 | let create f n = 97 | let qi = Mtq.create () and qo = Mtq.create () in 98 | for _ = 1 to n do 99 | ignore (Thread.create (fun () -> worker qi f qo) ()) 100 | done; 101 | qi,qo,n 102 | 103 | let perform (qi,qo,n) ?autoexit:_ e f = 104 | let active = ref 0 in 105 | for _ = 1 to n do 106 | match Enum.get e with 107 | | Some x -> Mtq.put qi x; incr active 108 | | None -> () 109 | done; 110 | while !active > 0 do 111 | let res = Mtq.get qo in 112 | begin match Enum.get e with 113 | | Some x -> Mtq.put qi x 114 | | None -> decr active 115 | end; 116 | f res 117 | done 118 | 119 | end 120 | 121 | let atomic_incr = incr 122 | let atomic_decr = decr 123 | let atomic_get x = !x 124 | 125 | module Pool = struct 126 | 127 | type t = { q : (unit -> unit) Mtq.t; 128 | total : int; 129 | free : int ref; 130 | mutable blocked : bool; 131 | } 132 | 133 | let create n = 134 | let t = { q = Mtq.create (); total = n; free = ref (-1); blocked = false;} in t 135 | 136 | let init t = 137 | let worker _i = 138 | while true do 139 | let f = Mtq.get t.q in 140 | atomic_decr t.free; 141 | begin try f () with exn -> log #warn ~exn "ThreadPool" end; 142 | atomic_incr t.free; 143 | done 144 | in 145 | t.free := t.total; 146 | for i = 1 to t.total do 147 | let (_:Thread.t) = log_create worker i in () 148 | done 149 | 150 | let status t = Printf.sprintf "queue %d threads %d of %d" 151 | (Mtq.length t.q) (atomic_get t.free) t.total 152 | 153 | let put t = 154 | if atomic_get t.free = -1 then init t; 155 | while t.blocked do 156 | Nix.sleep 0.05 157 | done; 158 | Mtq.put t.q 159 | 160 | let wait_blocked ?(n=0) t = 161 | if (atomic_get t.free <> -1) then begin 162 | while t.blocked do Nix.sleep 0.05 done;(* Wait for unblock *) 163 | t.blocked <- true; 164 | assert(n>=0); 165 | let i = ref 1 in 166 | while Mtq.length t.q + (t.total - atomic_get t.free)> n do (* Notice that some workers can be launched! *) 167 | if !i = 100 || !i mod 1000 = 0 then 168 | log #info "Thread Pool - waiting block : %s" (status t); 169 | Nix.sleep 0.05; 170 | incr i 171 | done; 172 | t.blocked <- false 173 | end 174 | 175 | end 176 | -------------------------------------------------------------------------------- /extEnum.ml: -------------------------------------------------------------------------------- 1 | (** Extensions to Enum *) 2 | 3 | include Enum 4 | 5 | let rec find_peek f e = 6 | match peek e with 7 | | Some x when f x -> 8 | x 9 | | None -> 10 | raise Not_found 11 | | _ -> 12 | junk e; 13 | find_peek f e 14 | 15 | let list_loop l = 16 | assert (l <> []); 17 | let r = ref l in 18 | let rec next () = 19 | match !r with 20 | | x :: xs -> r := xs; x 21 | | [] -> r := l; next () 22 | in 23 | from next 24 | 25 | let of_dynarray ?(start=0) ?n d = 26 | let last = 27 | match n with 28 | | None -> DynArray.length d 29 | | Some n -> start + n 30 | in 31 | let rec make start = 32 | let idxref = ref start in 33 | let next () = 34 | if !idxref >= last then 35 | raise Enum.No_more_elements; 36 | let retval = DynArray.get d !idxref in 37 | incr idxref; 38 | retval 39 | and count () = 40 | if !idxref >= last then 0 else last - !idxref 41 | and clone () = 42 | make !idxref 43 | in 44 | Enum.make ~next ~count ~clone 45 | in 46 | make start 47 | 48 | let take limit e = 49 | let limit = ref limit in 50 | from begin fun () -> 51 | if 0 = !limit then raise Enum.No_more_elements; 52 | let x = next e in 53 | decr limit; 54 | x 55 | end 56 | 57 | let align f e1 e2 = 58 | let next () = 59 | match peek e1, peek e2 with 60 | | None, None -> raise No_more_elements 61 | | Some x, None -> junk e1; x 62 | | None, Some y -> junk e2; y 63 | | Some x, Some y when f x y < 0 -> junk e1; x 64 | | Some _, Some y -> junk e2; y 65 | in 66 | from next 67 | 68 | let join ?(left=false) ?(right=false) ?(multi=true) f e1 e2 = 69 | let found = ref false in 70 | let rec next () = 71 | let found' = !found in 72 | found := false; 73 | match peek e1, peek e2 with 74 | | None, None -> raise No_more_elements 75 | | Some _, None as res -> junk e1; if left && not found' then res else next () 76 | | None, Some _ as res -> junk e2; if right then res else raise No_more_elements 77 | | Some x, Some y as res -> 78 | match f x y with 79 | | n when n < 0 -> junk e1; if left && not found' then Some x, None else next () 80 | | n when n > 0 -> junk e2; if right then None, Some y else next () 81 | | _ -> if not multi then junk e1; junk e2; found := multi; res 82 | in 83 | from next 84 | 85 | let join_assoc ?(left=false) ?(right=false) ?(multi=true) f e1 e2 = 86 | let found = ref false in 87 | let rec next () = 88 | let found' = !found in 89 | found := false; 90 | match peek e1, peek e2 with 91 | | None, None -> raise No_more_elements 92 | | Some (k, x), None -> junk e1; if left && not found' then k, Some x, None else next () 93 | | None, Some (k, y) -> junk e2; if right then k, None, Some y else raise No_more_elements 94 | | Some (kx, x), Some (ky, y) -> 95 | match f kx ky with 96 | | n when n < 0 -> junk e1; if left && not found' then kx, Some x, None else next () 97 | | n when n > 0 -> junk e2; if right then ky, None, Some y else next () 98 | | _ -> if not multi then junk e1; junk e2; found := multi; kx, Some x, Some y 99 | in 100 | from next 101 | 102 | include ExtEnum_merge 103 | 104 | let group equal fold zero e = 105 | let current = ref None in 106 | let rec next () = 107 | match get e, !current with 108 | | None, None -> raise No_more_elements 109 | | None, Some x -> current := None; x 110 | | Some v, None -> current := Some (fold zero v); next () 111 | | Some v, Some x when equal x v -> current := Some (fold x v); next () 112 | | Some v, Some x -> current := Some (fold zero v); x 113 | in 114 | from next 115 | 116 | let group_assoc equal fold zero e = 117 | let current = ref None in 118 | let rec next () = 119 | match get e, !current with 120 | | None, None -> raise No_more_elements 121 | | None, Some x -> current := None; x 122 | | Some (k,v), None -> current := Some (k, fold zero v); next () 123 | | Some (k,v), Some (g,acc) when equal k g -> current := Some (g, fold acc v); next () 124 | | Some (k,v), Some cur -> current := Some (k, fold zero v); cur 125 | in 126 | from next 127 | 128 | let uniq equal e = 129 | let current = ref None in 130 | let rec next () = 131 | match get e, !current with 132 | | None, None -> raise No_more_elements 133 | | None, Some x -> current := None; x 134 | | Some v, None -> current := Some v; next () 135 | | Some v, Some x when equal x v -> next () 136 | | Some v, Some x -> current := Some v; x 137 | in 138 | from next 139 | 140 | let count_unique equal e = 141 | let current = ref None in 142 | let n = ref 0 in 143 | let rec next () = 144 | match get e, !current with 145 | | None, None -> raise No_more_elements 146 | | None, Some x -> current := None; x, !n 147 | | Some v, None -> current := Some v; n := 1; next () 148 | | Some v, Some x when equal x v -> incr n; next () 149 | | Some v, Some x -> let count = !n in current := Some v; n := 1; x, count 150 | in 151 | from next 152 | 153 | let sub ?(eq=(=)) e f = 154 | match peek e with 155 | | None -> None 156 | | Some x -> 157 | let current = f x in 158 | let next () = 159 | match peek e with 160 | | Some x when eq (f x) current -> junk e; x 161 | | None | Some _ -> raise No_more_elements 162 | in 163 | Some (current, from next) 164 | 165 | let rec iter_while f e = 166 | match peek e with 167 | | Some x when f x -> 168 | begin match peek e with 169 | | Some y when x == y -> junk e (* "support" recursive invocations *) 170 | | _ -> () 171 | end; 172 | iter_while f e 173 | | _ -> () 174 | -------------------------------------------------------------------------------- /ocamlnet_lite/netstring_tstring.ml: -------------------------------------------------------------------------------- 1 | open Netsys_types 2 | 3 | type _ tstring_kind = 4 | | String_kind : string tstring_kind 5 | | Bytes_kind : Bytes.t tstring_kind 6 | 7 | type 't tstring_ops = { 8 | kind : 't tstring_kind option; 9 | length : 't -> int; 10 | get : 't -> int -> char; 11 | unsafe_get : 't -> int -> char; 12 | unsafe_get3 : 't -> int -> int; (* get 3 chars packed into one int *) 13 | copy : 't -> 't; 14 | string : 't -> string; 15 | bytes : 't -> Bytes.t; 16 | sub : 't -> int -> int -> 't; 17 | substring : 't -> int -> int -> string; 18 | subbytes : 't -> int -> int -> Bytes.t; 19 | subpoly : 'u. 'u tstring_kind -> 't -> int -> int -> 'u; 20 | blit_to_bytes : 't -> int -> Bytes.t -> int -> int -> unit; 21 | index_from : 't -> int -> char -> int; 22 | index_from3 : 't -> int -> int -> char -> char -> char -> int; 23 | rindex_from : 't -> int -> char -> int; 24 | rindex_from3 : 't -> int -> int -> char -> char -> char -> int; 25 | } 26 | 27 | type tstring_ops_box = 28 | | Tstring_ops_box : 't tstring_kind * 't tstring_ops -> tstring_ops_box 29 | 30 | type tstring_box = 31 | | Tstring_box : 't tstring_kind * 't tstring_ops * 't -> tstring_box 32 | 33 | type tstring_polybox = 34 | | Tstring_polybox : 't tstring_ops * 't -> tstring_polybox 35 | (* Warning: you cannot match on the type 't here *) 36 | 37 | let str_subpoly : type u. u tstring_kind -> string -> int -> int -> u = function 38 | | String_kind -> String.sub 39 | | Bytes_kind -> 40 | fun s pos len -> 41 | let b = Bytes.create len in 42 | Bytes.blit_string s pos b 0 len; 43 | b 44 | 45 | let str_index_from3 s p n c1 c2 c3 = 46 | (* FIXME: implement in C *) 47 | let sn = String.length s in 48 | if n < 0 || p < 0 || p > sn - n then invalid_arg "index_from3"; 49 | let lim = p + n in 50 | let p = ref p in 51 | while 52 | !p < lim 53 | && 54 | let c = String.unsafe_get s !p in 55 | c <> c1 && c <> c2 && c <> c3 56 | do 57 | incr p 58 | done; 59 | if !p >= lim then raise Not_found; 60 | !p 61 | 62 | let str_rindex_from3 s p n c1 c2 c3 = 63 | (* FIXME: implement in C *) 64 | let sn = String.length s in 65 | if n < 0 || p < -1 || p >= sn || n - 1 > p then invalid_arg "rindex_from"; 66 | let lim = p - n + 1 in 67 | let p = ref p in 68 | while 69 | !p >= lim 70 | && 71 | let c = String.unsafe_get s !p in 72 | c <> c1 && c <> c2 && c <> c3 73 | do 74 | decr p 75 | done; 76 | if !p < lim then raise Not_found; 77 | !p 78 | 79 | let string_ops = 80 | { 81 | kind = Some String_kind; 82 | length = String.length; 83 | get = String.get; 84 | unsafe_get = String.unsafe_get; 85 | unsafe_get3 = 86 | (fun s k -> 87 | let c0 = Char.code (String.unsafe_get s k) in 88 | let c1 = Char.code (String.unsafe_get s (k + 1)) in 89 | let c2 = Char.code (String.unsafe_get s (k + 2)) in 90 | (c0 lsl 16) lor (c1 lsl 8) lor c2); 91 | copy = (fun s -> s); 92 | (* ... for the time being ... *) 93 | string = (fun s -> s); 94 | bytes = Bytes.of_string; 95 | sub = String.sub; 96 | substring = String.sub; 97 | subbytes = 98 | (fun s p l -> 99 | let b = Bytes.create l in 100 | Bytes.blit_string s p b 0 l; 101 | b); 102 | subpoly = str_subpoly; 103 | blit_to_bytes = Bytes.blit_string; 104 | index_from = String.index_from; 105 | index_from3 = str_index_from3; 106 | rindex_from = String.rindex_from; 107 | rindex_from3 = str_rindex_from3; 108 | } 109 | 110 | let bytes_index_from3 s p n c1 c2 c3 = 111 | str_index_from3 (Bytes.unsafe_to_string s) p n c1 c2 c3 112 | 113 | let bytes_rindex_from3 s p n c1 c2 c3 = 114 | str_rindex_from3 (Bytes.unsafe_to_string s) p n c1 c2 c3 115 | 116 | let bytes_subpoly : type u. u tstring_kind -> Bytes.t -> int -> int -> u = 117 | function 118 | | String_kind -> Bytes.sub_string 119 | | Bytes_kind -> Bytes.sub 120 | 121 | let bytes_ops = 122 | { 123 | kind = Some Bytes_kind; 124 | length = Bytes.length; 125 | get = Bytes.get; 126 | unsafe_get = Bytes.unsafe_get; 127 | unsafe_get3 = 128 | (fun s k -> 129 | let c0 = Char.code (Bytes.unsafe_get s k) in 130 | let c1 = Char.code (Bytes.unsafe_get s (k + 1)) in 131 | let c2 = Char.code (Bytes.unsafe_get s (k + 2)) in 132 | (c0 lsl 16) lor (c1 lsl 8) lor c2); 133 | copy = Bytes.copy; 134 | string = Bytes.to_string; 135 | bytes = (fun s -> s); 136 | sub = Bytes.sub; 137 | substring = Bytes.sub_string; 138 | subbytes = Bytes.sub; 139 | subpoly = bytes_subpoly; 140 | blit_to_bytes = Bytes.blit; 141 | index_from = Bytes.index_from; 142 | index_from3 = bytes_index_from3; 143 | rindex_from = Bytes.rindex_from; 144 | rindex_from3 = bytes_rindex_from3; 145 | } 146 | 147 | let ops_of_tstring = function 148 | | `String _ -> Tstring_ops_box (String_kind, string_ops) 149 | | `Bytes _ -> Tstring_ops_box (Bytes_kind, bytes_ops) 150 | 151 | type 'a with_fun = { with_fun : 's. 's tstring_ops -> 's -> 'a } 152 | 153 | let with_tstring : 'a with_fun -> tstring -> 'a = 154 | fun f -> function 155 | | `String s -> f.with_fun string_ops s 156 | | `Bytes s -> f.with_fun bytes_ops s 157 | 158 | let length_tstring ts = 159 | with_tstring { with_fun = (fun ops s -> ops.length s) } ts 160 | 161 | let polymorph_string_transformation : 162 | type s t. (string -> string) -> s tstring_ops -> t tstring_kind -> s -> t = 163 | fun f ops out_kind s -> 164 | let s' = f (ops.string s) in 165 | match out_kind with 166 | | String_kind -> s' 167 | | Bytes_kind -> Bytes.of_string s' 168 | 169 | let tstring_of_tbuffer = function 170 | | `Bytes s -> `Bytes s 171 | | `String s -> `Bytes s 172 | -------------------------------------------------------------------------------- /ocamlnet_lite/netencoding.mli: -------------------------------------------------------------------------------- 1 | (* *********************************************************************) 2 | (* HTMLization *) 3 | (* *********************************************************************) 4 | 5 | (* THREAD-SAFETY: 6 | * The Html functions are thread-safe. 7 | *) 8 | 9 | module Url : sig 10 | (** Encoding/Decoding within URLs: 11 | * 12 | * The following two functions perform the '%'-substitution for 13 | * characters that may otherwise be interpreted as metacharacters. 14 | * 15 | * According to: RFC 1738, RFC 1630 16 | * 17 | * Option [plus]: This option has been added because there are some 18 | * implementations that do not map ' ' to '+', for example Javascript's 19 | * [escape] function. The default is [true] because this is the RFC- 20 | * compliant definition. 21 | *) 22 | 23 | (** There are no tstring and polymorphic versions of the encode and 24 | decode functions, as URLs are comparatively short, and it is 25 | considered as acceptable for the user to convert types as needed, 26 | even if strings need to be copied for that. 27 | *) 28 | 29 | val decode : ?plus:bool -> ?pos:int -> ?len:int -> string -> string 30 | (** Option [plus]: Whether '+' is converted to space. The default 31 | * is true. If false, '+' is returned as it is. 32 | * 33 | * The optional arguments [pos] and [len] may restrict the string 34 | * to process to this substring. 35 | *) 36 | 37 | val encode : ?plus:bool -> string -> string 38 | (** Option [plus]: Whether spaces are converted to '+'. The default 39 | * is true. If false, spaces are converted to "%20", and 40 | * only %xx sequences are produced. 41 | *) 42 | 43 | val dest_url_encoded_parameters : string -> (string * string) list 44 | (** The argument is the URL-encoded parameter string. The result is 45 | * the corresponding list of (name,value) pairs. 46 | * Note: Whitespace within the parameter string is ignored. 47 | * If there is a format error, the function fails. 48 | *) 49 | end 50 | 51 | module Html : sig 52 | (** Encodes characters that need protection by converting them to 53 | * entity references. E.g. ["<"] is converted to ["<"]. 54 | * As the entities may be named, there is a dependency on the character 55 | * set. 56 | *) 57 | 58 | val encode : 59 | in_enc:Netconversion.encoding -> 60 | ?out_enc:Netconversion.encoding -> 61 | (* default: `Enc_usascii *) 62 | ?prefer_name:bool -> 63 | (* default: true *) 64 | ?unsafe_chars:string -> 65 | (* default: unsafe_chars_html4 *) 66 | unit -> 67 | string -> 68 | string 69 | (** The input string that is encoded as [in_enc] is recoded to 70 | * [out_enc], and the following characters are encoded as HTML 71 | * entity ([&name;] or [&#num;]): 72 | * - The ASCII characters contained in [unsafe_chars] 73 | * - The characters that cannot be represented in [out_enc]. By 74 | * default ([out_enc=`Enc_usascii]), only ASCII characters can be 75 | * represented, and thus all code points >= 128 are encoded as 76 | * HTML entities. If you pass [out_enc=`Enc_utf8], all characters 77 | * can be represented. 78 | * 79 | * For example, the string ["(ad)"] is encoded as 80 | * ["(a<b) & (c>d)"]. 81 | * 82 | * It is required that [out_enc] is an ASCII-compatible encoding. 83 | * 84 | * The option [prefer_name] selects whether named entities (e.g. [<]) 85 | * or numeric entities (e.g. [<]) are prefered. 86 | * 87 | * The efficiency of the function can be improved when the same encoding 88 | * is applied to several strings. Create a specialized encoding function 89 | * by passing all arguments up to the unit argument, and apply this 90 | * function several times. For example: 91 | * {[ 92 | * let my_enc = encode ~in_enc:`Enc_utf8 () in 93 | * let s1' = my_enc s1 in 94 | * let s2' = my_enc s2 in ... 95 | * ]} 96 | *) 97 | 98 | type entity_set = [ `Html | `Xml | `Empty ] 99 | 100 | val decode : 101 | in_enc:Netconversion.encoding -> 102 | out_enc:Netconversion.encoding -> 103 | ?lookup:(string -> string) -> 104 | (* default: see below *) 105 | ?subst:(int -> string) -> 106 | (* default: see below *) 107 | ?entity_base:entity_set -> 108 | (* default: `Html *) 109 | unit -> 110 | string -> 111 | string 112 | (** The input string is recoded from [in_enc] to [out_enc], and HTML 113 | * entities ([&name;] or [&#num;]) are resolved. The input encoding 114 | * [in_enc] must be ASCII-compatible. 115 | * 116 | * By default, the function knows all entities defined for HTML 4 (this 117 | * can be changed using [entity_base], see below). If other 118 | * entities occur, the function [lookup] is called and the name of 119 | * the entity is passed as input string to the function. It is 120 | * expected that [lookup] returns the value of the entity, and that this 121 | * value is already encoded as [out_enc]. 122 | * By default, [lookup] raises a [Failure] exception. 123 | * 124 | * If a character cannot be represented in the output encoding, 125 | * the function [subst] is called. [subst] must return a substitute 126 | * string for the character. 127 | * By default, [subst] raises a [Failure] exception. 128 | * 129 | * The option [entity_base] determines which set of entities are 130 | * considered as the known entities that can be decoded without 131 | * help by the [lookup] function: [`Html] selects all entities defined 132 | * for HTML 4, [`Xml] selects only [<], [>], [&], ["], 133 | * and ['], 134 | * and [`Empty] selects the empty set (i.e. [lookup] is always called). 135 | *) 136 | 137 | end 138 | -------------------------------------------------------------------------------- /network.ml: -------------------------------------------------------------------------------- 1 | open Prelude 2 | 3 | let () = assert (Sys.word_size = 64) 4 | 5 | (* reexport exception *) 6 | include (Devkit_ragel : sig exception Parse_ipv4 of string end) 7 | 8 | type ipv4 = int32 9 | type ipv4_cidr = int32 * int32 10 | 11 | let ipv4_null = 0l 12 | let bytes_of_ipv4 addr = 13 | let a = Int32.to_int @@ Int32.shift_right_logical (Int32.logand 0xFF000000l addr) 24 in 14 | let b = Int32.to_int @@ Int32.shift_right_logical (Int32.logand 0x00FF0000l addr) 16 in 15 | let c = Int32.to_int @@ Int32.shift_right_logical (Int32.logand 0x0000FF00l addr) 8 in 16 | let d = Int32.to_int @@ Int32.logand 0x000000FFl addr in 17 | (a,b,c,d) 18 | 19 | let string_of_ipv4 addr = 20 | let (a,b,c,d) = bytes_of_ipv4 addr in 21 | Printf.sprintf "%u.%u.%u.%u" a b c d 22 | 23 | let ipv4_of_int32 = id 24 | let int32_of_ipv4 = id 25 | 26 | let ipv4_of_int = Int32.of_int 27 | let int_of_ipv4 = Int32.to_int 28 | 29 | (* 30 | 1_500_000 31 | scanf : allocated 73.0GB, heap 0B, collection 0 979 37360, elapsed 43 secs, 23056.45/sec : ok 32 | ocamllex : allocated 11.2GB, heap 0B, collection 0 33 5718, elapsed 17 secs, 57447.94/sec : ok 33 | ragel : allocated 6.5GB, heap 0B, collection 0 0 3319, elapsed 8.07 secs, 123908.12/sec : ok 34 | *) 35 | let ipv4_of_string_exn = Devkit_ragel.parse_ipv4 36 | let ipv4_of_string_null s = try ipv4_of_string_exn s with _ -> 0l 37 | (* 38 | Network.is_ipv4_slow : allocated 8.0GB, heap 0B, collection 0 0 1019, elapsed 1.57 secs, 31.92/sec : ok 39 | Network.is_ipv4 : allocated 625KB, heap 0B, collection 0 0 0, elapsed 0.2477 secs, 201.87/sec : ok 40 | *) 41 | let is_ipv4_slow = Devkit_ragel.is_ipv4_slow 42 | let is_ipv4 s = 43 | String.length s >= 7 44 | && String.length s <= 15 45 | && Stre.ASCII.is_digit s.[String.length s - 1] 46 | && Devkit_ragel.is_ipv4 s 47 | 48 | let class_c ip = Int32.logand 0xFFFFFF00l ip 49 | 50 | module IPv4 = struct 51 | type t = ipv4 52 | let equal = (=) 53 | let compare = Stdlib.compare 54 | let null = ipv4_null 55 | let to_bytes = bytes_of_ipv4 56 | let to_string = string_of_ipv4 57 | let of_string_exn = ipv4_of_string_exn 58 | let of_string_null = ipv4_of_string_null 59 | let of_int32 = ipv4_of_int32 60 | let to_int32 = int32_of_ipv4 61 | let of_int = ipv4_of_int 62 | let to_int = int_of_ipv4 63 | let class_c = class_c 64 | end 65 | 66 | let make_broadcast addr netmask = Int32.logor addr (Int32.lognot netmask) 67 | 68 | let cidr_of_string_exn s = 69 | Scanf.sscanf s "%s@/%u%!" (fun ip len -> 70 | if len < 0 || len > 32 then Exn.fail "bad cidr %s" s; 71 | let mask = if len = 0 then 0l else Int32.lognot @@ Int32.pred @@ Int32.shift_left 1l (32 - len) in 72 | let ip = ipv4_of_string_exn ip in 73 | Int32.logand ip mask, mask) 74 | 75 | let cidr_of_string_exn s = try ipv4_of_string_exn s, -1l with Parse_ipv4 _ -> cidr_of_string_exn s 76 | 77 | let string_of_cidr (ip,mask) = 78 | let rec subnet_bits acc n = if Int32.equal n (-1l) then (32 - acc) else subnet_bits (acc + 1) (Int32.shift_right n 1) in 79 | Printf.sprintf "%s/%s" (string_of_ipv4 ip) (string_of_int @@ subnet_bits 0 (int32_of_ipv4 mask)) 80 | 81 | let range_of_cidr (ip0,mask) = ip0, make_broadcast ip0 mask 82 | 83 | let ipv4_matches ip (prefix, mask) = Int32.logand ip mask = prefix 84 | let prefix_of_cidr = fst 85 | 86 | let special_cidr = List.map cidr_of_string_exn [ 87 | "0.0.0.0/8"; (* Current network (only valid as source address) RFC 1700 *) 88 | "10.0.0.0/8"; (* Private network RFC 1918 *) 89 | "127.0.0.0/8"; (* Loopback RFC 5735 *) 90 | "169.254.0.0/16"; (* Link-Local RFC 3927 *) 91 | "172.16.0.0/12"; (* Private network RFC 1918 *) 92 | "192.0.0.0/24"; (* Reserved (IANA) RFC 5735 *) 93 | "192.0.2.0/24"; (* TEST-NET-1, Documentation and example code RFC 5735 *) 94 | "192.88.99.0/24"; (* IPv6 to IPv4 relay RFC 3068 *) 95 | "192.168.0.0/16"; (* Private network RFC 1918 *) 96 | "198.18.0.0/15"; (* Network benchmark tests RFC 2544 *) 97 | "198.51.100.0/24"; (* TEST-NET-2, Documentation and examples RFC 5737 *) 98 | "203.0.113.0/24"; (* TEST-NET-3, Documentation and examples RFC 5737 *) 99 | "224.0.0.0/4"; (* Multicasts (former Class D network) RFC 3171 *) 100 | "240.0.0.0/4"; (* Reserved (former Class E network) RFC 1700 *) 101 | "255.255.255.255/32"; (* Broadcast RFC 919 *) 102 | ] 103 | 104 | let is_ipv4_special ip = List.exists (ipv4_matches ip) special_cidr 105 | 106 | let public_ipv4_network_ips () = 107 | U.getifaddrs () |> List.filter begin fun (_,ip) -> 108 | match ipv4_of_string_exn ip with 109 | | exception _ -> false 110 | | ip -> not @@ is_ipv4_special ip 111 | end |> List.map (fun (iface,ip) -> iface, Unix.inet_addr_of_string ip) |> List.sort Stdlib.compare 112 | 113 | let private_ipv4_network_ips () = 114 | (* RFC 1918 *) 115 | let private_net = List.map cidr_of_string_exn [ "10.0.0.0/8"; "172.16.0.0/12"; "192.168.0.0/16"; ] in 116 | U.getifaddrs () |> List.filter begin fun (_,ip) -> 117 | match ipv4_of_string_exn ip with 118 | | exception _ -> false 119 | | ip -> List.exists (ipv4_matches ip) private_net 120 | end |> List.map (fun (iface,ip) -> iface, Unix.inet_addr_of_string ip) |> List.sort Stdlib.compare 121 | 122 | let private_ipv4_network_ip () = 123 | match private_ipv4_network_ips () with 124 | | [] -> Unix.inet_addr_loopback 125 | | (_,ip)::_ -> ip 126 | 127 | let public_ipv4_network_ip () = match public_ipv4_network_ips () with [] -> None | (_,ip)::_ -> Some ip 128 | let public_ipv4_network_ip_exn () = match public_ipv4_network_ip () with None -> Exn.fail "Network: no public ipv4 address" | Some ip -> ip 129 | 130 | let public_network_ips = public_ipv4_network_ips 131 | let private_network_ips = private_ipv4_network_ips 132 | let private_network_ip = private_ipv4_network_ip 133 | 134 | let ipv4_to_yojson ip = `String (string_of_ipv4 ip) 135 | let ipv4_of_yojson j = 136 | match j with 137 | | `String i -> begin try Ok (ipv4_of_string_exn i) with exn -> Error (Printf.sprintf "ipv4: cannot parse %S (%s)" i (Exn.to_string exn)) end 138 | | _ -> Error "ipv4: expected string" 139 | -------------------------------------------------------------------------------- /memory.ml: -------------------------------------------------------------------------------- 1 | (** Memory reporting - GC and OS, optionally malloc 2 | 3 | General background: 4 | - VSZ is not very intersting, this is the amount of memory which is mapped to the process address space. 5 | It's not really memory use, only the amount of memory the process can access without triggering a segfault. 6 | - RSS is resident set size: this is the real world data. It's tracked by kernel and is the amount of memory 7 | currently allocated to this process. Most of the time this is what you want to look at. 8 | - Malloc stats: those are metrics tracked by C malloc (jemalloc, tcmalloc, glibc, etc). 9 | - size is basically like VSZ but from malloc point of view. 10 | That is it does not include mmap files for instance. 11 | - used is basically RSS from malloc point of view. 12 | - heap is the sum of all currently malloced values for which [free] had not been called. 13 | So this is what application requested, not including metadata, cache, etc 14 | - Gc stats are one level above and are tracked by ocaml gc. 15 | e.g. heap is the total size allocate for ocaml program. See [Gc] module documentation for more details. 16 | *) 17 | 18 | open Prelude 19 | open ExtLib 20 | open Printf 21 | 22 | let log = Log.from "memory" 23 | 24 | type t = { 25 | rss : int; (** resident set size *) 26 | vsize : int; (** virtual memory size *) 27 | nr_maps : int; (** number of VM mappings *) 28 | swap_used : int; (** used swap size *) 29 | } 30 | 31 | let get_num = int_of_string $ String.replace_chars (fun c -> if Stre.ASCII.is_digit c then String.of_char c else "") 32 | 33 | let pagesize = Int64.to_int ExtUnix.Specific.(sysconf PAGESIZE) 34 | 35 | (** 36 | @param swap whether to compute swap used, can be slow (many seconds), default [false] 37 | @return virtual memory info 38 | *) 39 | let get_vm_info ?(swap=false) () = 40 | let (vsize,rss) = 41 | match Action.file_lines "/proc/self/statm" with 42 | | [] -> Log.self #warn "cannot read /proc/self/statm, no VM info"; (0,0) 43 | | s::_ -> Scanf.sscanf s "%d %d" (fun vsize rss -> (pagesize * vsize, pagesize * rss)) 44 | in 45 | let nr_maps = List.length @@ Action.file_lines ("/proc/self/maps") in (* FIXME deleted *) 46 | (* process smaps *) 47 | let swap_used = 48 | match swap with 49 | | false -> 0 50 | | true -> 51 | Action.file_lines ("/proc/self/smaps") |> 52 | List.fold_left (fun acc s -> if Stre.starts_with s "Swap:" then acc + get_num s else acc) 0 53 | in 54 | { rss; vsize; nr_maps; swap_used = swap_used * 1024; } 55 | 56 | let show_vm_info () = 57 | let bytes = Action.bytes_string in 58 | let { rss; vsize; nr_maps; swap_used } = get_vm_info () in 59 | let swap = if swap_used > 0 then sprintf " %s," (bytes swap_used) else "" in 60 | sprintf "VM: rss %s, vsz %s,%s maps %d" (bytes rss) (bytes vsize) swap nr_maps 61 | 62 | let show_gc_heap ?(st=Gc.quick_stat ()) () = 63 | let open Action in 64 | sprintf "%s (max %s, chunks %d)" 65 | (caml_words st.Gc.heap_words) 66 | (caml_words st.Gc.top_heap_words) 67 | st.Gc.heap_chunks 68 | 69 | let show_gc_info () = 70 | let open Action in 71 | let st = Gc.quick_stat () in 72 | let gc_heap = show_gc_heap ~st () in 73 | let gc_ctrs = 74 | sprintf "%s %s %s" 75 | (caml_words_f st.Gc.minor_words) 76 | (caml_words_f st.Gc.promoted_words) 77 | (caml_words_f st.Gc.major_words) 78 | in 79 | let gc_coll = 80 | sprintf "%u %u %u" 81 | st.Gc.compactions 82 | st.Gc.major_collections 83 | st.Gc.minor_collections 84 | in 85 | sprintf "GC: Heap: %s Counters(mi,pr,ma): %s Collections(mv,ma,mi): %s" gc_heap gc_ctrs gc_coll 86 | 87 | let show_lwt_info () = 88 | let (r, w, t) = Lwt_engine.(readable_count (), writable_count (), timer_count ()) in 89 | sprintf "lwt readable %d, writable %d, timer %d" r w t 90 | 91 | (* hooks for Memory_gperftools *) 92 | let show_crt_info = ref (fun () -> "MALLOC: ?") 93 | let malloc_release = ref (ignore : unit -> unit) 94 | 95 | let reclaim_s () = 96 | let module A = Action in 97 | let st1 = Gc.stat () in 98 | let { rss; _ } = get_vm_info () in 99 | let t1 = Time.now () in 100 | Gc.compact (); 101 | let t2 = Time.now () in 102 | !malloc_release (); 103 | let t3 = Time.now () in 104 | let st3 = Gc.stat () in 105 | let { rss=rss'; _ } = get_vm_info () in 106 | let changed f a b = 107 | if a = b then sprintf "= %s" (f a) else sprintf "%s -> %s" (f a) (f b) 108 | in 109 | sprintf "Memory.reclaim: heap %s live %s freelist %s (%s), rss %s" 110 | (changed A.caml_words st1.heap_words st3.heap_words) 111 | (changed A.caml_words st1.live_words st3.live_words) 112 | (changed string_of_int st1.free_blocks st3.free_blocks) 113 | (Time.duration_str @@ t2 -. t1) 114 | (if !malloc_release == ignore then A.bytes_string rss 115 | else sprintf "%s (%s)" (changed A.bytes_string rss rss') (Time.duration_str @@ t3 -. t2)) 116 | 117 | let reclaim () = log #info "%s" @@ reclaim_s () 118 | 119 | let reclaim_silent () = 120 | Gc.compact (); 121 | !malloc_release () 122 | 123 | let (add_stats,new_stats,log_stats,get_stats) = 124 | let f_print = ref [] in (* called in reverse - and it is fine *) 125 | let f_get = ref [] in 126 | let log_stats () = 127 | List.iter (fun f -> f ()) !f_print; 128 | List.iter (fun f -> log #info_s @@ f ()) !f_get 129 | in 130 | let get_stats () = List.map (fun f -> f ()) !f_get in 131 | (tuck f_print), (tuck f_get), log_stats, get_stats 132 | 133 | let track_global = ref [] 134 | let show_global_reachable () = 135 | let l = List.map (fun (name,repr) -> sprintf "%s %s" name (Action.caml_words @@ Obj.reachable_words repr)) !track_global in 136 | sprintf "reachable: %s" (String.concat " " l) 137 | let track_global name var = tuck track_global (name,Obj.repr var) 138 | 139 | let show_c_info () = sprintf "%s. %s" (show_vm_info ()) (!show_crt_info ()) 140 | 141 | let show_all_info () = 142 | [ 143 | show_c_info (); 144 | show_gc_info (); 145 | show_lwt_info (); 146 | ] 147 | 148 | let log_all_info () = show_all_info () |> List.iter log#info_s 149 | 150 | let () = new_stats show_c_info 151 | let () = new_stats show_gc_info 152 | let () = new_stats show_lwt_info 153 | let () = new_stats show_global_reachable 154 | -------------------------------------------------------------------------------- /httpev_common.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | type encoding = Gzip | Identity 4 | 5 | type meth = [ 6 | | `GET 7 | | `POST 8 | | `PUT 9 | | `PATCH 10 | | `DELETE 11 | | `HEAD 12 | | `OPTIONS 13 | ] 14 | 15 | type request = { addr : Unix.sockaddr; 16 | url : string; (* path and arguments *) 17 | path : string; 18 | args : (string * string) list; 19 | conn : Time.t; (* time when client connected *) 20 | recv : Time.t; (* time when client request was fully read *) 21 | meth : meth; 22 | headers : (string * string) list; 23 | body : string; 24 | version : int * int; (* client HTTP version *) 25 | id : int; (* request id *) 26 | socket : Unix.file_descr; 27 | line : string; (** request line *) 28 | mutable blocking : unit IO.output option; (* hack for forked childs *) 29 | encoding : encoding; 30 | } 31 | 32 | type status_code = 33 | [ `Ok 34 | | `Created 35 | | `Accepted 36 | | `No_content 37 | | `Found 38 | | `Moved 39 | | `Bad_request 40 | | `Unauthorized 41 | | `Payment_required 42 | | `Forbidden 43 | | `Not_found 44 | | `Method_not_allowed 45 | | `Not_acceptable 46 | | `Conflict 47 | | `Length_required 48 | | `Request_too_large 49 | | `I'm_a_teapot 50 | | `Unprocessable_content 51 | | `Too_many_requests 52 | | `Internal_server_error 53 | | `Not_implemented 54 | | `Service_unavailable 55 | | `Version_not_supported ] 56 | 57 | type reply_status = [ status_code | `Custom of string ] 58 | type extended_reply_status = [ reply_status | `No_reply ] 59 | 60 | type 'status reply' = 'status * (string * string) list * string 61 | type reply = extended_reply_status reply' 62 | 63 | let show_method = function 64 | | `GET -> "GET" 65 | | `POST -> "POST" 66 | | `PUT -> "PUT" 67 | | `PATCH -> "PATCH" 68 | | `DELETE -> "DELETE" 69 | | `HEAD -> "HEAD" 70 | | `OPTIONS -> "OPTIONS" 71 | 72 | let method_of_string = function 73 | | "GET" -> `GET 74 | | "POST" -> `POST 75 | | "PUT" -> `PUT 76 | | "PATCH" -> `PATCH 77 | | "DELETE" -> `DELETE 78 | | "HEAD" -> `HEAD 79 | | "OPTIONS" -> `OPTIONS 80 | | s -> Exn.fail "method_of_string %s" s 81 | 82 | let show_client_addr ?(via=[Unix.inet_addr_loopback]) req = 83 | let header_or default = try List.assoc "x-real-ip" req.headers with Not_found -> default in 84 | match req.addr with 85 | | Unix.ADDR_UNIX _ -> header_or @@ Nix.show_addr req.addr 86 | | ADDR_INET (addr,_) when List.mem addr via -> header_or @@ Unix.string_of_inet_addr addr 87 | | ADDR_INET (addr,_) -> Unix.string_of_inet_addr addr 88 | 89 | let client_addr req = match req.addr with Unix.ADDR_INET (addr,port) -> addr, port | _ -> assert false 90 | let client_ip req = fst @@ client_addr req 91 | 92 | let find_header req name = List.assoc (String.lowercase_ascii name) req.headers 93 | let header_exn req name = try find_header req name with _ -> Exn.fail "header %S" name 94 | let header_safe req name = try find_header req name with _ -> "" 95 | let header_referer req = try find_header req "Referer" with _ -> try find_header req "Referrer" with _ -> "" 96 | 97 | let show_request req = 98 | sprintf "#%d %s time %.4f (recv %.4f) %s %s%s %S %S" 99 | req.id 100 | (show_client_addr req) 101 | (Time.get () -. req.conn) 102 | (req.recv -. req.conn) 103 | (show_method req.meth) 104 | (header_safe req "host") 105 | req.url 106 | (header_safe req "user-agent") 107 | (header_safe req "x-request-id") 108 | 109 | let status_code : reply_status -> int = function 110 | | `Ok -> 200 111 | | `Created -> 201 112 | | `Accepted -> 202 113 | | `No_content -> 204 114 | 115 | | `Moved -> 301 116 | | `Found -> 302 117 | 118 | | `Bad_request -> 400 119 | | `Unauthorized -> 401 120 | | `Payment_required -> 402 121 | | `Forbidden -> 403 122 | | `Not_found -> 404 123 | | `Method_not_allowed -> 405 124 | | `Not_acceptable -> 406 125 | | `Conflict -> 409 126 | | `Length_required -> 411 127 | | `Request_too_large -> 413 128 | | `I'm_a_teapot -> 418 129 | | `Unprocessable_content -> 422 130 | | `Too_many_requests -> 429 131 | 132 | | `Internal_server_error -> 500 133 | | `Not_implemented -> 501 134 | | `Service_unavailable -> 503 135 | | `Version_not_supported -> 505 136 | 137 | | `Custom _ -> 999 138 | 139 | let show_http_version = function 140 | | `Http_1_0 -> "HTTP/1.0" 141 | | `Http_1_1 -> "HTTP/1.1" 142 | 143 | let show_status_code : status_code -> string = function 144 | | `Ok -> "200 OK" 145 | | `Created -> "201 Created" 146 | | `Accepted -> "202 Accepted" 147 | | `No_content -> "204 No Content" 148 | 149 | | `Moved -> "301 Moved Permanently" 150 | | `Found -> "302 Found" 151 | 152 | | `Bad_request -> "400 Bad Request" 153 | | `Unauthorized -> "401 Unauthorized" 154 | | `Payment_required -> "402 Payment Required" 155 | | `Forbidden -> "403 Forbidden" 156 | | `Not_found -> "404 Not Found" 157 | | `Method_not_allowed -> "405 Method Not Allowed" 158 | | `Not_acceptable -> "406 Not Acceptable" 159 | | `Conflict -> "409 Conflict" 160 | | `Length_required -> "411 Length Required" 161 | | `Request_too_large -> "413 Request Entity Too Large" 162 | | `I'm_a_teapot -> "418 I'm a teapot" 163 | | `Unprocessable_content -> "422 Unprocessable Content" 164 | | `Too_many_requests -> "429 Too Many Requests" 165 | 166 | | `Internal_server_error -> "500 Internal Server Error" 167 | | `Not_implemented -> "501 Not Implemented" 168 | | `Service_unavailable -> "503 Service Unavailable" 169 | | `Version_not_supported -> "505 HTTP Version Not Supported" 170 | 171 | let show_http_reply : version:[ `Http_1_0 | `Http_1_1 ] -> reply_status -> string = 172 | fun ~version reply_status -> 173 | match reply_status with 174 | | `Custom s -> s 175 | | #status_code as code -> sprintf "%s %s" (show_http_version version) (show_status_code code) 176 | 177 | (* basically allow all *) 178 | let cors_preflight_allow_all = (`No_content, [ 179 | "Access-Control-Allow-Origin", "*"; 180 | "Access-Control-Allow-Methods", "GET, POST, OPTIONS, PUT, PATCH, DELETE, HEAD"; 181 | "Access-Control-Max-Age", "600"; 182 | ], "") 183 | -------------------------------------------------------------------------------- /static_config.ml: -------------------------------------------------------------------------------- 1 | open Prelude 2 | open Printf 3 | open ExtLib 4 | 5 | exception Error of string 6 | 7 | let fail fmt = ksprintf (fun s -> raise (Error s)) fmt 8 | 9 | module Label : sig 10 | type t = private string 11 | val make : string -> t 12 | end = struct 13 | type t = string 14 | let make s = 15 | let open Stre.ASCII in 16 | if s <> "" && is_alpha s.[0] && (List.for_all (fun c -> c = '_' || is_alnum c) @@ String.explode s) then 17 | s 18 | else 19 | fail "bad label %S" s 20 | end 21 | 22 | let make_value v (show : 'a -> string) (load : string -> 'a) = 23 | object 24 | val mutable contents = v 25 | val mutable dirty = false 26 | method get = contents 27 | method set y = dirty <- true; contents <- y 28 | method show = show contents 29 | method load s = dirty <- true; contents <- load s 30 | method dirty = dirty 31 | method reset = dirty <- false; contents <- v 32 | end 33 | 34 | type any_value = < show : string; load : string -> unit; dirty : bool; reset : unit; > 35 | type 'a value = < get : 'a; set : 'a -> unit; dirty : bool; > 36 | 37 | type group = { label : Label.t; groups : (Label.t, group) Hashtbl.t; values : (Label.t, any_value) Hashtbl.t; parent : group option; } 38 | 39 | let group_name g = 40 | let rec loop acc g = 41 | match g.parent with 42 | | None -> String.concat "." (List.rev acc) 43 | | Some g' -> loop ((g.label :> string) :: acc) g' 44 | in 45 | loop [] g 46 | 47 | let value_name g (k:Label.t) = 48 | match group_name g with 49 | | "" -> (k:>string) 50 | | s -> s ^ "." ^ (k:>string) 51 | 52 | let make_node show load group label (v : 'a) = 53 | let label = Label.make label in 54 | if Hashtbl.mem group.values label then fail "duplicate label %S" (label :> string); 55 | let v = make_value v show load in 56 | Hashtbl.replace group.values label (v :> any_value); 57 | (v :> 'a value) 58 | 59 | let int = make_node string_of_int int_of_string 60 | let long = make_node Int64.to_string Int64.of_string 61 | let string = make_node id id 62 | let float = make_node string_of_float float_of_string 63 | let bool = make_node string_of_bool (fun s -> match String.lowercase_ascii s with 64 | | "false" | "no" -> false 65 | | "true" | "yes" -> true 66 | | s -> fail "not a boolean : %S" s) 67 | 68 | let group parent label = 69 | let label = Label.make label in 70 | match Hashtbl.find_option parent.groups label with 71 | | Some x -> x 72 | | None -> 73 | let group = { label = label; parent = Some parent; groups = Hashtbl.create 1; values = Hashtbl.create 1; } in 74 | Hashtbl.add parent.groups label group; 75 | group 76 | 77 | let new_root () = { parent = None; groups = Hashtbl.create 1; values = Hashtbl.create 1; label = Label.make "whatever"; } 78 | 79 | let rec iter f g = 80 | Hashtbl.iter (fun k v -> f (value_name g k) v) g.values; 81 | Hashtbl.iter (fun _ g -> iter f g) g.groups 82 | 83 | let reset = iter (fun _ v -> v#reset) 84 | 85 | let read root s = 86 | reset root; 87 | let store k v = 88 | let rec loop g = function 89 | | [name] -> Hashtbl.find g.values name 90 | | x::xs -> loop (Hashtbl.find g.groups x) xs 91 | | [] -> fail "bad key %S" k 92 | in 93 | let o = loop root (List.map Label.make @@ Stre.nsplitc k '.') in 94 | o#load v 95 | in 96 | let store k v = 97 | try 98 | store k v 99 | with 100 | (* | Not_found -> prerr_endline (Printf.sprintf "Skipping unknown option : %S = %S" k v) *) 101 | | exn -> fail "Failed to store option : %S = %S : %s" k v (Exn.to_string exn) 102 | in 103 | let io = IO.input_string s in 104 | let line = ref 0 in 105 | try while true do 106 | match Exn.catch IO.read_line io with 107 | | None -> raise Exit 108 | | Some s -> 109 | let s = s ^ "\n" in 110 | incr line; 111 | try 112 | Scanf.sscanf s " #" () 113 | with Scanf.Scan_failure _ | End_of_file -> 114 | try 115 | Scanf.sscanf s " %!" () 116 | with Scanf.Scan_failure _ | End_of_file -> 117 | try 118 | Scanf.sscanf s "%s = %s@\n%!" (fun k v -> store k (String.strip v)) 119 | with Scanf.Scan_failure _ | End_of_file -> 120 | try 121 | Scanf.sscanf s "%s := %c%s@\n%!" (fun k c tail -> 122 | let pos = String.index tail c in 123 | String.iter (function ' ' | '\t' -> () | _ -> fail "extra characters after %C-delimtied value" c) 124 | (String.slice tail ~first:(pos+1)); 125 | store k (String.slice tail ~last:pos)) 126 | with Scanf.Scan_failure _ | End_of_file -> 127 | try 128 | Scanf.sscanf s "%s : %d\n%!" (fun k n -> 129 | assert (n >= 0); 130 | let l = List.init (n+1) (fun _ -> incr line; IO.read_line io) in 131 | store k (String.concat "\n" l)) 132 | with Scanf.Scan_failure _ | End_of_file -> fail "can't parse line" 133 | done with 134 | | Exit -> () 135 | | exn -> 136 | let s = match exn with Failure s -> s | Error s -> s | exn -> Exn.to_string exn in 137 | fail "error at line %d : %s" !line s 138 | 139 | let choose_quote s = 140 | let preferred = [ '"'; '\''; '`'; '|'; '!'; '@'; '#'; '%' ] in 141 | let ok = Array.make 256 true in 142 | String.iter (fun c -> ok.(Char.code c) <- false) s; 143 | try 144 | Some (List.find (fun c -> ok.(Char.code c)) preferred) 145 | with 146 | Not_found -> None 147 | 148 | let show ?(all=false) root = 149 | let iter f = iter (fun name v -> if v#dirty || all then f name v#show) in 150 | let b = Buffer.create 10 in 151 | iter begin fun name v -> 152 | match String.fold_left (fun n c -> if c = '\n' then n + 1 else n) 0 v with 153 | | 0 -> 154 | if Stre.starts_with v " " || Stre.ends_with v " " then 155 | begin match choose_quote v with 156 | | None -> bprintf b "%s :%d\n%s\n" name 0 v 157 | | Some c -> bprintf b "%s := %c%s%c\n" name c v c 158 | end 159 | else 160 | bprintf b "%s = %s\n" name v 161 | | n -> 162 | bprintf b "%s :%d\n%s\n" name n v 163 | end root; 164 | Buffer.contents b 165 | 166 | let load root file = reset root; match Exn.catch Std.input_file file with None -> () | Some s -> read root s 167 | let save ?all root file = Files.save_as file (fun ch -> output_string ch (show ?all root)) 168 | 169 | class base root filename = 170 | object 171 | initializer 172 | load root filename 173 | method save () = save root filename 174 | method load () = load root filename 175 | end 176 | -------------------------------------------------------------------------------- /var.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open ExtLib 3 | open Prelude 4 | 5 | let log = Log.from "var" 6 | 7 | let show_a = Stre.list (uncurry @@ sprintf "%S:%S") 8 | 9 | module Attr : sig 10 | type t = private (string * string) list 11 | val make : (string * string) list -> t 12 | val add : (string * string) -> t -> t 13 | val get : t -> (string * string) list 14 | end = struct 15 | type t = (string * string) list 16 | let add (k,_ as x) l = 17 | if List.mem_assoc k l then Exn.fail "duplicate attribute %S" k; 18 | List.sort ~cmp:compare (x :: l) 19 | let make l = 20 | let a = List.unique ~cmp:(fun (a,_) (b,_) -> a = b) l in 21 | if List.length a <> List.length l then Exn.fail "duplicate attributes : %s" (show_a l); 22 | List.sort ~cmp:compare l 23 | let get = identity 24 | end 25 | 26 | type attributes = (string * string) list 27 | type t = Time of Time.t | Count of int | Bytes of int 28 | type group = { k : string; attr : Attr.t; mutable get : (unit -> (string * t option) list) list; } 29 | 30 | let h_families = Hashtbl.create 10 31 | 32 | let show_value = function 33 | | Time t -> Time.compact_duration t 34 | | Count c -> string_of_int c 35 | | Bytes b -> Action.bytes_string b 36 | 37 | let make_family ~name ~k ~attr = 38 | let family = Attr.make (("class",name)::attr) in 39 | let (_:Attr.t) = Attr.add (k,"") family in (* check that all keys are unique *) 40 | (k,family) 41 | 42 | let register (k,family) get = 43 | match Hashtbl.find h_families family with 44 | | exception Not_found -> Hashtbl.replace h_families family { k; attr = family; get = [get] } (* register new family *) 45 | | r -> (* expand existing family *) 46 | log #warn "duplicate Var %s" (show_a @@ Attr.get family); 47 | r.get <- get :: r.get 48 | 49 | let unregister (_k,family) = Hashtbl.remove h_families family 50 | 51 | let is_in_families name = 52 | Hashtbl.fold begin fun k _ a -> 53 | match a with 54 | | true -> true 55 | | false -> List.exists (fun e -> e = ("class",name)) (Attr.get k) 56 | end h_families false 57 | 58 | let make_cc f pp name ?(attr=[]) k = 59 | let cc = Cache.Count.create () in 60 | let get () = Cache.Count.fold cc (fun k n acc -> (pp k, f n) :: acc) [] in 61 | register (make_family ~name ~k ~attr) get; 62 | cc 63 | 64 | let cc f = make_cc (fun n -> Some (Count n)) f 65 | let cc_ms f = make_cc (fun n -> Some (Time (float n /. 1000.))) f 66 | 67 | class typ name ?(attr=[]) k_name = (* name+attr - family of counters *) 68 | let get_all h = 69 | Hashtbl.fold begin fun k v acc -> (* return all counters created for this instance *) 70 | match v () with 71 | | exception exn -> log #warn ~exn "variable %S %s failed" name (show_a @@ (k_name,k)::attr); acc 72 | | v -> (k, v) :: acc end h [] 73 | in 74 | object(self) 75 | val h = Hashtbl.create 7 76 | val family = make_family ~k:k_name ~attr ~name 77 | initializer 78 | register family (fun () -> get_all h) 79 | method ref : 'a. 'a -> ('a -> t) -> string -> 'a ref = fun init f counter_name -> 80 | if Hashtbl.exists h counter_name then log#warn "counter %S already exists for %S" counter_name name; 81 | let v = ref init in 82 | Hashtbl.replace h counter_name (fun () -> some @@ f !v); 83 | v 84 | (* f() either returns Some value, either returns None, informing that value could not be obtained *) 85 | method get_count name f = Hashtbl.replace h name (fun () -> match f() with | Some x -> Some (Count x) | _ -> None) 86 | method get_bytes name f = Hashtbl.replace h name (fun () -> match f() with | Some x -> Some (Bytes x) | _ -> None) 87 | method get_time name f = Hashtbl.replace h name (fun () -> match f() with | Some x -> Some (Time x) | _ -> None) 88 | method count name = self#ref 0 (fun x -> Count x) name 89 | method bytes name = self#ref 0 (fun x -> Bytes x) name 90 | method time name = self#ref 0. (fun x -> Time x) name 91 | method unregister () = unregister family 92 | method get = 93 | get_all h |> List.filter_map (fun (k,v) -> match v with None -> None | Some v -> Some (k,v)) 94 | method show = 95 | self#get |> List.map (fun (k,v) -> sprintf "%s: %s" k (show_value v)) |> String.concat ", " 96 | end 97 | 98 | let iter f = 99 | h_families |> Hashtbl.iter begin fun name g -> (* iterate over counter families *) 100 | match g.get with 101 | | [get] -> (* no duplicates in this family *) 102 | let l = get () in 103 | let l' = List.sort_uniq (fun (a,_) (b,_) -> String.compare a b) l in 104 | if List.length l <> List.length l' then log#warn "var %s : duplicate keys found and will be ignored" (show_a @@ Attr.get name); 105 | l' |> List.iter begin fun (k,v) -> 106 | let attr = (g.k, k) :: Attr.get g.attr in (* this was checked to be valid in [register] *) 107 | match v with Some v -> f attr v | _ -> () 108 | end 109 | | l -> (* list of getters for all instances created with this family name *) 110 | let h = Hashtbl.create 10 in 111 | l |> List.iter begin fun get -> 112 | get () |> List.iter begin fun (k, vl) -> (* merge values of duplicated counters in family *) 113 | match vl with 114 | | Some v -> 115 | let r = match Hashtbl.find h k with 116 | | exception Not_found -> Some v 117 | | Some x -> begin 118 | match x, v with 119 | | Time a, Time b -> Some (Time (a+.b)) 120 | | Count a, Count b -> Some (Count (a+b)) 121 | | Bytes a, Bytes b -> Some (Bytes (a+b)) 122 | | Count _, Bytes _ | Count _, Time _ 123 | | Bytes _, Count _ | Bytes _, Time _ 124 | | Time _, Count _ | Time _, Bytes _ -> log #warn "mismatched value type for %S in %s" k (show_a @@ Attr.get g.attr); Some v 125 | end 126 | | None -> None 127 | in 128 | Hashtbl.replace h k r 129 | | None -> Hashtbl.replace h k None (* if at least one duplicate value is invalid - ignore all data for this counter *) 130 | end; 131 | end; 132 | h |> Hashtbl.iter begin fun k v -> 133 | let attr = (g.k, k) :: Attr.get g.attr in (* this was checked to be valid in [register] *) 134 | match v with Some v -> f attr v | _ -> () 135 | end 136 | end 137 | 138 | let list_stats filter = 139 | let l = ref [] in 140 | iter begin fun attrs v -> 141 | try 142 | let klass = List.assoc "class" attrs in 143 | if not @@ List.mem klass filter then raise Not_found; (* not interested stats *) 144 | let attrs = List.remove_assoc "class" attrs |> List.map (uncurry @@ sprintf "%s.%s") |> String.join "," in 145 | let value = show_value v in 146 | tuck l @@ sprintf "%s %s : %s" klass attrs value 147 | with Not_found -> () 148 | end; 149 | List.sort !l 150 | 151 | (* 152 | let show () = 153 | let b = Buffer.create (Hashtbl.length h_vars * 20) in 154 | iter begin fun ~t ~k ~kname:_ ~v -> 155 | Printf.bprintf b "%s[%s]=%s " t k (match v with Int n -> string_of_int n | Float f -> string_of_float f); 156 | end; 157 | Buffer.contents b 158 | *) 159 | 160 | (* non-monotonic, pointless to log*) 161 | (* let system_memory = new typ "system_memory" "kind" *) 162 | (* let () = system_memory#get_bytes "rss" (fun () -> (Memory.get_vm_info ()).rss) *) 163 | (* let () = system_memory#get_bytes "vsize" (fun () -> (Memory.get_vm_info ()).vsize) *) 164 | (* let () = system_memory#get_bytes "ocaml_heap" (fun () -> let gc = Gc.quick_stat () in Action.bytes_of_words gc.heap_words) *) 165 | -------------------------------------------------------------------------------- /log.ml: -------------------------------------------------------------------------------- 1 | (** 2 | Global ready-to-use logger 3 | 4 | TODO interface to manage State 5 | *) 6 | 7 | (** 8 | {2 Example usage} 9 | 10 | Create logging facility (messages origin) 11 | {[let http = Log.facility "http"]} 12 | 13 | Log from http subsystem at debug level 14 | {[Log.debug http "received %u bytes"]} 15 | 16 | Create and use object for http logging 17 | {[let log = Log.from "http" (* new Log.logger http *);; 18 | log#info "sent %u bytes" 1024 19 | log#warn ~exn "failed here" 20 | ]} 21 | 22 | Output only messages of warning level or higher for the http facility 23 | {[http#allow `Warn]} 24 | or 25 | {[Logger.set_filter http `Warn]} 26 | or 27 | {[Log.set_filter ~name:"http" `Warn]} 28 | or 29 | {[Log.set_filter ~name:"http*" `Warn]} to set for all facilities starting with "http" 30 | 31 | Output only messages of warning level or higher for all facilities 32 | {[Log.set_filter `Warn]} 33 | 34 | {2 API} 35 | *) 36 | 37 | open Printf 38 | open ExtLib 39 | open Prelude 40 | 41 | (** Global logger state *) 42 | module State = struct 43 | 44 | let all = Hashtbl.create 10 45 | let default_level = ref (`Info : Logger.level) 46 | 47 | let utc_timezone = ref false 48 | 49 | let facility name = 50 | try 51 | Hashtbl.find all name 52 | with 53 | Not_found -> 54 | let x = { Logger.name = name; show = Logger.int_level !default_level } in 55 | Hashtbl.add all name x; 56 | x 57 | 58 | let set_filter ?name level = 59 | match name with 60 | | None -> default_level := level; Hashtbl.iter (fun _ x -> Logger.set_filter x level) all 61 | | Some name when Stre.ends_with name "*" -> 62 | let prefix = String.slice ~last:(-1) name in 63 | Hashtbl.iter (fun k x -> if Stre.starts_with k prefix then Logger.set_filter x level) all 64 | | Some name -> Logger.set_filter (facility name) level 65 | 66 | let set_loglevels s = 67 | Stre.nsplitc s ',' |> List.iter begin fun spec -> 68 | match Stre.nsplitc spec '=' with 69 | | name :: l :: [] -> set_filter ~name (Logger.level l) 70 | | l :: [] -> set_filter @@ Logger.level l 71 | | _ -> Exn.fail "loglevel not recognized, specify either or = or *=" 72 | end 73 | 74 | let read_env_config ?(env="DEVKIT_LOG") () = 75 | set_loglevels @@ try Sys.getenv env with Not_found -> "" 76 | 77 | let output_ch ch = 78 | fun str -> try output_string ch str; flush ch with _ -> () (* logging never fails, most probably ENOSPC *) 79 | 80 | let format_simple level facil msg = 81 | let pid = Unix.getpid () in 82 | let tid = U.gettid () in 83 | let pinfo = if pid = tid then sprintf "%5u:" pid else sprintf "%5u:%u" pid tid in 84 | sprintf "[%s] %s [%s:%s] %s\n" 85 | (Time.to_string ~gmt:!utc_timezone ~ms:true (Unix.gettimeofday ())) 86 | pinfo 87 | facil.Logger.name 88 | (Logger.string_level level) 89 | msg 90 | 91 | let log_ch = stderr 92 | let () = assert (Unix.descr_of_out_channel stderr = Unix.stderr) 93 | let base_name = ref "" 94 | 95 | let hook = ref (fun _ _ _ -> ()) 96 | 97 | module Put = Logger.PutSimple( 98 | struct 99 | let format = format_simple 100 | let output = fun level facil s -> let () = !hook level facil s in output_ch log_ch s 101 | end) 102 | 103 | module M = Logger.Make(Put) 104 | 105 | let self = "lib" 106 | 107 | (* 108 | we open the new fd, then dup it to stderr and close afterwards 109 | so we are always logging to stderr 110 | *) 111 | let reopen_log_ch ?(self_call=false) file = 112 | try 113 | if self_call = false then base_name := file; 114 | let ch = Files.open_out_append_text file in 115 | Std.finally 116 | (fun () -> close_out_noerr ch) 117 | (fun () -> Unix.dup2 (Unix.descr_of_out_channel ch) Unix.stderr) 118 | () 119 | with 120 | e -> M.warn (facility self) "reopen_log_ch(%s) failed : %s" file (Printexc.to_string e) 121 | 122 | end 123 | 124 | include State.M 125 | 126 | let facility = State.facility 127 | let set_filter = State.set_filter 128 | let set_loglevels = State.set_loglevels 129 | let set_utc () = State.utc_timezone := true 130 | 131 | (** Update facilities configuration from the environment. 132 | 133 | By default, it reads the configuration in the environment variable [DEVKIT_LOG] 134 | which can be overwritten using the optional [process_name] parameter. 135 | 136 | The value of environment variable should match the following grammar: [(\[=\]debug|info|warn|error\[,\])*] 137 | 138 | @raise Failure on invalid level values of wrong format 139 | *) 140 | let read_env_config = State.read_env_config 141 | 142 | (** 143 | param [lines]: whether to split multiline message as separate log lines (default [true]) 144 | 145 | param [backtrace]: whether to show backtrace if [exn] is given (default is [false]) 146 | 147 | param [saved_backtrace]: supply backtrace to show instead of using [Printexc.get_backtrace] 148 | *) 149 | type 'a pr = ?exn:exn -> ?lines:bool -> ?backtrace:bool -> ?saved_backtrace:string list -> ('a, unit, string, unit) format4 -> 'a 150 | 151 | class logger facil = 152 | let make_s output_line = 153 | let output = function 154 | | true -> 155 | fun facil s -> 156 | if String.contains s '\n' then 157 | List.iter (output_line facil) @@ String.nsplit s "\n" 158 | else 159 | output_line facil s 160 | | false -> output_line 161 | in 162 | let print_bt lines exn bt s = 163 | output lines facil (s ^ " : exn " ^ Exn.str exn ^ (if bt = [] then " (no backtrace)" else "")); 164 | List.iter (fun line -> output_line facil (" " ^ line)) bt 165 | in 166 | fun ?exn ?(lines=true) ?(backtrace=false) ?saved_backtrace s -> 167 | try 168 | match exn with 169 | | None -> output lines facil s 170 | | Some exn -> 171 | match saved_backtrace with 172 | | Some bt -> print_bt lines exn bt s 173 | | None -> 174 | match backtrace with 175 | | true -> print_bt lines exn (Exn.get_backtrace ()) s 176 | | false -> output lines facil (s ^ " : exn " ^ Exn.str exn) 177 | with exn -> 178 | output_line facil (sprintf "LOG FAILED : %S with message %S" (Exn.str exn) s) 179 | in 180 | let make output ?exn ?lines ?backtrace ?saved_backtrace fmt = 181 | ksprintf (fun s -> output ?exn ?lines ?backtrace ?saved_backtrace s) fmt 182 | in 183 | let debug_s = make_s debug_s in 184 | let warn_s = make_s warn_s in 185 | let info_s = make_s info_s in 186 | let error_s = make_s error_s in 187 | let put_s level = make_s (put_s level) in 188 | object 189 | method debug_s = debug_s 190 | method warn_s = warn_s 191 | method info_s = info_s 192 | method error_s = error_s 193 | method put_s = put_s 194 | 195 | (* expecting direct inlining to be faster but it is not o_O 196 | method debug : 'a. 'a pr = 197 | fun ?exn ?lines ?backtrace ?saved_backtrace fmt -> 198 | ksprintf (fun s -> debug_s ?exn ?lines ?backtrace ?saved_backtrace s) fmt 199 | *) 200 | method debug : 'a. 'a pr = make debug_s 201 | method warn : 'a. 'a pr = make warn_s 202 | method info : 'a. 'a pr = make info_s 203 | method error : 'a. 'a pr = make error_s 204 | method put : 'a. Logger.level -> 'a pr = fun level -> make (put_s level) 205 | 206 | method allow (level:Logger.level) = Logger.set_filter facil level 207 | method level : Logger.level = Logger.get_level facil 208 | method name = facil.Logger.name 209 | method facility : Logger.facil = facil 210 | end 211 | 212 | let from name = new logger (facility name) 213 | 214 | (** internal logging facility *) 215 | let self = from State.self 216 | 217 | (** general logging facility *) 218 | let main = from "main" 219 | 220 | (** reopen log file *) 221 | let reopen = function 222 | | None -> () 223 | | Some name -> State.reopen_log_ch name 224 | 225 | let log_start = ref (Time.now()) 226 | let cur_size = ref 0 227 | -------------------------------------------------------------------------------- /lwt_mark.ml: -------------------------------------------------------------------------------- 1 | open ExtLib 2 | open Prelude 3 | 4 | let last_logs_max = 10 5 | 6 | let enabled = ref false 7 | 8 | let is_enabled () = !enabled 9 | 10 | (**) 11 | 12 | module LastN = struct 13 | 14 | type 'a t = 15 | { queue : 'a Queue.t; 16 | mutable avail : int; 17 | } 18 | 19 | let create n = 20 | if n < 0 then invalid_arg "LastN.create: n < 0" else 21 | { queue = Queue.create (); avail = n } 22 | 23 | let add x t = 24 | Queue.push x t.queue; 25 | if t.avail = 0 then 26 | ignore (Queue.pop t.queue) 27 | else 28 | t.avail <- t.avail - 1 29 | 30 | let to_list t = 31 | List.rev @@ Queue.fold (fun acc x -> x :: acc) [] t.queue 32 | 33 | end 34 | 35 | (**) 36 | 37 | type id = int 38 | 39 | type kind = 40 | | Normal 41 | | Background 42 | | Status 43 | 44 | type lazy_string = string Lazy.t 45 | 46 | type mark = 47 | { id : id; 48 | kind : kind; 49 | name : lazy_string; 50 | parent_name : lazy_string; 51 | parent_id : id; 52 | (** [id] is stored to find parent thread in !marks, but there are no direct links to parent's mark. 53 | [parent_{name,id}] don't reflect Lwt scheduling (so background thread's parent is not set to main/unnamed/toplevel); they are 54 | used to trace places where threads were born (control flow). *) 55 | logs : lazy_string LastN.t; 56 | } 57 | 58 | (**) 59 | 60 | let string_of_kind = function 61 | | Normal -> "normal" 62 | | Background -> "background" 63 | | Status -> "status" 64 | 65 | (** [0] is a special value, not used by threads. *) 66 | let next_mark_id = ref 1 67 | 68 | let marks : (int, mark) Hashtbl.t = Hashtbl.create 7 69 | 70 | let create ~name ~parent_id ~parent_name ~kind = 71 | { id = (let id = !next_mark_id in next_mark_id := id + 1; id); 72 | name; 73 | parent_id; 74 | parent_name; 75 | logs = LastN.create last_logs_max; 76 | kind; 77 | } 78 | 79 | let register_mark m = 80 | match Hashtbl.find marks m.id with 81 | | exception Not_found -> Hashtbl.add marks m.id m 82 | | _ -> assert false 83 | 84 | let unregister_mark m = 85 | match Hashtbl.find marks m.id with 86 | | _ -> Hashtbl.remove marks m.id 87 | | exception Not_found -> assert false 88 | 89 | let special name = 90 | let m = create ~name:(Lazy.from_val name) ~parent_id:0 ~parent_name:(Lazy.from_val "") ~kind:Normal in 91 | register_mark m; 92 | m 93 | 94 | (** dummy parent of threads created by parents without mark *) 95 | let top_mark = special "" 96 | 97 | (** dummy parent of threads/statuses which parent has terminated *) 98 | let orphan_mark = special "" 99 | 100 | (**) 101 | 102 | let log_add_line mark msg = 103 | let msg = lazy begin 104 | let msg = !!msg in 105 | if Stre.ends_with msg "\n" then msg else msg ^ "\n" 106 | end 107 | in 108 | LastN.add msg mark.logs 109 | 110 | let log_to mark msg = 111 | if not !enabled then () else 112 | log_add_line mark msg 113 | 114 | let key = Lwt.new_key () 115 | 116 | let with_mark v f = 117 | Lwt.with_value key v f 118 | 119 | let run_thread on_success on_failure func = 120 | match func () with 121 | | thr -> Lwt.on_any thr on_success on_failure; thr 122 | | exception exn -> on_failure exn; Lwt.reraise exn 123 | 124 | let mark_or_orphan id = 125 | try Hashtbl.find marks id with Not_found -> orphan_mark 126 | 127 | let log_exit mark msg = 128 | let parent = mark_or_orphan mark.parent_id in 129 | log_to parent begin 130 | let {name; id; kind; parent_name; parent_id; logs = _} = mark in 131 | lazy begin 132 | Printf.sprintf "thread %S (#%i, %s%s) exit %s\n" 133 | !!name id (string_of_kind kind) 134 | (if parent == orphan_mark then Printf.sprintf ", parent was %s#%i" !!parent_name parent_id else "") 135 | !!msg 136 | end 137 | end 138 | 139 | (** separate function to ease reasoning about which values are kept in closures (here: only arguments and top-level values, no local 140 | bindings from [with_new_mark]) *) 141 | let run_with_mark ?dump ?log:(log : Log.logger option) ~mark cont () = 142 | register_mark mark; 143 | let on_success v = 144 | unregister_mark mark; 145 | log_exit mark @@ lazy begin 146 | "ok" ^ (match dump with None -> "" | Some dump -> ", res: " ^ dump v) 147 | end; 148 | in 149 | let on_failure exn = 150 | unregister_mark mark; 151 | log_exit mark @@ lazy begin 152 | "exn: " ^ Printexc.to_string exn 153 | end; 154 | begin match log with None -> () | Some log -> log #warn "thread %S failed" !!(mark.name) ~exn end; 155 | in 156 | run_thread on_success on_failure cont 157 | 158 | let with_new_mark ?dump ?log ~name ~kind cont = 159 | if not !enabled then cont () else 160 | let new_mark = 161 | let (parent_name, parent_id) = 162 | let parent = Option.default top_mark (Lwt.get key) in 163 | (parent.name, parent.id) 164 | in 165 | create ~name ~kind ~parent_name ~parent_id 166 | in 167 | with_mark (Some new_mark) @@ run_with_mark ?dump ?log ~mark:new_mark cont 168 | 169 | (**) 170 | 171 | let name name cont = 172 | with_new_mark ~name:(Lazy.from_val name) ~kind:Normal cont 173 | 174 | let status name ?dump cont = 175 | with_new_mark ~name ?dump ~kind:Status cont 176 | 177 | let status_s name ?dump cont = 178 | status (Lazy.from_val name) ?dump cont 179 | 180 | let async ?log name run_thread = 181 | Lwt.async @@ fun () -> 182 | with_new_mark ?log ~name:(Lazy.from_val name) ~kind:Background @@ 183 | run_thread 184 | 185 | let log_do msg = 186 | let mark = Option.default top_mark (Lwt.get key) in 187 | log_add_line mark msg 188 | 189 | let log_l msg = 190 | if not !enabled then () else 191 | log_do msg 192 | 193 | let log_do_strict msg = 194 | log_do (Lazy.from_val msg) 195 | 196 | let log msg = 197 | if not !enabled then () else 198 | log_do_strict msg 199 | 200 | let log_f fmt = 201 | if not !enabled then Printf.ikfprintf ignore () fmt else Printf.ksprintf log_do_strict fmt 202 | 203 | (**) 204 | 205 | let rec parent_of_status parent_id = 206 | let parent = mark_or_orphan parent_id in 207 | match parent.kind with 208 | | Normal | Background -> parent 209 | | Status -> parent_of_status parent.parent_id 210 | 211 | let summary () = 212 | let b = Buffer.create 100 in 213 | let open Printf in 214 | Buffer.add_string b "Lwt_mark status (running threads):\n"; 215 | if !enabled 216 | then begin 217 | let statuses = Hashtbl.create 7 in 218 | Hashtbl.iter begin fun _id mark -> 219 | match mark.kind with 220 | | Normal | Background -> () 221 | | Status -> begin 222 | let {id = parent_id; _} = parent_of_status mark.parent_id in 223 | let sts = 224 | try Hashtbl.find statuses parent_id 225 | with Not_found -> let s = ref [] in (Hashtbl.add statuses parent_id s; s) 226 | in 227 | tuck sts mark 228 | end 229 | end 230 | marks; 231 | Hashtbl.iter begin fun _id {id; name; parent_id; parent_name; logs; kind} -> 232 | bprintf b "%s (#%i, %s%s)\n" 233 | !!name id (string_of_kind kind) 234 | (if parent_id = 0 then "" else sprintf ", parent: %s#%i" !!parent_name parent_id); 235 | let logs = LastN.to_list logs in 236 | List.iter (fun line -> Buffer.add_string b " L "; Buffer.add_string b !!line) logs; 237 | begin match kind with 238 | | Status -> () 239 | | Normal | Background -> 240 | let sts = 241 | match Hashtbl.find statuses id with 242 | | sts_acc -> List.rev !sts_acc 243 | | exception Not_found -> [] 244 | in 245 | List.iter (fun status -> bprintf b " S %s#%i\n" !!(status.name) status.id) sts 246 | end; 247 | Buffer.add_char b '\n' 248 | end 249 | marks 250 | end else 251 | bprintf b "\n"; 252 | Buffer.contents b 253 | 254 | (**) 255 | 256 | let init () = 257 | enabled := true; 258 | let old_hook = !Log.State.hook in 259 | Log.State.hook := fun level facil msg -> (log msg; old_hook level facil msg) 260 | -------------------------------------------------------------------------------- /idn.ml: -------------------------------------------------------------------------------- 1 | (* Punycode and IDN library for OCaml *) 2 | (* License: without restrictions *) 3 | (* Author: dima@caml.ru *) 4 | 5 | (* Fixes by: ygrek and cyberhuman *) 6 | (* Version: 2013/08/29 *) 7 | 8 | module type CONV = sig 9 | val upoints : string -> int array 10 | val ustring : int array -> string 11 | end 12 | 13 | module Make(CONV : CONV) = struct 14 | 15 | exception Bad_input 16 | exception Overflow 17 | 18 | (* Parameters *) 19 | 20 | let base = 36 21 | let tmin = 1 22 | let tmax = 26 23 | let skew = 38 24 | let damp = 700 25 | let initial_bias = 72 26 | let initial_n = 0x80 27 | let delimiter = 0x2D 28 | 29 | (* Encoding *) 30 | 31 | let basic p = p < 0x80 32 | 33 | let encode_digit d = 34 | if d < 26 then 35 | d + Char.code 'a' 36 | else if d < 36 then 37 | d - 26 + Char.code '0' 38 | else 39 | raise Bad_input 40 | 41 | let adapt delta num_points first = 42 | let delta = if first then delta / damp else (delta lsr 1) in 43 | let delta = ref (delta + (delta / num_points)) in 44 | let k = ref 0 in 45 | let lim = ((base - tmin) * tmax) / 2 in 46 | while (!delta > lim) do 47 | delta := !delta / (base - tmin); 48 | k := !k + base 49 | done; 50 | !k + (((base - tmin + 1) * !delta) / (!delta + skew)) 51 | 52 | let encode_data input_data = 53 | let n = ref initial_n in 54 | let delta = ref 0 in 55 | let bias = ref initial_bias in 56 | let basic_count = ref 0 in 57 | let buf = Buffer.create 32 in 58 | let out n = 59 | Buffer.add_char buf (Char.chr n) in 60 | 61 | Array.iter 62 | (fun c -> 63 | if basic c then 64 | begin 65 | out c; 66 | incr basic_count; 67 | end) 68 | input_data; 69 | 70 | if !basic_count > 0 then 71 | Buffer.add_char buf (Char.chr delimiter); 72 | 73 | let handled_count = ref !basic_count in 74 | 75 | while (!handled_count < Array.length input_data) do 76 | let m = ref max_int in 77 | Array.iter 78 | (fun c -> 79 | if c >= !n && c < !m then 80 | m := c) 81 | input_data; 82 | 83 | if !m - !n > (max_int - !delta) / (succ !handled_count) then 84 | raise Overflow; 85 | delta := !delta + (!m - !n) * (succ !handled_count); 86 | n := !m; 87 | 88 | Array.iter 89 | (fun c -> 90 | if c < !n then 91 | begin 92 | incr delta; 93 | if !delta = 0 then 94 | raise Overflow; 95 | end; 96 | if c = !n then 97 | begin 98 | let q = ref !delta in 99 | let k = ref base in 100 | (try 101 | while true do 102 | let t = 103 | if !k <= !bias then tmin 104 | else if !k >= !bias + tmax then tmax 105 | else !k - !bias in 106 | if !q < t then 107 | raise Exit; 108 | out (encode_digit (t + ((!q - t) mod (base - t)))); 109 | q := (!q - t) / (base - t); 110 | k := !k + base 111 | done 112 | with Exit -> ()); 113 | out (encode_digit !q); 114 | bias := adapt !delta (succ !handled_count) (!handled_count = !basic_count); 115 | delta := 0; 116 | incr handled_count; 117 | end) 118 | input_data; 119 | incr delta; 120 | incr n; 121 | done; 122 | Buffer.contents buf 123 | 124 | (* Decoding *) 125 | 126 | let decode_digit p = 127 | if p < 48 then raise Bad_input else 128 | if p < 58 then p + 26 - 48 else 129 | if p < 65 then raise Bad_input else 130 | if p < 65 + 26 then p - 65 else 131 | if p < 97 then raise Bad_input else 132 | if p < 97 + 26 then p - 97 else 133 | raise Bad_input 134 | 135 | let decode_data input_data = 136 | let buflen = String.length input_data in 137 | let n = ref initial_n in 138 | let i = ref 0 in 139 | let bias = ref initial_bias in 140 | let buf = Array.make buflen 0 in 141 | 142 | let input_length = 143 | String.length input_data in 144 | 145 | let out = ref 0 in 146 | let data_pos = 147 | try 148 | let pos = String.rindex input_data (Char.chr delimiter) in 149 | for i = 0 to pos - 1 do 150 | Array.unsafe_set buf i (Char.code input_data.[i]) 151 | done; 152 | out := pos; 153 | pos + 1 154 | with _ -> 0 155 | in 156 | 157 | let j = ref data_pos in 158 | while !j < input_length do 159 | let oldi = ref !i in 160 | let w = ref 1 in 161 | let k = ref base in 162 | (try 163 | while true do 164 | if !j >= input_length then raise Bad_input; 165 | let digit = decode_digit (Char.code input_data.[!j]) in incr j; 166 | if digit > (max_int - !i) / !w then raise Overflow; 167 | i := !i + digit * !w; 168 | let t = 169 | if !k <= !bias then tmin 170 | else if !k >= !bias + tmax then tmax 171 | else !k - !bias 172 | in 173 | if digit < t then 174 | raise Exit; 175 | if !w > max_int / (base - t) then raise Overflow; 176 | w := !w * (base - t); 177 | k := !k + base 178 | done 179 | with Exit -> ()); 180 | let next = succ !out in 181 | bias := adapt (!i - !oldi) next (!oldi = 0); 182 | if !i / next > max_int - !n then raise Overflow; 183 | n := !n + !i / next; 184 | i := !i mod next; 185 | if !out >= buflen then raise Overflow; 186 | if !out > !i then 187 | Array.blit buf !i buf (!i + 1) (!out - !i); 188 | buf.(!i) <- !n; 189 | incr i; incr out; 190 | done; 191 | Array.sub buf 0 !out 192 | 193 | (* Helpers *) 194 | 195 | let split domain = 196 | let rec make acc rest = 197 | try 198 | let pos = String.index rest '.' in 199 | make ((String.sub rest 0 pos)::acc) 200 | (String.sub rest (succ pos) ((String.length rest) - pos - 1)) 201 | with Not_found -> List.rev (rest::acc) 202 | in make [] domain 203 | 204 | let join = String.concat "." 205 | 206 | let need_encoding s = 207 | let l = 208 | String.length s in 209 | try 210 | for i = 0 to pred l do 211 | if not (basic (Char.code (String.unsafe_get s i))) then 212 | raise Exit 213 | done; false 214 | with Exit -> true 215 | 216 | let need_decoding s = 217 | let l = String.length s in 218 | try 219 | if l >= 4 then 220 | if (String.unsafe_get s 0 = 'x') 221 | && (String.unsafe_get s 1 = 'n') 222 | && (String.unsafe_get s 2 = '-') 223 | && (String.unsafe_get s 3 = '-') 224 | then raise Exit 225 | else 226 | for i = 0 to pred l - 4 do 227 | if (String.unsafe_get s i = '.') 228 | && (String.unsafe_get s (i+1) = 'x') 229 | && (String.unsafe_get s (i+2) = 'n') 230 | && (String.unsafe_get s (i+3) = '-') 231 | && (String.unsafe_get s (i+4) = '-') 232 | then raise Exit 233 | done; 234 | false 235 | with Exit -> true 236 | 237 | (* Punycode API *) 238 | 239 | let encode s = encode_data (CONV.upoints s) 240 | let decode s = CONV.ustring (decode_data s) 241 | 242 | let transcode s = 243 | if need_encoding s then 244 | "xn--" ^ encode s 245 | else s 246 | 247 | let transtext s = 248 | let l = String.length s in 249 | if l > 4 && String.sub s 0 4 = "xn--" then 250 | decode (String.sub s 4 (l - 4)) 251 | else s 252 | 253 | (* IDN api *) 254 | 255 | let encode_domain domain = 256 | if need_encoding domain then 257 | join (List.map transcode (split domain)) 258 | else 259 | domain 260 | 261 | let decode_domain domain = 262 | if need_decoding domain then 263 | join (List.map transtext (split domain)) 264 | else domain 265 | 266 | let self_test () = 267 | assert ("他们为什么不说中文" = decode "ihqwcrb4cv8a8dqg056pqjye"); 268 | assert ("---禁刊拍賣網址---" = decode "-------5j3ji85am9zsk4ckwjm29b"); 269 | assert ("reality44hire-b9a" = encode (decode "reality44hire-b9a")); 270 | assert (need_encoding "---禁刊拍賣網址---"); 271 | assert (not @@ need_encoding "asdasdasdfs"); 272 | assert (need_decoding "xn--asd.asda"); 273 | assert (need_decoding "xn--"); 274 | assert (need_decoding "a.xn--"); 275 | assert (not @@ need_decoding "a.xn-"); 276 | assert (not @@ need_decoding "a.b"); 277 | assert (need_decoding "qwe.xn--werw"); 278 | assert (not @@ need_decoding "qwexn--werw.sdfsf"); 279 | begin 280 | try 281 | let (_:string) = decode_domain "xn----7sbksbihemjgbjxflp8bn1jxc.xn--p1aiaudio_orlov_yum" in 282 | assert false 283 | with 284 | | Bad_input -> assert true 285 | | _ -> assert false 286 | end; 287 | () 288 | 289 | let () = self_test () 290 | 291 | end 292 | --------------------------------------------------------------------------------