This commit is contained in:
parent
aa2ff7b2f0
commit
2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
109
unikernel/duniverse/pgx/.circleci/config.yml
Normal file
109
unikernel/duniverse/pgx/.circleci/config.yml
Normal file
|
|
@ -0,0 +1,109 @@
|
|||
version: 2.1
|
||||
jobs:
|
||||
build:
|
||||
docker:
|
||||
- image: ocaml/opam:alpine-ocaml-4.11
|
||||
environment:
|
||||
PGUSER: pgx
|
||||
PGDATABASE: pgx-test
|
||||
PGHOST: 127.0.0.1
|
||||
PGX_FORCE_TESTS: true
|
||||
TERM: xterm
|
||||
- image: circleci/postgres:9.6-alpine
|
||||
environment:
|
||||
POSTGRES_USER: pgx
|
||||
POSTGRES_DB: pgx-test
|
||||
POSTGRES_PASSWORD: ""
|
||||
steps:
|
||||
- checkout
|
||||
- run:
|
||||
name: Update opam
|
||||
command: |
|
||||
opam remote remove default --all
|
||||
opam remote add default https://opam.ocaml.org
|
||||
- run:
|
||||
name: Pin packages
|
||||
command: ./pin_dev.sh
|
||||
- run:
|
||||
name: Install system dependencies
|
||||
command: opam depext -y `basename -s .opam *.opam | tr '\n' ' '`
|
||||
- run:
|
||||
name: Install OCaml dependencies
|
||||
command: opam install --deps-only -y `basename -s .opam *.opam | tr '\n' ' '`
|
||||
- run:
|
||||
name: Build
|
||||
command: opam exec -- make
|
||||
- run:
|
||||
# This is a separate step so we don't run tests for all of these ^
|
||||
name: Install OCaml test dependencies
|
||||
command: opam install --deps-only -t -y `basename -s .opam *.opam | tr '\n' ' '`
|
||||
- run:
|
||||
name: Test and coverage report
|
||||
command: |
|
||||
coverage_set () [[ -n $COVERALLS_REPO_TOKEN ]]
|
||||
opam exec -- make test-coverage
|
||||
(coverage_set && opam exec -- bisect-ppx-report send-to Coveralls) || true
|
||||
|
||||
|
||||
dune_lint:
|
||||
docker:
|
||||
- image: ocaml/opam2:4.09
|
||||
environment:
|
||||
TERM: xterm
|
||||
steps:
|
||||
- checkout
|
||||
- run:
|
||||
name: Pin packages
|
||||
command: ./pin_dev.sh
|
||||
- run:
|
||||
name: Install system dependencies
|
||||
command: opam depext -y dune-release
|
||||
- run:
|
||||
name: Install dependencies
|
||||
command: opam install -y dune-release
|
||||
- run:
|
||||
name: dune-release lint
|
||||
command: opam exec -- dune-release lint
|
||||
|
||||
build_mirage:
|
||||
docker:
|
||||
- image: ocaml/opam:alpine-ocaml-4.11
|
||||
environment:
|
||||
TERM: xterm
|
||||
steps:
|
||||
- checkout
|
||||
- run:
|
||||
name: Update opam
|
||||
command: |
|
||||
opam remote remove default --all
|
||||
opam remote add default https://opam.ocaml.org
|
||||
- run:
|
||||
name: Pin packages
|
||||
command: |
|
||||
opam pin add -k git -y -n pgx.dev .
|
||||
opam pin add -k git -y -n pgx_lwt.dev .
|
||||
opam pin add -k git -y -n pgx_lwt_mirage.dev .
|
||||
- run:
|
||||
name: Install system dependencies
|
||||
command: opam depext -y pgx pgx_lwt pgx_lwt_mirage
|
||||
- run:
|
||||
name: Install OCaml dependencies
|
||||
command: |
|
||||
opam install --deps-only -y pgx pgx_lwt pgx_lwt_mirage
|
||||
opam install mirage
|
||||
- run:
|
||||
name: Configure mirage
|
||||
command: cd unikernel && opam exec -- mirage configure -t spt
|
||||
- run:
|
||||
name: Install mirage deps
|
||||
command: cd unikernel && opam exec -- make depend
|
||||
- run:
|
||||
name: Build mirage
|
||||
command: cd unikernel && opam exec -- make
|
||||
|
||||
workflows:
|
||||
main:
|
||||
jobs:
|
||||
- build
|
||||
- build_mirage
|
||||
- dune_lint
|
||||
15
unikernel/duniverse/pgx/.editorconfig
Normal file
15
unikernel/duniverse/pgx/.editorconfig
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
# http://editorconfig.org
|
||||
|
||||
root = true
|
||||
|
||||
[*]
|
||||
indent_style = space
|
||||
indent_size = 2
|
||||
charset = utf-8
|
||||
trim_trailing_whitespace = true
|
||||
insert_final_newline = true
|
||||
max_line_length = 80
|
||||
|
||||
# Makefiles only support tab indents
|
||||
[Makefile]
|
||||
indent_style = tab
|
||||
8
unikernel/duniverse/pgx/.gitignore
vendored
Normal file
8
unikernel/duniverse/pgx/.gitignore
vendored
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
_build
|
||||
_coverage
|
||||
_esy
|
||||
*.install
|
||||
.merlin
|
||||
esy.lock
|
||||
node_modules
|
||||
_opam
|
||||
1
unikernel/duniverse/pgx/.ocamlformat
Normal file
1
unikernel/duniverse/pgx/.ocamlformat
Normal file
|
|
@ -0,0 +1 @@
|
|||
profile=janestreet
|
||||
1
unikernel/duniverse/pgx/.ocp-indent
Normal file
1
unikernel/duniverse/pgx/.ocp-indent
Normal file
|
|
@ -0,0 +1 @@
|
|||
JaneStreet
|
||||
6
unikernel/duniverse/pgx/.pre-commit-config.yaml
Normal file
6
unikernel/duniverse/pgx/.pre-commit-config.yaml
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
---
|
||||
repos:
|
||||
- repo: https://github.com/arenadotio/pre-commit-ocamlformat
|
||||
rev: 2b9c80c268df08bbe192ae58e5e8db2ba8496767
|
||||
hooks:
|
||||
- id: ocamlformat
|
||||
91
unikernel/duniverse/pgx/CHANGES.md
Normal file
91
unikernel/duniverse/pgx/CHANGES.md
Normal file
|
|
@ -0,0 +1,91 @@
|
|||
## 2.3 (unreleased)
|
||||
|
||||
## 2.2 (2022-10-26)
|
||||
* Support ocaml 5.0 deprecations (https://github.com/arenadotio/pgx/pull/129)
|
||||
|
||||
## 2.1 (2022-05-31)
|
||||
### Breaking changes
|
||||
|
||||
* Missing SASL authentication impl provides an error instead of hanging (https://github.com/arenadotio/pgx/pull/122).
|
||||
* pgx_lwt_mirage now requires conduit 2.3 instead of 2.2 (https://github.com/arenadotio/pgx/pull/117).
|
||||
|
||||
## 2.0 (2021-05-12)
|
||||
|
||||
### Breaking changes
|
||||
|
||||
* The Pgx module is now wrapped, which means `Pgx_aux`, `Types`, `Access`, etc. aren't added to the global scope.
|
||||
The main result of this is that `Pgx_value` now needs to be accessed as `Pgx.Value`.
|
||||
(https://github.com/arenadotio/pgx/pull/103)
|
||||
* `Pgx_async.connect` and `with_conn` now have an additional optional `?ssl` argument (see below).
|
||||
|
||||
### Added
|
||||
|
||||
* Pgx_async now supports TLS connections using Conduit_async. This is enabled by default and can be controlled with the
|
||||
new `?ssl` argument to `connect` and `with_conn`.
|
||||
(https://github.com/arenadotio/pgx/pull/108)
|
||||
|
||||
### Fixed
|
||||
|
||||
* Improved message for authentication errors. Previously these raised `Pgx_eof`, and now they raise
|
||||
`PostgreSQL_Error("Failed to authenticate with postgres server", additional details ...)`.
|
||||
(https://github.com/arenadotio/pgx/pull/105)
|
||||
|
||||
### Changed
|
||||
|
||||
* Support new Mirage-conduit timeout argument (https://github.com/arenadotio/pgx/pull/95).
|
||||
|
||||
## 1.0 (2020-05-08)
|
||||
|
||||
### Breaking changes
|
||||
|
||||
* Pgx_value.t is an opaque type now. Use `Pgx_value.of/to` converters. Note that these converters are _not_ equivalent
|
||||
to the OCaml functions like `bool_of_string` or `float_of_string`, and that for bytea data, you need to use
|
||||
`Pgx_value.of/to_binary`, not `Pgx_value.of/to_string`.
|
||||
* Pgx_lwt has been renamed Pgx_lwt_unix.
|
||||
* `Pgx.execute` now uses the unnamed prepare statement. In most cases this should not affect anything, but if you were
|
||||
relying on Pgx not internally using the unnamed prepared statement, you will need to fix your code. If you run into
|
||||
this, the fix is to use `Pgx.with_prepared` and name your prepared statement.
|
||||
* `Pgx_value.of_inet`/`to_inet` now use `Ipaddr.t` from the `ipaddr` library instead of `Unix.inet_addr`.
|
||||
|
||||
### Added
|
||||
|
||||
* `Pgx_value.of_binary` and `Pgx_value.to_binary` added for bytea data.
|
||||
* Add `execute_map` helper to Pgx
|
||||
* Add `execute_pipe` helper to Pgx_async
|
||||
* Add `execute_unit` helper to Pgx
|
||||
* Break out `Pgx_value_core` library, which will allow users of Pgx_unix and Pgx_lwt to use the `Core_kernel.Tim` and
|
||||
`Date` types. This is still included by default in Pgx_async.
|
||||
* Added Pgx_lwt_mirage
|
||||
* Pgx_value types now all implement `compare` and `sexp_of`
|
||||
|
||||
### Fixed
|
||||
|
||||
* Pgx no longer assumes all strings are binary data. Strings must be valid varchar data in the database's encoding.
|
||||
Use `Pgx_value.of/to_binary` with bytea columns if you want binary.
|
||||
* Use a tail-recursive `List.map` implementation
|
||||
* Use `Unix.getuid` + `Lwt_unix.getpwuid` instead of `Lwt.getlogin` for the default username, since `getlogin` fails
|
||||
in some cases.
|
||||
* Use int64 to keep track of prepared statements just in case someone prepares several million statements in one program
|
||||
|
||||
### Changed
|
||||
|
||||
* Re-raise exceptions with backtraces if possible.
|
||||
* Pgx_async uses Async.Log for logging instead of printing directly to stderr
|
||||
* Use Sexplib0 instead of Sexplib
|
||||
* Use the Query protocol for parameterless `execute` instead of Prepare + Bind
|
||||
* Use the unnamed prepared statement for `execute`
|
||||
* Use `ipaddr` library instead of `Unix.inet_addr`
|
||||
* Split Pgx_lwt into Pgx_lwt_unix and Pgx_lwt_mirage
|
||||
|
||||
## 0.1 (2018-05-31)
|
||||
|
||||
Initial release since fork from PG'OCaml.
|
||||
|
||||
* More tests
|
||||
* More consistent use of async API's
|
||||
* Addition of Pgx.Value for hopefully easier conversion to and
|
||||
from DB types
|
||||
* Safe handling of concurrent queries (not any faster, but they
|
||||
won't crash)
|
||||
* Improved interface for prepared statements to make it harder
|
||||
to execute non-existent ones
|
||||
504
unikernel/duniverse/pgx/LICENSE.md
Normal file
504
unikernel/duniverse/pgx/LICENSE.md
Normal file
|
|
@ -0,0 +1,504 @@
|
|||
This library is distributed under the terms of the GNU LGPL with the
|
||||
OCaml linking exception.
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
As a special exception to the GNU Library 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 Library General
|
||||
Public License. By "a publicly distributed version of the Library",
|
||||
we mean either the unmodified Library as distributed by INRIA, 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 Library General
|
||||
Public License.
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
GNU LIBRARY GENERAL PUBLIC LICENSE
|
||||
Version 2, June 1991
|
||||
|
||||
Copyright (C) 1991 Free Software Foundation, Inc.
|
||||
59 Temple Place - Suite 330
|
||||
Boston, MA 02111-1307, USA.
|
||||
Everyone is permitted to copy and distribute verbatim copies
|
||||
of this license document, but changing it is not allowed.
|
||||
|
||||
[This is the first released version of the library GPL. It is
|
||||
numbered 2 because it goes with version 2 of the ordinary GPL.]
|
||||
|
||||
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 Library General Public License, applies to some
|
||||
specially designated Free Software Foundation software, and to any
|
||||
other libraries whose authors decide to use it. You can use it for
|
||||
your libraries, too.
|
||||
|
||||
When we speak of free software, we are referring to freedom, not
|
||||
price. Our General Public Licenses are designed to make sure that you
|
||||
have the freedom to distribute copies of free software (and charge for
|
||||
this service if you wish), that you receive source code or can get it
|
||||
if you want it, that you can change the software or use pieces of it
|
||||
in new free programs; and that you know you can do these things.
|
||||
|
||||
To protect your rights, we need to make restrictions that forbid
|
||||
anyone to deny you these rights or to ask you to surrender the rights.
|
||||
These restrictions translate to certain responsibilities for you if
|
||||
you distribute copies of the 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 a program 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.
|
||||
|
||||
Our method of protecting your rights has two steps: (1) copyright
|
||||
the library, and (2) offer you this license which gives you legal
|
||||
permission to copy, distribute and/or modify the library.
|
||||
|
||||
Also, for each distributor's protection, we want to make certain
|
||||
that everyone understands that there is no warranty for this free
|
||||
library. If the library is modified by someone else and passed on, we
|
||||
want its recipients to know that what they have is not the original
|
||||
version, so that any problems introduced by others will not reflect on
|
||||
the original authors' reputations.
|
||||
|
||||
Finally, any free program is threatened constantly by software
|
||||
patents. We wish to avoid the danger that companies distributing free
|
||||
software will individually obtain patent licenses, thus in effect
|
||||
transforming the program into proprietary software. To prevent this,
|
||||
we have made it clear that any patent must be licensed for everyone's
|
||||
free use or not licensed at all.
|
||||
|
||||
Most GNU software, including some libraries, is covered by the ordinary
|
||||
GNU General Public License, which was designed for utility programs. This
|
||||
license, the GNU Library General Public License, applies to certain
|
||||
designated libraries. This license is quite different from the ordinary
|
||||
one; be sure to read it in full, and don't assume that anything in it is
|
||||
the same as in the ordinary license.
|
||||
|
||||
The reason we have a separate public license for some libraries is that
|
||||
they blur the distinction we usually make between modifying or adding to a
|
||||
program and simply using it. Linking a program with a library, without
|
||||
changing the library, is in some sense simply using the library, and is
|
||||
analogous to running a utility program or application program. However, in
|
||||
a textual and legal sense, the linked executable is a combined work, a
|
||||
derivative of the original library, and the ordinary General Public License
|
||||
treats it as such.
|
||||
|
||||
Because of this blurred distinction, using the ordinary General
|
||||
Public License for libraries did not effectively promote software
|
||||
sharing, because most developers did not use the libraries. We
|
||||
concluded that weaker conditions might promote sharing better.
|
||||
|
||||
However, unrestricted linking of non-free programs would deprive the
|
||||
users of those programs of all benefit from the free status of the
|
||||
libraries themselves. This Library General Public License is intended to
|
||||
permit developers of non-free programs to use free libraries, while
|
||||
preserving your freedom as a user of such programs to change the free
|
||||
libraries that are incorporated in them. (We have not seen how to achieve
|
||||
this as regards changes in header files, but we have achieved it as regards
|
||||
changes in the actual functions of the Library.) The hope is that this
|
||||
will lead to faster development of free libraries.
|
||||
|
||||
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, while the latter only
|
||||
works together with the library.
|
||||
|
||||
Note that it is possible for a library to be covered by the ordinary
|
||||
General Public License rather than by this special one.
|
||||
|
||||
GNU LIBRARY GENERAL PUBLIC LICENSE
|
||||
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
|
||||
|
||||
0. This License Agreement applies to any software library which
|
||||
contains a notice placed by the copyright holder or other authorized
|
||||
party saying it may be distributed under the terms of this Library
|
||||
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 compile 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) 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.
|
||||
|
||||
c) 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.
|
||||
|
||||
d) 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 source code distributed need not include anything that is normally
|
||||
distributed (in either source or binary form) with the major
|
||||
components (compiler, kernel, and so on) of the operating system on
|
||||
which the executable runs, unless that component itself accompanies
|
||||
the executable.
|
||||
|
||||
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 to
|
||||
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 Library 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
|
||||
|
||||
Appendix: 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.
|
||||
|
||||
<one line to give the library's name and a brief idea of what it does.>
|
||||
Copyright (C) <year> <name of author>
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU Library General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2 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
|
||||
Library General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License
|
||||
along with this library; see the file COPYING. If not, write to
|
||||
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
Boston, MA 02111-1307, USA.
|
||||
|
||||
Also add information on how to contact you by electronic and paper mail.
|
||||
|
||||
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.
|
||||
|
||||
<signature of Ty Coon>, 1 April 1990
|
||||
Ty Coon, President of Vice
|
||||
|
||||
That's all there is to it!
|
||||
21
unikernel/duniverse/pgx/Makefile
Normal file
21
unikernel/duniverse/pgx/Makefile
Normal file
|
|
@ -0,0 +1,21 @@
|
|||
PACKAGES := $(shell ls -1 *.opam | xargs echo | sed 's/.opam//g' | sed 's/ /,/g')
|
||||
|
||||
all: build
|
||||
|
||||
build:
|
||||
@dune build @install @examples -p $(PACKAGES)
|
||||
|
||||
clean:
|
||||
@dune clean
|
||||
|
||||
coverage: clean
|
||||
@BISECT_ENABLE=yes dune runtest -p $(PACKAGES)
|
||||
@bisect-ppx-report send-to Coveralls
|
||||
|
||||
test:
|
||||
@dune runtest --force -p $(PACKAGES)
|
||||
|
||||
test-coverage:
|
||||
@BISECT_ENABLE=yes dune runtest -p $(PACKAGES)
|
||||
|
||||
.PHONY: all build clean coverage test
|
||||
53
unikernel/duniverse/pgx/README.md
Normal file
53
unikernel/duniverse/pgx/README.md
Normal file
|
|
@ -0,0 +1,53 @@
|
|||
[](https://circleci.com/gh/arenadotio/pgx)
|
||||
[](https://coveralls.io/github/arenadotio/pgx?branch=master)
|
||||
[](https://arenadotio.github.io/pgx/index.html)
|
||||
|
||||
PGX is a pure-OCaml PostgreSQL client library, supporting Async, LWT, or
|
||||
synchronous operations.
|
||||
|
||||
This library focuses on correctness and safety, with features like:
|
||||
|
||||
- It is nearly impossible to try to execute a prepared statement that hasn't
|
||||
been prepared.
|
||||
- Trying to run multiple queries at the same time will work properly (although
|
||||
there's no performance benefit, since we currently don't send queries in
|
||||
parallel).
|
||||
- Lots of automated tests.
|
||||
- `Pgx.Value` for parameters and returned data, encouraging people to use
|
||||
the built-in converters instead of trying to handle everything as a string.
|
||||
- Async and LWT support are built in, no need to write your own IO module.
|
||||
- Mirage OS is supported via Pgx_lwt_mirage
|
||||
|
||||
We also provide a relatively high-level interface, like `Pgx_async.execute_pipe`,
|
||||
which prepares a statement, executes it with the given parameters, returns an
|
||||
`Async.Pipe.Reader.t` (so you can stream results), and unprepares the statement
|
||||
when the query is finished.
|
||||
|
||||
Significant portions of the code come from [PG'Ocaml](http://pgocaml.forge.ocamlcore.org/).
|
||||
|
||||
## Setup
|
||||
|
||||
```
|
||||
opam install pgx_async # or pgx_lwt_unix or pgx_unix or pgx_lwt_mirage
|
||||
```
|
||||
|
||||
## Examples
|
||||
|
||||
See [pgx_async/bin/pgx_async_example.ml](pgx_async/bin/pgx_async_example.ml) for
|
||||
a complete example of the high-level functional interface. To translate the
|
||||
example to Lwt, replace `Pgx_async` with `Pgx_lwt` and `>>|` with `>|=`. To
|
||||
translate it to synchronous IO / standard-library-only, use `Pgx_unix` and
|
||||
replace both `>>|` and `>>=` with `|>`, or just replace `>>| fun () ->` with `;`.
|
||||
|
||||
I.e. in `Pgx_unix`, you can replace:
|
||||
|
||||
```ocaml
|
||||
Pgx_async.execute ~params "INSERT INTO ..."
|
||||
>>| fun () ->
|
||||
```
|
||||
|
||||
... with:
|
||||
|
||||
```ocaml
|
||||
Pgx_unix.execute ~params "INSERT INTO ...";
|
||||
```
|
||||
0
unikernel/duniverse/pgx/doc/doc.odocl
Normal file
0
unikernel/duniverse/pgx/doc/doc.odocl
Normal file
186
unikernel/duniverse/pgx/dune-project
Normal file
186
unikernel/duniverse/pgx/dune-project
Normal file
|
|
@ -0,0 +1,186 @@
|
|||
(lang dune 3.2)
|
||||
|
||||
(name pgx)
|
||||
(version 2.2)
|
||||
|
||||
(generate_opam_files true)
|
||||
|
||||
(license "LGPL-2.0-only with OCaml-LGPL-linking-exception")
|
||||
|
||||
(maintainers "Arena Developers <silver-snakes@arena.io>")
|
||||
|
||||
(authors "Arena Developers <silver-snakes@arena.io>")
|
||||
|
||||
(source
|
||||
(github arenadotio/pgx))
|
||||
|
||||
(documentation "https://arenadotio.github.io/pgx")
|
||||
|
||||
(package
|
||||
(name pgx)
|
||||
(synopsis "Pure-OCaml PostgreSQL client library")
|
||||
(description
|
||||
"PGX is a pure-OCaml PostgreSQL client library, supporting Async, LWT, or synchronous operations.")
|
||||
(depends
|
||||
(alcotest
|
||||
(and
|
||||
:with-test
|
||||
(>= 1.0.0)))
|
||||
(bisect_ppx
|
||||
(and
|
||||
:dev
|
||||
(>= 2.0.0)))
|
||||
(dune
|
||||
(>= 3.2))
|
||||
hex
|
||||
ipaddr
|
||||
camlp-streams
|
||||
(ocaml
|
||||
(>= 4.08))
|
||||
(odoc :with-doc)
|
||||
(ppx_compare
|
||||
(>= v0.13.0))
|
||||
(ppx_custom_printf
|
||||
(>= v0.13.0))
|
||||
(ppx_sexp_conv
|
||||
(>= v0.13.0))
|
||||
(re
|
||||
(>= 1.5.0))
|
||||
(sexplib0
|
||||
(>= v0.13.0))
|
||||
uuidm))
|
||||
|
||||
(package
|
||||
(name pgx_unix)
|
||||
(synopsis
|
||||
"PGX using the standard library's Unix module for IO (synchronous)")
|
||||
(description
|
||||
"PGX using the standard library's Unix module for IO (synchronous)")
|
||||
(depends
|
||||
(alcotest
|
||||
(and
|
||||
:with-test
|
||||
(>= 1.0.0)))
|
||||
(base64
|
||||
(and
|
||||
:with-test
|
||||
(>= 3.0.0)))
|
||||
(ocaml
|
||||
(>= 4.08))
|
||||
(pgx
|
||||
(= :version))))
|
||||
|
||||
(package
|
||||
(name pgx_async)
|
||||
(synopsis "Pgx using Async for IO")
|
||||
(description "Pgx using Async for IO")
|
||||
(depends
|
||||
(alcotest-async
|
||||
(and
|
||||
:with-test
|
||||
(>= "1.0.0")))
|
||||
(async_kernel
|
||||
(>= "v0.13.0"))
|
||||
(async_unix
|
||||
(>= "v0.13.0"))
|
||||
async_ssl
|
||||
(base64
|
||||
(and
|
||||
:with-test
|
||||
(>= 3.0.0)))
|
||||
(conduit-async
|
||||
(>= 1.5.0))
|
||||
(ocaml
|
||||
(>= 4.08))
|
||||
(pgx
|
||||
(= :version))
|
||||
(pgx_value_core
|
||||
(= :version))))
|
||||
|
||||
(package
|
||||
(name pgx_lwt)
|
||||
(synopsis "Pgx using Lwt for IO")
|
||||
(description "Pgx using Lwt for IO")
|
||||
(depends
|
||||
lwt
|
||||
logs
|
||||
(ocaml
|
||||
(>= 4.08))
|
||||
(pgx
|
||||
(= :version))))
|
||||
|
||||
(package
|
||||
(name pgx_lwt_unix)
|
||||
(synopsis "Pgx using Lwt and Unix libraries for IO")
|
||||
(description "Pgx using Lwt and Unix libraries for IO")
|
||||
(depends
|
||||
(alcotest-lwt
|
||||
(and
|
||||
:with-test
|
||||
(>= "1.0.0")))
|
||||
(base64
|
||||
(and
|
||||
:with-test
|
||||
(>= 3.0.0)))
|
||||
(ocaml
|
||||
(>= 4.08))
|
||||
(pgx
|
||||
(= :version))
|
||||
(pgx_lwt
|
||||
(= :version))))
|
||||
|
||||
(package
|
||||
(name pgx_value_core)
|
||||
(synopsis "Pgx_value converters for Core types like Date and Time")
|
||||
(description "Pgx_value converters for Core types like Date and Time")
|
||||
(depends
|
||||
(alcotest
|
||||
(and
|
||||
:with-test
|
||||
(>= 1.0.0)))
|
||||
(core_kernel
|
||||
(>= "v0.13.0"))
|
||||
(ocaml
|
||||
(>= 4.08))
|
||||
(pgx
|
||||
(= :version))))
|
||||
|
||||
(package
|
||||
(name pgx_value_ptime)
|
||||
(synopsis "Pgx_value converters for Ptime types")
|
||||
(description "Pgx_value converters for Ptime types")
|
||||
(depends
|
||||
(alcotest
|
||||
(and
|
||||
:with-test
|
||||
(>= 1.0.0)))
|
||||
(ptime
|
||||
(>= 0.8.3))
|
||||
(ocaml
|
||||
(>= 4.08))
|
||||
(pgx
|
||||
(= :version))))
|
||||
|
||||
(package
|
||||
(name pgx_lwt_mirage)
|
||||
(synopsis "Pgx using Lwt on Mirage for IO")
|
||||
(description "Pgx using Lwt on Mirage for IO")
|
||||
(depends
|
||||
lwt
|
||||
(ocaml
|
||||
(>= 4.08))
|
||||
logs
|
||||
mirage-channel
|
||||
(conduit-mirage
|
||||
(>= 2.3.0))
|
||||
(dns-client
|
||||
(>= 6.0.0))
|
||||
mirage-random
|
||||
mirage-time
|
||||
mirage-clock
|
||||
(tcpip
|
||||
(>= 7.0.0))
|
||||
(pgx
|
||||
(= :version))
|
||||
(pgx_lwt
|
||||
(= :version))))
|
||||
43
unikernel/duniverse/pgx/pgx.opam
Normal file
43
unikernel/duniverse/pgx/pgx.opam
Normal file
|
|
@ -0,0 +1,43 @@
|
|||
version: "2.2"
|
||||
# This file is generated by dune, edit dune-project instead
|
||||
opam-version: "2.0"
|
||||
synopsis: "Pure-OCaml PostgreSQL client library"
|
||||
description:
|
||||
"PGX is a pure-OCaml PostgreSQL client library, supporting Async, LWT, or synchronous operations."
|
||||
maintainer: ["Arena Developers <silver-snakes@arena.io>"]
|
||||
authors: ["Arena Developers <silver-snakes@arena.io>"]
|
||||
license: "LGPL-2.0-only with OCaml-LGPL-linking-exception"
|
||||
homepage: "https://github.com/arenadotio/pgx"
|
||||
doc: "https://arenadotio.github.io/pgx"
|
||||
bug-reports: "https://github.com/arenadotio/pgx/issues"
|
||||
depends: [
|
||||
"alcotest" {with-test & >= "1.0.0"}
|
||||
"bisect_ppx" {dev & >= "2.0.0"}
|
||||
"dune" {>= "3.2" & >= "3.2"}
|
||||
"hex"
|
||||
"ipaddr"
|
||||
"camlp-streams"
|
||||
"ocaml" {>= "4.08"}
|
||||
"odoc" {with-doc}
|
||||
"ppx_compare" {>= "v0.13.0"}
|
||||
"ppx_custom_printf" {>= "v0.13.0"}
|
||||
"ppx_sexp_conv" {>= "v0.13.0"}
|
||||
"re" {>= "1.5.0"}
|
||||
"sexplib0" {>= "v0.13.0"}
|
||||
"uuidm"
|
||||
]
|
||||
build: [
|
||||
["dune" "subst"] {dev}
|
||||
[
|
||||
"dune"
|
||||
"build"
|
||||
"-p"
|
||||
name
|
||||
"-j"
|
||||
jobs
|
||||
"@install"
|
||||
"@runtest" {with-test}
|
||||
"@doc" {with-doc}
|
||||
]
|
||||
]
|
||||
dev-repo: "git+https://github.com/arenadotio/pgx.git"
|
||||
9
unikernel/duniverse/pgx/pgx/src/access.ml
Normal file
9
unikernel/duniverse/pgx/pgx/src/access.ml
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
type t =
|
||||
| Read_write
|
||||
| Read_only
|
||||
[@@deriving sexp]
|
||||
|
||||
let to_string = function
|
||||
| Read_write -> "read write"
|
||||
| Read_only -> "read only"
|
||||
;;
|
||||
6
unikernel/duniverse/pgx/pgx/src/access.mli
Normal file
6
unikernel/duniverse/pgx/pgx/src/access.mli
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
type t =
|
||||
| Read_write
|
||||
| Read_only
|
||||
[@@deriving sexp]
|
||||
|
||||
val to_string : t -> string
|
||||
15
unikernel/duniverse/pgx/pgx/src/dune
Normal file
15
unikernel/duniverse/pgx/pgx/src/dune
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
(* -*- tuareg -*- *)
|
||||
|
||||
let preprocess =
|
||||
match Sys.getenv "BISECT_ENABLE" with
|
||||
| "yes" -> "bisect_ppx"
|
||||
| _ -> ""
|
||||
| exception Not_found -> ""
|
||||
|
||||
let () = Jbuild_plugin.V1.send @@ {|
|
||||
|
||||
(library
|
||||
(public_name pgx)
|
||||
(libraries hex ipaddr uuidm re sexplib0 camlp-streams)
|
||||
(preprocess (pps ppx_compare ppx_custom_printf ppx_sexp_conv |} ^ preprocess ^ {|)))
|
||||
|}
|
||||
32
unikernel/duniverse/pgx/pgx/src/error_response.ml
Normal file
32
unikernel/duniverse/pgx/pgx/src/error_response.ml
Normal file
|
|
@ -0,0 +1,32 @@
|
|||
open Printf
|
||||
open Sexplib0.Sexp_conv
|
||||
open Pgx_aux
|
||||
|
||||
type t =
|
||||
{ code : string
|
||||
; severity : string
|
||||
; message : string
|
||||
; custom : (char * string) list
|
||||
}
|
||||
[@@deriving sexp]
|
||||
|
||||
let should_print t ~verbose =
|
||||
if verbose < 1
|
||||
then false
|
||||
else if verbose = 1
|
||||
then (
|
||||
match t.severity with
|
||||
| "ERROR" | "FATAL" | "PANIC" -> true
|
||||
| _ -> false)
|
||||
else true
|
||||
;;
|
||||
|
||||
let to_string ?(verbose = false) t =
|
||||
let msg = sprintf "%s: %s: %s" t.severity t.code t.message in
|
||||
let field_info =
|
||||
if verbose
|
||||
then List.map (fun (field_type, field) -> sprintf "%c: %s" field_type field) t.custom
|
||||
else []
|
||||
in
|
||||
String.concat "\n" (msg :: field_info)
|
||||
;;
|
||||
10
unikernel/duniverse/pgx/pgx/src/error_response.mli
Normal file
10
unikernel/duniverse/pgx/pgx/src/error_response.mli
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
type t =
|
||||
{ code : string
|
||||
; severity : string
|
||||
; message : string
|
||||
; custom : (char * string) list
|
||||
}
|
||||
[@@deriving sexp]
|
||||
|
||||
val should_print : t -> verbose:int -> bool
|
||||
val to_string : ?verbose:bool -> t -> string
|
||||
48
unikernel/duniverse/pgx/pgx/src/io_intf.ml
Normal file
48
unikernel/duniverse/pgx/pgx/src/io_intf.ml
Normal file
|
|
@ -0,0 +1,48 @@
|
|||
(** The interface implemented by IO backends (Async, Lwt, Unix, etc.) *)
|
||||
module type S = sig
|
||||
type 'a t
|
||||
|
||||
val return : 'a -> 'a t
|
||||
val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
|
||||
val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t
|
||||
|
||||
type in_channel
|
||||
type out_channel
|
||||
|
||||
type sockaddr =
|
||||
| Unix of string
|
||||
| Inet of string * int
|
||||
|
||||
val open_connection : sockaddr -> (in_channel * out_channel) t
|
||||
|
||||
type ssl_config
|
||||
|
||||
val upgrade_ssl
|
||||
: [ `Not_supported
|
||||
| `Supported of
|
||||
?ssl_config:ssl_config
|
||||
-> in_channel
|
||||
-> out_channel
|
||||
-> (in_channel * out_channel) t
|
||||
]
|
||||
|
||||
val output_char : out_channel -> char -> unit t
|
||||
val output_binary_int : out_channel -> int -> unit t
|
||||
val output_string : out_channel -> string -> unit t
|
||||
val flush : out_channel -> unit t
|
||||
val input_char : in_channel -> char t
|
||||
val input_binary_int : in_channel -> int t
|
||||
val really_input : in_channel -> Bytes.t -> int -> int -> unit t
|
||||
val close_in : in_channel -> unit t
|
||||
val getlogin : unit -> string t
|
||||
val debug : string -> unit t
|
||||
val protect : (unit -> 'a t) -> finally:(unit -> unit t) -> 'a t
|
||||
|
||||
module Sequencer : sig
|
||||
type 'a monad = 'a t
|
||||
type 'a t
|
||||
|
||||
val create : 'a -> 'a t
|
||||
val enqueue : 'a t -> ('a -> 'b monad) -> 'b monad
|
||||
end
|
||||
end
|
||||
13
unikernel/duniverse/pgx/pgx/src/isolation.ml
Normal file
13
unikernel/duniverse/pgx/pgx/src/isolation.ml
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
type t =
|
||||
| Serializable
|
||||
| Repeatable_read
|
||||
| Read_committed
|
||||
| Read_uncommitted
|
||||
[@@deriving sexp]
|
||||
|
||||
let to_string = function
|
||||
| Serializable -> "serializable"
|
||||
| Repeatable_read -> "repeatable read"
|
||||
| Read_committed -> "read committed"
|
||||
| Read_uncommitted -> "read uncommitted"
|
||||
;;
|
||||
9
unikernel/duniverse/pgx/pgx/src/isolation.mli
Normal file
9
unikernel/duniverse/pgx/pgx/src/isolation.mli
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
(** Database transaction isolation levels *)
|
||||
type t =
|
||||
| Serializable
|
||||
| Repeatable_read
|
||||
| Read_committed
|
||||
| Read_uncommitted
|
||||
[@@deriving sexp]
|
||||
|
||||
val to_string : t -> string
|
||||
1153
unikernel/duniverse/pgx/pgx/src/pgx.ml
Normal file
1153
unikernel/duniverse/pgx/pgx/src/pgx.ml
Normal file
File diff suppressed because it is too large
Load diff
53
unikernel/duniverse/pgx/pgx/src/pgx.mli
Normal file
53
unikernel/duniverse/pgx/pgx/src/pgx.mli
Normal file
|
|
@ -0,0 +1,53 @@
|
|||
(* PG'OCaml is a set of OCaml bindings for the PostgreSQL database.
|
||||
*
|
||||
* PG'OCaml - type safe interface to PostgreSQL.
|
||||
* Copyright (C) 2005-2009 Richard Jones and other authors.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Library General Public
|
||||
* License as published by the Free Software Foundation; either
|
||||
* version 2 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
|
||||
* Library General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU General Public License
|
||||
* along with this library; see the file COPYING. If not, write to
|
||||
* the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
* Boston, MA 02111-1307, USA.
|
||||
*)
|
||||
module type Io = Io_intf.S
|
||||
|
||||
(* FIXME: I can't figure out how to not duplicate these types from types.ml *)
|
||||
type oid = int32 [@@deriving compare, sexp]
|
||||
|
||||
(** None is NULL. *)
|
||||
type param = Pgx_value.t [@@deriving compare, sexp_of]
|
||||
|
||||
(** None is NULL. *)
|
||||
type result = Pgx_value.t [@@deriving compare, sexp_of]
|
||||
|
||||
(** One row is a list of fields. *)
|
||||
type row = Pgx_value.t list [@@deriving compare, sexp_of]
|
||||
|
||||
type params_description = oid list [@@deriving compare, sexp]
|
||||
|
||||
(** For errors generated by the PostgreSQL database back-end. The
|
||||
* first argument is a printable error message. The second argument
|
||||
* is the complete set of error fields returned from the back-end.
|
||||
* See [http://www.postgresql.org/docs/8.1/static/protocol-error-fields.html] *)
|
||||
exception PostgreSQL_Error of string * Error_response.t
|
||||
[@@deriving sexp]
|
||||
|
||||
module Access = Access
|
||||
module Isolation = Isolation
|
||||
module Error_response = Error_response
|
||||
module Result_desc = Result_desc
|
||||
module Value = Pgx_value
|
||||
|
||||
module type S = Pgx_intf.S
|
||||
|
||||
module Make (Thread : Io) :
|
||||
S with type 'a Io.t = 'a Thread.t and type Io.ssl_config = Thread.ssl_config
|
||||
65
unikernel/duniverse/pgx/pgx/src/pgx_aux.ml
Normal file
65
unikernel/duniverse/pgx/pgx/src/pgx_aux.ml
Normal file
|
|
@ -0,0 +1,65 @@
|
|||
module String = struct
|
||||
include String
|
||||
|
||||
let implode xs =
|
||||
let buf = Buffer.create (List.length xs) in
|
||||
List.iter (Buffer.add_char buf) xs;
|
||||
Buffer.contents buf
|
||||
;;
|
||||
|
||||
let fold_left f init str =
|
||||
let len = length str in
|
||||
let rec loop i accum = if i = len then accum else loop (i + 1) (f accum str.[i]) in
|
||||
loop 0 init
|
||||
;;
|
||||
end
|
||||
|
||||
module List = struct
|
||||
include List
|
||||
|
||||
(* From Base
|
||||
https://github.com/janestreet/base/blob/f86e72ee3b59ff5315e20a8392b81fb2f5237a25/src/ppx_compare_lib.ml
|
||||
|
||||
The MIT License
|
||||
|
||||
Copyright (c) 2016--2020 Jane Street Group, LLC <opensource@janestreet.com>
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
*)
|
||||
let rec compare compare_elt a b =
|
||||
match a, b with
|
||||
| [], [] -> 0
|
||||
| [], _ -> -1
|
||||
| _, [] -> 1
|
||||
| x :: xs, y :: ys ->
|
||||
let res = compare_elt x y in
|
||||
if res <> 0 then res else compare compare_elt xs ys
|
||||
;;
|
||||
|
||||
(* The default List.map isn't tail recursive so we replace it with one that is *)
|
||||
let map f xs = List.rev_map f xs |> List.rev
|
||||
end
|
||||
|
||||
let compare_bool = Bool.compare
|
||||
let compare_float = Float.compare
|
||||
let compare_int = Int.compare
|
||||
let compare_int32 = Int32.compare
|
||||
let compare_list = List.compare
|
||||
let compare_option = Option.compare
|
||||
let compare_string = String.compare
|
||||
25
unikernel/duniverse/pgx/pgx/src/pgx_aux.mli
Normal file
25
unikernel/duniverse/pgx/pgx/src/pgx_aux.mli
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
(** Helper functions since we don't want a dependency on Core or Batteries. *)
|
||||
|
||||
module String : sig
|
||||
include module type of String
|
||||
|
||||
val implode : char list -> string
|
||||
val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a
|
||||
end
|
||||
|
||||
module List : sig
|
||||
include module type of List
|
||||
|
||||
(** Like the built-in [List.map], but tail-recursive *)
|
||||
val map : ('a -> 'b) -> 'a list -> 'b list
|
||||
end
|
||||
|
||||
(** Necessary for ppx_compare *)
|
||||
val compare_bool : bool -> bool -> int
|
||||
|
||||
val compare_float : float -> float -> int
|
||||
val compare_int : int -> int -> int
|
||||
val compare_int32 : int32 -> int32 -> int
|
||||
val compare_list : ('a -> 'a -> int) -> 'a list -> 'a list -> int
|
||||
val compare_option : ('a -> 'a -> int) -> 'a option -> 'a option -> int
|
||||
val compare_string : string -> string -> int
|
||||
216
unikernel/duniverse/pgx/pgx/src/pgx_intf.ml
Normal file
216
unikernel/duniverse/pgx/pgx/src/pgx_intf.ml
Normal file
|
|
@ -0,0 +1,216 @@
|
|||
open Types
|
||||
|
||||
module type S = sig
|
||||
type t
|
||||
|
||||
module Io : sig
|
||||
type 'a t
|
||||
type ssl_config
|
||||
|
||||
val return : 'a -> 'a t
|
||||
val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
|
||||
val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t
|
||||
val protect : (unit -> 'a t) -> finally:(unit -> unit t) -> 'a t
|
||||
end
|
||||
|
||||
(** Connect to the database. The normal [$PGDATABASE], etc. environment
|
||||
variables are available.
|
||||
|
||||
[max_message_length] is the maximum message length accepted from the back-end.
|
||||
The default is [Sys.max_string_length], which means that we will try to
|
||||
read as much data from the back-end as we can, and this may cause us to
|
||||
run out of memory (particularly on 64 bit machines), causing a
|
||||
possible denial of service. You may want to set this to a smaller
|
||||
size to avoid this happening. *)
|
||||
val connect
|
||||
: ?ssl:[ `Auto | `No | `Always of Io.ssl_config ]
|
||||
-> ?host:string
|
||||
-> ?port:int
|
||||
-> ?user:string
|
||||
-> ?password:string
|
||||
-> ?database:string
|
||||
-> ?unix_domain_socket_dir:string
|
||||
-> ?verbose:int
|
||||
-> ?max_message_length:int
|
||||
-> unit
|
||||
-> t Io.t
|
||||
|
||||
(** Close the database handle. You must call this after you have
|
||||
finished with the handle, or else you will get leaked file
|
||||
descriptors. *)
|
||||
val close : t -> unit Io.t
|
||||
|
||||
(** Calls [connect], passes the DB handle to the callback, then calls
|
||||
[close]. This is the preferred way to use this library since it cleans up
|
||||
after itself. *)
|
||||
val with_conn
|
||||
: ?ssl:[ `Auto | `No | `Always of Io.ssl_config ]
|
||||
-> ?host:string
|
||||
-> ?port:int
|
||||
-> ?user:string
|
||||
-> ?password:string
|
||||
-> ?database:string
|
||||
-> ?unix_domain_socket_dir:string
|
||||
-> ?verbose:int
|
||||
-> ?max_message_length:int
|
||||
-> (t -> 'a Io.t)
|
||||
-> 'a Io.t
|
||||
|
||||
(** Ping the database. If the database is not available, some sort of
|
||||
exception will be thrown. *)
|
||||
val ping : t -> unit Io.t
|
||||
|
||||
(** This function is a wrapper of [ping] that returns a boolean instead of
|
||||
raising an exception. *)
|
||||
val alive : t -> bool Io.t
|
||||
|
||||
(** Start a transaction. *)
|
||||
val begin_work
|
||||
: ?isolation:Isolation.t
|
||||
-> ?access:Access.t
|
||||
-> ?deferrable:bool
|
||||
-> t
|
||||
-> t Io.t
|
||||
|
||||
(** Commit a transaction. Throws an exception if no transaction is open.
|
||||
Use [with_transaction] when possible. *)
|
||||
val commit : t -> unit Io.t
|
||||
|
||||
(** Rollback a transaction. Throws an exception if no transaction is open.
|
||||
Use [with_transaction] when possible. *)
|
||||
val rollback : t -> unit Io.t
|
||||
|
||||
(** [with_transaction db ?isolation ?access ?deferrable f] wraps your
|
||||
function [f] inside a transactional block.
|
||||
See [begin_work] for a description of [isolation], [access], and
|
||||
[deferrable].
|
||||
If [f] throws an exception, the transaction will be rolled back. Otherwise
|
||||
the transaction will be commited. It is an error to call [commit] or
|
||||
[rollback] manually inside of this function. *)
|
||||
val with_transaction
|
||||
: ?isolation:Isolation.t
|
||||
-> ?access:Access.t
|
||||
-> ?deferrable:bool
|
||||
-> t
|
||||
-> (t -> 'b Io.t)
|
||||
-> 'b Io.t
|
||||
|
||||
module Prepared : sig
|
||||
type s [@@deriving sexp_of]
|
||||
|
||||
(** [prepare ?name ?types conn ~query] prepares the statement [query] and
|
||||
sets the parameter types to [types].
|
||||
If no [name] is given, a random name will be generated.
|
||||
If no types are given, then the PostgreSQL engine infers types. *)
|
||||
val prepare : ?name:string -> ?types:oid list -> t -> query:string -> s Io.t
|
||||
|
||||
(** [close_statement t] closes a prepared statement and frees
|
||||
up any resources. *)
|
||||
val close : s -> unit Io.t
|
||||
|
||||
(** [prepare] a query, execute [f], and then [close_statement] *)
|
||||
val with_prepare
|
||||
: ?name:string
|
||||
-> ?types:oid list
|
||||
-> t
|
||||
-> query:string
|
||||
-> f:(s -> 'a Io.t)
|
||||
-> 'a Io.t
|
||||
|
||||
(** [execute conn ~params t] executes the given prepared statement, with
|
||||
the given parameters [params], returning the result rows (if any).
|
||||
|
||||
There are several steps involved at the protocol layer:
|
||||
(1) a "portal" is created from the statement, binding the
|
||||
parameters in the statement (Bind).
|
||||
(2) the portal is executed (Execute).
|
||||
(3) we synchronise the connection (Sync).
|
||||
|
||||
The optional [?portal] parameter may be used to name the portal
|
||||
created in step (1) above (otherwise the unnamed portal is used).
|
||||
This is only important if you want to call {!describe_portal}
|
||||
to find out the result types. *)
|
||||
val execute : ?portal:string -> s -> params:param list -> row list Io.t
|
||||
|
||||
(** [execute_unit ?portal s ?params] same as execute, but intended
|
||||
for database calls that have side-affects rather than returning results *)
|
||||
val execute_unit : ?portal:string -> s -> params:param list -> unit Io.t
|
||||
|
||||
val execute_fold
|
||||
: ?portal:string
|
||||
-> s
|
||||
-> params:param list
|
||||
-> init:'accum
|
||||
-> f:('accum -> row -> 'accum Io.t)
|
||||
-> 'accum Io.t
|
||||
|
||||
val execute_iter
|
||||
: ?portal:string
|
||||
-> s
|
||||
-> params:param list
|
||||
-> f:(row -> unit Io.t)
|
||||
-> unit Io.t
|
||||
|
||||
val execute_map
|
||||
: ?portal:string
|
||||
-> s
|
||||
-> params:param list
|
||||
-> f:(row -> 'a Io.t)
|
||||
-> 'a list Io.t
|
||||
|
||||
val execute_many : s -> params:param list list -> row list list Io.t
|
||||
|
||||
(** [describe_statement t] describes the statement's parameter types and
|
||||
result types. *)
|
||||
val describe : s -> (params_description * Result_desc.t list option) Io.t
|
||||
|
||||
(** [close_portal conn ?portal ()] closes a portal and frees up any
|
||||
resources. *)
|
||||
val close_portal : ?portal:string -> s -> unit Io.t
|
||||
|
||||
(** [describe_portal conn ?portal ()] describes the named or unnamed
|
||||
portal's result types. *)
|
||||
val describe_portal : ?portal:string -> s -> Result_desc.t list option Io.t
|
||||
end
|
||||
|
||||
(** [execute conn ?params query] prepares and executes the statement
|
||||
[query] and returns the result. *)
|
||||
val execute : ?params:row -> t -> string -> row list Io.t
|
||||
|
||||
(** [execute_unit conn ?params query ] same as execute, but intended
|
||||
for database calls that have side-affects rather than returning results *)
|
||||
val execute_unit : ?params:row -> t -> string -> unit Io.t
|
||||
|
||||
val execute_fold
|
||||
: ?params:param list
|
||||
-> t
|
||||
-> string
|
||||
-> init:'accum
|
||||
-> f:('accum -> row -> 'accum Io.t)
|
||||
-> 'accum Io.t
|
||||
|
||||
val execute_map
|
||||
: ?params:param list
|
||||
-> t
|
||||
-> string
|
||||
-> f:(row -> 'a Io.t)
|
||||
-> 'a list Io.t
|
||||
|
||||
val execute_iter
|
||||
: ?params:param list
|
||||
-> t
|
||||
-> string
|
||||
-> f:(row -> unit Io.t)
|
||||
-> unit Io.t
|
||||
|
||||
(** Prepares a query as in [execute] and then executes it once per set of
|
||||
parameters in [params]. This is more efficient than calling [execute]
|
||||
in a loop because the query is only prepared once. *)
|
||||
val execute_many : t -> query:string -> params:param list list -> row list list Io.t
|
||||
|
||||
(** [simple_query conn query] executes the command(s) in the given [query]
|
||||
and returns a list of query results (i.e. if you run two queries, you
|
||||
will get a list with two elements: the results of the first query
|
||||
followed by the results of the second query. *)
|
||||
val simple_query : t -> string -> row list list Io.t
|
||||
end
|
||||
345
unikernel/duniverse/pgx/pgx/src/pgx_value.ml
Normal file
345
unikernel/duniverse/pgx/pgx/src/pgx_value.ml
Normal file
|
|
@ -0,0 +1,345 @@
|
|||
open Sexplib0.Sexp_conv
|
||||
open Pgx_aux
|
||||
|
||||
type v = string [@@deriving compare, sexp_of]
|
||||
type t = v option [@@deriving compare, sexp_of]
|
||||
|
||||
exception Conversion_failure of string [@@deriving sexp_of]
|
||||
|
||||
let convert_failure ?hint type_ s =
|
||||
let hint =
|
||||
match hint with
|
||||
| None -> ""
|
||||
| Some hint -> Printf.sprintf " (%s)" hint
|
||||
in
|
||||
Conversion_failure (Printf.sprintf "Unable to convert to %s%s: %s" type_ hint s)
|
||||
|> raise
|
||||
;;
|
||||
|
||||
let required f = function
|
||||
| Some x -> f x
|
||||
| None -> raise (Conversion_failure "Expected not-null but got null")
|
||||
;;
|
||||
|
||||
let opt f v = Option.bind v f
|
||||
let null = None
|
||||
|
||||
let of_binary b =
|
||||
match b with
|
||||
| "" -> Some ""
|
||||
| _ ->
|
||||
(try
|
||||
let (`Hex hex) = Hex.of_string b in
|
||||
Some ("\\x" ^ hex)
|
||||
with
|
||||
| exn -> convert_failure ~hint:(Printexc.to_string exn) "binary" b)
|
||||
;;
|
||||
|
||||
let to_binary' = function
|
||||
| "" -> ""
|
||||
| t ->
|
||||
(* Skip if not encoded as hex *)
|
||||
(try
|
||||
if String.sub t 0 2 <> "\\x"
|
||||
then t (* Decode if encoded as hex *)
|
||||
else `Hex (String.sub t 2 (String.length t - 2)) |> Hex.to_string
|
||||
with
|
||||
| exn -> convert_failure ~hint:(Printexc.to_string exn) "binary" t)
|
||||
;;
|
||||
|
||||
let to_binary_exn = required to_binary'
|
||||
let to_binary = Option.map to_binary'
|
||||
|
||||
let of_bool = function
|
||||
| true -> Some "t"
|
||||
| false -> Some "f"
|
||||
;;
|
||||
|
||||
let to_bool' = function
|
||||
| "t" -> true
|
||||
| "f" -> false
|
||||
| s -> convert_failure "bool" s
|
||||
;;
|
||||
|
||||
let to_bool_exn = required to_bool'
|
||||
let to_bool = Option.map to_bool'
|
||||
|
||||
let of_float' f =
|
||||
match classify_float f with
|
||||
| FP_infinite when f > 0. -> "Infinity"
|
||||
| FP_infinite when f < 0. -> "-Infinity"
|
||||
| FP_nan -> "NaN"
|
||||
| _ -> string_of_float f
|
||||
;;
|
||||
|
||||
let of_float f = Some (of_float' f)
|
||||
|
||||
let to_float' t =
|
||||
match String.lowercase_ascii t with
|
||||
| "infinity" -> infinity
|
||||
| "-infinity" -> neg_infinity
|
||||
| "nan" -> nan
|
||||
| _ ->
|
||||
(try float_of_string t with
|
||||
| Failure hint -> convert_failure ~hint "float" t)
|
||||
;;
|
||||
|
||||
let to_float_exn = required to_float'
|
||||
let to_float = Option.map to_float'
|
||||
|
||||
type hstore = (string * string option) list [@@deriving compare, sexp_of]
|
||||
|
||||
let of_hstore hstore =
|
||||
let string_of_quoted str = "\"" ^ str ^ "\"" in
|
||||
let string_of_mapping (key, value) =
|
||||
let key_str = string_of_quoted key
|
||||
and value_str =
|
||||
match value with
|
||||
| Some v -> string_of_quoted v
|
||||
| None -> "NULL"
|
||||
in
|
||||
key_str ^ "=>" ^ value_str
|
||||
in
|
||||
Some (String.concat ", " (List.map string_of_mapping hstore))
|
||||
;;
|
||||
|
||||
let to_hstore' str =
|
||||
let expect target stream =
|
||||
if List.exists (fun c -> c <> Stream.next stream) target
|
||||
then convert_failure "hstore" str
|
||||
in
|
||||
let parse_quoted stream =
|
||||
let rec loop accum stream =
|
||||
match Stream.next stream with
|
||||
| '"' -> String.implode (List.rev accum)
|
||||
(* FIXME: Slashes don't seem to round-trip properly *)
|
||||
| '\\' -> loop (Stream.next stream :: accum) stream
|
||||
| x -> loop (x :: accum) stream
|
||||
in
|
||||
expect [ '"' ] stream;
|
||||
loop [] stream
|
||||
in
|
||||
let parse_value stream =
|
||||
match Stream.peek stream with
|
||||
| Some 'N' ->
|
||||
expect [ 'N'; 'U'; 'L'; 'L' ] stream;
|
||||
None
|
||||
| _ -> Some (parse_quoted stream)
|
||||
in
|
||||
let parse_mapping stream =
|
||||
let key = parse_quoted stream in
|
||||
expect [ '='; '>' ] stream;
|
||||
let value = parse_value stream in
|
||||
key, value
|
||||
in
|
||||
let parse_main stream =
|
||||
let rec loop accum stream =
|
||||
let mapping = parse_mapping stream in
|
||||
match Stream.peek stream with
|
||||
| Some _ ->
|
||||
expect [ ','; ' ' ] stream;
|
||||
loop (mapping :: accum) stream
|
||||
| None -> mapping :: accum
|
||||
in
|
||||
match Stream.peek stream with
|
||||
| Some _ -> loop [] stream
|
||||
| None -> []
|
||||
in
|
||||
parse_main (Stream.of_string str)
|
||||
;;
|
||||
|
||||
let to_hstore_exn = required to_hstore'
|
||||
let to_hstore = Option.map to_hstore'
|
||||
|
||||
type inet = Ipaddr.t * int [@@deriving compare]
|
||||
|
||||
let sexp_of_inet (addr, mask) = [%sexp_of: string * int] (Ipaddr.to_string addr, mask)
|
||||
|
||||
let of_inet (addr, mask) =
|
||||
let hostmask =
|
||||
match addr with
|
||||
| Ipaddr.V4 _ -> 32
|
||||
| Ipaddr.V6 _ -> 128
|
||||
in
|
||||
let addr = Ipaddr.to_string addr in
|
||||
if mask = hostmask
|
||||
then Some addr
|
||||
else if mask >= 0 && mask < hostmask
|
||||
then Some (addr ^ "/" ^ string_of_int mask)
|
||||
else invalid_arg "mask"
|
||||
;;
|
||||
|
||||
let to_inet' =
|
||||
let re =
|
||||
let open Re in
|
||||
[ group
|
||||
([ rep (compl [ set ":./" ]); group (set ":."); rep1 (compl [ char '/' ]) ] |> seq)
|
||||
; opt (seq [ char '/'; group (rep1 any) ])
|
||||
]
|
||||
|> seq
|
||||
|> compile
|
||||
in
|
||||
fun str ->
|
||||
try
|
||||
let subs = Re.exec re str in
|
||||
let addr = Ipaddr.of_string_exn (Re.Group.get subs 1) in
|
||||
(* optional match *)
|
||||
let mask =
|
||||
try Re.Group.get subs 3 with
|
||||
| Not_found -> ""
|
||||
in
|
||||
if mask = ""
|
||||
then addr, if Re.Group.get subs 2 = "." then 32 else 128
|
||||
else addr, int_of_string mask
|
||||
with
|
||||
| exn -> convert_failure ~hint:(Printexc.to_string exn) "inet" str
|
||||
;;
|
||||
|
||||
let to_inet_exn = required to_inet'
|
||||
let to_inet = Option.map to_inet'
|
||||
let of_int i = Some (string_of_int i)
|
||||
|
||||
let to_int' t =
|
||||
try int_of_string t with
|
||||
| Failure hint -> convert_failure ~hint "int" t
|
||||
;;
|
||||
|
||||
let to_int_exn = required to_int'
|
||||
let to_int = Option.map to_int'
|
||||
let of_int32 i = Some (Int32.to_string i)
|
||||
|
||||
let to_int32' t =
|
||||
try Int32.of_string t with
|
||||
| Failure hint -> convert_failure ~hint "int32" t
|
||||
;;
|
||||
|
||||
let to_int32_exn = required to_int32'
|
||||
let to_int32 = Option.map to_int32'
|
||||
let of_int64 i = Some (Int64.to_string i)
|
||||
|
||||
let to_int64' t =
|
||||
try Int64.of_string t with
|
||||
| Failure hint -> convert_failure ~hint "int64" t
|
||||
;;
|
||||
|
||||
let to_int64_exn = required to_int64'
|
||||
let to_int64 = Option.map to_int64'
|
||||
|
||||
let escape_string str =
|
||||
let buf = Buffer.create 128 in
|
||||
for i = 0 to String.length str - 1 do
|
||||
match str.[i] with
|
||||
| ('"' | '\\') as x ->
|
||||
Buffer.add_char buf '\\';
|
||||
Buffer.add_char buf x
|
||||
| x -> Buffer.add_char buf x
|
||||
done;
|
||||
Buffer.contents buf
|
||||
;;
|
||||
|
||||
let of_list (xs : t list) =
|
||||
let buf = Buffer.create 128 in
|
||||
Buffer.add_char buf '{';
|
||||
let adder i x =
|
||||
if i > 0 then Buffer.add_char buf ',';
|
||||
match x with
|
||||
| Some x ->
|
||||
let x = escape_string x in
|
||||
Buffer.add_char buf '"';
|
||||
Buffer.add_string buf x;
|
||||
Buffer.add_char buf '"'
|
||||
| None -> Buffer.add_string buf "NULL"
|
||||
in
|
||||
List.iteri adder xs;
|
||||
Buffer.add_char buf '}';
|
||||
Some (Buffer.contents buf)
|
||||
;;
|
||||
|
||||
let to_list' str =
|
||||
let n = String.length str in
|
||||
if n = 0 || str.[0] <> '{' || str.[n - 1] <> '}' then convert_failure "list" str;
|
||||
let str = String.sub str 1 (n - 2) in
|
||||
let buf = Buffer.create 128 in
|
||||
let add_field accum =
|
||||
let x = Buffer.contents buf in
|
||||
Buffer.clear buf;
|
||||
let field =
|
||||
if x = "NULL"
|
||||
then None
|
||||
else (
|
||||
let n = String.length x in
|
||||
if n >= 2 && x.[0] = '"' then Some (String.sub x 1 (n - 2)) else Some x)
|
||||
in
|
||||
field :: accum
|
||||
in
|
||||
let loop (accum, quoted, escaped) = function
|
||||
| '\\' when not escaped -> accum, quoted, true
|
||||
| '"' when not escaped ->
|
||||
Buffer.add_char buf '"';
|
||||
accum, not quoted, false
|
||||
| ',' when (not escaped) && not quoted -> add_field accum, false, false
|
||||
| x ->
|
||||
Buffer.add_char buf x;
|
||||
accum, quoted, false
|
||||
in
|
||||
let accum, _, _ = String.fold_left loop ([], false, false) str in
|
||||
let accum = if Buffer.length buf = 0 then accum else add_field accum in
|
||||
List.rev accum
|
||||
;;
|
||||
|
||||
let to_list_exn = required to_list'
|
||||
let to_list = Option.map to_list'
|
||||
|
||||
type point = float * float [@@deriving compare, sexp_of]
|
||||
|
||||
let of_point (x, y) =
|
||||
let x = of_float' x in
|
||||
let y = of_float' y in
|
||||
Some (Printf.sprintf "(%s,%s)" x y)
|
||||
;;
|
||||
|
||||
let to_point' =
|
||||
let point_re =
|
||||
let open Re in
|
||||
let part = seq [ rep space; group (rep any); rep space ] in
|
||||
[ rep space; char '('; part; char ','; part; char ')'; rep space ]
|
||||
|> seq
|
||||
|> whole_string
|
||||
|> compile
|
||||
in
|
||||
fun str ->
|
||||
try
|
||||
let subs = Re.exec point_re str in
|
||||
float_of_string (Re.Group.get subs 1), float_of_string (Re.Group.get subs 2)
|
||||
with
|
||||
| exn -> convert_failure ~hint:(Printexc.to_string exn) "point" str
|
||||
;;
|
||||
|
||||
let to_point_exn = required to_point'
|
||||
let to_point = Option.map to_point'
|
||||
let of_string t = Some t
|
||||
let to_string_exn = required (fun t -> t)
|
||||
let to_string t = t
|
||||
let unit = Some ""
|
||||
|
||||
let to_unit' = function
|
||||
| "" -> ()
|
||||
| t -> convert_failure "unit" t
|
||||
;;
|
||||
|
||||
let to_unit_exn = required to_unit'
|
||||
let to_unit = Option.map to_unit'
|
||||
|
||||
type uuid = Uuidm.t [@@deriving compare]
|
||||
|
||||
let sexp_of_uuid u = Uuidm.to_string u |> sexp_of_string
|
||||
let of_uuid s = Some (Uuidm.to_string s)
|
||||
|
||||
let to_uuid' t =
|
||||
match Uuidm.of_string t with
|
||||
| Some u -> u
|
||||
| None -> convert_failure "uuid" t
|
||||
;;
|
||||
|
||||
let to_uuid_exn = required to_uuid'
|
||||
let to_uuid = Option.map to_uuid'
|
||||
8
unikernel/duniverse/pgx/pgx/src/pgx_value.mli
Normal file
8
unikernel/duniverse/pgx/pgx/src/pgx_value.mli
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
include Pgx_value_intf.S
|
||||
|
||||
(* Exposed for extending this module *)
|
||||
|
||||
(** [convert_failure type_ str] raises [Convert_failure] with a useful
|
||||
error message. Add [~hint] if there's additional info you can give the
|
||||
user about the error. *)
|
||||
val convert_failure : ?hint:string -> string -> string -> _
|
||||
67
unikernel/duniverse/pgx/pgx/src/pgx_value_intf.ml
Normal file
67
unikernel/duniverse/pgx/pgx/src/pgx_value_intf.ml
Normal file
|
|
@ -0,0 +1,67 @@
|
|||
(** A wrapper for holding Postgres types *)
|
||||
module type S = sig
|
||||
(** [v] is opaque because the exact contents depend on Postgres types, so you could have two [v]'s with the
|
||||
same value but different internal data representation, for example if you did a [SELECT 'a'::bytea] vs
|
||||
[SELECT 'a'::varchar], the internal representation will be different, but the actual data if you use
|
||||
[to_binary] or [to_string] will be the same. *)
|
||||
type v [@@deriving compare, sexp_of]
|
||||
|
||||
type t = v option [@@deriving compare, sexp_of]
|
||||
|
||||
exception Conversion_failure of string [@@deriving sexp_of]
|
||||
|
||||
val required : ('a -> 'b) -> 'a option -> 'b
|
||||
val opt : ('a -> t) -> 'a option -> t
|
||||
val null : t
|
||||
val of_binary : string -> t
|
||||
val to_binary_exn : t -> string
|
||||
val to_binary : t -> string option
|
||||
val of_bool : bool -> t
|
||||
val to_bool_exn : t -> bool
|
||||
val to_bool : t -> bool option
|
||||
val of_float : float -> t
|
||||
val to_float_exn : t -> float
|
||||
val to_float : t -> float option
|
||||
|
||||
type hstore = (string * string option) list [@@deriving compare, sexp_of]
|
||||
|
||||
val of_hstore : hstore -> t
|
||||
val to_hstore_exn : t -> hstore
|
||||
val to_hstore : t -> hstore option
|
||||
|
||||
type inet = Ipaddr.t * int [@@deriving compare, sexp_of]
|
||||
|
||||
val of_inet : inet -> t
|
||||
val to_inet_exn : t -> inet
|
||||
val to_inet : t -> inet option
|
||||
val of_int : int -> t
|
||||
val to_int_exn : t -> int
|
||||
val to_int : t -> int option
|
||||
val of_int32 : int32 -> t
|
||||
val to_int32_exn : t -> int32
|
||||
val to_int32 : t -> int32 option
|
||||
val of_int64 : int64 -> t
|
||||
val to_int64_exn : t -> int64
|
||||
val to_int64 : t -> int64 option
|
||||
val of_list : t list -> t
|
||||
val to_list_exn : t -> t list
|
||||
val to_list : t -> t list option
|
||||
|
||||
type point = float * float [@@deriving compare, sexp_of]
|
||||
|
||||
val of_point : point -> t
|
||||
val to_point_exn : t -> point
|
||||
val to_point : t -> point option
|
||||
val of_string : string -> t
|
||||
val to_string_exn : t -> string
|
||||
val to_string : t -> string option
|
||||
val unit : t
|
||||
val to_unit_exn : t -> unit
|
||||
val to_unit : t -> unit option
|
||||
|
||||
type uuid = Uuidm.t [@@deriving compare, sexp_of]
|
||||
|
||||
val of_uuid : uuid -> t
|
||||
val to_uuid_exn : t -> uuid
|
||||
val to_uuid : t -> uuid option
|
||||
end
|
||||
23
unikernel/duniverse/pgx/pgx/src/result_desc.ml
Normal file
23
unikernel/duniverse/pgx/pgx/src/result_desc.ml
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
open Sexplib0.Sexp_conv
|
||||
include Types
|
||||
|
||||
type t =
|
||||
{ name : string
|
||||
; table : oid option
|
||||
; column : int option
|
||||
; field_type : oid
|
||||
; length : int
|
||||
; modifier : int32
|
||||
}
|
||||
[@@deriving sexp]
|
||||
|
||||
let of_row_desc r =
|
||||
let open Row_desc in
|
||||
{ name = r.name
|
||||
; table = (if r.table = 0l then None else Some r.table)
|
||||
; column = (if r.col = 0 then None else Some r.col)
|
||||
; field_type = r.oid
|
||||
; length = r.len
|
||||
; modifier = r.modifier
|
||||
}
|
||||
;;
|
||||
13
unikernel/duniverse/pgx/pgx/src/result_desc.mli
Normal file
13
unikernel/duniverse/pgx/pgx/src/result_desc.mli
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
open Types
|
||||
|
||||
type t =
|
||||
{ name : string (** Field name. *)
|
||||
; table : oid option (** OID of table. *)
|
||||
; column : int option (** Column number of field in table. *)
|
||||
; field_type : oid (** The type of the field. *)
|
||||
; length : int (** Length of the field. *)
|
||||
; modifier : int32 (** Type modifier. *)
|
||||
}
|
||||
[@@deriving sexp]
|
||||
|
||||
val of_row_desc : Row_desc.t -> t
|
||||
12
unikernel/duniverse/pgx/pgx/src/row_desc.ml
Normal file
12
unikernel/duniverse/pgx/pgx/src/row_desc.ml
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
open Sexplib0.Sexp_conv
|
||||
|
||||
type t =
|
||||
{ name : string
|
||||
; table : int32
|
||||
; col : int
|
||||
; oid : int32
|
||||
; len : int
|
||||
; modifier : int32
|
||||
; format : int
|
||||
}
|
||||
[@@deriving sexp]
|
||||
17
unikernel/duniverse/pgx/pgx/src/types.ml
Normal file
17
unikernel/duniverse/pgx/pgx/src/types.ml
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
open Sexplib0.Sexp_conv
|
||||
open Pgx_aux
|
||||
|
||||
type oid = int32 [@@deriving compare, sexp]
|
||||
|
||||
(** None is NULL. *)
|
||||
type param = Pgx_value.t [@@deriving compare, sexp_of]
|
||||
|
||||
(** None is NULL. *)
|
||||
type result = Pgx_value.t [@@deriving compare, sexp_of]
|
||||
|
||||
(** One row is a list of fields. *)
|
||||
type row = Pgx_value.t list [@@deriving compare, sexp_of]
|
||||
|
||||
type params_description = oid list [@@deriving compare, sexp]
|
||||
|
||||
exception PostgreSQL_Error of string * Error_response.t [@@deriving sexp]
|
||||
4
unikernel/duniverse/pgx/pgx/test/dune
Normal file
4
unikernel/duniverse/pgx/pgx/test/dune
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
(tests
|
||||
(names test_error_response test_pgx_value)
|
||||
(libraries alcotest ipaddr pgx)
|
||||
(package pgx))
|
||||
72
unikernel/duniverse/pgx/pgx/test/test_error_response.ml
Normal file
72
unikernel/duniverse/pgx/pgx/test/test_error_response.ml
Normal file
|
|
@ -0,0 +1,72 @@
|
|||
open Pgx.Error_response
|
||||
|
||||
let tests =
|
||||
let info_msg =
|
||||
{ code = "5"
|
||||
; severity = "INFO"
|
||||
; message = "test"
|
||||
; custom = [ 'a', "string"; 'c', "field" ]
|
||||
}
|
||||
in
|
||||
let error_msg = { info_msg with severity = "ERROR" } in
|
||||
[ Alcotest.test_case "to_string tests: print msg when verbose = false" `Quick (fun () ->
|
||||
let verbose = false in
|
||||
Alcotest.(check string)
|
||||
"info to string"
|
||||
"INFO: 5: test"
|
||||
(to_string ~verbose info_msg);
|
||||
Alcotest.(check string)
|
||||
"error to string"
|
||||
"ERROR: 5: test"
|
||||
(to_string ~verbose error_msg))
|
||||
; Alcotest.test_case
|
||||
"to_string tests: print msg and fields when verbose = true"
|
||||
`Quick
|
||||
(fun () ->
|
||||
let verbose = true in
|
||||
Alcotest.(check string)
|
||||
"vebose error to string"
|
||||
"ERROR: 5: test\na: string\nc: field"
|
||||
(to_string ~verbose error_msg))
|
||||
; Alcotest.test_case
|
||||
"should_print tests: should not print when verbose = 0"
|
||||
`Quick
|
||||
(fun () ->
|
||||
let verbose = 0 in
|
||||
Alcotest.(check bool)
|
||||
"should not print info"
|
||||
false
|
||||
(should_print ~verbose info_msg);
|
||||
Alcotest.(check bool)
|
||||
"should not print error"
|
||||
false
|
||||
(should_print ~verbose error_msg))
|
||||
; Alcotest.test_case
|
||||
"should_print tests: print if verbose = 1 and t.severity is one of three: INFO, \
|
||||
ERROR, PANIC"
|
||||
`Quick
|
||||
(fun () ->
|
||||
let verbose = 1 in
|
||||
[ "FATAL"; "ERROR"; "PANIC" ]
|
||||
|> List.iter (fun severity ->
|
||||
let msg = { info_msg with severity } in
|
||||
Alcotest.(check bool) "should print" true (should_print msg ~verbose));
|
||||
Alcotest.(check bool) "should not print" false (should_print info_msg ~verbose))
|
||||
; Alcotest.test_case
|
||||
"should_print tests: print if verbose > 1 no matter t.severity"
|
||||
`Quick
|
||||
(fun () ->
|
||||
let verbose = 2 in
|
||||
[ "INFO"; "FATAL"; "ERROR"; "PANIC" ]
|
||||
|> List.iter (fun severity ->
|
||||
let msg = { info_msg with severity } in
|
||||
Alcotest.(check bool)
|
||||
"should always print"
|
||||
true
|
||||
(should_print msg ~verbose)))
|
||||
]
|
||||
;;
|
||||
|
||||
let () =
|
||||
Alcotest.run "test_error_response" [ "to_string and should_print inline tests", tests ]
|
||||
;;
|
||||
203
unikernel/duniverse/pgx/pgx/test/test_pgx_value.ml
Normal file
203
unikernel/duniverse/pgx/pgx/test/test_pgx_value.ml
Normal file
|
|
@ -0,0 +1,203 @@
|
|||
open Printf
|
||||
open Sexplib0
|
||||
open Sexplib0.Sexp_conv
|
||||
open Pgx.Value
|
||||
|
||||
let pp_value ppf x = Sexp.pp_hum ppf (sexp_of_t x)
|
||||
let equal_value (x : t) (y : t) = x = y
|
||||
let pp_hstore ppf x = Sexp.pp_hum ppf (sexp_of_hstore x)
|
||||
let equal_hstore x y = Sexp.equal (sexp_of_hstore x) (sexp_of_hstore y)
|
||||
let printer sexp value = sexp value |> Sexp.to_string_hum
|
||||
let sort_hstore = List.sort (fun (k, _) (k', _) -> String.compare k k')
|
||||
let to_hstore_sorted v = to_hstore v |> Option.map sort_hstore
|
||||
let to_hstore_sorted_exn v = to_hstore_exn v |> sort_hstore
|
||||
let pp_inet ppf (addr, port) = Format.fprintf ppf "%a:%d" Ipaddr.pp addr port
|
||||
let equal_inet (a1, p1) (a2, p2) = Ipaddr.compare a1 a2 = 0 && p1 = p2
|
||||
let epsilon = 0.00001
|
||||
|
||||
let equal_float x y =
|
||||
match classify_float x, classify_float y with
|
||||
| FP_infinite, FP_infinite -> x = y
|
||||
| FP_nan, FP_nan -> true
|
||||
| _, _ -> abs_float (x -. y) <= epsilon *. (abs_float x +. abs_float y)
|
||||
;;
|
||||
|
||||
module Alcotest_ext = struct
|
||||
let hstore = Alcotest.testable pp_hstore equal_hstore
|
||||
let inet = Alcotest.testable pp_inet equal_inet
|
||||
let value = Alcotest.testable pp_value equal_value
|
||||
let uuid = Alcotest.testable Uuidm.pp Uuidm.equal
|
||||
let our_float = Alcotest.testable Format.pp_print_float equal_float
|
||||
end
|
||||
|
||||
let make_test name typ to_value of_value of_value_exn values fail_values =
|
||||
let fail_tests =
|
||||
Alcotest.test_case "null required input" `Quick (fun () ->
|
||||
Alcotest.check_raises
|
||||
"non-null conversion"
|
||||
(Conversion_failure "Expected not-null but got null")
|
||||
(fun () -> ignore (of_value_exn None)))
|
||||
::
|
||||
List.map
|
||||
(fun str ->
|
||||
let test_name = sprintf "bad conversion - %s" str in
|
||||
let value = of_string str in
|
||||
Alcotest.test_case test_name `Quick
|
||||
@@ fun () ->
|
||||
try
|
||||
of_value value |> ignore;
|
||||
Alcotest.fail "Expected Conversion_failure"
|
||||
with
|
||||
| Conversion_failure _ -> ())
|
||||
fail_values
|
||||
in
|
||||
let success_opt_tests =
|
||||
None :: List.map (fun v -> Some v) values
|
||||
|> List.map (fun expect ->
|
||||
let test_name =
|
||||
Format.asprintf "good conversion - %a" Alcotest.(pp (option typ)) expect
|
||||
in
|
||||
Alcotest.test_case test_name `Quick
|
||||
@@ fun () ->
|
||||
let value = expect |> opt to_value |> of_value in
|
||||
Alcotest.(check (option typ)) test_name expect value)
|
||||
in
|
||||
let success_tests =
|
||||
List.map
|
||||
(fun expect ->
|
||||
let test_name = Format.asprintf "good conversion - %a" (Alcotest.pp typ) expect in
|
||||
Alcotest.test_case test_name `Quick
|
||||
@@ fun () ->
|
||||
let value = expect |> to_value |> of_value_exn in
|
||||
Alcotest.(check typ) test_name expect value)
|
||||
values
|
||||
in
|
||||
name, success_tests @ success_opt_tests @ fail_tests
|
||||
;;
|
||||
|
||||
let () =
|
||||
let all_chars = String.init 255 char_of_int in
|
||||
Alcotest.run
|
||||
"Pgx.Value"
|
||||
[ make_test
|
||||
"binary"
|
||||
Alcotest.string
|
||||
of_binary
|
||||
to_binary
|
||||
to_binary_exn
|
||||
[ ""; "normal string"; "string with null\x00 in the midddle"; all_chars ]
|
||||
[]
|
||||
; make_test
|
||||
"bool"
|
||||
Alcotest.bool
|
||||
of_bool
|
||||
to_bool
|
||||
to_bool_exn
|
||||
[ true; false ]
|
||||
[ ""; "asd" ]
|
||||
; make_test
|
||||
"float"
|
||||
Alcotest_ext.our_float
|
||||
of_float
|
||||
to_float
|
||||
to_float_exn
|
||||
[ 0.; 3.14; -5.; neg_infinity; infinity; nan; max_float; min_float ]
|
||||
[ ""; "asd" ]
|
||||
; make_test
|
||||
"hstore"
|
||||
Alcotest_ext.hstore
|
||||
of_hstore
|
||||
to_hstore_sorted
|
||||
to_hstore_sorted_exn
|
||||
[ []
|
||||
; [ "a", Some "b" ]
|
||||
; [ "key", None ]
|
||||
; [ "1", Some "2"; "3;'", Some "'!"; "asdf=>", None ]
|
||||
]
|
||||
[ "asd"; "=>"; "a=>"; "=>v" ]
|
||||
; make_test
|
||||
"inet"
|
||||
Alcotest_ext.inet
|
||||
of_inet
|
||||
to_inet
|
||||
to_inet_exn
|
||||
([ "127.0.0.1", 32; "192.168.5.9", 0; "fe80::0202:b3ff:fe1e:8329", 128 ]
|
||||
|> List.map (fun (addr, mask) -> Ipaddr.of_string_exn addr, mask))
|
||||
[ ""; "asd"; "192.168.1.a/32" ]
|
||||
; make_test
|
||||
"int"
|
||||
Alcotest.int
|
||||
of_int
|
||||
to_int
|
||||
to_int_exn
|
||||
[ 0; 1; -1; max_int; min_int ]
|
||||
[ ""; "asd"; "t"; "f" ]
|
||||
; make_test
|
||||
"int32"
|
||||
Alcotest.int32
|
||||
of_int32
|
||||
to_int32
|
||||
to_int32_exn
|
||||
Int32.[ zero; of_int 1; of_int (-1); max_int; min_int ]
|
||||
[ ""; "asd"; "t"; "f" ]
|
||||
; make_test
|
||||
"int64"
|
||||
Alcotest.int64
|
||||
of_int64
|
||||
to_int64
|
||||
to_int64_exn
|
||||
Int64.[ zero; of_int 1; of_int (-1); max_int; min_int ]
|
||||
[ ""; "asd"; "t"; "f" ]
|
||||
; make_test
|
||||
"list"
|
||||
Alcotest.(list Alcotest_ext.value)
|
||||
of_list
|
||||
to_list
|
||||
to_list_exn
|
||||
[ []
|
||||
; [ of_bool true
|
||||
; of_bool false
|
||||
; of_float 10.5
|
||||
; of_hstore []
|
||||
; of_hstore [ "key", Some "value" ]
|
||||
; of_hstore [ "key2", None ]
|
||||
; of_inet (Ipaddr.of_string_exn "8.8.8.8", 4)
|
||||
; of_int 99
|
||||
; of_int32 (Int32.of_int 101)
|
||||
; of_int64 (Int64.of_int 1102931)
|
||||
; of_list []
|
||||
; null
|
||||
; of_point (-5., 100.)
|
||||
; unit
|
||||
; of_uuid (Uuidm.create `V4)
|
||||
; of_string all_chars
|
||||
]
|
||||
]
|
||||
[ ""; "asd" ]
|
||||
; make_test
|
||||
"point"
|
||||
Alcotest.(Alcotest_ext.(pair our_float our_float))
|
||||
of_point
|
||||
to_point
|
||||
to_point_exn
|
||||
[ 0., 0.; infinity, neg_infinity; nan, nan; max_float, 5.; -5., max_float ]
|
||||
[ ""; "asd"; "5." ]
|
||||
; make_test
|
||||
"string"
|
||||
Alcotest.string
|
||||
of_string
|
||||
to_string
|
||||
to_string_exn
|
||||
[ ""; "this is a test string"; all_chars ]
|
||||
[]
|
||||
; make_test "unit" Alcotest.unit (fun () -> unit) to_unit to_unit_exn [ () ] [ "asd" ]
|
||||
; make_test
|
||||
"uuid"
|
||||
Alcotest_ext.uuid
|
||||
of_uuid
|
||||
to_uuid
|
||||
to_uuid_exn
|
||||
[ Uuidm.create `V4 ]
|
||||
[ ""; "asd" ]
|
||||
]
|
||||
;;
|
||||
39
unikernel/duniverse/pgx/pgx_async.opam
Normal file
39
unikernel/duniverse/pgx/pgx_async.opam
Normal file
|
|
@ -0,0 +1,39 @@
|
|||
version: "2.2"
|
||||
# This file is generated by dune, edit dune-project instead
|
||||
opam-version: "2.0"
|
||||
synopsis: "Pgx using Async for IO"
|
||||
description: "Pgx using Async for IO"
|
||||
maintainer: ["Arena Developers <silver-snakes@arena.io>"]
|
||||
authors: ["Arena Developers <silver-snakes@arena.io>"]
|
||||
license: "LGPL-2.0-only with OCaml-LGPL-linking-exception"
|
||||
homepage: "https://github.com/arenadotio/pgx"
|
||||
doc: "https://arenadotio.github.io/pgx"
|
||||
bug-reports: "https://github.com/arenadotio/pgx/issues"
|
||||
depends: [
|
||||
"dune" {>= "3.2"}
|
||||
"alcotest-async" {with-test & >= "1.0.0"}
|
||||
"async_kernel" {>= "v0.13.0"}
|
||||
"async_unix" {>= "v0.13.0"}
|
||||
"async_ssl"
|
||||
"base64" {with-test & >= "3.0.0"}
|
||||
"conduit-async" {>= "1.5.0"}
|
||||
"ocaml" {>= "4.08"}
|
||||
"pgx" {= version}
|
||||
"pgx_value_core" {= version}
|
||||
"odoc" {with-doc}
|
||||
]
|
||||
build: [
|
||||
["dune" "subst"] {dev}
|
||||
[
|
||||
"dune"
|
||||
"build"
|
||||
"-p"
|
||||
name
|
||||
"-j"
|
||||
jobs
|
||||
"@install"
|
||||
"@runtest" {with-test}
|
||||
"@doc" {with-doc}
|
||||
]
|
||||
]
|
||||
dev-repo: "git+https://github.com/arenadotio/pgx.git"
|
||||
7
unikernel/duniverse/pgx/pgx_async/bin/dune
Normal file
7
unikernel/duniverse/pgx/pgx_async/bin/dune
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
(executables
|
||||
(names pgx_async_example)
|
||||
(libraries pgx_async))
|
||||
|
||||
(alias
|
||||
(name examples)
|
||||
(deps pgx_async_example.exe))
|
||||
141
unikernel/duniverse/pgx/pgx_async/bin/pgx_async_example.ml
Normal file
141
unikernel/duniverse/pgx/pgx_async/bin/pgx_async_example.ml
Normal file
|
|
@ -0,0 +1,141 @@
|
|||
(* A basic example of Pgx_async usage *)
|
||||
open Core_kernel
|
||||
open Async_kernel
|
||||
open Async_unix
|
||||
|
||||
module Employee = struct
|
||||
let create db =
|
||||
Pgx_async.simple_query
|
||||
db
|
||||
{|
|
||||
CREATE TEMPORARY TABLE Employee (
|
||||
id SERIAL PRIMARY KEY,
|
||||
name VARCHAR(100) NOT NULL UNIQUE);
|
||||
|}
|
||||
|> Deferred.ignore_m
|
||||
;;
|
||||
|
||||
(* This function lets us insert multiple users relatively efficiently *)
|
||||
let insert_many db names =
|
||||
let params = List.map names ~f:(fun name -> Pgx_async.Value.[ of_string name ]) in
|
||||
Pgx_async.execute_many
|
||||
db
|
||||
~params
|
||||
~query:
|
||||
{|
|
||||
INSERT INTO Employee (name)
|
||||
VALUES ($1)
|
||||
RETURNING id
|
||||
|}
|
||||
>>| List.map ~f:(function
|
||||
| [ [ id ] ] -> Pgx.Value.to_int_exn id
|
||||
| _ -> assert false)
|
||||
;;
|
||||
|
||||
let insert ~name db = insert_many db [ name ] >>| List.hd_exn
|
||||
end
|
||||
|
||||
module Facility = struct
|
||||
let create db =
|
||||
Pgx_async.simple_query
|
||||
db
|
||||
{|
|
||||
CREATE TEMPORARY TABLE Facility (
|
||||
id SERIAL PRIMARY KEY,
|
||||
name VARCHAR(100) NOT NULL UNIQUE,
|
||||
director_id INT REFERENCES Employee(id) ON DELETE SET NULL);
|
||||
|
||||
CREATE INDEX facility_director_id ON Facility (director_id);
|
||||
|}
|
||||
|> Deferred.ignore_m
|
||||
;;
|
||||
|
||||
let insert ~name ?director_id db =
|
||||
let params = Pgx_async.Value.[ of_string name; opt of_int director_id ] in
|
||||
Pgx_async.execute
|
||||
db
|
||||
~params
|
||||
{|
|
||||
INSERT INTO Facility (name, director_id)
|
||||
VALUES ($1, $2)
|
||||
RETURNING id
|
||||
|}
|
||||
>>| function
|
||||
| [ [ id ] ] -> Pgx.Value.to_int_exn id
|
||||
| _ -> assert false
|
||||
;;
|
||||
|
||||
let all_name_and_director_name db =
|
||||
Pgx_async.execute
|
||||
db
|
||||
{|
|
||||
SELECT f.name, e.name
|
||||
FROM Facility f
|
||||
LEFT JOIN Employee e ON e.id = f.director_id
|
||||
|}
|
||||
>>| List.map ~f:(function
|
||||
| [ name; director_name ] ->
|
||||
Pgx.Value.(to_string_exn name, to_string director_name)
|
||||
| _ -> assert false)
|
||||
;;
|
||||
|
||||
let reassign_director db ~director_id ~from_facility_id ~to_facility_id =
|
||||
(* Note: with_transaction doesn't currently have any special handling
|
||||
for concurrent queries *)
|
||||
Pgx_async.with_transaction db
|
||||
@@ fun db ->
|
||||
let params = Pgx.Value.[ of_int director_id; of_int from_facility_id ] in
|
||||
Pgx_async.execute
|
||||
db
|
||||
~params
|
||||
{|
|
||||
UPDATE Facility SET director_id = NULL WHERE id = $2 AND director_id = $1
|
||||
|}
|
||||
>>= fun _ ->
|
||||
let params = Pgx.Value.[ of_int director_id; of_int to_facility_id ] in
|
||||
Pgx_async.execute
|
||||
db
|
||||
~params
|
||||
{|
|
||||
UPDATE Facility SET director_id = $1 WHERE id = $2
|
||||
|}
|
||||
|> Deferred.ignore_m
|
||||
;;
|
||||
end
|
||||
|
||||
let setup db = Employee.create db >>= fun () -> Facility.create db
|
||||
|
||||
let main () =
|
||||
Pgx_async.with_conn
|
||||
@@ fun db ->
|
||||
setup db
|
||||
>>= fun () ->
|
||||
Employee.insert ~name:"Steve" db
|
||||
>>= fun steve_id ->
|
||||
(* Parallel queries are not an error, but will execute in serial *)
|
||||
[ Facility.insert ~name:"Headquarters" ~director_id:steve_id db
|
||||
; Facility.insert ~name:"New Office" db
|
||||
]
|
||||
|> Deferred.all
|
||||
>>= function
|
||||
| [ headquarters_id; new_office_id ] ->
|
||||
Facility.all_name_and_director_name db
|
||||
>>| List.iter ~f:(fun (name, director_name) ->
|
||||
let director_name = Option.value director_name ~default:"(none)" in
|
||||
printf "The director of %s is %s\n" name director_name)
|
||||
>>= fun () ->
|
||||
print_endline "Re-assigning Steve to the New Office";
|
||||
Facility.reassign_director
|
||||
db
|
||||
~director_id:steve_id
|
||||
~from_facility_id:headquarters_id
|
||||
~to_facility_id:new_office_id
|
||||
>>= fun () ->
|
||||
Facility.all_name_and_director_name db
|
||||
>>| List.iter ~f:(fun (name, director_name) ->
|
||||
let director_name = Option.value director_name ~default:"(none)" in
|
||||
printf "The director of %s is %s\n" name director_name)
|
||||
| _ -> assert false
|
||||
;;
|
||||
|
||||
let () = Thread_safe.block_on_async_exn main
|
||||
16
unikernel/duniverse/pgx/pgx_async/src/dune
Normal file
16
unikernel/duniverse/pgx/pgx_async/src/dune
Normal file
|
|
@ -0,0 +1,16 @@
|
|||
(* -*- tuareg -*- *)
|
||||
|
||||
let preprocess =
|
||||
match Sys.getenv "BISECT_ENABLE" with
|
||||
| "yes" -> "(preprocess (pps bisect_ppx))"
|
||||
| _ -> ""
|
||||
| exception Not_found -> ""
|
||||
|
||||
let () = Jbuild_plugin.V1.send @@ {|
|
||||
|
||||
(library
|
||||
(public_name pgx_async)
|
||||
(wrapped false)
|
||||
(libraries async_kernel async_unix conduit-async pgx_value_core)
|
||||
|} ^ preprocess ^ {|)
|
||||
|}
|
||||
200
unikernel/duniverse/pgx/pgx_async/src/pgx_async.ml
Normal file
200
unikernel/duniverse/pgx/pgx_async/src/pgx_async.ml
Normal file
|
|
@ -0,0 +1,200 @@
|
|||
open Core_kernel
|
||||
open Async_kernel
|
||||
open Async_unix
|
||||
|
||||
(* Pgx allows to generate bindings from any module implementing their
|
||||
THREAD signature which encompasses monadic concurrency + IO. The
|
||||
implementation that we've chosen here is a deferred represents an
|
||||
asynchronous value returned by pgx and Writer.t/Reader.t are the
|
||||
channels it uses for communication *)
|
||||
|
||||
exception Pgx_eof [@@deriving sexp]
|
||||
|
||||
module Thread = struct
|
||||
type 'a t = 'a Deferred.t
|
||||
|
||||
let return = return
|
||||
let ( >>= ) = ( >>= )
|
||||
|
||||
let catch f on_exn =
|
||||
try_with ~extract_exn:true f
|
||||
>>= function
|
||||
| Ok x -> return x
|
||||
| Error exn -> on_exn exn
|
||||
;;
|
||||
|
||||
type sockaddr =
|
||||
| Unix of string
|
||||
| Inet of string * int
|
||||
|
||||
type in_channel = Reader.t
|
||||
type out_channel = Writer.t
|
||||
|
||||
let output_char w char = return (Writer.write_char w char)
|
||||
let output_string w s = return (Writer.write w s)
|
||||
|
||||
let output_binary_int w n =
|
||||
let chr = Caml.Char.chr in
|
||||
Writer.write_char w (chr (n lsr 24));
|
||||
Writer.write_char w (chr ((n lsr 16) land 255));
|
||||
Writer.write_char w (chr ((n lsr 8) land 255));
|
||||
return @@ Writer.write_char w (chr (n land 255))
|
||||
;;
|
||||
|
||||
let flush = Writer.flushed
|
||||
|
||||
let input_char r =
|
||||
Reader.read_char r
|
||||
>>| function
|
||||
| `Ok c -> c
|
||||
| `Eof -> raise Pgx_eof
|
||||
;;
|
||||
|
||||
let input_binary_int r =
|
||||
let b = Bytes.create 4 in
|
||||
Reader.really_read r b
|
||||
>>| function
|
||||
| `Eof _ -> raise Pgx_eof
|
||||
| `Ok ->
|
||||
let code = Caml.Char.code in
|
||||
(code (Bytes.get b 0) lsl 24)
|
||||
lor (code (Bytes.get b 1) lsl 16)
|
||||
lor (code (Bytes.get b 2) lsl 8)
|
||||
lor code (Bytes.get b 3)
|
||||
;;
|
||||
|
||||
let really_input r s pos len =
|
||||
Reader.really_read r ~pos ~len s
|
||||
>>| function
|
||||
| `Ok -> ()
|
||||
| `Eof _ -> raise Pgx_eof
|
||||
;;
|
||||
|
||||
let close_in = Reader.close
|
||||
|
||||
let open_connection sockaddr =
|
||||
match sockaddr with
|
||||
| Unix path -> Conduit_async.connect (`Unix_domain_socket path)
|
||||
| Inet (host, port) ->
|
||||
Uri.make ~host ~port ()
|
||||
|> Conduit_async.V3.resolve_uri
|
||||
>>= Conduit_async.V3.connect
|
||||
>>| fun (_socket, in_channel, out_channel) -> in_channel, out_channel
|
||||
;;
|
||||
|
||||
type ssl_config = Conduit_async.Ssl.config
|
||||
|
||||
let upgrade_ssl =
|
||||
try
|
||||
let default_config = Conduit_async.V1.Conduit_async_ssl.Ssl_config.configure () in
|
||||
`Supported
|
||||
(fun ?(ssl_config = default_config) in_channel out_channel ->
|
||||
Conduit_async.V1.Conduit_async_ssl.ssl_connect ssl_config in_channel out_channel)
|
||||
with
|
||||
| _ -> `Not_supported
|
||||
;;
|
||||
|
||||
(* The unix getlogin syscall can fail *)
|
||||
let getlogin () = Unix.getuid () |> Unix.Passwd.getbyuid_exn >>| fun { name; _ } -> name
|
||||
|
||||
let debug msg =
|
||||
Log.Global.debug ~tags:[ "lib", "pgx_async" ] "%s" msg;
|
||||
Log.Global.flushed ()
|
||||
;;
|
||||
|
||||
let protect f ~finally = Monitor.protect f ~finally
|
||||
|
||||
module Sequencer = struct
|
||||
type 'a monad = 'a t
|
||||
type 'a t = 'a Sequencer.t
|
||||
|
||||
let create t = Sequencer.create ~continue_on_error:true t
|
||||
let enqueue = Throttle.enqueue
|
||||
end
|
||||
end
|
||||
|
||||
include Pgx.Make (Thread)
|
||||
|
||||
(* pgx uses configures this value at build time. But this breaks when
|
||||
pgx is installed before postgres itself. We prefer to set this variable
|
||||
at runtime and override the `connect` function from to respect it *)
|
||||
let default_unix_domain_socket_dir =
|
||||
let debian_default = "/var/run/postgresql" in
|
||||
Lazy_deferred.create (fun () ->
|
||||
Sys.is_directory debian_default
|
||||
>>| function
|
||||
| `Yes -> debian_default
|
||||
| `No | `Unknown -> "/tmp")
|
||||
;;
|
||||
|
||||
(* Fail if PGDATABASE environment variable is not set. *)
|
||||
let check_pgdatabase =
|
||||
lazy
|
||||
(let db = "PGDATABASE" in
|
||||
if Option.is_none (Sys.getenv db)
|
||||
then failwithf "%s environment variable must be set." db ())
|
||||
;;
|
||||
|
||||
let connect
|
||||
?ssl
|
||||
?host
|
||||
?port
|
||||
?user
|
||||
?password
|
||||
?database
|
||||
?unix_domain_socket_dir
|
||||
?verbose
|
||||
?max_message_length
|
||||
()
|
||||
=
|
||||
if Option.is_none database then Lazy.force check_pgdatabase;
|
||||
(match unix_domain_socket_dir with
|
||||
| Some p -> return p
|
||||
| None -> Lazy_deferred.force_exn default_unix_domain_socket_dir)
|
||||
>>= fun unix_domain_socket_dir ->
|
||||
connect
|
||||
?ssl
|
||||
?host
|
||||
?port
|
||||
?user
|
||||
?password
|
||||
?database
|
||||
?verbose
|
||||
?max_message_length
|
||||
~unix_domain_socket_dir
|
||||
()
|
||||
;;
|
||||
|
||||
let with_conn
|
||||
?ssl
|
||||
?host
|
||||
?port
|
||||
?user
|
||||
?password
|
||||
?database
|
||||
?unix_domain_socket_dir
|
||||
?verbose
|
||||
?max_message_length
|
||||
f
|
||||
=
|
||||
connect
|
||||
?ssl
|
||||
?host
|
||||
?port
|
||||
?user
|
||||
?password
|
||||
?database
|
||||
?unix_domain_socket_dir
|
||||
?verbose
|
||||
?max_message_length
|
||||
()
|
||||
>>= fun dbh -> Monitor.protect (fun () -> f dbh) ~finally:(fun () -> close dbh)
|
||||
;;
|
||||
|
||||
let execute_pipe ?params db query =
|
||||
Pipe.create_reader ~close_on_exception:false
|
||||
@@ fun writer ->
|
||||
execute_iter ?params db query ~f:(fun row -> Pipe.write_if_open writer row)
|
||||
;;
|
||||
|
||||
module Value = Pgx_value_core
|
||||
18
unikernel/duniverse/pgx/pgx_async/src/pgx_async.mli
Normal file
18
unikernel/duniverse/pgx/pgx_async/src/pgx_async.mli
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
(** Async based Postgres client based on Pgx. *)
|
||||
open Async_kernel
|
||||
|
||||
include
|
||||
Pgx.S
|
||||
with type 'a Io.t = 'a Deferred.t
|
||||
and type Io.ssl_config = Conduit_async.Ssl.config
|
||||
|
||||
(* for testing purposes *)
|
||||
module Thread : Pgx.Io with type 'a t = 'a Deferred.t
|
||||
|
||||
(** Like [execute] but returns a pipe so you can operate on the results before they have all returned.
|
||||
Note that [execute_iter] and [execute_fold] can perform significantly better because they don't have
|
||||
as much overhead. *)
|
||||
val execute_pipe : ?params:Pgx.row -> t -> string -> Pgx.row Pipe.Reader.t
|
||||
|
||||
(** Exposed for backwards compatiblity. New code should use [Pgx_value_core] directly. *)
|
||||
module Value = Pgx_value_core
|
||||
37
unikernel/duniverse/pgx/pgx_async/src/pgx_async_test.ml
Normal file
37
unikernel/duniverse/pgx/pgx_async/src/pgx_async_test.ml
Normal file
|
|
@ -0,0 +1,37 @@
|
|||
open Core_kernel
|
||||
open Async_kernel
|
||||
open Async_unix
|
||||
module Pga = Pgx_async
|
||||
|
||||
let default_database = "postgres"
|
||||
let set_to_default_db () = Unix.putenv ~key:"PGDATABASE" ~data:default_database
|
||||
|
||||
let random_db () =
|
||||
let random_char () = 10 |> Random.int |> Int.to_string |> Char.of_string in
|
||||
"pgx_test_" ^ String.init 8 ~f:(fun _ -> random_char ())
|
||||
;;
|
||||
|
||||
let ignore_empty = function
|
||||
| [] -> ()
|
||||
| _ :: _ -> invalid_arg "ignore_empty"
|
||||
;;
|
||||
|
||||
let drop_db dbh ~db_name = Pga.execute dbh ("DROP DATABASE " ^ db_name) >>| ignore_empty
|
||||
|
||||
let create_db dbh ~db_name =
|
||||
Pga.execute dbh ("CREATE DATABASE " ^ db_name) >>| ignore_empty
|
||||
;;
|
||||
|
||||
let with_temp_db f =
|
||||
let db_name = random_db () in
|
||||
Pga.with_conn ~database:default_database (fun dbh ->
|
||||
create_db dbh ~db_name
|
||||
>>= fun () ->
|
||||
Monitor.protect
|
||||
(fun () -> Pga.with_conn ~database:db_name (fun test_dbh -> f test_dbh ~db_name))
|
||||
~finally:(fun () -> drop_db dbh ~db_name))
|
||||
;;
|
||||
|
||||
type 'a new_db_callback = Pgx_async.t -> db_name:string -> 'a Deferred.t
|
||||
|
||||
let () = Random.self_init ~allow_in_tests:true ()
|
||||
12
unikernel/duniverse/pgx/pgx_async/src/pgx_async_test.mli
Normal file
12
unikernel/duniverse/pgx/pgx_async/src/pgx_async_test.mli
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
(** Testing library for code that uses postgres *)
|
||||
|
||||
open Async_kernel
|
||||
|
||||
val set_to_default_db : unit -> unit
|
||||
|
||||
type 'a new_db_callback = Pgx_async.t -> db_name:string -> 'a Deferred.t
|
||||
|
||||
(** [with_temp_db f] creates a temporary database and executes [f] with a database
|
||||
handle to this db and the name of the db. Once [f] executes or raises, the temp database
|
||||
will be deleted. *)
|
||||
val with_temp_db : 'a new_db_callback -> 'a Deferred.t
|
||||
4
unikernel/duniverse/pgx/pgx_async/test/dune
Normal file
4
unikernel/duniverse/pgx/pgx_async/test/dune
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
(tests
|
||||
(names test_pgx_async)
|
||||
(package pgx_async)
|
||||
(libraries alcotest alcotest-async pgx_async pgx_test))
|
||||
13
unikernel/duniverse/pgx/pgx_async/test/test_pgx_async.ml
Normal file
13
unikernel/duniverse/pgx/pgx_async/test/test_pgx_async.ml
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
module Alcotest_io = struct
|
||||
type 'a test_case = 'a Alcotest_async.test_case
|
||||
|
||||
let test_case name speed f = Alcotest_async.test_case name speed f
|
||||
|
||||
let run name tests =
|
||||
Async_unix.Thread_safe.block_on_async_exn @@ fun () -> Alcotest_async.run name tests
|
||||
;;
|
||||
end
|
||||
|
||||
include Pgx_test.Make_tests (Pgx_async) (Alcotest_io)
|
||||
|
||||
let () = run_tests ~library_name:"pgx_async"
|
||||
34
unikernel/duniverse/pgx/pgx_lwt.opam
Normal file
34
unikernel/duniverse/pgx/pgx_lwt.opam
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
version: "2.2"
|
||||
# This file is generated by dune, edit dune-project instead
|
||||
opam-version: "2.0"
|
||||
synopsis: "Pgx using Lwt for IO"
|
||||
description: "Pgx using Lwt for IO"
|
||||
maintainer: ["Arena Developers <silver-snakes@arena.io>"]
|
||||
authors: ["Arena Developers <silver-snakes@arena.io>"]
|
||||
license: "LGPL-2.0-only with OCaml-LGPL-linking-exception"
|
||||
homepage: "https://github.com/arenadotio/pgx"
|
||||
doc: "https://arenadotio.github.io/pgx"
|
||||
bug-reports: "https://github.com/arenadotio/pgx/issues"
|
||||
depends: [
|
||||
"dune" {>= "3.2"}
|
||||
"lwt"
|
||||
"logs"
|
||||
"ocaml" {>= "4.08"}
|
||||
"pgx" {= version}
|
||||
"odoc" {with-doc}
|
||||
]
|
||||
build: [
|
||||
["dune" "subst"] {dev}
|
||||
[
|
||||
"dune"
|
||||
"build"
|
||||
"-p"
|
||||
name
|
||||
"-j"
|
||||
jobs
|
||||
"@install"
|
||||
"@runtest" {with-test}
|
||||
"@doc" {with-doc}
|
||||
]
|
||||
]
|
||||
dev-repo: "git+https://github.com/arenadotio/pgx.git"
|
||||
15
unikernel/duniverse/pgx/pgx_lwt/src/dune
Normal file
15
unikernel/duniverse/pgx/pgx_lwt/src/dune
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
(* -*- tuareg -*- *)
|
||||
|
||||
let preprocess =
|
||||
match Sys.getenv "BISECT_ENABLE" with
|
||||
| "yes" -> "(preprocess (pps bisect_ppx))"
|
||||
| _ -> ""
|
||||
| exception Not_found -> ""
|
||||
|
||||
let () = Jbuild_plugin.V1.send @@ {|
|
||||
|
||||
(library
|
||||
(public_name pgx_lwt)
|
||||
(libraries lwt logs.lwt pgx)
|
||||
|} ^ preprocess ^ {|)
|
||||
|}
|
||||
17
unikernel/duniverse/pgx/pgx_lwt/src/io_intf.ml
Normal file
17
unikernel/duniverse/pgx/pgx_lwt/src/io_intf.ml
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
module type S = sig
|
||||
type in_channel
|
||||
type out_channel
|
||||
|
||||
type sockaddr =
|
||||
| Unix of string
|
||||
| Inet of string * int
|
||||
|
||||
val output_char : out_channel -> char -> unit Lwt.t
|
||||
val output_string : out_channel -> string -> unit Lwt.t
|
||||
val flush : out_channel -> unit Lwt.t
|
||||
val input_char : in_channel -> char Lwt.t
|
||||
val really_input : in_channel -> bytes -> int -> int -> unit Lwt.t
|
||||
val close_in : in_channel -> unit Lwt.t
|
||||
val getlogin : unit -> string Lwt.t
|
||||
val open_connection : sockaddr -> (in_channel * out_channel) Lwt.t
|
||||
end
|
||||
71
unikernel/duniverse/pgx/pgx_lwt/src/pgx_lwt.ml
Normal file
71
unikernel/duniverse/pgx/pgx_lwt/src/pgx_lwt.ml
Normal file
|
|
@ -0,0 +1,71 @@
|
|||
module Io_intf = Io_intf
|
||||
|
||||
module type S = Pgx.S with type 'a Io.t = 'a Lwt.t
|
||||
|
||||
module Thread = struct
|
||||
open Lwt
|
||||
|
||||
module Make (Io : Io_intf.S) = struct
|
||||
type 'a t = 'a Lwt.t
|
||||
|
||||
let return = return
|
||||
let ( >>= ) = ( >>= )
|
||||
let catch = catch
|
||||
|
||||
type sockaddr = Io.sockaddr =
|
||||
| Unix of string
|
||||
| Inet of string * int
|
||||
|
||||
type in_channel = Io.in_channel
|
||||
type out_channel = Io.out_channel
|
||||
|
||||
let output_char = Io.output_char
|
||||
let output_string = Io.output_string
|
||||
|
||||
let output_binary_int w n =
|
||||
let chr = Char.chr in
|
||||
output_char w (chr (n lsr 24))
|
||||
>>= fun () ->
|
||||
output_char w (chr ((n lsr 16) land 255))
|
||||
>>= fun () ->
|
||||
output_char w (chr ((n lsr 8) land 255))
|
||||
>>= fun () -> output_char w (chr (n land 255))
|
||||
;;
|
||||
|
||||
let flush = Io.flush
|
||||
let input_char = Io.input_char
|
||||
let really_input = Io.really_input
|
||||
|
||||
let input_binary_int r =
|
||||
let b = Bytes.create 4 in
|
||||
really_input r b 0 4
|
||||
>|= fun () ->
|
||||
let s = Bytes.to_string b in
|
||||
let code = Char.code in
|
||||
(code s.[0] lsl 24) lor (code s.[1] lsl 16) lor (code s.[2] lsl 8) lor code s.[3]
|
||||
;;
|
||||
|
||||
let close_in = Io.close_in
|
||||
let open_connection = Io.open_connection
|
||||
|
||||
type ssl_config
|
||||
|
||||
let upgrade_ssl = `Not_supported
|
||||
let getlogin = Io.getlogin
|
||||
let debug s = Logs_lwt.debug (fun m -> m "%s" s)
|
||||
let protect f ~finally = Lwt.finalize f finally
|
||||
|
||||
module Sequencer = struct
|
||||
type 'a monad = 'a t
|
||||
type 'a t = 'a * Lwt_mutex.t
|
||||
|
||||
let create t = t, Lwt_mutex.create ()
|
||||
let enqueue (t, mutex) f = Lwt_mutex.with_lock mutex (fun () -> f t)
|
||||
end
|
||||
end
|
||||
end
|
||||
|
||||
module Make (Io : Io_intf.S) = struct
|
||||
module Thread = Thread.Make (Io)
|
||||
include Pgx.Make (Thread)
|
||||
end
|
||||
5
unikernel/duniverse/pgx/pgx_lwt/src/pgx_lwt.mli
Normal file
5
unikernel/duniverse/pgx/pgx_lwt/src/pgx_lwt.mli
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
module Io_intf = Io_intf
|
||||
|
||||
module type S = Pgx.S with type 'a Io.t = 'a Lwt.t
|
||||
|
||||
module Make (Io : Io_intf.S) : S
|
||||
42
unikernel/duniverse/pgx/pgx_lwt_mirage.opam
Normal file
42
unikernel/duniverse/pgx/pgx_lwt_mirage.opam
Normal file
|
|
@ -0,0 +1,42 @@
|
|||
version: "2.2"
|
||||
# This file is generated by dune, edit dune-project instead
|
||||
opam-version: "2.0"
|
||||
synopsis: "Pgx using Lwt on Mirage for IO"
|
||||
description: "Pgx using Lwt on Mirage for IO"
|
||||
maintainer: ["Arena Developers <silver-snakes@arena.io>"]
|
||||
authors: ["Arena Developers <silver-snakes@arena.io>"]
|
||||
license: "LGPL-2.0-only with OCaml-LGPL-linking-exception"
|
||||
homepage: "https://github.com/arenadotio/pgx"
|
||||
doc: "https://arenadotio.github.io/pgx"
|
||||
bug-reports: "https://github.com/arenadotio/pgx/issues"
|
||||
depends: [
|
||||
"dune" {>= "3.2"}
|
||||
"lwt"
|
||||
"ocaml" {>= "4.08"}
|
||||
"logs"
|
||||
"mirage-channel"
|
||||
"conduit-mirage" {>= "2.3.0"}
|
||||
"dns-client" {>= "6.0.0"}
|
||||
"mirage-random"
|
||||
"mirage-time"
|
||||
"mirage-clock"
|
||||
"tcpip" {>= "7.0.0"}
|
||||
"pgx" {= version}
|
||||
"pgx_lwt" {= version}
|
||||
"odoc" {with-doc}
|
||||
]
|
||||
build: [
|
||||
["dune" "subst"] {dev}
|
||||
[
|
||||
"dune"
|
||||
"build"
|
||||
"-p"
|
||||
name
|
||||
"-j"
|
||||
jobs
|
||||
"@install"
|
||||
"@runtest" {with-test}
|
||||
"@doc" {with-doc}
|
||||
]
|
||||
]
|
||||
dev-repo: "git+https://github.com/arenadotio/pgx.git"
|
||||
15
unikernel/duniverse/pgx/pgx_lwt_mirage/src/dune
Normal file
15
unikernel/duniverse/pgx/pgx_lwt_mirage/src/dune
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
(* -*- tuareg -*- *)
|
||||
|
||||
let preprocess =
|
||||
match Sys.getenv "BISECT_ENABLE" with
|
||||
| "yes" -> "(preprocess (pps bisect_ppx))"
|
||||
| _ -> ""
|
||||
| exception Not_found -> ""
|
||||
|
||||
let () = Jbuild_plugin.V1.send @@ {|
|
||||
|
||||
(library
|
||||
(public_name pgx_lwt_mirage)
|
||||
(libraries pgx_lwt lwt logs.lwt pgx mirage-channel conduit-mirage dns-client mirage-random mirage-time mirage-clock tcpip)
|
||||
|} ^ preprocess ^ {|)
|
||||
|}
|
||||
129
unikernel/duniverse/pgx/pgx_lwt_mirage/src/pgx_lwt_mirage.ml
Normal file
129
unikernel/duniverse/pgx/pgx_lwt_mirage/src/pgx_lwt_mirage.ml
Normal file
|
|
@ -0,0 +1,129 @@
|
|||
(* Copyright (C) 2020 Petter A. Urkedal
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Library General Public
|
||||
* License as published by the Free Software Foundation; either
|
||||
* version 2 of the License, or (at your option) any later version,
|
||||
* with the OCaml static compilation exception.
|
||||
*
|
||||
* 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
|
||||
* Library General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU General Public License
|
||||
* along with this library; see the file COPYING. If not, write to
|
||||
* the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
* Boston, MA 02111-1307, USA.
|
||||
*)
|
||||
|
||||
open Lwt.Infix
|
||||
|
||||
(* Defining this inline so we can use older lwt versions. *)
|
||||
let ( let* ) = Lwt.bind
|
||||
let ( let+ ) t f = Lwt.map f t
|
||||
|
||||
module Make
|
||||
(RANDOM : Mirage_random.S)
|
||||
(TIME : Mirage_time.S)
|
||||
(MCLOCK : Mirage_clock.MCLOCK)
|
||||
(PCLOCK : Mirage_clock.PCLOCK)
|
||||
(STACK : Tcpip.Stack.V4V6) =
|
||||
struct
|
||||
module Channel = Mirage_channel.Make (STACK.TCP)
|
||||
|
||||
module Thread = struct
|
||||
type sockaddr =
|
||||
| Unix of string
|
||||
| Inet of string * int
|
||||
|
||||
type in_channel = Channel.t
|
||||
type out_channel = Channel.t
|
||||
|
||||
let output_char oc c =
|
||||
Channel.write_char oc c;
|
||||
Lwt.return_unit
|
||||
;;
|
||||
|
||||
let output_string oc s =
|
||||
Channel.write_string oc s 0 (String.length s);
|
||||
Lwt.return_unit
|
||||
;;
|
||||
|
||||
let flush oc =
|
||||
Channel.flush oc
|
||||
>>= function
|
||||
| Ok () -> Lwt.return_unit
|
||||
| Error err -> Lwt.fail_with (Format.asprintf "%a" Channel.pp_write_error err)
|
||||
;;
|
||||
|
||||
let input_char ic =
|
||||
Channel.read_char ic
|
||||
>>= function
|
||||
| Ok (`Data c) -> Lwt.return c
|
||||
| Ok `Eof -> Lwt.fail End_of_file
|
||||
| Error err -> Lwt.fail_with (Format.asprintf "%a" Channel.pp_error err)
|
||||
;;
|
||||
|
||||
let really_input ic buf off len =
|
||||
Channel.read_exactly ~len ic
|
||||
>>= function
|
||||
| Ok (`Data bufs) ->
|
||||
let content = Cstruct.copyv bufs in
|
||||
Bytes.blit_string content 0 buf off len;
|
||||
Lwt.return_unit
|
||||
| Ok `Eof -> Lwt.fail End_of_file
|
||||
| Error err -> Lwt.fail_with (Format.asprintf "%a" Channel.pp_error err)
|
||||
;;
|
||||
|
||||
let close_in oc =
|
||||
Channel.close oc
|
||||
>>= function
|
||||
| Ok () -> Lwt.return_unit
|
||||
| Error err -> Lwt.fail_with (Format.asprintf "%a" Channel.pp_write_error err)
|
||||
;;
|
||||
|
||||
let getlogin () = Lwt.fail_with "Running under MirageOS. getlogin not available."
|
||||
end
|
||||
|
||||
module Dns = Dns_client_mirage.Make (RANDOM) (TIME) (MCLOCK) (PCLOCK) (STACK)
|
||||
|
||||
type sockaddr = Thread.sockaddr =
|
||||
| Unix of string
|
||||
| Inet of string * int
|
||||
|
||||
module TCP = Conduit_mirage.TCP (STACK)
|
||||
|
||||
let connect_stack stack sockaddr =
|
||||
let dns = Dns.create stack in
|
||||
let* client =
|
||||
match sockaddr with
|
||||
| Unix _ -> Lwt.fail_with "Running under MirageOS. Unix sockets are not available."
|
||||
| Inet (host, port) ->
|
||||
(match Ipaddr.of_string host with
|
||||
| Ok ipaddr -> Lwt.return (`TCP (ipaddr, port))
|
||||
| Error _ ->
|
||||
let host' = host |> Domain_name.of_string_exn |> Domain_name.host_exn in
|
||||
Dns.gethostbyname dns host'
|
||||
>>= (function
|
||||
| Ok ipaddr -> Lwt.return (`TCP (Ipaddr.V4 ipaddr, port))
|
||||
| Error (`Msg msg) -> Lwt.fail_with msg))
|
||||
in
|
||||
let+ flow = TCP.connect stack client in
|
||||
let ch = Channel.create flow in
|
||||
ch, ch
|
||||
;;
|
||||
|
||||
let connect stack =
|
||||
let open_connection = connect_stack stack in
|
||||
(module struct
|
||||
module T : Pgx_lwt.Io_intf.S = struct
|
||||
include Thread
|
||||
|
||||
let open_connection = open_connection
|
||||
end
|
||||
|
||||
include Pgx_lwt.Make (T)
|
||||
end : Pgx_lwt.S)
|
||||
;;
|
||||
end
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
(* Copyright (C) 2020 Petter A. Urkedal
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Library General Public
|
||||
* License as published by the Free Software Foundation; either
|
||||
* version 2 of the License, or (at your option) any later version,
|
||||
* with the OCaml static compilation exception.
|
||||
*
|
||||
* 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
|
||||
* Library General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU General Public License
|
||||
* along with this library; see the file COPYING. If not, write to
|
||||
* the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
* Boston, MA 02111-1307, USA.
|
||||
*)
|
||||
|
||||
module Make
|
||||
(RANDOM : Mirage_random.S)
|
||||
(TIME : Mirage_time.S)
|
||||
(MCLOCK : Mirage_clock.MCLOCK)
|
||||
(PCLOCK : Mirage_clock.PCLOCK)
|
||||
(STACK : Tcpip.Stack.V4V6) : sig
|
||||
val connect : STACK.t -> (module Pgx_lwt.S)
|
||||
end
|
||||
35
unikernel/duniverse/pgx/pgx_lwt_unix.opam
Normal file
35
unikernel/duniverse/pgx/pgx_lwt_unix.opam
Normal file
|
|
@ -0,0 +1,35 @@
|
|||
version: "2.2"
|
||||
# This file is generated by dune, edit dune-project instead
|
||||
opam-version: "2.0"
|
||||
synopsis: "Pgx using Lwt and Unix libraries for IO"
|
||||
description: "Pgx using Lwt and Unix libraries for IO"
|
||||
maintainer: ["Arena Developers <silver-snakes@arena.io>"]
|
||||
authors: ["Arena Developers <silver-snakes@arena.io>"]
|
||||
license: "LGPL-2.0-only with OCaml-LGPL-linking-exception"
|
||||
homepage: "https://github.com/arenadotio/pgx"
|
||||
doc: "https://arenadotio.github.io/pgx"
|
||||
bug-reports: "https://github.com/arenadotio/pgx/issues"
|
||||
depends: [
|
||||
"dune" {>= "3.2"}
|
||||
"alcotest-lwt" {with-test & >= "1.0.0"}
|
||||
"base64" {with-test & >= "3.0.0"}
|
||||
"ocaml" {>= "4.08"}
|
||||
"pgx" {= version}
|
||||
"pgx_lwt" {= version}
|
||||
"odoc" {with-doc}
|
||||
]
|
||||
build: [
|
||||
["dune" "subst"] {dev}
|
||||
[
|
||||
"dune"
|
||||
"build"
|
||||
"-p"
|
||||
name
|
||||
"-j"
|
||||
jobs
|
||||
"@install"
|
||||
"@runtest" {with-test}
|
||||
"@doc" {with-doc}
|
||||
]
|
||||
]
|
||||
dev-repo: "git+https://github.com/arenadotio/pgx.git"
|
||||
15
unikernel/duniverse/pgx/pgx_lwt_unix/src/dune
Normal file
15
unikernel/duniverse/pgx/pgx_lwt_unix/src/dune
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
(* -*- tuareg -*- *)
|
||||
|
||||
let preprocess =
|
||||
match Sys.getenv "BISECT_ENABLE" with
|
||||
| "yes" -> "(preprocess (pps bisect_ppx))"
|
||||
| _ -> ""
|
||||
| exception Not_found -> ""
|
||||
|
||||
let () = Jbuild_plugin.V1.send @@ {|
|
||||
|
||||
(library
|
||||
(public_name pgx_lwt_unix)
|
||||
(libraries pgx pgx_lwt lwt.unix)
|
||||
|} ^ preprocess ^ {|)
|
||||
|}
|
||||
37
unikernel/duniverse/pgx/pgx_lwt_unix/src/pgx_lwt_unix.ml
Normal file
37
unikernel/duniverse/pgx/pgx_lwt_unix/src/pgx_lwt_unix.ml
Normal file
|
|
@ -0,0 +1,37 @@
|
|||
open Lwt
|
||||
|
||||
module Thread : Pgx_lwt.Io_intf.S = struct
|
||||
type sockaddr =
|
||||
| Unix of string
|
||||
| Inet of string * int
|
||||
|
||||
type in_channel = Lwt_io.input_channel
|
||||
type out_channel = Lwt_io.output_channel
|
||||
|
||||
let output_char = Lwt_io.write_char
|
||||
let output_string = Lwt_io.write
|
||||
let flush = Lwt_io.flush
|
||||
let input_char = Lwt_io.read_char
|
||||
let really_input = Lwt_io.read_into_exactly
|
||||
let close_in = Lwt_io.close
|
||||
|
||||
(* The unix getlogin syscall can fail *)
|
||||
let getlogin () =
|
||||
Unix.getuid () |> Lwt_unix.getpwuid >|= fun { Lwt_unix.pw_name; _ } -> pw_name
|
||||
;;
|
||||
|
||||
let open_connection sockaddr =
|
||||
(match sockaddr with
|
||||
| Unix path -> return (Unix.ADDR_UNIX path)
|
||||
| Inet (hostname, port) ->
|
||||
Lwt_unix.gethostbyname hostname
|
||||
>|= fun { Lwt_unix.h_addr_list; _ } ->
|
||||
let len = Array.length h_addr_list in
|
||||
let i = Random.int len in
|
||||
let addr = h_addr_list.(i) in
|
||||
Unix.ADDR_INET (addr, port))
|
||||
>>= Lwt_io.open_connection
|
||||
;;
|
||||
end
|
||||
|
||||
include Pgx_lwt.Make (Thread)
|
||||
|
|
@ -0,0 +1 @@
|
|||
include Pgx_lwt.S
|
||||
4
unikernel/duniverse/pgx/pgx_lwt_unix/test/dune
Normal file
4
unikernel/duniverse/pgx/pgx_lwt_unix/test/dune
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
(test
|
||||
(name test_pgx_lwt)
|
||||
(package pgx_lwt_unix)
|
||||
(libraries alcotest alcotest-lwt pgx_test pgx_lwt_unix))
|
||||
10
unikernel/duniverse/pgx/pgx_lwt_unix/test/test_pgx_lwt.ml
Normal file
10
unikernel/duniverse/pgx/pgx_lwt_unix/test/test_pgx_lwt.ml
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
module Alcotest_io = struct
|
||||
type 'a test_case = 'a Alcotest_lwt.test_case
|
||||
|
||||
let test_case name speed f = Alcotest_lwt.test_case name speed (fun _ -> f)
|
||||
let run name tests = Alcotest_lwt.run name tests |> Lwt_main.run
|
||||
end
|
||||
|
||||
include Pgx_test.Make_tests (Pgx_lwt_unix) (Alcotest_io)
|
||||
|
||||
let () = run_tests ~library_name:"pgx_lwt_unix"
|
||||
3
unikernel/duniverse/pgx/pgx_test/src/dune
Normal file
3
unikernel/duniverse/pgx/pgx_test/src/dune
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
(library
|
||||
(name pgx_test)
|
||||
(libraries alcotest base64 pgx))
|
||||
620
unikernel/duniverse/pgx/pgx_test/src/pgx_test.ml
Normal file
620
unikernel/duniverse/pgx/pgx_test/src/pgx_test.ml
Normal file
|
|
@ -0,0 +1,620 @@
|
|||
external reraise : exn -> _ = "%reraise"
|
||||
|
||||
module type S = sig
|
||||
val run_tests : library_name:string -> unit
|
||||
end
|
||||
|
||||
module type ALCOTEST_IO = sig
|
||||
open Alcotest
|
||||
|
||||
type 'a monad
|
||||
type 'a test_case
|
||||
|
||||
val test_case : string -> speed_level -> ('a -> unit monad) -> 'a test_case
|
||||
val run : string -> (string * unit test_case list) list -> unit
|
||||
end
|
||||
|
||||
module Alcotest_ext = struct
|
||||
let uuid = Alcotest.testable Uuidm.pp Uuidm.equal
|
||||
|
||||
let pgx_value =
|
||||
Alcotest.testable
|
||||
(fun fmt t ->
|
||||
Pgx.Value.sexp_of_t t |> Sexplib0.Sexp.to_string_hum |> Format.pp_print_string fmt)
|
||||
(fun a b -> Pgx.Value.compare a b = 0)
|
||||
;;
|
||||
end
|
||||
|
||||
let check_result = Alcotest.(check (list (list Alcotest_ext.pgx_value)))
|
||||
let check_results = Alcotest.(check (list (list (list Alcotest_ext.pgx_value))))
|
||||
|
||||
module Make_tests
|
||||
(Pgx_impl : Pgx.S)
|
||||
(Alcotest_io : ALCOTEST_IO with type 'a monad := 'a Pgx_impl.Io.t) =
|
||||
struct
|
||||
open Pgx_impl.Io
|
||||
open Pgx_impl
|
||||
|
||||
let default_database = "postgres"
|
||||
|
||||
let have_pg_config =
|
||||
try
|
||||
Unix.getenv "PGUSER" |> ignore;
|
||||
true
|
||||
with
|
||||
| Not_found -> false
|
||||
;;
|
||||
|
||||
let force_tests =
|
||||
try
|
||||
(Unix.getenv "PGX_FORCE_TESTS" : string) |> ignore;
|
||||
true
|
||||
with
|
||||
| Not_found -> false
|
||||
;;
|
||||
|
||||
let set_to_default_db () = Unix.putenv "PGDATABASE" default_database
|
||||
let ( >>| ) x f = x >>= fun x -> return (f x)
|
||||
|
||||
type ('a, 'b) result =
|
||||
| Ok of 'a
|
||||
| Error of 'b
|
||||
|
||||
let try_with f =
|
||||
catch (fun () -> f () >>| fun res -> Ok res) (fun e -> return (Error e))
|
||||
;;
|
||||
|
||||
let with_temp_db f =
|
||||
let random_db () =
|
||||
let random_char () = 10 |> Random.int |> string_of_int |> fun s -> s.[0] in
|
||||
"pgx_test_" ^ String.init 8 (fun _ -> random_char ())
|
||||
in
|
||||
let ignore_empty = function
|
||||
| [] -> ()
|
||||
| _ :: _ -> invalid_arg "ignore_empty"
|
||||
in
|
||||
let create_db dbh ~db_name =
|
||||
execute dbh ("CREATE DATABASE " ^ db_name) >>| ignore_empty
|
||||
in
|
||||
let drop_db dbh ~db_name =
|
||||
execute dbh ("DROP DATABASE " ^ db_name) >>| ignore_empty
|
||||
in
|
||||
with_conn ~database:default_database (fun dbh ->
|
||||
let db_name = random_db () in
|
||||
create_db dbh ~db_name
|
||||
>>= fun () ->
|
||||
connect ~database:db_name ()
|
||||
>>= fun test_dbh ->
|
||||
protect
|
||||
(fun () -> f test_dbh ~db_name)
|
||||
~finally:(fun () -> close test_dbh >>= fun () -> drop_db dbh ~db_name))
|
||||
;;
|
||||
|
||||
let assert_error_test query () =
|
||||
try_with (fun () -> with_conn @@ fun dbh -> execute dbh query)
|
||||
>>= function
|
||||
| Ok _ -> failwith "error expected"
|
||||
| Error _ -> return ()
|
||||
;;
|
||||
|
||||
let deferred_list_map l ~f =
|
||||
List.fold_left
|
||||
(fun acc x -> acc >>= fun acc -> f x >>| fun res -> res :: acc)
|
||||
(return [])
|
||||
l
|
||||
>>| List.rev
|
||||
;;
|
||||
|
||||
let list_init n f =
|
||||
let rec output_list x = if x < n then f x :: output_list (x + 1) else [] in
|
||||
output_list 0
|
||||
;;
|
||||
|
||||
let run_tests ~library_name =
|
||||
Random.self_init ();
|
||||
set_to_default_db ();
|
||||
let tests =
|
||||
[ Alcotest_io.test_case "test db connection" `Quick (fun () ->
|
||||
with_temp_db (fun _ ~db_name:_ -> return true)
|
||||
>>| Alcotest.(check bool) "with_temp_db makes a connection" true)
|
||||
; Alcotest_io.test_case
|
||||
"test fake table"
|
||||
`Quick
|
||||
(assert_error_test "SELECT * FROM non_exist")
|
||||
; Alcotest_io.test_case "query - 1 query" `Quick (fun () ->
|
||||
with_conn (fun dbh ->
|
||||
simple_query dbh "select 1"
|
||||
>>| check_results "select 1" [ [ [ Pgx.Value.of_string "1" ] ] ]))
|
||||
; Alcotest_io.test_case "query - multiple" `Quick (fun () ->
|
||||
with_conn (fun dbh ->
|
||||
simple_query dbh "select 1; select 2; select 3"
|
||||
>>| check_results
|
||||
"select three"
|
||||
Pgx.Value.
|
||||
[ [ [ of_string "1" ] ]
|
||||
; [ [ of_string "2" ] ]
|
||||
; [ [ of_string "3" ] ]
|
||||
]))
|
||||
; Alcotest_io.test_case "query - multiple single query" `Quick (fun () ->
|
||||
with_conn (fun dbh ->
|
||||
simple_query dbh "select 1 union all select 2 union all select 3"
|
||||
>>| check_results
|
||||
"select unit all"
|
||||
Pgx.Value.
|
||||
[ [ [ of_string "1" ]; [ of_string "2" ]; [ of_string "3" ] ] ]))
|
||||
; Alcotest_io.test_case "query - empty" `Quick (fun () ->
|
||||
with_conn (fun dbh -> simple_query dbh "" >>| check_results "empty query" []))
|
||||
; Alcotest_io.test_case
|
||||
"test fake column"
|
||||
`Quick
|
||||
(assert_error_test "SELECT qqq FROM pg_locks")
|
||||
; Alcotest_io.test_case "transaction error recovery" `Quick (fun () ->
|
||||
with_conn
|
||||
@@ fun dbh ->
|
||||
try_with (fun () ->
|
||||
with_transaction dbh (fun dbh -> simple_query dbh "select * from fake"))
|
||||
>>| function
|
||||
| Ok _ -> Alcotest.fail "test should fail. table doesn't exist"
|
||||
| Error _ -> ())
|
||||
; Alcotest_io.test_case "NoticeResponse in query" `Quick (fun () ->
|
||||
with_conn
|
||||
@@ fun dbh ->
|
||||
simple_query dbh "DROP VIEW IF EXISTS fake_view_doesnt_exist"
|
||||
>>| List.iter (check_result "drop view if exists" []))
|
||||
; Alcotest_io.test_case "test fold" `Quick (fun () ->
|
||||
with_conn
|
||||
@@ fun dbh ->
|
||||
Prepared.(
|
||||
with_prepare dbh ~query:"values (1,2),(3,4)" ~f:(fun s ->
|
||||
execute_fold s ~params:[] ~init:[] ~f:(fun acc a -> return (a :: acc))))
|
||||
>>| check_result
|
||||
"fold values"
|
||||
Pgx.Value.
|
||||
[ [ of_string "3"; of_string "4" ]; [ of_string "1"; of_string "2" ] ])
|
||||
; Alcotest_io.test_case "test execute_prepared" `Quick (fun () ->
|
||||
with_conn
|
||||
@@ fun dbh ->
|
||||
Prepared.(prepare dbh ~query:"values (1,2),(3,4)" >>= execute ~params:[])
|
||||
>>| check_result
|
||||
"prepare & execute"
|
||||
Pgx.Value.
|
||||
[ [ of_string "1"; of_string "2" ]; [ of_string "3"; of_string "4" ] ])
|
||||
; Alcotest_io.test_case "test execute_iter" `Quick (fun () ->
|
||||
let n = ref 0 in
|
||||
let rows = Array.make 2 [] in
|
||||
with_conn
|
||||
@@ fun dbh ->
|
||||
execute_iter dbh "values (1,2),(3,4)" ~f:(fun row ->
|
||||
rows.(!n) <- row;
|
||||
n := !n + 1;
|
||||
return ())
|
||||
>>| fun () ->
|
||||
Array.to_list rows
|
||||
|> check_result
|
||||
"execute_iter"
|
||||
Pgx.Value.
|
||||
[ [ of_string "1"; of_string "2" ]; [ of_string "3"; of_string "4" ] ])
|
||||
; Alcotest_io.test_case "with_prepare" `Quick (fun () ->
|
||||
with_conn
|
||||
@@ fun dbh ->
|
||||
let name = "with_prepare" in
|
||||
Prepared.(
|
||||
with_prepare dbh ~name ~query:"values ($1)" ~f:(fun s ->
|
||||
execute s ~params:Pgx.Value.[ of_string "test" ]))
|
||||
>>| check_result name Pgx.Value.[ [ of_string "test" ] ])
|
||||
; Alcotest_io.test_case "interleave unnamed prepares" `Quick (fun () ->
|
||||
with_conn
|
||||
@@ fun dbh ->
|
||||
let open Prepared in
|
||||
with_prepare dbh ~query:"values ($1)" ~f:(fun s1 ->
|
||||
with_prepare dbh ~query:"values (1)" ~f:(fun s2 ->
|
||||
execute s1 ~params:Pgx.Value.[ of_string "test" ]
|
||||
>>= fun r1 -> execute s2 ~params:[] >>| fun r2 -> r1, r2))
|
||||
>>| fun (r1, r2) ->
|
||||
check_result "outer prepare" Pgx.Value.[ [ of_string "test" ] ] r1;
|
||||
check_result "inner prepare" Pgx.Value.[ [ of_string "1" ] ] r2)
|
||||
; Alcotest_io.test_case "in_transaction invariant" `Quick (fun () ->
|
||||
with_conn
|
||||
@@ fun dbh ->
|
||||
try_with (fun () ->
|
||||
with_transaction dbh (fun dbh ->
|
||||
with_transaction dbh (fun _ -> return "unreachable")))
|
||||
>>| function
|
||||
| Ok "unreachable" -> failwith "in_transaction invariant failed"
|
||||
| Ok _ -> assert false
|
||||
| Error (Invalid_argument _) -> ()
|
||||
| Error exn -> reraise exn)
|
||||
; Alcotest_io.test_case "triple prepare no infinite loop" `Quick (fun () ->
|
||||
with_conn
|
||||
@@ fun dbh ->
|
||||
let name = "triple_prepare" in
|
||||
let p () = Prepared.prepare ~name dbh ~query:"values (1,2)" in
|
||||
p ()
|
||||
>>= fun _ ->
|
||||
try_with p
|
||||
>>= fun _ ->
|
||||
try_with p
|
||||
>>| function
|
||||
| Ok _ -> failwith "Triple prepare should fail"
|
||||
| Error (Pgx.PostgreSQL_Error _) -> ()
|
||||
| Error exn -> reraise exn)
|
||||
; Alcotest_io.test_case "execute_many function" `Quick (fun () ->
|
||||
let params =
|
||||
Pgx.Value.[ [ of_string "1" ]; [ of_string "2" ]; [ of_string "3" ] ]
|
||||
in
|
||||
with_conn (fun dbh ->
|
||||
execute_many dbh ~query:"select $1::int" ~params
|
||||
>>| check_results
|
||||
"execute_many result"
|
||||
Pgx.Value.
|
||||
[ [ [ of_string "1" ] ]
|
||||
; [ [ of_string "2" ] ]
|
||||
; [ [ of_string "3" ] ]
|
||||
]))
|
||||
; Alcotest_io.test_case "query with SET" `Quick (fun () ->
|
||||
with_conn (fun dbh ->
|
||||
simple_query dbh "SET LOCAL TIME ZONE 'Europe/Rome'; SELECT 'x'"
|
||||
>>| function
|
||||
| [ []; [ [ res ] ] ] ->
|
||||
Pgx.Value.to_string_exn res
|
||||
|> Alcotest.(check string) "SELECT after SET" "x"
|
||||
| _ -> assert false))
|
||||
; Alcotest_io.test_case "ping" `Quick (fun () -> with_conn (fun dbh -> ping dbh))
|
||||
; Alcotest_io.test_case "with_prepare and describe_statement" `Quick (fun () ->
|
||||
with_conn
|
||||
@@ fun dbh ->
|
||||
let name = "some name" in
|
||||
Prepared.(with_prepare dbh ~name ~query:"values ($1)" ~f:describe)
|
||||
>>| fun _ -> ())
|
||||
; Alcotest_io.test_case "should fail without sequencer" `Quick (fun () ->
|
||||
with_conn (fun dbh ->
|
||||
deferred_list_map
|
||||
(list_init 100 (fun x -> x))
|
||||
~f:(fun _ -> simple_query dbh "")
|
||||
>>| fun _ -> ()))
|
||||
; Alcotest_io.test_case "copy out simple query" `Quick (fun () ->
|
||||
with_temp_db (fun dbh ~db_name:_ ->
|
||||
simple_query
|
||||
dbh
|
||||
"CREATE TABLE tennis_greats ( name varchar(40), \
|
||||
grand_slams integer); INSERT INTO tennis_greats VALUES ('Roger \
|
||||
Federer', 19), ('Rafael Nadal', 15); COPY tennis_greats TO STDOUT \
|
||||
(DELIMITER '|')"
|
||||
>>| check_results
|
||||
"copy out result"
|
||||
Pgx.Value.
|
||||
[ []
|
||||
; []
|
||||
; [ [ of_string "Roger Federer|19\n" ]
|
||||
; [ of_string "Rafael Nadal|15\n" ]
|
||||
]
|
||||
]))
|
||||
; Alcotest_io.test_case "copy out extended query" `Quick (fun () ->
|
||||
with_temp_db (fun dbh ~db_name:_ ->
|
||||
execute
|
||||
dbh
|
||||
"CREATE TABLE tennis_greats ( name varchar(40), \
|
||||
grand_slams integer);"
|
||||
>>= fun _ ->
|
||||
execute
|
||||
dbh
|
||||
"INSERT INTO tennis_greats VALUES ('Roger Federer', 19), ('Rafael \
|
||||
Nadal', 15);"
|
||||
>>= fun _ -> execute dbh "COPY tennis_greats TO STDOUT (DELIMITER '|')")
|
||||
>>| check_result
|
||||
"copy out extended result"
|
||||
Pgx.Value.
|
||||
[ [ of_string "Roger Federer|19\n" ]
|
||||
; [ of_string "Rafael Nadal|15\n" ]
|
||||
])
|
||||
; Alcotest_io.test_case "execute_prepared_iter and transact test" `Quick (fun () ->
|
||||
with_temp_db (fun dbh ~db_name:_ ->
|
||||
with_transaction dbh (fun dbh ->
|
||||
execute
|
||||
dbh
|
||||
"CREATE TABLE tennis_greats ( name varchar(40), \
|
||||
grand_slams integer);"
|
||||
>>= fun _ ->
|
||||
execute
|
||||
dbh
|
||||
"INSERT INTO tennis_greats VALUES ('Roger Federer', 19), ('Rafael \
|
||||
Nadal', 15);"
|
||||
>>= fun _ ->
|
||||
let open Prepared in
|
||||
with_prepare
|
||||
dbh
|
||||
~query:
|
||||
"SELECT * FROM tennis_greats WHERE name=$1 AND grand_slams=$2"
|
||||
~f:(fun s ->
|
||||
let acc = ref [] in
|
||||
execute_iter
|
||||
s
|
||||
~params:Pgx.Value.[ of_string "Roger Federer"; of_int 19 ]
|
||||
~f:(fun fields -> return (acc := fields :: !acc))
|
||||
>>= fun () -> return !acc))
|
||||
>>| check_result
|
||||
"prepare & transact result"
|
||||
Pgx.Value.[ [ of_string "Roger Federer"; of_string "19" ] ]))
|
||||
; Alcotest_io.test_case "commit while not in transaction" `Quick (fun () ->
|
||||
try_with (fun () ->
|
||||
with_conn
|
||||
@@ fun dbh ->
|
||||
begin_work dbh >>= fun dbh -> commit dbh >>= fun () -> commit dbh)
|
||||
>>= function
|
||||
| Ok _ -> failwith "commit while not in transaction error expected"
|
||||
| Error _ -> return ())
|
||||
; Alcotest_io.test_case "rollback while not in transaction" `Quick (fun () ->
|
||||
try_with (fun () ->
|
||||
with_conn
|
||||
@@ fun dbh ->
|
||||
begin_work dbh >>= fun dbh -> commit dbh >>= fun () -> rollback dbh)
|
||||
>>= function
|
||||
| Ok _ -> failwith "rollback while not in transaction error expected"
|
||||
| Error _ -> return ())
|
||||
; Alcotest_io.test_case "alive test" `Quick (fun () ->
|
||||
with_conn
|
||||
@@ fun dbh -> alive dbh >>| Alcotest.(check bool) "alive result" true)
|
||||
; Alcotest_io.test_case "isolation level tests" `Quick (fun () ->
|
||||
with_temp_db (fun dbh ~db_name:_ ->
|
||||
execute
|
||||
dbh
|
||||
"CREATE TABLE tennis_greats ( name varchar(40), \
|
||||
grand_slams integer);"
|
||||
>>= fun _ ->
|
||||
with_transaction ~isolation:Pgx.Isolation.Serializable dbh (fun dbh ->
|
||||
execute dbh "INSERT INTO tennis_greats VALUES ('Roger Federer', 19);")
|
||||
>>= fun _ ->
|
||||
with_transaction ~isolation:Pgx.Isolation.Repeatable_read dbh (fun dbh ->
|
||||
execute dbh "INSERT INTO tennis_greats VALUES ('Rafael Nadal', 15);")
|
||||
>>= fun _ ->
|
||||
with_transaction ~isolation:Pgx.Isolation.Read_committed dbh (fun dbh ->
|
||||
execute dbh "INSERT INTO tennis_greats VALUES ('Novak Djokovic', 12);")
|
||||
>>= fun _ ->
|
||||
with_transaction ~isolation:Pgx.Isolation.Read_uncommitted dbh (fun dbh ->
|
||||
execute dbh "INSERT INTO tennis_greats VALUES ('Andy Murray', 3);")
|
||||
>>= fun _ ->
|
||||
let open Prepared in
|
||||
with_prepare
|
||||
dbh
|
||||
~query:"SELECT * FROM tennis_greats WHERE name=$1 AND grand_slams=$2"
|
||||
~f:(fun s ->
|
||||
let acc = ref [] in
|
||||
execute_iter
|
||||
s
|
||||
~params:Pgx.Value.[ of_string "Andy Murray"; of_string "3" ]
|
||||
~f:(fun fields -> return (acc := fields :: !acc))
|
||||
>>= fun () -> return !acc)
|
||||
>>| check_result
|
||||
"isolation query result"
|
||||
Pgx.Value.[ [ of_string "Andy Murray"; of_string "3" ] ]))
|
||||
; Alcotest_io.test_case "multi typed table" `Quick (fun () ->
|
||||
with_temp_db (fun dbh ~db_name:_ ->
|
||||
simple_query
|
||||
dbh
|
||||
"CREATE TABLE multi_typed(uuid uuid, int int, string text, numeric \
|
||||
numeric);"
|
||||
>>= fun _ ->
|
||||
let expect_uuid = Uuidm.create `V4 in
|
||||
let params =
|
||||
let open Pgx.Value in
|
||||
[ of_uuid expect_uuid
|
||||
; of_int 12
|
||||
; of_string "asdf"
|
||||
; of_string "9223372036854775807"
|
||||
]
|
||||
in
|
||||
execute
|
||||
dbh
|
||||
~params
|
||||
"INSERT INTO multi_typed (uuid, int, string, numeric) VALUES ($1, $2, \
|
||||
$3, $4)"
|
||||
>>= fun _ ->
|
||||
simple_query dbh "SELECT * FROM multi_typed"
|
||||
>>| function
|
||||
| [ [ [ uuid; int_; string_; numeric ] ] ] ->
|
||||
let open Pgx.Value in
|
||||
let uuid = to_uuid uuid in
|
||||
let int_ = to_int int_ in
|
||||
let string_ = to_string string_ in
|
||||
let numeric = to_string numeric in
|
||||
Alcotest.(Alcotest_ext.(check (option uuid)))
|
||||
"uuid"
|
||||
(Some expect_uuid)
|
||||
uuid;
|
||||
Alcotest.(check (option int)) "int" (Some 12) int_;
|
||||
Alcotest.(check (option string)) "string" (Some "asdf") string_;
|
||||
Alcotest.(check (option string))
|
||||
"numeric"
|
||||
(Some "9223372036854775807")
|
||||
numeric
|
||||
| _ ->
|
||||
Alcotest.fail "Error: multi typed table: got unexpected query result"))
|
||||
; Alcotest_io.test_case "binary string handling" `Quick (fun () ->
|
||||
let all_chars = String.init 255 char_of_int in
|
||||
with_conn (fun db ->
|
||||
[ ( "SELECT decode($1, 'base64')::bytea"
|
||||
, Base64.encode_exn all_chars |> Pgx.Value.of_string
|
||||
, Pgx.Value.to_binary_exn
|
||||
, all_chars )
|
||||
(* Postgres adds whitespace to base64 encodings, so we strip it
|
||||
back out *)
|
||||
; ( "SELECT regexp_replace(encode($1::bytea, 'base64'), '\\s', '', 'g')"
|
||||
, Pgx.Value.of_binary all_chars
|
||||
, Pgx.Value.to_string_exn
|
||||
, Base64.encode_exn all_chars )
|
||||
]
|
||||
|> deferred_list_map ~f:(fun (query, param, read_f, expect) ->
|
||||
let params = [ param ] in
|
||||
execute ~params db query
|
||||
>>| function
|
||||
| [ [ actual ] ] ->
|
||||
read_f actual |> Alcotest.(check string) "binary string" expect
|
||||
| _ -> assert false))
|
||||
>>| List.iter (fun () -> ()))
|
||||
; Alcotest_io.test_case "binary string round-trip" `Quick (fun () ->
|
||||
let all_chars = String.init 255 char_of_int in
|
||||
with_conn (fun db ->
|
||||
(* This binary string should get encoded as hex and stored as one byte-per-byte of input *)
|
||||
let params = [ Pgx.Value.of_binary all_chars ] in
|
||||
(* Checking here that Postgres doesn't throw an exception about null characters in input, since
|
||||
our encoded input has no null chars *)
|
||||
execute ~params db "SELECT $1::bytea, octet_length($1::bytea)"
|
||||
>>| function
|
||||
| [ [ value; length ] ] ->
|
||||
Pgx.Value.to_binary_exn value
|
||||
|> Alcotest.(check string) "binary string contents" all_chars;
|
||||
(* Our string is 255 bytes so it should be stored as 255 bytes, not as 512 (the length of the
|
||||
encoded hex). What we're testing here is that we're actually storing binary, not hex
|
||||
encoded binary *)
|
||||
Pgx.Value.to_int_exn length
|
||||
|> Alcotest.(check int) "binary string length" 255
|
||||
| _ -> assert false))
|
||||
; Alcotest_io.test_case "Non-binary literal hex string round-trip" `Quick (fun () ->
|
||||
with_conn (fun db ->
|
||||
(* This hex string should get inserted into the DB as literally "\x0001etc" *)
|
||||
let input =
|
||||
"\\x000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f202122232425262728292a2b2c2d2e2f303132333435363738393a3b3c3d3e3f404142434445464748494a4b4c4d4e4f505152535455565758595a5b5c5d5e5f606162636465666768696a6b6c6d6e6f707172737475767778797a7b7c7d7e7f808182838485868788898a8b8c8d8e8f909192939495969798999a9b9c9d9e9fa0a1a2a3a4a5a6a7a8a9aaabacadaeafb0b1b2b3b4b5b6b7b8b9babbbcbdbebfc0c1c2c3c4c5c6c7c8c9cacbcccdcecfd0d1d2d3d4d5d6d7d8d9dadbdcdddedfe0e1e2e3e4e5e6e7e8e9eaebecedeeeff0f1f2f3f4f5f6f7f8f9fafbfcfdfe"
|
||||
in
|
||||
let params = [ Pgx.Value.of_string input ] in
|
||||
execute ~params db "SELECT $1::varchar, octet_length($1::varchar)"
|
||||
>>| function
|
||||
| [ [ value; length ] ] ->
|
||||
Pgx.Value.to_string_exn value
|
||||
|> Alcotest.(check string) "string contents" input;
|
||||
Pgx.Value.to_int_exn length |> Alcotest.(check int) "string length" 512
|
||||
| _ -> assert false))
|
||||
; Alcotest_io.test_case "Binary literal hex string round-trip" `Quick (fun () ->
|
||||
with_conn (fun db ->
|
||||
(* This hex string should get double encoded so it makes it into the DB as literally "\x0001etc" *)
|
||||
let input =
|
||||
"\\x000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f202122232425262728292a2b2c2d2e2f303132333435363738393a3b3c3d3e3f404142434445464748494a4b4c4d4e4f505152535455565758595a5b5c5d5e5f606162636465666768696a6b6c6d6e6f707172737475767778797a7b7c7d7e7f808182838485868788898a8b8c8d8e8f909192939495969798999a9b9c9d9e9fa0a1a2a3a4a5a6a7a8a9aaabacadaeafb0b1b2b3b4b5b6b7b8b9babbbcbdbebfc0c1c2c3c4c5c6c7c8c9cacbcccdcecfd0d1d2d3d4d5d6d7d8d9dadbdcdddedfe0e1e2e3e4e5e6e7e8e9eaebecedeeeff0f1f2f3f4f5f6f7f8f9fafbfcfdfe"
|
||||
in
|
||||
let params = [ Pgx.Value.of_binary input ] in
|
||||
execute ~params db "SELECT $1::bytea, octet_length($1::bytea)"
|
||||
>>| function
|
||||
| [ [ value; length ] ] ->
|
||||
Pgx.Value.to_binary_exn value
|
||||
|> Alcotest.(check string) "string contents" input;
|
||||
Pgx.Value.to_int_exn length |> Alcotest.(check int) "string length" 512
|
||||
| _ -> assert false))
|
||||
; Alcotest_io.test_case "UTF-8 partial round-trip 1" `Quick (fun () ->
|
||||
(* Select a literal string *)
|
||||
let expect = "test-ä-test" in
|
||||
with_conn (fun db ->
|
||||
simple_query
|
||||
db
|
||||
{|
|
||||
CREATE TEMPORARY TABLE this_test (id text);
|
||||
INSERT INTO this_test (id) VALUES ('test-ä-test')
|
||||
|}
|
||||
>>= fun _ ->
|
||||
execute db "SELECT id FROM this_test"
|
||||
>>| function
|
||||
| [ [ result ] ] ->
|
||||
Alcotest.(check (option string))
|
||||
""
|
||||
(Some expect)
|
||||
(Pgx.Value.to_string result)
|
||||
| _ -> assert false))
|
||||
; Alcotest_io.test_case "UTF-8 partial round-trip 1 with where" `Quick (fun () ->
|
||||
(* Select a literal string *)
|
||||
let expect = "test-ä-test" in
|
||||
with_conn (fun db ->
|
||||
simple_query
|
||||
db
|
||||
{|
|
||||
CREATE TEMPORARY TABLE this_test (id text);
|
||||
INSERT INTO this_test (id) VALUES ('test-ä-test')
|
||||
|}
|
||||
>>= fun _ ->
|
||||
execute
|
||||
db
|
||||
~params:[ Pgx.Value.of_string expect ]
|
||||
"SELECT id FROM this_test WHERE id = $1"
|
||||
>>| function
|
||||
| [ [ result ] ] ->
|
||||
Alcotest.(check (option string))
|
||||
""
|
||||
(Some expect)
|
||||
(Pgx.Value.to_string result)
|
||||
| [] -> Alcotest.fail "Expected one row but got zero"
|
||||
| _ -> assert false))
|
||||
; Alcotest_io.test_case "UTF-8 partial round-trip 2" `Quick (fun () ->
|
||||
(* Insert string as a param, then select back the contents of
|
||||
the table *)
|
||||
let expect = "test-ä-test" in
|
||||
with_conn (fun db ->
|
||||
simple_query db "CREATE TEMPORARY TABLE this_test (id text)"
|
||||
>>= fun _ ->
|
||||
execute
|
||||
db
|
||||
~params:[ Pgx.Value.of_string expect ]
|
||||
"INSERT INTO this_test (id) VALUES ($1)"
|
||||
>>= fun _ ->
|
||||
execute db "SELECT id FROM this_test"
|
||||
>>| function
|
||||
| [ [ result ] ] ->
|
||||
Alcotest.(check (option string))
|
||||
""
|
||||
(Some expect)
|
||||
(Pgx.Value.to_string result)
|
||||
| _ -> assert false))
|
||||
; Alcotest_io.test_case "UTF-8 partial round-trip 3" `Quick (fun () ->
|
||||
with_conn (fun db ->
|
||||
simple_query
|
||||
db
|
||||
{|
|
||||
CREATE TEMPORARY TABLE this_test (id text);
|
||||
INSERT INTO this_test (id) VALUES('test-\303\244-test')
|
||||
|}
|
||||
>>= fun _ ->
|
||||
execute db "SELECT id FROM this_test"
|
||||
>>| function
|
||||
| [ [ result ] ] ->
|
||||
Alcotest.(check string)
|
||||
""
|
||||
{|test-\303\244-test|}
|
||||
(Pgx.Value.to_string_exn result)
|
||||
| _ -> assert false))
|
||||
; Alcotest_io.test_case "UTF-8 round-trip" `Quick (fun () ->
|
||||
(* Select the contents of a param *)
|
||||
let expect = "test-ä-test" in
|
||||
with_conn (fun db ->
|
||||
execute db ~params:[ Pgx.Value.of_string expect ] "SELECT $1::VARCHAR"
|
||||
>>| function
|
||||
| [ [ result ] ] ->
|
||||
Alcotest.(check (option string))
|
||||
""
|
||||
(Some expect)
|
||||
(Pgx.Value.to_string result)
|
||||
| _ -> assert false))
|
||||
; Alcotest_io.test_case "UTF-8 round-trip where" `Quick (fun () ->
|
||||
(* Insert string as a param, then select back the contents of
|
||||
the table using a WHERE *)
|
||||
let expect = "test-ä-test" in
|
||||
with_conn (fun db ->
|
||||
simple_query db "CREATE TEMPORARY TABLE this_test (id text)"
|
||||
>>= fun _ ->
|
||||
execute
|
||||
db
|
||||
~params:[ Pgx.Value.of_string expect ]
|
||||
"INSERT INTO this_test (id) VALUES ($1)"
|
||||
>>= fun _ ->
|
||||
execute
|
||||
db
|
||||
~params:[ Pgx.Value.of_string expect ]
|
||||
"SELECT id FROM this_test WHERE id = $1"
|
||||
>>| function
|
||||
| [ [ result ] ] ->
|
||||
Alcotest.(check (option string))
|
||||
""
|
||||
(Some expect)
|
||||
(Pgx.Value.to_string result)
|
||||
| _ -> assert false))
|
||||
]
|
||||
in
|
||||
if force_tests || have_pg_config
|
||||
then Alcotest_io.run "pgx_test" [ library_name, tests ]
|
||||
else print_endline "Skipping PostgreSQL tests since PGUSER is unset."
|
||||
;;
|
||||
end
|
||||
17
unikernel/duniverse/pgx/pgx_test/src/pgx_test.mli
Normal file
17
unikernel/duniverse/pgx/pgx_test/src/pgx_test.mli
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
module type S = sig
|
||||
val run_tests : library_name:string -> unit
|
||||
end
|
||||
|
||||
module type ALCOTEST_IO = sig
|
||||
open Alcotest
|
||||
|
||||
type 'a monad
|
||||
type 'a test_case
|
||||
|
||||
val test_case : string -> speed_level -> ('a -> unit monad) -> 'a test_case
|
||||
val run : string -> (string * unit test_case list) list -> unit
|
||||
end
|
||||
|
||||
module Make_tests
|
||||
(Pgx_impl : Pgx.S)
|
||||
(Alcotest_io : ALCOTEST_IO with type 'a monad := 'a Pgx_impl.Io.t) : S
|
||||
35
unikernel/duniverse/pgx/pgx_unix.opam
Normal file
35
unikernel/duniverse/pgx/pgx_unix.opam
Normal file
|
|
@ -0,0 +1,35 @@
|
|||
version: "2.2"
|
||||
# This file is generated by dune, edit dune-project instead
|
||||
opam-version: "2.0"
|
||||
synopsis: "PGX using the standard library's Unix module for IO (synchronous)"
|
||||
description:
|
||||
"PGX using the standard library's Unix module for IO (synchronous)"
|
||||
maintainer: ["Arena Developers <silver-snakes@arena.io>"]
|
||||
authors: ["Arena Developers <silver-snakes@arena.io>"]
|
||||
license: "LGPL-2.0-only with OCaml-LGPL-linking-exception"
|
||||
homepage: "https://github.com/arenadotio/pgx"
|
||||
doc: "https://arenadotio.github.io/pgx"
|
||||
bug-reports: "https://github.com/arenadotio/pgx/issues"
|
||||
depends: [
|
||||
"dune" {>= "3.2"}
|
||||
"alcotest" {with-test & >= "1.0.0"}
|
||||
"base64" {with-test & >= "3.0.0"}
|
||||
"ocaml" {>= "4.08"}
|
||||
"pgx" {= version}
|
||||
"odoc" {with-doc}
|
||||
]
|
||||
build: [
|
||||
["dune" "subst"] {dev}
|
||||
[
|
||||
"dune"
|
||||
"build"
|
||||
"-p"
|
||||
name
|
||||
"-j"
|
||||
jobs
|
||||
"@install"
|
||||
"@runtest" {with-test}
|
||||
"@doc" {with-doc}
|
||||
]
|
||||
]
|
||||
dev-repo: "git+https://github.com/arenadotio/pgx.git"
|
||||
15
unikernel/duniverse/pgx/pgx_unix/src/dune
Normal file
15
unikernel/duniverse/pgx/pgx_unix/src/dune
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
(* -*- tuareg -*- *)
|
||||
|
||||
let preprocess =
|
||||
match Sys.getenv "BISECT_ENABLE" with
|
||||
| "yes" -> "(preprocess (pps bisect_ppx))"
|
||||
| _ -> ""
|
||||
| exception Not_found -> ""
|
||||
|
||||
let () = Jbuild_plugin.V1.send @@ {|
|
||||
|
||||
(library
|
||||
(public_name pgx_unix)
|
||||
(libraries pgx)
|
||||
|} ^ preprocess ^ {|)
|
||||
|}
|
||||
100
unikernel/duniverse/pgx/pgx_unix/src/pgx_unix.ml
Normal file
100
unikernel/duniverse/pgx/pgx_unix/src/pgx_unix.ml
Normal file
|
|
@ -0,0 +1,100 @@
|
|||
(* PG'OCaml is a set of OCaml bindings for the PostgreSQL database.
|
||||
*
|
||||
* PG'OCaml - type safe interface to PostgreSQL.
|
||||
* Copyright (C) 2005-2009 Richard Jones and other authors.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Library General Public
|
||||
* License as published by the Free Software Foundation; either
|
||||
* version 2 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
|
||||
* Library General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU General Public License
|
||||
* along with this library; see the file COPYING. If not, write to
|
||||
* the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
* Boston, MA 02111-1307, USA.
|
||||
*)
|
||||
|
||||
external reraise : exn -> _ = "%reraise"
|
||||
|
||||
module Simple_thread = struct
|
||||
type 'a t = 'a
|
||||
|
||||
let return x = x
|
||||
let ( >>= ) v f = f v
|
||||
|
||||
let catch f fexn =
|
||||
try f () with
|
||||
| e -> fexn e
|
||||
;;
|
||||
|
||||
type sockaddr =
|
||||
| Unix of string
|
||||
| Inet of string * int
|
||||
|
||||
type nonrec in_channel = in_channel
|
||||
type nonrec out_channel = out_channel
|
||||
|
||||
let open_connection sockaddr =
|
||||
let std_socket =
|
||||
match sockaddr with
|
||||
| Unix path -> Unix.ADDR_UNIX path
|
||||
| Inet (hostname, port) ->
|
||||
let hostent = Unix.gethostbyname hostname in
|
||||
(* Choose a random address from the list. *)
|
||||
let addrs = hostent.Unix.h_addr_list in
|
||||
let len = Array.length addrs in
|
||||
let i = Random.int len in
|
||||
let addr = addrs.(i) in
|
||||
Unix.ADDR_INET (addr, port)
|
||||
in
|
||||
Unix.open_connection std_socket
|
||||
;;
|
||||
|
||||
type ssl_config
|
||||
|
||||
let upgrade_ssl = `Not_supported
|
||||
let output_char = output_char
|
||||
let output_binary_int = output_binary_int
|
||||
let output_string = output_string
|
||||
let flush = flush
|
||||
let input_char = input_char
|
||||
let input_binary_int = input_binary_int
|
||||
let really_input = really_input
|
||||
let close_in = close_in
|
||||
|
||||
(* The unix getlogin syscall can fail *)
|
||||
let getlogin () = Unix.getuid () |> Unix.getpwuid |> fun { Unix.pw_name; _ } -> pw_name
|
||||
let debug = prerr_endline
|
||||
|
||||
let protect f ~(finally : unit -> unit) =
|
||||
let result = ref None in
|
||||
try
|
||||
result := Some (f ());
|
||||
raise Exit
|
||||
with
|
||||
| Exit as e ->
|
||||
finally ();
|
||||
(match !result with
|
||||
| Some x -> x
|
||||
| None -> reraise e)
|
||||
| e ->
|
||||
finally ();
|
||||
reraise e
|
||||
;;
|
||||
|
||||
module Sequencer = struct
|
||||
type 'a monad = 'a t
|
||||
type 'a t = 'a
|
||||
|
||||
let create t = t
|
||||
let enqueue t f = f t
|
||||
end
|
||||
end
|
||||
|
||||
module M = Pgx.Make (Simple_thread)
|
||||
include M
|
||||
25
unikernel/duniverse/pgx/pgx_unix/src/pgx_unix.mli
Normal file
25
unikernel/duniverse/pgx/pgx_unix/src/pgx_unix.mli
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
(* PG'OCaml is a set of OCaml bindings for the PostgreSQL database.
|
||||
*
|
||||
* PG'OCaml - type safe interface to PostgreSQL.
|
||||
* Copyright (C) 2005-2009 Richard Jones and other authors.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Library General Public
|
||||
* License as published by the Free Software Foundation; either
|
||||
* version 2 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
|
||||
* Library General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU General Public License
|
||||
* along with this library; see the file COPYING. If not, write to
|
||||
* the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
* Boston, MA 02111-1307, USA.
|
||||
*)
|
||||
|
||||
include Pgx.S with type 'a Io.t = 'a
|
||||
|
||||
(* for testing purposes *)
|
||||
module Simple_thread : Pgx.Io with type 'a t = 'a
|
||||
4
unikernel/duniverse/pgx/pgx_unix/test/dune
Normal file
4
unikernel/duniverse/pgx/pgx_unix/test/dune
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
(test
|
||||
(name test_pgx_unix)
|
||||
(package pgx_unix)
|
||||
(libraries pgx_test pgx_unix))
|
||||
10
unikernel/duniverse/pgx/pgx_unix/test/test_pgx_unix.ml
Normal file
10
unikernel/duniverse/pgx/pgx_unix/test/test_pgx_unix.ml
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
module Alcotest_io = struct
|
||||
type 'a test_case = 'a Alcotest.test_case
|
||||
|
||||
let test_case name speed f = Alcotest.test_case name speed f
|
||||
let run name tests = Alcotest.run name tests
|
||||
end
|
||||
|
||||
include Pgx_test.Make_tests (Pgx_unix) (Alcotest_io)
|
||||
|
||||
let () = run_tests ~library_name:"pgx_unix"
|
||||
34
unikernel/duniverse/pgx/pgx_value_core.opam
Normal file
34
unikernel/duniverse/pgx/pgx_value_core.opam
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
version: "2.2"
|
||||
# This file is generated by dune, edit dune-project instead
|
||||
opam-version: "2.0"
|
||||
synopsis: "Pgx_value converters for Core types like Date and Time"
|
||||
description: "Pgx_value converters for Core types like Date and Time"
|
||||
maintainer: ["Arena Developers <silver-snakes@arena.io>"]
|
||||
authors: ["Arena Developers <silver-snakes@arena.io>"]
|
||||
license: "LGPL-2.0-only with OCaml-LGPL-linking-exception"
|
||||
homepage: "https://github.com/arenadotio/pgx"
|
||||
doc: "https://arenadotio.github.io/pgx"
|
||||
bug-reports: "https://github.com/arenadotio/pgx/issues"
|
||||
depends: [
|
||||
"dune" {>= "3.2"}
|
||||
"alcotest" {with-test & >= "1.0.0"}
|
||||
"core_kernel" {>= "v0.13.0"}
|
||||
"ocaml" {>= "4.08"}
|
||||
"pgx" {= version}
|
||||
"odoc" {with-doc}
|
||||
]
|
||||
build: [
|
||||
["dune" "subst"] {dev}
|
||||
[
|
||||
"dune"
|
||||
"build"
|
||||
"-p"
|
||||
name
|
||||
"-j"
|
||||
jobs
|
||||
"@install"
|
||||
"@runtest" {with-test}
|
||||
"@doc" {with-doc}
|
||||
]
|
||||
]
|
||||
dev-repo: "git+https://github.com/arenadotio/pgx.git"
|
||||
15
unikernel/duniverse/pgx/pgx_value_core/src/dune
Normal file
15
unikernel/duniverse/pgx/pgx_value_core/src/dune
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
(* -*- tuareg -*- *)
|
||||
|
||||
let preprocess =
|
||||
match Sys.getenv "BISECT_ENABLE" with
|
||||
| "yes" -> "(preprocess (pps bisect_ppx))"
|
||||
| _ -> ""
|
||||
| exception Not_found -> ""
|
||||
|
||||
let () = Jbuild_plugin.V1.send @@ {|
|
||||
|
||||
(library
|
||||
(public_name pgx_value_core)
|
||||
(libraries core_kernel pgx)
|
||||
|} ^ preprocess ^ {|)
|
||||
|}
|
||||
63
unikernel/duniverse/pgx/pgx_value_core/src/pgx_value_core.ml
Normal file
63
unikernel/duniverse/pgx/pgx_value_core/src/pgx_value_core.ml
Normal file
|
|
@ -0,0 +1,63 @@
|
|||
open Core_kernel
|
||||
include Pgx.Value
|
||||
|
||||
let of_time t =
|
||||
(*
|
||||
Postgres behaves differently depending on whether the timestamp data type
|
||||
includes the timezone or not:
|
||||
|
||||
Without timezone all inserted timezones are ignored
|
||||
2016-06-07 15:37:46 (no timezone)
|
||||
2016-06-07 15:37:46Z (utc timezone)
|
||||
2016-06-07 15:37:46-04 (local timezone)
|
||||
Get inserted as
|
||||
2016-06-07 15:37:46
|
||||
|
||||
With timezones:
|
||||
2016-06-07 15:37:46 (no timezone) -> 2016-06-07 15:37:46-04
|
||||
2016-06-07 15:37:46Z (utc timezone) -> 2016-06-07 11:37:46-04
|
||||
2016-06-07 15:37:46-04 (local timezone) -> 2016-06-07 15:37:46-04
|
||||
*)
|
||||
Time.to_string_abs ~zone:Time.Zone.utc t |> Pgx.Value.of_string
|
||||
;;
|
||||
|
||||
let to_time' =
|
||||
(*
|
||||
The time string can come in various forms depending on whether the
|
||||
Postgres timestamp used includes the time zone:
|
||||
|
||||
Without timezone
|
||||
2016-06-07 15:37:46
|
||||
2016-06-07 15:37:46.962425
|
||||
|
||||
With timezone
|
||||
2016-06-07 15:37:46-04
|
||||
2016-06-07 15:37:46.962425-04
|
||||
|
||||
For the first one we need to indicate that it's a UTC time by appending
|
||||
a 'Z'. For the second one we need to append the minutes to the timezone.
|
||||
Without these formattings Time.of_string fails spectacularly
|
||||
*)
|
||||
let open Re in
|
||||
let tz = seq [ alt [ char '-'; char '+' ]; digit; digit ] in
|
||||
let utctz = seq [ char 'Z'; eol ] |> compile in
|
||||
let localtz_no_min = seq [ tz; eol ] |> compile in
|
||||
let localtz = seq [ tz; char ':'; digit; digit; eol ] |> compile in
|
||||
fun s ->
|
||||
Time.of_string
|
||||
@@
|
||||
match matches utctz s, matches localtz s, matches localtz_no_min s with
|
||||
| [], [], [] -> s ^ "Z"
|
||||
| _, [], [] -> s
|
||||
| [], _, [] -> s
|
||||
| [], [], _ -> s ^ ":00"
|
||||
(* It either finishes in one of the patterns above or it doesn't *)
|
||||
| _ -> convert_failure "time" s
|
||||
;;
|
||||
|
||||
let to_time_exn v = Pgx.Value.to_string_exn v |> to_time'
|
||||
let to_time v = Pgx.Value.to_string v |> Option.map ~f:to_time'
|
||||
let of_date d = Date.to_string d |> Pgx.Value.of_string
|
||||
let to_date' = Date.of_string
|
||||
let to_date_exn v = Pgx.Value.to_string_exn v |> to_date'
|
||||
let to_date v = Pgx.Value.to_string v |> Option.map ~f:to_date'
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
(** Pgx_value types using Core_kernel's Date and Time modules *)
|
||||
open Core_kernel
|
||||
|
||||
type v = Pgx.Value.v [@@deriving compare, sexp_of]
|
||||
type t = Pgx.Value.t [@@deriving compare, sexp_of]
|
||||
|
||||
include module type of Pgx.Value with type v := v and type t := t
|
||||
|
||||
val of_date : Date.t -> t
|
||||
val to_date_exn : t -> Date.t
|
||||
val to_date : t -> Date.t option
|
||||
val of_time : Time.t -> t
|
||||
val to_time_exn : t -> Time.t
|
||||
val to_time : t -> Time.t option
|
||||
4
unikernel/duniverse/pgx/pgx_value_core/test/dune
Normal file
4
unikernel/duniverse/pgx/pgx_value_core/test/dune
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
(tests
|
||||
(names test_pgx_value_core)
|
||||
(package pgx_value_core)
|
||||
(libraries alcotest pgx_value_core))
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
open Core_kernel
|
||||
module Value = Pgx_value_core
|
||||
|
||||
let time_roundtrip str = Value.of_string str |> Value.to_time_exn
|
||||
let printer = Time.to_string_abs ~zone:Time.Zone.utc
|
||||
|
||||
let time_testable =
|
||||
Alcotest.testable (fun ppf t -> Format.pp_print_string ppf (printer t)) Time.equal
|
||||
;;
|
||||
|
||||
let check_time = Alcotest.check time_testable
|
||||
let check_string = Alcotest.(check string)
|
||||
|
||||
let test_time_of_string _ =
|
||||
let expected = Time.of_string "2016-03-15 19:55:18.123456-04:00" in
|
||||
check_time "without TZ" expected (time_roundtrip "2016-03-15 23:55:18.123456");
|
||||
check_time "zulu" expected (time_roundtrip "2016-03-15 23:55:18.123456Z");
|
||||
check_time "hour TZ" expected (time_roundtrip "2016-03-15 19:55:18.123456-04");
|
||||
check_time "full TZ" expected (time_roundtrip "2016-03-15 19:55:18.123456-04:00")
|
||||
;;
|
||||
|
||||
let test_time_of_string_no_ms _ =
|
||||
let expected = Time.of_string "2016-03-15 19:55:18-04:00" in
|
||||
check_time "without TZ" expected (time_roundtrip "2016-03-15 23:55:18");
|
||||
check_time "zulu" expected (time_roundtrip "2016-03-15 23:55:18Z");
|
||||
check_time "hour TZ" expected (time_roundtrip "2016-03-15 19:55:18-04");
|
||||
check_time "full TZ" expected (time_roundtrip "2016-03-15 19:55:18-04:00")
|
||||
;;
|
||||
|
||||
let test_time_conversion_roundtrip _ =
|
||||
let expected_str = "2016-03-15 23:55:18.123456Z" in
|
||||
check_string "parse-print" expected_str (time_roundtrip expected_str |> printer);
|
||||
let expected_time = Time.of_string expected_str in
|
||||
check_time "print-parse" expected_time (Value.of_time expected_time |> Value.to_time_exn)
|
||||
;;
|
||||
|
||||
let time_tests =
|
||||
[ Alcotest.test_case "test time_of_string" `Quick test_time_of_string
|
||||
; Alcotest.test_case
|
||||
"test time_of_string no milliseconds"
|
||||
`Quick
|
||||
test_time_of_string_no_ms
|
||||
; Alcotest.test_case
|
||||
"test time conversion roundtrip"
|
||||
`Quick
|
||||
test_time_conversion_roundtrip
|
||||
]
|
||||
;;
|
||||
|
||||
let () = Alcotest.run "pgx_async_conversions" [ "time", time_tests ]
|
||||
34
unikernel/duniverse/pgx/pgx_value_ptime.opam
Normal file
34
unikernel/duniverse/pgx/pgx_value_ptime.opam
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
version: "2.2"
|
||||
# This file is generated by dune, edit dune-project instead
|
||||
opam-version: "2.0"
|
||||
synopsis: "Pgx_value converters for Ptime types"
|
||||
description: "Pgx_value converters for Ptime types"
|
||||
maintainer: ["Arena Developers <silver-snakes@arena.io>"]
|
||||
authors: ["Arena Developers <silver-snakes@arena.io>"]
|
||||
license: "LGPL-2.0-only with OCaml-LGPL-linking-exception"
|
||||
homepage: "https://github.com/arenadotio/pgx"
|
||||
doc: "https://arenadotio.github.io/pgx"
|
||||
bug-reports: "https://github.com/arenadotio/pgx/issues"
|
||||
depends: [
|
||||
"dune" {>= "3.2"}
|
||||
"alcotest" {with-test & >= "1.0.0"}
|
||||
"ptime" {>= "0.8.3"}
|
||||
"ocaml" {>= "4.08"}
|
||||
"pgx" {= version}
|
||||
"odoc" {with-doc}
|
||||
]
|
||||
build: [
|
||||
["dune" "subst"] {dev}
|
||||
[
|
||||
"dune"
|
||||
"build"
|
||||
"-p"
|
||||
name
|
||||
"-j"
|
||||
jobs
|
||||
"@install"
|
||||
"@runtest" {with-test}
|
||||
"@doc" {with-doc}
|
||||
]
|
||||
]
|
||||
dev-repo: "git+https://github.com/arenadotio/pgx.git"
|
||||
15
unikernel/duniverse/pgx/pgx_value_ptime/src/dune
Normal file
15
unikernel/duniverse/pgx/pgx_value_ptime/src/dune
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
(* -*- tuareg -*- *)
|
||||
|
||||
let preprocess =
|
||||
match Sys.getenv "BISECT_ENABLE" with
|
||||
| "yes" -> "(preprocess (pps bisect_ppx))"
|
||||
| _ -> ""
|
||||
| exception Not_found -> ""
|
||||
|
||||
let () = Jbuild_plugin.V1.send @@ {|
|
||||
|
||||
(library
|
||||
(public_name pgx_value_ptime)
|
||||
(libraries ptime pgx)
|
||||
|} ^ preprocess ^ {|)
|
||||
|}
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
include Pgx.Value
|
||||
|
||||
let of_date (year, month, day) =
|
||||
Printf.sprintf "%04d-%02d-%02d" year month day |> Pgx.Value.of_string
|
||||
;;
|
||||
|
||||
let to_date' text =
|
||||
match text ^ "T00:00:00Z" |> Ptime.of_rfc3339 with
|
||||
| Result.Ok (t, _, _) -> Ptime.to_date t
|
||||
| _ -> convert_failure "date" text
|
||||
;;
|
||||
|
||||
let to_date_exn v = Pgx.Value.to_string_exn v |> to_date'
|
||||
let to_date v = Pgx.Value.to_string v |> Option.map to_date'
|
||||
|
||||
let of_time ?tz_offset_s t =
|
||||
let tz_offset_s = Option.value tz_offset_s ~default:0 in
|
||||
Ptime.to_rfc3339 ~tz_offset_s ~frac_s:12 t |> Pgx.Value.of_string
|
||||
;;
|
||||
|
||||
let time_of_string text =
|
||||
match Ptime.of_rfc3339 text with
|
||||
| Result.Ok (t, offset, _) -> t, Option.value ~default:0 offset
|
||||
| _ -> convert_failure "time" text
|
||||
;;
|
||||
|
||||
let to_time' text =
|
||||
(*
|
||||
The time string can come in various forms depending on whether the
|
||||
Postgres timestamp used includes the time zone:
|
||||
|
||||
Without timezone
|
||||
2016-06-07 15:37:46
|
||||
2016-06-07 15:37:46.962425
|
||||
|
||||
With timezone
|
||||
2016-06-07 15:37:46-04
|
||||
2016-06-07 15:37:46.962425-04
|
||||
|
||||
For the first one we need to indicate that it's a UTC time by appending
|
||||
a 'Z'. For the second one we need to append the minutes to the timezone.
|
||||
*)
|
||||
let open Re in
|
||||
let tz = seq [ alt [ char '-'; char '+' ]; digit; digit ] in
|
||||
let utctz = seq [ char 'Z'; eol ] |> compile in
|
||||
let localtz = seq [ tz; char ':'; digit; digit; eol ] |> compile in
|
||||
let localtz_no_min = seq [ tz; eol ] |> compile in
|
||||
time_of_string
|
||||
@@
|
||||
match matches utctz text, matches localtz text, matches localtz_no_min text with
|
||||
| [], [], [] -> text ^ "Z"
|
||||
| _, _, [] -> text
|
||||
| [], [], _ -> text ^ ":00"
|
||||
| _ -> convert_failure "time" text
|
||||
;;
|
||||
|
||||
let to_time_exn v = Pgx.Value.to_string_exn v |> to_time'
|
||||
let to_time v = Pgx.Value.to_string v |> Option.map to_time'
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
(** Pgx_value types using Ptime's Date and Time modules
|
||||
|
||||
To use Ptime in utop, first run: #require "ptime";;
|
||||
*)
|
||||
|
||||
type v = Pgx.Value.v [@@deriving compare, sexp_of]
|
||||
type t = Pgx.Value.t [@@deriving compare, sexp_of]
|
||||
|
||||
include module type of Pgx.Value with type v := v and type t := t
|
||||
|
||||
val of_date : Ptime.date -> t
|
||||
val to_date_exn : t -> Ptime.date
|
||||
val to_date : t -> Ptime.date option
|
||||
val of_time : ?tz_offset_s:Ptime.tz_offset_s -> Ptime.t -> t
|
||||
val to_time_exn : t -> Ptime.t * Ptime.tz_offset_s
|
||||
val to_time : t -> (Ptime.t * Ptime.tz_offset_s) option
|
||||
val time_of_string : string -> Ptime.t * Ptime.tz_offset_s
|
||||
4
unikernel/duniverse/pgx/pgx_value_ptime/test/dune
Normal file
4
unikernel/duniverse/pgx/pgx_value_ptime/test/dune
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
(tests
|
||||
(names test_pgx_value_ptime)
|
||||
(package pgx_value_ptime)
|
||||
(libraries alcotest pgx_value_ptime))
|
||||
|
|
@ -0,0 +1,123 @@
|
|||
module Value = Pgx_value_ptime
|
||||
|
||||
(* Show both an human-readable version of the date and the underlying
|
||||
seconds/offset pair for the input datetime.*)
|
||||
let print_time (t, tz_offset_s) =
|
||||
let sec = Ptime.to_float_s t
|
||||
and txt = Ptime.to_rfc3339 t ~tz_offset_s ~frac_s:6 in
|
||||
Printf.sprintf "<%s | Seconds: %f, Offset: %d>" txt sec tz_offset_s
|
||||
;;
|
||||
|
||||
let value_testable =
|
||||
let print_time value =
|
||||
match Pgx.Value.to_string value with
|
||||
| Some text -> text
|
||||
| None -> "<None>"
|
||||
in
|
||||
let formatter ppf value = Format.pp_print_string ppf (print_time value) in
|
||||
Alcotest.testable formatter ( = )
|
||||
;;
|
||||
|
||||
let check_value = Alcotest.check value_testable
|
||||
|
||||
let test_to_date _ =
|
||||
let check_date = Alcotest.(check (triple int int int)) in
|
||||
let value = Pgx.Value.of_string "2021-11-14" in
|
||||
let expected = 2021, 11, 14 in
|
||||
check_date "check date parsing" expected (Value.to_date_exn value);
|
||||
let value = Pgx.Value.of_string "0900-06-13" in
|
||||
let expected = 900, 6, 13 in
|
||||
check_date "check date with leading zeros" expected (Value.to_date_exn value)
|
||||
;;
|
||||
|
||||
let test_of_date _ =
|
||||
let date = 2021, 11, 14 in
|
||||
let expected = Pgx.Value.of_string "2021-11-14" in
|
||||
check_value "check date rendering" expected (Value.of_date date);
|
||||
let date = 900, 6, 13 in
|
||||
let expected = Pgx.Value.of_string "0900-06-13" in
|
||||
check_value "dates with leading zeros render properly" expected (Value.of_date date)
|
||||
;;
|
||||
|
||||
let date_tests =
|
||||
[ Alcotest.test_case "of_date renders a Ptime date to a Pgx Value" `Quick test_of_date
|
||||
; Alcotest.test_case "to_date parses a Pgx Value to a Ptime date" `Quick test_to_date
|
||||
]
|
||||
;;
|
||||
|
||||
(* Show only the human-readable version of the date-time. *)
|
||||
let check_time =
|
||||
let compare_times (t1, o1) (t2, o2) =
|
||||
let tf1 = Ptime.to_float_s t1
|
||||
and tf2 = Ptime.to_float_s t2 in
|
||||
abs_float (tf1 -. tf2) < 1.0e-6 && o1 = o2
|
||||
in
|
||||
let time_testable =
|
||||
Alcotest.testable
|
||||
(fun ppf t -> Format.pp_print_string ppf (print_time t))
|
||||
compare_times
|
||||
in
|
||||
Alcotest.check time_testable
|
||||
;;
|
||||
|
||||
let test_time_of_string _ =
|
||||
let hour = 3600 in
|
||||
let hourf = 3600. in
|
||||
let to_pt x = Ptime.of_float_s x |> Option.value ~default:Ptime.min in
|
||||
check_time
|
||||
"minimum time parses"
|
||||
(Ptime.min, 0)
|
||||
(Value.time_of_string "0000-01-01T00:00:00Z");
|
||||
let pt = to_pt (12. *. hourf) in
|
||||
check_time
|
||||
"time with tz offset parses"
|
||||
(pt, ~-4 * hour)
|
||||
(Value.time_of_string "1970-01-01T08:00:00-04:00");
|
||||
let pt = to_pt ((12. *. hourf) +. 0.12345) in
|
||||
check_time
|
||||
"a time with milliseconds parses"
|
||||
(pt, 0)
|
||||
(Value.time_of_string "1970-01-01T12:00:00.12345Z");
|
||||
(* On linux, one can run "TZ='UTC' date -d @1458086118" in a shell to confirm this conversion is correct.*)
|
||||
check_time
|
||||
"a recent time parses"
|
||||
(to_pt 1458086118., ~-4 * hour)
|
||||
(Value.time_of_string "2016-03-15 19:55:18-04:00")
|
||||
;;
|
||||
|
||||
let time_roundtrip str = Value.of_string str |> Value.to_time_exn
|
||||
|
||||
let test_time_tz_handling _ =
|
||||
let utc_t, tz_offset_s = Value.time_of_string "2016-03-15 19:55:18-04:00" in
|
||||
check_time "without TZ" (utc_t, 0) (time_roundtrip "2016-03-15 23:55:18");
|
||||
check_time "zulu" (utc_t, 0) (time_roundtrip "2016-03-15 23:55:18Z");
|
||||
check_time "hour TZ" (utc_t, tz_offset_s) (time_roundtrip "2016-03-15 19:55:18-04");
|
||||
check_time "full TZ" (utc_t, tz_offset_s) (time_roundtrip "2016-03-15 19:55:18-04:00")
|
||||
;;
|
||||
|
||||
let test_time_conversion_roundtrip _ =
|
||||
let print_time (t, tz_offset_s) = Ptime.to_rfc3339 t ~tz_offset_s ~frac_s:6 in
|
||||
let expected_str = "2016-03-15T23:55:18.123456Z" in
|
||||
Alcotest.(check string)
|
||||
"parse-print"
|
||||
expected_str
|
||||
(time_roundtrip expected_str |> print_time);
|
||||
let t, tz_offset_s = Value.time_of_string expected_str in
|
||||
let actual = Value.of_time t ~tz_offset_s |> Value.to_time_exn in
|
||||
check_time "print-parse" (t, tz_offset_s) actual
|
||||
;;
|
||||
|
||||
let time_tests =
|
||||
[ Alcotest.test_case "test time_of_string" `Quick test_time_of_string
|
||||
; Alcotest.test_case
|
||||
"test time_of_string time zone handling"
|
||||
`Quick
|
||||
test_time_tz_handling
|
||||
; Alcotest.test_case
|
||||
"test time conversion roundtrip"
|
||||
`Quick
|
||||
test_time_conversion_roundtrip
|
||||
]
|
||||
;;
|
||||
|
||||
let () = Alcotest.run "pgx_async_conversions" [ "date", date_tests; "time", time_tests ]
|
||||
4
unikernel/duniverse/pgx/pin_dev.sh
Executable file
4
unikernel/duniverse/pgx/pin_dev.sh
Executable file
|
|
@ -0,0 +1,4 @@
|
|||
#!/bin/bash
|
||||
for p in *.opam; do
|
||||
opam pin add -y -n ${p%.opam}.~dev .
|
||||
done
|
||||
1
unikernel/duniverse/pgx/unikernel/.ocamlformat
Normal file
1
unikernel/duniverse/pgx/unikernel/.ocamlformat
Normal file
|
|
@ -0,0 +1 @@
|
|||
profile=janestreet
|
||||
28
unikernel/duniverse/pgx/unikernel/README.md
Normal file
28
unikernel/duniverse/pgx/unikernel/README.md
Normal file
|
|
@ -0,0 +1,28 @@
|
|||
# Using pgx on mirage
|
||||
|
||||
### Network setup
|
||||
|
||||
Assuming one is using linux. The following steps are needed to setup networking for the mirage unikernel.
|
||||
|
||||
```
|
||||
ip tuntap add tap100 mode tap
|
||||
ip addr add 10.0.0.1/24 dev tap100
|
||||
ip link set dev tap100 up
|
||||
|
||||
echo 1 > /proc/sys/net/ipv4/ip_forward # enables IP forwarding
|
||||
|
||||
# assuming "eth0" is your default network interface where all the traffic goes to the Internet.
|
||||
iptables -t nat -A POSTROUTING -o eth0 -j MASQUERADE
|
||||
iptables -A FORWARD -i eth0 -o tap100 -m state --state RELATED,ESTABLISHED -j ACCEPT
|
||||
iptables -A FORWARD -i tap100 -o eth0 -j ACCEPT
|
||||
```
|
||||
|
||||
### Building and running the unikernel
|
||||
|
||||
```
|
||||
opam install mirage
|
||||
mirage configure -t hvt # replace hvt with spt/unix/xen etc
|
||||
make depends
|
||||
make
|
||||
solo5-hvt --net:service=tap100 -- pgx_unikernel.hvt --pgpassword <password> --pguser <postgres user> --pghost <hostname for the postgres database> --pgport <port that the database is running on> --pgdatabase <database name to use> # The --pgdatabase flag is optional, but make sure to create the database before trying to run the example
|
||||
```
|
||||
63
unikernel/duniverse/pgx/unikernel/config.ml
Normal file
63
unikernel/duniverse/pgx/unikernel/config.ml
Normal file
|
|
@ -0,0 +1,63 @@
|
|||
open Mirage
|
||||
|
||||
let packages =
|
||||
[ package "pgx" ~pin:"file://../"
|
||||
; package "pgx_lwt" ~pin:"file://../"
|
||||
; package "pgx_lwt_mirage" ~pin:"file://../"
|
||||
; package "logs"
|
||||
; package "mirage-logs"
|
||||
]
|
||||
;;
|
||||
|
||||
let stack = generic_stackv4v6 default_network
|
||||
|
||||
let database =
|
||||
let doc = Key.Arg.info ~doc:"database to use" [ "db"; "pgdatabase" ] in
|
||||
Key.(create "pgdatabase" Arg.(opt string "postgres" doc))
|
||||
;;
|
||||
|
||||
let port =
|
||||
let doc = Key.Arg.info ~doc:"port to use for postgresql" [ "p"; "pgport" ] in
|
||||
Key.(create "pgport" Arg.(opt int 5432 doc))
|
||||
;;
|
||||
|
||||
let hostname =
|
||||
let doc = Key.Arg.info ~doc:"host for postgres database" [ "h"; "pghost" ] in
|
||||
Key.(create "pghost" Arg.(opt string "127.0.0.1" doc))
|
||||
;;
|
||||
|
||||
let user =
|
||||
let doc = Key.Arg.info ~doc:"postgres user" [ "u"; "pguser" ] in
|
||||
Key.(create "pguser" Arg.(required string doc))
|
||||
;;
|
||||
|
||||
let password =
|
||||
let doc = Key.Arg.info ~doc:"postgres password" [ "pgpassword" ] in
|
||||
Key.(create "pgpassword" Arg.(required string doc))
|
||||
;;
|
||||
|
||||
let server =
|
||||
foreign
|
||||
"Unikernel.Make"
|
||||
~keys:
|
||||
[ Key.abstract port
|
||||
; Key.abstract hostname
|
||||
; Key.abstract user
|
||||
; Key.abstract password
|
||||
; Key.abstract database
|
||||
]
|
||||
~packages
|
||||
(random @-> time @-> pclock @-> mclock @-> stackv4v6 @-> job)
|
||||
;;
|
||||
|
||||
let () =
|
||||
register
|
||||
"pgx_unikernel"
|
||||
[ server
|
||||
$ default_random
|
||||
$ default_time
|
||||
$ default_posix_clock
|
||||
$ default_monotonic_clock
|
||||
$ stack
|
||||
]
|
||||
;;
|
||||
75
unikernel/duniverse/pgx/unikernel/unikernel.ml
Normal file
75
unikernel/duniverse/pgx/unikernel/unikernel.ml
Normal file
|
|
@ -0,0 +1,75 @@
|
|||
open Lwt.Infix
|
||||
|
||||
module Make
|
||||
(RANDOM : Mirage_random.S)
|
||||
(TIME : Mirage_time.S)
|
||||
(PCLOCK : Mirage_clock.PCLOCK)
|
||||
(MCLOCK : Mirage_clock.MCLOCK)
|
||||
(STACK : Tcpip.Stack.V4V6) =
|
||||
struct
|
||||
module Pgx_mirage = Pgx_lwt_mirage.Make (RANDOM) (TIME) (MCLOCK) (PCLOCK) (STACK)
|
||||
module Logs_reporter = Mirage_logs.Make (PCLOCK)
|
||||
|
||||
type user =
|
||||
{ id : int
|
||||
; email : string
|
||||
}
|
||||
|
||||
let emails = [ "foo@test.com"; "bar@foo.com"; "hello@test.net" ]
|
||||
|
||||
let setup_database ~port ~user ~host ~password ~database pgx () =
|
||||
Logs.info (fun m -> m "setting up database");
|
||||
let module P = (val pgx : Pgx_lwt.S) in
|
||||
P.with_conn ~user ~host ~password ~port ~database (fun conn ->
|
||||
P.execute_unit
|
||||
conn
|
||||
"CREATE TABLE IF NOT EXISTS users( id SERIAL PRIMARY KEY, email VARCHAR(40) \
|
||||
NOT NULL UNIQUE );"
|
||||
>>= fun () ->
|
||||
let params = List.map (fun email -> Pgx.Value.[ of_string email ]) emails in
|
||||
P.execute_many
|
||||
conn
|
||||
~params
|
||||
~query:"INSERT INTO USERS (email) VALUES ($1) ON CONFLICT (email) DO NOTHING"
|
||||
>>= fun rows ->
|
||||
Logs.info (fun m -> m "Inserted %d rows" (List.length rows));
|
||||
Lwt.return_unit)
|
||||
;;
|
||||
|
||||
let get_users ~port ~user ~host ~password ~database pgx () =
|
||||
Logs.info (fun m -> m "Fetching users");
|
||||
let module P = (val pgx : Pgx_lwt.S) in
|
||||
P.with_conn ~user ~host ~password ~port ~database (fun conn ->
|
||||
P.execute conn "SELECT * FROM USERS"
|
||||
>|= fun rows ->
|
||||
List.map
|
||||
(fun row ->
|
||||
match row with
|
||||
| [ id; email ] ->
|
||||
{ id = Pgx.Value.to_int_exn id; email = Pgx.Value.to_string_exn email }
|
||||
| _ -> failwith "invalid data")
|
||||
rows)
|
||||
;;
|
||||
|
||||
let print_users users =
|
||||
users
|
||||
>|= fun users ->
|
||||
List.iter
|
||||
(fun { id; email } -> Logs.info (fun m -> m "{id = %d; email = %s}\n" id email))
|
||||
users
|
||||
;;
|
||||
|
||||
let start _random _time _pclock _mclock stack =
|
||||
Logs.(set_level (Some Info));
|
||||
Logs_reporter.(create () |> run)
|
||||
@@ fun () ->
|
||||
let port = Key_gen.pgport () in
|
||||
let host = Key_gen.pghost () in
|
||||
let user = Key_gen.pguser () in
|
||||
let password = Key_gen.pgpassword () in
|
||||
let database = Key_gen.pgdatabase () in
|
||||
let pgx = Pgx_mirage.connect stack in
|
||||
setup_database ~port ~host ~user ~password ~database pgx ()
|
||||
>>= fun () -> print_users (get_users ~port ~host ~user ~password ~database pgx ())
|
||||
;;
|
||||
end
|
||||
Loading…
Add table
Add a link
Reference in a new issue