diff --git a/.github/workflows/format.yml b/.github/workflows/format.yml index 94bda1e5a0b..b15173805cf 100644 --- a/.github/workflows/format.yml +++ b/.github/workflows/format.yml @@ -35,6 +35,7 @@ jobs: xs-opam: ${{ steps.dotenv.outputs.repository }} dune-cache: true opam-pin: false + opam-depext: false - name: Install ocamlformat run: opam install ocamlformat diff --git a/Makefile b/Makefile index 7c65b089dff..f30a39513df 100644 --- a/Makefile +++ b/Makefile @@ -241,7 +241,9 @@ install: build doc sdk doc-json gzip http-lib pciutil sexpr stunnel uuid xml-light2 zstd xapi-compression safe-resources \ message-switch message-switch-async message-switch-cli message-switch-core message-switch-lwt \ message-switch-unix xapi-idl forkexec xapi-forkexecd xapi-storage xapi-storage-script xapi-storage-cli \ - xapi-nbd varstored-guard xapi-log xapi-open-uri xapi-tracing xapi-expiry-alerts cohttp-posix + xapi-nbd varstored-guard xapi-log xapi-open-uri xapi-tracing xapi-expiry-alerts cohttp-posix \ + xapi-rrd xapi-inventory \ + xapi-stdext-date xapi-stdext-encodings xapi-stdext-pervasives xapi-stdext-std xapi-stdext-threads xapi-stdext-unix xapi-stdext-zerocheck xapi-stdext # docs mkdir -p $(DESTDIR)$(DOCDIR) cp -r $(XAPIDOC)/jekyll $(DESTDIR)$(DOCDIR) @@ -261,7 +263,9 @@ uninstall: gzip http-lib pciutil sexpr stunnel uuid xml-light2 zstd xapi-compression safe-resources \ message-switch message-switch-async message-switch-cli message-switch-core message-switch-lwt \ message-switch-unix xapi-idl forkexec xapi-forkexecd xapi-storage xapi-storage-script xapi-log \ - xapi-open-uri xapi-tracing xapi-expiry-alerts cohttp-posix + xapi-open-uri xapi-tracing xapi-expiry-alerts cohttp-posix \ + xapi-rrd xapi-inventory \ + xapi-stdext-date xapi-stdext-encodings xapi-stdext-pervasives xapi-stdext-std xapi-stdext-threads xapi-stdext-unix xapi-stdext-zerocheck xapi-stdext compile_flags.txt: Makefile (ocamlc -config-var ocamlc_cflags;\ diff --git a/dune-project b/dune-project index 1d7c53c0480..747fc62b133 100644 --- a/dune-project +++ b/dune-project @@ -253,3 +253,107 @@ (package (name cohttp-posix) ) + +(package + (name xapi-rrd) +) + +(package + (name xapi-inventory) +) + +(package + (name xapi-stdext) + (synopsis "Xapi's standard library extension") + (description "Dummy package that enables the usage of dune-release") + (depends + (xapi-stdext-date (= :version)) + (xapi-stdext-encodings (= :version)) + (xapi-stdext-pervasives (= :version)) + (xapi-stdext-std (= :version)) + (xapi-stdext-threads (= :version)) + (xapi-stdext-unix (= :version)) + (xapi-stdext-zerocheck (= :version)) + ) +) + +(package + (name xapi-stdext-date) + (synopsis "Xapi's standard library extension, Dates") + (depends + (ocaml (>= 4.12)) + (alcotest :with-test) + astring + base-unix + ptime + (odoc :with-doc) + ) +) + +(package + (name xapi-stdext-encodings) + (synopsis "Xapi's standard library extension, Encodings") + (depends + (ocaml (>= 4.13.0)) + (alcotest (and (>= 0.6.0) :with-test)) + (odoc :with-doc) + (bechamel :with-test) + (bechamel-notty :with-test) + (notty :with-test) + ) +) + +(package + (name xapi-stdext-pervasives) + (synopsis "Xapi's standard library extension, Pervasives") + (depends + (ocaml (>= 4.08)) + logs + (odoc :with-doc) + xapi-backtrace + ) +) + +(package + (name xapi-stdext-std) + (synopsis "Xapi's standard library extension, Stdlib") + (depends + (ocaml (>= 4.08.0)) + (alcotest :with-test) + (odoc :with-doc) + ) +) + +(package + (name xapi-stdext-threads) + (synopsis "Xapi's standard library extension, Threads") + (depends + ocaml + base-threads + base-unix + (odoc :with-doc) + (xapi-stdext-pervasives (= :version)) + ) +) + +(package + (name xapi-stdext-unix) + (synopsis "Xapi's standard library extension, Unix") + (depends + (ocaml (>= 4.12.0)) + base-unix + (fd-send-recv (>= 2.0.0)) + (odoc :with-doc) + xapi-backtrace + (xapi-stdext-pervasives (= :version)) + ) +) + +(package + (name xapi-stdext-zerocheck) + (synopsis "Xapi's standard library extension, Zerocheck") + (depends + ocaml + (odoc :with-doc) + ) +) diff --git a/ocaml/forkexecd/.ocamlformat b/ocaml/forkexecd/.ocamlformat deleted file mode 100644 index f86522707f6..00000000000 --- a/ocaml/forkexecd/.ocamlformat +++ /dev/null @@ -1,9 +0,0 @@ -profile=ocamlformat -indicate-multiline-delimiters=closing-on-separate-line -if-then-else=fit-or-vertical -dock-collection-brackets=true -break-struct=natural -break-separators=before -break-infix=fit-or-vertical -break-infix-before-func=false -sequence-blank-line=preserve-one diff --git a/ocaml/libs/xapi-inventory/.gitignore b/ocaml/libs/xapi-inventory/.gitignore new file mode 100644 index 00000000000..a2da242d6a4 --- /dev/null +++ b/ocaml/libs/xapi-inventory/.gitignore @@ -0,0 +1,7 @@ +_build/ +*.install +.merlin + +*.orig +*.rej +xcp_inventory_config.ml diff --git a/ocaml/libs/xapi-inventory/ChangeLog b/ocaml/libs/xapi-inventory/ChangeLog new file mode 100644 index 00000000000..1a57fb351d8 --- /dev/null +++ b/ocaml/libs/xapi-inventory/ChangeLog @@ -0,0 +1,36 @@ +## v1.2.3 (17 Jun 2022): +* maintenance: Decrease direct usages of Threadext +* Add license to opam metadata + +## v1.2.2 (28 Jul 2021): +* maintenance: clean up opam metadata +* maintenance: change default filename to /etc/xensource-inventory +* maintenance: use dune instead of jbuilder +* maintenance: fix travis + +## v1.2.1 (3 Dec 2018): +- Removed conflict between xcp-inventory and xapi-inventory. +- Ported build to dune and deprecated the old package xcp-inventory. + +## v1.2.0 (9 Jan 2018): +* inventory: preserve old ~limit:2 semantic + +## v1.1.0 (14 Dec 2017): +* Reindentation and file mode change. +* Replace xapi-stdext with xapi-stdext-subpackages and astring. +* CA-276606: Ported build from _oasis to jbuilder. +* Sync opam file with xs-opam + +## v1.0.2 (03 Febr 2017): +* fix Makfile to make installation via Opam work +* add Git meta data files .gitarchive-info and .gitattributes + +## v1.0.1 (22 Jun 2016): +* Update to Stdext 2.0.0 + +## v0.9.1 (3 Jun 2014): +* second public release +* Update to cohttp-0.11.2 interface + +## v0.9.0 (5 Jun 2013): +* first public release diff --git a/ocaml/libs/xapi-inventory/LICENSE b/ocaml/libs/xapi-inventory/LICENSE new file mode 100644 index 00000000000..1b1ce97cb5c --- /dev/null +++ b/ocaml/libs/xapi-inventory/LICENSE @@ -0,0 +1,521 @@ +This repository is distributed under the terms of the GNU Lesser General +Public License version 2.1 (included below). + +As a special exception to the GNU Lesser General Public License, you +may link, statically or dynamically, a "work that uses the Library" +with a publicly distributed version of the Library to produce an +executable file containing portions of the Library, and distribute +that executable file under terms of your choice, without any of the +additional requirements listed in clause 6 of the GNU Lesser General +Public License. By "a publicly distributed version of the Library", +we mean either the unmodified Library as distributed, or a +modified version of the Library that is distributed under the +conditions defined in clause 3 of the GNU Library General Public +License. This exception does not however invalidate any other reasons +why the executable file might be covered by the GNU Lesser General +Public License. + +------------ + + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +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 and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, 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 library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete 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 distribute a copy of this License along with the +Library. + + 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 Library or any portion +of it, thus forming a work based on the Library, 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) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +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 Library, 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 Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you 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. + + If distribution of 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 satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be 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. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library 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. + + 9. 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 Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +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 with +this License. + + 11. 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 Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library 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 Library. + +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. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library 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. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser 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 Library +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 Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +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 + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "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 +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. 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 LIBRARY 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 +LIBRARY (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 LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), 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 Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. 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 library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/ocaml/libs/xapi-inventory/README.md b/ocaml/libs/xapi-inventory/README.md new file mode 100644 index 00000000000..18b4f596890 --- /dev/null +++ b/ocaml/libs/xapi-inventory/README.md @@ -0,0 +1,4 @@ +# The XCP inventory library + +Maintains a database of key-value pairs at a specific location in the +filesystem. diff --git a/ocaml/libs/xapi-inventory/lib/dune b/ocaml/libs/xapi-inventory/lib/dune new file mode 100644 index 00000000000..7fb4aa7e40b --- /dev/null +++ b/ocaml/libs/xapi-inventory/lib/dune @@ -0,0 +1,12 @@ +(library + (name inventory) + (public_name xapi-inventory) + (wrapped false) + (libraries + uuidm + astring + xapi-stdext-unix + xapi-stdext-threads + threads + ) +) diff --git a/ocaml/libs/xapi-inventory/lib/inventory.ml b/ocaml/libs/xapi-inventory/lib/inventory.ml new file mode 100644 index 00000000000..374780a09f8 --- /dev/null +++ b/ocaml/libs/xapi-inventory/lib/inventory.ml @@ -0,0 +1,147 @@ +(* + * Copyright (C) 2006-2010 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) +(* Code to parse the XenSource inventory file *) + +open Xapi_stdext_unix +module M = Xapi_stdext_threads.Threadext.Mutex + +let inventory_filename = ref "/etc/xensource-inventory" + +(* Keys which must exist: *) +let _installation_uuid = "INSTALLATION_UUID" + +let _control_domain_uuid = "CONTROL_DOMAIN_UUID" + +let _management_interface = "MANAGEMENT_INTERFACE" + +let _management_address_type = "MANAGEMENT_ADDRESS_TYPE" + +let _build_number = "BUILD_NUMBER" + +(* Optional keys: *) +let _current_interfaces = "CURRENT_INTERFACES" + +let _oem_manufacturer = "OEM_MANUFACTURER" + +let _oem_model = "OEM_MODEL" + +let _oem_build_number = "OEM_BUILD_NUMBER" + +let _machine_serial_number = "MACHINE_SERIAL_NUMBER" + +let _machine_serial_name = "MACHINE_SERIAL_NAME" + +let _stunnel_idle_timeout = "STUNNEL_IDLE_TIMEOUT" + +let _stunnel_legacy = "STUNNEL_LEGACY" + +let loaded_inventory = ref false + +let inventory = Hashtbl.create 10 + +let inventory_m = Mutex.create () + +(* Compute the minimum necessary inventory file contents *) +let minimum_default_entries () = + let host_uuid = Uuidm.to_string (Uuidm.v `V4) in + let dom0_uuid = Uuidm.to_string (Uuidm.v `V4) in + [ + (_installation_uuid, host_uuid) + ; (_control_domain_uuid, dom0_uuid) + ; (_management_interface, "") + ; (_management_address_type, "IPv4") + ; (_build_number, "0") + ] + +(* trim any quotes off the ends *) +let strip_quotes v = + if String.length v >= 2 && v.[0] = '\'' && v.[String.length v - 1] = '\'' then + String.sub v 1 (String.length v - 2) + else + v + +let parse_inventory_entry line = + match Astring.String.cut ~sep:"=" line with + | Some (k, v) -> + (* trim whitespace *) + Some (k, v |> strip_quotes |> String.trim) + | None -> + None + +let string_of_table h = + let lines = + List.fold_left + (fun acc (k, v) -> Printf.sprintf "%s='%s'\n" k v :: acc) + [] h + in + String.concat "" lines + +let read_inventory_contents () = + if not (Sys.file_exists !inventory_filename) then + Unixext.write_string_to_file !inventory_filename + (string_of_table (minimum_default_entries ())) ; + (* Perhaps we should blank the old inventory before we read the new one? + What is the desired behaviour? *) + Unixext.file_lines_iter + (fun line -> + match parse_inventory_entry line with + | Some (k, v) -> + Hashtbl.add inventory k v + | None -> + () + ) + !inventory_filename ; + loaded_inventory := true + +let read_inventory () = M.execute inventory_m read_inventory_contents + +let reread_inventory () = + M.execute inventory_m (fun () -> + Hashtbl.clear inventory ; read_inventory_contents () + ) + +exception Missing_inventory_key of string + +let lookup ?default key = + M.execute inventory_m (fun () -> + if not !loaded_inventory then read_inventory_contents () ; + if Hashtbl.mem inventory key then + Hashtbl.find inventory key + else + match default with + | None -> + raise (Missing_inventory_key key) + | Some v -> + v + ) + +let flush_to_disk_locked () = + let h = Hashtbl.fold (fun k v acc -> (k, v) :: acc) inventory [] in + Unixext.write_string_to_file !inventory_filename (string_of_table h) + +let update key value = + M.execute inventory_m (fun () -> + Hashtbl.clear inventory ; + read_inventory_contents () ; + Hashtbl.replace inventory key value ; + flush_to_disk_locked () + ) + +let remove key = + M.execute inventory_m (fun () -> + Hashtbl.clear inventory ; + read_inventory_contents () ; + Hashtbl.remove inventory key ; + flush_to_disk_locked () + ) diff --git a/ocaml/libs/xapi-rrd/.gitignore b/ocaml/libs/xapi-rrd/.gitignore new file mode 100644 index 00000000000..3fce47935b6 --- /dev/null +++ b/ocaml/libs/xapi-rrd/.gitignore @@ -0,0 +1,3 @@ +_build +.merlin +*.install diff --git a/ocaml/libs/xapi-rrd/ChangeLog b/ocaml/libs/xapi-rrd/ChangeLog new file mode 100644 index 00000000000..0606ae6dd3a --- /dev/null +++ b/ocaml/libs/xapi-rrd/ChangeLog @@ -0,0 +1,115 @@ +## v1.12.0 (11-Dec-2023) +* lib: fix typo in ds field minimal_heartbeat + +## v1.11.0 (16-Nov-2023) +* lib: remove Failure "hd" exceptions + +## v1.10.0 (02-Aug-2023) +* rrd_updates: use yojson instead of ad-hoc json serialization + +## v1.9.2 (13-Jun-2023) +* CA-378301: Avoid memory leaks when writing XML + +## v1.9.1 (28-Oct-2022) +* CA-371780: Remove quadratic cost in ds_update_name + +## v1.9.0 (02-Aug-2022) +* ocamlformat: apply new formatting +* unix: remove code from module +* CA-367236: replace ezjsonm with yojson +* Add license to opam metadata and delete deprecated package +* ci: drop travis +* ci: use github +* maintenance: format code with ocamlformat +* chore: prepare for ocamlformat, use dune 2.0 + +## v1.8.2 (09-Sep-2020) +* maintenance(lib_test): refactor crowbar tests +* fix (lib_test): remove duplicated test suite + +## v1.8.1 (24-Mar-2020) +* CP-33354 fix inconsistent number of columns +* rrd: update documentation +* rrd: delete unused functions +* maintenance: whitespace +* rrd_updates: Do not expose Failure "hd" when exporting rrds +* rrd: share to_string methods among serializers +* rrd: cleanup around ds_values processing + +## v1.8.0 (31-Oct-2019) +CA-329813: fix including a datasource to an rrd +CA-329813: add regression tests +opam: refresh metadata + +## v1.7.0 (29-Oct-2019) +* CA-325844: Test RRAs are validated when deserializing +* CA-329043: Add sanity checks to rrds +* CA-329043: Use type system to avoid storing out-of-range values +* CA-329043: add case generated by crowbar +* unit_tests: compare min and max values once per ds +* dune: simplify test definition +* CA-329043: Add crowbar tests +* CA-329043: Do not produce default values that are out-of-bounds +* CA-329043: Add regression test +* tests: add json marshalling +* travis: load vars from xs-opam repo + +## v1.6.0 (29-Jul-2019) +* CA-322008: Report out-of-bounds PDP values as NaN +* maintenance: whitespace and commented code deletion +* maintenance: use infix operators for Int64 in rrd +* CA-322008: Reorganize code for incoming values by type +* CA-322008: do not treat DERIVE sources as COUNTER +* tests: add regression test for CA-322008 +* ci: update and simplify travis configuration +* tests: use random names for files +* tests: check that all values in RRas are within bounds +* tests: convert int and string asserts to alcotest +* tests: Consolidate floating-point comparisons +* tests: port to alcotest + +## v1.5.0 (17-May-2019) +* CA-315952 add missing data in Json output +* CA-315952 fix JSON output + +## v1.4.1 (08-Jan-2019) +* Deprecated package rrd in favour of xapi-rrd. +* Move from jbuilder to dune. + +## v1.4.0 (03-Sep-2018) +* Simplify PPX processing +* Use rpclib if it's available + +## v1.3.0 (15-Mar-2018): +* Make safe-string safe + +## v1.2.0 (28-Feb-2018): +* Added missing bigarray dependency in the jbuild file + +## v1.1.0 (06-Dec-2017): +* Updated dependencies +* Code cleanup +* Port to jbuilder + +## v1.0.1 (16-Jun-2017): +* Use new ppx deriver in place of old camlp4 one +* Fix deprecation warnings + +## v1.0.0 (27-Apr-2016): +* Declare this package stable + +## v0.12.0 (25-Jun-2015): +* rrd_updates: interpret a -ve start as relative to now +* add a concept of rrd_timescales + +## v0.10.1 (2-Apr-2015): +* remove dependency on xapi libraries +* remove Unix dependency + +## v0.9.1 (26-Sep-2014): +* CA-102285: Use the stream API to read the XML RRD file +* Fix 'make install' and 'make uninstall' (by making them PHONY targets) + +## v0.9.0 (6-Jun-2013): +* first public release + diff --git a/ocaml/libs/xapi-rrd/LICENSE b/ocaml/libs/xapi-rrd/LICENSE new file mode 100644 index 00000000000..1b1ce97cb5c --- /dev/null +++ b/ocaml/libs/xapi-rrd/LICENSE @@ -0,0 +1,521 @@ +This repository is distributed under the terms of the GNU Lesser General +Public License version 2.1 (included below). + +As a special exception to the GNU Lesser General Public License, you +may link, statically or dynamically, a "work that uses the Library" +with a publicly distributed version of the Library to produce an +executable file containing portions of the Library, and distribute +that executable file under terms of your choice, without any of the +additional requirements listed in clause 6 of the GNU Lesser General +Public License. By "a publicly distributed version of the Library", +we mean either the unmodified Library as distributed, or a +modified version of the Library that is distributed under the +conditions defined in clause 3 of the GNU Library General Public +License. This exception does not however invalidate any other reasons +why the executable file might be covered by the GNU Lesser General +Public License. + +------------ + + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +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 and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, 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 library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete 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 distribute a copy of this License along with the +Library. + + 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 Library or any portion +of it, thus forming a work based on the Library, 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) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +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 Library, 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 Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you 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. + + If distribution of 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 satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be 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. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library 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. + + 9. 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 Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +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 with +this License. + + 11. 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 Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library 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 Library. + +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. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library 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. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser 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 Library +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 Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +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 + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "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 +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. 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 LIBRARY 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 +LIBRARY (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 LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), 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 Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. 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 library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/ocaml/libs/xapi-rrd/README.md b/ocaml/libs/xapi-rrd/README.md new file mode 100644 index 00000000000..66444557269 --- /dev/null +++ b/ocaml/libs/xapi-rrd/README.md @@ -0,0 +1 @@ +Round-Robin Datasources (RRDs) for OCaml. diff --git a/ocaml/libs/xapi-rrd/lib/dune b/ocaml/libs/xapi-rrd/lib/dune new file mode 100644 index 00000000000..00b4bedfc3d --- /dev/null +++ b/ocaml/libs/xapi-rrd/lib/dune @@ -0,0 +1,14 @@ +(library + (name rrd) + (public_name xapi-rrd) + (flags (:standard -w -39)) + (wrapped false) + (libraries + bigarray + rpclib.json + xmlm + yojson + ) + (preprocess (pps ppx_deriving_rpc)) +) + diff --git a/ocaml/libs/xapi-rrd/lib/rrd.ml b/ocaml/libs/xapi-rrd/lib/rrd.ml new file mode 100644 index 00000000000..3c2f8d707a8 --- /dev/null +++ b/ocaml/libs/xapi-rrd/lib/rrd.ml @@ -0,0 +1,1002 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) +(** This module provides a util that records data in a way that's compatible + with {{: http://oss.oetiker.ch/rrdtool/index.en.html} rrdtool}. *) + +module Fring = Rrd_fring +module Utils = Rrd_utils +module StringMap = Map.Make (String) + +exception No_RRA_Available + +exception Invalid_data_source of string + +type ds_owner = VM of string | Host | SR of string + +(** Data source types - see ds datatype *) +type ds_type = Absolute | Gauge | Derive [@@deriving rpc] + +(** Consolidation function - see RRA datatype *) +type cf_type = CF_Average | CF_Min | CF_Max | CF_Last + +(** Container so that we can handle different typed inputs *) +type ds_value_type = VT_Float of float | VT_Int64 of int64 | VT_Unknown +[@@deriving rpc] + +type sampling_frequency = Five_Seconds [@@deriving rpc] + +(* utility *) + +let ( +++ ) = Int64.add + +let ( --- ) = Int64.sub + +let ( *** ) = Int64.mul + +let ( /// ) = Int64.div + +let ds_type_to_string = function + | Gauge -> + "GAUGE" + | Absolute -> + "ABSOLUTE" + | Derive -> + "DERIVE" + +let cf_type_of_string = function + | "AVERAGE" -> + CF_Average + | "MIN" -> + CF_Min + | "MAX" -> + CF_Max + | "LAST" -> + CF_Last + | x -> + failwith (Printf.sprintf "Unknown cf_type: %s" x) + +let cf_type_to_string = function + | CF_Average -> + "AVERAGE" + | CF_Max -> + "MAX" + | CF_Min -> + "MIN" + | CF_Last -> + "LAST" + +let ds_value_to_string = function + | VT_Float x -> + Utils.f_to_s x + | VT_Int64 x -> + Printf.sprintf "%Ld" x + | _ -> + "0.0" + +(** The CDP preparation scratch area. + The 'value' field should be accumulated in such a way that it always + contains the value that will eventually be the CDP. This means that + for averages, we accumulate 1/n * the PDP, and renormalise when we + have unknown PDPs. For the other types it's much easier *) + +type cdp_prep = { + mutable cdp_value: float + ; mutable cdp_unknown_pdps: int (** How may PDPs have been unknown so far *) +} + +(** DS - a data source + This defines how we deal with incoming data. Type is one of: + + - Absolute: meaning that the incoming data is an absolute rate + - Derive: meaning that the rate must come from the difference between the + incoming data and the previous value + - Gauge: meaning that the value isn't a rate at all (e.g. temperature, load avg) + + Optionally, there is a maximum time greater than which we mark the PDPs + as unknown. *) + +type ds = { + ds_name: string (** Name *) + ; ds_ty: ds_type + (** Type of rate the input must be processed as, see above *) + ; ds_min: float + ; ds_max: float + ; ds_mrhb: float (** Maximum time between updates *) + ; mutable ds_last: ds_value_type (** Last raw value that was processed *) + ; mutable ds_value: float (** Current calculated rate of the PDP *) + ; mutable ds_unknown_sec: float + (** Number of seconds that are unknown in the current PDP *) +} +[@@deriving rpc] + +(** RRA - RRD archive + This is an archive that holds consolidated data points (CDPs) belonging to + a single consolidation function. They are stored in rings buffers, each + one related to a single different data-source. It defines the type of + consolidation that happens (average, max, min or last), the number of + primary data points (PDPs) that go to make a CDP, and the number of CDPs + to store. + + To better visualize how the datapoints are stored: + + │ Datasources ┃ ┃ ┃ + └─────────────────┨ Memory ┃ cputime ┃ + Consolidators ┃ ┃ ┃ + ━━━━━━━━━━━━━━━━━━╋━━━━━━━━━━━━━━━━━╋━━━━━━━━━━━━━━━━━┫ + Average ┃ Fring of CDPs ┃ Fring of CDPs ┃ ← RRA + ━━━━━━━━━━━━━━━━━━╋━━━━━━━━━━━━━━━━━╋━━━━━━━━━━━━━━━━━┫ + Max ┃ Fring of CDPs ┃ Fring of CDPs ┃ ← RRA + ━━━━━━━━━━━━━━━━━━┻━━━━━━━━━━━━━━━━━┻━━━━━━━━━━━━━━━━━┛ + *) + +type rra = { + rra_cf: cf_type (** consolidation function *) + ; rra_row_cnt: int (** number of entries to store *) + ; rra_pdp_cnt: int (** number of pdps per cdp *) + ; rra_xff: float + (** proportion of missing pdps at which we mark the cdp as unknown *) + ; rra_data: Fring.t array (** Stored data, one ring per datasource *) + ; rra_cdps: cdp_prep array + (** scratch area for consolidated datapoint preparation *) + ; mutable rra_updatehook: (rrd -> int -> unit) option + (** Hook that gets called when an update happens *) +} + +(** The container for the DSs and RRAs. Also specifies the period between pdps *) + +and rrd = { + mutable last_updated: float (** Last updated time in seconds *) + ; timestep: int64 (** Period between PDPs *) + ; rrd_dss: ds array + ; rrd_rras: rra array +} + +let copy_cdp_prep x = + {cdp_value= x.cdp_value; cdp_unknown_pdps= x.cdp_unknown_pdps} + +let copy_rra x = + { + rra_cf= x.rra_cf + ; rra_row_cnt= x.rra_row_cnt + ; rra_pdp_cnt= x.rra_pdp_cnt + ; rra_xff= x.rra_xff + ; rra_data= Array.map Fring.copy x.rra_data + ; rra_cdps= Array.map copy_cdp_prep x.rra_cdps + ; rra_updatehook= x.rra_updatehook + } + +let copy_ds x = + { + ds_name= x.ds_name (* not mutable *) + ; ds_ty= x.ds_ty + ; ds_min= x.ds_min + ; ds_max= x.ds_max + ; ds_mrhb= x.ds_mrhb + ; ds_last= x.ds_last + ; ds_value= x.ds_value + ; ds_unknown_sec= x.ds_unknown_sec + } + +let copy_rrd x = + { + last_updated= x.last_updated + ; timestep= x.timestep + ; rrd_dss= Array.map copy_ds x.rrd_dss + ; rrd_rras= Array.map copy_rra x.rrd_rras + } + +(* CA-329043: avoid producing out-of-range rates *) +let cf_init_value cf ds = + let default = + match cf with + | CF_Average -> + 0.0 + | CF_Min -> + infinity + | CF_Max -> + neg_infinity + | CF_Last -> + nan + in + min ds.ds_max (max ds.ds_min default) + +(** Helper function to get the start time and age of the current/last PDP *) +let get_times time timestep = + let starttime = timestep *** (Int64.of_float time /// timestep) in + let age = time -. Int64.to_float starttime in + (starttime, age) + +(** Update the CDP value with a number (start_pdp_offset) of PDPs. *) +let do_cfs rra start_pdp_offset pdps = + for i = 0 to Array.length pdps - 1 do + let cdp = rra.rra_cdps.(i) in + if Utils.isnan pdps.(i) then ( + (* CDP is an accumulator for the average. If we've got some unknowns, we need to + renormalize. ie, CDP contains \sum_{i=0}^j{ (1/n) x_i} where n is the number of + values we expect to have. If we have unknowns, we need to multiply the whole + thing by \frac{n_{old}}{n_{new}} *) + let olddiv = rra.rra_pdp_cnt - cdp.cdp_unknown_pdps in + let newdiv = olddiv - start_pdp_offset in + if newdiv > 0 then ( + cdp.cdp_value <- + cdp.cdp_value *. float_of_int olddiv /. float_of_int newdiv ; + cdp.cdp_unknown_pdps <- cdp.cdp_unknown_pdps + start_pdp_offset + ) + ) else + let cdpv = cdp.cdp_value in + cdp.cdp_value <- + ( match rra.rra_cf with + | CF_Average -> + cdpv + +. pdps.(i) + *. float_of_int start_pdp_offset + /. float_of_int rra.rra_pdp_cnt + | CF_Min -> + min cdpv pdps.(i) + | CF_Max -> + max cdpv pdps.(i) + | CF_Last -> + pdps.(i) + ) + done + +(** Update the RRAs with a number of PDPs. *) +let rra_update rrd proc_pdp_st elapsed_pdp_st pdps = + (* debug "rra_update";*) + let updatefn rra = + let start_pdp_offset = + rra.rra_pdp_cnt + - Int64.( + to_int (rem (proc_pdp_st /// rrd.timestep) (of_int rra.rra_pdp_cnt)) + ) + in + let rra_step_cnt = + if elapsed_pdp_st < start_pdp_offset then + 0 + else + ((elapsed_pdp_st - start_pdp_offset) / rra.rra_pdp_cnt) + 1 + in + do_cfs rra (min start_pdp_offset elapsed_pdp_st) pdps ; + if rra_step_cnt > 0 then ( + (* When writing multiple CDP values into the archive, the + first one (primary) is calculated using the values we + already had accumulated from the last update, whereas any + subsequent values (secondary) are calculated just using the + current PDP. It turns out that the secondary values are + simply the PDPs as whichever CF is used, a CDP of many + repeated values is simply the value itself. *) + let primaries = + Array.map + (fun cdp -> + if + cdp.cdp_unknown_pdps + <= int_of_float (rra.rra_xff *. float_of_int rra.rra_pdp_cnt) + then + cdp.cdp_value + else + nan + ) + rra.rra_cdps + in + let secondaries = pdps in + + let push i value = Fring.push rra.rra_data.(i) value in + Array.iteri push primaries ; + for _ = 1 to min (rra_step_cnt - 1) rra.rra_row_cnt do + Array.iteri push secondaries + done ; + + (* Reinitialise the CDP preparation area *) + let new_start_pdp_offset = + (elapsed_pdp_st - start_pdp_offset) mod rra.rra_pdp_cnt + in + Array.iteri + (fun i cdp -> + let ds = rrd.rrd_dss.(i) in + let cdp_init = cf_init_value rra.rra_cf ds in + cdp.cdp_unknown_pdps <- 0 ; + cdp.cdp_value <- cdp_init + ) + rra.rra_cdps ; + do_cfs rra new_start_pdp_offset pdps ; + match rra.rra_updatehook with None -> () | Some f -> f rrd rra_step_cnt + ) + in + Array.iter updatefn rrd.rrd_rras + +(* We assume that the data being given is of the form of a rate; that is, + it's dependent on the time interval between updates. To be able to + deal with gauge DSs, we multiply by the interval so that it cancels + the subsequent divide by interval later on *) +let process_ds_value ds value interval new_domid = + if interval > ds.ds_mrhb then + nan + else + let value_raw = + match value with + | VT_Int64 y -> + Int64.to_float y + | VT_Float y -> + y + | VT_Unknown -> + nan + in + + let rate = + match (ds.ds_ty, new_domid) with + | Absolute, _ | Derive, true -> + value_raw + | Gauge, _ -> + value_raw *. interval + | Derive, false -> ( + match (ds.ds_last, value) with + | VT_Int64 x, VT_Int64 y -> + Int64.to_float (y --- x) + | VT_Float x, VT_Float y -> + y -. x + | VT_Unknown, _ | _, VT_Unknown -> + nan + | _ -> + failwith ("Bad type updating ds: " ^ ds.ds_name) + ) + in + ds.ds_last <- value ; + rate + +let ds_update rrd timestamp values transforms new_domid = + (* Interval is the time between this and the last update *) + let interval = timestamp -. rrd.last_updated in + (* Work around the clock going backwards *) + let interval = if interval < 0. then 5. else interval in + + (* start time (st) and age of the last processed pdp and the currently occupied one *) + let proc_pdp_st, _proc_pdp_age = get_times rrd.last_updated rrd.timestep in + let occu_pdp_st, occu_pdp_age = get_times timestamp rrd.timestep in + + (* The number of pdps that should result from this update *) + let elapsed_pdp_st = + Int64.to_int ((occu_pdp_st --- proc_pdp_st) /// rrd.timestep) + in + + (* if we're due one or more PDPs, pre_int is the amount of the + current update interval that will be used in calculating them, and + post_int is the amount left over + this step. If a PDP isn't post is what's left over *) + let pre_int, post_int = + if elapsed_pdp_st > 0 then + let pre = interval -. occu_pdp_age in + (pre, occu_pdp_age) + else + (interval, 0.0) + in + + (* We're now done with the last_updated value, so update it *) + rrd.last_updated <- timestamp ; + + (* Calculate the values we're going to store based on the input data and the type of the DS *) + let v2s = + Array.mapi + (fun i value -> process_ds_value rrd.rrd_dss.(i) value interval new_domid) + values + in + (* Update the PDP accumulators up until the most recent PDP *) + Array.iteri + (fun i value -> + let ds = rrd.rrd_dss.(i) in + if Utils.isnan value then + ds.ds_unknown_sec <- pre_int + else + ds.ds_value <- ds.ds_value +. (pre_int *. value /. interval) + ) + v2s ; + + (* If we've passed a PDP point, we need to update the RRAs *) + if elapsed_pdp_st > 0 then ( + (* Calculate the PDPs for each DS *) + let pdps = + Array.mapi + (fun i ds -> + if interval > ds.ds_mrhb then + nan + else + let raw = + ds.ds_value + /. (Int64.to_float (occu_pdp_st --- proc_pdp_st) + -. ds.ds_unknown_sec + ) + in + (* Apply the transform after the raw value has been calculated *) + let raw = transforms.(i) raw in + (* Make sure the values are not out of bounds after all the processing *) + if raw < ds.ds_min || raw > ds.ds_max then + nan + else + raw + ) + rrd.rrd_dss + in + + rra_update rrd proc_pdp_st elapsed_pdp_st pdps ; + + (* Reset the PDP accumulators *) + Array.iteri + (fun i value -> + let ds = rrd.rrd_dss.(i) in + if Utils.isnan value then ( + ds.ds_value <- 0.0 ; + ds.ds_unknown_sec <- post_int + ) else ( + ds.ds_value <- post_int *. value /. interval ; + ds.ds_unknown_sec <- 0.0 + ) + ) + v2s + ) + +(** Update the rrd with named values rather than just an ordered array *) +let ds_update_named rrd timestamp ~new_domid valuesandtransforms = + let valuesandtransforms = + valuesandtransforms |> List.to_seq |> StringMap.of_seq + in + let get_value_and_transform {ds_name; _} = + Option.value ~default:(VT_Unknown, Fun.id) + (StringMap.find_opt ds_name valuesandtransforms) + in + let ds_values, ds_transforms = + Array.split (Array.map get_value_and_transform rrd.rrd_dss) + in + ds_update rrd timestamp ds_values ds_transforms new_domid + +(** Get registered DS names *) +let ds_names rrd = Array.to_list (Array.map (fun ds -> ds.ds_name) rrd.rrd_dss) + +(** create an rra structure *) +let rra_create cf row_cnt pdp_cnt xff = + { + rra_cf= cf + ; rra_row_cnt= row_cnt + ; rra_pdp_cnt= pdp_cnt + ; rra_xff= xff + ; rra_data= + [||] + (* defer creation of the data until we know how many dss we're storing *) + ; rra_cdps= + [||] + (* defer creation of the data until we know how many dss we're storing *) + ; rra_updatehook= None (* DEPRECATED *) + } + +let ds_create name ty ?(min = neg_infinity) ?(max = infinity) ?(mrhb = infinity) + init = + { + ds_name= name + ; ds_ty= ty + ; ds_min= min + ; ds_max= max + ; ds_mrhb= mrhb + ; ds_last= init + ; ds_value= 0.0 + ; ds_unknown_sec= 0.0 + } + +let rrd_create dss rras timestep inittime = + (* Use the standard update routines to initialise everything to correct values *) + let rrd = + { + last_updated= 0.0 + ; timestep + ; rrd_dss= dss + ; rrd_rras= + Array.map + (fun rra -> + { + rra with + rra_data= + Array.init (Array.length dss) (fun i -> + let ds = dss.(i) in + Fring.make rra.rra_row_cnt nan ds.ds_min ds.ds_max + ) + ; rra_cdps= + Array.init (Array.length dss) (fun i -> + let ds = dss.(i) in + let cdp_init = cf_init_value rra.rra_cf ds in + {cdp_value= cdp_init; cdp_unknown_pdps= 0} + ) + } + ) + rras + } + in + let values = Array.map (fun ds -> ds.ds_last) dss in + let transforms = Array.make (Array.length values) (fun x -> x) in + ds_update rrd inittime values transforms true ; + rrd + +(** Add in a new DS into a pre-existing RRD. Preserves data of all the other archives + and fills the new one full of NaNs. Note that this doesn't fill in the CDP values + correctly at the moment! + + @param now = Unix.gettimeofday () +*) + +let rrd_add_ds rrd now newds = + if List.mem newds.ds_name (ds_names rrd) then + rrd + else + let npdps = Int64.of_float now /// rrd.timestep in + { + rrd with + rrd_dss= Array.append rrd.rrd_dss [|newds|] + ; rrd_rras= + Array.map + (fun rra -> + let cdp_init = cf_init_value rra.rra_cf newds in + let fring = + Fring.make rra.rra_row_cnt nan newds.ds_min newds.ds_max + in + let nunknowns = + Int64.to_int (Int64.rem npdps (Int64.of_int rra.rra_pdp_cnt)) + in + { + rra with + rra_data= Array.append rra.rra_data [|fring|] + ; rra_cdps= + Array.append rra.rra_cdps + [|{cdp_value= cdp_init; cdp_unknown_pdps= nunknowns}|] + } + ) + rrd.rrd_rras + } + +(** Remove the named DS from an RRD. Removes all of the data associated with it, too *) +let rrd_remove_ds rrd ds_name = + let n = + Utils.array_index ds_name (Array.map (fun ds -> ds.ds_name) rrd.rrd_dss) + in + if n = -1 then + raise (Invalid_data_source ds_name) + else + { + rrd with + rrd_dss= Utils.array_remove n rrd.rrd_dss + ; rrd_rras= + Array.map + (fun rra -> + { + rra with + rra_data= Utils.array_remove n rra.rra_data + ; rra_cdps= Utils.array_remove n rra.rra_cdps + } + ) + rrd.rrd_rras + } + +(** Find the RRA with a particular CF that contains a particular start + time, and also has a minimum pdp_cnt. If it can't find an + appropriate one, either return the RRA with the correct CF that + has the most ancient data, or raise No_RRA_Available if there's + not archive with the correct CF. Assumes the RRAs are stored in + increasing time-length *) +let find_best_rras rrd pdp_interval cf start = + let rras = + match cf with + | Some realcf -> + List.filter (fun rra -> rra.rra_cf = realcf) (Array.to_list rrd.rrd_rras) + | None -> + Array.to_list rrd.rrd_rras + in + if rras = [] then raise No_RRA_Available ; + let last_pdp_time, _age = get_times rrd.last_updated rrd.timestep in + let contains_time t rra = + let lasttime = + last_pdp_time + --- (rrd.timestep *** Int64.of_int (rra.rra_row_cnt * rra.rra_pdp_cnt)) + in + rra.rra_pdp_cnt >= pdp_interval && t > lasttime + in + try + let first_ok_rra = List.find (contains_time start) rras in + let pdp_cnt = first_ok_rra.rra_pdp_cnt in + let row_cnt = first_ok_rra.rra_row_cnt in + let ok_rras = + List.filter + (fun rra -> rra.rra_row_cnt = row_cnt && rra.rra_pdp_cnt = pdp_cnt) + rras + in + ok_rras + with _ -> + let rra = List.hd (List.rev rras) in + let newstarttime = + 1L + +++ last_pdp_time + --- (rrd.timestep *** Int64.of_int (rra.rra_row_cnt * rra.rra_pdp_cnt)) + in + List.filter (contains_time newstarttime) rras + +(* now = Unix.gettimeofday () *) +let query_named_ds rrd now ds_name cf = + let n = + Utils.array_index ds_name (Array.map (fun ds -> ds.ds_name) rrd.rrd_dss) + in + if n = -1 then + raise (Invalid_data_source ds_name) + else + let rras = find_best_rras rrd 0 (Some cf) (Int64.of_float now) in + match rras with + | [] -> + raise No_RRA_Available + | rra :: _ -> + Fring.peek rra.rra_data.(n) 0 + +(******************************************************************************) +(* Marshalling/Unmarshalling functions *) +(******************************************************************************) + +let from_xml input = + let open Utils.Xmlm_utils in + let read_header i = + ignore (get_el "version" i) ; + let step = get_el "step" i in + let last_update = get_el "lastupdate" i in + (step, last_update) + in + + let read_dss i = + let read_ds i = + read_block "ds" + (fun i -> + let name = get_el "name" i in + let type_ = get_el "type" i in + let min_hb = get_el "minimal_heartbeat" i in + let min = get_el "min" i in + let max = get_el "max" i in + ignore (get_el "last_ds" i) ; + let value = get_el "value" i in + let unknown_sec = get_el "unknown_sec" i in + { + ds_name= name + ; ds_ty= + ( match type_ with + | "GAUGE" -> + Gauge + | "ABSOLUTE" -> + Absolute + | "DERIVE" -> + Derive + | _ -> + failwith "Bad format" + ) + ; ds_mrhb= float_of_string min_hb + ; ds_min= float_of_string min + ; ds_max= float_of_string max + ; ds_last= VT_Unknown + ; (* float_of_string "last_ds"; *) + ds_value= float_of_string value + ; ds_unknown_sec= float_of_string unknown_sec + } + ) + i + in + let dss = read_all "ds" read_ds i [] in + dss + in + + let read_rras dss i = + let read_rra i = + let read_cdp_prep i = + let read_ds i = + read_block "ds" + (fun i -> + ignore (get_el "primary_value" i) ; + ignore (get_el "secondary_value" i) ; + let value = get_el "value" i in + let unknown_datapoints = get_el "unknown_datapoints" i in + { + cdp_value= float_of_string value + ; cdp_unknown_pdps= int_of_string unknown_datapoints + } + ) + i + in + let cdps = + read_block "cdp_prep" (fun i -> read_all "ds" read_ds i []) i + in + cdps + in + let read_database i = + let read_row i = + (* should directly write in fring *) + let row = + read_block "row" + (fun i -> Array.of_list (iter_seq (get_el "v") [] i)) + i + in + row + in + let data = + read_block "database" + (fun i -> Array.of_list (read_all "row" read_row i [])) + i + in + let rows = Array.length data in + let cols = try Array.length data.(0) with _ -> -1 in + let db = + Array.init cols (fun i -> + let ds = List.nth dss i in + Fring.make rows nan ds.ds_min ds.ds_max + ) + in + for i = 0 to cols - 1 do + for j = 0 to rows - 1 do + let value = float_of_string data.(j).(i) in + Fring.push db.(i) value + done + done ; + db + in + let rra = + read_block "rra" + (fun i -> + let cf = get_el "cf" i in + let pdp_cnt = get_el "pdp_per_row" i in + let xff = read_block "params" (fun i -> get_el "xff" i) i in + let cdps = read_cdp_prep i in + let database = read_database i in + { + rra_cf= + ( match cf with + | "AVERAGE" -> + CF_Average + | "MIN" -> + CF_Min + | "MAX" -> + CF_Max + | "LAST" -> + CF_Last + | _ -> + raise Utils.Parse_error + ) + ; rra_row_cnt= Fring.length database.(0) + ; rra_pdp_cnt= int_of_string pdp_cnt + ; rra_xff= float_of_string xff + ; rra_data= database + ; rra_cdps= Array.of_list cdps + ; rra_updatehook= None + } + ) + i + in + rra + in + let rras = read_all "rra" read_rra i [] in + rras + in + + accept (`Dtd None) input ; + read_block "rrd" + (fun i -> + let step, last_update = read_header i in + let dss = read_dss i in + let rras = read_rras dss i in + let rrd = + { + last_updated= float_of_string last_update + ; timestep= Int64.of_string step + ; rrd_dss= Array.of_list dss + ; rrd_rras= Array.of_list rras + } + in + + (* Purge any repeated data sources from the RRD *) + let ds_names = ds_names rrd in + let ds_names_set = Utils.setify ds_names in + let ds_name_counts = + List.map + (fun name -> + let x, _ = List.partition (( = ) name) ds_names in + (name, List.length x) + ) + ds_names_set + in + let removals_required = + List.filter (fun (_, x) -> x > 1) ds_name_counts + in + List.fold_left + (fun rrd (name, n) -> + (* Remove n-1 lots of this data source *) + let rec inner rrd n = + if n = 1 then + rrd + else + inner (rrd_remove_ds rrd name) (n - 1) + in + inner rrd n + ) + rrd removals_required + ) + input + +let xml_to_output rrd output = + (* We use an output channel for Xmlm-compat buffered output. Provided we flush + at the end we should be safe. *) + let tag n fn output = + Xmlm.output output (`El_start (("", n), [])) ; + fn output ; + Xmlm.output output `El_end + in + let data dat output = Xmlm.output output (`Data dat) in + + let do_ds ds output = + tag "ds" + (fun output -> + tag "name" (data ds.ds_name) output ; + tag "type" (data (ds_type_to_string ds.ds_ty)) output ; + tag "minimal_heartbeat" (data (Utils.f_to_s ds.ds_mrhb)) output ; + tag "min" (data (Utils.f_to_s ds.ds_min)) output ; + tag "max" (data (Utils.f_to_s ds.ds_max)) output ; + tag "last_ds" (data (ds_value_to_string ds.ds_last)) output ; + tag "value" (data (Utils.f_to_s ds.ds_value)) output ; + tag "unknown_sec" + (data (Printf.sprintf "%d" (int_of_float ds.ds_unknown_sec))) + output + ) + output + in + + let do_dss dss output = Array.iter (fun ds -> do_ds ds output) dss in + + let do_rra_cdp cdp output = + tag "ds" + (fun output -> + tag "primary_value" (data "0.0") output ; + tag "secondary_value" (data "0.0") output ; + tag "value" (data (Utils.f_to_s cdp.cdp_value)) output ; + tag "unknown_datapoints" + (data (Printf.sprintf "%d" cdp.cdp_unknown_pdps)) + output + ) + output + in + + let do_rra_cdps cdps output = + Array.iter (fun cdp -> do_rra_cdp cdp output) cdps + in + + let do_database rings output = + if Array.length rings = 0 then + () + else + let rows = Fring.length rings.(0) in + let cols = Array.length rings in + for row = 0 to rows - 1 do + tag "row" + (fun output -> + for col = 0 to cols - 1 do + tag "v" + (data (Utils.f_to_s (Fring.peek rings.(col) (rows - row - 1)))) + output + done + ) + output + done + in + + let do_rra rra output = + tag "rra" + (fun output -> + tag "cf" (data (cf_type_to_string rra.rra_cf)) output ; + tag "pdp_per_row" (data (string_of_int rra.rra_pdp_cnt)) output ; + tag "params" (tag "xff" (data (Utils.f_to_s rra.rra_xff))) output ; + tag "cdp_prep" (fun output -> do_rra_cdps rra.rra_cdps output) output ; + tag "database" (fun output -> do_database rra.rra_data output) output + ) + output + in + + let do_rras rras output = Array.iter (fun rra -> do_rra rra output) rras in + + Xmlm.output output (`Dtd None) ; + tag "rrd" + (fun output -> + tag "version" (data "0003") output ; + tag "step" (data (Int64.to_string rrd.timestep)) output ; + tag "lastupdate" + (data (Printf.sprintf "%Ld" (Int64.of_float rrd.last_updated))) + output ; + do_dss rrd.rrd_dss output ; + do_rras rrd.rrd_rras output + ) + output + +module Json = struct + let fmt fmt x = Printf.ksprintf (fun msg -> `String msg) fmt x + + let string x = fmt "%s" x + + let float x = string (Utils.f_to_s x) + + let int x = fmt "%d" x + + let int64 x = fmt "%Ld" x + + let record xs = `Assoc xs + + let array xs = `List xs + + let datasource ds = + record + [ + ("name", string ds.ds_name) + ; ("type", string (ds_type_to_string ds.ds_ty)) + ; ("minimal_heartbeat", float ds.ds_mrhb) + ; ("min", float ds.ds_min) + ; ("max", float ds.ds_max) + ; ("last_ds", string (ds_value_to_string ds.ds_last)) + ; ("value", float ds.ds_value) + ; ("unknown_sec", float ds.ds_unknown_sec) + ] + + let cdp x = + record + [ + ("primary_value", float 0.0) + ; ("secondary_value", float 0.0) + ; ("value", float x.cdp_value) + ; ("unknown_datapoints", int x.cdp_unknown_pdps) + ] + + let get rings rows row col = Fring.peek rings.(col) (rows - row - 1) |> float + + let database = function + | [||] -> + array [] + | rings -> + let rows = Fring.length rings.(0) in + let cols = Array.length rings in + array + @@ Array.to_list + @@ Array.init rows (fun row -> + array + @@ Array.to_list + @@ Array.init cols (fun col -> get rings rows row col) + ) + + let rra x = + record + [ + ("cf", string (cf_type_to_string x.rra_cf)) + ; ("pdp_per_row", int x.rra_pdp_cnt) + ; ("params", record [("xff", float x.rra_xff)]) + ; ( "cdp_prep" + , record [("ds", array @@ List.map cdp @@ Array.to_list x.rra_cdps)] + ) + ; ("database", database x.rra_data) + ] + + let rrd x = + record + [ + ("version", string "0003") + ; ("step", int64 x.timestep) + ; ("lastupdate", float x.last_updated) + ; ("ds", array @@ List.map datasource @@ Array.to_list x.rrd_dss) + ; ("rra", array @@ List.map rra @@ Array.to_list x.rrd_rras) + ] +end + +let json_to_string rrd = Yojson.to_string (Json.rrd rrd) + +module Statefile_latency = struct + type t = {id: string; latency: float option} [@@deriving rpc] +end diff --git a/ocaml/libs/xapi-rrd/lib/rrd_fring.ml b/ocaml/libs/xapi-rrd/lib/rrd_fring.ml new file mode 100644 index 00000000000..456e2a8d0b0 --- /dev/null +++ b/ocaml/libs/xapi-rrd/lib/rrd_fring.ml @@ -0,0 +1,98 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) + +module BoundedFloat = Rrd_utils.BoundedFloat + +type t = { + size: int + ; mutable current: int + ; min: float + ; max: float + ; data: (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t +} + +let make size (init : float) minimum maximum = + let ring = + { + size + ; current= size - 1 + ; min= minimum + ; max= maximum + ; data= Bigarray.Array1.create Bigarray.float32 Bigarray.c_layout size + } + in + let bound = + BoundedFloat.of_float ~minimum ~maximum ~f:BoundedFloat.To_Nan init + in + Bigarray.Array1.fill ring.data @@ BoundedFloat.to_float bound ; + ring + +let copy x = + let y = make x.size nan x.min x.max in + Bigarray.Array1.blit x.data y.data ; + y.current <- x.current ; + y + +let length ring = ring.size + +let push ring (e : float) = + ring.current <- ring.current + 1 ; + if ring.current = ring.size then + ring.current <- 0 ; + let bound = + BoundedFloat.of_float ~minimum:ring.min ~maximum:ring.max + ~f:BoundedFloat.To_Nan e + in + Bigarray.Array1.set ring.data ring.current @@ BoundedFloat.to_float bound + +let peek ring i = + if i >= ring.size then + raise (Invalid_argument "peek: index") ; + let index = + let offset = ring.current - i in + if offset >= 0 then offset else ring.size + offset + in + ring.data.{index} + +let top ring = ring.data.{ring.current} + +let iter_nb ring f nb = + if nb > ring.size then + raise (Invalid_argument "iter_nb: nb") ; + (* FIXME: OPTIMIZE ME with 2 Array.iter ? *) + for i = 0 to nb - 1 do + f (peek ring i) + done + +(* iter directly on all element without using the index *) +let iter f a = + for i = 0 to Bigarray.Array1.dim a - 1 do + f a.{i} + done + +let raw_iter ring f = iter f ring.data + +let iter ring f = iter_nb ring f ring.size + +let get_nb ring nb = + if nb > ring.size then + raise (Invalid_argument "get_nb: nb") ; + let a = Array.make nb (top ring) in + for i = 1 to nb - 1 do + (* FIXME: OPTIMIZE ME with 2 Array.blit *) + a.(i) <- peek ring i + done ; + a + +let get ring = get_nb ring ring.size diff --git a/ocaml/libs/xapi-rrd/lib/rrd_fring.mli b/ocaml/libs/xapi-rrd/lib/rrd_fring.mli new file mode 100644 index 00000000000..7da606a3663 --- /dev/null +++ b/ocaml/libs/xapi-rrd/lib/rrd_fring.mli @@ -0,0 +1,54 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) +(** Ring structures for RRAs + The values in the structures are bound to a range *) + +module BoundedFloat = Rrd_utils.BoundedFloat + +type t + +val make : int -> float -> float -> float -> t +(** create a ring structure with [size] record; records initialised to [init] + @param size number of elements the ring holds (constant) + @param init value all the elements are initialized to + *) + +val copy : t -> t +(** create a duplicate ring structure *) + +val length : t -> int +(** length (size) of the ring, it is constant *) + +val push : t -> float -> unit +(** push into the ring one element *) + +val peek : t -> int -> float +(** get the i{^th} old element from the ring *) + +val top : t -> float +(** get the top element of the ring *) + +val iter_nb : t -> (float -> unit) -> int -> unit +(** iterate over nb element of the ring, starting from the top *) + +val raw_iter : t -> (float -> unit) -> unit + +val iter : t -> (float -> unit) -> unit +(** iterate over all elements of the ring, starting from the top *) + +val get_nb : t -> int -> float array +(** get array of latest [nb] value *) + +val get : t -> float array +(** get an array with all the values in the ring *) diff --git a/ocaml/libs/xapi-rrd/lib/rrd_timescales.ml b/ocaml/libs/xapi-rrd/lib/rrd_timescales.ml new file mode 100644 index 00000000000..2432cd1857d --- /dev/null +++ b/ocaml/libs/xapi-rrd/lib/rrd_timescales.ml @@ -0,0 +1,37 @@ +(* + * Copyright (C) 2015 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) +(* + * Timescales: this allows an RRD server to advertise which Timescales + * are available, to avoid clients having to already know or guess. + *) + +type t = {name: string; num_intervals: int; interval_in_steps: int} +[@@deriving rpc] + +type ts = t list [@@deriving rpc] + +let make ~name ~num_intervals ~interval_in_steps () = + {name; num_intervals; interval_in_steps} + +let name_of t = t.name + +let to_span t = t.num_intervals * t.interval_in_steps * 5 + +(* ??? *) + +let interval_to_span t = t.interval_in_steps * 5 + +let to_json ts = Jsonrpc.to_string (rpc_of_ts ts) + +let of_json txt = ts_of_rpc (Jsonrpc.of_string txt) diff --git a/ocaml/libs/xapi-rrd/lib/rrd_timescales.mli b/ocaml/libs/xapi-rrd/lib/rrd_timescales.mli new file mode 100644 index 00000000000..aa2ba1646f6 --- /dev/null +++ b/ocaml/libs/xapi-rrd/lib/rrd_timescales.mli @@ -0,0 +1,35 @@ +(* + * Copyright (C) 2015 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) +(* + * Timescales: this allows an RRD server to advertise which Timescales + * are available, to avoid clients having to already know or guess. + *) + +type t = {name: string; num_intervals: int; interval_in_steps: int} + +val make : + name:string -> num_intervals:int -> interval_in_steps:int -> unit -> t + +val name_of : t -> string + +val to_span : t -> int +(** Total length of time covered by the archive *) + +val interval_to_span : t -> int +(** Length of time in one interval (clients requesting updates should poll at + most every interval) *) + +val to_json : t list -> string + +val of_json : string -> t list diff --git a/ocaml/libs/xapi-rrd/lib/rrd_updates.ml b/ocaml/libs/xapi-rrd/lib/rrd_updates.ml new file mode 100644 index 00000000000..e1e3a98f88d --- /dev/null +++ b/ocaml/libs/xapi-rrd/lib/rrd_updates.ml @@ -0,0 +1,311 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) +(* + * Updates module: this module deals with the updates type, which + * represents a delta between an RRD's past and current state. + *) +(** + * @group Performance Monitoring +*) + +open Rrd + +type row = {time: int64; row_data: float array} + +type t = { + start_time: int64 + ; step: int64 + ; end_time: int64 + ; legend: string array + ; data: row array +} + +(** Debugging only *) +let string_of t = + let leg_string = + Printf.sprintf "[%s]" + (String.concat ";" + (List.map (fun l -> Printf.sprintf "\"%s\"" l) (Array.to_list t.legend)) + ) + in + + let data_string = + Printf.sprintf "[|%s|]" + (String.concat ";\n" + (List.map + (fun row -> + Printf.sprintf "{time=%Ld; row_data=[|%s|]}" row.time + (String.concat "; " + (List.map + (fun f -> Printf.sprintf "%0.4f" f) + (Array.to_list row.row_data) + ) + ) + ) + (Array.to_list t.data) + ) + ) + in + + Printf.sprintf + "start_time:\t%Ld\nstep:\t\t%Ld\nend_time:\t%Ld\nlegend:\t\t%s\ndata:\n%s\n" + t.start_time t.step t.end_time leg_string data_string + +(* Helper utility - use create_multi instead *) +let create rra_timestep rras first_rra last_cdp_time first_cdp_time start + legends = + let rec do_data i accum = + let time = Int64.(sub last_cdp_time (mul (of_int i) rra_timestep)) in + if time < start || i >= first_rra.rra_row_cnt then + List.rev accum + else + let extract_row rra = + List.map (fun ring -> Fring.peek ring i) (Array.to_list rra.rra_data) + in + let values = List.concat (List.map extract_row rras) in + do_data (i + 1) ({time; row_data= Array.of_list values} :: accum) + in + + let data = Array.of_list (do_data 0 []) in + + { + start_time= first_cdp_time + ; step= rra_timestep + ; end_time= last_cdp_time + ; legend= legends + ; data + } + +let xml_of t output = + let tag tag next () = + Xmlm.output output (`El_start (("", tag), [])) ; + List.iter (fun x -> x ()) next ; + Xmlm.output output `El_end + in + let data dat () = Xmlm.output output (`Data dat) in + + let xml_of_row row = + let values = + List.map + (fun v -> tag "v" [data (Utils.f_to_s v)]) + (Array.to_list row.row_data) + in + tag "row" (tag "t" [data (Printf.sprintf "%Ld" row.time)] :: values) + in + + let rows = List.map xml_of_row (Array.to_list t.data) in + let mydata = tag "data" rows in + + let meta = + tag "meta" + [ + tag "start" [data (Printf.sprintf "%Ld" t.start_time)] + ; tag "step" [data (Printf.sprintf "%Ld" t.step)] + ; tag "end" [data (Printf.sprintf "%Ld" t.end_time)] + ; tag "rows" [data (Printf.sprintf "%d" (List.length rows))] + ; tag "columns" [data (Printf.sprintf "%d" (Array.length t.legend))] + ; tag "legend" + (List.map (fun x -> tag "entry" [data x]) (Array.to_list t.legend)) + ] + in + + Xmlm.output output (`Dtd None) ; + tag "xport" [meta; mydata] () + +let of_xml input = + let open Utils.Xmlm_utils in + let read_row i = + read_block "row" + (fun i -> + let time = get_el "t" i in + let values = read_all "v" (get_el "v") i [] in + { + time= Int64.of_string time + ; row_data= Array.of_list (List.map (fun v -> float_of_string v) values) + } + ) + i + in + + let read_data i = Array.of_list (read_all "row" read_row i []) in + + let read_meta i = + read_block "meta" + (fun i -> + let start_time = get_el "start" i |> Int64.of_string in + let step = get_el "step" i |> Int64.of_string in + let end_time = get_el "end" i |> Int64.of_string in + let rows = get_el "rows" i |> int_of_string in + let columns = get_el "columns" i |> int_of_string in + let legend = + read_block "legend" + (fun i -> read_all "entry" (get_el "entry") i []) + i + |> Array.of_list + in + let data = [||] in + let meta = {start_time; step; end_time; legend; data} in + (meta, rows, columns) + ) + i + in + + accept (`Dtd None) input ; + read_block "xport" + (fun i -> + let meta, _, _ = read_meta i in + let data = read_block "data" read_data i in + {meta with data} + ) + input + +let json_of_t t = + let open Json in + let map_to_list f arr = Array.to_seq arr |> Seq.map f |> List.of_seq in + let data_record row = + record + [ + ("t", int64 row.time) + ; ( "values" + , array (map_to_list (fun x -> string (Utils.f_to_s x)) row.row_data) + ) + ] + in + let meta = + record + [ + ( "meta" + , record + [ + ("start", int64 t.start_time) + ; ("step", int64 t.step) + ; ("end", int64 t.end_time) + ; ("rows", int (Array.length t.data)) + ; ("columns", int (Array.length t.legend)) + ; ("legend", array (map_to_list string t.legend)) + ; ("data", array (map_to_list data_record t.data)) + ] + ) + ] + in + Yojson.to_string meta + +(** Export data from a bunch of rrds. Specify a prefix per rrd to be + put onto legend. Note that each rrd *must* have the same timestep + and have been updated at the same time, and *must* have + homogeneous rras too. If not, those that dont look like the 1st + one will be silently dropped. The export format is the rrdtool + 'xport' format. *) + +let create_multi prefixandrrds start interval cfopt = + let timestep, last_updated = + match prefixandrrds with + | (_, r) :: _ -> + (r.timestep, r.last_updated) + | [] -> + raise No_RRA_Available + in + + let pdp_interval = Int64.to_int (Int64.div interval timestep) in + + (* Sanity - make sure the RRDs are homogeneous *) + let prefixandrrds = + List.filter (fun (_prefix, rrd) -> rrd.timestep = timestep) prefixandrrds + in + + (* Treat -ve start values as relative to the latest update. *) + let start = + prefixandrrds + |> List.map (fun (_, rrd) -> + if start < 0L then + Int64.(add start (of_float rrd.last_updated)) + else + start + ) + |> List.fold_left min Int64.max_int + in + + let rras = + List.map + (fun (_prefix, rrd) -> + (* Find the rrds that satisfy the requirements *) + Rrd.find_best_rras rrd pdp_interval cfopt start + ) + prefixandrrds + in + let first_rra = + rras |> List.find_opt (fun x -> x <> []) |> function + | Some (x :: _) -> + x + | Some [] | None -> + raise No_RRA_Available + in + let rras = + let only_valid_pdp_and_num_rows rra = + rra.rra_pdp_cnt = first_rra.rra_pdp_cnt + && rra.rra_row_cnt = first_rra.rra_row_cnt + in + List.map (List.filter only_valid_pdp_and_num_rows) rras + in + + let legends = + Array.concat + (List.map2 + (fun (prefix, rrd) rras -> + let ds_legends = + Array.map (fun ds -> prefix ^ ds.ds_name) rrd.rrd_dss + in + let ds_legends_with_cf_prefix = + Array.concat + (List.map + (fun rra -> + Array.map + (fun name -> cf_type_to_string rra.rra_cf ^ ":" ^ name) + ds_legends + ) + rras + ) + in + ds_legends_with_cf_prefix + ) + prefixandrrds rras + ) + in + + let rras = List.flatten rras in + + (* The following timestep is that of the archive *) + let rra_timestep = Int64.mul timestep (Int64.of_int first_rra.rra_pdp_cnt) in + + (* Get the last and first times of the CDPs to be returned *) + let last_cdp_time, _age = get_times last_updated rra_timestep in + let first_cdp_time_minus_one, _age = + get_times (Int64.to_float start) rra_timestep + in + let first_cdp_time = Int64.add first_cdp_time_minus_one rra_timestep in + + create rra_timestep rras first_rra last_cdp_time first_cdp_time start legends + +let export ?(json = false) prefixandrrds start interval cfopt = + let t = create_multi prefixandrrds start interval cfopt in + if json then + json_of_t t + else + let buffer = Buffer.create 10 in + let output = Xmlm.make_output (`Buffer buffer) in + xml_of t output ; Buffer.contents buffer + +let of_string s = + let input = Xmlm.make_input (`String (0, s)) in + of_xml input diff --git a/ocaml/libs/xapi-rrd/lib/rrd_utils.ml b/ocaml/libs/xapi-rrd/lib/rrd_utils.ml new file mode 100644 index 00000000000..c0863d0175f --- /dev/null +++ b/ocaml/libs/xapi-rrd/lib/rrd_utils.ml @@ -0,0 +1,139 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) + +(* Utils, some from stdext originally *) + +(** + * @group Performance Monitoring +*) + +exception Parse_error + +module BoundedFloat : sig + type t = private float + + type entry_fun = Clamp | To_Nan + + val of_float : minimum:float -> maximum:float -> f:entry_fun -> float -> t + + val to_float : t -> float +end = struct + type t = float + + type entry_fun = Clamp | To_Nan + + let of_float ~minimum ~maximum ~f x = + match f with + | Clamp -> + min maximum (max minimum x) + | To_Nan when x < minimum || x > maximum -> + nan + | To_Nan -> + x + + let to_float x = x +end + +let isnan x = match classify_float x with FP_nan -> true | _ -> false + +let array_index e a = + let len = Array.length a in + let rec check i = + if len <= i then + -1 + else if a.(i) = e then + i + else + check (i + 1) + in + check 0 + +let array_remove n a = + Array.append (Array.sub a 0 n) (Array.sub a (n + 1) (Array.length a - n - 1)) + +let filter_map f list = + let rec inner acc l = + match l with + | [] -> + List.rev acc + | x :: xs -> + let acc = match f x with Some res -> res :: acc | None -> acc in + inner acc xs + in + inner [] list + +let rec setify = function + | [] -> + [] + | x :: xs -> + if List.mem x xs then setify xs else x :: setify xs + +(** C# and JS representation of special floats are 'NaN' and 'Infinity' which + are different from ocaml's native representation. Caml is fortunately more + forgiving when doing a float_of_string, and can cope with these forms, so + we make a generic float_to_string function here *) +let f_to_s f = + match classify_float f with + | FP_normal | FP_subnormal -> + Printf.sprintf "%0.5g" f + | FP_nan -> + "NaN" + | FP_infinite -> + if f > 0.0 then "Infinity" else "-Infinity" + | FP_zero -> + "0.0" + +module Xmlm_utils = struct + let tag n = (("", n), []) + + let start_tag n = `El_start (tag n) + + let accept s i = if Xmlm.input i = s then () else raise Parse_error + + let rec iter_seq el acc i = + match Xmlm.peek i with + | `El_start _ -> + iter_seq el (el i :: acc) i + | `El_end -> + List.rev acc + | _ -> + raise Parse_error + + let get_el n i = + if Xmlm.input i = start_tag n then ( + let d = + match Xmlm.peek i with + | `Data d -> + ignore (Xmlm.input i) ; + d + | `El_end -> + "" + | _ -> + raise Parse_error + in + accept `El_end i ; d + ) else + raise Parse_error + + let rec read_all t read_f i acc = + if Xmlm.peek i = start_tag t then + read_all t read_f i (read_f i :: acc) + else + List.rev acc + + let read_block t f i = + accept (start_tag t) i ; + let res = f i in + accept `El_end i ; res +end diff --git a/ocaml/libs/xapi-rrd/lib_test/crowbar_tests.ml b/ocaml/libs/xapi-rrd/lib_test/crowbar_tests.ml new file mode 100644 index 00000000000..2aecd81d030 --- /dev/null +++ b/ocaml/libs/xapi-rrd/lib_test/crowbar_tests.ml @@ -0,0 +1,102 @@ +module Fring = Rrd.Fring +module Cb = Crowbar + +(* cast double-precision floats to single-precision and return them in + ascending order *) +let castd2s x y = + let _data = Bigarray.Array1.create Bigarray.float32 Bigarray.c_layout 1 in + _data.{0} <- x ; + let x = _data.{0} in + _data.{0} <- y ; + let y = _data.{0} in + if x > y then + (y, x) + else + (x, y) + +let in_range min max values = + let between value = + if Rrd.Utils.isnan value then + true + else if min > value then + Cb.fail (Printf.sprintf "value (%f) lower than min (%f); " value min) + else if max < value then + Cb.fail (Printf.sprintf "value (%f) higher than max (%f); " value max) + else + true + in + Cb.check @@ Array.for_all between values + +(* Checks if all the values in the archives are within the limits set by the data sources + * Each archive (RRA) has a ring for each datasource (DS) *) +let test_ranges rrd = + let open Rrd in + let in_range_fring ds fring = + in_range ds.ds_min ds.ds_max (Fring.get fring) + in + let in_range_rra dss rra = Array.iter2 in_range_fring dss rra.rra_data in + Array.iter (in_range_rra rrd.rrd_dss) rrd.rrd_rras + +let same_input_type vf vf' = + let open Rrd in + match vf vf' with + | VT_Unknown, VT_Unknown -> + true + | VT_Int64 _, VT_Int64 _ -> + true + | VT_Float _, VT_Float _ -> + true + | _ -> + false + +let cf = + Cb.choose + [ + Cb.const Rrd.CF_Average + ; Cb.const Rrd.CF_Min + ; Cb.const Rrd.CF_Max + ; Cb.const Rrd.CF_Last + ] + +let rra = + Cb.map [cf] (fun consolidation -> Rrd.rra_create consolidation 10 1 0.5) + +let ds_value = + Cb.choose + [Cb.const Rrd.VT_Unknown; Cb.map Cb.[int64] (fun v -> Rrd.VT_Int64 v)] + +(* Cast generated floats for min and max values to single-precision. + This is done because all values that get into the RRAs get converted + to single precision as well. In the case that one of these two values + cannot be represented with single-recision the values will clamp to + be infinity, leading to a comparison where the clamped value is out of range. + This is not an issue when normally running as there are no data sources which + such outrageous limits. +*) +let ds = + let open Rrd in + let ds_type = Cb.(choose [const Derive; const Absolute; const Gauge]) in + Cb.( + map [ds_value; float; float; ds_type] (fun v x y typ -> + let min, max = castd2s x y in + ds_create (ds_type_to_string typ) ~min ~max typ v + ) + ) + +let rrd = + Cb.(map [list1 int64; rra; ds]) (fun values rra ds -> + let open Rrd in + let init_time = 0. in + + let rrd = rrd_create [|ds|] [|rra|] 5L init_time in + + List.iteri + (fun i v -> + let t = 5. *. (init_time +. float_of_int i) in + ds_update rrd t [|VT_Int64 v|] [|Fun.id|] (i = 0) + ) + values ; + rrd + ) + +let () = Cb.add_test ~name:"Out-of-bounds rates in archives" [rrd] test_ranges diff --git a/ocaml/libs/xapi-rrd/lib_test/dune b/ocaml/libs/xapi-rrd/lib_test/dune new file mode 100644 index 00000000000..2b1a00908bf --- /dev/null +++ b/ocaml/libs/xapi-rrd/lib_test/dune @@ -0,0 +1,23 @@ +(test + (name unit_tests) + (modules unit_tests) + (deps (source_tree test_data)) + (libraries + bigarray + alcotest + unix + xapi-rrd + xapi-stdext-unix + ) +) + +(test + (name crowbar_tests) + (modules crowbar_tests) + (libraries + bigarray + crowbar + unix + xapi-rrd + ) +) diff --git a/ocaml/libs/xapi-rrd/lib_test/test_data/flip_flop.xml b/ocaml/libs/xapi-rrd/lib_test/test_data/flip_flop.xml new file mode 100644 index 00000000000..8e368ed41b7 --- /dev/null +++ b/ocaml/libs/xapi-rrd/lib_test/test_data/flip_flop.xml @@ -0,0 +1,2 @@ + +00035100flip_flopDERIVEInfinity0Infinity00.00AVERAGE10.50000.00.00.00NaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaN0.01.0000-3.00003.0000-5.00005.0000-7.00007.0000-9.00009.0000-11.000011.0000-13.000013.0000-15.000015.0000-17.000017.0000-19.000019.0000MIN10.50000.00.019.00000NaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaN0.01.0000-3.0000-3.0000-5.0000-5.0000-7.0000-7.0000-9.0000-9.0000-11.0000-11.0000-13.0000-13.0000-15.0000-15.0000-17.0000-17.0000-19.0000-19.0000MAX10.50000.00.019.00000NaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaNNaN0.01.00001.00003.00003.00005.00005.00007.00007.00009.00009.000011.000011.000013.000013.000015.000015.000017.000017.000019.0000 diff --git a/ocaml/libs/xapi-rrd/lib_test/unit_tests.ml b/ocaml/libs/xapi-rrd/lib_test/unit_tests.ml new file mode 100644 index 00000000000..d1938b68a42 --- /dev/null +++ b/ocaml/libs/xapi-rrd/lib_test/unit_tests.ml @@ -0,0 +1,381 @@ +open Rrd + +(* pick between absolute or relative tolerance of a number *) +let tolerance x = max 1e-4 (abs_float x *. 1e-12) + +let compare_float message x y = + Alcotest.(check @@ float @@ tolerance x) message x y + +let assert_ds_equal d1 d2 = + Alcotest.(check string) __LOC__ d1.ds_name d2.ds_name ; + assert (d1.ds_ty = d2.ds_ty) ; + compare_float __LOC__ d1.ds_min d2.ds_min ; + compare_float __LOC__ d1.ds_max d2.ds_max ; + compare_float __LOC__ d1.ds_mrhb d2.ds_mrhb ; + compare_float __LOC__ d1.ds_value d2.ds_value ; + compare_float __LOC__ d1.ds_unknown_sec d2.ds_unknown_sec + +let assert_dss_equal d1s d2s = + let d1s = Array.to_list d1s in + let d2s = Array.to_list d2s in + List.iter2 assert_ds_equal d1s d2s + +let assert_cdp_prep_equal c1 c2 = + compare_float __LOC__ c1.cdp_value c2.cdp_value ; + Alcotest.(check int) __LOC__ c1.cdp_unknown_pdps c2.cdp_unknown_pdps + +let assert_fring_equal f1 f2 = + for i = 0 to Fring.length f1 - 1 do + let peek1 = Fring.peek f1 i in + let peek2 = Fring.peek f2 i in + let msg = Printf.sprintf "Fring value must match: %f, %f" peek1 peek2 in + Alcotest.(check @@ float @@ tolerance peek1) msg peek1 peek2 + done + +let assert_rra_equal a1 a2 = + assert (a1.rra_cf = a2.rra_cf) ; + Alcotest.(check int) __LOC__ a1.rra_row_cnt a2.rra_row_cnt ; + Alcotest.(check int) __LOC__ a1.rra_pdp_cnt a2.rra_pdp_cnt ; + compare_float __LOC__ a1.rra_xff a2.rra_xff ; + List.iter2 assert_cdp_prep_equal + (Array.to_list a1.rra_cdps) + (Array.to_list a2.rra_cdps) ; + List.iter2 assert_fring_equal + (Array.to_list a1.rra_data) + (Array.to_list a2.rra_data) + +let assert_rras_equal a1s a2s = + List.iter2 assert_rra_equal (Array.to_list a1s) (Array.to_list a2s) + +let assert_rrds_equal r1 r2 = + compare_float __LOC__ r1.last_updated r2.last_updated ; + Alcotest.(check int64) __LOC__ r1.timestep r2.timestep ; + assert_dss_equal r1.rrd_dss r2.rrd_dss ; + assert_rras_equal r1.rrd_rras r2.rrd_rras + +let in_range min max values = + let between value = + if not (Utils.isnan value) then ( + Alcotest.(check bool) + (Printf.sprintf "value (%f) higher than min (%f); " value min) + true (min <= value) ; + Alcotest.(check bool) + (Printf.sprintf "value (%f) ≤ max (%f); " value max) + true (max >= value) + ) + in + List.iter between values + +let fring_to_list fring = Array.to_list @@ Fring.get fring + +(* Checks if all the values in the archives are within the limits set by the data sources + * Each archive (RRA) has a ring for each datasource (DS) *) +let test_ranges rrd () = + let in_range_fring ds fring = + in_range ds.ds_min ds.ds_max (fring_to_list fring) + in + let in_range_rra dss rra = + List.iter2 in_range_fring dss (Array.to_list rra.rra_data) + in + let range_is_not_empty ds = + Alcotest.(check bool) + (Printf.sprintf "min (%f) < max (%f); " ds.ds_min ds.ds_max) + true (ds.ds_min < ds.ds_max) + in + + Array.iter range_is_not_empty rrd.rrd_dss ; + List.iter + (in_range_rra @@ Array.to_list rrd.rrd_dss) + (Array.to_list rrd.rrd_rras) + +let test_marshall rrd ~json () = + ignore + ( if json then + Rrd.json_to_string rrd + else + let out = Buffer.create 2048 in + Rrd.xml_to_output rrd (Xmlm.make_output (`Buffer out)) ; + Buffer.contents out + ) + +let test_marshall_unmarshall rrd () = + let out = Buffer.create 2048 in + Rrd.xml_to_output rrd (Xmlm.make_output (`Buffer out)) ; + let contents = Buffer.contents out in + let xml = Xmlm.make_input (`String (0, contents)) in + let rrd' = Rrd.from_xml xml in + assert_rrds_equal rrd rrd' + +let test_export rrd () = + let check_same_as_rras (updates : Rrd_updates.row array) (rras : Rrd.rra array) + = + let cf_count = Array.length rras in + for i = 0 to cf_count - 1 do + (* consolidation functions *) + for j = 0 to Array.length rras.(0).Rrd.rra_data - 1 do + (* datasources *) + for k = 0 to Rrd_fring.length rras.(0).Rrd.rra_data.(0) - 1 do + (* time datapoints *) + let update_value = + updates.(k).Rrd_updates.row_data.(i + (j * cf_count)) + in + let rra_value = Rrd_fring.peek rras.(i).Rrd.rra_data.(j) k in + compare_float + (Printf.sprintf "CF: %d Datasource: %d datapoint: %d " i j k) + update_value rra_value + done + done + done + in + + let updates = Rrd_updates.(of_string @@ export [("", rrd)] 0L 5L None) in + check_same_as_rras updates.Rrd_updates.data rrd.rrd_rras + +let test_length_invariants rrd () = + let check_length_of_fring dss (frings : Rrd_fring.t array) = + Alcotest.(check int) + (Printf.sprintf + "Number of elements in Datasource (%d) must be the same as Frings in \ + a RRA (%d)" + (Array.length dss) (Array.length frings) + ) + (Array.length dss) (Array.length frings) + in + let check_length dss rra = check_length_of_fring dss rra.rra_data in + Array.iter (check_length rrd.rrd_dss) rrd.rrd_rras + +let gauge_rrd = + let rra = rra_create CF_Average 100 1 0.5 in + let rra2 = rra_create CF_Average 100 10 0.5 in + let rra3 = rra_create CF_Average 100 100 0.5 in + let rra4 = rra_create CF_Average 100 1000 0.5 in + let ds = ds_create "foo" Gauge ~mrhb:10.0 (VT_Float 0.0) in + let ds2 = ds_create "bar" Gauge ~mrhb:10.0 (VT_Float 0.0) in + let ds3 = ds_create "baz" Gauge ~mrhb:10.0 (VT_Float 0.0) in + let ds4 = ds_create "boo" Gauge ~mrhb:10.0 (VT_Float 0.0) in + let rrd = + rrd_create [|ds; ds2; ds3; ds4|] [|rra; rra2; rra3; rra4|] 1L 1000000000.0 + in + let id x = x in + for i = 1 to 100000 do + let t = 1000000000.0 +. (0.7 *. float_of_int i) in + let v1 = VT_Float (0.5 +. (0.5 *. sin (t /. 10.0))) in + let v2 = VT_Float (1.5 +. (0.5 *. cos (t /. 80.0))) in + let v3 = VT_Float (3.5 +. (0.5 *. sin (t /. 700.0))) in + let v4 = VT_Float (6.5 +. (0.5 *. cos (t /. 5000.0))) in + ds_update rrd t [|v1; v2; v3; v4|] [|id; id; id; id|] false + done ; + rrd + +let of_file filename = + let body = Xapi_stdext_unix.Unixext.string_of_file filename in + let input = Xmlm.make_input (`String (0, body)) in + Rrd.from_xml input + +(* Used to generate flip_flop.xml for test_ca_325844, + * then gets edited manually to set min to 0 *) +let deserialize_verify_rrd = + let init_time = 0. in + + let rra1 = rra_create CF_Average 100 1 0.5 in + let rra2 = rra_create CF_Min 100 1 0.5 in + let rra3 = rra_create CF_Max 100 1 0.5 in + let ds = ds_create "flip_flop" Derive (VT_Int64 0L) in + + let rrd = rrd_create [|ds|] [|rra1; rra2; rra3|] 5L init_time in + + let id x = x in + for i = 1 to 100 do + let t = init_time +. float_of_int i in + let t64 = Int64.of_float t in + let v = VT_Int64 Int64.(mul t64 (mul (-1L) (rem t64 2L))) in + ds_update rrd t [|v|] [|id|] false + done ; + rrd + +let ca_322008_rrd = + let init_time = 0. in + + let rra1 = rra_create CF_Average 100 1 0.5 in + let rra2 = rra_create CF_Min 100 1 0.5 in + let rra3 = rra_create CF_Max 100 1 0.5 in + let ds = ds_create "even or zero" Derive ~min:0. (VT_Int64 0L) in + + let rrd = rrd_create [|ds|] [|rra1; rra2; rra3|] 5L init_time in + + let id x = x in + + for i = 1 to 100000 do + let t = init_time +. float_of_int i in + let t64 = Int64.of_float t in + let v = VT_Int64 (Int64.mul t64 (Int64.rem t64 2L)) in + ds_update rrd t [|v|] [|id|] false + done ; + rrd + +let ca_329043_rrd_1 = + let init_time = 0. in + + let rra1 = rra_create CF_Average 3 1 0.5 in + let rra2 = rra_create CF_Min 3 1 0.5 in + let rra3 = rra_create CF_Max 3 1 0.5 in + let ds = ds_create "derive_with_min" ~min:0. ~max:1. Derive VT_Unknown in + + let rrd = rrd_create [|ds|] [|rra1; rra2; rra3|] 5L init_time in + + let id x = x in + + let time_value_of_i i = + let t = 5. *. (init_time +. float_of_int i) in + if i = 1 then + (t, VT_Int64 0L) + else + (t, VT_Int64 Int64.(of_float t)) + in + for i = 0 to 4 do + let t, v = time_value_of_i i in + ds_update rrd t [|v|] [|id|] (i = 0) + done ; + rrd + +let create_rrd ?(rows = 2) values min max = + let init_time = 0. in + + let rra1 = rra_create CF_Average rows 10 0.5 in + let rra2 = rra_create CF_Min rows 10 0.5 in + let rra3 = rra_create CF_Max rows 10 0.5 in + let rra4 = rra_create CF_Last rows 10 0.5 in + let ds1 = ds_create "derive" ~min ~max Derive VT_Unknown in + let ds2 = ds_create "absolute" ~min ~max Derive VT_Unknown in + let ds3 = ds_create "gauge" ~min ~max Derive VT_Unknown in + + let rrd = + rrd_create [|ds1; ds2; ds3|] [|rra1; rra2; rra3; rra4|] 5L init_time + in + + let id x = x in + + List.iteri + (fun i v -> + let t = 5. *. (init_time +. float_of_int i) in + ds_update rrd t [|VT_Int64 v|] [|id; id; id; id|] (i = 0) + ) + values ; + rrd + +let ca_329043_rrd_2 = + create_rrd + [-3710420213458133667L; -4382108469022348614L] + (-115833951388699606673086965578224992861890232359671476890007240704.000000) + (-13815257.710330) + +let ca_329813_rrd = + let rrd = create_rrd [0L; 5L; 10L] 0. 1. in + let new_ds = ds_create "new!" Derive VT_Unknown in + Rrd.rrd_add_ds rrd rrd.last_updated new_ds + +let test_ca_322008 () = + let rrd = ca_322008_rrd in + + (* Check against the maximum reasonable value of this series, + * the time in seconds when it was last updated, setting max + * value may cause the bug to not trigger *) + let in_range_fring ds fring = + in_range ds.ds_min rrd.last_updated (fring_to_list fring) + in + let in_range_rra dss rra = + List.iter2 in_range_fring dss (Array.to_list rra.rra_data) + in + List.iter (in_range_rra @@ Array.to_list rrd.rrd_dss) + @@ Array.to_list rrd.rrd_rras + +let test_ca_325844 () = + let rrd = of_file (Filename.concat "test_data" "flip_flop.xml") in + test_ranges rrd () + +let suite_create_multi = + let module RU = Rrd_updates in + let assert_size t = + (* we can't to check that the number of rows is consistent, + since this is defined purely by the number of rows + the number of columns should match the number of items in the legend - + each element in the legend array defines the contents for one column *) + let num_cols_in_legend = Array.length t.RU.legend in + t.RU.data + |> Array.iteri (fun i r -> + Alcotest.(check int) + (Printf.sprintf + "number of cols in legend must matche number of cols in row[%i]" + i + ) + num_cols_in_legend + (Array.length r.RU.row_data) + ) + in + let test_no_rrds () = + Alcotest.check_raises "should raise error" No_RRA_Available (fun () -> + let _ = RU.create_multi [] 0L 1L None in + () + ) + in + (* confusingly, rows in an rra are used to define the cols in the rrd_updates/ xml... + essentially we usually expect 'rows' in each rrd to be the same (test_rows_with_same_num_cols) + however, we should also handle the case where they are not (test_rows_with_different_num_cols) *) + let valid_rrd_tests = + [ + ("one_rrd", [create_rrd ~rows:2 [0L; 5L; 10L] 0. 1.]) + ; ( "rows_with_same_num_cols" + , [ + create_rrd ~rows:3 [0L; 5L; 10L] 0. 1. + ; create_rrd ~rows:3 [1L; 6L; 11L] 0. 1. + ] + ) + ; ( "rows_with_different_num_cols" + , [ + create_rrd ~rows:3 [0L; 5L; 10L] 0. 1. + ; create_rrd ~rows:2 [1L; 6L; 11L] 0. 1. + ] + ) + ] + |> List.map (fun (name, rrds) -> + ( name + , `Quick + , fun () -> + let rrds = + List.mapi (fun i rrd -> (Printf.sprintf "row[%i]" i, rrd)) rrds + in + RU.create_multi rrds 0L 1L None |> assert_size + ) + ) + in + ("no rrds", `Quick, test_no_rrds) :: valid_rrd_tests + +let rrd_suite rrd = + [ + ("Save xml to disk", `Quick, test_marshall ~json:false rrd) + ; ("Save json to disk", `Quick, test_marshall ~json:true rrd) + ; (* there is no json deserializer implementation *) + ("Save and restore from disk", `Quick, test_marshall_unmarshall rrd) + ; ("Length invariants", `Quick, test_length_invariants rrd) + ; ("Values in range", `Quick, test_ranges rrd) + ] + +let regression_suite = + [ + ("CA-322008", `Quick, test_ca_322008) + ; ("CA-325844", `Quick, test_ca_325844) + ; ("CA-329043 (1)", `Quick, test_ranges ca_329043_rrd_1) + ; ("CA-329043 (2)", `Quick, test_ranges ca_329043_rrd_2) + ; ("CA-329813", `Quick, test_ranges ca_329813_rrd) + ] + +let () = + Alcotest.run "Test RRD library" + [ + ("Gauge RRD", rrd_suite gauge_rrd) + ; ("RRD for CA-322008", rrd_suite ca_322008_rrd) + ; ("RRD for CA-329043", rrd_suite ca_329043_rrd_1) + ; ("RRD for CA-329813", rrd_suite ca_329813_rrd) + ; ("CP-33354", suite_create_multi) + ; ("Regressions", regression_suite) + ] diff --git a/ocaml/libs/xapi-rrd/unix/dune b/ocaml/libs/xapi-rrd/unix/dune new file mode 100644 index 00000000000..0a6b533348f --- /dev/null +++ b/ocaml/libs/xapi-rrd/unix/dune @@ -0,0 +1,12 @@ +(library + (name rrd_unix) + (public_name xapi-rrd.unix) + (wrapped false) + (libraries + unix + uuidm + xapi-rrd + xapi-stdext-pervasives + xmlm + ) +) diff --git a/ocaml/libs/xapi-rrd/unix/rrd_unix.ml b/ocaml/libs/xapi-rrd/unix/rrd_unix.ml new file mode 100644 index 00000000000..da91c99fd65 --- /dev/null +++ b/ocaml/libs/xapi-rrd/unix/rrd_unix.ml @@ -0,0 +1,41 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) +(* + * RRD Unix module + * This module provides Unix tools for dealing with RRDs + *) +(** + * @group Performance Monitoring +*) + +let finally = Xapi_stdext_pervasives.Pervasiveext.finally + +let with_out_channel_output fd f = + let oc = Unix.(out_channel_of_descr (dup fd)) in + finally + (fun () -> + let output = Xmlm.make_output (`Channel oc) in + f output + ) + (fun () -> Out_channel.close_noerr oc) + +let xml_to_fd rrd fd = with_out_channel_output fd (Rrd.xml_to_output rrd) + +let json_to_fd rrd fd = + let payload = Rrd.json_to_string rrd |> Bytes.unsafe_of_string in + let len = Bytes.length payload in + Unix.write fd payload 0 len |> ignore + +let to_fd ?(json = false) rrd fd = + (if json then json_to_fd else xml_to_fd) rrd fd diff --git a/ocaml/libs/xapi-rrd/unix/rrd_unix.mli b/ocaml/libs/xapi-rrd/unix/rrd_unix.mli new file mode 100644 index 00000000000..bddb4553413 --- /dev/null +++ b/ocaml/libs/xapi-rrd/unix/rrd_unix.mli @@ -0,0 +1,19 @@ +(* + Copyright (C) Citrix Systems Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation; version 2.1 only. with the special + exception on linking described in file LICENSE. + + 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 Lesser General Public License for more details. + *) +(** RRD Unix module + This module provides Unix tools for dealing with RRDs + *) + +val to_fd : ?json:bool -> Rrd.rrd -> Unix.file_descr -> unit +(** Serialize the rrd to xml / json and offer it through a file descriptor *) diff --git a/ocaml/libs/xapi-stdext/.gitignore b/ocaml/libs/xapi-stdext/.gitignore new file mode 100644 index 00000000000..4e66100e8f3 --- /dev/null +++ b/ocaml/libs/xapi-stdext/.gitignore @@ -0,0 +1,3 @@ +_build/ +*.install +.merlin diff --git a/ocaml/libs/xapi-stdext/CHANGES.md b/ocaml/libs/xapi-stdext/CHANGES.md new file mode 100644 index 00000000000..0973572d6da --- /dev/null +++ b/ocaml/libs/xapi-stdext/CHANGES.md @@ -0,0 +1,149 @@ +## v4.24.0 (17-Jan-2024) +- unix: really_read now retries reads on EINTR +- std: add Listext.List.find_minimum + +## v4.23.0 (30-Oct-2023) +- unix: fix blkgetsize return type mismatch (CA-382014) +- unix: add function to recursively remove files + +## v4.22.0 (24-May-2023) +- date, pervasive, std: remove deprecated code +- encodings: Optimize XML_UTF8.is_valid: avoid allocating an int32 for each unicode codepoint + +## v4.21.0 (29-Nov-2022) + - unix: add permissions to write_{bytes,string}_to_file + - Use a dune version with fixed metadata generation + - threads, unix: avoid using C functions deprecated in OCaml 5 + - Avoid warnings and add the check to detect them to the CI + - zerocheck: remove wrong, unused code. It was dangerous to leave it available + +## v4.20.0 (17-Nov-2022) + - date: consolidate the types into a single t + - date: add conversion functions that have semantic meaning, the previous functions containing 'float' and 'string' will be deprecated in a future release. + +## v4.19.0 (17-Jun-2022) + - maintenance: give a name to the project + - threads: Remove all the modules except Mutex + - Add license to opam metadata, remove unused opam files + +## v4.18.0 (15-Jun-2021) + - CP-31119: Enable documentation upload + - CP-31119: Prepare to generate documentation + - CP-34643: Prepare doc comments for odoc + - CP-34643: Reorder functions in listext interface + - CP-34643: drop deprecated methods from listext + - unix: remove unused stdext-std dependency + +## v4.17.0 (01-Mar-2021) + - listext: avoid traversing list twice on assoc_default + - maintenance: format with ocamlformat + - maintenance: prepare for ocamlformat + - CP-34643: listext: add drop function, rework some functions + - CP-34643: add unit tests for listext + - CP-34643: Listext: deprecate functions in Stdlib.List + - CP-34643: listext: remove implementations for functions in Stdlib.List + +## v4.16.0 (29-Dec-2020) + - ci: remove travis workflow + - Create ocaml-ci.yml + - date: allow timezones other than UTC for printing + - XSI-894 date.iso8601.to_float should assume UTC + +## v4.15.0 (14-Dec-2020) + - XSI-894 handle iso8601's with no timezone + - maintenance: format xstringext files with ocamlformat + - xapi-stdext-std: Do not duplicate functions from Stdlib + - CP-34643: add tests for xstringext + - maintenance: reformat pervasivesext with ocamlformat + - CP-34643: Deprecated non-idiomatic pervasivesext functions + - unixext: remove Fdset module and stubs + +## v4.14.0 (11-Aug-2020) + - CP-33121: Move encodings test to the package directory + - CP-33121: remove dependency of date in encodings tests + +## v4.13.0 (11-Aug-2020) + - CA-342171 allow clients to create an iso8601 from localtime + +## v4.12.0 (24-Jul-2020) + - CP-33121: run encodings tests as part of the encodings package + - maintenance: update travis config + - maintenance: prepare for ocamlformat + - CP-33121: remove obsoleted modules and packages + +## v4.11.0 (24-Apr-2020) + - CA-338243 remove legacy variant in iso8601 + +## v4.09.0 (23-Apr-2020) + - CA-338243 iso8601.to_string backwards compatibility + +## v4.8.0 (15-Apr-2020) + - CA-333908 accept YYYY-MM-DD date format + - unixext: better description for write___to_file + - fixup! CP-32686: Ensure durability with atomic_write_to_file + - fixup! CP-32686: Ensure durability with atomic_write_to_file + - maintenance: whitespace + - CP-32686: Ensure durability with atomic_write_to_file + - ci: use environment vars from xs-opam + - ci: do do not pin base64, it doesn't exist + +## v4.7.0 (04-Jun-2019) + - CP-30756: Remove Base64 + +## v4.6.0 (02-Apr-2019) +- CA-314001: release runtime lock around long running system calls + +## v4.5.0 (13-Mar-2019) + - Update .travis.yml + - CA-310525 fix C binding for statvfs + +## 4.4.1 (21-Jan-2019) + - Replaced jbuild files with dune. + +## 4.4.0 (05-Jul-2018): -- xapi-stdext-pervasives only +* CA-292641: Use Logs to log cleanup exn instead of shadowing the original one with it + +## 4.3.0 (30-May-2018): +* CP-28365: improve backtraces by using finally + +## 4.2.0 (25-May-2018): -- xapi-stdext-unix only +* unixext: update interface to mimick the ocaml Unix one + +## 4.1.0 (25-Apr-2018): -- xapi-stdext-unix only +* really_write: + - use single_write_substring and avoid an unsafe coercion + - remove deprecation and make robust against EINTR +* unixext_open_stubs: fix use of uninitialised variable + +## 4.0.0 (15-Mar-2018): +* Make safe-string safe (xap-stdext-{bigbuffer, encodings, std, threads, unix} 1.1.0) +* Remove bigbuffer from the default stdext set of packages +* Use backward compatible naming for stdext xapi-stdext + +## 3.0.0 (02-Aug-2017): +* Remove unused packages +* Refactor in a backward compatible wrapper and 12 new separate libraries (see https://github.com/xapi-project/stdext/pull/21) +* Port to jbuilder + +## 2.1.0 (20-Oct-2016): +* New Semaphore module + +## 2.0.0 (22-Jun-2016): +* Namespace everything under Stdext. This is a backwards incompatible change. + +## 0.13.0 (20-Nov-2014): +* Depend on Backtrace from xapi-backtrace +* Add an opam file + +## 0.12.0 (26-Sep-2014): +* Fix build errors on OS X + +## 0.11.0 (30-May-2013): +* Change Stringext module to Xstringext to avoid conflict with other packages + +## 0.9.1 (10-Sep-2013): +* Add Unixext.domain_of_addr +* Add String.sub_{before,after} + +## 0.9.0 (3-Jun-2013): +* first public release diff --git a/ocaml/libs/xapi-stdext/LICENSE b/ocaml/libs/xapi-stdext/LICENSE new file mode 100644 index 00000000000..1b1ce97cb5c --- /dev/null +++ b/ocaml/libs/xapi-stdext/LICENSE @@ -0,0 +1,521 @@ +This repository is distributed under the terms of the GNU Lesser General +Public License version 2.1 (included below). + +As a special exception to the GNU Lesser General Public License, you +may link, statically or dynamically, a "work that uses the Library" +with a publicly distributed version of the Library to produce an +executable file containing portions of the Library, and distribute +that executable file under terms of your choice, without any of the +additional requirements listed in clause 6 of the GNU Lesser General +Public License. By "a publicly distributed version of the Library", +we mean either the unmodified Library as distributed, or a +modified version of the Library that is distributed under the +conditions defined in clause 3 of the GNU Library General Public +License. This exception does not however invalidate any other reasons +why the executable file might be covered by the GNU Lesser General +Public License. + +------------ + + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +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 and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, 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 library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete 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 distribute a copy of this License along with the +Library. + + 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 Library or any portion +of it, thus forming a work based on the Library, 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) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +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 Library, 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 Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you 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. + + If distribution of 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 satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be 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. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library 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. + + 9. 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 Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +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 with +this License. + + 11. 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 Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library 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 Library. + +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. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library 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. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser 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 Library +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 Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +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 + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "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 +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. 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 LIBRARY 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 +LIBRARY (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 LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), 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 Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. 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 library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/ocaml/libs/xapi-stdext/README.md b/ocaml/libs/xapi-stdext/README.md new file mode 100644 index 00000000000..258f7cb3732 --- /dev/null +++ b/ocaml/libs/xapi-stdext/README.md @@ -0,0 +1,11 @@ +Deprecated misc utility functions +================================= + +These utility functions are used by several other services. Much of this +should be replaced with other libraries such as + * Stdlib + * Bos + +Eventually this library should disappear. + +In the meantime documentation can be found at http://xapi-project.github.io/stdext/index.html diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/date.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/date.ml new file mode 100644 index 00000000000..77f3994fe68 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/date.ml @@ -0,0 +1,189 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) + +let months = + [| + "Jan" + ; "Feb" + ; "Mar" + ; "Apr" + ; "May" + ; "Jun" + ; "Jul" + ; "Aug" + ; "Sep" + ; "Oct" + ; "Nov" + ; "Dec" + |] + +let days = [|"Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat"|] + +type print_timezone = Empty | TZ of string + +(* we must store the print_type with iso8601 to handle the case where the local time zone is UTC *) +type t = Ptime.date * Ptime.time * print_timezone + +let utc = TZ "Z" + +let of_dt print_type dt = + let date, time = dt in + (date, time, print_type) + +let to_dt (date, time, _) = (date, time) + +let best_effort_iso8601_to_rfc3339 x = + (* (a) add dashes + * (b) add UTC tz if no tz provided *) + let x = + try + Scanf.sscanf x "%04d%02d%02dT%s" (fun y mon d rest -> + Printf.sprintf "%04d-%02d-%02dT%s" y mon d rest + ) + with _ -> x + in + let tz = + try + Scanf.sscanf x "%04d-%02d-%02dT%02d:%02d:%02d%s" (fun _ _ _ _ _ _ tz -> + Some tz + ) + with _ -> None + in + match tz with + | None | Some "" -> + (* the caller didn't specify a tz. we must try to add one so that ptime can at least attempt to parse *) + (Printf.sprintf "%sZ" x, Empty) + | Some tz -> + (x, TZ tz) + +let of_iso8601 x = + let rfc3339, print_timezone = best_effort_iso8601_to_rfc3339 x in + match Ptime.of_rfc3339 rfc3339 |> Ptime.rfc3339_error_to_msg with + | Error _ -> + invalid_arg (Printf.sprintf "%s: %s" __FUNCTION__ x) + | Ok (t, tz, _) -> ( + match tz with + | None | Some 0 -> + Ptime.to_date_time t |> of_dt print_timezone + | Some _ -> + invalid_arg (Printf.sprintf "%s: %s" __FUNCTION__ x) + ) + +let to_rfc3339 ((y, mon, d), ((h, min, s), _), print_type) = + match print_type with + | TZ tz -> + Printf.sprintf "%04i%02i%02iT%02i:%02i:%02i%s" y mon d h min s tz + | Empty -> + Printf.sprintf "%04i%02i%02iT%02i:%02i:%02i" y mon d h min s + +let weekday ~year ~mon ~day = + let a = (14 - mon) / 12 in + let y = year - a in + let m = mon + (12 * a) - 2 in + (day + y + (y / 4) - (y / 100) + (y / 400) + (31 * m / 12)) mod 7 + +let to_rfc822 ((year, mon, day), ((h, min, s), _), print_type) = + let timezone = + match print_type with Empty | TZ "Z" -> "GMT" | TZ tz -> tz + in + let weekday = weekday ~year ~mon ~day in + Printf.sprintf "%s, %d %s %d %02d:%02d:%02d %s" days.(weekday) day + months.(mon - 1) + year h min s timezone + +let to_ptime_t t = + match to_dt t |> Ptime.of_date_time with + | Some t -> + t + | None -> + let _, (_, offset), _ = t in + invalid_arg + (Printf.sprintf "%s: dt='%s', offset='%i' is invalid" __FUNCTION__ + (to_rfc3339 t) offset + ) + +let to_ptime = to_ptime_t + +let of_ptime t = Ptime.to_date_time t |> of_dt utc + +let of_unix_time s = + match Ptime.of_float_s s with + | None -> + invalid_arg (Printf.sprintf "%s: %f" __FUNCTION__ s) + | Some t -> + of_ptime t + +let to_unix_time t = to_ptime_t t |> Ptime.to_float_s + +let _localtime current_tz_offset t = + let tz_offset_s = current_tz_offset |> Option.value ~default:0 in + let localtime = t |> Ptime.to_date_time ~tz_offset_s |> of_dt Empty in + let _, (_, localtime_offset), _ = localtime in + if localtime_offset <> tz_offset_s then + invalid_arg + (Printf.sprintf "%s: offsets don't match. offset='%i', t='%s'" + __FUNCTION__ tz_offset_s (Ptime.to_rfc3339 t) + ) ; + localtime + +let _localtime_string current_tz_offset t = + _localtime current_tz_offset t |> to_rfc3339 + +let localtime () = + _localtime (Ptime_clock.current_tz_offset_s ()) (Ptime_clock.now ()) + +let now () = of_ptime (Ptime_clock.now ()) + +let epoch = of_ptime Ptime.epoch + +let is_earlier ~than t = Ptime.is_earlier ~than:(to_ptime than) (to_ptime t) + +let is_later ~than t = Ptime.is_later ~than:(to_ptime than) (to_ptime t) + +let diff a b = Ptime.diff (to_ptime a) (to_ptime b) + +let compare_print_tz a b = + match (a, b) with + | Empty, Empty -> + 0 + | TZ a_s, TZ b_s -> + String.compare a_s b_s + | Empty, TZ _ -> + -1 + | TZ _, Empty -> + 1 + +let compare ((_, _, a_z) as a) ((_, _, b_z) as b) = + let ( ) a b = if a = 0 then b else a in + Ptime.compare (to_ptime a) (to_ptime b) compare_print_tz a_z b_z + +let eq x y = compare x y = 0 + +let never = epoch + +let of_string = of_iso8601 + +let to_string = to_rfc3339 + +let of_float = of_unix_time + +let to_float = to_unix_time + +let rfc822_of_float = of_unix_time + +let rfc822_to_string = to_rfc822 + +type iso8601 = t + +type rfc822 = t diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/date.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/date.mli new file mode 100644 index 00000000000..62e894808bf --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/date.mli @@ -0,0 +1,105 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) + +(** date-time with support for keeping timezone for ISO 8601 conversion *) +type t + +(** Conversions *) + +val of_ptime : Ptime.t -> t +(** Convert ptime to time in UTC *) + +val to_ptime : t -> Ptime.t +(** Convert date/time to a ptime value: the number of seconds since 00:00:00 + UTC, 1 Jan 1970. Assumes the underlying {!t} is in UTC *) + +val of_unix_time : float -> t +(** Convert calendar time [x] (as returned by e.g. Unix.time), to time in UTC *) + +val to_unix_time : t -> float +(** Convert date/time to a unix timestamp: the number of seconds since + 00:00:00 UTC, 1 Jan 1970. Assumes the underlying {!t} is in UTC *) + +val to_rfc822 : t -> string +(** Convert date/time to email-formatted (RFC 822) string. *) + +val to_rfc3339 : t -> string +(** Convert date/time to an RFC-3339-formatted string. It also complies with + the ISO 8601 format *) + +val of_iso8601 : string -> t +(** Convert ISO 8601 formatted string to a date/time value. Does not accept a + timezone annotated datetime - i.e. string must be UTC, and end with a Z *) + +val epoch : t +(** 00:00:00 UTC, 1 Jan 1970, in UTC *) + +val now : unit -> t +(** Count the number of seconds passed since 00:00:00 UTC, 1 Jan 1970, in UTC *) + +val _localtime_string : Ptime.tz_offset_s option -> Ptime.t -> string +(** exposed for testing *) + +val localtime : unit -> t +(** Count the number of seconds passed since 00:00:00 UTC, 1 Jan 1970, in local + time *) + +(** Comparisons *) + +val eq : t -> t -> bool +(** [eq a b] returns whether [a] and [b] are equal *) + +val compare : t -> t -> int +(** [compare a b] returns -1 if [a] is earlier than [b], 1 if [a] is later than + [b] or the ordering of the timezone printer *) + +val is_earlier : than:t -> t -> bool +(** [is_earlier ~than a] returns whether the timestamp [a] happens before + [than] *) + +val is_later : than:t -> t -> bool +(** [is_later ~than a] returns whether the timestamp [a] happens after [than] + *) + +val diff : t -> t -> Ptime.Span.t +(** [diff a b] returns the span of time corresponding to [a - b] *) + +(** Deprecated bindings, these will be removed in a future release: *) + +val rfc822_to_string : t -> string +(** Same as {!to_rfc822} *) + +val rfc822_of_float : float -> t +(** Same as {!of_unix_time} *) + +val of_float : float -> t +(** Same as {!of_unix_time} *) + +val to_float : t -> float +(** Same as {!to_unix_time} *) + +val to_string : t -> string +(** Same as {!to_rfc3339} *) + +val of_string : string -> t +(** Same as {!of_iso8601} *) + +val never : t +(** Same as {!epoch} *) + +(** Deprecated alias for {!t} *) +type iso8601 = t + +(** Deprecated alias for {!t} *) +type rfc822 = t diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/dune new file mode 100644 index 00000000000..c2ed6c448da --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/dune @@ -0,0 +1,16 @@ +(library + (name xapi_stdext_date) + (public_name xapi-stdext-date) + (modules :standard \ test) + (libraries astring + ptime + ptime.clock.os + unix) +) + +(test + (name test) + (package xapi-stdext-date) + (modules test) + (libraries alcotest xapi-stdext-date ptime) +) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/test.ml new file mode 100644 index 00000000000..66ec59696da --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/test.ml @@ -0,0 +1,135 @@ +open Xapi_stdext_date.Date + +let check_float = Alcotest.(check @@ float 1e-2) + +let check_float_neq = Alcotest.(check @@ neg @@ float 1e-2) + +let check_string = Alcotest.(check string) + +let check_true str = Alcotest.(check bool) str true + +let dash_time_str = "2020-04-07T08:28:32Z" + +let no_dash_utc_time_str = "20200407T08:28:32Z" + +let tests = + let test_of_unix_time_invertible () = + let non_int_time = 1586245987.70200706 in + let time = non_int_time |> Float.floor in + check_float "to_unix_time inverts of_unix_time" time + (time |> of_unix_time |> to_unix_time) ; + check_true "of_unix_time inverts to_unix_time" + @@ eq (time |> of_unix_time) + (time |> of_unix_time |> to_unix_time |> of_unix_time) + in + let test_only_utc () = + let utc = "2020-12-20T18:10:19Z" in + let _ = of_iso8601 utc in + (* UTC is valid *) + let non_utc = "2020-12-20T18:10:19+02:00" in + let exn = + Invalid_argument + "Xapi_stdext_date__Date.of_iso8601: 2020-12-20T18:10:19+02:00" + in + Alcotest.check_raises "only UTC is accepted" exn (fun () -> + of_iso8601 non_utc |> ignore + ) + in + let test_ca333908 () = + check_float "dash time and no dash time represent the same unix timestamp" + (dash_time_str |> of_iso8601 |> to_unix_time) + (no_dash_utc_time_str |> of_iso8601 |> to_unix_time) + in + let test_of_iso8601_invertible_when_no_dashes () = + check_string "to_rfc3339 inverts of_iso8601" no_dash_utc_time_str + (no_dash_utc_time_str |> of_iso8601 |> to_rfc3339) ; + check_true "of_iso8601 inverts to_rfc3339" + (eq + (no_dash_utc_time_str |> of_iso8601) + (no_dash_utc_time_str |> of_iso8601 |> to_rfc3339 |> of_iso8601) + ) + in + (* CA-338243 - breaking backwards compatibility will break XC and XRT *) + let test_to_rfc3339_backwards_compatibility () = + check_string "to_rfc3339 is backwards compatible" no_dash_utc_time_str + (dash_time_str |> of_iso8601 |> to_rfc3339) + in + let test_localtime_string () = + let[@warning "-8"] (Ok (t, _, _)) = + Ptime.of_rfc3339 "2020-04-07T09:01:28Z" + in + let minus_2_hrs = -7200 in + let plus_3_hrs = 10800 in + let zero_hrs = 0 in + check_string "can subtract 2 hours" + (_localtime_string (Some minus_2_hrs) t) + "20200407T07:01:28" ; + check_string "can add 3 hours" + (_localtime_string (Some plus_3_hrs) t) + "20200407T12:01:28" ; + check_string "can add None" (_localtime_string None t) "20200407T09:01:28" ; + check_string "can add zero" + (_localtime_string (Some zero_hrs) t) + "20200407T09:01:28" + in + (* sanity check (on top of test_localtime_string) that localtime produces valid looking output *) + let test_ca342171 () = + (* no exception is thrown + backward compatible formatting *) + let localtime_string = localtime () |> to_rfc3339 in + Alcotest.(check int) + "localtime string has correct number of chars" + (String.length localtime_string) + (String.length no_dash_utc_time_str - 1) ; + Alcotest.(check bool) + "localtime string does not contain a Z" false + (String.contains localtime_string 'Z') + in + let test_xsi894 () = + let missing_tz_no_dash = "20201210T17:19:20" in + let missing_tz_dash = "2020-12-10T17:19:20" in + check_string "can process missing tz no dash" missing_tz_no_dash + (missing_tz_no_dash |> of_iso8601 |> to_rfc3339) ; + check_string "can process missing tz with dashes, but return without dashes" + missing_tz_no_dash + (missing_tz_dash |> of_iso8601 |> to_rfc3339) ; + check_float "to_unix_time assumes UTC" 1607620760. + (missing_tz_no_dash |> of_iso8601 |> to_unix_time) ; + let localtime' = localtime () in + check_string "to_rfc3339 inverts of_iso8601 for localtime" + (localtime' |> to_rfc3339) + (localtime' |> to_rfc3339 |> of_iso8601 |> to_rfc3339) + in + let test_email_date (unix_timestamp, expected) = + let formatted = of_unix_time unix_timestamp |> to_rfc822 in + check_string "String is properly RFC-822-formatted" expected formatted + in + let test_email_dates () = + let dates = + [ + (-1221847200., "Tue, 14 Apr 1931 06:00:00 GMT") + ; (0., "Thu, 1 Jan 1970 00:00:00 GMT") + ; (626637180., "Thu, 9 Nov 1989 17:53:00 GMT") + ; (2889734400., "Thu, 28 Jul 2061 00:00:00 GMT") + ] + in + List.iter test_email_date dates + in + [ + ("test_of_unix_time_invertible", `Quick, test_of_unix_time_invertible) + ; ("test_only_utc", `Quick, test_only_utc) + ; ("test_ca333908", `Quick, test_ca333908) + ; ( "test_of_iso8601_invertible_when_no_dashes" + , `Quick + , test_of_iso8601_invertible_when_no_dashes + ) + ; ( "test_to_rfc3339_backwards_compatibility" + , `Quick + , test_to_rfc3339_backwards_compatibility + ) + ; ("test_localtime_string", `Quick, test_localtime_string) + ; ("test_ca342171", `Quick, test_ca342171) + ; ("test_xsi894", `Quick, test_xsi894) + ; ("RFC 822 formatting", `Quick, test_email_dates) + ] + +let () = Alcotest.run "Date" [("Conversions", tests)] diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/bench/bechamel_simple_cli.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/bench/bechamel_simple_cli.ml new file mode 100644 index 00000000000..fef03cce765 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/bench/bechamel_simple_cli.ml @@ -0,0 +1,56 @@ +(* based on bechamel example code *) +open Bechamel +open Toolkit + +let instances = Instance.[monotonic_clock; minor_allocated; major_allocated] + +let benchmark tests = + let cfg = Benchmark.cfg () in + Benchmark.all cfg instances tests + +let analyze raw_results = + let ols = + Analyze.ols ~r_square:true ~bootstrap:0 ~predictors:[|Measure.run|] + in + let results = + List.map (fun instance -> Analyze.all ols instance raw_results) instances + in + (Analyze.merge ols instances results, raw_results) + +let () = + List.iter (fun i -> Bechamel_notty.Unit.add i (Measure.unit i)) instances + +let img (window, results) = + Bechamel_notty.Multiple.image_of_ols_results ~rect:window + ~predictor:Measure.run results + +open Notty_unix + +let cli tests = + Format.printf "@,Running benchmarks@." ; + let results, _ = tests |> benchmark |> analyze in + (* compute speed from duration *) + let () = + Hashtbl.find results (Measure.label Instance.monotonic_clock) + |> Hashtbl.iter @@ fun name result -> + try + (* this relies on extracting input size from test name, + which works if Test.make_indexed* was used *) + Scanf.sscanf name "%_s@:%d" @@ fun length -> + match Analyze.OLS.estimates result with + | Some [duration] -> + (* unit is ns *) + let speed = 1e9 *. float length /. duration /. 1048576.0 in + Fmt.pf Fmt.stdout "@[%s = %.1f MiB/s@]@." name speed + | _ -> + () + with Failure _ | Scanf.Scan_failure _ -> () + in + let window = + match winsize Unix.stdout with + | Some (w, h) -> + {Bechamel_notty.w; h} + | None -> + {Bechamel_notty.w= 80; h= 1} + in + img (window, results) |> eol |> output_image diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/bench/bench_encodings.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/bench/bench_encodings.ml new file mode 100644 index 00000000000..7308c756d8b --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/bench/bench_encodings.ml @@ -0,0 +1,15 @@ +open Bechamel +open Xapi_stdext_encodings.Encodings + +let test name f = + Test.make_indexed_with_resource ~name ~args:[10; 1000; 10000] + Test.multiple (* TODO: Test.uniq segfaults here, bechamel bug *) + ~allocate:(fun i -> String.make i 'x') + ~free:ignore + (fun (_ : int) -> Staged.stage f) + +let benchmarks = + Test.make_grouped ~name:"Encodings.validate" + [test "UTF8_XML" UTF8_XML.validate] + +let () = Bechamel_simple_cli.cli benchmarks diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/bench/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/bench/dune new file mode 100644 index 00000000000..9f12bcbf8ce --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/bench/dune @@ -0,0 +1,6 @@ +(executable + (name bench_encodings) + (modes exe) + (optional) + (libraries bechamel xapi_stdext_encodings bechamel-notty notty.unix fmt) +) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/dune new file mode 100644 index 00000000000..742dd212f1e --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/dune @@ -0,0 +1,12 @@ +(library + (name xapi_stdext_encodings) + (public_name xapi-stdext-encodings) + (modules :standard \ test) +) + +(test + (name test) + (package xapi-stdext-encodings) + (modules test) + (libraries alcotest xapi-stdext-encodings) +) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/encodings.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/encodings.ml new file mode 100644 index 00000000000..8d6d07e012a --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/encodings.ml @@ -0,0 +1,167 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) +exception UCS_value_out_of_range + +exception UCS_value_prohibited_in_UTF8 + +exception UCS_value_prohibited_in_XML + +exception UTF8_character_incomplete + +exception UTF8_header_byte_invalid + +exception UTF8_continuation_byte_invalid + +exception UTF8_encoding_not_canonical + +exception String_incomplete + +(* === Unicode Functions === *) + +module UCS = struct + let is_non_character value = + false + || (0xfdd0 <= value && value <= 0xfdef) (* case 1 *) + || Int.logand 0xfffe value = 0xfffe + (* case 2 *) + [@@inline] +end + +module XML = struct + let is_illegal_control_character value = + let value = Uchar.to_int value in + value < 0x20 && value <> 0x09 && value <> 0x0a && value <> 0x0d + [@@inline] +end + +(* === UCS Validators === *) + +module type UCS_VALIDATOR = sig + val validate : Uchar.t -> unit [@@inline] +end + +module UTF8_UCS_validator = struct + let validate value = + if (UCS.is_non_character [@inlined]) (Uchar.to_int value) then + raise UCS_value_prohibited_in_UTF8 + [@@inline] +end + +module XML_UTF8_UCS_validator = struct + let validate value = + (UTF8_UCS_validator.validate [@inlined]) value ; + if (XML.is_illegal_control_character [@inlined]) value then + raise UCS_value_prohibited_in_XML +end + +(* === String Validators === *) + +module type STRING_VALIDATOR = sig + val is_valid : string -> bool + + val validate : string -> unit + + val longest_valid_prefix : string -> string +end + +exception Validation_error of int * exn + +module UTF8_XML : STRING_VALIDATOR = struct + let decode_continuation_byte byte = + if byte land 0b11000000 = 0b10000000 then + byte land 0b00111111 + else + raise UTF8_continuation_byte_invalid + + let rec decode_continuation_bytes string last value index = + if index <= last then + let chunk = decode_continuation_byte (Char.code string.[index]) in + let value = (value lsl 6) lor chunk in + decode_continuation_bytes string last value (index + 1) + else + value + + let validate_character_utf8 string byte index = + let value, width = + if byte land 0b10000000 = 0b00000000 then + (byte, 1) + else if byte land 0b11100000 = 0b11000000 then + (byte land 0b0011111, 2) + else if byte land 0b11110000 = 0b11100000 then + (byte land 0b0001111, 3) + else if byte land 0b11111000 = 0b11110000 then + (byte land 0b0000111, 4) + else + raise UTF8_header_byte_invalid + in + let value = + if width = 1 then + value + else + decode_continuation_bytes string (index + width - 1) value (index + 1) + in + XML_UTF8_UCS_validator.validate (Uchar.unsafe_of_int value) ; + width + + let rec validate_aux string length index = + if index = length then + () + else + let width = + try + let byte = string.[index] |> Char.code in + validate_character_utf8 string byte index + with + | Invalid_argument _ -> + raise String_incomplete + | error -> + raise (Validation_error (index, error)) + in + validate_aux string length (index + width) + + let validate string = validate_aux string (String.length string) 0 + + let rec validate_with_fastpath string stop pos = + if pos < stop then + (* the compiler is smart enough to optimize the 'int32' away here, + and not allocate *) + let i32 = String.get_int32_ne string pos |> Int32.to_int in + (* test that for all bytes 0x20 <= byte < 0x80. + If any is <0x20 it would cause a negative value to appear in that byte, + which we can detect if we use 0x80 as a mask. + Byte >= 0x80 can be similarly detected with a mask of 0x80 on each byte. + We don't want to see a 0x80 from either of these, hence we bitwise or the 2 values together. + *) + if i32 lor (i32 - 0x20_20_20_20) land 0x80_80_80_80 = 0 then + validate_with_fastpath string stop (pos + 4) + else (* when the condition doesn't hold fall back to full UTF8 decoder *) + validate_aux string (String.length string) pos + else + validate_aux string (String.length string) pos + + let validate_with_fastpath string = + validate_with_fastpath string (String.length string - 3) 0 + + let validate = + if Sys.word_size = 64 then + validate_with_fastpath + else + validate + + let is_valid string = try validate string ; true with _ -> false + + let longest_valid_prefix string = + try validate string ; string + with Validation_error (index, _) -> String.sub string 0 index +end diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/encodings.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/encodings.mli new file mode 100644 index 00000000000..2a139ae3786 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/encodings.mli @@ -0,0 +1,84 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) + +(** Encoding helper modules *) + +(** {2 Exceptions} *) + +exception UCS_value_out_of_range + +exception UCS_value_prohibited_in_UTF8 + +exception UCS_value_prohibited_in_XML + +exception UTF8_character_incomplete + +exception UTF8_header_byte_invalid + +exception UTF8_continuation_byte_invalid + +exception UTF8_encoding_not_canonical + +exception String_incomplete + +(** {2 UCS Validators} *) + +(** Validates UCS character values. *) +module type UCS_VALIDATOR = sig + val validate : Uchar.t -> unit +end + +(** Accepts all values within the UCS character value range except + * those which are invalid for all UTF-8-encoded XML documents. *) +module XML_UTF8_UCS_validator : UCS_VALIDATOR + +module XML : sig + val is_illegal_control_character : Uchar.t -> bool + (** Returns true if and only if the given value corresponds to + * a illegal control character as defined in section 2.2 of + * the XML specification, version 1.0. *) +end + +(** {2 String Validators} *) + +(** Provides functionality for validating and processing + * strings according to a particular character encoding. *) +module type STRING_VALIDATOR = sig + val is_valid : string -> bool + (** Returns true if and only if the given string is validly-encoded. *) + + val validate : string -> unit + (** Raises an encoding error if the given string is not validly-encoded. *) + + val longest_valid_prefix : string -> string + (** Returns the longest validly-encoded prefix of the given string. *) +end + +(** Represents a validation error as a tuple [(i,e)], where: + * [i] = the index of the first non-compliant character; + * [e] = the reason for non-compliance. *) +exception Validation_error of int * exn + +(** Provides functions for validating and processing + * strings according to the UTF-8 character encoding, + * with certain additional restrictions on UCS values + * imposed by the XML specification. + * + * Validly-encoded strings must satisfy both RFC 3629 + * and section 2.2 of the XML specification. + * + * For further information, see: + * http://www.rfc.net/rfc3629.html + * http://www.w3.org/TR/REC-xml/#charsets *) +module UTF8_XML : STRING_VALIDATOR diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/test.ml new file mode 100644 index 00000000000..e94825accae --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/test.ml @@ -0,0 +1,607 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) +module E = Xapi_stdext_encodings.Encodings + +(* Pull in the infix operators from Encodings used in this test *) +let ( --- ), ( +++ ), ( <<< ) = (Int.sub, Int.add, Int.shift_left) + +(* === Mock exceptions ==================================================== *) + +(** Simulates a decoding error. *) +exception Decode_error + +(* === Mock types ===========================================================*) + +(** Generates mock character widths, in bytes. *) +module type WIDTH_GENERATOR = sig + val next : unit -> int +end + +(* === Mock UCS validators ================================================= *) + +(** A validator that always succeeds. *) +module Lenient_UCS_validator : E.UCS_VALIDATOR = struct + let validate _ = () +end + +(* === Mock character validators ============================================= *) + +(** A validator that succeeds for all characters. *) +module Universal_character_validator = struct + let validate _ = () +end + +(** A validator that fails for all characters. *) +module Failing_character_validator = struct + let validate _ = raise Decode_error +end + +(** A validator that succeeds for all characters except the letter 'F'. *) +module Selective_character_validator = struct + let validate uchar = + if Uchar.equal uchar (Uchar.of_char 'F') then raise Decode_error +end + +(* === Test helpers ======================================================== *) + +let assert_true = Alcotest.(check bool) "true" true + +let assert_false = Alcotest.(check bool) "false" false + +let check_indices = Alcotest.(check (list int)) "indices" + +let assert_raises_match exception_match fn = + try + fn () ; + Alcotest.fail "assert_raises_match: failure expected" + with failure -> + if not (exception_match failure) then + raise failure + else + () + +(* === Mock codecs ========================================================= *) + +module UCS = struct + (* === Unicode Functions === *) + let min_value = 0x000000 + + let max_value = 0x10ffff + (* used to be 0x1fffff, but this changed and Unicode won't allocate larger than 0x10ffff *) + + let is_non_character value = + false + || (0xfdd0 <= value && value <= 0xfdef) (* case 1 *) + || Int.logand 0xfffe value = 0xfffe + (* case 2 *) + + let is_out_of_range value = value < min_value || value > max_value + + let is_surrogate value = 0xd800 <= value && value <= 0xdfff + + (** A list of UCS non-characters values, including: + a. non-characters within the basic multilingual plane; + b. non-characters at the end of the basic multilingual plane; + c. non-characters at the end of the private use area. *) + let non_characters = + [ + 0x00fdd0 + ; 0x00fdef + ; (* case a. *) + 0x00fffe + ; 0x00ffff + ; (* case b. *) + 0x1ffffe + ; 0x1fffff (* case c. *) + ] + + (** A list of UCS character values located immediately before or + after UCS non-character values, including: + a. non-characters within the basic multilingual plane; + b. non-characters at the end of the basic multilingual plane; + c. non-characters at the end of the private use area. *) + let valid_characters_next_to_non_characters = + [ + 0x00fdcf + ; 0x00fdf0 + ; (* case a. *) + 0x00fffd + ; 0x010000 + ; (* case b. *) + 0x1ffffd + ; 0x200000 (* case c. *) + ] + + let test_is_non_character () = + List.iter (fun value -> assert_true (is_non_character value)) non_characters ; + List.iter + (fun value -> assert_false (is_non_character value)) + valid_characters_next_to_non_characters + + let test_is_out_of_range () = + assert_true (is_out_of_range (min_value --- 1)) ; + assert_false (is_out_of_range min_value) ; + assert_false (is_out_of_range max_value) ; + assert_true (is_out_of_range (max_value +++ 1)) + + let test_is_surrogate () = + assert_false (is_surrogate 0xd7ff) ; + assert_true (is_surrogate 0xd800) ; + assert_true (is_surrogate 0xdfff) ; + assert_false (is_surrogate 0xe000) + + let tests = + [ + ("test_is_non_character", `Quick, test_is_non_character) + ; ("test_is_out_of_range", `Quick, test_is_out_of_range) + ; ("test_is_surrogate", `Quick, test_is_surrogate) + ] +end + +module Lenient_UTF8_codec = struct + let decode_header_byte byte = + if byte land 0b10000000 = 0b00000000 then + (byte, 1) + else if byte land 0b11100000 = 0b11000000 then + (byte land 0b0011111, 2) + else if byte land 0b11110000 = 0b11100000 then + (byte land 0b0001111, 3) + else if byte land 0b11111000 = 0b11110000 then + (byte land 0b0000111, 4) + else + raise E.UTF8_header_byte_invalid + + let decode_continuation_byte byte = + if byte land 0b11000000 = 0b10000000 then + byte land 0b00111111 + else + raise E.UTF8_continuation_byte_invalid + + let width_required_for_ucs_value value = + if value < 0x000080 (* 1 lsl 7 *) then + 1 + else if value < 0x000800 (* 1 lsl 11 *) then + 2 + else if value < 0x010000 (* 1 lsl 16 *) then + 3 + else + 4 + + let decode_character string index = + let value, width = decode_header_byte (Char.code string.[index]) in + let value = + if width = 1 then + value + else + let value = ref value in + for index = index + 1 to index + width - 1 do + let chunk = decode_continuation_byte (Char.code string.[index]) in + value := (!value lsl 6) lor chunk + done ; + if width > width_required_for_ucs_value !value then + raise E.UTF8_encoding_not_canonical ; + !value + in + (value, width) +end + +(* === Mock string validators ============================================== *) +module Mock_String_validator (Validator : E.UCS_VALIDATOR) : + E.STRING_VALIDATOR = struct + (* no longer a functor in Encodings for performance reasons, + so modify the original string passed as argument instead replacing + characters that would be invalid with a known invalid XML char: 0x0B. + *) + + let transform str = + let b = Buffer.create (String.length str) in + let rec loop pos = + if pos < String.length str then + let value, width = Lenient_UTF8_codec.decode_character str pos in + let () = + try + let u = Uchar.of_int value in + Validator.validate u ; Buffer.add_utf_8_uchar b u + with _ -> Buffer.add_char b '\x0B' + in + loop (pos + width) + in + loop 0 ; Buffer.contents b + + let is_valid str = E.UTF8_XML.is_valid (transform str) + + let validate str = + try E.UTF8_XML.validate (transform str) + with E.Validation_error (pos, _) -> + raise (E.Validation_error (pos, Decode_error)) + + let longest_valid_prefix str = E.UTF8_XML.longest_valid_prefix (transform str) +end + +(** A validator that accepts all strings. *) +module Universal_string_validator = + Mock_String_validator (Universal_character_validator) + +(** A validator that rejects all strings. *) +module Failing_string_validator = + Mock_String_validator (Failing_character_validator) + +(** A validator that rejects strings containing the character 'F'. *) +module Selective_string_validator = + Mock_String_validator (Selective_character_validator) + +(* === Tests =============================================================== *) + +module String_validator = struct + let test_is_valid () = + assert_true (Universal_string_validator.is_valid "") ; + assert_true (Universal_string_validator.is_valid "123456789") ; + assert_true (Selective_string_validator.is_valid "") ; + assert_true (Selective_string_validator.is_valid "123456789") ; + assert_false (Selective_string_validator.is_valid "F23456789") ; + assert_false (Selective_string_validator.is_valid "1234F6789") ; + assert_false (Selective_string_validator.is_valid "12345678F") ; + assert_false (Selective_string_validator.is_valid "FFFFFFFFF") + + let test_longest_valid_prefix () = + Alcotest.(check string) + "prefix" + (Universal_string_validator.longest_valid_prefix "") + "" ; + Alcotest.(check string) + "prefix" + (Universal_string_validator.longest_valid_prefix "123456789") + "123456789" ; + Alcotest.(check string) + "prefix" + (Selective_string_validator.longest_valid_prefix "") + "" ; + Alcotest.(check string) + "prefix" + (Selective_string_validator.longest_valid_prefix "123456789") + "123456789" ; + Alcotest.(check string) + "prefix" + (Selective_string_validator.longest_valid_prefix "F23456789") + "" ; + Alcotest.(check string) + "prefix" + (Selective_string_validator.longest_valid_prefix "1234F6789") + "1234" ; + Alcotest.(check string) + "prefix" + (Selective_string_validator.longest_valid_prefix "12345678F") + "12345678" ; + Alcotest.(check string) + "prefix" + (Selective_string_validator.longest_valid_prefix "FFFFFFFFF") + "" + + (** Tests that validation does not fail for an empty string. *) + let test_validate_with_empty_string () = E.UTF8_XML.validate "" + + let test_validate_with_incomplete_string () = + Alcotest.check_raises "Validation fails correctly for an incomplete string" + E.String_incomplete (fun () -> E.UTF8_XML.validate "\xc2" + ) + + let test_validate_with_failing_decoders () = + Failing_string_validator.validate "" ; + assert_raises_match + (function E.Validation_error (0, Decode_error) -> true | _ -> false) + (fun () -> Selective_string_validator.validate "F") ; + assert_raises_match + (function E.Validation_error (0, Decode_error) -> true | _ -> false) + (fun () -> Selective_string_validator.validate "F12345678") ; + assert_raises_match + (function E.Validation_error (4, Decode_error) -> true | _ -> false) + (fun () -> Selective_string_validator.validate "0123F5678") ; + assert_raises_match + (function E.Validation_error (8, Decode_error) -> true | _ -> false) + (fun () -> Selective_string_validator.validate "01234567F") ; + assert_raises_match + (function E.Validation_error (0, Decode_error) -> true | _ -> false) + (fun () -> Selective_string_validator.validate "FFFFFFFFF") + + let tests = + [ + ("test_is_valid", `Quick, test_is_valid) + ; ("test_longest_valid_prefix", `Quick, test_longest_valid_prefix) + ; ( "test_validate_with_empty_string" + , `Quick + , test_validate_with_empty_string + ) + ; ( "test_validate_with_incomplete_string" + , `Quick + , test_validate_with_incomplete_string + ) + ; ( "test_validate_with_failing_decoders" + , `Quick + , test_validate_with_failing_decoders + ) + ] +end + +module XML = struct + include E.XML + + let test_is_illegal_control_character () = + assert_true (is_illegal_control_character (Uchar.of_int 0x00)) ; + assert_true (is_illegal_control_character (Uchar.of_int 0x19)) ; + assert_false (is_illegal_control_character (Uchar.of_int 0x09)) ; + assert_false (is_illegal_control_character (Uchar.of_int 0x0a)) ; + assert_false (is_illegal_control_character (Uchar.of_int 0x0d)) ; + assert_false (is_illegal_control_character (Uchar.of_int 0x20)) + + let tests = + [ + ( "test_is_illegal_control_character" + , `Quick + , test_is_illegal_control_character + ) + ] +end + +(** Tests the XML-specific UTF-8 UCS validation function. *) +module XML_UTF8_UCS_validator = struct + include E.XML_UTF8_UCS_validator + + let validate uchar = + if Uchar.is_valid uchar then + validate @@ Uchar.of_int uchar + else if uchar < Uchar.to_int Uchar.min || uchar > Uchar.to_int Uchar.max + then + raise E.UCS_value_out_of_range + else + raise E.UCS_value_prohibited_in_UTF8 + + let test_validate () = + let value = ref (UCS.min_value --- 1) in + while !value <= UCS.max_value +++ 1 do + if UCS.is_out_of_range !value then + Alcotest.check_raises "should fail" E.UCS_value_out_of_range (fun () -> + validate !value + ) + else if UCS.is_non_character !value || UCS.is_surrogate !value then + Alcotest.check_raises "should fail" E.UCS_value_prohibited_in_UTF8 + (fun () -> validate !value + ) + else if + Uchar.is_valid !value + && XML.is_illegal_control_character (Uchar.of_int !value) + then + Alcotest.check_raises "should fail" E.UCS_value_prohibited_in_XML + (fun () -> validate !value + ) + else + validate !value ; + value := !value +++ 1 + done + + let tests = [("test_validate", `Quick, test_validate)] +end + +module UTF8_codec = struct + (** A list of canonical encoding widths of UCS values, + represented by tuples of the form (v, w), where: + v = the UCS character value to be encoded; and + w = the width of the encoded character, in bytes. *) + let valid_ucs_value_widths = + [ + (1, 1) + ; ((1 <<< 7) --- 1, 1) + ; (1 <<< 7, 2) + ; ((1 <<< 11) --- 1, 2) + ; (1 <<< 11, 3) + ; ((1 <<< 16) --- 1, 3) + ; (1 <<< 16, 4) + ; ((1 <<< 21) --- 1, 4) + ] + + let width_required_for_ucs_value value = + if value < 0x000080 (* 1 lsl 7 *) then + 1 + else if value < 0x000800 (* 1 lsl 11 *) then + 2 + else if value < 0x010000 (* 1 lsl 16 *) then + 3 + else + 4 + + let test_width_required_for_ucs_value () = + List.iter + (fun (value, width) -> + Alcotest.(check int) + "same ints" + (width_required_for_ucs_value value) + width + ) + valid_ucs_value_widths + + (** A list of valid header byte decodings, represented by + tuples of the form (b, (v, w)), where: + b = a valid header byte; + v = the (partial) value contained within the byte; and + w = the total width of the encoded character, in bytes. *) + let valid_header_byte_decodings = + [ + (0b00000000, (0b00000000, 1)) + ; (0b00000001, (0b00000001, 1)) + ; (0b01111111, (0b01111111, 1)) + ; (0b11000000, (0b00000000, 2)) + ; (0b11000001, (0b00000001, 2)) + ; (0b11011111, (0b00011111, 2)) + ; (0b11100000, (0b00000000, 3)) + ; (0b11100001, (0b00000001, 3)) + ; (0b11101111, (0b00001111, 3)) + ; (0b11110000, (0b00000000, 4)) + ; (0b11110001, (0b00000001, 4)) + ; (0b11110111, (0b00000111, 4)) + ] + + (** A list of invalid header bytes that should not be decodable. *) + let invalid_header_bytes = + [ + 0b10000000 + ; 0b10111111 + ; 0b11111000 + ; 0b11111011 + ; 0b11111100 + ; 0b11111101 + ; 0b11111110 + ; 0b11111111 + ] + + (** A list of valid continuation byte decodings, represented + by tuples of the form (b, v), where: + b = a valid continuation byte; and + v = the partial value contained within the byte. *) + let valid_continuation_byte_decodings = + [ + (0b10000000, 0b00000000) + ; (0b10000001, 0b00000001) + ; (0b10111110, 0b00111110) + ; (0b10111111, 0b00111111) + ] + + (** A list of invalid continuation bytes that should not be decodable. *) + let invalid_continuation_bytes = + [ + 0b00000000 + ; 0b01111111 + ; 0b11000000 + ; 0b11011111 + ; 0b11100000 + ; 0b11101111 + ; 0b11110000 + ; 0b11110111 + ; 0b11111000 + ; 0b11111011 + ; 0b11111100 + ; 0b11111101 + ; 0b11111111 + ; 0b11111110 + ] + + (** A list of valid character decodings represented by + tuples of the form (s, (v, w)), where: + + s = a validly-encoded UTF-8 string; + v = the UCS value represented by the string; + (which may or may not be valid in its own right) + w = the width of the encoded string, in bytes. + + For each byte length b in [1...4], the list contains + decodings for: + + v_min = the smallest UCS value encodable in b bytes. + v_max = the greatest UCS value encodable in b bytes. *) + let valid_character_decodings = + [ + (* 7654321 *) + (* 0b0xxxxxxx *) + (* 00000000000000xxxxxxx *) + ( "\x00" (* 0b00000000 *) + , (0b000000000000000000000, 1) + ) + ; ( "\x7f" (* 0b01111111 *) + , (0b000000000000001111111, 1) + ) + ; (* 10987654321 *) + (* 0b110xxxsx 0b10xxxxxx *) + (* 0000000000xxxsxxxxxxx *) + ( "\xc2\x80" (* 0b11000010 0b10000000 *) + , (0b000000000000010000000, 2) + ) + ; ( "\xdf\xbf" (* 0b11011111 0b10111111 *) + , (0b000000000011111111111, 2) + ) + ; (* 6543210987654321 *) + (* 0b1110xxxx 0b10sxxxxx 0b10xxxxxx *) + (* xxxxsxxxxxxxxxxx *) + ( "\xe0\xa0\x80" (* 0b11100000 0b10100000 0b10000000 *) + , (0b000000000100000000000, 3) + ) + ; ( "\xef\xbf\xbf" (* 0b11101111 0b10111111 0b10111111 *) + , (0b000001111111111111111, 3) + ) + ; (* 109876543210987654321 *) + (* 0b11110xxx 0b10xsxxxx 0b10xxxxxx 0b10xxxxxx *) + (* xxxxsxxxxxxxxxxxxxxxx *) + ( "\xf0\x90\x80\x80" (* 0b11110000 0b10010000 0b10000000 0b10000000 *) + , (0b000010000000000000000, 4) + ) + ; ( "\xf7\xbf\xbf\xbf" (* 0b11110111 0b10111111 0b10111111 0b10111111 *) + , (0b111111111111111111111, 4) + ) + ] + + let uchar = Alcotest.int + + let test_decode_character_when_valid () = + List.iter + (fun (string, (value, width)) -> + Alcotest.(check (pair uchar int)) + "same pair" + (Lenient_UTF8_codec.decode_character string 0) + (value, width) + ) + valid_character_decodings + + (** A list of strings containing overlong character encodings. + For each byte length b in [2...4], this list contains the + overlong encoding e (v), where v is the UCS value one less + than the smallest UCS value validly-encodable in b bytes. *) + let overlong_character_encodings = + [ + "\xc1\xbf" (* 0b11000001 0b10111111 *) + ; "\xe0\x9f\xbf" (* 0b11100000 0b10011111 0b10111111 *) + ; "\xf0\x8f\xbf\xbf" (* 0b11110000 0b10001111 0b10111111 0b10111111 *) + ] + + let test_decode_character_when_overlong () = + List.iter + (fun string -> + Alcotest.check_raises "should fail" E.UTF8_encoding_not_canonical + (fun () -> Lenient_UTF8_codec.decode_character string 0 |> ignore + ) + ) + overlong_character_encodings + + let tests = + [ + ( "test_width_required_for_ucs_value" + , `Quick + , test_width_required_for_ucs_value + ) + ; ( "test_decode_character_when_valid" + , `Quick + , test_decode_character_when_valid + ) + ; ( "test_decode_character_when_overlong" + , `Quick + , test_decode_character_when_overlong + ) + ] +end + +let () = + Alcotest.run "Encodings" + [ + ("UCS", UCS.tests) + ; ("XML", XML.tests) + ; ("String_validator", String_validator.tests) + ; ("XML_UTF8_UCS_validator", XML_UTF8_UCS_validator.tests) + ; ("UTF8_codec", UTF8_codec.tests) + ] diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/dune new file mode 100644 index 00000000000..2a12545a2b9 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/dune @@ -0,0 +1,7 @@ +(library + (name xapi_stdext_pervasives) + (public_name xapi-stdext-pervasives) + (libraries + logs + xapi-backtrace) +) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.ml new file mode 100644 index 00000000000..7d8e16c4346 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.ml @@ -0,0 +1,69 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) +(** apply the clean_f function after fct function has been called. + * Even if fct raises an exception, clean_f is applied +*) + +let src = + Logs.Src.create "pervasiveext" + ~doc:"logs from Xapi_stdext_pervasives.Pervasiveext" + +let finally fct clean_f = + let result = + try fct () + with exn -> + Backtrace.is_important exn ; + ( try + (* We catch and log exceptions raised by clean_f to avoid shadowing + the original exception raised by fct *) + clean_f () + with cleanup_exn -> + Logs.warn ~src (fun m -> + m + "finally: Error while running cleanup after failure of main \ + function: %s" + (Printexc.to_string cleanup_exn) + ) + ) ; + raise exn + in + clean_f () ; result + +(** execute fct ignoring exceptions *) +let ignore_exn fct = try fct () with _ -> () + +(* non polymorphic ignore function *) +let ignore_int v = + let (_ : int) = v in + () + +let ignore_int64 v = + let (_ : int64) = v in + () + +let ignore_int32 v = + let (_ : int32) = v in + () + +let ignore_string v = + let (_ : string) = v in + () + +let ignore_float v = + let (_ : float) = v in + () + +let ignore_bool v = + let (_ : bool) = v in + () diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.mli new file mode 100644 index 00000000000..4190071de07 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.mli @@ -0,0 +1,31 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) + +val finally : (unit -> 'a) -> (unit -> unit) -> 'a +(** [finally f g] returns [f ()] guaranteeing to run clean-up actions + [g ()] even if [f ()] throws an exception. *) + +val ignore_exn : (unit -> unit) -> unit + +val ignore_int : int -> unit + +val ignore_int32 : int32 -> unit + +val ignore_int64 : int64 -> unit + +val ignore_string : string -> unit + +val ignore_float : float -> unit + +val ignore_bool : bool -> unit diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/dune new file mode 100644 index 00000000000..dd8393a4427 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/dune @@ -0,0 +1,11 @@ +(library + (public_name xapi-stdext-std) + (name xapi_stdext_std) + (modules :standard \ xstringext_test listext_test) +) +(tests + (names xstringext_test listext_test) + (package xapi-stdext-std) + (modules xstringext_test listext_test) + (libraries xapi_stdext_std alcotest) +) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml new file mode 100644 index 00000000000..39ebb6c6ea6 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml @@ -0,0 +1,203 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) + +module List = struct + open! List + + (** Turn a list into a set *) + let rec setify = function + | [] -> + [] + | x :: xs -> + if mem x xs then setify xs else x :: setify xs + + let subset s1 s2 = + List.fold_left ( && ) true (List.map (fun s -> List.mem s s2) s1) + + let set_equiv s1 s2 = subset s1 s2 && subset s2 s1 + + let iteri_right f list = iteri f (rev list) + + let rec inv_assoc k = function + | [] -> + raise Not_found + | (v, k') :: _ when k = k' -> + v + | _ :: t -> + inv_assoc k t + + (* Tail-recursive map. *) + let map_tr f l = rev (rev_map f l) + + let count pred l = + fold_left (fun count e -> count + if pred e then 1 else 0) 0 l + + let position pred l = + let aux (i, is) e = (i + 1, if pred e then i :: is else is) in + snd (fold_left aux (0, []) l) + + let rev_mapi f l = + let rec aux n accu = function + | h :: t -> + aux (n + 1) (f n h :: accu) t + | [] -> + accu + in + aux 0 [] l + + let mapi_tr f l = rev (rev_mapi f l) + + let take n list = + let rec loop i acc = function + | x :: xs when i < n -> + loop (i + 1) (x :: acc) xs + | _ -> + List.rev acc + in + loop 0 [] list + + let drop n list = + let rec loop i = function + | _ :: xs when i < n -> + loop (i + 1) xs + | l -> + l + in + loop 0 list + + let sub i j l = drop i l |> take (j - max i 0) + + let rec chop i l = + match (i, l) with + | j, _ when j < 0 -> + invalid_arg "chop: index cannot be negative" + | 0, l -> + ([], l) + | _, h :: t -> + (fun (fr, ba) -> (h :: fr, ba)) (chop (i - 1) t) + | _, [] -> + invalid_arg "chop: index not in list" + + let rev_chop i l = + let rec aux i fr ba = + match (i, fr, ba) with + | i, _, _ when i < 0 -> + invalid_arg "rev_chop: index cannot be negative" + | 0, fr, ba -> + (fr, ba) + | i, fr, h :: t -> + aux (i - 1) (h :: fr) t + | _ -> + invalid_arg "rev_chop" + in + aux i [] l + + let chop_tr i l = (fun (fr, ba) -> (rev fr, ba)) (rev_chop i l) + + let rec dice m l = + match chop m l with l, [] -> [l] | l1, l2 -> l1 :: dice m l2 + + let remove i l = + match rev_chop i l with + | rfr, _ :: t -> + rev_append rfr t + | _ -> + invalid_arg "remove" + + let insert i e l = + match rev_chop i l with rfr, ba -> rev_append rfr (e :: ba) + + let replace i e l = + match rev_chop i l with + | rfr, _ :: t -> + rev_append rfr (e :: t) + | _ -> + invalid_arg "replace" + + let morph i f l = + match rev_chop i l with + | rfr, h :: t -> + rev_append rfr (f h :: t) + | _ -> + invalid_arg "morph" + + let rec between e = function + | [] -> + [] + | [h] -> + [h] + | h :: t -> + h :: e :: between e t + + let between_tr e l = + let rec aux accu e = function + | [] -> + rev accu + | [h] -> + rev (h :: accu) + | h :: t -> + aux (e :: h :: accu) e t + in + aux [] e l + + let inner fold_left2 base f l1 l2 g = + fold_left2 (fun accu e1 e2 -> g accu (f e1 e2)) base l1 l2 + + let rec is_sorted compare list = + match list with + | x :: y :: list -> + if compare x y <= 0 then + is_sorted compare (y :: list) + else + false + | _ -> + true + + let intersect xs ys = List.filter (fun x -> List.mem x ys) xs + + let set_difference a b = List.filter (fun x -> not (List.mem x b)) a + + let assoc_default k l d = Option.value ~default:d (List.assoc_opt k l) + + let map_assoc_with_key op al = List.map (fun (k, v1) -> (k, op k v1)) al + + (* Thanks to sharing we only use linear space. (Roughly double the space needed for the spine of the original list) *) + let rec tails = function [] -> [[]] | _ :: xs as l -> l :: tails xs + + let replace_assoc key new_value existing = + (key, new_value) :: List.filter (fun (k, _) -> k <> key) existing + + let update_assoc update existing = + update @ List.filter (fun (k, _) -> not (List.mem_assoc k update)) existing + + let make_assoc op l = map (fun key -> (key, op key)) l + + let unbox_list l = List.filter_map Fun.id l + + let restrict_with_default default keys al = + make_assoc (fun k -> assoc_default k al default) keys + + let range lower = + let rec aux accu upper = + if lower >= upper then + accu + else + aux ((upper - 1) :: accu) (upper - 1) + in + aux [] + + let find_minimum compare = + let min a b = if compare a b <= 0 then a else b in + function [] -> None | x :: xs -> Some (List.fold_left min x xs) +end diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli new file mode 100644 index 00000000000..d3fcfdf79f0 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli @@ -0,0 +1,173 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) +module List : sig + (** {1 Comparison} *) + + val is_sorted : ('a -> 'a -> int) -> 'a list -> bool + (** [is_sorted cmp l] returns whether [l] is sorted according to [cmp]. *) + + (** {1 Iterators} *) + + val take : int -> 'a list -> 'a list + (** [take n list] returns the first [n] elements of [list] (or less if list + is shorter).*) + + val drop : int -> 'a list -> 'a list + (** [drop n list] returns the list without the first [n] elements of [list] + (or [] if list is shorter). *) + + val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list + (** [rev_map f l] gives the same result as {!Stdlib.List.rev}[ (] + {!Stdlib.List.mapi}[ f l)], but is tail-recursive and more efficient. *) + + val map_tr : ('a -> 'b) -> 'a list -> 'b list + (** [map_tr f l] is {!Stdlib.List.rev}[ (]{!Stdlib.List.rev_map}[ f l)]. *) + + val mapi_tr : (int -> 'a -> 'b) -> 'a list -> 'b list + (** [mapi_tr f l] is {!Stdlib.List.rev}[ (]{!rev_mapi}[ f l)]. *) + + val unbox_list : 'a option list -> 'a list + (** Unbox all values from the option list. *) + + val count : ('a -> bool) -> 'a list -> int + (** Count the number of list elements matching the given predicate. *) + + val position : ('a -> bool) -> 'a list -> int list + (** Find the indices of all elements matching the given predicate. *) + + val iteri_right : (int -> 'a -> unit) -> 'a list -> unit + (** [iteri_right f l] is {!Stdlib.List.iteri}[ f (]{!Stdlib.List.rev}[ l)] *) + + (** {1 List searching} *) + + val find_minimum : ('a -> 'a -> int) -> 'a list -> 'a option + (** [find_minimum cmp l] returns the lowest element in [l] according to + the sort order of [cmp], or [None] if the list is empty. When two ore + more elements match the lowest value, the left-most is returned. *) + + (** {1 Using indices to manipulate lists} *) + + val chop : int -> 'a list -> 'a list * 'a list + (** [chop k l] splits [l] at index [k] to return a pair of lists. Raises + invalid_arg when [i] is negative or greater than the length of [l]. *) + + val rev_chop : int -> 'a list -> 'a list * 'a list + (** [rev_chop k l] splits [l] at index [k] to return a pair of lists, the + first in reverse order. Raises invalid_arg when [i] is negative or + greater than the length of [l]. *) + + val chop_tr : int -> 'a list -> 'a list * 'a list + (** Tail-recursive {!chop}. *) + + val dice : int -> 'a list -> 'a list list + (** [dice k l] splits [l] into lists with [k] elements each. Raises + {!Invalid_arg} if [List.length l] is not divisible by [k]. *) + + val sub : int -> int -> 'a list -> 'a list + (** [sub from to l] returns the sub-list of [l] that starts at index [from] + and ends at [to] or an empty list if [to] is equal or less than [from]. + Negative indices are treated as 0 and indeces higher than [List.length l + - 1] are treated as [List.length l - 1]. *) + + val remove : int -> 'a list -> 'a list + (** Remove the element at the given index. *) + + val insert : int -> 'a -> 'a list -> 'a list + (** Insert the given element at the given index. *) + + val replace : int -> 'a -> 'a list -> 'a list + (** Replace the element at the given index with the given value. *) + + val morph : int -> ('a -> 'a) -> 'a list -> 'a list + (** Apply the given function to the element at the given index. *) + + (** {1 Association Lists} *) + + val make_assoc : ('a -> 'b) -> 'a list -> ('a * 'b) list + + val assoc_default : 'a -> ('a * 'b) list -> 'b -> 'b + (** Act as List.assoc, but return the given default value if the + key is not in the list. *) + + val replace_assoc : 'a -> 'b -> ('a * 'b) list -> ('a * 'b) list + (** Replace the value belonging to a key in an association list. Adds the key/value pair + if it does not yet exist in the list. If the same key occurs multiple time in the original + list, all occurances are removed and replaced by a single new key/value pair. + This function is useful is the assoc list is used as a lightweight map/hashtable/dictonary. *) + + val update_assoc : ('a * 'b) list -> ('a * 'b) list -> ('a * 'b) list + (** Includes everything from [update] and all key/value pairs from [existing] for + which the key does not exist in [update]. In other words, it is like [replace_assoc] + but then given a whole assoc list of updates rather than a single key/value pair. *) + + val map_assoc_with_key : + ('k -> 'v1 -> 'v2) -> ('k * 'v1) list -> ('k * 'v2) list + (** [map_assoc_with_key op al] transforms every value in [al] based on the + key and the value using [op]. *) + + val inv_assoc : 'a -> ('b * 'a) list -> 'b + (** Perform a lookup on an association list of (value, key) pairs. *) + + val restrict_with_default : 'v -> 'k list -> ('k * 'v) list -> ('k * 'v) list + (** [restrict_with_default default keys al] makes a new association map + from [keys] to previous values for [keys] in [al]. If a key is not found + in [al], the [default] is used. *) + + (** {1 Run-length encoded lists} + There are no known users of these functions. *) + + (** {1 Generative functions} + These are usually useful for coding challenges like Advent of Code.*) + + val range : int -> int -> int list + (** range lower upper = [lower; lower + 1; ...; upper - 1] + Returns the empty list if lower >= upper. + Consider building an {!Stdlib.Seq}, it's more flexible *) + + val between : 'a -> 'a list -> 'a list + (** [between e l] Intersperses [e] between elements of [l]. *) + + val between_tr : 'a -> 'a list -> 'a list + (** Tail-recursive {!between}. *) + + val inner : + (('a -> 'b -> 'c -> 'd) -> 'e -> 'f -> 'g -> 'h) + -> 'e + -> ('b -> 'c -> 'i) + -> 'f + -> 'g + -> ('a -> 'i -> 'd) + -> 'h + (** Compute the inner product of two lists. *) + + val tails : 'a list -> 'a list list + + (** {1 Lists as sets, avoid} + Please use Set.Make instead, these functions have quadratic costs! *) + + val setify : 'a list -> 'a list + (** [setify a] removes all duplicates from [a] while maintaining order. + Please use [List.sort_uniq] instead to deduplicate lists if possible *) + + val subset : 'a list -> 'a list -> bool + (** [subset a b] returns whether all elements in [b] can be found in [a]*) + + val set_equiv : 'a list -> 'a list -> bool + + val set_difference : 'a list -> 'a list -> 'a list + (** Returns the set difference of two lists *) + + val intersect : 'a list -> 'a list -> 'a list + (** Returns the intersection of two lists. *) +end diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext_test.ml new file mode 100644 index 00000000000..2ff7961760e --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext_test.ml @@ -0,0 +1,240 @@ +(* Copyright (C) Citrix Systems Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation; version 2.1 only. with the special + exception on linking described in file LICENSE. + + 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 Lesser General Public License for more details. +*) + +module Listext = Xapi_stdext_std.Listext.List + +let test_list tested_f (name, case, expected) = + let check () = Alcotest.(check @@ list int) name expected (tested_f case) in + (name, `Quick, check) + +let test_option typ tested_f (name, case, expected) = + let check () = Alcotest.(check @@ option typ) name expected (tested_f case) in + (name, `Quick, check) + +let test_chopped_list tested_f (name, case, expected) = + let check () = + Alcotest.(check @@ pair (list int) (list int)) name expected (tested_f case) + in + (name, `Quick, check) + +let test_error tested_f (name, case, expected) = + let check () = Alcotest.check_raises name expected (tested_f case) in + (name, `Quick, check) + +let test_iteri_right = + let specs = + [ + ([], []) + ; ([0], [(0, 0)]) + ; ([2; 4], [(0, 4); (1, 2)]) + ; ([2; 4; 8], [(0, 8); (1, 4); (2, 2)]) + ] + in + let test (list, expected) = + let name = + Printf.sprintf "iteri over from [%s]" + (String.concat "; " (List.map string_of_int list)) + in + let accum = ref [] in + let tested_f = Listext.iteri_right (fun i x -> accum := (i, x) :: !accum) in + let check () = + tested_f list ; + (* reverse the list so the lists in the specs reflect the order of + processing *) + let result = List.rev !accum in + Alcotest.(check @@ list @@ pair int int) name expected result + in + (name, `Quick, check) + in + let tests = List.map test specs in + ("iteri_right", tests) + +let test_take = + let specs = + [ + ([], -1, []) + ; ([], 0, []) + ; ([], 1, []) + ; ([1; 2; 3], -1, []) + ; ([1; 2; 3], 0, []) + ; ([1; 2; 3], 1, [1]) + ; ([1; 2; 3], 2, [1; 2]) + ; ([1; 2; 3], 3, [1; 2; 3]) + ; ([1; 2; 3], 4, [1; 2; 3]) + ; ([1; 2; 3], 5, [1; 2; 3]) + ] + in + let test (whole, number, expected) = + let name = + Printf.sprintf "take %i from [%s]" number + (String.concat "; " (List.map string_of_int whole)) + in + test_list (Listext.take number) (name, whole, expected) + in + let tests = List.map test specs in + ("take", tests) + +let test_drop = + let specs = + [ + ([], -1, []) + ; ([], 0, []) + ; ([], 1, []) + ; ([1; 2; 3], -1, [1; 2; 3]) + ; ([1; 2; 3], 0, [1; 2; 3]) + ; ([1; 2; 3], 1, [2; 3]) + ; ([1; 2; 3], 2, [3]) + ; ([1; 2; 3], 3, []) + ; ([1; 2; 3], 4, []) + ; ([1; 2; 3], 5, []) + ] + in + let test (whole, number, expected) = + let name = + Printf.sprintf "drop %i from [%s]" number + (String.concat "; " (List.map string_of_int whole)) + in + test_list (Listext.drop number) (name, whole, expected) + in + let tests = List.map test specs in + ("drop", tests) + +let test_chop = + let specs = + [ + ([], 0, ([], [])) + ; ([0], 0, ([], [0])) + ; ([0], 1, ([0], [])) + ; ([0; 1], 0, ([], [0; 1])) + ; ([0; 1], 1, ([0], [1])) + ; ([0; 1], 2, ([0; 1], [])) + ] + in + let error_specs = + [ + ([0], -1, Invalid_argument "chop: index cannot be negative") + ; ([0], 2, Invalid_argument "chop: index not in list") + ] + in + let test (whole, number, expected) = + let name = + Printf.sprintf "chop [%s] with %i" + (String.concat "; " (List.map string_of_int whole)) + number + in + test_chopped_list (Listext.chop number) (name, whole, expected) + in + let tests = List.map test specs in + let error_test (whole, number, error) = + let name = + Printf.sprintf "chop [%s] with %i fails" + (String.concat "; " (List.map string_of_int whole)) + number + in + test_error + (fun ls () -> ignore (Listext.chop number ls)) + (name, whole, error) + in + let error_tests = List.map error_test error_specs in + ("chop", tests @ error_tests) + +let test_sub = + let specs = + [ + ([], 0, 0, []) + ; ([], 0, 1, []) + ; ([0], 0, 0, []) + ; ([0], 0, 1, [0]) + ; ([0], 1, 1, []) + ; ([0], 0, 2, [0]) + ; ([0; 1], 0, 0, []) + ; ([0; 1], 0, 1, [0]) + ; ([0; 1], 0, 2, [0; 1]) + ; ([0; 1], 1, 1, []) + ; ([0; 1], 1, 2, [1]) + ; ([0; 1], 2, 2, []) + (* test_cases below used to fail *) [@ocamlformat "disable"] + ; ([0], -1, 0, []) + ; ([0], 0, -1, []) + ; ([0; 1], 1, 0, []) + ] + in + let test (whole, from, until, expected) = + let name = + Printf.sprintf "sub [%s] from %i to %i" + (String.concat "; " (List.map string_of_int whole)) + from until + in + test_list (Listext.sub from until) (name, whole, expected) + in + let tests = List.map test specs in + ("sub", tests) + +let test_find_minimum (name, pp, typ, specs) = + let test ((cmp, cmp_name), input, expected) = + let name = Printf.sprintf "%s of [%s]" cmp_name (pp input) in + test_option typ (Listext.find_minimum cmp) (name, input, expected) + in + let tests = List.map test specs in + (Printf.sprintf "find_minimum (%s)" name, tests) + +let test_find_minimum_int = + let ascending = (Int.compare, "ascending") in + let descending = ((fun a b -> Int.compare b a), "descending") in + let specs_int = + ( "int" + , (fun a -> String.concat "; " (List.map string_of_int a)) + , Alcotest.int + , [ + (ascending, [], None) + ; (ascending, [1; 2; 3; 4; 5], Some 1) + ; (ascending, [2; 3; 1; 5; 4], Some 1) + ; (descending, [], None) + ; (descending, [1; 2; 3; 4; 5], Some 5) + ; (descending, [2; 3; 1; 5; 4], Some 5) + ] + ) + in + test_find_minimum specs_int + +let test_find_minimum_tuple = + let ascending = ((fun (a, _) (b, _) -> Int.compare a b), "ascending") in + let descending = ((fun (a, _) (b, _) -> Int.compare b a), "descending") in + let specs_tuple = + ( "tuple" + , (fun a -> + String.concat "; " + (List.map (fun (a, b) -> "(" ^ string_of_int a ^ ", " ^ b ^ ")") a) + ) + , Alcotest.(pair int string) + , [ + (ascending, [(1, "fst"); (1, "snd")], Some (1, "fst")) + ; (descending, [(1, "fst"); (1, "snd")], Some (1, "fst")) + ; (ascending, [(1, "fst"); (1, "snd"); (2, "nil")], Some (1, "fst")) + ; (descending, [(1, "nil"); (2, "fst"); (2, "snd")], Some (2, "fst")) + ] + ) + in + test_find_minimum specs_tuple + +let () = + Alcotest.run "Listext" + [ + test_iteri_right + ; test_take + ; test_drop + ; test_chop + ; test_sub + ; test_find_minimum_int + ; test_find_minimum_tuple + ] diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml new file mode 100644 index 00000000000..7fb16aba6f8 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml @@ -0,0 +1,223 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) +module String = struct + include String + + let of_char c = String.make 1 c + + let rev_map f string = + let n = length string in + String.init n (fun i -> f string.[n - i - 1]) + + let rev_iter f string = + for i = length string - 1 downto 0 do + f string.[i] + done + + let fold_left f accu string = + let accu = ref accu in + for i = 0 to length string - 1 do + accu := f !accu string.[i] + done ; + !accu + + let fold_right f string accu = + let accu = ref accu in + for i = length string - 1 downto 0 do + accu := f string.[i] !accu + done ; + !accu + + let explode string = fold_right (fun h t -> h :: t) string [] + + let implode list = concat "" (List.map of_char list) + + (** True if string 'x' ends with suffix 'suffix' *) + let endswith suffix x = + let x_l = String.length x and suffix_l = String.length suffix in + suffix_l <= x_l && String.sub x (x_l - suffix_l) suffix_l = suffix + + (** True if string 'x' starts with prefix 'prefix' *) + let startswith prefix x = + let x_l = String.length x and prefix_l = String.length prefix in + prefix_l <= x_l && String.sub x 0 prefix_l = prefix + + (** Returns true for whitespace characters, false otherwise *) + let isspace = function ' ' | '\n' | '\r' | '\t' -> true | _ -> false + + (** Removes all the characters from the ends of a string for which the predicate is true *) + let strip predicate string = + let rec remove = function + | [] -> + [] + | c :: cs -> + if predicate c then remove cs else c :: cs + in + implode (List.rev (remove (List.rev (remove (explode string))))) + + let escaped ?rules string = + match rules with + | None -> + String.escaped string + | Some rules -> + let aux h t = + ( if List.mem_assoc h rules then + List.assoc h rules + else + of_char h + ) + :: t + in + concat "" (fold_right aux string []) + + (** Take a predicate and a string, return a list of strings separated by + runs of characters where the predicate was true (excluding those characters from the result) *) + let split_f p str = + let not_p x = not (p x) in + let rec split_one p acc = function + | [] -> + (List.rev acc, []) + | c :: cs -> + if p c then split_one p (c :: acc) cs else (List.rev acc, c :: cs) + in + let rec alternate acc drop chars = + if chars = [] then + acc + else + let a, b = split_one (if drop then p else not_p) [] chars in + alternate (if drop then acc else a :: acc) (not drop) b + in + List.rev (List.map implode (alternate [] true (explode str))) + + let index_opt s c = + let rec loop i = + if String.length s = i then + None + else if s.[i] = c then + Some i + else + loop (i + 1) + in + loop 0 + + let rec split ?(limit = -1) c s = + let i = match index_opt s c with Some x -> x | None -> -1 in + let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in + if i = -1 || nlimit = 0 then + [s] + else + let a = String.sub s 0 i + and b = String.sub s (i + 1) (String.length s - i - 1) in + a :: split ~limit:nlimit c b + + let rtrim s = + let n = String.length s in + if n > 0 && s.[n - 1] = '\n' then + String.sub s 0 (n - 1) + else + s + + (** has_substr str sub returns true if sub is a substring of str. Simple, naive, slow. *) + let has_substr str sub = + if String.length sub > String.length str then + false + else + let result = ref false in + for start = 0 to String.length str - String.length sub do + if String.sub str start (String.length sub) = sub then result := true + done ; + !result + + (** find all occurences of needle in haystack and return all their respective index *) + let find_all needle haystack = + let m = String.length needle and n = String.length haystack in + if m > n then + [] + else + let i = ref 0 and found = ref [] in + while !i < n - m + 1 do + if String.sub haystack !i m = needle then ( + found := !i :: !found ; + i := !i + m + ) else + incr i + done ; + List.rev !found + + (* replace all @f substring in @s by @t *) + let replace f t s = + let indexes = find_all f s in + let n = List.length indexes in + if n > 0 then ( + let len_f = String.length f and len_t = String.length t in + let new_len = String.length s + (n * len_t) - (n * len_f) in + let new_b = Bytes.make new_len '\000' in + let orig_offset = ref 0 and dest_offset = ref 0 in + List.iter + (fun h -> + let len = h - !orig_offset in + Bytes.blit_string s !orig_offset new_b !dest_offset len ; + Bytes.blit_string t 0 new_b (!dest_offset + len) len_t ; + orig_offset := !orig_offset + len + len_f ; + dest_offset := !dest_offset + len + len_t + ) + indexes ; + Bytes.blit_string s !orig_offset new_b !dest_offset + (String.length s - !orig_offset) ; + Bytes.unsafe_to_string new_b + ) else + s + + let filter_chars s valid = + let badchars = ref false in + let buf = Buffer.create 0 in + for i = 0 to String.length s - 1 do + if !badchars then ( + if valid s.[i] then + Buffer.add_char buf s.[i] + ) else if not (valid s.[i]) then ( + Buffer.add_substring buf s 0 i ; + badchars := true + ) + done ; + if !badchars then Buffer.contents buf else s + + let map_unlikely s f = + let changed = ref false in + let m = ref 0 in + let buf = Buffer.create 0 in + for i = 0 to String.length s - 1 do + match f s.[i] with + | None -> + () + | Some n -> + changed := true ; + Buffer.add_substring buf s !m (i - !m) ; + Buffer.add_string buf n ; + m := i + 1 + done ; + if !changed then ( + Buffer.add_substring buf s !m (String.length s - !m) ; + Buffer.contents buf + ) else + s + + let sub_to_end s start = + let length = String.length s in + String.sub s start (length - start) + + let sub_before c s = String.sub s 0 (String.index s c) + + let sub_after c s = sub_to_end s (String.index s c + 1) +end diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.mli new file mode 100644 index 00000000000..e2587929916 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.mli @@ -0,0 +1,88 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) +module String : sig + include module type of String + + val of_char : char -> string + + val rev_map : (char -> char) -> string -> string + (** Map a string to a string, applying the given function in reverse + order. *) + + val rev_iter : (char -> unit) -> string -> unit + (** Iterate over the characters in a string in reverse order. *) + + val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a + (** Fold over the characters in a string. *) + + val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a + (** Iterate over the characters in a string in reverse order. *) + + val explode : string -> char list + (** Split a string into a list of characters. *) + + val implode : char list -> string + (** Concatenate a list of characters into a string. *) + + val endswith : string -> string -> bool + (** True if string 'x' ends with suffix 'suffix' *) + + val startswith : string -> string -> bool + (** True if string 'x' starts with prefix 'prefix' *) + + val isspace : char -> bool + (** True if the character is whitespace *) + + val strip : (char -> bool) -> string -> string + (** Removes all the characters from the ends of a string for which the predicate is true *) + + val escaped : ?rules:(char * string) list -> string -> string + (** Backward-compatible string escaping, defaulting to the built-in + OCaml string escaping but allowing an arbitrary mapping from characters + to strings. *) + + val split_f : (char -> bool) -> string -> string list + (** Take a predicate and a string, return a list of strings separated by + runs of characters where the predicate was true *) + + val split : ?limit:int -> char -> string -> string list + (** split a string on a single char *) + + val rtrim : string -> string + (** FIXME document me|remove me if similar to strip *) + + val has_substr : string -> string -> bool + (** True if sub is a substr of str *) + + val find_all : string -> string -> int list + (** find all occurences of needle in haystack and return all their respective index *) + + val replace : string -> string -> string -> string + (** replace all [f] substring in [s] by [t] *) + + val filter_chars : string -> (char -> bool) -> string + (** filter chars from a string *) + + val map_unlikely : string -> (char -> string option) -> string + (** map a string trying to fill the buffer by chunk *) + + val sub_to_end : string -> int -> string + (** a substring from the specified position to the end of the string *) + + val sub_before : char -> string -> string + (** a substring from the start of the string to the first occurrence of a given character, excluding the character *) + + val sub_after : char -> string -> string + (** a substring from the first occurrence of a given character to the end of the string, excluding the character *) +end diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext_test.ml new file mode 100644 index 00000000000..7d2766cbaf4 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext_test.ml @@ -0,0 +1,197 @@ +(* Copyright (C) Citrix Systems Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation; version 2.1 only. with the special + exception on linking described in file LICENSE. + + 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 Lesser General Public License for more details. +*) + +module XString = Xapi_stdext_std.Xstringext.String + +let test_boolean tested_f (name, case, expected) = + let check () = Alcotest.(check bool) name expected (tested_f case) in + (name, `Quick, check) + +let test_string tested_f (name, case, expected) = + let check () = Alcotest.(check string) name expected (tested_f case) in + (name, `Quick, check) + +let test_list tested_f (name, case, expected) = + let check () = + Alcotest.(check @@ list string) name expected (tested_f case) + in + (name, `Quick, check) + +let test_rev_map = + let spec_rev = [("", ""); ("foo bar", "rab oof")] in + let spec_func = [("id", Fun.id); ("uppercase_ascii", Char.uppercase_ascii)] in + let test (f_name, f) (case, expected) = + let expected = String.map f expected in + let name = + Printf.sprintf {|"%s" produces "%s" (%s)|} case expected f_name + in + test_string (XString.rev_map f) (name, case, expected) + in + let tests = + (* Generate the product of the two lists to generate the tests *) + List.concat (List.map (fun func -> List.map (test func) spec_rev) spec_func) + in + ("rev_map", tests) + +let test_split = + let test ?limit (splitter, splitted, expected) = + let split, name = + match limit with + | None -> + let name = Printf.sprintf {|'%c' splits "%s"|} splitter splitted in + (* limit being set to -1 is the same as not using the parameter *) + let split = XString.split ~limit:(-1) in + (split, name) + | Some limit -> + let name = + Printf.sprintf {|'%c' splits "%s" with limit %i|} splitter splitted + limit + in + let split = XString.split ~limit in + (split, name) + in + test_list (split splitter) (name, splitted, expected) + in + let specs_no_limit = + [ + ('.', "...", [""; ""; ""; ""]); ('.', "foo.bar.baz", ["foo"; "bar"; "baz"]) + ] + in + let tests_no_limit = List.map test specs_no_limit in + let specs_limit = + [ + (0, [('.', "...", ["..."]); ('.', "foo.bar.baz", ["foo.bar.baz"])]) + ; (1, [('.', "...", ["..."]); ('.', "foo.bar.baz", ["foo.bar.baz"])]) + ; (2, [('.', "...", [""; ".."]); ('.', "foo.bar.baz", ["foo"; "bar.baz"])]) + ; ( 3 + , [ + ('.', "...", [""; ""; "."]) + ; ('.', "foo.bar.baz", ["foo"; "bar"; "baz"]) + ] + ) + ; (4, [('.', "...", [""; ""; ""; ""])]) + ] + in + let tests_limit = + List.map (fun (limit, spec) -> List.map (test ~limit) spec) specs_limit + |> List.concat + in + ("split", List.concat [tests_no_limit; tests_limit]) + +let test_split_f = + let specs = + [ + (XString.isspace, "foo bar", ["foo"; "bar"]) + ; (XString.isspace, "foo bar", ["foo"; "bar"]) + ; (XString.isspace, "foo \n\t\r bar", ["foo"; "bar"]) + ; (XString.isspace, " foo bar ", ["foo"; "bar"]) + ; (XString.isspace, "", []) + ; (XString.isspace, " ", []) + ] + in + let test (splitter, splitted, expected) = + let name = Printf.sprintf {|"%s"|} (String.escaped splitted) in + test_list (XString.split_f splitter) (name, splitted, expected) + in + let tests = List.map test specs in + ("split_f", tests) + +let test_has_substr = + let spec = + [ + ("", "", true) + ; ("", "foo bar", true) + ; ("f", "foof", true) + ; ("foofo", "foof", false) + ; ("foof", "foof", true) + ; ("f", "foof", true) + ; ("fo", "foof", true) + ; ("of", "foof", true) + ; ("ff", "foof", false) + ] + in + let test (contained, container, expected) = + let name = Printf.sprintf {|"%s" in "%s"|} contained container in + test_boolean (XString.has_substr container) (name, contained, expected) + in + ("has_substr", List.map test spec) + +let test_startswith = + let spec = + [ + ("", "", true) + ; ("", "foo bar", true) + ; ("foofo", "foof", false) + ; ("foof", "foof", true) + ; ("f", "foof", true) + ; ("fo", "foof", true) + ; ("of", "foof", false) + ; ("ff", "foof", false) + ] + in + let test (contained, container, expected) = + let name = Printf.sprintf {|"%s" starts with "%s"|} container contained in + test_boolean (XString.startswith contained) (name, container, expected) + in + ("startswith", List.map test spec) + +let test_endswith = + let spec = + [ + ("", "", true) + ; ("", "foo bar", true) + ; ("ofoof", "foof", false) + ; ("foof", "foof", true) + ; ("f", "foof", true) + ; ("fo", "foof", false) + ; ("of", "foof", true) + ; ("ff", "foof", false) + ] + in + let test (contained, container, expected) = + let name = Printf.sprintf {|"%s" ends with "%s"|} container contained in + test_boolean (XString.endswith contained) (name, container, expected) + in + ("endswith", List.map test spec) + +let test_rtrim = + let spec = + [ + ("", "") + ; ("\n", "") + ; ("\n\n", "\n") + ; ("\n ", "\n ") + ; ("foo\n", "foo") + ; ("fo\no", "fo\no") + ] + in + let test (case, expected) = + let name = + Printf.sprintf {|"%s" gets trimmed to "%s"|} (String.escaped case) + (String.escaped expected) + in + test_string XString.rtrim (name, case, expected) + in + ("rtrim", List.map test spec) + +let () = + Alcotest.run "Xstringext" + [ + test_rev_map + ; test_split + ; test_split_f + ; test_has_substr + ; test_startswith + ; test_endswith + ; test_rtrim + ] diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune new file mode 100644 index 00000000000..fe2cc6dd85a --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune @@ -0,0 +1,8 @@ +(library + (public_name xapi-stdext-threads) + (name xapi_stdext_threads) + (libraries + threads.posix + unix + xapi-stdext-pervasives) +) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/semaphore.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/semaphore.ml new file mode 100644 index 00000000000..06621049c91 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/semaphore.ml @@ -0,0 +1,57 @@ +(* + * Copyright (C) Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) + +type t = {mutable n: int; m: Mutex.t; c: Condition.t} + +let create n = + if n <= 0 then + invalid_arg (Printf.sprintf "Semaphore value must be positive, got %d" n) ; + let m = Mutex.create () and c = Condition.create () in + {n; m; c} + +exception Inconsistent_state of string + +let inconsistent_state fmt = + Printf.ksprintf (fun msg -> raise (Inconsistent_state msg)) fmt + +let acquire s k = + if k <= 0 then + invalid_arg + (Printf.sprintf "Semaphore acquisition requires a positive value, got %d" + k + ) ; + Mutex.lock s.m ; + while s.n < k do + Condition.wait s.c s.m + done ; + if not (s.n >= k) then + inconsistent_state "Semaphore value cannot be smaller than %d, got %d" k s.n ; + s.n <- s.n - k ; + Condition.signal s.c ; + Mutex.unlock s.m + +let release s k = + if k <= 0 then + invalid_arg + (Printf.sprintf "Semaphore release requires a positive value, got %d" k) ; + Mutex.lock s.m ; + s.n <- s.n + k ; + Condition.signal s.c ; + Mutex.unlock s.m + +let execute_with_weight s k f = + acquire s k ; + Xapi_stdext_pervasives.Pervasiveext.finally f (fun () -> release s k) + +let execute s f = execute_with_weight s 1 f diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/semaphore.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/semaphore.mli new file mode 100644 index 00000000000..207e612032d --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/semaphore.mli @@ -0,0 +1,40 @@ +(* + * Copyright (C) Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) + +type t + +exception Inconsistent_state of string + +val create : int -> t +(** [create n] create a semaphore with initial value [n] (a positive integer). + Raise {!Invalid_argument} if [n] <= 0 *) + +val acquire : t -> int -> unit +(** [acquire k s] block until the semaphore value is >= [k] (a positive integer), + then atomically decrement the semaphore value by [k]. + Raise {!Invalid_argument} if [k] <= 0 *) + +val release : t -> int -> unit +(** [release k s] atomically increment the semaphore value by [k] (a positive + integer). + Raise {!Invalid_argument} if [k] <= 0 *) + +val execute_with_weight : t -> int -> (unit -> 'a) -> 'a +(** [execute_with_weight s k f] {!acquire} the semaphore with [k], + then run [f ()], and finally {!release} the semaphore with the same value [k] + (even in case of failure in the execution of [f]). + Return the value of [f ()] or re-raise the exception if any. *) + +val execute : t -> (unit -> 'a) -> 'a +(** [execute s f] same as [{execute_with_weight} s 1 f] *) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml new file mode 100644 index 00000000000..56025d51154 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.ml @@ -0,0 +1,113 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) + +module M = Mutex + +module Mutex = struct + (** execute the function f with the mutex hold *) + let execute lock f = + Mutex.lock lock ; + Xapi_stdext_pervasives.Pervasiveext.finally f (fun () -> Mutex.unlock lock) +end + +(** Parallel List.iter. Remembers all exceptions and returns an association list mapping input x to an exception. + Applications of x which succeed will be missing from the returned list. *) +let thread_iter_all_exns f xs = + let exns = ref [] in + let m = M.create () in + List.iter Thread.join + (List.map + (fun x -> + Thread.create + (fun () -> + try f x + with e -> Mutex.execute m (fun () -> exns := (x, e) :: !exns) + ) + () + ) + xs + ) ; + !exns + +(** Parallel List.iter. Remembers one exception (at random) and throws it in the + error case. *) +let thread_iter f xs = + match thread_iter_all_exns f xs with [] -> () | (_, e) :: _ -> raise e + +module Delay = struct + (* Concrete type is the ends of a pipe *) + type t = { + (* A pipe is used to wake up a thread blocked in wait: *) + mutable pipe_out: Unix.file_descr option + ; mutable pipe_in: Unix.file_descr option + ; (* Indicates that a signal arrived before a wait: *) + mutable signalled: bool + ; m: M.t + } + + let make () = + {pipe_out= None; pipe_in= None; signalled= false; m= M.create ()} + + exception Pre_signalled + + let wait (x : t) (seconds : float) = + let finally = Xapi_stdext_pervasives.Pervasiveext.finally in + let to_close = ref [] in + let close' fd = + if List.mem fd !to_close then Unix.close fd ; + to_close := List.filter (fun x -> fd <> x) !to_close + in + finally + (fun () -> + try + let pipe_out = + Mutex.execute x.m (fun () -> + if x.signalled then ( + x.signalled <- false ; + raise Pre_signalled + ) ; + let pipe_out, pipe_in = Unix.pipe () in + (* these will be unconditionally closed on exit *) + to_close := [pipe_out; pipe_in] ; + x.pipe_out <- Some pipe_out ; + x.pipe_in <- Some pipe_in ; + x.signalled <- false ; + pipe_out + ) + in + let r, _, _ = Unix.select [pipe_out] [] [] seconds in + (* flush the single byte from the pipe *) + if r <> [] then ignore (Unix.read pipe_out (Bytes.create 1) 0 1) ; + (* return true if we waited the full length of time, false if we were woken *) + r = [] + with Pre_signalled -> false + ) + (fun () -> + Mutex.execute x.m (fun () -> + x.pipe_out <- None ; + x.pipe_in <- None ; + List.iter close' !to_close + ) + ) + + let signal (x : t) = + Mutex.execute x.m (fun () -> + match x.pipe_in with + | Some fd -> + ignore (Unix.write fd (Bytes.of_string "X") 0 1) + | None -> + x.signalled <- true + (* If the wait hasn't happened yet then store up the signal *) + ) +end diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.mli new file mode 100644 index 00000000000..8349ab71366 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/threadext.mli @@ -0,0 +1,35 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) +module Mutex : sig + val execute : Mutex.t -> (unit -> 'a) -> 'a +end + +val thread_iter_all_exns : ('a -> unit) -> 'a list -> ('a * exn) list + +val thread_iter : ('a -> unit) -> 'a list -> unit + +module Delay : sig + type t + + val make : unit -> t + + val wait : t -> float -> bool + (** Blocks the calling thread for a given period of time with the option of + returning early if someone calls 'signal'. Returns true if the full time + period elapsed and false if signalled. Note that multple 'signals' are + coalesced; 'signals' sent before 'wait' is called are not lost. *) + + val signal : t -> unit + (** Sends a signal to a waiting thread. See 'wait' *) +end diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/blkgetsize.h b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/blkgetsize.h new file mode 100644 index 00000000000..a9cd75bfedc --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/blkgetsize.h @@ -0,0 +1,6 @@ +#ifndef BLKGETSIZE_H +#define BLKGETSIZE_H + +#include +int stdext_blkgetsize(int fd, uint64_t *psize); +#endif diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/blkgetsize_stubs.c b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/blkgetsize_stubs.c new file mode 100644 index 00000000000..0324f3dfb3f --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/blkgetsize_stubs.c @@ -0,0 +1,78 @@ +/* + * Copyright (C) 2012-2013 Citrix Inc + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + */ + +#include +#include +#include + +#include +#include +#include +#include + +#include +#include +#include +#include +#include +#include + +#include "blkgetsize.h" +#ifdef __linux__ +#include + +int stdext_blkgetsize(int fd, uint64_t *psize) +{ +#ifdef BLKGETSIZE64 + int ret = ioctl(fd, BLKGETSIZE64, psize); +#elif BLKGETSIZE + unsigned long sectors = 0; + int ret = ioctl(fd, BLKGETSIZE, §ors); + *psize = sectors * 512ULL; +#else +# error "Linux configuration error (blkgetsize)" +#endif + return ret; +} + +#elif defined(__APPLE__) +#include + +int stdext_blkgetsize(int fd, uint64_t *psize) +{ + unsigned long blocksize = 0; + int ret = ioctl(fd, DKIOCGETBLOCKSIZE, &blocksize); + if (!ret) { + unsigned long nblocks; + ret = ioctl(fd, DKIOCGETBLOCKCOUNT, &nblocks); + if (!ret) + *psize = (uint64_t)nblocks * blocksize; + } + return ret; +} + +#elif defined(__FreeBSD__) +#include + +int stdext_blkgetsize(int fd, uint64_t *psize) +{ + int ret = ioctl(fd, DIOCGMEDIASIZE, psize); + return ret; +} + +#else +# error "Unable to query block device size: unsupported platform, please report." +#endif diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune new file mode 100644 index 00000000000..da0b509d2d2 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune @@ -0,0 +1,16 @@ +(library + (name xapi_stdext_unix) + (public_name xapi-stdext-unix) + (libraries + fd-send-recv + unix + xapi-backtrace + xapi-stdext-pervasives) + (foreign_stubs + (language c) + (names + blkgetsize_stubs + unixext_open_stubs + unixext_stubs + unixext_write_stubs)) +) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml new file mode 100644 index 00000000000..4cf628d45e9 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -0,0 +1,819 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) +open Xapi_stdext_pervasives.Pervasiveext + +exception Unix_error of int + +let _exit = Unix._exit + +(** remove a file, but doesn't raise an exception if the file is already removed *) +let unlink_safe file = + try Unix.unlink file with (* Unix.Unix_error (Unix.ENOENT, _ , _)*) _ -> () + +(** create a directory but doesn't raise an exception if the directory already exist *) +let mkdir_safe dir perm = + try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> () + +(** create a directory, and create parent if doesn't exist *) +let mkdir_rec dir perm = + let rec p_mkdir dir = + let p_name = Filename.dirname dir in + if p_name <> "/" && p_name <> "." then + p_mkdir p_name ; + mkdir_safe dir perm + in + p_mkdir dir + +(** removes a file or recursively removes files/directories below a directory without following + symbolic links. If path is a directory, it is only itself removed if rm_top is true. If path + is non-existent nothing happens, it does not lead to an error. *) +let rm_rec ?(rm_top = true) path = + let ( // ) = Filename.concat in + let rec rm rm_top path = + match Unix.lstat path with + | exception Unix.Unix_error (Unix.ENOENT, _, _) -> + () (*noop*) + | exception e -> + raise e + | st -> ( + match st.Unix.st_kind with + | Unix.S_DIR -> + Sys.readdir path |> Array.iter (fun file -> rm true (path // file)) ; + if rm_top then Unix.rmdir path + | _ -> + Unix.unlink path + ) + in + rm rm_top path + +(** write a pidfile file *) +let pidfile_write filename = + let fd = + Unix.openfile filename [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC] 0o640 + in + finally + (fun () -> + let pid = Unix.getpid () in + let buf = string_of_int pid ^ "\n" in + let len = String.length buf in + if Unix.write fd (Bytes.unsafe_of_string buf) 0 len <> len then + failwith "pidfile_write failed" + ) + (fun () -> Unix.close fd) + +(** read a pidfile file, return either Some pid or None *) +let pidfile_read filename = + let fd = Unix.openfile filename [Unix.O_RDONLY] 0o640 in + finally + (fun () -> + try + let buf = Bytes.create 80 in + let rd = Unix.read fd buf 0 (Bytes.length buf) in + if rd = 0 then + failwith "pidfile_read failed" ; + Scanf.sscanf (Bytes.sub_string buf 0 rd) "%d" (fun i -> Some i) + with _ -> None + ) + (fun () -> Unix.close fd) + +(** open a file, and make sure the close is always done *) +let with_file file mode perms f = + let fd = Unix.openfile file mode perms in + Xapi_stdext_pervasives.Pervasiveext.finally + (fun () -> f fd) + (fun () -> Unix.close fd) + +(* !! Must call this before spawning any threads !! *) + +(** daemonize a process *) +let daemonize () = + match Unix.fork () with + | 0 -> ( + if Unix.setsid () == -1 then + failwith "Unix.setsid failed" ; + match Unix.fork () with + | 0 -> + with_file "/dev/null" [Unix.O_WRONLY] 0 (fun nullfd -> + Unix.close Unix.stdin ; + Unix.dup2 nullfd Unix.stdout ; + Unix.dup2 nullfd Unix.stderr + ) + | _ -> + exit 0 + ) + | _ -> + exit 0 + +exception Break + +let lines_fold f start input = + let accumulator = ref start in + let running = ref true in + while !running do + let line = try Some (input_line input) with End_of_file -> None in + match line with + | Some line -> ( + try accumulator := f !accumulator line with Break -> running := false + ) + | None -> + running := false + done ; + !accumulator + +let lines_iter f = lines_fold (fun () line -> ignore (f line)) () + +(** open a file, and make sure the close is always done *) +let with_input_channel file f = + let input = open_in file in + finally (fun () -> f input) (fun () -> close_in input) + +let file_lines_fold f start file_path = + with_input_channel file_path (lines_fold f start) + +let read_lines ~(path : string) : string list = + List.rev (file_lines_fold (fun acc line -> line :: acc) [] path) + +let file_lines_iter f = file_lines_fold (fun () line -> ignore (f line)) () + +let readfile_line = file_lines_iter + +(** [fd_blocks_fold block_size f start fd] folds [f] over blocks (strings) + from the fd [fd] with initial value [start] *) +let fd_blocks_fold block_size f start fd = + let block = Bytes.create block_size in + let rec fold acc = + let n = Unix.read fd block 0 block_size in + (* Consider making the interface explicitly use Substrings *) + let b = if n = block_size then block else Bytes.sub block 0 n in + if n = 0 then acc else fold (f acc b) + in + fold start + +let with_directory dir f = + let dh = Unix.opendir dir in + Xapi_stdext_pervasives.Pervasiveext.finally + (fun () -> f dh) + (fun () -> Unix.closedir dh) + +let buffer_of_fd fd = + fd_blocks_fold 1024 + (fun b s -> Buffer.add_bytes b s ; b) + (Buffer.create 1024) fd + +let string_of_fd fd = Buffer.contents (buffer_of_fd fd) + +let buffer_of_file file_path = + with_file file_path [Unix.O_RDONLY] 0 buffer_of_fd + +let string_of_file file_path = Buffer.contents (buffer_of_file file_path) + +(** Write a file, ensures atomicity and durability. *) +let atomic_write_to_file fname perms f = + let dir_path = Filename.dirname fname in + let tmp_path, tmp_chan = + Filename.open_temp_file ~temp_dir:dir_path "" ".tmp" + in + let tmp_fd = Unix.descr_of_out_channel tmp_chan in + let write_tmp_file () = + let result = f tmp_fd in + Unix.fchmod tmp_fd perms ; Unix.fsync tmp_fd ; result + in + let write_and_persist () = + let result = finally write_tmp_file (fun () -> Stdlib.close_out tmp_chan) in + Unix.rename tmp_path fname ; + (* sync parent directory to make sure the file is persisted *) + let dir_fd = Unix.openfile dir_path [O_RDONLY] 0 in + finally (fun () -> Unix.fsync dir_fd) (fun () -> Unix.close dir_fd) ; + result + in + finally write_and_persist (fun () -> unlink_safe tmp_path) + +(** Atomically write a string to a file *) +let write_bytes_to_file ?(perms = 0o644) fname b = + atomic_write_to_file fname perms (fun fd -> + let len = Bytes.length b in + let written = Unix.write fd b 0 len in + if written <> len then failwith "Short write occured!" + ) + +let write_string_to_file ?(perms = 0o644) fname s = + write_bytes_to_file fname ~perms (Bytes.unsafe_of_string s) + +let execv_get_output cmd args = + let pipe_exit, pipe_entrance = Unix.pipe () in + let r = + try + Unix.set_close_on_exec pipe_exit ; + true + with _ -> false + in + match Unix.fork () with + | 0 -> ( + Unix.dup2 pipe_entrance Unix.stdout ; + Unix.close pipe_entrance ; + if not r then + Unix.close pipe_exit ; + try Unix.execv cmd args with _ -> exit 127 + ) + | pid -> + Unix.close pipe_entrance ; (pid, pipe_exit) + +let copy_file_internal ?limit reader writer = + let buffer = Bytes.make 65536 '\000' in + let buffer_len = Int64.of_int (Bytes.length buffer) in + let finished = ref false in + let total_bytes = ref 0L in + let limit = ref limit in + while not !finished do + let requested = min (Option.value ~default:buffer_len !limit) buffer_len in + let num = reader buffer 0 (Int64.to_int requested) in + let num64 = Int64.of_int num in + limit := Option.map (fun x -> Int64.sub x num64) !limit ; + ignore_int (writer buffer 0 num) ; + total_bytes := Int64.add !total_bytes num64 ; + finished := num = 0 || !limit = Some 0L + done ; + !total_bytes + +let copy_file ?limit ifd ofd = + copy_file_internal ?limit (Unix.read ifd) (Unix.write ofd) + +let file_exists file_path = + try + Unix.access file_path [Unix.F_OK] ; + true + with _ -> false + +let touch_file file_path = + let fd = + Unix.openfile file_path + [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_NOCTTY; Unix.O_NONBLOCK] + 0o666 + in + Unix.close fd ; + Unix.utimes file_path 0.0 0.0 + +let is_empty_file file_path = + try + let stats = Unix.stat file_path in + stats.Unix.st_size = 0 + with Unix.Unix_error (Unix.ENOENT, _, _) -> false + +let delete_empty_file file_path = + if is_empty_file file_path then ( + Sys.remove file_path ; true + ) else + false + +(** Create a new file descriptor, connect it to host:port and return it *) +exception Host_not_found of string + +let open_connection_fd host port = + let open Unix in + let addrinfo = + getaddrinfo host (string_of_int port) [AI_SOCKTYPE SOCK_STREAM] + in + match addrinfo with + | [] -> + failwith (Printf.sprintf "Couldn't resolve hostname: %s" host) + | ai :: _ -> ( + let s = socket ai.ai_family ai.ai_socktype 0 in + try connect s ai.ai_addr ; s + with e -> Backtrace.is_important e ; close s ; raise e + ) + +let open_connection_unix_fd filename = + let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + try + let addr = Unix.ADDR_UNIX filename in + Unix.connect s addr ; s + with e -> Backtrace.is_important e ; Unix.close s ; raise e + +module CBuf = struct + (** A circular buffer constructed from a string *) + type t = { + mutable buffer: bytes + ; mutable len: int (** bytes of valid data in [buffer] *) + ; mutable start: int (** index of first valid byte in [buffer] *) + ; mutable r_closed: bool (** true if no more data can be read due to EOF *) + ; mutable w_closed: bool + (** true if no more data can be written due to EOF *) + } + + let empty length = + { + buffer= Bytes.create length + ; len= 0 + ; start= 0 + ; r_closed= false + ; w_closed= false + } + + let drop (x : t) n = + if n > x.len then failwith (Printf.sprintf "drop %d > %d" n x.len) ; + x.start <- (x.start + n) mod Bytes.length x.buffer ; + x.len <- x.len - n + + let should_read (x : t) = + (not x.r_closed) && x.len < Bytes.length x.buffer - 1 + + let should_write (x : t) = (not x.w_closed) && x.len > 0 + + let end_of_reads (x : t) = x.r_closed && x.len = 0 + + let end_of_writes (x : t) = x.w_closed + + let write (x : t) fd = + (* Offset of the character after the substring *) + let next = min (Bytes.length x.buffer) (x.start + x.len) in + let len = next - x.start in + let written = + try Unix.single_write fd x.buffer x.start len + with _ -> + x.w_closed <- true ; + len + in + drop x written + + let read (x : t) fd = + (* Offset of the next empty character *) + let next = (x.start + x.len) mod Bytes.length x.buffer in + let len = + min (Bytes.length x.buffer - next) (Bytes.length x.buffer - x.len) + in + let read = Unix.read fd x.buffer next len in + if read = 0 then x.r_closed <- true ; + x.len <- x.len + read +end + +exception Process_still_alive + +let kill_and_wait ?(signal = Sys.sigterm) ?(timeout = 10.) pid = + let proc_entry_exists pid = + try + Unix.access (Printf.sprintf "/proc/%d" pid) [Unix.F_OK] ; + true + with _ -> false + in + if pid > 0 && proc_entry_exists pid then ( + let loop_time_waiting = 0.03 in + let left = ref timeout in + let readcmdline pid = + try string_of_file (Printf.sprintf "/proc/%d/cmdline" pid) with _ -> "" + in + let reference = readcmdline pid and quit = ref false in + Unix.kill pid signal ; + (* We cannot do a waitpid here, since we might not be parent of + the process, so instead we are waiting for the /proc/%d to go + away. Also we verify that the cmdline stay the same if it's still here + to prevent the very very unlikely event that the pid get reused before + we notice it's gone *) + while proc_entry_exists pid && (not !quit) && !left > 0. do + let cmdline = readcmdline pid in + if cmdline = reference then ( + (* still up, let's sleep a bit *) + ignore (Unix.select [] [] [] loop_time_waiting) ; + left := !left -. loop_time_waiting + ) else (* not the same, it's gone ! *) + quit := true + done ; + if !left <= 0. then + raise Process_still_alive + ) + +let string_of_signal x = + let table = + [ + (Sys.sigabrt, "SIGABRT") + ; (Sys.sigalrm, "SIGALRM") + ; (Sys.sigfpe, "SIGFPE") + ; (Sys.sighup, "SIGHUP") + ; (Sys.sigill, "SIGILL") + ; (Sys.sigint, "SIGINT") + ; (Sys.sigkill, "SIGKILL") + ; (Sys.sigpipe, "SIGPIPE") + ; (Sys.sigquit, "SIGQUIT") + ; (Sys.sigsegv, "SIGSEGV") + ; (Sys.sigterm, "SIGTERM") + ; (Sys.sigusr1, "SIGUSR1") + ; (Sys.sigusr2, "SIGUSR2") + ; (Sys.sigchld, "SIGCHLD") + ; (Sys.sigcont, "SIGCONT") + ; (Sys.sigstop, "SIGSTOP") + ; (Sys.sigttin, "SIGTTIN") + ; (Sys.sigttou, "SIGTTOU") + ; (Sys.sigvtalrm, "SIGVTALRM") + ; (Sys.sigprof, "SIGPROF") + ] + in + if List.mem_assoc x table then + List.assoc x table + else + Printf.sprintf "(ocaml signal %d with an unknown name)" x + +let proxy (a : Unix.file_descr) (b : Unix.file_descr) = + let size = 64 * 1024 in + (* [a'] is read from [a] and will be written to [b] *) + (* [b'] is read from [b] and will be written to [a] *) + let a' = CBuf.empty size and b' = CBuf.empty size in + Unix.set_nonblock a ; + Unix.set_nonblock b ; + try + while true do + let r = + (if CBuf.should_read a' then [a] else []) + @ if CBuf.should_read b' then [b] else [] + in + let w = + (if CBuf.should_write a' then [b] else []) + @ if CBuf.should_write b' then [a] else [] + in + (* If we can't make any progress (because fds have been closed), then stop *) + if r = [] && w = [] then raise End_of_file ; + let r, w, _ = Unix.select r w [] (-1.0) in + (* Do the writing before the reading *) + List.iter + (fun fd -> if a = fd then CBuf.write b' a else CBuf.write a' b) + w ; + List.iter (fun fd -> if a = fd then CBuf.read a' a else CBuf.read b' b) r ; + (* If there's nothing else to read or write then signal the other end *) + List.iter + (fun (buf, fd) -> + if CBuf.end_of_reads buf then Unix.shutdown fd Unix.SHUTDOWN_SEND ; + if CBuf.end_of_writes buf then Unix.shutdown fd Unix.SHUTDOWN_RECEIVE + ) + [(a', b); (b', a)] + done + with _ -> ( + (try Unix.clear_nonblock a with _ -> ()) ; + (try Unix.clear_nonblock b with _ -> ()) ; + (try Unix.close a with _ -> ()) ; + try Unix.close b with _ -> () + ) + +let try_read_string ?limit fd = + let buf = Buffer.create 0 in + let chunk = match limit with None -> 4096 | Some x -> x in + let cache = Bytes.make chunk '\000' in + let finished = ref false in + while not !finished do + let to_read = + match limit with + | Some x -> + min (x - Buffer.length buf) chunk + | None -> + chunk + in + let read_bytes = Unix.read fd cache 0 to_read in + Buffer.add_subbytes buf cache 0 read_bytes ; + if read_bytes = 0 then finished := true + done ; + Buffer.contents buf + +(* From https://ocaml.github.io/ocamlunix/ocamlunix.html#sec118 + The function write of the Unix module iterates the system call write until + all the requested bytes are effectively written. + val write : file_descr -> string -> int -> int -> int + However, when the descriptor is a pipe (or a socket, see chapter 6), writes + may block and the system call write may be interrupted by a signal. In this + case the OCaml call to Unix.write is interrupted and the error EINTR is raised. + The problem is that some of the data may already have been written by a + previous system call to write but the actual size that was transferred is + unknown and lost. This renders the function write of the Unix module useless + in the presence of signals. + + To address this problem, the Unix module also provides the “raw” system call + write under the name single_write. + + We can use multiple single_write calls to write exactly the requested + amount of data (but not atomically!). +*) +let rec restart_on_EINTR f x = + try f x with Unix.Unix_error (Unix.EINTR, _, _) -> restart_on_EINTR f x + +and really_write fd buffer offset len = + let n = restart_on_EINTR (Unix.single_write_substring fd buffer offset) len in + if n < len then really_write fd buffer (offset + n) (len - n) + +(* Ideally, really_write would be implemented with optional arguments ?(off=0) ?(len=String.length string) *) +let really_write_string fd string = + really_write fd string 0 (String.length string) + +let rec really_read fd string off n = + if n = 0 then + () + else + let m = restart_on_EINTR (Unix.read fd string off) n in + if m = 0 then raise End_of_file ; + really_read fd string (off + m) (n - m) + +let really_read_string fd length = + let buf = Bytes.make length '\000' in + really_read fd buf 0 length ; + Bytes.unsafe_to_string buf + +(* --------------------------------------------------------------------------------------- *) +(* Functions to read and write to/from a file descriptor with a given latest response time *) + +exception Timeout + +(* Write as many bytes to a file descriptor as possible from data before a given clock time. *) +(* Raises Timeout exception if the number of bytes written is less than the specified length. *) +(* Writes into the file descriptor at the current cursor position. *) +let time_limited_write_internal + (write : Unix.file_descr -> 'a -> int -> int -> int) filedesc length data + target_response_time = + let total_bytes_to_write = length in + let bytes_written = ref 0 in + let now = ref (Unix.gettimeofday ()) in + while !bytes_written < total_bytes_to_write && !now < target_response_time do + let remaining_time = target_response_time -. !now in + let _, ready_to_write, _ = Unix.select [] [filedesc] [] remaining_time in + (* Note: there is a possibility that the storage could go away after the select and before the write, so the write would block. *) + ( if List.mem filedesc ready_to_write then + let bytes_to_write = total_bytes_to_write - !bytes_written in + let bytes = + try write filedesc data !bytes_written bytes_to_write + with + | Unix.Unix_error (Unix.EAGAIN, _, _) + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) + -> + 0 + in + (* write from buffer=data from offset=bytes_written, length=bytes_to_write *) + bytes_written := bytes + !bytes_written + ) ; + now := Unix.gettimeofday () + done ; + if !bytes_written = total_bytes_to_write then + () + else (* we ran out of time *) + raise Timeout + +let time_limited_write filedesc length data target_response_time = + time_limited_write_internal Unix.write filedesc length data + target_response_time + +let time_limited_write_substring filedesc length data target_response_time = + time_limited_write_internal Unix.write_substring filedesc length data + target_response_time + +(* Read as many bytes to a file descriptor as possible before a given clock time. *) +(* Raises Timeout exception if the number of bytes read is less than the desired number. *) +(* Reads from the file descriptor at the current cursor position. *) +let time_limited_read filedesc length target_response_time = + let total_bytes_to_read = length in + let bytes_read = ref 0 in + let buf = Bytes.make total_bytes_to_read '\000' in + let now = ref (Unix.gettimeofday ()) in + while !bytes_read < total_bytes_to_read && !now < target_response_time do + let remaining_time = target_response_time -. !now in + let ready_to_read, _, _ = Unix.select [filedesc] [] [] remaining_time in + ( if List.mem filedesc ready_to_read then + let bytes_to_read = total_bytes_to_read - !bytes_read in + let bytes = + try Unix.read filedesc buf !bytes_read bytes_to_read + with + | Unix.Unix_error (Unix.EAGAIN, _, _) + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) + -> + 0 + in + (* read into buffer=buf from offset=bytes_read, length=bytes_to_read *) + if bytes = 0 then + raise End_of_file (* End of file has been reached *) + else + bytes_read := bytes + !bytes_read + ) ; + now := Unix.gettimeofday () + done ; + if !bytes_read = total_bytes_to_read then + Bytes.unsafe_to_string buf + else (* we ran out of time *) + raise Timeout + +(* --------------------------------------------------------------------------------------- *) + +(* Read a given number of bytes of data from the fd, or stop at EOF, whichever comes first. *) +(* A negative ~max_bytes indicates that all the data should be read from the fd until EOF. This is the default. *) +let read_data_in_chunks_internal (sub : bytes -> int -> int -> 'a) + (f : 'a -> int -> unit) ?(block_size = 1024) ?(max_bytes = -1) from_fd = + let buf = Bytes.make block_size '\000' in + let rec do_read acc = + let remaining_bytes = max_bytes - acc in + if remaining_bytes = 0 then + acc (* we've read the amount requested *) + else + let bytes_to_read = + if max_bytes < 0 || remaining_bytes > block_size then + block_size + else + remaining_bytes + in + let bytes_read = Unix.read from_fd buf 0 bytes_to_read in + if bytes_read = 0 then + acc (* we reached EOF *) + else ( + f (sub buf 0 bytes_read) bytes_read ; + do_read (acc + bytes_read) + ) + in + do_read 0 + +let read_data_in_string_chunks (f : string -> int -> unit) ?(block_size = 1024) + ?(max_bytes = -1) from_fd = + read_data_in_chunks_internal Bytes.sub_string f ~block_size ~max_bytes from_fd + +let read_data_in_chunks (f : bytes -> int -> unit) ?(block_size = 1024) + ?(max_bytes = -1) from_fd = + read_data_in_chunks_internal Bytes.sub f ~block_size ~max_bytes from_fd + +let spawnvp ?(pid_callback = fun _ -> ()) cmd args = + match Unix.fork () with + | 0 -> + Unix.execvp cmd args + | pid -> + (try pid_callback pid with _ -> ()) ; + snd (Unix.waitpid [] pid) + +let double_fork f = + match Unix.fork () with + | 0 -> ( + match Unix.fork () with + (* NB: use _exit (calls C lib _exit directly) to avoid + calling at_exit handlers and flushing output channels + which wouild cause intermittent deadlocks if we + forked from a threaded program *) + | 0 -> + (try f () with _ -> ()) ; + _exit 0 + | _ -> + _exit 0 + ) + | pid -> + ignore (Unix.waitpid [] pid) + +external set_tcp_nodelay : Unix.file_descr -> bool -> unit + = "stub_unixext_set_tcp_nodelay" + +external set_sock_keepalives : Unix.file_descr -> int -> int -> int -> unit + = "stub_unixext_set_sock_keepalives" + +external fsync : Unix.file_descr -> unit = "stub_unixext_fsync" + +external blkgetsize64 : Unix.file_descr -> int64 = "stub_unixext_blkgetsize64" + +external get_max_fd : unit -> int = "stub_unixext_get_max_fd" + +let int_of_file_descr (x : Unix.file_descr) : int = Obj.magic x + +let file_descr_of_int (x : int) : Unix.file_descr = Obj.magic x + +(** Forcibly closes all open file descriptors except those explicitly passed in as arguments. + Useful to avoid accidentally passing a file descriptor opened in another thread to a + process being concurrently fork()ed (there's a race between open/set_close_on_exec). + NB this assumes that 'type Unix.file_descr = int' +*) +let close_all_fds_except (fds : Unix.file_descr list) = + (* get at the file descriptor within *) + let fds' = List.map int_of_file_descr fds in + let close' (x : int) = try Unix.close (file_descr_of_int x) with _ -> () in + let highest_to_keep = List.fold_left max (-1) fds' in + (* close all the fds higher than the one we want to keep *) + for i = highest_to_keep + 1 to get_max_fd () do + close' i + done ; + (* close all the rest *) + for i = 0 to highest_to_keep - 1 do + if not (List.mem i fds') then close' i + done + +(** Remove "." and ".." from paths (NB doesn't attempt to resolve symlinks) *) +let resolve_dot_and_dotdot (path : string) : string = + let of_string (x : string) : string list = + let rec rev_split path = + let basename = Filename.basename path + and dirname = Filename.dirname path in + let rest = + if Filename.dirname dirname = dirname then [] else rev_split dirname + in + basename :: rest + in + let abs_path path = + if Filename.is_relative path then + Filename.concat "/" path (* no notion of a cwd *) + else + path + in + rev_split (abs_path x) + in + let to_string (x : string list) = + List.fold_left Filename.concat "/" (List.rev x) + in + (* Process all "." and ".." references *) + let rec remove_dots (n : int) (x : string list) = + match (x, n) with + | [], _ -> + [] + | "." :: rest, _ -> + remove_dots n rest (* throw away ".", don't count as parent for ".." *) + | ".." :: rest, _ -> + remove_dots (n + 1) rest (* note the number of ".." *) + | x :: rest, 0 -> + x :: remove_dots 0 rest + | _ :: rest, n -> + remove_dots (n - 1) rest (* munch *) + in + to_string (remove_dots 0 (of_string path)) + +(** Seek to an absolute offset within a file descriptor *) +let seek_to fd pos = Unix.lseek fd pos Unix.SEEK_SET + +(** Seek to an offset within a file descriptor, relative to the current cursor position *) +let seek_rel fd diff = Unix.lseek fd diff Unix.SEEK_CUR + +(** Return the current cursor position within a file descriptor *) +let current_cursor_pos fd = + (* 'seek' to the current position, exploiting the return value from Unix.lseek as the new cursor position *) + Unix.lseek fd 0 Unix.SEEK_CUR + +let wait_for_path path delay timeout = + let rec inner ttl = + if ttl = 0 then failwith "No path!" ; + try ignore (Unix.stat path) + with _ -> + delay 0.5 ; + inner (ttl - 1) + in + inner (timeout * 2) + +let _ = Callback.register_exception "unixext.unix_error" (Unix_error 0) + +let send_fd = Fd_send_recv.send_fd + +let send_fd_substring = Fd_send_recv.send_fd_substring + +let recv_fd = Fd_send_recv.recv_fd + +type statvfs_t = { + f_bsize: int64 + ; f_frsize: int64 + ; f_blocks: int64 + ; f_bfree: int64 + ; f_bavail: int64 + ; f_files: int64 + ; f_ffree: int64 + ; f_favail: int64 + ; f_fsid: int64 + ; f_flag: int64 + ; f_namemax: int64 +} + +external statvfs : string -> statvfs_t = "stub_statvfs" + +(** Returns Some Unix.PF_INET or Some Unix.PF_INET6 if passed a valid IP address, otherwise returns None. *) +let domain_of_addr str = + try + let addr = Unix.inet_addr_of_string str in + Some (Unix.domain_of_sockaddr (Unix.ADDR_INET (addr, 1))) + with _ -> None + +module Direct = struct + type t = Unix.file_descr + + external openfile : string -> Unix.open_flag list -> Unix.file_perm -> t + = "stub_stdext_unix_open_direct" + + let close = Unix.close + + let with_openfile path flags perms f = + let t = openfile path flags perms in + finally (fun () -> f t) (fun () -> close t) + + external unsafe_write : t -> bytes -> int -> int -> int + = "stub_stdext_unix_write" + + let write fd buf ofs len = + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then + invalid_arg "Unixext.write" + else + unsafe_write fd buf ofs len + + let copy_from_fd ?limit socket fd = + copy_file_internal ?limit (Unix.read socket) (write fd) + + let fsync x = fsync x + + let lseek fd x cmd = Unix.LargeFile.lseek fd x cmd +end diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli new file mode 100644 index 00000000000..c6168150b54 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli @@ -0,0 +1,276 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) +(** A collection of extensions to the [Unix] module. *) + +val _exit : int -> unit + +val unlink_safe : string -> unit + +val mkdir_safe : string -> Unix.file_perm -> unit + +val mkdir_rec : string -> Unix.file_perm -> unit + +val rm_rec : ?rm_top:bool -> string -> unit +(** removes a file or recursively removes files/directories below a directory without following + symbolic links. If path is a directory, it is only itself removed if rm_top is true. If path + is non-existent nothing happens, it does not lead to an error. *) + +val pidfile_write : string -> unit + +val pidfile_read : string -> int option + +val daemonize : unit -> unit + +val with_file : + string + -> Unix.open_flag list + -> Unix.file_perm + -> (Unix.file_descr -> 'a) + -> 'a + +val with_input_channel : string -> (in_channel -> 'a) -> 'a + +val with_directory : string -> (Unix.dir_handle -> 'a) -> 'a + +(** Exception to be raised in function to break out of [file_lines_fold]. *) +exception Break + +val lines_fold : ('a -> string -> 'a) -> 'a -> in_channel -> 'a +(** Folds function [f] over every line in the input channel *) + +val lines_iter : (string -> unit) -> in_channel -> unit +(** Applies function [f] to every line in the input channel *) + +val file_lines_fold : ('a -> string -> 'a) -> 'a -> string -> 'a +(** Folds function [f] over every line in the file at [file_path] using the + starting value [start]. *) + +val read_lines : path:string -> string list +(** [read_lines path] returns a list of lines in the file at [path]. *) + +val file_lines_iter : (string -> unit) -> string -> unit +(** Applies function [f] to every line in the file at [file_path]. *) + +val fd_blocks_fold : int -> ('a -> bytes -> 'a) -> 'a -> Unix.file_descr -> 'a +(** [fd_blocks_fold block_size f start fd] folds [f] over blocks (strings) + from the fd [fd] with initial value [start] *) + +val readfile_line : (string -> 'a) -> string -> unit +(** Alias for function [file_lines_iter]. *) + +val buffer_of_fd : Unix.file_descr -> Buffer.t +(** [buffer_of_fd fd] returns a Buffer.t containing all data read from [fd] up to EOF *) + +val string_of_fd : Unix.file_descr -> string +(** [string_of_fd fd] returns a string containing all data read from [fd] up to EOF *) + +val buffer_of_file : string -> Buffer.t +(** [buffer_of_file file] returns a Buffer.t containing the contents of [file] *) + +val string_of_file : string -> string +(** [string_of_file file] returns a string containing the contents of [file] *) + +val atomic_write_to_file : + string -> Unix.file_perm -> (Unix.file_descr -> 'a) -> 'a +(** [atomic_write_to_file fname perms f] writes a file to path [fname] + using the function [f] with permissions [perms]. In case of error during + the operation the file with the path [fname] is not modified at all. *) + +val write_string_to_file : ?perms:Unix.file_perm -> string -> string -> unit +(** [write_string_to_file fname contents] creates a file with path [fname] + with the string [contents] as its contents, atomically *) + +val write_bytes_to_file : ?perms:Unix.file_perm -> string -> bytes -> unit +(** [write_string_to_file fname contents] creates a file with path [fname] + with the buffer [contents] as its contents, atomically *) + +val execv_get_output : string -> string array -> int * Unix.file_descr + +val copy_file : ?limit:int64 -> Unix.file_descr -> Unix.file_descr -> int64 + +val file_exists : string -> bool +(** Returns true if and only if a file exists at the given path. *) + +val touch_file : string -> unit +(** Sets both the access and modification times of the file + * at the given path to the current time. Creates an empty + * file at the given path if no such file already exists. *) + +val is_empty_file : string -> bool +(** Returns true if and only if an empty file exists at the given path. *) + +val delete_empty_file : string -> bool +(** Safely deletes a file at the given path if (and only if) the + * file exists and is empty. Returns true if a file was deleted. *) + +exception Host_not_found of string + +val open_connection_fd : string -> int -> Unix.file_descr + +val open_connection_unix_fd : string -> Unix.file_descr + +exception Process_still_alive + +val kill_and_wait : ?signal:int -> ?timeout:float -> int -> unit + +val string_of_signal : int -> string +(** [string_of_signal x] translates an ocaml signal number into + * a string suitable for logging. *) + +val proxy : Unix.file_descr -> Unix.file_descr -> unit + +val really_read : Unix.file_descr -> bytes -> int -> int -> unit + +val really_read_string : Unix.file_descr -> int -> string + +val really_write : Unix.file_descr -> string -> int -> int -> unit +(** [really_write] keeps repeating the write operation until all bytes + * have been written or an error occurs. This is not atomic but is + * robust against EINTR errors. + * See: https://ocaml.github.io/ocamlunix/ocamlunix.html#sec118 *) + +val really_write_string : Unix.file_descr -> string -> unit + +val try_read_string : ?limit:int -> Unix.file_descr -> string + +exception Timeout + +val time_limited_write : Unix.file_descr -> int -> bytes -> float -> unit + +val time_limited_write_substring : + Unix.file_descr -> int -> string -> float -> unit + +val time_limited_read : Unix.file_descr -> int -> float -> string + +val read_data_in_string_chunks : + (string -> int -> unit) + -> ?block_size:int + -> ?max_bytes:int + -> Unix.file_descr + -> int + +val read_data_in_chunks : + (bytes -> int -> unit) + -> ?block_size:int + -> ?max_bytes:int + -> Unix.file_descr + -> int + +val spawnvp : + ?pid_callback:(int -> unit) -> string -> string array -> Unix.process_status + +val double_fork : (unit -> unit) -> unit + +external set_tcp_nodelay : Unix.file_descr -> bool -> unit + = "stub_unixext_set_tcp_nodelay" + +external set_sock_keepalives : Unix.file_descr -> int -> int -> int -> unit + = "stub_unixext_set_sock_keepalives" + +external fsync : Unix.file_descr -> unit = "stub_unixext_fsync" + +external get_max_fd : unit -> int = "stub_unixext_get_max_fd" + +external blkgetsize64 : Unix.file_descr -> int64 = "stub_unixext_blkgetsize64" + +val int_of_file_descr : Unix.file_descr -> int + +val file_descr_of_int : int -> Unix.file_descr + +val close_all_fds_except : Unix.file_descr list -> unit + +val resolve_dot_and_dotdot : string -> string + +val seek_to : Unix.file_descr -> int -> int + +val seek_rel : Unix.file_descr -> int -> int + +val current_cursor_pos : Unix.file_descr -> int + +val wait_for_path : string -> (float -> unit) -> int -> unit + +val send_fd : + Unix.file_descr + -> bytes + -> int + -> int + -> Unix.msg_flag list + -> Unix.file_descr + -> int + +val send_fd_substring : + Unix.file_descr + -> string + -> int + -> int + -> Unix.msg_flag list + -> Unix.file_descr + -> int + +val recv_fd : + Unix.file_descr + -> bytes + -> int + -> int + -> Unix.msg_flag list + -> int * Unix.sockaddr * Unix.file_descr + +type statvfs_t = { + f_bsize: int64 + ; f_frsize: int64 + ; f_blocks: int64 + ; f_bfree: int64 + ; f_bavail: int64 + ; f_files: int64 + ; f_ffree: int64 + ; f_favail: int64 + ; f_fsid: int64 + ; f_flag: int64 + ; f_namemax: int64 +} + +val statvfs : string -> statvfs_t + +val domain_of_addr : string -> Unix.socket_domain option +(** Returns Some Unix.PF_INET or Some Unix.PF_INET6 if passed a valid IP address, otherwise returns None. *) + +module Direct : sig + (** Perform I/O in O_DIRECT mode using 4KiB page-aligned buffers *) + + (** represents a file open in O_DIRECT mode *) + type t + + val openfile : string -> Unix.open_flag list -> Unix.file_perm -> t + (** [openfile name flags perm] behaves the same as [Unix.openfile] but includes the O_DIRECT flag *) + + val close : t -> unit + (** [close t] closes [t], a file open in O_DIRECT mode *) + + val with_openfile : + string -> Unix.open_flag list -> Unix.file_perm -> (t -> 'a) -> 'a + (** [with_openfile name flags perm f] opens [name], applies the result to [f] and closes *) + + val write : t -> bytes -> int -> int -> int + (** [write t buf ofs len] writes [len] bytes at offset [ofs] from buffer [buf] to + [t] using page-aligned buffers. *) + + val copy_from_fd : ?limit:int64 -> Unix.file_descr -> t -> int64 + (** [copy_from_fd ?limit fd t] copies from [fd] to [t] up to [limit] *) + + val fsync : t -> unit + (** [fsync t] commits all outstanding writes, throwing an error if necessary. *) + + val lseek : t -> int64 -> Unix.seek_command -> int64 + (** [lseek t offset command]: see Unix.LargeFile.lseek *) +end diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_open_stubs.c b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_open_stubs.c new file mode 100644 index 00000000000..d15cfeff0b1 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_open_stubs.c @@ -0,0 +1,75 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id: open.c 9547 2010-01-22 12:48:24Z doligez $ */ + +#define _GNU_SOURCE /* O_DIRECT */ + +#include +#include +#include +#include +#include +#include +#include + +#ifndef O_NONBLOCK +#define O_NONBLOCK O_NDELAY +#endif +#ifndef O_DSYNC +#define O_DSYNC 0 +#endif +#ifndef O_SYNC +#define O_SYNC 0 +#endif +#ifndef O_RSYNC +#define O_RSYNC 0 +#endif + +static int open_flag_table[] = { + O_RDONLY, O_WRONLY, O_RDWR, O_NONBLOCK, O_APPEND, O_CREAT, O_TRUNC, O_EXCL, + O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC +}; + +CAMLprim value stub_stdext_unix_open_direct(value path, value flags, value perm) +{ + CAMLparam3(path, flags, perm); + int fd, cv_flags; +#ifndef O_DIRECT + int ret; +#endif + char * p; + + cv_flags = caml_convert_flag_list(flags, open_flag_table); + +#ifdef O_DIRECT + cv_flags |= O_DIRECT; +#endif + p = caml_stat_alloc(caml_string_length(path) + 1); + strcpy(p, String_val(path)); + /* open on a named FIFO can block (PR#1533) */ + caml_enter_blocking_section(); + fd = open(p, cv_flags, Int_val(perm)); +#ifndef O_DIRECT + if (fd != -1) + ret = fcntl(fd, F_NOCACHE); +#endif + caml_leave_blocking_section(); + caml_stat_free(p); + if (fd == -1) uerror("open", path); +#ifndef O_DIRECT + if (ret == -1) uerror("fcntl", path); +#endif + + CAMLreturn (Val_int(fd)); +} diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_stubs.c b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_stubs.c new file mode 100644 index 00000000000..28fd7f9af89 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_stubs.c @@ -0,0 +1,172 @@ +/* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + */ +#include +#include +#include +#include +#include +#include +#include +#include /* needed for _SC_OPEN_MAX */ +#include /* snprintf */ +#include +#include +#if defined(__linux__) +# include +#endif + +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "blkgetsize.h" + +/* Set the TCP_NODELAY flag on a Unix.file_descr */ +CAMLprim value stub_unixext_set_tcp_nodelay (value fd, value bool) +{ + CAMLparam2 (fd, bool); + int c_fd = Int_val(fd); + int opt = (Bool_val(bool)) ? 1 : 0; + if (setsockopt(c_fd, IPPROTO_TCP, TCP_NODELAY, (void *)&opt, sizeof(opt)) != 0){ + uerror("setsockopt", Nothing); + } + CAMLreturn(Val_unit); +} + +CAMLprim value stub_unixext_fsync (value fd) +{ + CAMLparam1(fd); + int c_fd = Int_val(fd); + int rc; + + caml_release_runtime_system(); + rc = fsync(c_fd); + caml_acquire_runtime_system(); + if (rc != 0) uerror("fsync", Nothing); + CAMLreturn(Val_unit); +} + + +CAMLprim value stub_unixext_blkgetsize64(value fd) +{ + CAMLparam1(fd); + uint64_t size; + int c_fd = Int_val(fd); + int rc; + + caml_release_runtime_system(); + /* mirage-block-unix binding: */ + rc = stdext_blkgetsize(c_fd, &size); + caml_acquire_runtime_system(); + + if (rc) { + uerror("ioctl(BLKGETSIZE64)", Nothing); + } + CAMLreturn(caml_copy_int64(size)); +} + +CAMLprim value stub_unixext_get_max_fd (value unit) +{ + CAMLparam1 (unit); + long maxfd; + maxfd = sysconf(_SC_OPEN_MAX); + CAMLreturn(Val_int(maxfd)); +} + +#if defined(__linux__) +# define TCP_LEVEL SOL_TCP +#elif defined(__APPLE__) +# define TCP_LEVEL IPPROTO_TCP +#else +# error "Don't know how to use setsockopt on this platform" +#endif + +CAMLprim value stub_unixext_set_sock_keepalives(value fd, value count, value idle, value interval) +{ + CAMLparam4(fd, count, idle, interval); + + int c_fd = Int_val(fd); + int optval; + socklen_t optlen=sizeof(optval); + + optval = Int_val(count); + if(setsockopt(c_fd, TCP_LEVEL, TCP_KEEPCNT, &optval, optlen) < 0) { + uerror("setsockopt(TCP_KEEPCNT)", Nothing); + } +#if defined(__linux__) + optval = Int_val(idle); + if(setsockopt(c_fd, TCP_LEVEL, TCP_KEEPIDLE, &optval, optlen) < 0) { + uerror("setsockopt(TCP_KEEPIDLE)", Nothing); + } +#endif + optval = Int_val(interval); + if(setsockopt(c_fd, TCP_LEVEL, TCP_KEEPINTVL, &optval, optlen) < 0) { + uerror("setsockopt(TCP_KEEPINTVL)", Nothing); + } + + CAMLreturn(Val_unit); +} + +void unixext_error(int code) +{ + static const value *exn = NULL; + + if (!exn) { + exn = caml_named_value("unixext.unix_error"); + if (!exn) + caml_invalid_argument("unixext.unix_error not initialiazed"); + } + caml_raise_with_arg(*exn, Val_int(code)); +} + +CAMLprim value stub_statvfs(value filename) +{ + CAMLparam1(filename); + CAMLlocal1(v); + int ret; + struct statvfs buf; + + /* We want to release the runtime lock, so we must copy + * all OCaml arguments. + * See the manual section 20.12.2 Parallel execution of long running C code */ + char *name = caml_stat_strdup(String_val(filename)); + + caml_release_runtime_system(); + ret = statvfs(name, &buf); + caml_stat_free(name); + caml_acquire_runtime_system(); + + if(ret == -1) uerror("statvfs", Nothing); + + v=caml_alloc(11,0); + Store_field(v, 0, caml_copy_int64(buf.f_bsize)); + Store_field(v, 1, caml_copy_int64(buf.f_frsize)); + Store_field(v, 2, caml_copy_int64(buf.f_blocks)); + Store_field(v, 3, caml_copy_int64(buf.f_bfree)); + Store_field(v, 4, caml_copy_int64(buf.f_bavail)); + Store_field(v, 5, caml_copy_int64(buf.f_files)); + Store_field(v, 6, caml_copy_int64(buf.f_ffree)); + Store_field(v, 7, caml_copy_int64(buf.f_favail)); + Store_field(v, 8, caml_copy_int64(buf.f_fsid)); + Store_field(v, 9, caml_copy_int64(buf.f_flag)); + Store_field(v,10, caml_copy_int64(buf.f_namemax)); + + CAMLreturn(v); +} diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_write_stubs.c b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_write_stubs.c new file mode 100644 index 00000000000..e4be9f68018 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_write_stubs.c @@ -0,0 +1,65 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id: write.c 9547 2010-01-22 12:48:24Z doligez $ */ + +#include +#include +#include +#include +#include +#include + +#define PAGE_SIZE 4096 + +#ifndef EAGAIN +#define EAGAIN (-1) +#endif +#ifndef EWOULDBLOCK +#define EWOULDBLOCK (-1) +#endif + +CAMLprim value stub_stdext_unix_write(value fd, value buf, value vofs, value vlen) +{ + long ofs, len, written; + int numbytes, ret; + void *iobuf = NULL; + + Begin_root (buf); + ofs = Long_val(vofs); + len = Long_val(vlen); + written = 0; + while (len > 0) { + numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; + ret = posix_memalign(&iobuf, PAGE_SIZE, numbytes); + if (ret != 0) + uerror("write/posix_memalign", Nothing); + + memmove (iobuf, &Byte(buf, ofs), numbytes); + caml_enter_blocking_section(); + ret = write(Int_val(fd), iobuf, numbytes); + caml_leave_blocking_section(); + free(iobuf); + + if (ret == -1) { + if ((errno == EAGAIN || errno == EWOULDBLOCK) && written > 0) break; + uerror("write", Nothing); + } + written += ret; + ofs += ret; + len -= ret; + } + End_roots(); + return Val_long(written); +} + diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/dune new file mode 100644 index 00000000000..ec7532c6a9a --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/dune @@ -0,0 +1,5 @@ +(library + (public_name xapi-stdext-zerocheck) + (name xapi_stdext_zerocheck) + (foreign_stubs (language c) (names zerocheck_stub)) +) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck.ml new file mode 100644 index 00000000000..e128431c588 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck.ml @@ -0,0 +1,14 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) +external is_all_zeros : string -> int -> bool = "is_all_zeros" diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck.mli new file mode 100644 index 00000000000..08eb9b73d4e --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck.mli @@ -0,0 +1,16 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + *) + +external is_all_zeros : string -> int -> bool = "is_all_zeros" +(** [is_all_zeroes x len] returns true if the substring is all zeroes *) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck_stub.c b/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck_stub.c new file mode 100644 index 00000000000..776ef854849 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-zerocheck/zerocheck_stub.c @@ -0,0 +1,41 @@ +/* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * 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 Lesser General Public License for more details. + */ + +#include + +/* for better performance in all case, we should process the unalign data at + * the beginning until we reach a 32 bit align value, however since ocaml + * allocate the string and we don't use any offset in this string, the string + * is always correctly aligned. + */ +value is_all_zeros(value string, value length) +{ + CAMLparam2(string, length); + const char *s = String_val(string); + unsigned int *p; + int len = Int_val(length); + int i; + + p = (unsigned int *) s; + for (i = len / 4; i > 0; i--) + if (*p++ != 0) + goto notallzero; + s = (unsigned char *) p; + for (i = 0; i < len % 4; i++) + if (s[i] != 0) + goto notallzero; + CAMLreturn(Val_true); +notallzero: + CAMLreturn(Val_false); +} diff --git a/ocaml/message-switch/.ocamlformat b/ocaml/message-switch/.ocamlformat deleted file mode 100644 index ea8e56a85a7..00000000000 --- a/ocaml/message-switch/.ocamlformat +++ /dev/null @@ -1,8 +0,0 @@ -profile=ocamlformat -indicate-multiline-delimiters=closing-on-separate-line -if-then-else=fit-or-vertical -dock-collection-brackets=true -break-struct=natural -break-separators=before -break-infix=fit-or-vertical -break-infix-before-func=false diff --git a/ocaml/xapi-idl/.gitarchive-info b/ocaml/xapi-idl/.gitarchive-info deleted file mode 100644 index 83e5b86e569..00000000000 --- a/ocaml/xapi-idl/.gitarchive-info +++ /dev/null @@ -1,2 +0,0 @@ -Changeset: $Format:%H$ -Commit date: $Format:%cD$ diff --git a/ocaml/xapi-idl/.gitattributes b/ocaml/xapi-idl/.gitattributes deleted file mode 100644 index f7bf506d392..00000000000 --- a/ocaml/xapi-idl/.gitattributes +++ /dev/null @@ -1 +0,0 @@ -.gitarchive-info export-subst diff --git a/ocaml/xapi-idl/.github/workflows/ocaml-ci.yml b/ocaml/xapi-idl/.github/workflows/ocaml-ci.yml deleted file mode 100644 index b08cc575bb8..00000000000 --- a/ocaml/xapi-idl/.github/workflows/ocaml-ci.yml +++ /dev/null @@ -1,40 +0,0 @@ -name: Build and test - -on: - push: - pull_request: - -jobs: - ocaml-test: - name: Ocaml tests - runs-on: ubuntu-20.04 - env: - package: "xapi-idl" - - steps: - - name: Checkout code - uses: actions/checkout@v2 - - - name: Pull configuration from xs-opam - run: | - curl --fail --silent https://raw.githubusercontent.com/xapi-project/xs-opam/master/tools/xs-opam-ci.env | cut -f2 -d " " > .env - - name: Load environment file - id: dotenv - uses: falti/dotenv-action@v0.2.4 - - - name: Use ocaml - uses: avsm/setup-ocaml@v1 - with: - ocaml-version: ${{ steps.dotenv.outputs.ocaml_version_full }} - opam-repository: ${{ steps.dotenv.outputs.repository }} - - - name: Install dependencies - run: | - opam pin add . --no-action - opam depext -u ${{ env.package }} - opam install ${{ env.package }} --deps-only --with-test -v - - name: Build - run: | - opam exec -- make all - - name: Run tests - run: opam exec -- make test diff --git a/ocaml/xapi-idl/.ocamlformat b/ocaml/xapi-idl/.ocamlformat deleted file mode 100644 index ea8e56a85a7..00000000000 --- a/ocaml/xapi-idl/.ocamlformat +++ /dev/null @@ -1,8 +0,0 @@ -profile=ocamlformat -indicate-multiline-delimiters=closing-on-separate-line -if-then-else=fit-or-vertical -dock-collection-brackets=true -break-struct=natural -break-separators=before -break-infix=fit-or-vertical -break-infix-before-func=false diff --git a/quality-gate.sh b/quality-gate.sh index d0a1a7ee296..224e852aa32 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -3,7 +3,7 @@ set -e list-hd () { - N=317 + N=318 LIST_HD=$(git grep -r --count 'List.hd' -- **/*.ml | cut -d ':' -f 2 | paste -sd+ - | bc) if [ "$LIST_HD" -eq "$N" ]; then echo "OK counted $LIST_HD List.hd usages" @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=518 + N=530 # do not count ml files from the tests in ocaml/{tests/perftest/quicktest} MLIS=$(git ls-files -- '**/*.mli' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) MLS=$(git ls-files -- '**/*.ml' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) @@ -40,7 +40,7 @@ mli-files () { } structural-equality () { - N=9 + N=10 EQ=$(git grep -r --count ' == ' -- '**/*.ml' ':!ocaml/sdk-gen/**/*.ml' | cut -d ':' -f 2 | paste -sd+ - | bc) if [ "$EQ" -eq "$N" ]; then echo "OK counted $EQ usages of ' == '" diff --git a/xapi-inventory.opam b/xapi-inventory.opam new file mode 100644 index 00000000000..3783ff02467 --- /dev/null +++ b/xapi-inventory.opam @@ -0,0 +1,30 @@ +# This file is generated by dune, edit dune-project instead + +opam-version: "2.0" +name: "xapi-inventory" +maintainer: "xen-api@lists.xen.org" +authors: "xen-api@lists.xen.org" +homepage: "https://github.com/xapi-project/xcp-inventory" +bug-reports: "https://github.com/xapi-project/xcp-inventory/issues" +dev-repo: "git+http://github.com/xapi-project/xcp-inventory.git" +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +tags: [ "org:xapi-project" ] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +depends: [ + "ocaml" + "ocamlfind" {build} + "dune" {build} + "base-threads" + "astring" + "xapi-stdext-unix" + "xapi-stdext-threads" + "cmdliner" + "uuidm" +] +synopsis: "Library for accessing the xapi toolstack inventory file" +description: """ +The inventory file provides global host identify information +needed by multiple services.""" diff --git a/xapi-inventory.opam.template b/xapi-inventory.opam.template new file mode 100644 index 00000000000..7d6338dc108 --- /dev/null +++ b/xapi-inventory.opam.template @@ -0,0 +1,28 @@ +opam-version: "2.0" +name: "xapi-inventory" +maintainer: "xen-api@lists.xen.org" +authors: "xen-api@lists.xen.org" +homepage: "https://github.com/xapi-project/xcp-inventory" +bug-reports: "https://github.com/xapi-project/xcp-inventory/issues" +dev-repo: "git+http://github.com/xapi-project/xcp-inventory.git" +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +tags: [ "org:xapi-project" ] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +depends: [ + "ocaml" + "ocamlfind" {build} + "dune" {build} + "base-threads" + "astring" + "xapi-stdext-unix" + "xapi-stdext-threads" + "cmdliner" + "uuidm" +] +synopsis: "Library for accessing the xapi toolstack inventory file" +description: """ +The inventory file provides global host identify information +needed by multiple services.""" diff --git a/xapi-rrd.opam b/xapi-rrd.opam new file mode 100644 index 00000000000..abc1e4bb28c --- /dev/null +++ b/xapi-rrd.opam @@ -0,0 +1,37 @@ +# This file is generated by dune, edit dune-project instead + +opam-version: "2.0" +maintainer: "Xapi project maintainers" +authors: ["Dave Scott" "Jon Ludlam" "John Else"] +homepage: "https://github.com/xapi-project/xcp-rrd" +bug-reports: "https://github.com/xapi-project/xcp-rrd/issues" +dev-repo: "git+https://github.com/xapi-project/xcp-rrd.git" +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +tags: [ + "org:xapi-project" +] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +depends: [ + "ocaml" {>= "4.14"} + "dune" {>= "2.0.0"} + "base-bigarray" + "base-unix" + "ppx_deriving_rpc" {>= "6.1.0"} + "rpclib" + "xmlm" + "uuidm" + "xapi-stdext-pervasives" + "yojson" + "alcotest" {with-test} + "crowbar" {with-test} + "xapi-stdext-unix" {with-test} +] +available: [arch != "ppc64"] +synopsis: "RRD library for use with xapi" +description: """ +Round-Robin Databases (RRDs) are constant-space datastructures +used for archiving historical data where the older data is stored +at a lower resolution.""" diff --git a/xapi-rrd.opam.template b/xapi-rrd.opam.template new file mode 100644 index 00000000000..8185db9f7aa --- /dev/null +++ b/xapi-rrd.opam.template @@ -0,0 +1,35 @@ +opam-version: "2.0" +maintainer: "Xapi project maintainers" +authors: ["Dave Scott" "Jon Ludlam" "John Else"] +homepage: "https://github.com/xapi-project/xcp-rrd" +bug-reports: "https://github.com/xapi-project/xcp-rrd/issues" +dev-repo: "git+https://github.com/xapi-project/xcp-rrd.git" +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +tags: [ + "org:xapi-project" +] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +depends: [ + "ocaml" {>= "4.14"} + "dune" {>= "2.0.0"} + "base-bigarray" + "base-unix" + "ppx_deriving_rpc" {>= "6.1.0"} + "rpclib" + "xmlm" + "uuidm" + "xapi-stdext-pervasives" + "yojson" + "alcotest" {with-test} + "crowbar" {with-test} + "xapi-stdext-unix" {with-test} +] +available: [arch != "ppc64"] +synopsis: "RRD library for use with xapi" +description: """ +Round-Robin Databases (RRDs) are constant-space datastructures +used for archiving historical data where the older data is stored +at a lower resolution.""" diff --git a/xapi-stdext-date.opam b/xapi-stdext-date.opam new file mode 100644 index 00000000000..a7f4951d856 --- /dev/null +++ b/xapi-stdext-date.opam @@ -0,0 +1,32 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Xapi's standard library extension, Dates" +maintainer: ["Xapi project maintainers"] +authors: ["xen-api@lists.xen.org"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://xapi-project.github.io/" +bug-reports: "https://github.com/xapi-project/xen-api/issues" +depends: [ + "dune" {>= "2.0"} + "ocaml" {>= "4.12"} + "alcotest" {with-test} + "astring" + "base-unix" + "ptime" + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/xen-api.git" diff --git a/xapi-stdext-encodings.opam b/xapi-stdext-encodings.opam new file mode 100644 index 00000000000..c3538116761 --- /dev/null +++ b/xapi-stdext-encodings.opam @@ -0,0 +1,33 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Xapi's standard library extension, Encodings" +maintainer: ["Xapi project maintainers"] +authors: ["xen-api@lists.xen.org"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://xapi-project.github.io/" +bug-reports: "https://github.com/xapi-project/xen-api/issues" +depends: [ + "dune" {>= "2.0"} + "ocaml" {>= "4.13.0"} + "alcotest" {>= "0.6.0" & with-test} + "odoc" {with-doc} + "bechamel" {with-test} + "bechamel-notty" {with-test} + "notty" {with-test} +] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/xen-api.git" +available: arch != "arm32" & arch != "x86_32" diff --git a/xapi-stdext-encodings.opam.template b/xapi-stdext-encodings.opam.template new file mode 100644 index 00000000000..66595f2d564 --- /dev/null +++ b/xapi-stdext-encodings.opam.template @@ -0,0 +1 @@ +available: arch != "arm32" & arch != "x86_32" diff --git a/xapi-stdext-pervasives.opam b/xapi-stdext-pervasives.opam new file mode 100644 index 00000000000..53fd4b34939 --- /dev/null +++ b/xapi-stdext-pervasives.opam @@ -0,0 +1,30 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Xapi's standard library extension, Pervasives" +maintainer: ["Xapi project maintainers"] +authors: ["xen-api@lists.xen.org"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://xapi-project.github.io/" +bug-reports: "https://github.com/xapi-project/xen-api/issues" +depends: [ + "dune" {>= "2.0"} + "ocaml" {>= "4.08"} + "logs" + "odoc" {with-doc} + "xapi-backtrace" +] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/xen-api.git" diff --git a/xapi-stdext-std.opam b/xapi-stdext-std.opam new file mode 100644 index 00000000000..95b61c73e3e --- /dev/null +++ b/xapi-stdext-std.opam @@ -0,0 +1,29 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Xapi's standard library extension, Stdlib" +maintainer: ["Xapi project maintainers"] +authors: ["xen-api@lists.xen.org"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://xapi-project.github.io/" +bug-reports: "https://github.com/xapi-project/xen-api/issues" +depends: [ + "dune" {>= "2.0"} + "ocaml" {>= "4.08.0"} + "alcotest" {with-test} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/xen-api.git" diff --git a/xapi-stdext-threads.opam b/xapi-stdext-threads.opam new file mode 100644 index 00000000000..9dcc9ff090c --- /dev/null +++ b/xapi-stdext-threads.opam @@ -0,0 +1,31 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Xapi's standard library extension, Threads" +maintainer: ["Xapi project maintainers"] +authors: ["xen-api@lists.xen.org"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://xapi-project.github.io/" +bug-reports: "https://github.com/xapi-project/xen-api/issues" +depends: [ + "dune" {>= "2.0"} + "ocaml" + "base-threads" + "base-unix" + "odoc" {with-doc} + "xapi-stdext-pervasives" {= version} +] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/xen-api.git" diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam new file mode 100644 index 00000000000..f8e709afe7f --- /dev/null +++ b/xapi-stdext-unix.opam @@ -0,0 +1,34 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Xapi's standard library extension, Unix" +maintainer: ["Xapi project maintainers"] +authors: ["xen-api@lists.xen.org"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://xapi-project.github.io/" +bug-reports: "https://github.com/xapi-project/xen-api/issues" +depends: [ + "dune" {>= "2.0"} + "ocaml" {>= "4.12.0"} + "base-unix" + "fd-send-recv" {>= "2.0.0"} + "odoc" {with-doc} + "xapi-backtrace" + "xapi-stdext-pervasives" {= version} +] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/xen-api.git" +depexts: ["linux-headers"] {os-distribution = "alpine"} +available: [ os = "macos" | os = "linux" ] diff --git a/xapi-stdext-unix.opam.template b/xapi-stdext-unix.opam.template new file mode 100644 index 00000000000..ae75bf72ee5 --- /dev/null +++ b/xapi-stdext-unix.opam.template @@ -0,0 +1,2 @@ +depexts: ["linux-headers"] {os-distribution = "alpine"} +available: [ os = "macos" | os = "linux" ] diff --git a/xapi-stdext-zerocheck.opam b/xapi-stdext-zerocheck.opam new file mode 100644 index 00000000000..30861bf3dc1 --- /dev/null +++ b/xapi-stdext-zerocheck.opam @@ -0,0 +1,28 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Xapi's standard library extension, Zerocheck" +maintainer: ["Xapi project maintainers"] +authors: ["xen-api@lists.xen.org"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://xapi-project.github.io/" +bug-reports: "https://github.com/xapi-project/xen-api/issues" +depends: [ + "dune" {>= "2.0"} + "ocaml" + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/xen-api.git" diff --git a/xapi-stdext.opam b/xapi-stdext.opam new file mode 100644 index 00000000000..e2654f782ab --- /dev/null +++ b/xapi-stdext.opam @@ -0,0 +1,34 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Xapi's standard library extension" +description: "Dummy package that enables the usage of dune-release" +maintainer: ["Xapi project maintainers"] +authors: ["xen-api@lists.xen.org"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://xapi-project.github.io/" +bug-reports: "https://github.com/xapi-project/xen-api/issues" +depends: [ + "dune" {>= "2.0"} + "xapi-stdext-date" {= version} + "xapi-stdext-encodings" {= version} + "xapi-stdext-pervasives" {= version} + "xapi-stdext-std" {= version} + "xapi-stdext-threads" {= version} + "xapi-stdext-unix" {= version} + "xapi-stdext-zerocheck" {= version} +] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/xen-api.git"