├── src ├── logs-syslog.mllib ├── logs-syslog-unix.mllib ├── logs-syslog-lwt-tls.mllib ├── logs-syslog-mirage-tls.mllib ├── logs-syslog-lwt.mllib ├── logs-syslog-mirage.mllib ├── logs_syslog_lwt_common.mli ├── logs_syslog_lwt_common.ml ├── logs_syslog.ml ├── logs_syslog_lwt_tls.mli ├── logs_syslog_mirage_tls.mli ├── logs_syslog_unix.mli ├── logs_syslog_lwt.mli ├── logs_syslog_mirage_tls.ml ├── logs_syslog_mirage.mli ├── logs_syslog_mirage.ml ├── logs_syslog_unix.ml ├── logs_syslog_lwt.ml ├── logs_syslog_lwt_tls.ml └── logs_syslog.mli ├── doc └── api.odocl ├── .travis-test.sh ├── .merlin ├── .gitignore ├── example ├── config.ml └── unikernel.ml ├── CHANGES.md ├── _tags ├── .travis.yml ├── LICENSE.md ├── pkg ├── pkg.ml └── META ├── opam └── README.md /src/logs-syslog.mllib: -------------------------------------------------------------------------------- 1 | Logs_syslog 2 | -------------------------------------------------------------------------------- /src/logs-syslog-unix.mllib: -------------------------------------------------------------------------------- 1 | Logs_syslog_unix 2 | -------------------------------------------------------------------------------- /src/logs-syslog-lwt-tls.mllib: -------------------------------------------------------------------------------- 1 | Logs_syslog_lwt_tls 2 | -------------------------------------------------------------------------------- /src/logs-syslog-mirage-tls.mllib: -------------------------------------------------------------------------------- 1 | Logs_syslog_mirage_tls 2 | -------------------------------------------------------------------------------- /src/logs-syslog-lwt.mllib: -------------------------------------------------------------------------------- 1 | Logs_syslog_lwt_common 2 | Logs_syslog_lwt 3 | -------------------------------------------------------------------------------- /src/logs-syslog-mirage.mllib: -------------------------------------------------------------------------------- 1 | Logs_syslog_lwt_common 2 | Logs_syslog_mirage 3 | -------------------------------------------------------------------------------- /doc/api.odocl: -------------------------------------------------------------------------------- 1 | Logs_syslog 2 | Logs_syslog_unix 3 | Logs_syslog_lwt 4 | Logs_syslog_lwt_tls 5 | Logs_syslog_mirage 6 | Logs_syslog_mirage_tls 7 | -------------------------------------------------------------------------------- /src/logs_syslog_lwt_common.mli: -------------------------------------------------------------------------------- 1 | val syslog_report_common : 2 | string -> int -> (unit -> Ptime.t) -> (string -> unit Lwt.t) -> Logs.reporter 3 | -------------------------------------------------------------------------------- /.travis-test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh -x 2 | 3 | export OPAMYES=1 4 | eval `opam config env` 5 | opam install mirage 6 | cd example 7 | mirage configure -t unix 8 | make depend 9 | make 10 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG logs syslog-message ptime ptime.clock.os ipaddr 2 | PKG x509 lwt tls tls.lwt cstruct 3 | PKG mirage-kv-lwt mirage-console-lwt mirage-clock mirage-stack-lwt 4 | PKG duration mirage-types-lwt mirage-types 5 | 6 | S src 7 | 8 | B _build/** -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | *.native 3 | *.byte 4 | *.install 5 | 6 | example/mirage-unikernel-*.opam 7 | example/.mirage.config 8 | example/Makefile 9 | example/key_gen.ml 10 | example/log 11 | example/main.ml 12 | example/myocamlbuild.ml 13 | example/syslog* 14 | 15 | *.key 16 | *.pem 17 | *.csr 18 | certs/ -------------------------------------------------------------------------------- /example/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let packages = [ 4 | package "duration"; 5 | package ~sublibs:["mirage"] "logs-syslog"; 6 | package ~sublibs:["lwt"] "logs" 7 | ] 8 | 9 | let handler = 10 | foreign ~packages "Unikernel.Main" 11 | (console @-> pclock @-> time @-> stackv4 @-> job) 12 | 13 | let stack = generic_stackv4 default_network 14 | 15 | let () = 16 | register "syslog" [handler $ default_console $ default_posix_clock $ default_time $ stack] 17 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## 0.1.0 (2017-01-18) 2 | 3 | - remove <4.03 compatibility 4 | - Mirage: use STACK instead of UDP/TCP 5 | - MirageOS3 support 6 | 7 | ## 0.0.2 (2016-11-06) 8 | 9 | - Unix, TCP: wait (if something else reconnects) for 10 ms instead of 1s 10 | - Lwt, UDP: remove unneeded mutex 11 | - Lwt, TCP: lock in reconnect, close socket during at_exit 12 | - Lwt, TLS: lock in reconnect, close socket during at_exit 13 | - Mirage, TCP: respect ?framing argument 14 | - Mirage: catch possible exceptions, print errors to console (now required) 15 | - Mirage, TCP & TLS: lock in reconnect 16 | 17 | ## 0.0.1 (2016-10-31) 18 | 19 | - initial release with Unix, Lwt, Mirage2 support -------------------------------------------------------------------------------- /src/logs_syslog_lwt_common.ml: -------------------------------------------------------------------------------- 1 | open Logs_syslog 2 | 3 | let syslog_report_common host len now send = 4 | let report src level ~over k msgf = 5 | let source = Logs.Src.name src in 6 | let timestamp = now () in 7 | let k tags ?header _ = 8 | let msg = 9 | message ~host ~source ~tags ?header level timestamp (flush ()) 10 | in 11 | let bytes = Syslog_message.encode ~len msg in 12 | let unblock () = over () ; Lwt.return_unit in 13 | Lwt.finalize (fun () -> send bytes) unblock |> Lwt.ignore_result ; k () 14 | in 15 | msgf @@ fun ?header ?(tags = Logs.Tag.empty) fmt -> 16 | Format.kfprintf (k tags ?header) ppf fmt 17 | in 18 | { Logs.report } 19 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true : color(always), bin_annot, safe_string, principal 2 | true : warn(+A-4-44) 3 | true : package(syslog-message logs ptime) 4 | "src" : include 5 | 6 | : package(ptime.clock.os) 7 | 8 | : package(lwt) 9 | 10 | : package(ptime.clock.os lwt) 11 | : package(ptime.clock.os lwt x509 tls tls.lwt cstruct) 12 | 13 | : package(lwt cstruct ipaddr mirage-stack-lwt mirage-console-lwt mirage-clock) 14 | : package(lwt cstruct ipaddr mirage-stack-lwt mirage-console-lwt mirage-kv-lwt mirage-clock tls.mirage x509 tls) 15 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh 3 | script: bash -ex .travis-opam.sh 4 | sudo: required 5 | env: 6 | global: 7 | - PACKAGE="logs-syslog" 8 | matrix: 9 | - OCAML_VERSION=4.03 10 | - OCAML_VERSION=4.04 11 | - OCAML_VERSION=4.03 DEPOPTS="lwt x509 tls cstruct" TESTS=false 12 | - OCAML_VERSION=4.03 DEPOPTS="lwt mirage-stack-lwt mirage-console-lwt mirage-clock cstruct ipaddr" TESTS=false POST_INSTALL_HOOK="./.travis-test.sh" 13 | - OCAML_VERSION=4.04 DEPOPTS="lwt x509 tls mirage-kv-lwt mirage-stack-lwt mirage-console-lwt mirage-clock cstruct ipaddr" TESTS=false POST_INSTALL_HOOK="./.travis-test.sh" 14 | notifications: 15 | email: false 16 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Hannes Mehnert 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | -------------------------------------------------------------------------------- /example/unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Mirage_types_lwt 3 | 4 | module Main (C : CONSOLE) (CLOCK : Mirage_types.PCLOCK) (T : TIME) (S: STACKV4) = struct 5 | module LU = Logs_syslog_mirage.Udp(C)(CLOCK)(S) 6 | 7 | let start c clock _time s = 8 | let ip = Ipaddr.V4.of_string_exn "127.0.0.1" in 9 | let r = LU.create c clock s ~hostname:"MirageOS.example" ip () in 10 | Logs.set_reporter r ; 11 | Logs.set_level ~all:true (Some Logs.Debug) ; 12 | let rec go () = 13 | Logs_lwt.warn (fun l -> l "foobar") >>= fun () -> 14 | Logs_lwt.err (fun l -> l "bar foofoobar") >>= fun () -> 15 | Logs_lwt.info (fun l -> l "foofoobar") >>= fun () -> 16 | Logs_lwt.debug (fun l -> l "debug foofoobar") >>= fun () -> 17 | T.sleep_ns (Duration.of_sec 1) >>= fun () -> 18 | go () 19 | in 20 | go () 21 | 22 | end 23 | -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #use "topfind" 3 | #require "topkg" 4 | open Topkg 5 | 6 | let lwt = Conf.with_pkg ~default:false "lwt" 7 | let mirage = Conf.with_pkg ~default:false "mirage" 8 | let lwt_tls = Conf.with_pkg ~default:false "lwt-tls" 9 | let mirage_tls = Conf.with_pkg ~default:false "mirage-tls" 10 | 11 | let () = 12 | Pkg.describe "logs-syslog" @@ fun c -> 13 | let lwt = Conf.value c lwt 14 | and mirage = Conf.value c mirage 15 | and lwt_tls = Conf.value c lwt_tls 16 | and mirage_tls = Conf.value c mirage_tls 17 | in 18 | Ok [ 19 | Pkg.mllib "src/logs-syslog.mllib" ; 20 | Pkg.mllib "src/logs-syslog-unix.mllib" ; 21 | Pkg.mllib ~api:["Logs_syslog_lwt"] ~cond:lwt "src/logs-syslog-lwt.mllib" ; 22 | Pkg.mllib ~api:["Logs_syslog_lwt_tls"] ~cond:lwt_tls "src/logs-syslog-lwt-tls.mllib" ; 23 | Pkg.mllib ~api:["Logs_syslog_mirage"] ~cond:mirage "src/logs-syslog-mirage.mllib" ; 24 | Pkg.mllib ~api:["Logs_syslog_mirage_tls"] ~cond:mirage_tls "src/logs-syslog-mirage-tls.mllib" ; 25 | ] 26 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "Hannes Mehnert " 3 | authors: ["Hannes Mehnert "] 4 | homepage: "https://github.com/hannesm/logs-syslog" 5 | doc: "https://hannesm.github.io/logs-syslog/doc" 6 | dev-repo: "https://github.com/hannesm/logs-syslog.git" 7 | bug-reports: "https://github.com/hannesm/logs-syslog/issues" 8 | license: "ISC" 9 | available: [ ocaml-version >= "4.03.0"] 10 | 11 | depends: [ 12 | "ocamlfind" {build} 13 | "ocamlbuild" {build} 14 | "topkg" {build} 15 | "logs" 16 | "ptime" 17 | "syslog-message" {>= "0.0.2"} 18 | ] 19 | 20 | depopts: [ 21 | "lwt" 22 | "x509" "tls" "cstruct" 23 | "mirage-kv-lwt" 24 | "mirage-console-lwt" "mirage-clock" "mirage-stack-lwt" "ipaddr" 25 | ] 26 | 27 | conflicts: [ 28 | "mirage-types-lwt" {< "3.0.0"} 29 | ] 30 | 31 | build: [ 32 | [ "ocaml" "pkg/pkg.ml" "build" "--pinned" "%{pinned}%" 33 | "--with-lwt" "%{lwt:installed}%" 34 | "--with-lwt-tls" "%{lwt+x509+tls+cstruct:installed}%" 35 | "--with-mirage" "%{lwt+mirage-stack-lwt+mirage-console-lwt+mirage-clock+cstruct+ipaddr:installed}%" 36 | "--with-mirage-tls" "%{lwt+mirage-kv-lwt+x509+tls+mirage-stack-lwt+mirage-console-lwt+mirage-clock+cstruct+ipaddr:installed}%" 37 | ] 38 | ] 39 | 40 | -------------------------------------------------------------------------------- /src/logs_syslog.ml: -------------------------------------------------------------------------------- 1 | 2 | let slevel = function 3 | | Logs.App -> Syslog_message.Informational 4 | | Logs.Error -> Syslog_message.Error 5 | | Logs.Warning -> Syslog_message.Warning 6 | | Logs.Info -> Syslog_message.Informational 7 | | Logs.Debug -> Syslog_message.Debug 8 | 9 | let ppf, flush = 10 | let b = Buffer.create 255 in 11 | let ppf = Format.formatter_of_buffer b in 12 | let flush () = 13 | Format.pp_print_flush ppf () ; 14 | let s = Buffer.contents b in Buffer.clear b ; s 15 | in 16 | ppf, flush 17 | 18 | (* TODO: can we derive the facility from the source? *) 19 | let message ?(facility = Syslog_message.System_Daemons) 20 | ~host:hostname ~source ~tags ?header level timestamp message = 21 | let tags = 22 | if Logs.Tag.is_empty tags then 23 | "" 24 | else 25 | (Logs.Tag.pp_set ppf tags ; 26 | " " ^ flush ()) 27 | in 28 | let hdr = match header with None -> "" | Some x -> " " ^ x in 29 | let message = Printf.sprintf "%s%s%s %s" source tags hdr message 30 | and severity = slevel level 31 | in 32 | { Syslog_message.facility ; severity ; timestamp ; hostname ; message } 33 | 34 | type framing = [ 35 | | `LineFeed 36 | | `Null 37 | | `Custom of string 38 | | `Count 39 | ] 40 | 41 | let frame_message msg = function 42 | | `LineFeed -> msg ^ "\n" 43 | | `Null -> msg ^ "\000" 44 | | `Custom s -> msg ^ s 45 | | `Count -> Printf.sprintf "%d %s" (String.length msg) msg 46 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Logs-syslog - Logs output via syslog 2 | %%VERSION%% 3 | 4 | This library provides log reporters using syslog over various transports (UDP, 5 | TCP, TLS) with various effectful layers: Unix, Lwt, MirageOS. It integrates the 6 | [Logs](http://erratique.ch/software/logs) library, which provides logging 7 | infrastructure for OCaml, with the 8 | [syslog-message](http://verbosemo.de/syslog-message/) library, which provides 9 | encoding and decoding of syslog messages ([RFC 10 | 3164](https://tools.ietf.org/html/rfc3164)). 11 | 12 | Six ocamlfind libraries are provided: the bare `Logs-syslog`, a minimal 13 | dependency Unix `Logs-syslog-unix`, a Lwt one `Logs-syslog-lwt`, another one 14 | with Lwt and TLS ([RFC 5425](https://tools.ietf.org/html/rfc5425)) support 15 | `Logs-syslog-lwt-tls`, a MirageOS one `Logs-syslog-mirage`, and a MirageOS one 16 | using TLS `Logs-syslog-mirage-tls`. 17 | 18 | Since MirageOS3, [syslog is well integrated](http://docs.mirage.io/mirage/Mirage/index.html#type-syslog_config): 19 | 20 | ``` 21 | let logger = 22 | syslog_udp 23 | (syslog_config ~truncate:1484 "nqsb.io" (Ipaddr.V4.of_string_exn "192.168.0.1")) 24 | net 25 | ... 26 | register "myunikernel" [ 27 | foreign 28 | ~deps:[abstract logger] 29 | ``` 30 | 31 | 32 | ## Documentation 33 | 34 | [![Build Status](https://travis-ci.org/hannesm/logs-syslog.svg?branch=master)](https://travis-ci.org/hannesm/logs-syslog) 35 | 36 | [API documentation](https://hannesm.github.io/logs-syslog/doc/) is available online. 37 | 38 | ## Installation 39 | 40 | This is targeting other libraries (apart from syslog-message) which are released to opam-repository. 41 | 42 | ``` 43 | opam pin add syslog-message --dev-repo 44 | opam pin add logs-syslog https://github.com/hannesm/logs-syslog.git 45 | ``` 46 | -------------------------------------------------------------------------------- /src/logs_syslog_lwt_tls.mli: -------------------------------------------------------------------------------- 1 | (** Logs reporter via syslog using Lwt and TLS 2 | 3 | Please read {!Logs_syslog} first. *) 4 | 5 | (** [tcp_tls_reporter ~hostname remote_ip ~port ~cacert ~cert ~priv_key 6 | ~truncate ~framing ()] is [Ok reporter] or [Error msg]. The TLS connection 7 | validates the certificate of the log server, it must be signed by [cacert]. 8 | The reporters credentials are its public [cert], and its [priv_key]. The 9 | [reporter] sends each log message to [remote_ip, port] via TLS. If the 10 | initial TLS connection to the [remote_ip] fails, an [Error msg] is returned 11 | instead. If the TLS connection fails, the log message is reported to 12 | standard error, and an attempt is made to re-establish the TLS connection. 13 | Each message can be truncated after [truncate] bytes (defaults to no 14 | truncation). Each message is framed: by default a single byte containing 0 15 | is appended, depending on [framing], its length could be prepended, as 16 | specified in {{:https://tools.ietf.org/html/rfc5125}RFC 5125}. The default 17 | value for [hostname] is [Lwt_unix.gethostname ()], the default value for 18 | [port] is 6514. *) 19 | val tcp_tls_reporter : ?hostname:string -> Lwt_unix.inet_addr -> ?port:int -> 20 | cacert:string -> cert:string -> priv_key:string -> 21 | ?truncate:int -> 22 | ?framing:Logs_syslog.framing -> unit -> 23 | (Logs.reporter, string) result Lwt.t 24 | 25 | (** {1:lwt_tls_example Example usage} 26 | 27 | To install a Lwt syslog reporter, sending via TLS to localhost, use the 28 | following snippet (assuming you already have certificates, and the common 29 | name of the collector is "log server"): 30 | {[ 31 | let install_logger () = 32 | tls_reporter (Unix.inet_addr_of_string "127.0.0.1") 33 | ~cacert:"ca.pem" ~cert:"log.pem" ~priv_key:"log.key" 34 | () >|= function 35 | | Ok r -> Logs.set_reporter r 36 | | Error e -> print_endline e 37 | 38 | let _ = Lwt_main.run (install_logger ()) 39 | ]} 40 | 41 | *) 42 | -------------------------------------------------------------------------------- /src/logs_syslog_mirage_tls.mli: -------------------------------------------------------------------------------- 1 | (** Logs reporter via syslog using MirageOS and TLS 2 | 3 | Please read {!Logs_syslog} first. *) 4 | 5 | (** TLS reporter *) 6 | module Tls (C : Mirage_console_lwt.S) (CLOCK : Mirage_clock.PCLOCK) (STACK : Mirage_stack_lwt.V4) (KV : Mirage_kv_lwt.RO) : sig 7 | 8 | (** [create c clock tcp kv ~keyname ~hostname ip ~port ~truncate ~framing ()] 9 | is [Ok reporter] or [Error msg]. Key material (ca-roots.crt, certificate 10 | chain, private key) are read from [kv] (using [keyname], defaults to 11 | [server]). The [reporter] sends log messages to [ip, port] via TLS. If 12 | the initial TLS connection to the [remote_ip] fails, an [Error msg] is 13 | returned instead. If the TLS connection fails, it is reported to console 14 | [c], and attempts are made to re-establish the TLS connection. Each 15 | message can be truncated (to [truncate] bytes), default is to not 16 | truncate. The [hostname] is part of each syslog message. The [port] 17 | defaults to 6514, [framing] to appending a 0 byte. *) 18 | val create : C.t -> CLOCK.t -> STACK.t -> KV.t -> ?keyname:string -> hostname:string -> 19 | STACK.ipv4addr -> ?port:int -> ?truncate:int -> ?framing:Logs_syslog.framing -> unit -> 20 | (Logs.reporter, string) result STACK.io 21 | end 22 | 23 | (** {1:mirage_example Example usage} 24 | 25 | To install a Mirage syslog reporter, sending via TLS to localhost, use the 26 | following snippet: 27 | {[ 28 | open Mirage_types_lwt 29 | module Main (C : CONSOLE) (S : STACKV4) (CLOCK : PCLOCK) (KEYS : KV_RO) 30 | module TLS = Tls_mirage.Make(S.TCPV4) 31 | module X509 = Tls_mirage.X509(KEYS)(CLOCK) 32 | 33 | module LT = Logs_syslog_mirage_tls.Tls(C)(CLOCK)(S)(KEYS) 34 | 35 | let start c s _ kv = 36 | let ip = Ipaddr.V4.of_string_exn "127.0.0.1" in 37 | LT.create c s kv ~hostname ip () >>= function 38 | | Ok r -> Logs.set_reporter r ; Lwt.return_unit 39 | | Error e -> Lwt.fail_invalid_arg e 40 | end 41 | ]} 42 | 43 | *) 44 | -------------------------------------------------------------------------------- /src/logs_syslog_unix.mli: -------------------------------------------------------------------------------- 1 | (** Logs reporter via syslog using Unix 2 | 3 | Please read {!Logs_syslog} first. *) 4 | 5 | (** [udp_reporter ~hostname remote_ip ~port ~truncate ()] is [reporter], which 6 | sends log message to [remote_ip, port] via UDP. Each message is truncated 7 | to [truncate] bytes (defaults to 65535). The [hostname] is part of each 8 | syslog message, and defaults to [Unix.gethostname ()], the [port] defaults 9 | to 514. *) 10 | val udp_reporter : 11 | ?hostname:string -> Unix.inet_addr -> ?port:int -> ?truncate:int -> unit -> 12 | Logs.reporter 13 | 14 | (** [tcp_reporter ~hostname remote_ip ~port ~truncate ~framing ()] is [Ok 15 | reporter] or [Error msg]. The [reporter] sends each log message via syslog 16 | to [remote_ip, port] via TCP. If the initial TCP connection to the 17 | [remote_ip] fails, an [Error msg] is returned instead. If the TCP 18 | connection fails, the log message is reported to standard error, and 19 | attempts are made to re-establish the TCP connection. A syslog message is 20 | truncated to [truncate] bytes (by default no truncation happens). Each 21 | syslog message is framed according to the given [framing] (defaults to a 22 | single 0 byte). The [hostname] defaults to [Unix.gethostname ()], [port] to 23 | 514, [framing] to append a 0 byte. *) 24 | val tcp_reporter : ?hostname:string -> Unix.inet_addr -> ?port:int -> 25 | ?truncate:int -> 26 | ?framing:Logs_syslog.framing -> unit -> 27 | (Logs.reporter, string) result 28 | 29 | (** {1:unix_example Example usage} 30 | 31 | To install a Unix syslog reporter. sending via UDP to localhost, use the 32 | following snippet: 33 | 34 | {[ 35 | Logs.set_reporter (udp_reporter (Unix.inet_addr_of_string "127.0.0.1") ()) 36 | ]} 37 | 38 | To install a reporter using TCP, use the following snippet: 39 | {[ 40 | let () = 41 | match tcp_reporter (Unix.inet_addr_of_string "127.0.0.1") () with 42 | | Error e -> print_endline e 43 | | Ok r -> Logs.set_reporter r 44 | ]} 45 | 46 | *) 47 | -------------------------------------------------------------------------------- /src/logs_syslog_lwt.mli: -------------------------------------------------------------------------------- 1 | (** Logs reporter via syslog, using Lwt 2 | 3 | Please read {!Logs_syslog} first. *) 4 | 5 | (** [udp_reporter ~hostname remote_ip ~port ~truncate ()] is [reporter], which 6 | sends syslog message using the given [hostname] to [remote_ip, remote_port] 7 | via UDP. Each message is truncated to [truncate] bytes (defaults to 65535). 8 | The [hostname] default to [Lwt_unix.gethostname ()], [port] defaults to 9 | 514. *) 10 | val udp_reporter : 11 | ?hostname:string -> Lwt_unix.inet_addr -> ?port:int -> ?truncate:int -> unit -> 12 | Logs.reporter Lwt.t 13 | 14 | (** [tcp_reporter ~hostname remote_ip ~port ~truncate ~framing ()] is [Ok 15 | reporter] or [Error msg]. The [reporter] sends each log message to 16 | [remote_ip, port] via TCP. If the initial TCP connection to the [remote_ip] 17 | fails, an [Error msg] is returned instead. If the TCP connection fails, the 18 | log message is reported to standard error, and attempts are made to 19 | re-establish the TCP connection. Each syslog message is truncated to 20 | [truncate] bytes (defaults to 0, thus no truncation). Each syslog message 21 | is framed (using [framing]), the default strategy is to append a single byte 22 | containing 0. The [hostname] default to [Lwt_unix.gethostname ()], [port] 23 | to 514. *) 24 | val tcp_reporter : ?hostname:string -> Lwt_unix.inet_addr -> ?port:int -> 25 | ?truncate:int -> 26 | ?framing:Logs_syslog.framing -> unit -> 27 | (Logs.reporter, string) result Lwt.t 28 | 29 | (** {1:lwt_example Example usage} 30 | 31 | To install a Lwt syslog reporter, sending via UDP to localhost, use the 32 | following snippet: 33 | {[ 34 | let install_logger () = 35 | udp_reporter (Unix.inet_addr_of_string "127.0.0.1") () >|= fun r -> 36 | Logs.set_reporter r 37 | 38 | let _ = Lwt_main.run (install_logger ()) 39 | ]} 40 | 41 | And via TCP: 42 | {[ 43 | let install_logger () = 44 | tcp_reporter (Unix.inet_addr_of_string "127.0.0.1") () >|= function 45 | | Ok r -> Logs.set_reporter r 46 | | Error e -> print_endline e 47 | 48 | let _ = Lwt_main.run (install_logger ()) 49 | ]} 50 | 51 | *) 52 | -------------------------------------------------------------------------------- /pkg/META: -------------------------------------------------------------------------------- 1 | description = "Emit logs via syslog" 2 | version = "%%VERSION_NUM%%" 3 | requires = "logs syslog-message ptime" 4 | archive(byte) = "logs-syslog.cma" 5 | archive(native) = "logs-syslog.cmxa" 6 | plugin(byte) = "logs-syslog.cma" 7 | plugin(native) = "logs-syslog.cmxs" 8 | exists_if = "logs-syslog.cma" 9 | 10 | package "unix" ( 11 | description = "Unix syslog reporter" 12 | version = "%%VERSION_NUM%%" 13 | requires = "logs-syslog logs syslog-message ptime.clock.os" 14 | archive(byte) = "logs-syslog-unix.cma" 15 | archive(native) = "logs-syslog-unix.cmxa" 16 | plugin(byte) = "logs-syslog-unix.cma" 17 | plugin(native) = "logs-syslog-unix.cmxs" 18 | exists_if = "logs-syslog-unix.cma" 19 | ) 20 | 21 | package "lwt" ( 22 | description = "Lwt syslog reporter" 23 | version = "%%VERSION_NUM%%" 24 | requires = "logs-syslog logs syslog-message ptime.clock.os lwt" 25 | archive(byte) = "logs-syslog-lwt.cma" 26 | archive(native) = "logs-syslog-lwt.cmxa" 27 | plugin(byte) = "logs-syslog-lwt.cma" 28 | plugin(native) = "logs-syslog-lwt.cmxs" 29 | exists_if = "logs-syslog-lwt.cma" 30 | 31 | package "tls" ( 32 | description = "Lwt TLS syslog reporter" 33 | version = "%%VERSION_NUM%%" 34 | requires = "logs-syslog logs-syslog.lwt logs syslog-message ptime.clock.os lwt x509 tls tls.lwt cstruct" 35 | archive(byte) = "logs-syslog-lwt-tls.cma" 36 | archive(native) = "logs-syslog-lwt-tls.cmxa" 37 | plugin(byte) = "logs-syslog-lwt-tls.cma" 38 | plugin(native) = "logs-syslog-lwt-tls.cmxs" 39 | exists_if = "logs-syslog-lwt-tls.cma" 40 | ) 41 | ) 42 | 43 | package "mirage" ( 44 | description = "Mirage syslog reporter" 45 | version = "%%VERSION_NUM%%" 46 | requires = "logs-syslog logs syslog-message ipaddr lwt mirage-console-lwt mirage-clock mirage-stack-lwt cstruct" 47 | archive(byte) = "logs-syslog-mirage.cma" 48 | archive(native) = "logs-syslog-mirage.cmxa" 49 | plugin(byte) = "logs-syslog-mirage.cma" 50 | plugin(native) = "logs-syslog-mirage.cmxs" 51 | exists_if = "logs-syslog-mirage.cma" 52 | 53 | package "tls" ( 54 | description = "Mirage TLS syslog reporter" 55 | version = "%%VERSION_NUM%%" 56 | requires = "logs-syslog logs-syslog.mirage x509 tls tls.mirage mirage-kv-lwt" 57 | archive(byte) = "logs-syslog-mirage-tls.cma" 58 | archive(native) = "logs-syslog-mirage-tls.cmxa" 59 | plugin(byte) = "logs-syslog-mirage-tls.cma" 60 | plugin(native) = "logs-syslog-mirage-tls.cmxs" 61 | exists_if = "logs-syslog-mirage-tls.cma" 62 | ) 63 | ) 64 | -------------------------------------------------------------------------------- /src/logs_syslog_mirage_tls.ml: -------------------------------------------------------------------------------- 1 | module Tls (C : Mirage_console_lwt.S) (CLOCK : Mirage_clock.PCLOCK) (STACK : Mirage_stack_lwt.V4) (KV : Mirage_kv_lwt.RO) = struct 2 | open Lwt.Infix 3 | open Logs_syslog 4 | 5 | module TCP = STACK.TCPV4 6 | module TLS = Tls_mirage.Make(TCP) 7 | module X509 = Tls_mirage.X509(KV)(CLOCK) 8 | 9 | let create c clock stack kv ?keyname ~hostname dst ?(port = 6514) ?(truncate = 0) ?(framing = `Null) () = 10 | let tcp = STACK.tcpv4 stack in 11 | let f = ref None in 12 | let dsts = 13 | Printf.sprintf "while writing to %s:%d" (Ipaddr.V4.to_string dst) port 14 | in 15 | let m = Lwt_mutex.create () in 16 | X509.authenticator kv clock `CAs >>= fun authenticator -> 17 | let certname = match keyname with None -> `Default | Some x -> `Name x in 18 | X509.certificate kv certname >>= fun priv -> 19 | let certificates = `Single priv in 20 | let conf = Tls.Config.client ~authenticator ~certificates () in 21 | let connect () = 22 | TCP.create_connection tcp (dst, port) >>= function 23 | | Error e -> 24 | TCP.pp_error Format.str_formatter e ; 25 | let err = Printf.sprintf "error %s %s" (Format.flush_str_formatter ()) dsts in 26 | Lwt.return (Error err) 27 | | Ok flow -> 28 | TLS.client_of_flow conf flow >|= function 29 | | Ok tlsflow -> f := Some tlsflow ; Ok () 30 | | Error e -> 31 | TLS.pp_write_error Format.str_formatter e ; 32 | let err = Printf.sprintf "error %s %s" (Format.flush_str_formatter ()) dsts in 33 | Error err 34 | in 35 | let reconnect k msg = 36 | Lwt_mutex.lock m >>= fun () -> 37 | (match !f with 38 | | None -> connect () 39 | | Some _ -> Lwt.return (Ok ())) >>= function 40 | | Ok () -> Lwt_mutex.unlock m ; k msg 41 | | Error e -> 42 | Lwt_mutex.unlock m ; 43 | C.log c (Printf.sprintf "error %s, message %s" e msg) 44 | in 45 | let rec send omsg = 46 | match !f with 47 | | None -> reconnect send omsg 48 | | Some flow -> 49 | let msg = Cstruct.of_string (frame_message omsg framing) in 50 | TLS.write flow msg >>= function 51 | | Ok () -> Lwt.return_unit 52 | | Error e -> 53 | f := None ; 54 | TLS.pp_write_error Format.str_formatter e ; 55 | let err = Printf.sprintf "error %s %s, reconnecting" 56 | (Format.flush_str_formatter ()) dsts 57 | in 58 | C.log c err >>= fun () -> 59 | reconnect send omsg 60 | in 61 | connect () >|= function 62 | | Ok () -> 63 | Ok (Logs_syslog_lwt_common.syslog_report_common 64 | hostname 65 | truncate 66 | (fun () -> Ptime.v (CLOCK.now_d_ps clock)) 67 | send) 68 | | Error e -> Error e 69 | end 70 | -------------------------------------------------------------------------------- /src/logs_syslog_mirage.mli: -------------------------------------------------------------------------------- 1 | (** Logs reporter via syslog using MirageOS 2 | 3 | Please read {!Logs_syslog} first. *) 4 | 5 | (** UDP syslog *) 6 | module Udp (C : Mirage_console_lwt.S) (CLOCK : Mirage_clock.PCLOCK) (STACK : Mirage_stack_lwt.V4) : sig 7 | (** [create c clock udp ~hostname ip ~port ~truncate ()] is [reporter], which 8 | sends log messages to [ip, port] via UDP. Upon failure, a message is 9 | emitted to the console [c]. Each message can be truncated: [truncate] 10 | defaults to 65535 bytes. The [hostname] is part of each syslog message. 11 | The [port] defaults to 514. *) 12 | val create : C.t -> CLOCK.t -> STACK.t -> hostname:string -> 13 | STACK.ipv4addr -> ?port:int -> ?truncate:int -> unit -> Logs.reporter 14 | end 15 | 16 | (** TCP syslog *) 17 | module Tcp (C : Mirage_console_lwt.S) (CLOCK : Mirage_clock.PCLOCK) (STACK : Mirage_stack_lwt.V4) : sig 18 | (** [create c clock tcp ~hostname ip ~port ~truncate ~framing ()] is [Ok 19 | reporter] or [Error msg]. The [reporter] sends log messages to [ip, port] 20 | via TCP. If the initial TCP connection to the [remote_ip] fails, an 21 | [Error msg] is returned instead. If the TCP connection fails, an error is 22 | logged to the console [c] and attempts are made to re-establish the TCP 23 | connection. Each syslog message can be truncated, depending on [truncate] 24 | (defaults to no truncating). The [hostname] is part of each syslog 25 | message. The default value of [port] is 514, the default behaviour of 26 | [framing] is to append a 0 byte. *) 27 | val create : C.t -> CLOCK.t -> STACK.t -> hostname:string -> 28 | STACK.ipv4addr -> ?port:int -> 29 | ?truncate:int -> 30 | ?framing:Logs_syslog.framing -> unit -> 31 | (Logs.reporter, string) result STACK.io 32 | end 33 | 34 | (** {1:mirage_example Example usage} 35 | 36 | To install a Mirage syslog reporter, sending via UDP to localhost, use the 37 | following snippet: 38 | {[ 39 | open Mirage_types_lwt 40 | module Main (C : CONSOLE) (S : STACKV4) (CLOCK : PCLOCK) 41 | module LU = Logs_syslog_mirage.Udp(C)(CLOCK)(S) 42 | 43 | let start c s _ = 44 | let ip = Ipaddr.V4.of_string_exn "127.0.0.1" in 45 | let r = LU.create c s ip ~hostname:"MirageOS.example" () in 46 | Logs.set_reporter r ; 47 | Lwt.return_unit 48 | end 49 | ]} 50 | 51 | The TCP transport is very similar: 52 | {[ 53 | open Mirage_types_lwt 54 | module Main (C : CONSOLE) (S : STACKV4) (CLOCK : PCLOCK) 55 | module LT = Logs_syslog_mirage.Tcp(C)(CLOCK)(S) 56 | 57 | let start c s _ = 58 | let ip = Ipaddr.V4.of_string_exn "127.0.0.1" in 59 | LT.create c s ip ~hostname:"MirageOS.example" () >>= function 60 | | Ok r -> Logs.set_reporter r ; Lwt.return_unit 61 | | Error e -> Lwt.fail_invalid_arg e 62 | end 63 | ]} 64 | 65 | *) 66 | -------------------------------------------------------------------------------- /src/logs_syslog_mirage.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module Udp (C : Mirage_console_lwt.S) (CLOCK : Mirage_clock.PCLOCK) (STACK : Mirage_stack_lwt.V4) = struct 4 | module UDP = STACK.UDPV4 5 | 6 | let create c clock stack ~hostname dst ?(port = 514) ?(truncate = 65535) () = 7 | let dsts = 8 | Printf.sprintf "while writing to %s:%d" (Ipaddr.V4.to_string dst) port 9 | in 10 | Logs_syslog_lwt_common.syslog_report_common 11 | hostname 12 | truncate 13 | (* This API for PCLOCK is inconvenient (overengineered?) *) 14 | (fun () -> Ptime.v (CLOCK.now_d_ps clock)) 15 | (fun s -> 16 | UDP.write ~dst ~dst_port:port (STACK.udpv4 stack) (Cstruct.of_string s) >>= function 17 | | Ok _ -> Lwt.return_unit 18 | | Error e -> 19 | Format.(fprintf str_formatter "error %a %s, message: %s" 20 | UDP.pp_error e dsts s) ; 21 | C.log c (Format.flush_str_formatter ())) 22 | end 23 | 24 | module Tcp (C : Mirage_console_lwt.S) (CLOCK : Mirage_clock.PCLOCK) (STACK : Mirage_stack_lwt.V4) = struct 25 | open Logs_syslog 26 | module TCP = STACK.TCPV4 27 | 28 | let create c clock stack ~hostname dst ?(port = 514) ?(truncate = 0) ?(framing = `Null) () = 29 | let tcp = STACK.tcpv4 stack in 30 | let f = ref None in 31 | let dsts = 32 | Printf.sprintf "while writing to %s:%d" (Ipaddr.V4.to_string dst) port 33 | in 34 | let m = Lwt_mutex.create () in 35 | let connect () = 36 | TCP.create_connection tcp (dst, port) >|= function 37 | | Ok flow -> f := Some flow ; Ok () 38 | | Error e -> 39 | TCP.pp_error Format.str_formatter e ; 40 | Error (Format.flush_str_formatter ()) 41 | in 42 | let reconnect k msg = 43 | Lwt_mutex.lock m >>= fun () -> 44 | (match !f with 45 | | None -> connect () 46 | | Some _ -> Lwt.return (Ok ())) >>= function 47 | | Ok () -> Lwt_mutex.unlock m ; k msg 48 | | Error e -> 49 | Lwt_mutex.unlock m ; 50 | C.log c (Printf.sprintf "error %s, message %s" e msg) 51 | in 52 | let rec send omsg = 53 | match !f with 54 | | None -> reconnect send omsg 55 | | Some flow -> 56 | let msg = Cstruct.(of_string (frame_message omsg framing)) in 57 | TCP.write flow msg >>= function 58 | | Ok () -> Lwt.return_unit 59 | | Error e -> 60 | f := None ; 61 | TCP.pp_write_error Format.str_formatter e ; 62 | C.log c (Format.flush_str_formatter () ^ " " ^ dsts ^ ", reconnecting") >>= fun () -> 63 | reconnect send omsg 64 | in 65 | connect () >|= function 66 | | Ok () -> 67 | Ok (Logs_syslog_lwt_common.syslog_report_common 68 | hostname 69 | truncate 70 | (fun () -> Ptime.v (CLOCK.now_d_ps clock)) 71 | send) 72 | | Error e -> Error e 73 | end 74 | -------------------------------------------------------------------------------- /src/logs_syslog_unix.ml: -------------------------------------------------------------------------------- 1 | open Logs_syslog 2 | 3 | let syslog_report host len send = 4 | let report src level ~over k msgf = 5 | let source = Logs.Src.name src in 6 | let timestamp = Ptime_clock.now () in 7 | let k tags ?header _ = 8 | let msg = 9 | message ~host ~source ~tags ?header level timestamp (flush ()) 10 | in 11 | send (Syslog_message.encode ~len msg) ; over () ; k () 12 | in 13 | msgf @@ fun ?header ?(tags = Logs.Tag.empty) fmt -> 14 | Format.kfprintf (k tags ?header) ppf fmt 15 | in 16 | { Logs.report } 17 | 18 | let udp_reporter 19 | ?(hostname = Unix.gethostname ()) 20 | ip 21 | ?(port = 514) 22 | ?(truncate = 65535) () = 23 | let sa = Unix.ADDR_INET (ip, port) in 24 | let s = Unix.(socket PF_INET SOCK_DGRAM 0) in 25 | let rec send msg = 26 | let b = Bytes.of_string msg in 27 | try ignore(Unix.sendto s b 0 (String.length msg) [] sa) with 28 | | Unix.Unix_error (Unix.EAGAIN, _, _) -> send msg 29 | | Unix.Unix_error (e, f, _) -> 30 | Printf.eprintf "error in %s %s while sending to %s:%d\n%s %s\n" 31 | f (Unix.error_message e) (Unix.string_of_inet_addr ip) port 32 | (Ptime.to_rfc3339 (Ptime_clock.now ())) 33 | msg 34 | in 35 | syslog_report hostname truncate send 36 | 37 | type state = 38 | | Disconnected 39 | | Connecting 40 | | Connected of Unix.file_descr 41 | 42 | let wait_time = 0.01 43 | 44 | let tcp_reporter 45 | ?(hostname = Unix.gethostname ()) 46 | ip 47 | ?(port = 514) 48 | ?(truncate = 0) 49 | ?(framing = `Null) () = 50 | let sa = Unix.ADDR_INET (ip, port) in 51 | let s = ref Disconnected in 52 | let connect () = 53 | let sock = Unix.(socket PF_INET SOCK_STREAM 0) in 54 | Unix.(setsockopt sock SO_REUSEADDR true) ; 55 | Unix.(setsockopt sock SO_KEEPALIVE true) ; 56 | try 57 | Unix.connect sock sa ; 58 | s := Connected sock; 59 | Ok () 60 | with 61 | | Unix.Unix_error (e, f, _) -> 62 | let err = 63 | Printf.sprintf "error %s in function %s while connecting to %s:%d\n" 64 | (Unix.error_message e) f (Unix.string_of_inet_addr ip) port 65 | in 66 | Error err 67 | in 68 | let reconnect k msg = 69 | s := Connecting ; 70 | match connect () with 71 | | Ok () -> k msg 72 | | Error e -> Printf.eprintf "%s while sending syslog message\n%s %s\n" 73 | e (Ptime.to_rfc3339 (Ptime_clock.now ())) msg 74 | in 75 | match connect () with 76 | | Error e -> Error e 77 | | Ok () -> 78 | let rec send omsg = match !s with 79 | | Disconnected -> reconnect send omsg 80 | | Connecting -> let _ = Unix.select [] [] [] wait_time in send omsg 81 | | Connected sock -> 82 | let msg = Bytes.of_string (frame_message omsg framing) in 83 | let len = Bytes.length msg in 84 | let rec aux idx = 85 | try 86 | let should = len - idx in 87 | let n = Unix.send sock msg idx should [] in 88 | if n = should then () else aux (idx + n) 89 | with 90 | | Unix.Unix_error (Unix.EAGAIN, _, _) -> send omsg 91 | | Unix.Unix_error (e, f, _) -> 92 | let err = Unix.error_message e in 93 | Printf.eprintf "error %s in function %s, reconnecting\n" err f ; 94 | (try Unix.close sock with Unix.Unix_error _ -> ()) ; 95 | s := Disconnected ; 96 | reconnect send omsg 97 | in 98 | aux 0 99 | in 100 | at_exit (fun () -> match !s with Connected x -> Unix.close x | _ -> ()) ; 101 | Ok (syslog_report hostname truncate send) 102 | -------------------------------------------------------------------------------- /src/logs_syslog_lwt.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Logs_syslog_lwt_common 3 | open Logs_syslog 4 | 5 | let udp_reporter ?hostname ip ?(port = 514) ?(truncate = 65535) () = 6 | let sa = Lwt_unix.ADDR_INET (ip, port) in 7 | let s = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in 8 | let rec send msg = 9 | Lwt.catch (fun () -> 10 | let b = Bytes.of_string msg in 11 | Lwt_unix.sendto s b 0 (String.length msg) [] sa >|= fun _ -> ()) 12 | (function 13 | | Unix.Unix_error (Unix.EAGAIN, _, _) -> send msg 14 | | Unix.Unix_error (e, f, _) -> 15 | Printf.eprintf "error in %s %s while sending to %s:%d\n%s %s\n" 16 | f (Unix.error_message e) (Unix.string_of_inet_addr ip) port 17 | (Ptime.to_rfc3339 (Ptime_clock.now ())) 18 | msg ; 19 | Lwt.return_unit) 20 | in 21 | (match hostname with 22 | | Some x -> Lwt.return x 23 | | None -> Lwt_unix.gethostname ()) >|= fun host -> 24 | syslog_report_common host truncate Ptime_clock.now send 25 | 26 | let tcp_reporter ?hostname ip ?(port = 514) ?(truncate = 0) ?(framing = `Null) () = 27 | let sa = Lwt_unix.ADDR_INET (ip, port) in 28 | let s = ref None in 29 | let m = Lwt_mutex.create () in 30 | (match hostname with 31 | | Some x -> Lwt.return x 32 | | None -> Lwt_unix.gethostname ()) >>= fun host -> 33 | let connect () = 34 | let sock = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in 35 | Lwt_unix.(setsockopt sock SO_REUSEADDR true) ; 36 | Lwt_unix.(setsockopt sock SO_KEEPALIVE true) ; 37 | Lwt.catch 38 | (fun () -> Lwt_unix.connect sock sa >|= fun () -> s := Some sock ; Ok ()) 39 | (function Unix.Unix_error (e, f, _) -> 40 | let err = 41 | Printf.sprintf "error %s in function %s while connecting to %s:%d" 42 | (Unix.error_message e) f (Unix.string_of_inet_addr ip) port 43 | in 44 | Lwt.return (Error err)) 45 | in 46 | let reconnect k msg = 47 | Lwt_mutex.lock m >>= fun () -> 48 | (match !s with 49 | | None -> connect () 50 | | Some _ -> Lwt.return (Ok ())) >>= function 51 | | Ok () -> Lwt_mutex.unlock m ; k msg 52 | | Error e -> 53 | Printf.eprintf "%s while sending syslog message\n%s %s\n" 54 | e (Ptime.to_rfc3339 (Ptime_clock.now ())) msg ; 55 | Lwt_mutex.unlock m ; 56 | Lwt.return_unit 57 | in 58 | connect () >>= function 59 | | Error e -> Lwt.return (Error e) 60 | | Ok () -> 61 | let rec send omsg = 62 | match !s with 63 | | None -> reconnect send omsg 64 | | Some sock -> 65 | let msg = Bytes.of_string (frame_message omsg framing) in 66 | let len = Bytes.length msg in 67 | let rec aux idx = 68 | let should = len - idx in 69 | (Lwt.catch (fun () -> Lwt_unix.send sock msg idx (len - idx) []) 70 | (function 71 | | Unix.Unix_error (Unix.EAGAIN, _, _) -> Lwt.return idx 72 | | Unix.Unix_error (e, f, _) -> 73 | s := None ; 74 | let err = Unix.error_message e in 75 | Printf.eprintf "error %s in function %s, reconnecting\n" err f ; 76 | Lwt.catch 77 | (fun () -> Lwt_unix.close sock) 78 | (function Unix.Unix_error _ -> Lwt.return_unit) >>= fun () -> 79 | reconnect send omsg >|= fun () -> should)) >>= fun n -> 80 | if n = should then 81 | Lwt.return_unit 82 | else 83 | aux (idx + n) 84 | in 85 | aux 0 86 | in 87 | at_exit (fun () -> match !s with 88 | | None -> () 89 | | Some x -> Lwt.async (fun () -> Lwt_unix.close x)) ; 90 | Lwt.return (Ok (syslog_report_common host truncate Ptime_clock.now send)) 91 | -------------------------------------------------------------------------------- /src/logs_syslog_lwt_tls.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Logs_syslog_lwt_common 3 | open Logs_syslog 4 | 5 | let tcp_tls_reporter 6 | ?hostname ip ?(port = 6514) ~cacert ~cert ~priv_key ?(truncate = 0) 7 | ?(framing = `Null) () = 8 | let sa = Lwt_unix.ADDR_INET (ip, port) in 9 | let tls = ref None in 10 | let m = Lwt_mutex.create () in 11 | X509_lwt.private_of_pems ~cert ~priv_key >>= fun priv -> 12 | X509_lwt.authenticator (`Ca_file cacert) >>= fun authenticator -> 13 | let conf = Tls.Config.client ~authenticator ~certificates:(`Single priv) () in 14 | (match hostname with 15 | | Some x -> Lwt.return x 16 | | None -> Lwt_unix.gethostname ()) >>= fun host -> 17 | let connect () = 18 | let sock = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in 19 | Lwt_unix.(setsockopt sock SO_REUSEADDR true) ; 20 | Lwt_unix.(setsockopt sock SO_KEEPALIVE true) ; 21 | Lwt.catch 22 | (fun () -> 23 | Lwt_unix.connect sock sa >>= fun () -> 24 | Tls_lwt.Unix.client_of_fd conf sock >|= fun t -> 25 | tls := Some t ; 26 | Ok ()) 27 | (fun exn -> 28 | Lwt.return @@ match exn with 29 | | Unix.Unix_error (e, f, _) -> 30 | let err = 31 | Printf.sprintf "error %s in function %s while connecting to %s:%d" 32 | (Unix.error_message e) f (Unix.string_of_inet_addr ip) port 33 | in 34 | Error err 35 | | Tls_lwt.Tls_failure f -> 36 | let err = Tls.Engine.string_of_failure f in 37 | Error (Printf.sprintf "TLS failure %s" err)) 38 | in 39 | let reconnect k msg = 40 | Lwt_mutex.lock m >>= fun () -> 41 | (match !tls with 42 | | None -> connect () 43 | | Some _ -> Lwt.return (Ok ())) >>= function 44 | | Ok () -> Lwt_mutex.unlock m ; k msg 45 | | Error e -> 46 | Printf.eprintf "%s while sending syslog message\n%s %s\n" 47 | e (Ptime.to_rfc3339 (Ptime_clock.now ())) msg ; 48 | Lwt_mutex.unlock m ; 49 | Lwt.return_unit 50 | in 51 | connect () >>= function 52 | | Error e -> Lwt.return (Error e) 53 | | Ok () -> 54 | let rec send omsg = 55 | match !tls with 56 | | None -> reconnect send omsg 57 | | Some t -> 58 | let msg = Cstruct.of_string (frame_message omsg framing) in 59 | Lwt.catch 60 | (fun () -> Tls_lwt.Unix.write t msg) 61 | (function 62 | | Unix.Unix_error (Unix.EAGAIN, _, _) -> send omsg 63 | | Unix.Unix_error (e, f, _) -> 64 | tls := None ; 65 | let err = Unix.error_message e in 66 | Printf.eprintf "error %s in function %s, reconnecting\n" err f ; 67 | Lwt.catch 68 | (fun () -> Tls_lwt.Unix.close t) 69 | (fun _ -> Lwt.return_unit) >>= fun () -> 70 | reconnect send omsg 71 | | Tls_lwt.Tls_failure f -> 72 | tls := None ; 73 | Printf.eprintf "TLS error %s\n" (Tls.Engine.string_of_failure f) ; 74 | Lwt.catch 75 | (fun () -> Tls_lwt.Unix.close t) 76 | (fun _ -> Lwt.return_unit) >>= fun () -> 77 | reconnect send omsg) 78 | in 79 | at_exit (fun () -> match !tls with 80 | | None -> () 81 | | Some tls -> Lwt.async (fun () -> Tls_lwt.Unix.close tls)) ; 82 | Lwt.return (Ok (syslog_report_common host truncate Ptime_clock.now send)) 83 | 84 | (* 85 | let main () = 86 | let lo = Unix.inet_addr_of_string "127.0.0.1" in 87 | tcp_tls_reporter lo 88 | ~cacert:"cacert.pem" ~cert:"client.pem" ~priv_key:"client.key" () 89 | >>= function 90 | | Error e -> print_endline e ; Lwt.return_unit 91 | | Ok r -> 92 | Logs.set_reporter r ; 93 | Logs.set_level ~all:true (Some Logs.Debug) ; 94 | Logs_lwt.warn (fun l -> l "foobar") >>= fun () -> 95 | Logs_lwt.err (fun l -> l "bar foofoobar") >>= fun () -> 96 | Logs_lwt.info (fun l -> l "foofoobar") >>= fun () -> 97 | Logs_lwt.debug (fun l -> l "debug foofoobar") 98 | 99 | let _ = Lwt_main.run (main ()) 100 | *) 101 | -------------------------------------------------------------------------------- /src/logs_syslog.mli: -------------------------------------------------------------------------------- 1 | (** Logs reporter using syslog 2 | 3 | The {{:http://erratique.ch/software/logs/doc/Logs.html}logs} library 4 | provides basic logging support, each log source has an independent logging 5 | level, and reporting is decoupled from logging. 6 | 7 | This library implements log reporters via syslog, using 8 | {{:http://verbosemo.de/syslog-message/}syslog-message}. 9 | 10 | A variety of transport mechanisms are implemented: 11 | {ul 12 | {- {{:https://tools.ietf.org/html/rfc3164}RFC 3164} specifies the original 13 | BSD syslog protocol over UDP on port 514 (also 14 | {{:https://tools.ietf.org/html/rfc5426}RFC 5426}).} 15 | {- {{:https://tools.ietf.org/html/rfc6587}RFC 6587} specifies the historic 16 | syslog over TCP on port 514.} 17 | {- {{:https://tools.ietf.org/html/rfc5425}RFC 5425} specifies syslog over 18 | TLS on TCP port 6514.}} 19 | 20 | The UDP transport sends each log message to the remote log host using 21 | [sendto]. If [sendto] raises an [Unix.Unix_error], this error is printed 22 | together with the log message on standard error. 23 | 24 | When using a stream transport, TCP or TLS, the creation of a reporter 25 | attempts to establish a connection to the log host, and only results in [Ok] 26 | {!Logs.reporter} on success, otherwise the [Error msg] is returned. At 27 | runtime when the connection failed, the message is printed on standard 28 | error, and a re-establishment of the connection is attempted. 29 | 30 | Syslog messages need to be framed when transported over TCP and TLS streams. 31 | In the historical {{:https://tools.ietf.org/html/rfc6587}RFC 6587} this is 32 | defined to be either non-transparent (which lets you stream the message), by 33 | terminating each syslog message with a line feed (0x0A), a null byte (0x00), 34 | a CR-LF sequence, or any custom byte sequence. The alternative is octet 35 | counting, also defined in {{:https://tools.ietf.org/html/rfc5425}RFC 5425}, 36 | which prepends the message with the message length, ASCII-encoded as decimal 37 | number, followed by a whitespace (0x20). We support all three popular 38 | methods, and also a [`Custom] one appending any byte sequence at the end of 39 | each message. There are defaults (TCP: null byte, TLS: octet counting) 40 | passed to the individual reporter constructors (see the {!framing} type 41 | below). 42 | 43 | Every time a library logs a message which reaches the reporter (depending on 44 | log level), the function {!message} is evaluated with the [hostname] 45 | provided while creating the reporter, the log level is mapped to a syslog 46 | level, and the current timestamp is added. The log message is prepended 47 | with the log source name. 48 | 49 | This module contains the pure fragments shared between the effectful 50 | implementation for {{!Logs_syslog_unix}Unix}, {{!Logs_syslog_lwt}Lwt}, and 51 | {{!Logs_syslog_mirage}MirageOS}. TLS support is available for 52 | {{!Logs_syslog_lwt_tls}Lwt} and {{!Logs_syslog_mirage_tls}MirageOS}. 53 | 54 | Not implemented is the reliable transport for syslog (see 55 | {{:https://tools.ietf.org/html/rfc3195}RFC 3195}) (using port 601), which is 56 | an alternative transport of syslog messages over TCP. 57 | 58 | {e %%VERSION%% - {{:%%PKG_HOMEPAGE%% }homepage}} *) 59 | 60 | (** [message ~facility ~host ~source ~tags ~header level now msg] is [message], 61 | a syslog message with the given values. The default [facility] is 62 | [Syslog_message.System_Daemons]. *) 63 | val message : 64 | ?facility:Syslog_message.facility -> 65 | host:string -> 66 | source:string -> 67 | tags:Logs.Tag.set -> 68 | ?header:string -> 69 | Logs.level -> 70 | Ptime.t -> 71 | string -> 72 | Syslog_message.t 73 | 74 | (** Different framing methods used in the wild, as described in 75 | {{:https://tools.ietf.org/html/rfc6587}RFC 6587} *) 76 | type framing = [ 77 | | `LineFeed 78 | | `Null 79 | | `Custom of string 80 | | `Count 81 | ] 82 | 83 | (** [frame_msg msg framing] is [framed_message], where the [framing] is 84 | applied. *) 85 | val frame_message : string -> framing -> string 86 | 87 | (** [ppf] is a formatter *) 88 | val ppf : Format.formatter 89 | 90 | (** [flush ()] flushes the formatter, and return the [text] *) 91 | val flush : unit -> string 92 | --------------------------------------------------------------------------------