├── .ocamlformat ├── src ├── .exclude ├── config.ml ├── json.mli ├── config.mli ├── json.ml ├── severity_level.mli ├── uuid.mli ├── datetime.mli ├── message.mli ├── capped_string_4k.mli ├── capped_string_512.mli ├── sdk.mli ├── platform.mli ├── util.ml ├── uuid.ml ├── datetime.ml ├── sdk.ml ├── capped_string_512.ml ├── capped_string_4k.ml ├── severity_level.ml ├── client.mli ├── dune ├── util.mli ├── message.ml ├── breadcrumb.mli ├── platform.ml ├── event.mli ├── context.mli ├── dsn.mli ├── context.ml ├── exception.mli ├── breadcrumb.ml ├── payloads.atd ├── dsn.ml ├── sentry.mli ├── sentry.ml ├── client.ml ├── event.ml └── exception.ml ├── .gitignore ├── static └── exception_in_sentry.png ├── bin ├── dune └── sentry_example.ml ├── .pre-commit-config.yaml ├── .editorconfig ├── Makefile ├── dune-project ├── sentry.opam ├── LICENSE ├── circle.yml ├── CHANGES.md └── README.md /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | -------------------------------------------------------------------------------- /src/.exclude: -------------------------------------------------------------------------------- 1 | file regexp ".*_[jt].ml" -------------------------------------------------------------------------------- /src/config.ml: -------------------------------------------------------------------------------- 1 | let name = "sentry-ocaml" 2 | let version = "0.1" 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | _coverage 3 | _esy 4 | _opam 5 | .merlin 6 | node_modules 7 | sentry.install 8 | bisect*.out 9 | -------------------------------------------------------------------------------- /src/json.mli: -------------------------------------------------------------------------------- 1 | (** Wrapper for Yojson.Basic.json with sexp_of *) 2 | type t = Yojson.Basic.json [@@deriving sexp_of] 3 | -------------------------------------------------------------------------------- /static/exception_in_sentry.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/arenadotio/sentry-ocaml/HEAD/static/exception_in_sentry.png -------------------------------------------------------------------------------- /src/config.mli: -------------------------------------------------------------------------------- 1 | (** The name of this Sentry client *) 2 | val name : string 3 | 4 | (** The version of this Sentry client *) 5 | val version : string 6 | -------------------------------------------------------------------------------- /src/json.ml: -------------------------------------------------------------------------------- 1 | type t = Yojson.Basic.json 2 | 3 | let sexp_of_t (t : Yojson.Basic.json) = 4 | Json_derivers.Yojson.sexp_of_t (t :> Json_derivers.Yojson.t) 5 | ;; 6 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names sentry_example) 3 | (libraries async sentry) 4 | (preprocess 5 | (pps ppx_jane))) 6 | 7 | (alias 8 | (name examples) 9 | (deps sentry_example.exe)) 10 | -------------------------------------------------------------------------------- /.pre-commit-config.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | repos: 3 | - repo: https://github.com/arenadotio/pre-commit-ocamlformat 4 | rev: 2b9c80c268df08bbe192ae58e5e8db2ba8496767 5 | hooks: 6 | - id: ocamlformat 7 | -------------------------------------------------------------------------------- /src/severity_level.mli: -------------------------------------------------------------------------------- 1 | (** https://docs.sentry.io/clientdev/attributes/#required-attributes *) 2 | type t = 3 | [ `Fatal 4 | | `Error 5 | | `Warning 6 | | `Info 7 | | `Debug 8 | ] 9 | [@@deriving sexp_of] 10 | 11 | val wrap : string -> [> t ] 12 | val unwrap : [< t ] -> string 13 | -------------------------------------------------------------------------------- /src/uuid.mli: -------------------------------------------------------------------------------- 1 | (** Atdgen wrapper for the Sentry Datetime type 2 | 3 | The timestamp are in ISO 8601 format, without a timezone. 4 | 5 | https://docs.sentry.io/clientdev/attributes/#required-attributes *) 6 | type t = Uuidm.t 7 | 8 | val wrap : string -> t 9 | val unwrap : t -> string 10 | -------------------------------------------------------------------------------- /src/datetime.mli: -------------------------------------------------------------------------------- 1 | (** Atdgen wrapper for the Sentry Datetime type 2 | 3 | The timestamp are in ISO 8601 format, without a timezone. 4 | 5 | https://docs.sentry.io/clientdev/attributes/#required-attributes *) 6 | open Core_kernel 7 | 8 | type t = Time.t 9 | 10 | val wrap : string -> t 11 | val unwrap : t -> string 12 | -------------------------------------------------------------------------------- /src/message.mli: -------------------------------------------------------------------------------- 1 | (** https://docs.sentry.io/clientdev/interfaces/message/ *) 2 | type t = private 3 | { message : string 4 | ; params : string list 5 | ; formatted : string option 6 | } 7 | [@@deriving sexp_of] 8 | 9 | val make : message:string -> ?params:string list -> ?formatted:string -> unit -> t 10 | val to_payload : t -> Payloads_t.message 11 | -------------------------------------------------------------------------------- /src/capped_string_4k.mli: -------------------------------------------------------------------------------- 1 | (** The Sentry API discards anything after the first 512 characters of most 2 | string attributes, so avoid sending them in the first place, so we can 3 | also avoid sending events that are too big. 4 | https://docs.sentry.io/accounts/quotas/#attributes-limits *) 5 | type t = string [@@deriving sexp_of] 6 | 7 | val wrap : string -> t 8 | val unwrap : t -> string 9 | -------------------------------------------------------------------------------- /src/capped_string_512.mli: -------------------------------------------------------------------------------- 1 | (** The Sentry API discards anything after the first 512 characters of most 2 | string attributes, so avoid sending them in the first place, so we can 3 | also avoid sending events that are too big. 4 | https://docs.sentry.io/accounts/quotas/#attributes-limits *) 5 | type t = string [@@deriving sexp_of] 6 | 7 | val wrap : string -> t 8 | val unwrap : t -> string 9 | -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | # http://editorconfig.org 2 | 3 | root = true 4 | 5 | [*] 6 | indent_style = space 7 | indent_size = 2 8 | charset = utf-8 9 | trim_trailing_whitespace = true 10 | insert_final_newline = true 11 | max_line_length = 80 12 | 13 | # PEP8 says use 4-space indent 14 | [*.py] 15 | indent_size = 4 16 | 17 | # Makefiles only support tab indents 18 | [Makefile] 19 | indent_style = tab 20 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: build 2 | 3 | build: 4 | @dune build @install @examples 5 | 6 | clean: 7 | @rm -rf `find . -name 'bisect*.out'` _coverage 8 | @dune clean 9 | 10 | coverage: clean 11 | @BISECT_ENABLE=yes dune runtest 12 | @bisect-ppx-report send-to Coveralls 13 | 14 | install: build 15 | @dune install 16 | 17 | test: 18 | @dune runtest --force 19 | 20 | .PHONY: all build clean coverage test 21 | -------------------------------------------------------------------------------- /src/sdk.mli: -------------------------------------------------------------------------------- 1 | (** https://docs.sentry.io/clientdev/attributes/#required-attributes *) 2 | open Core_kernel 3 | 4 | type t = private 5 | { name : string 6 | ; version : string 7 | ; integrations : String.Set.t 8 | } 9 | [@@deriving sexp_of] 10 | 11 | val make : name:string -> version:string -> ?integrations:String.Set.t -> unit -> t 12 | val default : t 13 | val to_payload : t -> Payloads_t.sdk_info 14 | -------------------------------------------------------------------------------- /src/platform.mli: -------------------------------------------------------------------------------- 1 | (** https://docs.sentry.io/clientdev/attributes/#required-attributes *) 2 | type t = 3 | [ `As3 4 | | `C 5 | | `Cfml 6 | | `Cocoa 7 | | `Csharp 8 | | `Go 9 | | `Java 10 | | `Javascript 11 | | `Node 12 | | `Objc 13 | | `Other 14 | | `Perl 15 | | `Php 16 | | `Python 17 | | `Ruby 18 | ] 19 | [@@deriving sexp_of] 20 | 21 | val wrap : string -> [> t ] 22 | val unwrap : [< t ] -> string 23 | -------------------------------------------------------------------------------- /src/util.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Async 3 | 4 | let cap_string_length ?(max_len = 512) str = 5 | if String.length str > max_len then String.sub ~pos:0 ~len:max_len str else str 6 | ;; 7 | 8 | let empty_list_option l = 9 | match l with 10 | | [] -> None 11 | | l -> Some l 12 | ;; 13 | 14 | let map_to_alist_option m = Map.to_alist m |> empty_list_option 15 | 16 | let with_print_exn f = 17 | try f () with 18 | | e -> Exn.to_string e |> print_endline 19 | ;; 20 | -------------------------------------------------------------------------------- /src/uuid.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | 3 | type t = Uuidm.t 4 | 5 | let unwrap t = Uuidm.to_bytes t |> Hex.of_string |> Hex.show 6 | 7 | let wrap s = 8 | Hex.to_string (`Hex s) 9 | |> Uuidm.of_bytes 10 | |> function 11 | | Some uuid -> uuid 12 | | None -> failwithf "Failed to parse %s as a UUID" s () 13 | ;; 14 | 15 | let%test_unit "wrap" = 16 | let expect = "fc6d8c0c43fc4630ad850ee518f1b9d0" in 17 | expect |> wrap |> unwrap |> [%test_result: string] ~expect 18 | ;; 19 | -------------------------------------------------------------------------------- /src/datetime.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | 3 | type t = Time.t 4 | 5 | let unwrap t = 6 | Time.to_string_iso8601_basic ~zone:Time.Zone.utc t 7 | |> String.rstrip ~drop:(Char.( = ) 'Z') 8 | ;; 9 | 10 | let wrap s = 11 | Time.of_string_gen 12 | ~default_zone:(fun () -> Time.Zone.utc) 13 | ~find_zone:(fun s -> failwithf "Unexpected time zone: %s" s ()) 14 | s 15 | ;; 16 | 17 | let%test_unit "round-trip" = 18 | let expect = "2011-05-02T17:41:36.000000" in 19 | expect |> wrap |> unwrap |> [%test_result: string] ~expect 20 | ;; 21 | -------------------------------------------------------------------------------- /src/sdk.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Util 3 | 4 | type t = 5 | { name : string 6 | ; version : string 7 | ; integrations : String.Set.t 8 | } 9 | [@@deriving sexp_of] 10 | 11 | let make ~name ~version ?(integrations = String.Set.empty) () = 12 | { name; version; integrations } 13 | ;; 14 | 15 | let default = make ~name:Config.name ~version:Config.version () 16 | 17 | let to_payload { name; version; integrations } = 18 | { Payloads_t.name 19 | ; version 20 | ; integrations = String.Set.to_list integrations |> empty_list_option 21 | } 22 | ;; 23 | -------------------------------------------------------------------------------- /src/capped_string_512.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Sexplib.Conv 3 | 4 | type t = string [@@deriving sexp_of] 5 | 6 | let unwrap t = Util.cap_string_length ~max_len:512 t 7 | let wrap t = t 8 | 9 | let%test_unit "round-trip" = 10 | let expect = "adsfasdfsdsd131" in 11 | expect |> wrap |> unwrap |> [%test_result: string] ~expect 12 | ;; 13 | 14 | let%test_unit "long string round trip" = 15 | let input = String.init 1000 ~f:(Fn.const 'a') in 16 | let expect = String.sub ~pos:0 ~len:512 input in 17 | input |> wrap |> unwrap |> [%test_result: string] ~expect 18 | ;; 19 | -------------------------------------------------------------------------------- /src/capped_string_4k.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Sexplib.Conv 3 | 4 | type t = string [@@deriving sexp_of] 5 | 6 | let unwrap t = Util.cap_string_length ~max_len:4096 t 7 | let wrap t = t 8 | 9 | let%test_unit "round-trip" = 10 | let expect = "adsfasdfsdsd131" in 11 | expect |> wrap |> unwrap |> [%test_result: string] ~expect 12 | ;; 13 | 14 | let%test_unit "long string round trip" = 15 | let input = String.init 5000 ~f:(Fn.const 'a') in 16 | let expect = String.sub ~pos:0 ~len:4096 input in 17 | input |> wrap |> unwrap |> [%test_result: string] ~expect 18 | ;; 19 | -------------------------------------------------------------------------------- /src/severity_level.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | 3 | type t = 4 | [ `Fatal 5 | | `Error 6 | | `Warning 7 | | `Info 8 | | `Debug 9 | ] 10 | [@@deriving sexp_of] 11 | 12 | let unwrap = function 13 | | `Fatal -> "fatal" 14 | | `Error -> "error" 15 | | `Warning -> "warning" 16 | | `Info -> "info" 17 | | `Debug -> "debug" 18 | ;; 19 | 20 | let wrap = function 21 | | "fatal" -> `Fatal 22 | | "error" -> `Error 23 | | "warning" -> `Warning 24 | | "info" -> `Info 25 | | "debug" -> `Debug 26 | | s -> failwithf "Unknown severity level %s" s () 27 | ;; 28 | -------------------------------------------------------------------------------- /src/client.mli: -------------------------------------------------------------------------------- 1 | open Async_kernel 2 | 3 | (** Low level functions to access the Sentry API. You probably want the high 4 | level functions in sentry.ml *) 5 | 6 | (** [send_event ~dsn message] uploads a message to Sentry using the given 7 | [dsn]. Uploading happens in the background but will finish before the 8 | program exits. *) 9 | val send_event : dsn:Dsn.t' -> Event.t -> unit 10 | 11 | (** [send_event_and_wait] immediately uploads a message to Sentry and waits for 12 | the upload to complete. Returns the UUID of the created event or [None] if 13 | an exception occurred. *) 14 | val send_event_and_wait : dsn:Dsn.t' -> Event.t -> Uuidm.t option Deferred.t 15 | 16 | (** Like [send_event_and_wait] but throws exceptions if uploading fails. *) 17 | val send_event_and_wait_exn : dsn:Dsn.t' -> Event.t -> Uuidm.t Deferred.t 18 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (* -*- tuareg -*- *) 2 | 3 | let preprocess = 4 | match Sys.getenv "BISECT_ENABLE" with 5 | | "yes" -> "bisect_ppx" 6 | | _ -> "" 7 | | exception Not_found -> "" 8 | 9 | let () = Jbuild_plugin.V1.send @@ {| 10 | 11 | (env 12 | (dev 13 | (flags 14 | (:standard -w -3))) 15 | (release 16 | (flags 17 | (:standard -w -3)))) 18 | 19 | (library 20 | (public_name sentry) 21 | (libraries async_kernel atdgen cohttp-async core_kernel hex json-derivers 22 | uri uuidm re2 yojson) 23 | (inline_tests 24 | (flags (-verbose))) 25 | (preprocess 26 | (pps ppx_jane |} ^ preprocess ^ {|))) 27 | 28 | (rule 29 | (targets payloads_j.ml payloads_j.mli) 30 | (deps payloads.atd) 31 | (action 32 | (run atdgen -j -j-std payloads.atd))) 33 | 34 | (rule 35 | (targets payloads_t.ml payloads_t.mli) 36 | (deps payloads.atd) 37 | (action 38 | (run atdgen -t -j-std payloads.atd))) 39 | 40 | |} 41 | -------------------------------------------------------------------------------- /src/util.mli: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | 3 | (** [cap_string_length ?max_len str] creates a substring of [str] of length 4 | [max_len] if [str] is longer than [max_len]. Otherwise returns [str] 5 | unchanged. *) 6 | val cap_string_length : ?max_len:int -> string -> string 7 | 8 | (** [empty_list_option l] returns [None] if l is an empty list and returns 9 | [Some l] otherwise. This is useful for removing empty lists from our JSON 10 | payloads. *) 11 | val empty_list_option : 'a list -> 'a list option 12 | 13 | (** [map_to_alist_option] converts a map to an alist and returns [None] if the 14 | resulting list is empty or [Some _] if it is not. This is useful for 15 | converting our maps to the types atdgen expects. *) 16 | val map_to_alist_option : ('key, 'value, _) Map.t -> ('key * 'value) list option 17 | 18 | (** [with_print_exn] runs [f] and prints the exception it throws [if 19 | applicable]. This function is only for testing. *) 20 | val with_print_exn : (unit -> unit) -> unit 21 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.11) 2 | 3 | (using fmt 1.1) 4 | 5 | (name sentry) 6 | 7 | (generate_opam_files true) 8 | 9 | (license "Unlicense") 10 | 11 | (maintainers "Brendan Long ") 12 | 13 | (authors "Brendan Long ") 14 | 15 | (source 16 | (github brendanlong/sentry-ocaml)) 17 | 18 | (documentation "https://brendanlong.github.io/sentry-ocaml") 19 | 20 | (package 21 | (name sentry) 22 | (synopsis "Unofficial Async Sentry error monitoring client") 23 | (description 24 | "Sentry is an unofficial Async OCaml client for the Sentry error reporting.") 25 | (depends 26 | (core 27 | (>= v0.13.0)) 28 | atdgen 29 | (bisect_ppx 30 | (and 31 | :dev 32 | (>= 2.0.0))) 33 | (cohttp 34 | (>= 2.0.0)) 35 | (cohttp-async 36 | (>= 2.0.0)) 37 | (dune 38 | (>= 1.11.0)) 39 | (hex 40 | (>= 1.2.0)) 41 | json-derivers 42 | ppx_jane 43 | (ocaml 44 | (>= 4.08.0)) 45 | re2 46 | (sexplib 47 | (>= v0.13.0)) 48 | uuidm 49 | uri 50 | yojson)) 51 | -------------------------------------------------------------------------------- /src/message.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Util 3 | 4 | type t = 5 | { message : string 6 | ; params : string list 7 | ; formatted : string option 8 | } 9 | [@@deriving sexp_of] 10 | 11 | let make ~message ?(params = []) ?formatted () = { message; params; formatted } 12 | 13 | let to_payload { message; params; formatted } = 14 | { Payloads_t.message; params = empty_list_option params; formatted } 15 | ;; 16 | 17 | let%expect_test "to_payload with params" = 18 | make 19 | ~message:"My raw message with interpolated strings like %s" 20 | ~params:[ "this"; "is an example" ] 21 | () 22 | |> to_payload 23 | |> Payloads_j.string_of_message 24 | |> print_endline; 25 | [%expect 26 | {| {"message":"My raw message with interpolated strings like %s","params":["this","is an example"]} |}] 27 | ;; 28 | 29 | let%expect_test "to_payload without params" = 30 | make ~message:"Lorem ipsum" () 31 | |> to_payload 32 | |> Payloads_j.string_of_message 33 | |> print_endline; 34 | [%expect {| {"message":"Lorem ipsum"} |}] 35 | ;; 36 | -------------------------------------------------------------------------------- /src/breadcrumb.mli: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | 3 | type level = 4 | [ `Critical 5 | | `Error 6 | | `Warning 7 | | `Info 8 | | `Debug 9 | ] 10 | [@@deriving sexp_of] 11 | 12 | type t = private 13 | { timestamp : Time.t 14 | ; type_ : string 15 | ; message : string option 16 | ; data : Json.t String.Map.t 17 | ; category : string option 18 | ; level : level 19 | } 20 | [@@deriving sexp_of] 21 | 22 | val make 23 | : ?timestamp:Time.t 24 | -> ?type_:string 25 | -> ?message:string 26 | -> ?data:Json.t String.Map.t 27 | -> ?category:string 28 | -> ?level:level 29 | -> unit 30 | -> t 31 | 32 | val make_navigation 33 | : ?timestamp:Time.t 34 | -> ?message:string 35 | -> ?category:string 36 | -> ?level:level 37 | -> from:string 38 | -> to_:string 39 | -> unit 40 | -> t 41 | 42 | val make_http 43 | : ?timestamp:Time.t 44 | -> ?message:string 45 | -> ?category:string 46 | -> ?level:level 47 | -> url:string 48 | -> method_:string 49 | -> status_code:int 50 | -> reason:string 51 | -> unit 52 | -> t 53 | 54 | val to_payload : t -> Payloads_t.breadcrumb 55 | -------------------------------------------------------------------------------- /src/platform.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | 3 | type t = 4 | [ `As3 5 | | `C 6 | | `Cfml 7 | | `Cocoa 8 | | `Csharp 9 | | `Go 10 | | `Java 11 | | `Javascript 12 | | `Node 13 | | `Objc 14 | | `Other 15 | | `Perl 16 | | `Php 17 | | `Python 18 | | `Ruby 19 | ] 20 | [@@deriving sexp_of] 21 | 22 | let unwrap = function 23 | | `As3 -> "as3" 24 | | `C -> "c" 25 | | `Cfml -> "cfml" 26 | | `Cocoa -> "cocoa" 27 | | `Csharp -> "csharp" 28 | | `Go -> "go" 29 | | `Java -> "java" 30 | | `Javascript -> "javascript" 31 | | `Node -> "node" 32 | | `Objc -> "objc" 33 | | `Other -> "other" 34 | | `Perl -> "perl" 35 | | `Php -> "php" 36 | | `Python -> "python" 37 | | `Ruby -> "ruby" 38 | ;; 39 | 40 | let wrap = function 41 | | "as3" -> `As3 42 | | "c" -> `C 43 | | "cfml" -> `Cfml 44 | | "cocoa" -> `Cocoa 45 | | "csharp" -> `Csharp 46 | | "go" -> `Go 47 | | "java" -> `Java 48 | | "javascript" -> `Javascript 49 | | "node" -> `Node 50 | | "objc" -> `Objc 51 | | "other" -> `Other 52 | | "perl" -> `Perl 53 | | "php" -> `Php 54 | | "python" -> `Python 55 | | "ruby" -> `Ruby 56 | | s -> failwithf "Unknown platform %s" s () 57 | ;; 58 | -------------------------------------------------------------------------------- /sentry.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Unofficial Async Sentry error monitoring client" 4 | description: 5 | "Sentry is an unofficial Async OCaml client for the Sentry error reporting." 6 | maintainer: ["Brendan Long "] 7 | authors: ["Brendan Long "] 8 | license: "Unlicense" 9 | homepage: "https://github.com/brendanlong/sentry-ocaml" 10 | doc: "https://brendanlong.github.io/sentry-ocaml" 11 | bug-reports: "https://github.com/brendanlong/sentry-ocaml/issues" 12 | depends: [ 13 | "core" {>= "v0.13.0"} 14 | "atdgen" 15 | "bisect_ppx" {dev & >= "2.0.0"} 16 | "cohttp" {>= "2.0.0"} 17 | "cohttp-async" {>= "2.0.0"} 18 | "dune" {>= "1.11.0"} 19 | "hex" {>= "1.2.0"} 20 | "json-derivers" 21 | "ppx_jane" 22 | "ocaml" {>= "4.08.0"} 23 | "re2" 24 | "sexplib" {>= "v0.13.0"} 25 | "uuidm" 26 | "uri" 27 | "yojson" 28 | ] 29 | build: [ 30 | ["dune" "subst"] {pinned} 31 | [ 32 | "dune" 33 | "build" 34 | "-p" 35 | name 36 | "-j" 37 | jobs 38 | "@install" 39 | "@runtest" {with-test} 40 | "@doc" {with-doc} 41 | ] 42 | ] 43 | dev-repo: "git+https://github.com/brendanlong/sentry-ocaml.git" 44 | -------------------------------------------------------------------------------- /src/event.mli: -------------------------------------------------------------------------------- 1 | (** https://docs.sentry.io/clientdev/attributes/ *) 2 | open Core_kernel 3 | 4 | type t = private 5 | { event_id : Uuidm.t 6 | ; timestamp : Time.t 7 | ; logger : string option 8 | ; platform : Platform.t 9 | ; sdk : Sdk.t 10 | ; level : Severity_level.t option 11 | ; culprit : string option 12 | ; server_name : string option 13 | ; release : string option 14 | ; tags : string String.Map.t 15 | ; environment : string option 16 | ; modules : string String.Map.t 17 | ; extra : Json.t String.Map.t 18 | ; fingerprint : string list option 19 | ; exception_ : Exception.t list option 20 | ; message : Message.t option 21 | ; breadcrumbs : Breadcrumb.t list 22 | } 23 | [@@deriving sexp_of] 24 | 25 | val make 26 | : ?event_id:Uuidm.t 27 | -> ?timestamp:Time.t 28 | -> ?context:Context.t 29 | -> ?tags:(string * string) list 30 | -> ?logger:string 31 | -> ?platform:Platform.t 32 | -> ?sdk:Sdk.t 33 | -> ?level:Severity_level.t 34 | -> ?culprit:string 35 | -> ?fingerprint:string list 36 | -> ?message:Message.t 37 | -> ?exn:Exception.t list 38 | -> unit 39 | -> t 40 | 41 | val to_payload : t -> Payloads_t.event 42 | 43 | (** Converts [t] to the Sentry JSON representation, suitable to be uploaded. *) 44 | val to_json_string : t -> string 45 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This is free and unencumbered software released into the public domain. 2 | 3 | Anyone is free to copy, modify, publish, use, compile, sell, or 4 | distribute this software, either in source code form or as a compiled 5 | binary, for any purpose, commercial or non-commercial, and by any 6 | means. 7 | 8 | In jurisdictions that recognize copyright laws, the author or authors 9 | of this software dedicate any and all copyright interest in the 10 | software to the public domain. We make this dedication for the benefit 11 | of the public at large and to the detriment of our heirs and 12 | successors. We intend this dedication to be an overt act of 13 | relinquishment in perpetuity of all present and future rights to this 14 | software under copyright law. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | For more information, please refer to 25 | -------------------------------------------------------------------------------- /circle.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | jobs: 3 | build: 4 | docker: 5 | - image: ocaml/opam2:4.08 6 | environment: 7 | TERM: xterm 8 | steps: 9 | - run: 10 | name: Update opam 11 | command: | 12 | opam remote remove --all default 13 | opam remote add default https://opam.ocaml.org 14 | - checkout 15 | - run: 16 | name: Pin packages 17 | command: | 18 | opam pin add -y -n sentry . 19 | - run: 20 | name: Install system dependencies 21 | command: sudo apt-get update && opam depext -y sentry 22 | - run: 23 | name: Install OCaml dependencies 24 | command: opam install --deps-only -y sentry 25 | - run: 26 | # This is a separate step so we don't run tests for all of these ^ 27 | name: Install OCaml test dependencies 28 | command: opam install --deps-only -t -y sentry 29 | - run: 30 | name: Build 31 | command: opam config exec -- make 32 | - run: 33 | name: Test 34 | command: opam config exec -- make coverage 35 | - run: 36 | name: Upload coverage report 37 | command: | 38 | opam config exec -- bisect-ppx-report send-to Coveralls 39 | -------------------------------------------------------------------------------- /bin/sentry_example.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Async 3 | 4 | (* Note: We currently require the Async scheduler to be running *) 5 | 6 | let send_message = 7 | let spec = Command.Spec.empty in 8 | Command.async_spec ~summary:"Sends a message to Sentry" spec 9 | @@ fun () -> 10 | Sentry.merge_tags [ "subcommand", "send-message" ]; 11 | Sentry.add_breadcrumb 12 | (Sentry.Breadcrumb.make_navigation 13 | ~from:"nothing" 14 | ~to_:"something" 15 | ~message:"first crumb" 16 | ()); 17 | Sentry.(add_breadcrumb (Breadcrumb.make ~message:"second crumb" ())); 18 | Sentry.capture_message "test from OCaml" |> return 19 | ;; 20 | 21 | let send_exn = 22 | let spec = Command.Spec.empty in 23 | Command.async_spec ~summary:"Sends an exception to Sentry" spec 24 | @@ fun () -> 25 | Sentry.merge_tags [ "subcommand", "send-exn" ]; 26 | Sentry.add_breadcrumb 27 | (Sentry.Breadcrumb.make_navigation 28 | ~from:"nothing" 29 | ~to_:"something" 30 | ~message:"first crumb" 31 | ()); 32 | Sentry.(add_breadcrumb (Breadcrumb.make ~message:"second crumb" ())); 33 | Sentry.with_exn_handler_ignore (fun () -> failwith "Test exception!") |> return 34 | ;; 35 | 36 | let () = 37 | [ "send-message", send_message; "send-exn", send_exn ] 38 | |> Command.group ~summary:"Test commands for Sentry" 39 | |> Command.run 40 | ;; 41 | -------------------------------------------------------------------------------- /src/context.mli: -------------------------------------------------------------------------------- 1 | (** A context is a set of tags and breadcrumbs attached to an event 2 | https://docs.sentry.io/clientdev/context/ 3 | 4 | Note that contexts are mutable to make it easier to add tags and 5 | breadcrumbs. *) 6 | open Core_kernel 7 | 8 | type t = 9 | { mutable environment : string option 10 | ; mutable release : string option 11 | ; mutable server_name : string option 12 | ; tags : string String.Table.t 13 | ; extra : Json.t String.Table.t 14 | ; modules : string String.Table.t 15 | ; breadcrumbs : Breadcrumb.t Queue.t 16 | } 17 | [@@deriving sexp_of] 18 | 19 | (** Returns a new context with default data from the environment and system 20 | calls. *) 21 | val default : ?max_breadcrumbs:int -> unit -> t 22 | 23 | (** Returns a new context with no tags or breadcrumbs. You probably want to use 24 | [default ()] or copying the parent context in most cases. *) 25 | val empty : ?max_breadcrumbs:int -> unit -> t 26 | 27 | (** Copy a context so you can add / clear data without affecting the original *) 28 | val copy : t -> t 29 | 30 | (** [merge_tags tags t] merges the given tags into [t] *) 31 | val merge_tags : (string * string) list -> t -> unit 32 | 33 | (** [merge_extra extra t] merges the given extra data into [t] *) 34 | val merge_extra : (string * Json.t) list -> t -> unit 35 | 36 | (** [merge_modules modules t] merges the given module info into [t] *) 37 | val merge_modules : (string * string) list -> t -> unit 38 | 39 | (** Add a breadcrumb to the context and remove older breadcrumbs *) 40 | val add_breadcrumb : Breadcrumb.t -> t -> unit 41 | -------------------------------------------------------------------------------- /src/dsn.mli: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | type t' = private 4 | { uri : Uri.t 5 | ; public_key : string 6 | ; private_key : string option 7 | ; project_id : int 8 | } 9 | [@@deriving compare, sexp_of] 10 | 11 | type t = t' option [@@deriving sexp_of] 12 | 13 | val make 14 | : uri:Uri.t 15 | -> public_key:string 16 | -> ?private_key:string 17 | -> project_id:int 18 | -> unit 19 | -> t 20 | 21 | (** [default] is the DSN determined from [SENTRY_DSN] in the environment (or 22 | [None] if it's not set or invalid) *) 23 | val default : t 24 | 25 | (** [of_string dsn] parses the given DSN and returns the resulting Sentry 26 | config. You should generally not use this function directly and should use 27 | [Sentry.context] (or [Sentry.async_context]), which looks up the DSN for 28 | you from the environment. 29 | 30 | The DSN should look like 31 | ['{PROTOCOL}://{PUBLIC_KEY}:{PRIVATE_KEY}@{HOST}/{PATH}{PROJECT_ID}'] 32 | 33 | All values except for [PRIVATE_KEY] are required. [PROJECT_ID] must be an 34 | integer. In general you should get this value from Sentry and should not 35 | construct it yourself. 36 | 37 | Returns [None] if the DSN is invalid. 38 | 39 | See docs: https://docs.sentry.io/quickstart/#about-the-dsn *) 40 | val of_string : string -> t 41 | 42 | (** [of_uri dsn] is like [of_string dsn] but takes a [Uri.t] *) 43 | val of_uri : Uri.t -> t 44 | 45 | (** [arg] is a Command.Spec argument type which calls [of_string] *) 46 | val arg : t Command.Arg_type.t 47 | 48 | (** Like [arg] but uses [of_string_exn] *) 49 | val arg_exn : t Command.Arg_type.t 50 | 51 | (** [event_store_uri] is the URI we should POST Sentry events to *) 52 | val event_store_uri : t' -> Uri.t 53 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## v0.11.0 2 | 3 | - Support Async Monitor exceptions from v0.14 4 | 5 | ## v0.10.2 6 | 7 | - Drain cohttp response bodies so we don't leak connections on redirect or error 8 | 9 | ## v0.10.1 10 | 11 | - Don't require bisect_ppx for builds 12 | 13 | ## v0.10.0 14 | 15 | - Removed unused dependencies like async_extended and ounit 16 | - Better handing of 429 errors (#27) 17 | 18 | ## v0.9.0 19 | 20 | - Update Core/Async to v0.13 21 | - Update cohttp to v2.0 22 | - Update to bisect_ppx 2.0 23 | 24 | ## v0.8.0 25 | 26 | - Allow messages and exception values to be up to 4KB long 27 | 28 | ## v0.7.0 29 | 30 | - Switch back to cohttp 1.2 since 2.0 is incompatible with core_extended.base64 31 | - Cap strings at 512 characters each to try to keep us under Sentry's API limits 32 | 33 | ## v0.6.1 34 | 35 | - Remove yojson version restrictions again 36 | 37 | ## v0.6.0 38 | 39 | - Support cohttp 2.0 40 | - Require yojson <= 1.5.0 41 | - Add helpers to make esy builds work 42 | 43 | ## v0.5.0 44 | 45 | - Fix an issue where exceptions containing functions cause this library to throw exceptions 46 | 47 | ## v0.5.5 48 | 49 | - Support Uri 2.0 (split into Uri.t and Uri_sexp.t -- we just use a custom sexp function) 50 | 51 | ## v0.5.1 52 | 53 | - Add missing / at the end of Sentry event uploading URL 54 | 55 | ## v0.4.1 56 | 57 | - Add missing / at the end of Sentry event uploading URL 58 | 59 | ## v0.5 60 | 61 | - Redo context to be mutable to match other Sentry libraries and make it easier to add new tags to an existing context 62 | - Add support for breadcrumbs 63 | 64 | ## v0.4 65 | 66 | - Put context/context_async tags in the thread-global map so sub-contexts can use them 67 | 68 | ## v0.3 69 | 70 | - Parse Monitor exceptions to get significantly better async backtraces 71 | 72 | ## v0.2 73 | 74 | - Parse stringified exceptions for much nicer messages 75 | - Don't print the exception name twice 76 | - Clean up exception names 77 | - Print exception messages that are just strings as just a string instead of an sexp of a string (or an sexp of a list of strings) 78 | - Improve examples and README 79 | 80 | ## v0.1 81 | 82 | Initial release 83 | -------------------------------------------------------------------------------- /src/context.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | type t = 4 | { mutable environment : string option 5 | ; mutable release : string option 6 | ; mutable server_name : string option 7 | ; tags : string String.Table.t 8 | ; extra : Json.t String.Table.t 9 | ; modules : string String.Table.t 10 | ; breadcrumbs : Breadcrumb.t Queue.t 11 | } 12 | [@@deriving sexp_of] 13 | 14 | let empty ?(max_breadcrumbs = 10) () = 15 | { environment = None 16 | ; release = None 17 | ; server_name = None 18 | ; tags = String.Table.create () 19 | ; extra = String.Table.create () 20 | ; modules = String.Table.create () 21 | ; breadcrumbs = Queue.create ~capacity:max_breadcrumbs () 22 | } 23 | ;; 24 | 25 | let copy t = { t with tags = String.Table.copy t.tags; extra = String.Table.copy t.extra } 26 | 27 | let merge_into_table new_ existing = 28 | List.iter new_ ~f:(fun (key, data) -> Hashtbl.set existing ~key ~data) 29 | ;; 30 | 31 | let merge_tags tags t = merge_into_table tags t.tags 32 | let merge_extra extra t = merge_into_table extra t.extra 33 | let merge_modules modules t = merge_into_table modules t.modules 34 | 35 | let add_breadcrumb crumb t = 36 | if Queue.capacity t.breadcrumbs = Queue.length t.breadcrumbs 37 | then (Queue.dequeue_exn t.breadcrumbs : Breadcrumb.t) |> ignore; 38 | Queue.enqueue t.breadcrumbs crumb 39 | ;; 40 | 41 | let default_environment = Sys.getenv "SENTRY_ENVIRONMENT" 42 | let default_release = Sys.getenv "SENTRY_RELEASE" 43 | 44 | let default_server_name = 45 | match Sys.getenv "SENTRY_NAME" with 46 | | None -> Some (Unix.gethostname ()) 47 | | value -> value 48 | ;; 49 | 50 | let default_extra = 51 | (* TODO: Add system username (Unix.getlogin) and cwd (Sys.getcwd). We need to 52 | handle Deferred in here for that to work *) 53 | [ "os_type", `String Sys.os_type 54 | ; "executable_name", `String Sys.executable_name 55 | ; "argv", `List (Sys.argv |> Array.to_list |> List.map ~f:(fun v -> `String v)) 56 | ; ( "backend_type" 57 | , `String 58 | (match Caml.Sys.backend_type with 59 | | Caml.Sys.Native -> "Native" 60 | | Bytecode -> "Bytecode" 61 | | Other o -> o) ) 62 | ] 63 | |> String.Table.of_alist_exn 64 | ;; 65 | 66 | let default ?max_breadcrumbs () = 67 | let empty = empty ?max_breadcrumbs () in 68 | { empty with 69 | environment = default_environment 70 | ; release = default_release 71 | ; server_name = default_server_name 72 | ; extra = String.Table.copy default_extra 73 | } 74 | ;; 75 | -------------------------------------------------------------------------------- /src/exception.mli: -------------------------------------------------------------------------------- 1 | (** https://docs.sentry.io/clientdev/interfaces/exception/ *) 2 | open Core_kernel 3 | 4 | module Mechanism : sig 5 | type t = private 6 | { type_ : string 7 | ; description : string option 8 | ; help_link : string option 9 | ; handled : bool option (* TODO: meta *) 10 | ; data : string String.Map.t 11 | } 12 | 13 | val make 14 | : type_:string 15 | -> ?description:string 16 | -> ?help_link:string 17 | -> ?handled:bool 18 | -> ?data:string String.Map.t 19 | -> unit 20 | -> t 21 | 22 | val to_payload : t -> Payloads_t.mechanism 23 | end 24 | 25 | module Frame : sig 26 | (** https://docs.sentry.io/clientdev/interfaces/stacktrace/ *) 27 | type t = private 28 | { filename : string option 29 | ; function_ : string option 30 | ; module_ : string option 31 | ; lineno : int option 32 | ; colno : int option 33 | ; abs_path : string option 34 | ; context_line : string option 35 | ; pre_context : string list 36 | ; post_context : string list 37 | ; in_app : bool option 38 | ; vars : string String.Map.t 39 | ; package : string option 40 | ; platform : Platform.t option 41 | (* TODO: image_addr, instruction_addr, symbol_addr, instruction_offset *) 42 | } 43 | 44 | val make 45 | : ?filename:string 46 | -> ?function_:string 47 | -> ?module_:string 48 | -> ?lineno:int 49 | -> ?colno:int 50 | -> ?abs_path:string 51 | -> ?context_line:string 52 | -> ?pre_context:string list 53 | -> ?post_context:string list 54 | -> ?in_app:bool 55 | -> ?vars:string String.Map.t 56 | -> ?package:string 57 | -> ?platform:Platform.t 58 | -> unit 59 | -> t Or_error.t 60 | 61 | val make_exn 62 | : ?filename:string 63 | -> ?function_:string 64 | -> ?module_:string 65 | -> ?lineno:int 66 | -> ?colno:int 67 | -> ?abs_path:string 68 | -> ?context_line:string 69 | -> ?pre_context:string list 70 | -> ?post_context:string list 71 | -> ?in_app:bool 72 | -> ?vars:string String.Map.t 73 | -> ?package:string 74 | -> ?platform:Platform.t 75 | -> unit 76 | -> t 77 | 78 | val to_payload : t -> Payloads_t.stackframe 79 | end 80 | 81 | type t = private 82 | { type_ : string 83 | ; value : string option 84 | ; module_ : string option 85 | ; thread_id : string option 86 | ; mechanism : Mechanism.t option 87 | ; stacktrace : Frame.t list 88 | } 89 | 90 | val make 91 | : type_:string 92 | -> ?value:string 93 | -> ?module_:string 94 | -> ?thread_id:string 95 | -> ?mechanism:Mechanism.t 96 | -> ?stacktrace:Frame.t list 97 | -> unit 98 | -> t 99 | 100 | val to_payload : t -> Payloads_t.exception_value 101 | val list_to_payload : t list -> Payloads_t.exception_ 102 | val of_exn : exn -> t 103 | val of_error : Error.t -> t 104 | -------------------------------------------------------------------------------- /src/breadcrumb.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | 3 | type level = 4 | [ `Critical 5 | | `Error 6 | | `Warning 7 | | `Info 8 | | `Debug 9 | ] 10 | [@@deriving sexp_of] 11 | 12 | let level_to_string = function 13 | | `Critical -> "critical" 14 | | `Error -> "error" 15 | | `Warning -> "warning" 16 | | `Info -> "info" 17 | | `Debug -> "debug" 18 | ;; 19 | 20 | type t = 21 | { timestamp : Time.t sexp_opaque 22 | ; type_ : string 23 | ; message : string option 24 | ; data : Json.t String.Map.t 25 | ; category : string option 26 | ; level : level 27 | } 28 | [@@deriving sexp_of] 29 | 30 | let make 31 | ?timestamp 32 | ?(type_ = "default") 33 | ?message 34 | ?(data = String.Map.empty) 35 | ?category 36 | ?(level = `Info) 37 | () 38 | = 39 | let timestamp = 40 | match timestamp with 41 | | Some timestamp -> timestamp 42 | | None -> Time.now () 43 | in 44 | { timestamp; type_; message; data; category; level } 45 | ;; 46 | 47 | let make_navigation ?timestamp ?message ?category ?level ~from ~to_ () = 48 | let data = [ "from", `String from; "to", `String to_ ] |> String.Map.of_alist_exn in 49 | make ?timestamp ?message ?category ?level ~data ~type_:"navigation" () 50 | ;; 51 | 52 | let make_http ?timestamp ?message ?category ?level ~url ~method_ ~status_code ~reason () = 53 | let data = 54 | [ "url", `String url 55 | ; "method", `String method_ 56 | ; "status_code", `Int status_code 57 | ; "reason", `String reason 58 | ] 59 | |> String.Map.of_alist_exn 60 | in 61 | make ?timestamp ?message ?category ?level ~data ~type_:"http" () 62 | ;; 63 | 64 | let to_payload t = 65 | { Payloads_t.timestamp = t.timestamp 66 | ; type_ = Some t.type_ 67 | ; message = t.message 68 | ; data = Util.map_to_alist_option t.data 69 | ; category = t.category 70 | ; level = Some (level_to_string t.level) 71 | } 72 | ;; 73 | 74 | let%test_module _ = 75 | (module struct 76 | let timestamp = Time.of_string "2018-09-12T12:09:02Z" 77 | 78 | let%expect_test "empty to_payload" = 79 | make ~timestamp () |> to_payload |> Payloads_j.string_of_breadcrumb |> print_endline; 80 | [%expect 81 | {| {"timestamp":"2018-09-12T12:09:02.000000","type":"default","level":"info"} |}] 82 | ;; 83 | 84 | let%expect_test "navigation to_payload" = 85 | make_navigation ~timestamp ~from:"example from" ~to_:"example to" () 86 | |> to_payload 87 | |> Payloads_j.string_of_breadcrumb 88 | |> print_endline; 89 | [%expect 90 | {| {"timestamp":"2018-09-12T12:09:02.000000","type":"navigation","data":{"from":"example from","to":"example to"},"level":"info"} |}] 91 | ;; 92 | 93 | let%expect_test "http to_payload" = 94 | make_navigation ~timestamp ~from:"example from" ~to_:"example to" () 95 | |> to_payload 96 | |> Payloads_j.string_of_breadcrumb 97 | |> print_endline; 98 | [%expect 99 | {| {"timestamp":"2018-09-12T12:09:02.000000","type":"navigation","data":{"from":"example from","to":"example to"},"level":"info"} |}] 100 | ;; 101 | end) 102 | ;; 103 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![CircleCI](https://circleci.com/gh/brendanlong/sentry-ocaml.svg?style=shield)](https://circleci.com/gh/brendanlong/sentry-ocaml) 2 | [![Coverage Status](https://coveralls.io/repos/github/brendanlong/sentry-ocaml/badge.svg?branch=master)](https://coveralls.io/github/brendanlong/sentry-ocaml?branch=master) 3 | [![GitHub release](https://img.shields.io/github/release/brendanlong/sentry-ocaml.svg)](https://github.com/brendanlong/sentry-ocaml/releases/latest) 4 | [![License: Unlicense](https://img.shields.io/badge/license-Unlicense-blue.svg)](http://unlicense.org/) 5 | [![Documentation](https://img.shields.io/badge/documentation-odoc-blue)](https://brendanlong.github.io/sentry-ocaml/sentry/index.html) 6 | 7 | # Sentry (OCaml) - WORK IN PROGRESS 8 | 9 | This is an unofficial work-in-progress [Sentry](https://sentry.io) library for 10 | OCaml. 11 | 12 | **This currently requires the Async scheduler to be running or data will not 13 | be uploaded** 14 | 15 | ## Missing features: 16 | 17 | - Only supports Async (pull requests to factor out Lwt/Unix are welcome!) 18 | - Global unhandled exception handler isn't implemented yet. 19 | - Probably other things 20 | 21 | ## Example 22 | 23 | See [the example program](bin/sentry_example.ml). 24 | 25 | In general, you should use this like: 26 | 27 | ``` 28 | let () = 29 | let spec = Command.Spec.(...) in 30 | Command.async_spec ~summary:"..." spec @@ fun args () -> 31 | (* Using [SENTRY_DSN] from the environment *) 32 | Sentry.with_exn_handler @@ fun () -> 33 | (* your normal code here *) 34 | ``` 35 | 36 | **To release the warning above: The Async schedule *must* be running.** 37 | 38 | This will execute your code as usual, and if it throws an exception, it will be 39 | uploaded to Sentry: 40 | 41 | ![Exception in Sentry](static/exception_in_sentry.png) 42 | 43 | Then the exception will be re-thrown so your program will exit and print the 44 | backtrace to stderr as usual (if you want to continue after errors, wrap 45 | `Sentry.with_exn_handler` in another error handler or use `Sentry.with_exn_handler_ignore`). 46 | 47 | Note that `Sentry.with_error_and_exn_handler` exists (which handles both exceptions and 48 | `Or_error.t`), but using exceptions exclusively is recommended because they have 49 | backtraces (and wrapping exceptions in `Error.t` loses whatever backtrace did 50 | exist in most cases). 51 | 52 | ## Tags 53 | 54 | We upload some data by default. From environment variables, we get: 55 | 56 | - `SENTRY_ENVIRONMENT` -> `environment` 57 | - `SENTRY_RELEASE` -> `release` 58 | 59 | From `Sys` or `Unix`: 60 | 61 | - `Sys.argv` -> `argv` 62 | - `Sys.backend_type` -> `backend_type` 63 | - `Sys.executable_name` -> `executable_name` 64 | - `Sys.gethostname` -> `server_name` 65 | - `Sys.os_type` -> `os_type` 66 | 67 | You can override any of these with `Sentry.merge_extra`, 68 | `Sentry.set_environment`, and `Sentry.set_release`. 69 | 70 | You can also upload custom tags using either `Sentry.merge_tags` or by passing 71 | `~tags` to a `capture` function. Tags will be merged for the 72 | current async job, so you only need to pass additional tags: 73 | 74 | ``` 75 | Sentry.merge_tags [ "app_name", "http_server" ]; 76 | Sentry.with_exn_handler @@ fun () -> 77 | ... 78 | Sentry.merge_tags [ "method", "GET", "path", "/example" ]; 79 | ... 80 | (* This will upload with default tags + app_name, method, path, and user_id *) 81 | Sentry.capture_message ~tags:[ "user_id", user_id ] "invalid login" 82 | ``` 83 | -------------------------------------------------------------------------------- /src/payloads.atd: -------------------------------------------------------------------------------- 1 | type json = abstract 2 | 3 | type capped_string_4k = string wrap 4 | type capped_string_512 = string wrap 5 | type datetime = string wrap 6 | type platform = string wrap 7 | type severity_level = string wrap 8 | type uuid = string wrap 9 | 10 | type sdk_info = 11 | { name : capped_string_512 12 | ; version: capped_string_512 13 | ; ?integrations : capped_string_512 list nullable } 14 | 15 | type mechanism = 16 | { type_ : capped_string_512 17 | ; ?description : capped_string_512 nullable 18 | ; ?help_link : capped_string_512 nullable 19 | ; ?handled : bool nullable 20 | (* TODO: meta *) 21 | ; ?data : (capped_string_512 * capped_string_512) list nullable } 22 | 23 | type stackframe = 24 | { ?filename : capped_string_512 nullable 25 | ; ?function_ : capped_string_512 nullable 26 | ; ?module_ : capped_string_512 nullable 27 | ; ?lineno : int nullable 28 | ; ?colno : int nullable 29 | ; ?abs_path : capped_string_512 nullable 30 | ; ?context_line : capped_string_512 nullable 31 | ; ?pre_context : capped_string_512 list nullable 32 | ; ?post_context : capped_string_512 list nullable 33 | ; ?in_app : bool nullable 34 | ; ?vars : (capped_string_512 * capped_string_512) list nullable 35 | ; ?package : capped_string_512 nullable 36 | ; ?platform : platform nullable 37 | (* TODO: image_addr, instruction_addr, symbol_addr, instruction_offset *) } 38 | 39 | type stacktrace = 40 | { frames : stackframe list } 41 | 42 | type exception_value = 43 | { type_ : capped_string_512 44 | ; ?value : capped_string_4k nullable 45 | ; ?module_ : capped_string_512 nullable 46 | ; ?thread_id : capped_string_512 nullable 47 | ; ?mechanism : mechanism nullable 48 | ; ?stacktrace : stacktrace nullable } 49 | 50 | type exception_ = 51 | { values : exception_value list } 52 | 53 | type message = 54 | { message : capped_string_4k 55 | ; ?params : capped_string_512 list nullable 56 | ; ?formatted : capped_string_512 nullable } 57 | 58 | type breadcrumb = 59 | { timestamp : datetime 60 | ; ?type_ : capped_string_512 nullable 61 | ; ?message : capped_string_512 nullable 62 | ; ?data : (capped_string_512 * json) list nullable 63 | ; ?category : capped_string_512 nullable 64 | ; ?level : capped_string_512 nullable } 65 | 66 | type event = 67 | { event_id : uuid 68 | ; timestamp : datetime 69 | ; ?logger : capped_string_512 nullable 70 | ; platform : platform 71 | ; sdk : sdk_info 72 | ; ?level : severity_level nullable 73 | ; ?culprit : capped_string_512 nullable 74 | ; ?server_name : capped_string_512 nullable 75 | ; ?release : capped_string_512 nullable 76 | ; ?tags : (capped_string_512 * capped_string_512) list nullable 77 | ; ?environment : capped_string_512 nullable 78 | ; ?modules : (capped_string_512 * capped_string_512) list nullable 79 | ; ?extra : (capped_string_512 * json) list nullable 80 | ; ?fingerprint : capped_string_512 list nullable 81 | ; ?exception_ : exception_ nullable 82 | ; ?message : message nullable 83 | ; ?breadcrumbs : breadcrumb list nullable } 84 | 85 | type response = 86 | { id : uuid } 87 | -------------------------------------------------------------------------------- /src/dsn.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | type uri = Uri.t 4 | 5 | let compare_uri = Uri.compare 6 | let sexp_of_uri u = Uri.to_string u |> sexp_of_string 7 | 8 | type t' = 9 | { uri : uri 10 | ; public_key : string 11 | ; private_key : string sexp_option 12 | ; project_id : int 13 | } 14 | [@@deriving compare, sexp_of] 15 | 16 | type t = t' option [@@deriving compare, sexp_of] 17 | 18 | let make ~uri ~public_key ?private_key ~project_id () = 19 | Some { uri; public_key; private_key; project_id } 20 | ;; 21 | 22 | let of_uri_exn dsn = 23 | let required = 24 | [ "SCHEME", Uri.scheme dsn 25 | ; "HOST", Uri.host dsn 26 | ; "PUBLIC_KEY", Uri.user dsn 27 | ; "PROJECT_ID", Uri.path dsn |> String.rsplit2 ~on:'/' |> Option.map ~f:snd 28 | ] 29 | in 30 | List.filter_map required ~f:(fun (name, value) -> 31 | match value with 32 | | None -> Some name 33 | | Some _ -> None) 34 | |> function 35 | | [] -> 36 | (match List.map required ~f:snd with 37 | | [ Some scheme; Some host; Some public_key; Some project_id ] -> 38 | let private_key = Uri.password dsn in 39 | let uri = Uri.make ~scheme ~host () in 40 | (try 41 | let project_id = Int.of_string project_id in 42 | make ~uri ~public_key ?private_key ~project_id () 43 | with 44 | | _ -> failwithf "Invalid PROJECT_ID: %s (should be an integer)" project_id ()) 45 | | _ -> assert false) 46 | | missing -> 47 | let fields = String.concat missing ~sep:"," in 48 | failwithf "Missing required DSN field(s): %s" fields () 49 | ;; 50 | 51 | let of_uri dsn = 52 | try of_uri_exn dsn with 53 | | _ -> None 54 | ;; 55 | 56 | let of_string_exn dsn = Uri.of_string dsn |> of_uri_exn 57 | 58 | let of_string dsn = 59 | try of_string_exn dsn with 60 | | _ -> None 61 | ;; 62 | 63 | let default = Sys.getenv "SENTRY_DSN" |> Option.bind ~f:of_string 64 | let arg = Command.Spec.Arg_type.create of_string 65 | let arg_exn = Command.Spec.Arg_type.create of_string_exn 66 | 67 | let event_store_uri { uri; project_id; _ } = 68 | sprintf "/api/%d/store/" project_id |> Uri.with_path uri 69 | ;; 70 | 71 | let%test_unit "full DSN" = 72 | let expect = 73 | make 74 | ~uri:(Uri.of_string "https://test.example.com") 75 | ~public_key:"abcdef" 76 | ~private_key:"qwerty" 77 | ~project_id:12345 78 | () 79 | in 80 | List.iter [ of_string; of_string_exn ] ~f:(fun f -> 81 | "https://abcdef:qwerty@test.example.com/12345" |> f |> [%test_result: t] ~expect) 82 | ;; 83 | 84 | let%test_unit "only public key DSN" = 85 | let expect = 86 | make 87 | ~uri:(Uri.of_string "https://test.example.com") 88 | ~public_key:"lkasl" 89 | ~project_id:56789 90 | () 91 | in 92 | List.iter [ of_string; of_string_exn ] ~f:(fun f -> 93 | "https://lkasl@test.example.com/56789" |> f |> [%test_result: t] ~expect) 94 | ;; 95 | 96 | let%test_unit "empty DSN no exception" = (of_string "" : t) |> ignore 97 | 98 | let%expect_test "empty DSN exception" = 99 | Util.with_print_exn (fun () -> (of_string_exn "" : t) |> ignore); 100 | [%expect 101 | {| (Failure "Missing required DSN field(s): SCHEME,HOST,PUBLIC_KEY,PROJECT_ID") |}] 102 | ;; 103 | 104 | let%test_unit "invalid DSN no exception" = 105 | (of_string "https://asdf@example.com/abcd" : t) |> ignore 106 | ;; 107 | 108 | let%expect_test "invalid DSN exception" = 109 | Util.with_print_exn (fun () -> 110 | (of_string_exn "https://asdf@example.com/abcd" : t) |> ignore); 111 | [%expect {| (Failure "Invalid PROJECT_ID: abcd (should be an integer)") |}] 112 | ;; 113 | -------------------------------------------------------------------------------- /src/sentry.mli: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Async_kernel 3 | module Breadcrumb = Breadcrumb 4 | module Client = Client 5 | module Config = Config 6 | module Context = Context 7 | module Dsn = Dsn 8 | module Event = Event 9 | module Exception = Exception 10 | module Platform = Platform 11 | module Sdk = Sdk 12 | module Severity_level = Severity_level 13 | 14 | (** [with_dsn dsn f] overrides the default DSN (from the environment variable 15 | [SENTRY_DSN]) within the execution of [f] *) 16 | val with_dsn : Dsn.t -> (unit -> 'a) -> 'a 17 | 18 | (** [with_context f] sets the current thread-local context and runs [f] with 19 | it. *) 20 | val with_context : Context.t -> (unit -> 'a) -> 'a 21 | 22 | (** Like [with_new_context] but creates the new context for you as a copy 23 | of the current context. [~tags] will be merged into the new context. *) 24 | val with_new_context : ?tags:(string * string) list -> (Context.t -> 'a) -> 'a 25 | 26 | (** Override the environment in the current context *) 27 | val set_environment : string -> unit 28 | 29 | (** Override the release in the current context *) 30 | val set_release : string -> unit 31 | 32 | (** Override the server name in the current context *) 33 | val set_server_name : string -> unit 34 | 35 | (** Merge tags into the current context *) 36 | val merge_tags : (string * string) list -> unit 37 | 38 | (** Add a breadcrumb to the current context *) 39 | val add_breadcrumb : Breadcrumb.t -> unit 40 | 41 | (** [capture_message ?tags ?dsn message] uploads a message to Sentry using the 42 | given [dsn] (or looking it up in the environment). 43 | 44 | If you pass [tags], it will be as if you called [with_tags] before this 45 | function. *) 46 | val capture_message : ?tags:(string * string) list -> string -> unit 47 | 48 | (** [capture_exception ?dsn ?message e] records the backtrace from [e] and an 49 | optional message and uploads it to Sentry. 50 | 51 | If you pass [tags], it will be as if you called [with_tags] before this 52 | function. *) 53 | val capture_exception : ?tags:(string * string) list -> ?message:string -> exn -> unit 54 | 55 | (** [capture_error ?dsn ?message e] records the backtrace from [e] and uploads 56 | it to Sentry. 57 | 58 | If you pass [tags], it will be as if you called [with_tags] before this 59 | function. *) 60 | val capture_error : ?tags:(string * string) list -> Error.t -> unit 61 | 62 | (** [with_exn_handler ?dsn f] runs [f]. If [f] throws an exception, it will be 63 | uploaded to Sentry and then re-reraised. *) 64 | val with_exn_handler : (unit -> 'a) -> 'a 65 | 66 | (** [with_exn_handler ?dsn f] is like [context] except exceptions will not be 67 | re-raised. Use this if you're using Sentry in a loop where you want to 68 | report on errors and then continue (like in an web server). *) 69 | val with_exn_handler_ignore : (unit -> unit) -> unit 70 | 71 | (** [with_error_and_exn_handler ?dsn f] runs [f]. If [f] throws an exception or 72 | error, it will be uploaded to Sentry and then re-raised or returned. Note 73 | that [Error.t] does not handle backtraces as well as exceptions. *) 74 | val with_error_and_exn_handler : (unit -> 'a Or_error.t) -> 'a Or_error.t 75 | 76 | (** [with_async_exn_handler f] runs [f]. If [f] throws one or more exceptions, they 77 | will be uploaded to Sentry. The first raised exception willl be re-raised 78 | (multiple exceptions could be raised to the Async monitor but only one can 79 | be re-raised). *) 80 | val with_async_exn_handler : (unit -> 'a Deferred.t) -> 'a Deferred.t 81 | 82 | (** See [with_exn_handler_ignore] and [with_async_exn_handler] *) 83 | val with_async_exn_handler_ignore : (unit -> unit Deferred.t) -> unit Deferred.t 84 | 85 | (** [with_async_error_and_exn_handler f] runs [f]. If [f] throws an exception or 86 | returns an error, it will be uploaded to Sentry and then re-raised or 87 | returned. *) 88 | val with_async_error_and_exn_handler 89 | : (unit -> 'a Deferred.Or_error.t) 90 | -> 'a Deferred.Or_error.t 91 | -------------------------------------------------------------------------------- /src/sentry.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Async_kernel 3 | open Async_unix 4 | module Breadcrumb = Breadcrumb 5 | module Client = Client 6 | module Config = Config 7 | module Context = Context 8 | module Dsn = Dsn 9 | module Event = Event 10 | module Exception = Exception 11 | module Platform = Platform 12 | module Sdk = Sdk 13 | module Severity_level = Severity_level 14 | 15 | let make_key name sexp_of = 16 | let name = "sentry_" ^ name in 17 | Univ_map.Key.create ~name sexp_of 18 | ;; 19 | 20 | let dsn_key = make_key "dsn" [%sexp_of: Dsn.t] 21 | let context_key = make_key "context" [%sexp_of: Context.t] 22 | let with_thread_local key value f = Scheduler.with_local key (Some value) ~f 23 | let with_dsn value f = with_thread_local dsn_key value f 24 | let with_context value f = with_thread_local context_key value f 25 | let default_context = lazy (Context.default ()) 26 | 27 | let find_context () = 28 | Scheduler.find_local context_key 29 | |> function 30 | | Some context -> context 31 | | None -> Lazy.force default_context 32 | ;; 33 | 34 | let with_new_context ?tags f = 35 | let context = find_context () |> Context.copy in 36 | with_context context (fun () -> 37 | Option.iter tags ~f:(fun tags -> Context.merge_tags tags context); 38 | f context) 39 | ;; 40 | 41 | let set_environment env = (find_context ()).environment <- Some env 42 | let set_server_name name = (find_context ()).server_name <- Some name 43 | let set_release release = (find_context ()).release <- Some release 44 | let merge_tags tags = find_context () |> Context.merge_tags tags 45 | let add_breadcrumb crumb = find_context () |> Context.add_breadcrumb crumb 46 | 47 | let make_event ?tags ?exn ?message () = 48 | let context = find_context () in 49 | let exn = Option.map exn ~f:List.return in 50 | Event.make ?exn ?message ~context ?tags () 51 | ;; 52 | 53 | let capture_event ?tags ?exn ?message () = 54 | let dsn = Scheduler.find_local dsn_key |> Option.value ~default:Dsn.default in 55 | match dsn with 56 | | Some dsn -> 57 | let event = make_event ?tags ?exn ?message () in 58 | Log.Global.info "Uploading sentry event %s" (Uuid.unwrap event.event_id); 59 | Client.send_event ~dsn event 60 | | _ -> Log.Global.info "Not uploading Sentry event because no DSN is set" 61 | ;; 62 | 63 | let capture_message ?tags message = 64 | let message = Message.make ~message () in 65 | capture_event ?tags ~message () 66 | ;; 67 | 68 | let capture_exception ?tags ?message exn = 69 | let exn = Exception.of_exn exn in 70 | let message = Option.map message ~f:(fun message -> Message.make ~message ()) in 71 | capture_event ?tags ?message ~exn () 72 | ;; 73 | 74 | let capture_error ?tags err = 75 | let exn = Exception.of_error err in 76 | let message = Message.make ~message:(Error.to_string_hum err) () in 77 | capture_event ?tags ~message ~exn () 78 | ;; 79 | 80 | let with_exn_handler f = 81 | try f () with 82 | | e -> 83 | let backtrace = Caml.Printexc.get_raw_backtrace () in 84 | capture_exception e; 85 | Caml.Printexc.raise_with_backtrace e backtrace 86 | ;; 87 | 88 | let with_exn_handler_ignore f = 89 | try f () with 90 | | e -> capture_exception e 91 | ;; 92 | 93 | let capture_and_return_or_error v = 94 | match v with 95 | | Ok _ -> v 96 | | Error e -> 97 | capture_error e; 98 | v 99 | ;; 100 | 101 | let with_error_and_exn_handler f = 102 | with_exn_handler (fun () -> f () |> capture_and_return_or_error) 103 | ;; 104 | 105 | let with_async_exn_handler f = 106 | Monitor.try_with ~extract_exn:false ~rest:(`Call capture_exception) f 107 | >>= function 108 | | Ok res -> return res 109 | | Error e -> 110 | let backtrace = Caml.Printexc.get_raw_backtrace () in 111 | capture_exception e; 112 | Caml.Printexc.raise_with_backtrace e backtrace 113 | ;; 114 | 115 | let with_async_exn_handler_ignore f = Monitor.handle_errors f capture_exception 116 | 117 | let with_async_error_and_exn_handler f = 118 | with_async_exn_handler (fun () -> f () >>| capture_and_return_or_error) 119 | ;; 120 | -------------------------------------------------------------------------------- /src/client.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Async_kernel 3 | open Async_unix 4 | 5 | let user_agent = sprintf "%s/%s" Config.name Config.version 6 | 7 | let dsn_to_auth_header { Dsn.uri; public_key; private_key; _ } time = 8 | let value = 9 | let base = 10 | sprintf 11 | "Sentry sentry_version=7, sentry_client=%s, sentry_timestamp=%d, sentry_key=%s" 12 | user_agent 13 | Time.(to_span_since_epoch time |> Span.to_sec |> Float.iround_exn) 14 | public_key 15 | in 16 | (* Only had a private key if we have one and we're talking over a secure 17 | channel *) 18 | match Uri.scheme uri, private_key with 19 | | Some "https", Some private_key -> sprintf "%s, sentry_secret=%s" base private_key 20 | | _ -> base 21 | in 22 | Cohttp.Header.init_with "X-Sentry-Auth" value 23 | ;; 24 | 25 | let make_headers ~dsn timestamp = 26 | dsn_to_auth_header dsn timestamp 27 | |> Fn.flip Cohttp.Header.prepend_user_agent user_agent 28 | |> fun h -> Cohttp.Header.add h "Content-Type" "application/json" 29 | ;; 30 | 31 | let rec send_request ~headers ~data uri = 32 | let body = Cohttp_async.Body.of_string data in 33 | let%bind response, body = Cohttp_async.Client.post ~headers ~body uri in 34 | if Cohttp.Response.status response 35 | |> Cohttp.Code.code_of_status 36 | |> Cohttp.Code.is_redirection 37 | then 38 | Cohttp_async.Body.drain body 39 | >>= fun () -> 40 | Cohttp.Response.headers response 41 | |> Cohttp.Header.get_location 42 | |> function 43 | | None -> failwithf "Redirect with no Location header from %s" (Uri.to_string uri) () 44 | | Some uri -> send_request ~headers ~data uri 45 | else return (response, body) 46 | ;; 47 | 48 | type api_error = 49 | { status : Cohttp.Code.status_code 50 | ; error : string option 51 | ; event : Event.t 52 | } 53 | [@@deriving sexp_of] 54 | 55 | exception Api_error of api_error 56 | 57 | let send_event_and_wait_exn ~dsn event = 58 | let headers = make_headers ~dsn event.Event.timestamp in 59 | let uri = Dsn.event_store_uri dsn in 60 | let data = Event.to_json_string event in 61 | let%bind response, body = send_request ~headers ~data uri in 62 | match Cohttp.Response.status response with 63 | | `OK -> 64 | Cohttp_async.Body.to_string body 65 | >>| Payloads_j.response_of_string 66 | >>| fun { Payloads_j.id } -> id 67 | | status -> 68 | Cohttp_async.Body.drain body 69 | >>| fun () -> 70 | let error = 71 | Cohttp.Response.headers response |> Fn.flip Cohttp.Header.get "X-Sentry-Error" 72 | in 73 | raise (Api_error { status; error; event }) 74 | ;; 75 | 76 | let send_event_and_wait ~dsn event = 77 | Monitor.try_with (fun () -> send_event_and_wait_exn ~dsn event) 78 | >>| function 79 | | Ok id -> 80 | Log.Global.info "Successfully uploaded sentry event %s" (Uuid.unwrap event.event_id); 81 | Some id 82 | | Error e -> 83 | (match Monitor.extract_exn e with 84 | | Api_error { status = `Too_many_requests; event; _ } -> 85 | Log.Global.error 86 | "Event %s not uploaded due to Sentry API limits." 87 | (Uuid.unwrap event.event_id); 88 | None 89 | | _ -> 90 | Exn.to_string e |> Log.Global.error "Failed to upload Sentry event: %s"; 91 | None) 92 | ;; 93 | 94 | let event_pipe = 95 | let reader, writer = Pipe.create () in 96 | (* Use a pipe to let us sent events asynchronously and still ensure that they're 97 | all written before the program exits *) 98 | let close p = 99 | if not (Pipe.is_closed p) 100 | then ( 101 | Pipe.close p; 102 | Pipe.upstream_flushed p >>| ignore) 103 | else return () 104 | in 105 | Pipe.iter ~flushed:When_value_processed reader ~f:(fun (dsn, event) -> 106 | send_event_and_wait ~dsn event |> Deferred.ignore_m) 107 | |> don't_wait_for; 108 | Shutdown.at_shutdown (fun () -> 109 | close writer 110 | >>= fun () -> Pipe.downstream_flushed writer >>= fun _ -> Log.Global.flushed ()); 111 | Gc.add_finalizer_exn writer (Fn.compose don't_wait_for close); 112 | writer 113 | ;; 114 | 115 | let send_event ~dsn event = Pipe.write_without_pushback_if_open event_pipe (dsn, event) 116 | -------------------------------------------------------------------------------- /src/event.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Util 3 | 4 | type t = 5 | { event_id : Uuidm.t sexp_opaque 6 | ; timestamp : Time.t sexp_opaque 7 | ; logger : string sexp_option 8 | ; platform : Platform.t 9 | ; sdk : Sdk.t 10 | ; level : Severity_level.t sexp_option 11 | ; culprit : string sexp_option 12 | ; server_name : string sexp_option 13 | ; release : string sexp_option 14 | ; tags : string String.Map.t 15 | ; environment : string sexp_option 16 | ; modules : string String.Map.t 17 | ; extra : Json.t String.Map.t 18 | ; fingerprint : string list sexp_option 19 | ; exception_ : Exception.t list option sexp_opaque 20 | ; message : Message.t sexp_option 21 | ; breadcrumbs : Breadcrumb.t list 22 | } 23 | [@@deriving sexp_of] 24 | 25 | let make 26 | ?event_id 27 | ?timestamp 28 | ?context 29 | ?tags 30 | ?logger 31 | ?(platform = `Other) 32 | ?(sdk = Sdk.default) 33 | ?level 34 | ?culprit 35 | ?fingerprint 36 | ?message 37 | ?exn 38 | () 39 | = 40 | let { Context.server_name 41 | ; release 42 | ; environment 43 | ; extra 44 | ; tags = context_tags 45 | ; breadcrumbs 46 | ; _ 47 | } 48 | = 49 | match context with 50 | | Some context -> context 51 | | None -> Context.empty () 52 | in 53 | let tags = 54 | (match tags with 55 | | None | Some [] -> context_tags 56 | | Some tags -> 57 | let merged = Hashtbl.copy context_tags in 58 | List.iter tags ~f:(fun (key, data) -> Hashtbl.set merged ~key ~data); 59 | merged) 60 | |> Hashtbl.to_alist 61 | |> String.Map.of_alist_exn 62 | in 63 | let event_id = 64 | match event_id with 65 | | Some id -> id 66 | | None -> Uuidm.create `V4 67 | in 68 | let timestamp = 69 | match timestamp with 70 | | Some ts -> ts 71 | | None -> Time.now () 72 | in 73 | { event_id 74 | ; timestamp 75 | ; logger 76 | ; platform 77 | ; sdk 78 | ; level 79 | ; culprit 80 | ; server_name 81 | ; release 82 | ; tags 83 | ; environment 84 | ; modules = String.Map.empty 85 | ; extra = String.Table.to_alist extra |> String.Map.of_alist_exn 86 | ; fingerprint 87 | ; message 88 | ; exception_ = exn 89 | ; breadcrumbs = Queue.to_list breadcrumbs 90 | } 91 | ;; 92 | 93 | let to_payload 94 | { event_id 95 | ; timestamp 96 | ; logger 97 | ; platform 98 | ; sdk 99 | ; level 100 | ; culprit 101 | ; server_name 102 | ; release 103 | ; tags 104 | ; environment 105 | ; modules 106 | ; extra 107 | ; fingerprint 108 | ; exception_ 109 | ; message 110 | ; breadcrumbs 111 | } 112 | = 113 | { Payloads_t.event_id 114 | ; timestamp 115 | ; logger 116 | ; platform 117 | ; sdk = Sdk.to_payload sdk 118 | ; level 119 | ; culprit 120 | ; server_name 121 | ; release 122 | ; tags = map_to_alist_option tags 123 | ; environment 124 | ; modules = map_to_alist_option modules 125 | ; extra = map_to_alist_option extra 126 | ; fingerprint 127 | ; exception_ = Option.map ~f:Exception.list_to_payload exception_ 128 | ; message = Option.map ~f:Message.to_payload message 129 | ; breadcrumbs = 130 | (match breadcrumbs with 131 | | [] -> None 132 | | _ -> List.map breadcrumbs ~f:Breadcrumb.to_payload |> Util.empty_list_option) 133 | } 134 | ;; 135 | 136 | let to_json_string t = to_payload t |> Payloads_j.string_of_event 137 | 138 | let%expect_test "to_json_string basic" = 139 | let event_id = Uuid.wrap "bce345569e7548a384bac4512a9ad909" in 140 | let timestamp = Time.of_string "2018-08-03T11:44:21.298019Z" in 141 | make ~event_id ~timestamp () |> to_json_string |> print_endline; 142 | [%expect 143 | {| {"event_id":"bce345569e7548a384bac4512a9ad909","timestamp":"2018-08-03T11:44:21.298019","platform":"other","sdk":{"name":"sentry-ocaml","version":"0.1"}} |}] 144 | ;; 145 | 146 | let%expect_test "to_json_string everything" = 147 | (try raise (Failure "test") with 148 | | exn -> 149 | let event_id = Uuid.wrap "ad2579b4f62f486498781636c1450148" in 150 | let timestamp = Time.of_string "2014-12-23T22:44:21.2309Z" in 151 | let message = Message.make ~message:"Testy test test" () in 152 | let context = Context.empty () in 153 | context.server_name <- Some "example.com"; 154 | context.release <- Some "5"; 155 | context.environment <- Some "dev"; 156 | Context.merge_modules [ "ocaml", "4.02.1"; "core", "v0.10" ] context; 157 | Context.merge_extra [ "a thing", `String "value" ] context; 158 | Breadcrumb.make ~timestamp ~message:"test crumb" () 159 | |> Fn.flip Context.add_breadcrumb context; 160 | make 161 | ~event_id 162 | ~timestamp 163 | ~logger:"test" 164 | ~platform:`Python 165 | ~context 166 | ~sdk:(Sdk.make ~name:"test-sdk" ~version:"10.5" ()) 167 | ~level:`Error 168 | ~culprit:"the tests" 169 | ~tags:[ "a", "b"; "c", "d" ] 170 | ~fingerprint:[ "039432409"; "asdf" ] 171 | ~message 172 | ~exn:[ Exception.of_exn exn ] 173 | () 174 | |> to_json_string 175 | |> print_endline); 176 | [%expect 177 | {| {"event_id":"ad2579b4f62f486498781636c1450148","timestamp":"2014-12-23T22:44:21.230900","logger":"test","platform":"python","sdk":{"name":"test-sdk","version":"10.5"},"level":"error","culprit":"the tests","server_name":"example.com","release":"5","tags":{"a":"b","c":"d"},"environment":"dev","extra":{"a thing":"value"},"fingerprint":["039432409","asdf"],"exception":{"values":[{"type":"Failure","value":"test","stacktrace":{"frames":[{"filename":"src/event.ml","lineno":147,"colno":7}]}}]},"sentry.interfaces.Message":{"message":"Testy test test"},"breadcrumbs":[{"timestamp":"2014-12-23T22:44:21.230900","type":"default","message":"test crumb","level":"info"}]} |}] 178 | ;; 179 | 180 | let%expect_test "to_json_string really long message" = 181 | (* String_capped.t should ensure that the message is capped to 512 characters. 182 | which will keep the length of the total string at 708 chars *) 183 | let event_id = Uuid.wrap "bce345569e7548a384bac4512a9ad909" in 184 | let timestamp = Time.of_string "2018-08-03T11:44:21.298019Z" in 185 | let message = Message.make ~message:(String.init 5000 ~f:(Fn.const 'a')) () in 186 | let output = make ~event_id ~timestamp ~message () |> to_json_string in 187 | String.length output |> [%test_result: int] ~expect:4292; 188 | print_endline output; 189 | [%expect 190 | {| {"event_id":"bce345569e7548a384bac4512a9ad909","timestamp":"2018-08-03T11:44:21.298019","platform":"other","sdk":{"name":"sentry-ocaml","version":"0.1"},"sentry.interfaces.Message":{"message":"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"}} |}] 191 | ;; 192 | -------------------------------------------------------------------------------- /src/exception.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Async 3 | open Util 4 | 5 | module Mechanism = struct 6 | type t = 7 | { type_ : string 8 | ; description : string option 9 | ; help_link : string option 10 | ; handled : bool option (* TODO: meta *) 11 | ; data : string String.Map.t 12 | } 13 | 14 | let make ~type_ ?description ?help_link ?handled ?(data = String.Map.empty) () = 15 | { type_; description; help_link; handled; data } 16 | ;; 17 | 18 | let to_payload { type_; description; help_link; handled; data } = 19 | { Payloads_t.type_; description; help_link; handled; data = map_to_alist_option data } 20 | ;; 21 | end 22 | 23 | module Frame = struct 24 | type t = 25 | { filename : string option 26 | ; function_ : string option 27 | ; module_ : string option 28 | ; lineno : int option 29 | ; colno : int option 30 | ; abs_path : string option 31 | ; context_line : string option 32 | ; pre_context : string list 33 | ; post_context : string list 34 | ; in_app : bool option 35 | ; vars : string String.Map.t 36 | ; package : string option 37 | ; platform : Platform.t option 38 | (* TODO: image_addr, instruction_addr, symbol_addr, instruction_offset *) 39 | } 40 | 41 | let make 42 | ?filename 43 | ?function_ 44 | ?module_ 45 | ?lineno 46 | ?colno 47 | ?abs_path 48 | ?context_line 49 | ?(pre_context = []) 50 | ?(post_context = []) 51 | ?in_app 52 | ?(vars = String.Map.empty) 53 | ?package 54 | ?platform 55 | () 56 | = 57 | [ filename; function_; module_ ] 58 | |> List.for_all ~f:Option.is_none 59 | |> function 60 | | true -> 61 | Or_error.error_string 62 | "One of filename, function_ or module_ is required in Frame.make" 63 | | false -> 64 | Ok 65 | { filename 66 | ; function_ 67 | ; module_ 68 | ; lineno 69 | ; colno 70 | ; abs_path 71 | ; context_line 72 | ; pre_context 73 | ; post_context 74 | ; in_app 75 | ; vars 76 | ; package 77 | ; platform 78 | } 79 | ;; 80 | 81 | let make_exn 82 | ?filename 83 | ?function_ 84 | ?module_ 85 | ?lineno 86 | ?colno 87 | ?abs_path 88 | ?context_line 89 | ?pre_context 90 | ?post_context 91 | ?in_app 92 | ?vars 93 | ?package 94 | ?platform 95 | () 96 | = 97 | make 98 | ?filename 99 | ?function_ 100 | ?module_ 101 | ?lineno 102 | ?colno 103 | ?abs_path 104 | ?context_line 105 | ?pre_context 106 | ?post_context 107 | ?in_app 108 | ?vars 109 | ?package 110 | ?platform 111 | () 112 | |> Or_error.ok_exn 113 | ;; 114 | 115 | let to_payload 116 | { filename 117 | ; function_ 118 | ; module_ 119 | ; lineno 120 | ; colno 121 | ; abs_path 122 | ; context_line 123 | ; pre_context 124 | ; post_context 125 | ; in_app 126 | ; vars 127 | ; package 128 | ; platform 129 | } 130 | = 131 | { Payloads_t.filename 132 | ; function_ 133 | ; module_ 134 | ; lineno 135 | ; colno 136 | ; abs_path 137 | ; context_line 138 | ; pre_context = empty_list_option pre_context 139 | ; post_context = empty_list_option post_context 140 | ; in_app 141 | ; vars = map_to_alist_option vars 142 | ; package 143 | ; platform 144 | } 145 | ;; 146 | end 147 | 148 | type t = 149 | { type_ : string 150 | ; value : string option 151 | ; module_ : string option 152 | ; thread_id : string option 153 | ; mechanism : Mechanism.t option 154 | ; stacktrace : Frame.t list 155 | } 156 | 157 | let make ~type_ ?value ?module_ ?thread_id ?mechanism ?(stacktrace = []) () = 158 | { type_; value; module_; thread_id; mechanism; stacktrace } 159 | ;; 160 | 161 | let to_payload { type_; value; module_; thread_id; mechanism; stacktrace } = 162 | { Payloads_t.type_ 163 | ; value 164 | ; module_ 165 | ; thread_id 166 | ; mechanism = Option.map mechanism ~f:Mechanism.to_payload 167 | ; stacktrace = 168 | List.map stacktrace ~f:Frame.to_payload 169 | |> empty_list_option 170 | |> Option.map ~f:(fun frames -> { Payloads_t.frames }) 171 | } 172 | ;; 173 | 174 | let list_to_payload t = 175 | let values = List.map t ~f:to_payload in 176 | { Payloads_t.values } 177 | ;; 178 | 179 | let backtrace_regex = 180 | Re2.create_exn 181 | {|(?:Raised at|Called from)(?: \S+ in)? file "([^"]*)", line ([0-9]+), characters ([0-9]+)-[0-9]+|} 182 | ;; 183 | 184 | let of_exn exn = 185 | let stacktrace = 186 | Caml.Printexc.get_raw_backtrace () 187 | |> Caml.Printexc.backtrace_slots 188 | |> Option.value ~default:[||] 189 | |> Array.to_list 190 | (* Frames should be sorted from oldest to newest. *) 191 | |> List.rev 192 | |> List.filter_map ~f:(fun frame -> 193 | match Caml.Printexc.Slot.location frame with 194 | | None -> None 195 | | Some { Caml.Printexc.filename; line_number; start_char; _ } -> 196 | Frame.make ~filename ~lineno:line_number ~colno:start_char () |> Option.some) 197 | |> Or_error.all 198 | (* Asserting that there are no errors here since we always pass 199 | ~filename to Frame.make *) 200 | |> Or_error.ok_exn 201 | in 202 | (* Extract the inner exception for messages and stack trace when dealing 203 | with async *) 204 | let base_exn = Monitor.extract_exn exn in 205 | let type_ = 206 | (* exn_slot_name prints something like Module__filename.Submodule.Exn_name, 207 | but we only want Exn_name *) 208 | Caml.Printexc.exn_slot_name base_exn |> String.split ~on:'.' |> List.last_exn 209 | in 210 | let value = 211 | let str = Caml.Printexc.to_string base_exn in 212 | (* Try to extract nicer info from the string output *) 213 | try 214 | (try Sexp.of_string str with 215 | | _ -> 216 | (* Try to parse the default format: Exception_name(arg1, arg2) *) 217 | String.chop_suffix_exn str ~suffix:")" 218 | |> String.split ~on:'(' 219 | |> (function 220 | | name :: args -> 221 | let args = 222 | String.concat ~sep:"" args 223 | |> String.split ~on:',' 224 | |> List.map ~f:(fun arg -> Sexp.of_string arg) 225 | in 226 | Sexp.List (Atom name :: args) 227 | | _ -> assert false)) 228 | |> function 229 | (* Exceptions using [@@deriving sexp_of] will be in the form 230 | (Exception_name "message" other args) *) 231 | | Sexp.List (Atom name :: msgs) when String.is_suffix ~suffix:type_ name -> 232 | (match msgs with 233 | | [] -> None 234 | | [ Atom msg ] -> Some msg 235 | | sexp -> Sexp.to_string_hum (Sexp.List sexp) |> Option.some) 236 | (* Handles argumentless exceptions like Not_found *) 237 | | Atom name when String.is_suffix ~suffix:type_ name -> None 238 | | sexp -> Sexp.to_string_hum sexp |> Option.some 239 | with 240 | | _ -> Some str 241 | in 242 | (* Combine the stack trace from the Monitor exn if applicable *) 243 | let stacktrace, value = 244 | if phys_equal base_exn exn 245 | then stacktrace, value 246 | else ( 247 | let monitor_trace = 248 | let open Sexp in 249 | Exn.sexp_of_t exn 250 | |> function 251 | | List [ Atom "monitor.ml.Error"; _base_exn; List monitor_stacktrace ] -> 252 | List.filter_map monitor_stacktrace ~f:(function 253 | | Atom frame -> 254 | Re2.find_submatches backtrace_regex frame 255 | |> (function 256 | | Ok [| _; Some filename; Some lineno; Some colno |] -> 257 | (try 258 | let lineno = Int.of_string lineno 259 | and colno = Int.of_string colno in 260 | Frame.make_exn ~filename ~lineno ~colno () |> Option.some 261 | with 262 | | _ -> None) 263 | | _ -> None) 264 | | _ -> None) 265 | | _ -> [] 266 | in 267 | match monitor_trace with 268 | | [] -> 269 | ( stacktrace 270 | , List.filter_opt [ value; Some (Exn.to_string exn) ] 271 | |> String.concat ~sep:"\n\n" 272 | |> Option.some ) 273 | | monitor_trace -> stacktrace @ monitor_trace, value) 274 | in 275 | make ~type_ ?value ~stacktrace () 276 | ;; 277 | 278 | let of_error err = 279 | let open Error.Internal_repr in 280 | let rec find_backtrace = function 281 | | With_backtrace (_, bt) -> Some bt 282 | | Tag_t (_, t) | Tag_arg (_, _, t) -> find_backtrace t 283 | | Of_list (_, l) -> List.find_map l ~f:find_backtrace 284 | | _ -> None 285 | in 286 | match of_info err with 287 | | Exn exn -> of_exn exn 288 | | info -> 289 | let _backtrace = find_backtrace info in 290 | (* TODO: Parse backtrace *) 291 | let type_ = "Error" in 292 | let value = Error.to_string_hum err in 293 | make ~type_ ~value () 294 | ;; 295 | 296 | let exn_test_helper e = 297 | try raise e with 298 | | e -> 299 | let e = of_exn e in 300 | { e with 301 | stacktrace = 302 | List.map e.stacktrace ~f:(fun frame -> 303 | { frame with Frame.lineno = Some 192; colno = Some 4 }) 304 | } 305 | |> to_payload 306 | |> Payloads_j.string_of_exception_value 307 | |> print_endline 308 | ;; 309 | 310 | exception Exception_containing_function of (unit -> unit) 311 | 312 | let%expect_test "don't throw compare error on exn containing function" = 313 | exn_test_helper (Exception_containing_function Fn.id); 314 | [%expect 315 | {| {"type":"Exception_containing_function","value":"_","stacktrace":{"frames":[{"filename":"src/exception.ml","lineno":192,"colno":4}]}} |}] 316 | ;; 317 | 318 | let%expect_test "parse exn to payload" = 319 | exn_test_helper (Failure "This is a test"); 320 | [%expect 321 | {| {"type":"Failure","value":"This is a test","stacktrace":{"frames":[{"filename":"src/exception.ml","lineno":192,"colno":4}]}} |}] 322 | ;; 323 | 324 | let%expect_test "parse Not_found to payload" = 325 | exn_test_helper Caml.Not_found; 326 | [%expect 327 | {| {"type":"Not_found","stacktrace":{"frames":[{"filename":"src/exception.ml","lineno":192,"colno":4}]}} |}] 328 | ;; 329 | 330 | exception Custom_sexp_exception of string * int list [@@deriving sexp_of] 331 | 332 | let%expect_test "parse complex sexp exn to payload" = 333 | exn_test_helper (Custom_sexp_exception ("This is a test", [ 4; 2 ])); 334 | [%expect 335 | {| {"type":"Custom_sexp_exception","value":"(\"This is a test\" (4 2))","stacktrace":{"frames":[{"filename":"src/exception.ml","lineno":192,"colno":4}]}} |}] 336 | ;; 337 | 338 | exception Custom_no_sexp_exception of string * int list 339 | 340 | let%expect_test "parse complex no-sexp exn to payload" = 341 | exn_test_helper (Custom_no_sexp_exception ("This is a test", [ 4; 2 ])); 342 | [%expect 343 | {| {"type":"Custom_no_sexp_exception","value":"(\"This is a test\" _)","stacktrace":{"frames":[{"filename":"src/exception.ml","lineno":192,"colno":4}]}} |}] 344 | ;; 345 | 346 | exception Custom_no_sexp_single_arg_exception of string 347 | 348 | let%expect_test "parse single arg no-sexp exn to payload" = 349 | exn_test_helper (Custom_no_sexp_single_arg_exception "This is a test"); 350 | [%expect 351 | {| {"type":"Custom_no_sexp_single_arg_exception","value":"This is a test","stacktrace":{"frames":[{"filename":"src/exception.ml","lineno":192,"colno":4}]}} |}] 352 | ;; 353 | 354 | exception Custom_no_sexp_no_arg_exception 355 | 356 | let%expect_test "parse no arg no-sexp exn to payload" = 357 | exn_test_helper Custom_no_sexp_no_arg_exception; 358 | [%expect 359 | {| {"type":"Custom_no_sexp_no_arg_exception","stacktrace":{"frames":[{"filename":"src/exception.ml","lineno":192,"colno":4}]}} |}] 360 | ;; 361 | 362 | let%expect_test "parse Error.t to payload" = 363 | Error.of_string "This is different test" 364 | |> of_error 365 | |> to_payload 366 | |> Payloads_j.string_of_exception_value 367 | |> print_endline; 368 | [%expect {| {"type":"Error","value":"This is different test"} |}] 369 | ;; 370 | 371 | let%expect_test "parse Async Monitor exception" = 372 | Backtrace.elide := false; 373 | Monitor.try_with ~extract_exn:false (fun () -> raise Caml.Not_found) 374 | >>= fun res -> 375 | (match res with 376 | | Ok () -> assert false 377 | | Error exn -> exn_test_helper exn); 378 | [%expect 379 | {| {"type":"Not_found","stacktrace":{"frames":[{"filename":"src/exception.ml","lineno":192,"colno":4},{"filename":"src/exception.ml","lineno":192,"colno":4},{"filename":"src/monitor.ml","lineno":192,"colno":4},{"filename":"src/job_queue.ml","lineno":192,"colno":4}]}} |}] 380 | ;; 381 | 382 | let%expect_test "parse Async Monitor exception parse failure" = 383 | Backtrace.elide := true; 384 | Monitor.try_with ~extract_exn:false (fun () -> raise Caml.Not_found) 385 | >>= fun res -> 386 | (match res with 387 | | Ok () -> assert false 388 | | Error exn -> exn_test_helper exn); 389 | [%expect 390 | {| {"type":"Not_found","value":"(monitor.ml.Error Not_found (\"\"))","stacktrace":{"frames":[{"filename":"src/exception.ml","lineno":192,"colno":4}]}} |}] 391 | ;; 392 | --------------------------------------------------------------------------------