pax_global_header00006660000000000000000000000064147665606260014534gustar00rootroot0000000000000052 comment=ca9ae8a6ba2953b9990f16a11962657d4652b873 ocaml-dtools-0.4.6/000077500000000000000000000000001476656062600141405ustar00rootroot00000000000000ocaml-dtools-0.4.6/.github/000077500000000000000000000000001476656062600155005ustar00rootroot00000000000000ocaml-dtools-0.4.6/.github/workflows/000077500000000000000000000000001476656062600175355ustar00rootroot00000000000000ocaml-dtools-0.4.6/.github/workflows/ci.yml000066400000000000000000000012061476656062600206520ustar00rootroot00000000000000name: CI on: [push] jobs: build: runs-on: ${{ matrix.os }} strategy: matrix: os: [ubuntu-latest, macos-latest] ocaml-compiler: - 4.14.x - 5.0.x steps: - name: Checkout code uses: actions/checkout@v2 - name: Use OCaml ${{ matrix.ocaml-compiler }} uses: ocaml/setup-ocaml@v2 with: ocaml-compiler: ${{ matrix.ocaml-compiler }} - name: Install locally run: opam install . --deps-only --with-test - name: Build locally run: opam exec -- dune build - name: Run tests locally run: opam exec -- dune runtest ocaml-dtools-0.4.6/.gitignore000066400000000000000000000000421476656062600161240ustar00rootroot00000000000000_build/ *.install .*sw* .merlin *~ocaml-dtools-0.4.6/.ocamlformat000066400000000000000000000003371476656062600164500ustar00rootroot00000000000000version=0.25.1 profile = conventional break-separators = after space-around-lists = false doc-comments = before match-indent = 2 match-indent-nested = always parens-ite exp-grouping = preserve module-item-spacing = compact ocaml-dtools-0.4.6/CHANGES000066400000000000000000000060261476656062600151370ustar00rootroot000000000000000.4.6 (2025-03-19) ===== * Fix tracing log. * Make sure `Log.stop` atom is idempotent. * Evaluate log level depth-first. * Fix memleak when creating logs. 0.4.5 (2023-06-27) ===== * Add optional log colorization function. 0.4.4 (10-07-2021) ===== * Export Log object's path. 0.4.3 (24-06-2021) ===== * Split log string by lines before printing. * Cleanup daemon args. * Remove `conf_concurrent` * Added `conf_daemon_pidfile_perms` 0.4.2 (27-02-2020) ===== * Added `Conf` values validation API, thanks to @CyberDomovoy * Switched to dune 0.4.1 (09-11-2018) ===== * Use seperate thread for logging, finer-grained critical section to avoid deadlock with `Gc.finalise` logging messages. 0.4.0 (08-18-2018) ===== * Raise Root_prohibited exception instead of exiting when running as root. 0.3.4 (08-10-2017) ===== * Added on_change to Conf.t 0.3.3 (11-04-2017) ===== * Catch USR1 signal regardless of logging configuration. 0.3.2 (03-08-2015) ===== * Dummy github release. 0.3.1 (08-05-2013) ===== * Added daemon cleanup that removed PID file. 0.3.0 (25-06-2012) ===== * Added Conf.alias 0.2.2 (26-06-2011) ===== * Cleaned up daemonization code, added optional change of user, should be useful when running as root. 0.2.1 (18-09-2010) ===== * Fixed requires, s/thread/threads/ 0.2.0 (19-08-2010) ===== * Use Thread.join instead of Thread.wait_signal under Win32 (Thread.wait_signal is not implemented in this case). Also do not use sigmask since it is not implemented either. * Added support for Syslog when detected. 0.1.6 (15-04-2008) ===== * Added support for --enable-debugging configure option * Reopen stdin/out/er instead of closing them * Install .cmx file when available * Set as blocked signals that we use with Thread.wait_signal, i.e. sigterm and sigint. Those are not blocked by default on some systems (e.g. freeBSD). 0.1.5 (12-12-2007) ===== * Fix: better daemon setup: + Close stdout and stderr + Set umask to 0 + Change pwd to / 0.1.4 (10-17-2007) ===== * Fix: do not include whole thread and unix lib in dtools lib * Conf: full rewrite, keys are documented * Conf: new: --conf-descr and --conf-dump features * Log: full rewrite, loggers are associated to keys * Log: fix: small error in timestamp generation 0.1.3 (02-03-2007) ===== * Fixed a deadlock * Made possible to check the type of a settings variable 0.1.2 (07-07-2006) ===== * Log: new human-readable timestamps by default. * Init: remove the pidfile. * Init: concurrent init disabled by default. * Init: better handling of exceptions in start/stop phases. 0.1.1 (20-04-2005) ===== * Conf: added: access to a reference containing a volatile configuration value. * Init: added: init tracability support. * Init: added: multithreaded init. * Conf: added: global default logging level key. * Conf: fix: Better handling of values syntax error exceptions. * Conf: fix: Bad configuration pair notification takes ~root in account. * Init: added: Support for depends, triggers, before and after lists. * Init: fix: Better Daemonization. 0.1.0 (28-02-2004) ===== * Initial release. ocaml-dtools-0.4.6/COPYING000066400000000000000000000431311476656062600151750ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. ocaml-dtools-0.4.6/COPYRIGHT000066400000000000000000000014751476656062600154420ustar00rootroot00000000000000 ocaml-dtools OCaml daemon tools library. Copyright (C) 2003-2006 The Savonet Team This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ocaml-dtools-0.4.6/README.md000066400000000000000000000031561476656062600154240ustar00rootroot00000000000000OCaml-dtools - OCaml daemon tools library ======================================================= Author: Gimenez Stéphane Email: savonet-users@lists.sourceforge.net Homepage: http://savonet.sourceforge.net/ Copyright (c) 2003-2020 the Savonet Team. Dependencies ============ To build this library you need to have OCaml 3.07. or later (available at http://caml.inria.fr) and ocamlfind also called findlib (available at http://www.ocaml-programming.de/packages/) Installation ============ This module is provided as part of the [opam](http://opam.ocaml.org/packages/dtools/). Recommended installation method is via `opam`: ``` opam install dtools ``` This installs the latest released version of this module. To compile the code from this repository, type: ``` dune build ``` To install the code from this repository using `opam`, type: ``` opam install . ``` To instal the code from this repository using `dune`: ``` dune install ``` License ======= This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ocaml-dtools-0.4.6/dtools.opam000066400000000000000000000013601476656062600163220ustar00rootroot00000000000000# This file is generated by dune, edit dune-project instead opam-version: "2.0" version: "0.4.6" synopsis: "Library providing various helper functions to make daemons" maintainer: ["Romain Beauxis "] authors: ["The Savonet Team "] license: "GPL-2.0-only" homepage: "https://github.com/savonet/ocaml-dtools" bug-reports: "https://github.com/savonet/ocaml-dtools/issues" depends: [ "ocaml" {>= "4.05.0"} "dune" {>= "2.8"} "odoc" {with-doc} ] depopts: ["syslog"] build: [ ["dune" "subst"] {dev} [ "dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} "@doc" {with-doc} ] ] dev-repo: "git+https://github.com/savonet/ocaml-dtools.git" ocaml-dtools-0.4.6/dune-project000066400000000000000000000006371476656062600164700ustar00rootroot00000000000000(lang dune 2.8) (name dtools) (version 0.4.6) (source (github savonet/ocaml-dtools)) (license GPL-2.0-only) (authors "The Savonet Team ") (maintainers "Romain Beauxis ") (generate_opam_files true) (package (name dtools) (synopsis "Library providing various helper functions to make daemons") (depends (ocaml (>= 4.05.0)) dune) (depopts syslog)) ocaml-dtools-0.4.6/src/000077500000000000000000000000001476656062600147275ustar00rootroot00000000000000ocaml-dtools-0.4.6/src/dtools.ml000066400000000000000000000016711476656062600165720ustar00rootroot00000000000000(**************************************************************************) (* ocaml-dtools *) (* Copyright (C) 2003-2010 The Savonet Team *) (**************************************************************************) (* This program is free software; you can redistribute it and/or modify *) (* it under the terms of the GNU General Public License as published by *) (* the Free Software Foundation; either version 2 of the License, or *) (* any later version. *) (**************************************************************************) (* Contact: savonet-devl@lists.sourceforge.net *) (**************************************************************************) (* $Id$ *) (** ocaml-dtools. @author Stephane Gimenez *) include Dtools_impl include Dtools_syslog ocaml-dtools-0.4.6/src/dtools.mli000066400000000000000000000214641476656062600167450ustar00rootroot00000000000000(**************************************************************************) (* ocaml-dtools *) (* Copyright (C) 2003-2010 The Savonet Team *) (**************************************************************************) (* This program is free software; you can redistribute it and/or modify *) (* it under the terms of the GNU General Public License as published by *) (* the Free Software Foundation; either version 2 of the License, or *) (* any later version. *) (**************************************************************************) (* Contact: savonet-devl@lists.sourceforge.net *) (**************************************************************************) (* $Id$ *) (** ocaml-dtools. @author Stephane Gimenez *) (** Configuration management module. *) module Conf : sig (** Type for links between keys *) type link = string (** Type for paths between keys *) type path = link list type ut = < kind : string option ; descr : string ; comments : string list ; plug : link -> ut -> unit ; subs : link list ; path : path -> ut ; routes : ut -> path list ; ut : ut > (** Type for untyped keys (or keys with unknown type) - [kind]: a string describing the type of this key - [descr]: a key description/title - [comments]: some comments on the key purposes - [plug]: a way to plug subkeys - [subs]: the list of link names to subkeys - [path]: a way to access subkeys - [routes]: a way to find paths to an other key *) type 'a t = < kind : string option ; alias : ?comments:string list -> ?descr:string -> (ut -> unit) -> 'a t ; descr : string ; comments : string list ; plug : link -> ut -> unit ; subs : link list ; path : path -> ut ; routes : ut -> path list ; ut : ut ; set_d : 'a option -> unit ; get_d : 'a option ; set : 'a -> unit ; get : 'a ; validate : ('a -> bool) -> unit ; on_change : ('a -> unit) -> unit > (** Type for 'a keys - [ut]: cast to un untyped key - [set_d]: set the default value associated to the key - [get_d]: get the default value associated to the key - [set]: set the key value according to a user demmand - [get]: retrieve the resulting key value *) (** A set of connections to others keys *) type links = (link * ut) list (** Raised on access to an undefined key (without default value) *) exception Undefined of ut (** Raised when an invalid link has been specified *) exception Invalid of string (** Raised when a specified link does not exist *) exception Unbound of ut * string (** Raised when a specified link already exist *) exception Bound of ut * string (** Raised on access to a key with a mismatching type *) exception Mismatch of ut (** Raised on cyclic plug *) exception Cyclic of ut * ut (** Raised on invalid value set *) exception Invalid_Value of ut (** Raised when bad configuration assignations are encountered *) exception Wrong_Conf of string * string (** Raised when bad configuration assignations are encountered inside configuration files *) exception File_Wrong_Conf of string * int * string (** Receipt to build a 'a key *) type 'a builder = ?d:'a -> ?p:(ut -> unit) -> ?l:links -> ?comments:string list -> string -> 'a t val unit : unit builder val int : int builder val float : float builder val bool : bool builder val string : string builder (** Some key builders *) val list : string list builder (** A structural key builder *) val void : ?p:(ut -> unit) -> ?l:links -> ?comments:string list -> string -> ut val as_unit : ut -> unit t val as_int : ut -> int t val as_float : ut -> float t val as_bool : ut -> bool t val as_string : ut -> string t (** Casts to specificaly typed keys. Raises [Mismatch] on mismatching cast. *) val as_list : ut -> string list t (** Convert a dot separated string to a path *) val path_of_string : string -> path (** Convert a path to a dot separated string *) val string_of_path : path -> string (** Generate a description table of a (sub)key *) val descr : ?prefix:path -> ut -> string (** Dump the configuration table for a (sub)key *) val dump : ?prefix:path -> ut -> string (** Add a value to the configuration keys, according to the given correctly formated string: "type key :value" Raises [Wrong_Conf] in badly formated cases. *) val conf_set : ut -> string -> unit (** Read configuration values from the file associated with the given filename. Raises [File_Wrong_Conf] with filename line and and error message in case of a bad configuration file. *) val conf_file : ut -> string -> unit (** A set of command line options to be used with the Arg module. *) val args : ut -> (string list * Arg.spec * string) list end (** Initialisation management module. Allow to define procedures that must be executed at start up, and procedures that are to be executed at exit to have a clean quit. *) module Init : sig type t (** Root start atom *) val start : t (** Root stop atom *) val stop : t (** Define a init atom associated with the given [(unit -> unit)] procedure, which eventualy depends on others atoms (these atoms will be executed before the one currently defined) and triggers other atoms (these atoms will be executed after the one currently defined). [after] and [before] allow to register the currently defined atom in the depend and triggers lists of other atoms. *) val make : ?name:string -> ?depends:t list -> ?triggers:t list -> ?after:t list -> ?before:t list -> (unit -> unit) -> t (** Same as [make] plus a shortcut for "after Init.start". *) val at_start : ?name:string -> ?depends:t list -> ?triggers:t list -> ?after:t list -> ?before:t list -> (unit -> unit) -> t (** Same as [make] plus a shortcut for "before Init.stop". *) val at_stop : ?name:string -> ?depends:t list -> ?triggers:t list -> ?after:t list -> ?before:t list -> (unit -> unit) -> t (** Launch the execution of a given init atom. *) val exec : t -> unit exception Root_prohibited of [ `User | `Group | `Both ] (** This fuction must be used to launch the main procedure of the program. It first execute the registered start atoms, then call the main procedure, then execute the registered stop atoms. Exceptions raised by the main procedure are catched, in order to close properly even in such cases. Exceptions are raised again after cleaning. When invoqued with [~prohibit_root:true], it checks for root access rights (euid, egid) and exit in this case. *) val init : ?prohibit_root:bool -> (unit -> unit) -> unit exception StartError of exn exception StopError of exn val conf : Conf.ut val conf_daemon : bool Conf.t val conf_daemon_pidfile : bool Conf.t val conf_daemon_pidfile_path : string Conf.t val conf_daemon_pidfile_perms : int Conf.t val conf_trace : bool Conf.t val conf_catch_exn : bool Conf.t (** A set of command line options to be used with the Arg module. *) val args : (string list * Arg.spec * string) list end module Log : sig type entry = { time : float; label : string option; level : int option; log : string; } (** Type for loggers. *) type t = < active : int -> bool ; level : int ; set_level : int -> unit ; path : Conf.path ; f : 'a. int -> ('a, unit, string, unit) format4 -> 'a ; g : 'a. ?colorize:(entry -> entry) -> int -> ('a, unit, string, unit) format4 -> 'a > type custom_log = { timestamp : bool; exec : string -> unit } (** Add a custom logging functions. *) val add_custom_log : string -> custom_log -> unit (** Remove a custom logging functions. *) val rm_custom_log : string -> unit (** Make a logger labeled according to the given path. *) val make : Conf.path -> t (** An atom that starts the logging. *) val start : Init.t (** An atom that stops the logging. *) val stop : Init.t val conf : Conf.ut val conf_level : int Conf.t val conf_unix_timestamps : bool Conf.t val conf_stdout : bool Conf.t val conf_file : bool Conf.t val conf_file_path : string Conf.t val conf_file_append : bool Conf.t val conf_file_perms : int Conf.t (** A set of command line options to be used with the Arg module. *) val args : (string list * Arg.spec * string) list end ocaml-dtools-0.4.6/src/dtools_impl.ml000066400000000000000000000646771476656062600176320ustar00rootroot00000000000000(**************************************************************************) (* ocaml-dtools *) (* Copyright (C) 2003-2010 The Savonet Team *) (**************************************************************************) (* This program is free software; you can redistribute it and/or modify *) (* it under the terms of the GNU General Public License as published by *) (* the Free Software Foundation; either version 2 of the License, or *) (* any later version. *) (**************************************************************************) (* Contact: savonet-devl@lists.sourceforge.net *) (**************************************************************************) (* $Id$ *) (** ocaml-dtools @author Stephane Gimenez *) module Conf = struct type link = string type path = link list and ut = < kind : string option ; descr : string ; comments : string list ; plug : string -> ut -> unit ; subs : string list ; path : string list -> ut ; routes : ut -> path list ; ut : ut > type 'a t = < kind : string option ; alias : ?comments:string list -> ?descr:string -> (ut -> unit) -> 'a t ; descr : string ; comments : string list ; plug : string -> ut -> unit ; subs : string list ; path : string list -> ut ; routes : ut -> path list ; ut : ut ; set_d : 'a option -> unit ; get_d : 'a option ; set : 'a -> unit ; get : 'a ; validate : ('a -> bool) -> unit ; on_change : ('a -> unit) -> unit > type links = (string * ut) list type 'a builder = ?d:'a -> ?p:(ut -> unit) -> ?l:links -> ?comments:string list -> string -> 'a t exception Undefined of ut exception Invalid of string exception Unbound of ut * string exception Bound of ut * string exception Mismatch of ut exception Wrong_Conf of string * string exception File_Wrong_Conf of string * int * string exception Cyclic of ut * ut exception Invalid_Value of ut let path_sep_regexp = Str.regexp "\\." let list_sep_regexp = Str.regexp ":" let line_regexp = Str.regexp "^[ \t]*\\([a-zA-Z]+\\)[ \t]+\\([a-zA-Z0-9._-]+\\)[ \t]*:\\(.*\\)$" let comment_regexp = Str.regexp "^[ ]*\\(#.*\\)?$" let check s = if Str.string_match path_sep_regexp s 0 then raise (Invalid s) let make kind ?(d : 'a option) ?(p : ut -> unit = fun _ -> ()) ?(l : links = []) ?(comments : string list = []) descr : 'a t = object (self) val kind : string option = kind val mutable descr : string = descr val mutable comments : string list = comments val mutable links : links = [] val value_d : 'a option ref = ref d val value : 'a option ref = ref None val mutable validators : ('a -> bool) list = [] val mutable listeners : ('a -> unit) list = [] initializer p self#ut; List.iter (fun (s, t) -> self#plug s t) l method subs = List.sort compare (List.map fst links) method private sub (s : string) : ut = check s; try List.assoc s links with Not_found -> raise (Unbound (self#ut, s)) method path (l : string list) : ut = match l with [] -> self#ut | s :: q -> (self#sub s)#path q method routes (st : ut) = (* todo: cache already accessed nodes *) let rec aux l t = match t = st with | true -> [List.rev l] | false -> List.concat (List.map (fun s -> aux (s :: l) (t#path [s])) t#subs) in aux [] self#ut method kind = kind method descr = descr method private set_descr new_descr = descr <- new_descr method comments = comments method private set_comments new_comments = comments <- new_comments method plug s t = if t#routes self#ut <> [] then raise (Cyclic (self#ut, t)); if List.mem_assoc s links then raise (Bound (self#ut, s)); links <- (s, t) :: links (* Nice hack. heh! *) method alias ?comments ?descr p = let maybe f x = match x with Some x -> f x | None -> () in let old_comments = self#comments in let old_descr = self#descr in maybe self#set_comments comments; maybe self#set_descr descr; let key = Oo.copy self in p key#ut; self#set_comments old_comments; self#set_descr old_descr; key method ut = (self :> ut) method get_d : 'a option = !value_d method set_d (v : 'a option) : unit = value_d := v method get : 'a = match !value with | None -> ( match !value_d with | None -> raise (Undefined self#ut) | Some v -> v) | Some v -> v method set (v : 'a) : unit = List.iter (fun fn -> if not (fn v) then raise (Invalid_Value self#ut)) validators; value := Some v; List.iter (fun fn -> fn v) listeners method validate (fn : 'a -> bool) : unit = validators <- fn :: validators method on_change (fn : 'a -> unit) : unit = listeners <- fn :: listeners end let void ?p ?l ?comments descr = (make None ?p ?l ~d:None ?comments descr)#ut let unit ?d = make (Some "unit") ?d let int ?d = make (Some "int") ?d let float ?d = make (Some "float") ?d let bool ?d = make (Some "bool") ?d let string ?d = make (Some "string") ?d let list ?d = make (Some "list") ?d (* Harmful function, do not use *) let force_type c (t : ut) : 'a t = match t#kind with | Some x when x = c -> (Obj.magic t : 'a t) | _ -> raise (Mismatch t) let as_unit t : unit t = force_type "unit" t let as_int t : int t = force_type "int" t let as_float t : float t = force_type "float" t let as_bool t : bool t = force_type "bool" t let as_string t : string t = force_type "string" t let as_list t : string list t = force_type "list" t let path_of_string p = Str.split path_sep_regexp p let string_of_path p = String.concat "." p let get_string (t : ut) = try match t#kind with | None -> None | Some "unit" -> Some "" | Some "int" -> Some (string_of_int (as_int t)#get) | Some "float" -> Some (string_of_float (as_float t)#get) | Some "bool" -> Some (string_of_bool (as_bool t)#get) | Some "string" -> Some (as_string t)#get | Some "list" -> Some (String.concat ":" (as_list t)#get) | _ -> assert false with Undefined _ -> None let get_d_string (t : ut) = let mapopt f = function None -> None | Some x -> Some (f x) in try match t#kind with | None -> None | Some "unit" -> mapopt (fun () -> "") (as_unit t)#get_d | Some "int" -> mapopt string_of_int (as_int t)#get_d | Some "float" -> mapopt string_of_float (as_float t)#get_d | Some "bool" -> mapopt string_of_bool (as_bool t)#get_d | Some "string" -> (as_string t)#get_d | Some "list" -> mapopt (String.concat ":") (as_list t)#get_d | _ -> assert false with Undefined _ -> None let descr ?(prefix = []) (t : ut) = let rec aux prefix t = let p s = if prefix = "" then s else prefix ^ "." ^ s in let subs = List.map (function s -> aux (p s) (t#path [s])) t#subs in Printf.sprintf "## %s\n" t#descr ^ begin match get_d_string t with | None -> "" | Some d -> Printf.sprintf "# default :%s\n" d end ^ begin match (t#kind, get_string t) with | Some k, None -> Printf.sprintf "#%s\t%-30s\n" k prefix | Some k, Some p -> Printf.sprintf "%s\t%-30s :%s\n" k prefix p | _ -> "" end ^ begin match t#comments with | [] -> "" | l -> "# comments:\n" ^ String.concat "" (List.map (fun s -> Printf.sprintf "# %s\n" s) l) end ^ "\n" ^ String.concat "" subs in aux (string_of_path prefix) (t#path prefix) let dump ?(prefix = []) (t : ut) = let rec aux prefix t = let p s = if prefix = "" then s else prefix ^ "." ^ s in let subs = List.map (function s -> aux (p s) (t#path [s])) t#subs in begin match t#kind with | Some k -> ( match (get_d_string t, get_string t) with | None, None -> Printf.sprintf "#%s\t%-30s\n" k prefix | Some p, None -> Printf.sprintf "#%s\t%-30s :%s\n" k prefix p | Some p, Some p' when p' = p -> Printf.sprintf "#%s\t%-30s :%s\n" k prefix p | _, Some p -> Printf.sprintf "%s\t%-30s :%s\n" k prefix p) | _ -> "" end ^ String.concat "" subs in aux (string_of_path prefix) (t#path prefix) let conf_set (t : ut) s = if Str.string_match line_regexp s 0 then ( let val0 = Str.matched_group 1 s in let val1 = Str.matched_group 2 s in let val2 = Str.matched_group 3 s in let st = t#path (path_of_string val1) in match val0 with | "unit" -> ( match val2 = "" with | false -> raise (Wrong_Conf (s, "unit expected")) | true -> (as_unit st)#set ()) | "int" -> let i = try int_of_string val2 with Invalid_argument _ -> raise (Wrong_Conf (s, "integer expected")) in (as_int st)#set i | "float" -> let f = try float_of_string val2 with Invalid_argument _ -> raise (Wrong_Conf (s, "float expected")) in (as_float st)#set f | "bool" -> let b = try bool_of_string val2 with Invalid_argument _ -> raise (Wrong_Conf (s, "boolean expected")) in (as_bool st)#set b | "string" -> let s = val2 in (as_string st)#set s | "list" -> let l = Str.split list_sep_regexp val2 in (as_list st)#set l | _ -> raise (Wrong_Conf (s, "unknown type"))) else raise (Wrong_Conf (s, "syntax error")) let conf_file t s = let nb = ref 0 in let f = open_in s in try while true do nb := !nb + 1; let l = input_line f in if Str.string_match comment_regexp l 0 then () else begin try conf_set t l with Wrong_Conf (_, y) -> raise (File_Wrong_Conf (s, !nb, y)) end done with End_of_file -> () let args t = [ ( ["--conf-file"; "-f"], Arg.String (conf_file t), "read the given configuration file" ); ( ["--conf-set"; "-s"], Arg.String (conf_set t), "apply the given configuration assignation" ); ( ["--conf-descr-key"], Arg.String (fun p -> Printf.printf "%s" (descr ~prefix:(path_of_string p) t); exit 0), "describe a configuration key" ); ( ["--conf-descr"], Arg.Unit (fun () -> Printf.printf "%s" (descr t); exit 0), "display a described table of the configuration keys" ); ( ["--conf-dump"], Arg.Unit (fun () -> Printf.printf "%s" (dump t); exit 0), "dump the configuration state" ); ] end module Init = struct let conf = Conf.void "initialization configuration" (* Unix.fork is not implemented in Win32. *) let daemon_conf = if Sys.os_type <> "Win32" then conf else Conf.void "dummy conf" let conf_daemon = Conf.bool ~p:(daemon_conf#plug "daemon") ~d:false "run in daemon mode" let conf_daemon_pidfile = Conf.bool ~p:(conf_daemon#plug "pidfile") ~d:false "support for pidfile generation" let conf_daemon_pidfile_path = Conf.string ~p:(conf_daemon_pidfile#plug "path") "path to pidfile" let conf_daemon_pidfile_perms = Conf.int ~d:0o640 ~p:(conf_daemon_pidfile#plug "perms") "Unix file permissions for pidfile. Default: `0o640`." let conf_daemon_drop_user = Conf.bool ~p:(conf_daemon#plug "change_user") ~d:false "Changes the effective user (drops privileges)." let conf_daemon_user = Conf.string ~p:(conf_daemon_drop_user#plug "user") ~d:"daemon" "User used to run the daemon." let conf_daemon_group = Conf.string ~p:(conf_daemon_drop_user#plug "group") ~d:"daemon" "Group used to run the daemon." let conf_trace = Conf.bool ~p:(conf#plug "trace") ~d:false "dump an initialization trace" let conf_catch_exn = Conf.bool ~p:(conf#plug "catch_exn") ~d:true "catch exceptions, use false to backtrace exceptions" type t = { name : string; mutable launched : bool; mutable depends : t list; mutable triggers : t list; mutable mutex : Mutex.t; f : unit -> unit; } let make ?(name = "") ?(depends = []) ?(triggers = []) ?(after = []) ?(before = []) f = let na = { name; launched = false; depends; triggers; mutex = Mutex.create (); f } in List.iter (fun a -> a.triggers <- na :: a.triggers) after; List.iter (fun a -> a.depends <- na :: a.depends) before; na let start = make ~name:"init-start" flush_all let stop = make ~name:"init-stop" flush_all let at_start ?name ?depends ?triggers ?after ?before f = let a = make ?name ?depends ?triggers ?after ?before f in start.triggers <- a :: start.triggers; a let at_stop ?name ?depends ?triggers ?after ?before f = let a = make ?name ?depends ?triggers ?after ?before f in stop.depends <- a :: stop.depends; a let rec exec a = let log = if conf_trace#get then fun s -> let id = Thread.id (Thread.self ()) in Printf.printf "init(%i):%-35s@%s\n%!" id a.name s else fun _ -> () in log "called"; Mutex.lock a.mutex; try if not a.launched then begin a.launched <- true; log "start"; log "start-depends"; List.iter exec a.depends; log "stop-depends"; log "start-atom"; a.f (); log "stop-atom"; log "start-triggers"; List.iter exec a.triggers; log "stop-triggers"; log "stop" end; Mutex.unlock a.mutex; log "return" with e -> Mutex.unlock a.mutex; raise e let rec wait_signal () = try ignore (Thread.wait_signal [Sys.sigterm; Sys.sigint]) with | Unix.Unix_error (Unix.EINTR, _, _) -> () | Sys_error s when s = "Thread.wait_signal: Interrupted system call" -> wait_signal () exception StartError of exn exception StopError of exn (* Dummy functions in the case where * Printexc does not have the required * functions. *) let get_backtrace () = "ocaml-dtools not compiled with ocaml >= 3.11, cannot print stack backtrace" (* For the compiler.. *) let () = ignore (get_backtrace ()) open Printexc let main f () = begin try exec start with e -> raise (StartError e) end; let quit pid = if Sys.os_type <> "Win32" then Unix.kill pid Sys.sigterm in let thread pid = try f (); quit pid with e -> let se = Printexc.to_string e in Printf.eprintf "init: exception encountered during main phase:\n %s\n%!" se; Printf.eprintf "exception: %s\n%s%!" se (get_backtrace ()); if conf_catch_exn#get then quit pid else raise e in let th = Thread.create thread (Unix.getpid ()) in if Sys.os_type <> "Win32" then wait_signal () else Thread.join th; try exec stop with e -> raise (StopError e) let catch f clean = try f (); clean () with | StartError e -> Printf.eprintf "init: exception encountered during start phase:\n %s\n%!" (Printexc.to_string e); clean (); exit (-1) | StopError e -> Printf.eprintf "init: exception encountered during stop phase:\n %s\n%!" (Printexc.to_string e); clean (); exit (-1) (** A function to reopen a file descriptor * Thanks to Xavier Leroy! * Ref: http://caml.inria.fr/pub/ml-archives/caml-list/2000/01/ * a7e3bbdfaab33603320d75dbdcd40c37.en.html *) let reopen_out outchan filename = flush outchan; let fd1 = Unix.descr_of_out_channel outchan in let fd2 = Unix.openfile filename [Unix.O_WRONLY] 0o666 in Unix.dup2 fd2 fd1; Unix.close fd2 (** The same for inchan *) let reopen_in inchan filename = let fd1 = Unix.descr_of_in_channel inchan in let fd2 = Unix.openfile filename [Unix.O_RDONLY] 0o666 in Unix.dup2 fd2 fd1; Unix.close fd2 let daemonize () = if Unix.fork () <> 0 then exit 0; (* Dettach from the console *) if Unix.setsid () < 0 then exit 1; (* Refork.. *) if Unix.fork () <> 0 then exit 0; (* Change umask to 0 *) ignore (Unix.umask 0); (* chdir to / *) Unix.chdir "/"; if conf_daemon_pidfile#get then begin (* Write PID to file *) let filename = conf_daemon_pidfile_path#get in let f = open_out_gen [Open_wronly; Open_creat; Open_trunc] conf_daemon_pidfile_perms#get filename in let pid = Unix.getpid () in output_string f (string_of_int pid); output_char f '\n'; close_out f end; (* Reopen usual file descriptor *) reopen_in stdin "/dev/null"; reopen_out stdout "/dev/null"; reopen_out stderr "/dev/null" let cleanup_daemon () = if conf_daemon_pidfile#get then ( try let filename = conf_daemon_pidfile_path#get in Sys.remove filename with _ -> ()) exception Root_prohibited of [ `User | `Group | `Both ] let exit_when_root () = (* Change user.. *) if conf_daemon_drop_user#get then begin let grd = Unix.getgrnam conf_daemon_group#get in let gid = grd.Unix.gr_gid in if Unix.getegid () <> gid then Unix.setgid gid; let pwd = Unix.getpwnam conf_daemon_user#get in let uid = pwd.Unix.pw_uid in if Unix.geteuid () <> uid then Unix.setuid uid end; match (Unix.geteuid (), Unix.getegid ()) with | 0, 0 -> raise (Root_prohibited `Both) | 0, _ -> raise (Root_prohibited `User) | _, 0 -> raise (Root_prohibited `Group) | _ -> () let init ?(prohibit_root = false) f = if prohibit_root then exit_when_root (); if conf_daemon#get && Sys.os_type <> "Win32" then daemonize (); let signal_h _ = () in Sys.set_signal Sys.sigterm (Sys.Signal_handle signal_h); Sys.set_signal Sys.sigint (Sys.Signal_handle signal_h); (* We block signals that would kill us, * we'll wait for them and shutdown cleanly. * On Windows this is impossible so the only way for the application * to shutdown is to terminate the main function [f]. *) if Sys.os_type <> "Win32" then ignore (Unix.sigprocmask Unix.SIG_BLOCK [Sys.sigterm; Sys.sigint]); let cleanup = if conf_daemon#get && Sys.os_type <> "Win32" then cleanup_daemon else fun () -> () in catch (main f) cleanup let args = if Sys.os_type <> "Win32" then [ ( ["-d"; "--daemon"], Arg.Unit (fun () -> conf_daemon#set true), "Run in daemon mode." ); ] else [] end module Log = struct type entry = { time : float; label : string option; level : int option; log : string; } type pending_entry = { colorize : entry -> entry; entry : entry } type t = < active : int -> bool ; level : int ; set_level : int -> unit ; path : Conf.path ; f : 'a. int -> ('a, unit, string, unit) format4 -> 'a ; g : 'a. ?colorize:(entry -> entry) -> int -> ('a, unit, string, unit) format4 -> 'a > type custom_log = { timestamp : bool; exec : string -> unit } let log_ch = ref None (* Custom logging methods. *) let custom_log : (string, custom_log) Hashtbl.t = Hashtbl.create 0 let add_custom_log name f = Hashtbl.replace custom_log name f let rm_custom_log name = Hashtbl.remove custom_log name let conf = Conf.void "log configuration" let conf_level = Conf.int ~p:(conf#plug "level") ~d:3 "general log level" let conf_unix_timestamps = Conf.bool ~p:(conf#plug "unix_timestamps") ~d:false "display unix timestamps (subsecond accuracy, timezone independant)" let conf_file = Conf.bool ~p:(conf#plug "file") ~d:true "log to file" let conf_file_path = Conf.string ~p:(conf_file#plug "path") "path to log file" let conf_file_append = Conf.bool ~p:(conf_file#plug "append") ~d:true "append log to the file" let conf_file_perms = Conf.int ~p:(conf_file#plug "perms") ~d:0o600 "log file permissions" let conf_stdout = Conf.bool ~p:(conf#plug "stdout") ~d:false "log to stdout" let timestamp time = match conf_unix_timestamps#get with | true -> Printf.sprintf "%f" time | false -> let date = Unix.localtime time in Printf.sprintf "%d/%02d/%02d %02d:%02d:%02d" (date.Unix.tm_year + 1900) (date.Unix.tm_mon + 1) date.Unix.tm_mday date.Unix.tm_hour date.Unix.tm_min date.Unix.tm_sec let message ?(show_timestamp = true) { time; label; level; log } = let label = match (label, level) with | None, None -> "" | Some l, None -> Printf.sprintf "[%s] " l | None, Some d -> Printf.sprintf "[%d] " d | Some l, Some d -> Printf.sprintf "[%s:%d] " l d in let str = label ^ log in let timestamp = if show_timestamp then timestamp time ^ " " else "" in Printf.sprintf "%s%s" timestamp str let print { colorize; entry } = let to_stdout = conf_stdout#get in let to_file = !log_ch <> None in begin match to_stdout || to_file with | true -> let do_stdout () = Printf.printf "%s\n%!" (message (colorize entry)) in let do_file () = match !log_ch with | None -> () | Some ch -> Printf.fprintf ch "%s\n%!" (message entry) in if to_stdout then do_stdout (); if to_file then do_file () | false -> () end; let f _ x = x.exec (message ~show_timestamp:x.timestamp entry) in Hashtbl.iter f custom_log (* Avoid interlacing logs *) let log_mutex = Mutex.create () let log_condition = Condition.create () let log_queue = ref (Queue.create ()) let log_stop = ref false let log_thread = ref None let mutexify f x = Mutex.lock log_mutex; try let ret = f x in Mutex.unlock log_mutex; ret with e -> Mutex.unlock log_mutex; raise e let rotate_queue () = let new_q = Queue.create () in mutexify (fun () -> let q = !log_queue in log_queue := new_q; q) () let flush_queue () = let rec flush q = Queue.iter print q; let q = rotate_queue () in if not (Queue.is_empty q) then flush q in flush (rotate_queue ()) let log_thread_fn () = let rec f () = flush_queue (); let log_stop = mutexify (fun () -> if !log_stop then true else begin Condition.wait log_condition log_mutex; !log_stop end) () in if not log_stop then f () in f () let proceed = mutexify (fun entry -> Queue.push entry !log_queue; Condition.signal log_condition) let make path : t = let path_str = Conf.string_of_path path in let conf_level = ref (fun () -> conf_level#get) in object (self : t) method path = path method active level = level <= !conf_level () method level = !conf_level () method set_level level = conf_level := (fun () -> level) method g ?(colorize = fun x -> x) level = match self#active level with | true -> let time = Unix.gettimeofday () in Printf.ksprintf (fun s -> List.iter (fun log -> proceed { colorize; entry = { time; label = Some path_str; level = Some level; log; }; }) (String.split_on_char '\n' s)) | false -> Printf.ksprintf (fun _ -> ()) method f level = self#g ?colorize:None level end let init () = let time = Unix.gettimeofday () in let reopen_log = if conf_file#get then begin let opts = [Open_wronly; Open_creat; Open_nonblock] @ if conf_file_append#get then [Open_append] else [Open_trunc] in let log_file_path = conf_file_path#get in let log_file_perms = conf_file_perms#get in log_ch := Some (open_out_gen opts log_file_perms log_file_path); fun _ -> begin match !log_ch with | None -> () | Some ch -> log_ch := None; close_out ch end; log_ch := Some (open_out_gen opts log_file_perms log_file_path) end else fun _ -> () in (* Re-open log file on SIGUSR1 -- for logrotate *) if Sys.os_type <> "Win32" then Sys.set_signal Sys.sigusr1 (Sys.Signal_handle reopen_log); print { colorize = (fun x -> x); entry = { time; level = None; label = None; log = ">>> LOG START" }; }; log_thread := Some (Thread.create log_thread_fn ()) let start = Init.make ~name:"init-log-start" ~before:[Init.start] init let close () = let time = Unix.gettimeofday () in mutexify (fun () -> log_stop := true) (); proceed { colorize = (fun x -> x); entry = { time; level = None; label = None; log = ">>> LOG END" }; }; begin match !log_thread with | None -> () | Some th -> log_thread := None; Condition.signal log_condition; Thread.join th end; match !log_ch with | None -> () | Some ch -> log_ch := None; close_out ch let stop = Init.make ~name:"init-log-stop" ~after:[Init.stop] close let args = [ ( ["--log-stdout"], Arg.Unit (fun () -> conf_stdout#set true), "log also to stdout" ); ( ["--log-file"; "-l"], Arg.String (fun s -> conf_file#set true; conf_file_path#set s), "log file" ); ] end ocaml-dtools-0.4.6/src/dtools_syslog.impl.ml000066400000000000000000000034651476656062600211350ustar00rootroot00000000000000(**************************************************************************) (* ocaml-dtools *) (* Copyright (C) 2003-2010 The Savonet Team *) (**************************************************************************) (* This program is free software; you can redistribute it and/or modify *) (* it under the terms of the GNU General Public License as published by *) (* the Free Software Foundation; either version 2 of the License, or *) (* any later version. *) (**************************************************************************) (* Contact: savonet-devl@lists.sourceforge.net *) (**************************************************************************) (* $Id$ *) (* Syslog logging. *) open Dtools_impl let conf_syslog = Conf.bool ~p:(Log.conf#plug "syslog") ~d:false "Enable syslog logging." let conf_program = Conf.string ~p:(conf_syslog#plug "program") ~d:(Filename.basename Sys.executable_name) "Name of the program." let conf_facility = Conf.string ~p:(conf_syslog#plug "facility") ~d:"DAEMON" "Logging facility." let logging = ref None let () = let start () = if conf_syslog#get then ( let facility = Syslog.facility_of_string conf_facility#get in let program = Printf.sprintf "%s[%d]" conf_program#get (Unix.getpid ()) in let log = Syslog.openlog ~facility program in logging := Some log; let exec s = Syslog.syslog log `LOG_INFO s in Log.add_custom_log program { Log.timestamp = false; exec }) in let stop () = match !logging with Some x -> Syslog.closelog x | _ -> () in ignore (Init.at_start ~before:[Log.start] start); ignore (Init.at_stop ~after:[Log.stop] stop) ocaml-dtools-0.4.6/src/dtools_syslog.noop.ml000066400000000000000000000000131476656062600211310ustar00rootroot00000000000000(* noop *) ocaml-dtools-0.4.6/src/dune000066400000000000000000000004061476656062600156050ustar00rootroot00000000000000(library (name dtools) (public_name dtools) (libraries str threads unix (select dtools_syslog.ml from (syslog -> dtools_syslog.impl.ml) (-> dtools_syslog.noop.ml))) (synopsis "Library providing various helper functions to make daemons")) ocaml-dtools-0.4.6/tools/000077500000000000000000000000001476656062600153005ustar00rootroot00000000000000ocaml-dtools-0.4.6/tools/logrider.ml000066400000000000000000000034711476656062600174460ustar00rootroot00000000000000#!/bin/env ocaml #load "str.cma" #load "unix.cma" let max_level = ref 9 let ddate = ref true let dtime = ref true let ddecimal = ref false let parse s = let re = Str.regexp "\\([0-9]+\\.[0-9]+\\) \\[\\([a-zA-Z._-]*\\):\\([0-9]+\\)\\] \\(.*\\)$" in if Str.string_match re s 0 then ( let time = float_of_string (Str.matched_group 1 s) in let label = Str.matched_group 2 s in let level = int_of_string (Str.matched_group 3 s) in let str = Str.matched_group 4 s in Some (time, label, level, str)) else None let rec disp file = let rec h f = try let l = input_line f in begin match parse l with | Some (time, label, level, str) -> let tm = Unix.localtime time in if level <= !max_level then begin if !ddate then Printf.printf "%04d-%02d-%02d " (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday; if !dtime then begin Printf.printf "%02d:%02d:%02d " tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec; if !ddecimal then Printf.printf "%f " (time -. floor time) end; Printf.printf "[%20s:%d]\n>>> %s\n" label level str end | None -> Printf.printf "-?-\n" end; h f with End_of_file -> () in let f = open_in file in h f; close_in f let parse_args = Arg.parse [ ("-l", Arg.String (fun l -> max_level := int_of_string l), "level"); ("-nd", Arg.Unit (fun () -> ddate := false), "no date"); ("-nt", Arg.Unit (fun () -> dtime := false), "no time"); ("-d", Arg.Unit (fun () -> ddecimal := true), "decimals"); ] (fun s -> disp s) (Printf.sprintf "usage : %s [options]" (Filename.basename Sys.argv.(0)))