swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Browse source
This commit is contained in:
swrup 2025-11-11 02:07:51 +01:00
parent aa2ff7b2f0
commit 2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

48
unikernel/duniverse/ocaml-caqti/.circleci/config.yml Normal file
View file

@ -0,0 +1,48 @@
version: 2
jobs:
build:
branches:
ignore:
- deploy-doc
- gh-pages
docker:
- image: ocaml/opam:debian-ocaml-5.1
environment:
TERM: xterm
- image: cimg/postgres:14.1
environment:
POSTGRES_USER: test
POSTGRES_DB: test
POSTGRES_PASSWORD: ""
steps:
- checkout
- run:
name: Pin packages
command: |
version=`egrep '^## v[0-9]' CHANGES.md | head -1 | sed 's/^## v\(.*\) - .*/\1/'`
for f in *.opam; do
# FIXME: Restore when packages becomes available.
if [ "$f" != caqti-driver-mariadb.opam ]; then
echo >>.ci-tmp-packages "${f%.opam}"
opam pin add -yn "${f%.opam}.${version}.dev" .
fi
done
- run:
name: Install system dependencies
command: |
opam depext -y $(cat .ci-tmp-packages)
- run:
name: Install OCaml dependencies
command: opam install --deps-only -ty $(cat .ci-tmp-packages)
- run:
name: Build
command: opam config exec -- dune build @install
- run:
name: Test
command: |
echo "
sqlite3:test.db?busy_timeout=60000
postgresql://test@localhost/test
" > testsuite/uris.conf
opam config exec -- dune runtest

43
unikernel/duniverse/ocaml-caqti/.github/workflows/docs.yml vendored Normal file
View file

@ -0,0 +1,43 @@
name: Deploy API Documentation
on:
push:
branches:
- deploy-doc
jobs:
deploy-doc:
runs-on: ubuntu-latest
steps:
- name: Checkout code
uses: actions/checkout@v2
- name: Use OCaml 4.13.x
uses: ocaml/setup-ocaml@v2
with:
ocaml-compiler: 4.13.x
dune-cache: true
opam-pin: false
opam-depext: false
- name: Pin packages
run: |
version=`egrep '^## v[0-9]' CHANGES.md | head -1 | sed 's/^## v\(.*\) - .*/\1/'`
for f in *.opam; do
opam pin add -yn "${f%.opam}.${version}" .
done
shell: bash
- name: Install system dependencies
run: |
opam depext -y --with-doc $(ls -1 *.opam | sed -e 's/\.opam$//')
sudo apt-get install -y libmariadb-dev
shell: bash
- name: Install OCaml dependencies
run: opam install --deps-only -y --with-doc $(ls -1 *.opam | sed -e 's/\.opam$//')
shell: bash
- name: Deploy odoc to GitHub Pages
uses: ocaml/setup-ocaml/deploy-doc@v2

19
unikernel/duniverse/ocaml-caqti/.gitignore vendored Normal file
View file

@ -0,0 +1,19 @@
.merlin
/_build
/_test.db
/caqti.install
/caqti-async.install
/caqti-driver-*.install
/caqti-dynload.install
/caqti-lwt.install
/caqti-mirage/unikernel/Makefile
/caqti-mirage/unikernel/_build
/caqti-mirage/unikernel/dist
/caqti-mirage/unikernel/dune
/caqti-mirage/unikernel/dune-project
/caqti-mirage/unikernel/dune-workspace
/caqti-mirage/unikernel/dune.build
/caqti-mirage/unikernel/dune.config
/caqti-mirage/unikernel/mirage
/caqti-type-*.install
/testsuite/uris.conf

631
unikernel/duniverse/ocaml-caqti/CHANGES.md Normal file
View file

@ -0,0 +1,631 @@
## v2.2.4 - 2025-03-28
- Remove Stdlib qualification from caqti.blocking to restore compatibility
with OCaml 4.
## v2.2.3 - 2025-03-28
- Make the pool implementation shared-memory safe.
## v2.2.2 - 2025-03-25
- Fix one test and comment out a failing assertion in another test, the
latter awaiting solution to #126.
## v2.2.1 - 2025-03-21
A few minor fixes discovered while making the 2.2.0 release:
- Restored compatibility with OCaml before 5.1 in a test code.
- Make it clear in the documentation that caqti.template is a preview.
- Fixed version constraint for lru.
## v2.2.0 - 2025-03-20
Improvements:
- The sqlite3 driver now supports the refined error causes
(`Caqti_error.cause`) for integrity constraint violations.
- There is now experimental support for Miou (#117 by Calascibetta
Romain).
- The new library `caqti.template` provides a preview of a interface for
creating and working with request templates, with a few new features
and, I think, a tidier design. This is not yet suitable for production
code, since it will change before the final version. Feedback is
welcome.
Fixes:
- Fixed a memory leak in the fall-back implementation of the `populate`
connection method which affects all except the postgresql drivers.
Deprecations:
- `Caqti_request.query_id` is deprecated and will be removed.
- Constructors of `Caqti_type.t` are now fully private and will be moved
away and likely defined differently in the next major release.
Dependency updates:
- Prepare for upcoming mirage (#124 by Hannes Mehnert).
The following packages are updated in this release: caqti, caqti-lwt,
caqti-miou, caqti-mirage, and all drivers.
## v2.1.2 - 2024-09-04
Fixes:
- Improve error reporting when failing to load a driver (#115).
- Fix validation of dead connection in postgresql driver (#119 by Sam
Tombury).
- Tolerate exceptions from pool resource allocators (#116 reported by Ryan
Moore).
- Fix install script for the caqti.opam package to work with caqti.plugin.
- Fix the announced license exception in the caqti-driver-pgx package.
Dependency updates:
- Update to `tls` >= 1.0.0 for caqti-mirage (#120 by Hannes Mehnert).
- Update tls-eio to >= 0.17.4 for caqti-tls-eio (to eliminate a hack).
- Update `async_kernel` to >= v0.17.0 and `tcpip` to >= 8.1.0 (due to
resolving deprecations for future compatibility).
## v2.1.1 - 2024-02-19
This minor update fixes running of the test suite and packaging issues.
## v2.1.0 - 2024-02-19
This release has been replaced by 2.1.1.
- There is now TLS support for PGX. The networking code (for PGX) was
revised in the process, in particular the EIO variant is now buffered,
which improves performance. TLS implementations are shipped as separate
packages (`caqti-tls*`) but `caqti-tls-async`, `caqti-tls-eio`, and
`caqti-tls-lwt` should be considered experimental and will be omitted
from the OPAM release for now. On the other hand, `caqti-mirage` now
ships with built-in TLS support for PGX.
- Connect functions now accept an optional configuration. For the time
being, this is used for TLS parameters and for the optional
`tweaks_version` argument, which is still available for backwards
compatibility.
- The newly introduced `Caqti_query.qprintf` and associated formatters
have been moved to a separate module `Caqti_query_fmt` (#108), to limit
clashes when used in local open, and since the formatters were nominally
underqualified.
- Constants of any field type can now be embedded in queries using the new
`Caqti_query.V` constructor and associated shortcuts. This allows
taking advantage of driver-specific encoders, e.g. to correctly convert
a `Ptime.Span.t` to the representation expected by the target database
system.
- Equality with type unification evidence is now available for
`Caqti_type.t` and `Caqti_type.Field.t`. The equality type introduced
for the purpose is compatible with `Type.eq` from OCaml 5.1, but will
not be aliased yet. This required a backwards incompatible adjustment
of the `Caqti_type.Product` constructor.
- Added tuples type constructors with arity up to 12.
- Added multi-statement parser (`Caqti_query.angstrom_list_parser`)
intended for loading SQL schema files.
- The new `caqti.plugin` sublibrary is a drop-in replacement for the
`caqti-dynload` package. It is based on the `dune-site.plugin` library.
Please try it and report back if there are issues.
- Some updates to external dependencies, esp. we are now at EIO 0.12+.
- Fixed lacking details in error messages related to driver load failures.
- Fixed uncaught exceptions for PGX (#113).
## v2.0.1 - 2023-08-14
Fixes:
- Upgrade Eio to 0.11.
- Update README and make a note about caqti-eio and caqti-mirage being
experimental.
- Fix build and packaging issues.
This release was sponsored by the OCaml Software Foundation.
## v2.0.0 - 2023-08-10
New features:
- Added driver based on the pure-OCaml PGX library (#38). However, due to
lack of TLS support it is not suitable for production, unless you have a
dedicated secure network.
- Added support for MirageOS. This only works for the PGX driver, since
the other drivers link against external C libraries.
- Added experimental support for Eio, both pure-OCaml and Unix. The
former supports PGX while the latter supports all drivers.
- Implemented single-row mode for PostgreSQL (#24), but while this avoids
uncontrolled memory consumption when a large number of rows is returned,
it is a lot less efficient.
- A new pool connection parameter `?max_idle_age` provides removal
resources from pools which have been unused for the given period.
- Printf-style function `Caqti_query.qprintf` for dynamic queries
(GPR#103, Basile Clément).
- Added general-purpose product type to provide functionality covering
both product and custom types.
- Added new tuple types `t3`, ..., `t8` based on the new product type and
deprecated `tup2`, `tup3`, `tup4` which are now aliases for these.
Breaking changes:
- The minimal OCaml requirement is now 4.08.0.
- The connection functions previously found in `caqti-lwt` has been moved
into a sublibrary `caqti-lwt.unix` as part of the addition of
`caqti-mirage`, whereas shared functionality remains in `caqti-lwt`.
The LWT connection function is therefore now found in `Caqti_lwt_unix`.
- Removed all deprecated functionality and a few unintended or
undocumented definitions like the type `Caqti_blocking.future` and
`Caqti_driver_info.describe_has_typed_*`.
- Reworked the driver API to accommodate the addition of the PGX driver
and MirageOS and Eio support, and to avoid exposting internal interfaces
in the main library. These modules are now found in the sublibraries
`caqti.platform` and `caqti.platform.unix`, depending on their external
depnedencies. They are not meant for use by applications, though this
might not have fully clear previously.
- Removed constructors Custom, Unit, Tup2, Tup3, Tup4 from `Caqti_type.t`.
They were private but could in prinicle be matched against.
- The extensibility of `Caqti_type.Field.t` has been dropped along with
the associated functions for registering conversions. This means that
there are no custom field types any more, only custom row types. The
purpose of custom field types where to support non-standard types for
3rd party drivers; we should coordinate additions to the core type
instead if needed.
- According to the above point, the `caqti-type-calendar` is reimplemented
as a row type, which means the `Cdate` and `Ctime` constructors are
gone.
- There are adjustments for the pretty printer for types. (The context is
assumed to start at the lowest precedence, meaning parentheses around
lowest-precedence expressions are dropped. Also, `redacted` is shown
with suffix notation, allowing us to remove one precedence level.)
- Moved pool tuning parameters into a configuration object.
Fixes:
- Fixed a missing `Preemptive.detach` call for `to_stream` for Sqlite3.
- Incorrect error reporting related to type conversions were discovered by
exhaustiveness checks when making field types non-extensible.
Other:
- The documentation of `call` now makes clear that the result *must* be
retrieved in order to make sure the request is performed. This is made
relevant by the addition of the PGX driver where request and retrieval
are fused.
- Customized the top-level index and some other documentation work.
Removal of private modules from the main library should also help to
make the documentation more accessible.
- Added a benchmark to measure row decoding performance.
- Improved decoding performance by partially applying the type descriptor.
This release was sponsored by the OCaml Software Foundation.
## v1.9.1 - 2022-09-21
This release only updates the caqti-driver-postgresql package, with the
following fixes:
- PostgreSQL expects "=" in query values to be URI-encoded (#95).
- The validation logic for PostgreSQL was missing a call to consume
available input, meaning that broken pooled connections were reused.
This release was sponsored by the OCaml Software Foundation.
## v1.9.0 - 2022-09-06
New features:
- Allow unquoted semicolons in query strings in the new API. There are
corner cases where it is needed, as reported in issue #87, and a parser
which rejects semicolons are still available for loading schema files
statement by statement.
- Add support for MySQL and MariaDB configuration files, as a solution to
issue #86.
- Add a limit to the number of times a database connection is reused when
pooling connections (#94). Thanks to Peter Mondlock for investigating
resource usage server side motivating this addition.
- Provide access to the raw SQLite3 connection handle for the purpose of
defining custom functions (#56).
Fixes:
- Add missing dune dependency on unix (GPR#85 by David Allsopp).
- Documentation fixes (GPR#82, GPR#83, GPR#84 by Reynir Björnsson,
GPR#88 by Jonathan Duarte, and GPR#92 by Jim Tittsler).
Deprecations:
- `Caqti_type.field` was deprecated in favour of `Caqti_type.Field.t`.
Other:
- Replace deprecated core\_kernel dependency with core.
This release was sponsored by the OCaml Software Foundation.
## v1.8.0 - 2022-03-24
New features:
- A matchable representation of common causes of errors on the database
side is now available, with limitations. It focuses on conditions which
seem most likely useful to handle. At the moment we lack extended error
codes from SQLite3 needed to make the cause fully precise.
- Expose the underlying error details from database client libraries.
This is meant to be use as a last resort, and requires directly linking
with the relevant drivers.
- A second set of request construction operators `->.`, `->?`, `->!`, and
`->*` were introduced after experience with converting existing code.
Given the parameter and result type they return a function which
constructs a request directly from a query string. Avoiding the need to
compose with `@:-` simplifies local opens and usage with `List.map` etc.
- Environment variables are now expanded in the debug log when using the
new request constructors introduced in 1.7.0.
- A new `?tweaks_version` connection parameter has been added to control
when the client is ready to adapt to changes in database session
parameters or other adjustments of the interaction with specific
database systems.
- Enable foreign key constraint checks for SQLite3 starting at tweaks
version 1.8.
Fixes:
- Fixed debug logging to pass the correct driver info to the query
callback instead of a dummy driver info which would cause a failure if
unsupported.
Deprecations:
- The `-->` operator was renamed to `-->!`, with a deprecated alias, for
consistency with the new `->!` operator.
- The old convenience interface for creating requests has been deprecated
in favour of the new infix operators and the new query template parser.
- Documented-only deprecations of `Caqti_sql_io`, `Caqti_lwt_sql_io`, and
`Caqti_async_sql_io` have been annotated.
This release was sponsored by the OCaml Software Foundation.
## v1.7.0 - 2022-02-13
New features:
- Added a new query-string parser based on Angstrom. Its main advantage
is that it can be used stand-alone e.g. to load SQL schemas from files
split into individual statements which can be sent to the database.
- Support passing a query environment to the connect and pool construction
functions. This avoids using globals to modify the environment and
facilitates e.g. targeting different database schemas with different
connetions or connection pools.
- A new `Caqti_query.E` case was added to support the two above cases.
This is a breaking change, but hopefully does not break existing code.
The exception (not counting `module type of`) would be if the
constructors are aliased along with an alias of the type. On the other
hand, pattern matching should be compatible since the new constructor is
only emitted by newly introduced functions.
- Added a module `Caqti_request.Infix` providing a new high-level API for
constructing requests. It uses two-stage combinators, first to apply
type arguments then to apply the query string. Apart from allowing
nicer looking code, this solves the problem of switching to a the query
string parser while maintaining backwards compatibility.
- Added `set_statement_timeout` to connection modules, used to set query
timeout. It is only supported for PostgreSQL and MariaDB. (#74)
- Added `with_transaction` function to connection modules. This is just
fail-safed wrapper around `start`, `commit`, and `rollback`.
Fixes:
- Fixed delayed recovery of connection pools after loosing connections to
PostgreSQL. Due to a missing call to consume inputs, the pool validator
did not discover that a connection was lost before it was attempted
reused.
- Improved resilience against exceptions and monadic errors in callbacks
and fixed in-use checking.
- Changed Sqlite3 driver to use non-linear parameters and improve error
reporting when the wrong number of arguments are received (#77 & GPR#79
Reynir Björnsson).
Other changes:
- The Caqti license now uses the LGPL-3.0 Linking Exception instead of a
rephrasing of the OCaml LGPL Linking Exception which was written for
LGPL-2.1.
- Improved documentation, pretty-printing, logging, and exception details.
- The test suite has been switched to use Alcotest; not without some
struggle due to the use of test harness and argument-dependent test
suite, but the result seems like a clear improvement.
This release was sponsored by the OCaml Software Foundation.
## v1.6.0 - 2021-06-10
- Set the time zone of PostgreSQL connections to UTC to mitigate an
undesirable implicit conversion to the local time zone for `timestamp`.
This issue was exposed by the specification of field types introduced in
version 1.4.0. Earlier versions worked as expected, if only accidentally,
since the time zone is ignored when a string is converted to a
`timestamp`. While this change makes `timestamp` more usable again for
storing UTC time stamps, I strongly recommend using `timestamp with time
zone` since it's interpretation is unambiguous. The API reference is now
updated with details about how the `ptime` OCaml type is mapped for
different database systems.
- Drop specification of OCaml `string` as SQL `text` for PostgreSQL. This is
due to issues with implicit conversions and function overloading when the
desired type on the SQL side is `char`, `varchar`, or `jsonb`.
- Add `Caqti_type.redact` to protect sensitive information from being
logged.
- Only log parameters if `$CAQTI_DEBUG_PARAM` is set to "`true`".
- When logging requests, show underlying values for custom types.
- Reject multi-row response in `find_opt` implementation for sqlite3.
- Tolerate Lwt promise rejections in `Pool.use`.
## v1.5.1 - 2021-04-18
- Fix option recognition in PostgreSQL driver (GPR#67 mefyl).
- Fix option recognition in MariaDB driver and add test (Petter A. Urkedal).
## v1.5.0 - 2021-04-11
- Request the full UTF-8 character for the MariaDB connection.
- Support int16 and enum types for parameters and rows.
## v1.4.0 - 2021-03-11
- Fix infinite loop when deserializing an optional tuple (GPR#63 mefyl).
- Add `Caqti_connect_sig.S.with_connection` (GPR#61 Anton Bachin).
- Pass parameter types to PostgreSQL prepare and query functions. This
avoids the need to CAST parameters on the SQL side in some cases.
- Add `?post_connect` callback to `connect_pool`.
- Documentation fixes and improvements (Aaron L. Zeng, Anton Bachin, Petter
A. Urkedal).
## v1.3.0 - 2021-01-17
- Implement `affected_count` for sqlite backend (GPR#46 jakob).
- Add method `exec_with_affected_count` to `Caqti_connection_sig.S` (GPR#45
jakob).
- Add `?max_idle_size` to pool creation functions.
- Dropped dependency on `ppx_deriving` due to issue with static compilation
(GPR#50 Ulrik Strid).
- Pass through `$<var>$` in query strings and deprecate `$$`.
- Log statements to be executed at debug level.
- Add COPYING.OCAML and fix license expression in opam files.
- Misc improvements to tests and documentation (GPR#51 Philippe Wang, GPR#54
Reynir Björnsson, etc.).
## v1.2.4 - 2020-06-07
- Switch to TEXT format for PostgreSQL populate implementation.
## v1.2.3 - 2020-06-02
- Silence PostgreSQL notifications which were printed to stderr. They can
be re-enabled with a parameter on the connection URI (#33).
- Improve details in exceptions in two places.
- Fix info about connection caching for sqlite in README (#35, dgllghr).
## v1.2.2 - 2019-12-19
- Update for core v0.13 (GPR#31 Xavier Clerc).
## v1.2.1 - 2019-12-08
- Support TEXT literals in queries.
- Fix decoding of binary results for PostgreSQL (thanks to James Owen).
- Implement copy-mode for PostgreSQL (GPR#30 James Owen).
## v1.2.0 - 2019-10-02
- Add a signature for the populate function, and add basic implementations
for all drivers (GPR#28).
- Add stream for result extraction (GPR#22 Nathan Rebours).
- Use the postgres driver when `postgres` is specified as the URL scheme
(GPR#25 James Owen).
- Documentation improvements (GPR#20 Nathan Rebours, etc.).
- Reimplemented partly ineffective prepare-cache for PostgreSQL.
- Backwards incompatible changes to the driver API.
- Backwards incompatible changes to modules marked internal but exposed due
to being split across packages.
- Fix forward compatibility past OCaml 4.08 as announced by deprecations.
## v1.1.0 - 2019-02-03
- Add pretty printer for requests.
- Add variance to `'a future` declarations.
- Add blocking instance of API.
- Generalize `$.` to `$<var>.` in queries.
- Infer the expansion of `$(<var>.)` from `$(<var>)` if not provided.
- Fix connection recovery for PostgreSQL (issue #19, Dave Aitken).
- Fix some unhandled exceptions for PostgreSQL.
- Fix connection validation for MariaDB.
## v1.0.0 - 2018-08-26
- Added `Caqti_type.Std : Caqti_type_sig.Std`, containing type descriptors
needed for building requests, for easy inclusion in custom modules.
- Fix ptime to string conversion for PostgreSQL (monstasat).
- Support microsecond precision for MariaDB.
- Removed `Caqti_type.Field.ex` and renamed `Caqti_type.ex` to
`Caqti_type.any` and related functions.
- Removed other deprecated definitions.
- Moved `Caqti_system_sig` into `Caqti_driver` and split up the signature to
make room for future drivers on alternative platforms.
## v0.11.0 - 2018-05-25
Added and improved:
- Compliance with Lwt 4.0 contributed by Brendan Long.
- Switched to the logs library for logging.
- Strengthen detection of concurrent use of connection.
- Support microsecond precision for timestamps for PostgreSQL and
millisecond for Sqlite3.
- Use float for time spans in Sqlite3.
- Map the `octets` type to BLOBs for MariaDB and Sqlite3.
- Log recoverable errors for MariaDB and Sqlite3.
Removed:
- The v1 API is now removed.
Ecosystem:
- CI setup contributed by Brendan Long.
- Various documentation updates.
## v0.10.2 - 2018-04-05
- Fix incompatibility with `ppx_optcomp` v0.11.0 by dropping it, since the
conditionals where no longer needed.
- Restore test during opam build.
- The v1 API is now fully `[@@@deprecated]` and will be removed in the next
major release.
## v0.10.1 - 2018-02-27
- Fix a pool size counting bug when resource allocation fails. This can
cause deadlock due to pool exhaustion.
## v0.10.0 - 2018-02-14
- Added `-linkall` flags to driver libraries to fix direct linking (#9).
- Added convenience functions `collect_list` and `rev_collect_list` (#8).
- Renamed `template` to `query` and related function, leaving deprecated
aliases.
- Added `ptime_span` field type mapping to SQL intervals.
- Be more permissive about types of data returned from MariaDB when
expecting numerical results.
## v0.9.0 - 2018-01-04
- Move v1 into findlib sublibraries and announce deprecation.
- Port remaining tests to v2 and fix issues in MariaDB and Sqlite3 drivers.
- Don't include password component of URIs in error messages.
- Rename `io` type constructor to `future`.
- Fix pool size limit enforcement.
- Drop error on disconnect.
- Support substitutions in request convenience functions.
## v0.8.1 - 2017-12-06
- Fix `start` transaction for PostgreSQL v2.
- Fix dependency on ptime in `caqti.opam` in distribution.
## v0.8.0 - 2017-12-04
- Remove most deprecations.
- Add new v2 API.
- Move away most of the v1 API, but keep deprecated aliases for the client
API.
The main difference of the new API compared to the old is:
- It uses typed parameters and rows with an extensible variant for field
type and a custom definable compound type.
- The connection has a `call` method which gives access to a result object
before iterating over the returned rows.
- Error handling is done with the `result` type, using a collection of error
types formed as polymorphic variants of records.
*Notice:* This version is mostly backwards compatible. New code should use
v2, but v1 will be kept for now. To keep using the v1 in upcoming releases:
- Fix the new deprecations from this release.
- Link with `caqti-dynload` to keep using dynamic loading, or link with the
needed `caqti-driver-*.v1` driver libraries.
- Link with `caqti.v1` instead of `caqti`.
- Link with `caqti-lwt.v1` instead of `caqti-lwt`.
- Link with `caqti-async.v1` instead of `caqti-async`.
## v0.7.0 - 2017-11-03
- Remove WRAPPER and REPORT functionality.
- Remove deprecated findlib aliases.
- Renamed `date` and `utc` conversions to `date_cl` and `utc_cl`.
- Deprecate `Caqti_metadata` in favour of the new `Caqti_driver_info`.
- Move various signature to separate files, leaving deprecated aliases.
## v0.6.1 - 2017-10-26
- Fixed support for lwt >= 3, but keep supporting 2.7 as well for now.
- Fixed preparation of query after reconnect to PostgreSQL.
- Fixed support for ocaml 4.03.x.
- Added `Tuple.length`.
- Deprecated `Param.sub_types`.
- Deprecated `Param.other` and `Tuple.other`.
## v0.6.0 - 2017-06-05
- Split into separate packages to avoid depopts and rename findlib names
accordingly.
- Use findlib to load DB drivers, and use `-linkall`. This hopefully solves
loading issues.
## v0.5.3 - 2017-05-22
- Fix handling of spaces in Sqlite3 URIs and allow setting mode.
- Split `Caqti` (now deprecated) into `Caqti_errors` and `Caqti_connect`.
- Update to async 0.9.0.
## v0.5.2 - 2017-02-25
- Fix plugin loader to handle modernised `META`.
## v0.5.1 - 2017-02-25 retracted
- Rename libraries to match `META`.
## v0.5.0 - 2017-02-25 retracted
- Added MariaDB backend.
- Fixed VARCHAR for SQLite3 describe.

674
unikernel/duniverse/ocaml-caqti/COPYING Normal file
View file

@ -0,0 +1,674 @@
GNU GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
The GNU General Public License is a free, copyleft license for
software and other kinds of works.
The licenses for most software and other practical works are designed
to take away your freedom to share and change the works. By contrast,
the GNU General Public License is intended to guarantee your freedom to
share and change all versions of a program--to make sure it remains free
software for all its users. We, the Free Software Foundation, use the
GNU General Public License for most of our software; it applies also to
any other work released this way by its authors. You can apply it to
your programs, too.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
them 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 prevent others from denying you
these rights or asking you to surrender the rights. Therefore, you have
certain responsibilities if you distribute copies of the software, or if
you modify it: responsibilities to respect the freedom of others.
For example, if you distribute copies of such a program, whether
gratis or for a fee, you must pass on to the recipients the same
freedoms that you received. You must make sure that they, too, receive
or can get the source code. And you must show them these terms so they
know their rights.
Developers that use the GNU GPL protect your rights with two steps:
(1) assert copyright on the software, and (2) offer you this License
giving you legal permission to copy, distribute and/or modify it.
For the developers' and authors' protection, the GPL clearly explains
that there is no warranty for this free software. For both users' and
authors' sake, the GPL requires that modified versions be marked as
changed, so that their problems will not be attributed erroneously to
authors of previous versions.
Some devices are designed to deny users access to install or run
modified versions of the software inside them, although the manufacturer
can do so. This is fundamentally incompatible with the aim of
protecting users' freedom to change the software. The systematic
pattern of such abuse occurs in the area of products for individuals to
use, which is precisely where it is most unacceptable. Therefore, we
have designed this version of the GPL to prohibit the practice for those
products. If such problems arise substantially in other domains, we
stand ready to extend this provision to those domains in future versions
of the GPL, as needed to protect the freedom of users.
Finally, every program is threatened constantly by software patents.
States should not allow patents to restrict development and use of
software on general-purpose computers, but in those that do, we wish to
avoid the special danger that patents applied to a free program could
make it effectively proprietary. To prevent this, the GPL assures that
patents cannot be used to render the program non-free.
The precise terms and conditions for copying, distribution and
modification follow.
TERMS AND CONDITIONS
0. Definitions.
"This License" refers to version 3 of the GNU General Public License.
"Copyright" also means copyright-like laws that apply to other kinds of
works, such as semiconductor masks.
"The Program" refers to any copyrightable work licensed under this
License. Each licensee is addressed as "you". "Licensees" and
"recipients" may be individuals or organizations.
To "modify" a work means to copy from or adapt all or part of the work
in a fashion requiring copyright permission, other than the making of an
exact copy. The resulting work is called a "modified version" of the
earlier work or a work "based on" the earlier work.
A "covered work" means either the unmodified Program or a work based
on the Program.
To "propagate" a work means to do anything with it that, without
permission, would make you directly or secondarily liable for
infringement under applicable copyright law, except executing it on a
computer or modifying a private copy. Propagation includes copying,
distribution (with or without modification), making available to the
public, and in some countries other activities as well.
To "convey" a work means any kind of propagation that enables other
parties to make or receive copies. Mere interaction with a user through
a computer network, with no transfer of a copy, is not conveying.
An interactive user interface displays "Appropriate Legal Notices"
to the extent that it includes a convenient and prominently visible
feature that (1) displays an appropriate copyright notice, and (2)
tells the user that there is no warranty for the work (except to the
extent that warranties are provided), that licensees may convey the
work under this License, and how to view a copy of this License. If
the interface presents a list of user commands or options, such as a
menu, a prominent item in the list meets this criterion.
1. Source Code.
The "source code" for a work means the preferred form of the work
for making modifications to it. "Object code" means any non-source
form of a work.
A "Standard Interface" means an interface that either is an official
standard defined by a recognized standards body, or, in the case of
interfaces specified for a particular programming language, one that
is widely used among developers working in that language.
The "System Libraries" of an executable work include anything, other
than the work as a whole, that (a) is included in the normal form of
packaging a Major Component, but which is not part of that Major
Component, and (b) serves only to enable use of the work with that
Major Component, or to implement a Standard Interface for which an
implementation is available to the public in source code form. A
"Major Component", in this context, means a major essential component
(kernel, window system, and so on) of the specific operating system
(if any) on which the executable work runs, or a compiler used to
produce the work, or an object code interpreter used to run it.
The "Corresponding Source" for a work in object code form means all
the source code needed to generate, install, and (for an executable
work) run the object code and to modify the work, including scripts to
control those activities. However, it does not include the work's
System Libraries, or general-purpose tools or generally available free
programs which are used unmodified in performing those activities but
which are not part of the work. For example, Corresponding Source
includes interface definition files associated with source files for
the work, and the source code for shared libraries and dynamically
linked subprograms that the work is specifically designed to require,
such as by intimate data communication or control flow between those
subprograms and other parts of the work.
The Corresponding Source need not include anything that users
can regenerate automatically from other parts of the Corresponding
Source.
The Corresponding Source for a work in source code form is that
same work.
2. Basic Permissions.
All rights granted under this License are granted for the term of
copyright on the Program, and are irrevocable provided the stated
conditions are met. This License explicitly affirms your unlimited
permission to run the unmodified Program. The output from running a
covered work is covered by this License only if the output, given its
content, constitutes a covered work. This License acknowledges your
rights of fair use or other equivalent, as provided by copyright law.
You may make, run and propagate covered works that you do not
convey, without conditions so long as your license otherwise remains
in force. You may convey covered works to others for the sole purpose
of having them make modifications exclusively for you, or provide you
with facilities for running those works, provided that you comply with
the terms of this License in conveying all material for which you do
not control copyright. Those thus making or running the covered works
for you must do so exclusively on your behalf, under your direction
and control, on terms that prohibit them from making any copies of
your copyrighted material outside their relationship with you.
Conveying under any other circumstances is permitted solely under
the conditions stated below. Sublicensing is not allowed; section 10
makes it unnecessary.
3. Protecting Users' Legal Rights From Anti-Circumvention Law.
No covered work shall be deemed part of an effective technological
measure under any applicable law fulfilling obligations under article
11 of the WIPO copyright treaty adopted on 20 December 1996, or
similar laws prohibiting or restricting circumvention of such
measures.
When you convey a covered work, you waive any legal power to forbid
circumvention of technological measures to the extent such circumvention
is effected by exercising rights under this License with respect to
the covered work, and you disclaim any intention to limit operation or
modification of the work as a means of enforcing, against the work's
users, your or third parties' legal rights to forbid circumvention of
technological measures.
4. Conveying Verbatim Copies.
You may convey verbatim copies of the Program's source code as you
receive it, in any medium, provided that you conspicuously and
appropriately publish on each copy an appropriate copyright notice;
keep intact all notices stating that this License and any
non-permissive terms added in accord with section 7 apply to the code;
keep intact all notices of the absence of any warranty; and give all
recipients a copy of this License along with the Program.
You may charge any price or no price for each copy that you convey,
and you may offer support or warranty protection for a fee.
5. Conveying Modified Source Versions.
You may convey a work based on the Program, or the modifications to
produce it from the Program, in the form of source code under the
terms of section 4, provided that you also meet all of these conditions:
a) The work must carry prominent notices stating that you modified
it, and giving a relevant date.
b) The work must carry prominent notices stating that it is
released under this License and any conditions added under section
7. This requirement modifies the requirement in section 4 to
"keep intact all notices".
c) You must license the entire work, as a whole, under this
License to anyone who comes into possession of a copy. This
License will therefore apply, along with any applicable section 7
additional terms, to the whole of the work, and all its parts,
regardless of how they are packaged. This License gives no
permission to license the work in any other way, but it does not
invalidate such permission if you have separately received it.
d) If the work has interactive user interfaces, each must display
Appropriate Legal Notices; however, if the Program has interactive
interfaces that do not display Appropriate Legal Notices, your
work need not make them do so.
A compilation of a covered work with other separate and independent
works, which are not by their nature extensions of the covered work,
and which are not combined with it such as to form a larger program,
in or on a volume of a storage or distribution medium, is called an
"aggregate" if the compilation and its resulting copyright are not
used to limit the access or legal rights of the compilation's users
beyond what the individual works permit. Inclusion of a covered work
in an aggregate does not cause this License to apply to the other
parts of the aggregate.
6. Conveying Non-Source Forms.
You may convey a covered work in object code form under the terms
of sections 4 and 5, provided that you also convey the
machine-readable Corresponding Source under the terms of this License,
in one of these ways:
a) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by the
Corresponding Source fixed on a durable physical medium
customarily used for software interchange.
b) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by a
written offer, valid for at least three years and valid for as
long as you offer spare parts or customer support for that product
model, to give anyone who possesses the object code either (1) a
copy of the Corresponding Source for all the software in the
product that is covered by this License, on a durable physical
medium customarily used for software interchange, for a price no
more than your reasonable cost of physically performing this
conveying of source, or (2) access to copy the
Corresponding Source from a network server at no charge.
c) Convey individual copies of the object code with a copy of the
written offer to provide the Corresponding Source. This
alternative is allowed only occasionally and noncommercially, and
only if you received the object code with such an offer, in accord
with subsection 6b.
d) Convey the object code by offering access from a designated
place (gratis or for a charge), and offer equivalent access to the
Corresponding Source in the same way through the same place at no
further charge. You need not require recipients to copy the
Corresponding Source along with the object code. If the place to
copy the object code is a network server, the Corresponding Source
may be on a different server (operated by you or a third party)
that supports equivalent copying facilities, provided you maintain
clear directions next to the object code saying where to find the
Corresponding Source. Regardless of what server hosts the
Corresponding Source, you remain obligated to ensure that it is
available for as long as needed to satisfy these requirements.
e) Convey the object code using peer-to-peer transmission, provided
you inform other peers where the object code and Corresponding
Source of the work are being offered to the general public at no
charge under subsection 6d.
A separable portion of the object code, whose source code is excluded
from the Corresponding Source as a System Library, need not be
included in conveying the object code work.
A "User Product" is either (1) a "consumer product", which means any
tangible personal property which is normally used for personal, family,
or household purposes, or (2) anything designed or sold for incorporation
into a dwelling. In determining whether a product is a consumer product,
doubtful cases shall be resolved in favor of coverage. For a particular
product received by a particular user, "normally used" refers to a
typical or common use of that class of product, regardless of the status
of the particular user or of the way in which the particular user
actually uses, or expects or is expected to use, the product. A product
is a consumer product regardless of whether the product has substantial
commercial, industrial or non-consumer uses, unless such uses represent
the only significant mode of use of the product.
"Installation Information" for a User Product means any methods,
procedures, authorization keys, or other information required to install
and execute modified versions of a covered work in that User Product from
a modified version of its Corresponding Source. The information must
suffice to ensure that the continued functioning of the modified object
code is in no case prevented or interfered with solely because
modification has been made.
If you convey an object code work under this section in, or with, or
specifically for use in, a User Product, and the conveying occurs as
part of a transaction in which the right of possession and use of the
User Product is transferred to the recipient in perpetuity or for a
fixed term (regardless of how the transaction is characterized), the
Corresponding Source conveyed under this section must be accompanied
by the Installation Information. But this requirement does not apply
if neither you nor any third party retains the ability to install
modified object code on the User Product (for example, the work has
been installed in ROM).
The requirement to provide Installation Information does not include a
requirement to continue to provide support service, warranty, or updates
for a work that has been modified or installed by the recipient, or for
the User Product in which it has been modified or installed. Access to a
network may be denied when the modification itself materially and
adversely affects the operation of the network or violates the rules and
protocols for communication across the network.
Corresponding Source conveyed, and Installation Information provided,
in accord with this section must be in a format that is publicly
documented (and with an implementation available to the public in
source code form), and must require no special password or key for
unpacking, reading or copying.
7. Additional Terms.
"Additional permissions" are terms that supplement the terms of this
License by making exceptions from one or more of its conditions.
Additional permissions that are applicable to the entire Program shall
be treated as though they were included in this License, to the extent
that they are valid under applicable law. If additional permissions
apply only to part of the Program, that part may be used separately
under those permissions, but the entire Program remains governed by
this License without regard to the additional permissions.
When you convey a copy of a covered work, you may at your option
remove any additional permissions from that copy, or from any part of
it. (Additional permissions may be written to require their own
removal in certain cases when you modify the work.) You may place
additional permissions on material, added by you to a covered work,
for which you have or can give appropriate copyright permission.
Notwithstanding any other provision of this License, for material you
add to a covered work, you may (if authorized by the copyright holders of
that material) supplement the terms of this License with terms:
a) Disclaiming warranty or limiting liability differently from the
terms of sections 15 and 16 of this License; or
b) Requiring preservation of specified reasonable legal notices or
author attributions in that material or in the Appropriate Legal
Notices displayed by works containing it; or
c) Prohibiting misrepresentation of the origin of that material, or
requiring that modified versions of such material be marked in
reasonable ways as different from the original version; or
d) Limiting the use for publicity purposes of names of licensors or
authors of the material; or
e) Declining to grant rights under trademark law for use of some
trade names, trademarks, or service marks; or
f) Requiring indemnification of licensors and authors of that
material by anyone who conveys the material (or modified versions of
it) with contractual assumptions of liability to the recipient, for
any liability that these contractual assumptions directly impose on
those licensors and authors.
All other non-permissive additional terms are considered "further
restrictions" within the meaning of section 10. If the Program as you
received it, or any part of it, contains a notice stating that it is
governed by this License along with a term that is a further
restriction, you may remove that term. If a license document contains
a further restriction but permits relicensing or conveying under this
License, you may add to a covered work material governed by the terms
of that license document, provided that the further restriction does
not survive such relicensing or conveying.
If you add terms to a covered work in accord with this section, you
must place, in the relevant source files, a statement of the
additional terms that apply to those files, or a notice indicating
where to find the applicable terms.
Additional terms, permissive or non-permissive, may be stated in the
form of a separately written license, or stated as exceptions;
the above requirements apply either way.
8. Termination.
You may not propagate or modify a covered work except as expressly
provided under this License. Any attempt otherwise to propagate or
modify it is void, and will automatically terminate your rights under
this License (including any patent licenses granted under the third
paragraph of section 11).
However, if you cease all violation of this License, then your
license from a particular copyright holder is reinstated (a)
provisionally, unless and until the copyright holder explicitly and
finally terminates your license, and (b) permanently, if the copyright
holder fails to notify you of the violation by some reasonable means
prior to 60 days after the cessation.
Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from that
copyright holder, and you cure the violation prior to 30 days after
your receipt of the notice.
Termination of your rights under this section does not terminate the
licenses of parties who have received copies or rights from you under
this License. If your rights have been terminated and not permanently
reinstated, you do not qualify to receive new licenses for the same
material under section 10.
9. Acceptance Not Required for Having Copies.
You are not required to accept this License in order to receive or
run a copy of the Program. Ancillary propagation of a covered work
occurring solely as a consequence of using peer-to-peer transmission
to receive a copy likewise does not require acceptance. However,
nothing other than this License grants you permission to propagate or
modify any covered work. These actions infringe copyright if you do
not accept this License. Therefore, by modifying or propagating a
covered work, you indicate your acceptance of this License to do so.
10. Automatic Licensing of Downstream Recipients.
Each time you convey a covered work, the recipient automatically
receives a license from the original licensors, to run, modify and
propagate that work, subject to this License. You are not responsible
for enforcing compliance by third parties with this License.
An "entity transaction" is a transaction transferring control of an
organization, or substantially all assets of one, or subdividing an
organization, or merging organizations. If propagation of a covered
work results from an entity transaction, each party to that
transaction who receives a copy of the work also receives whatever
licenses to the work the party's predecessor in interest had or could
give under the previous paragraph, plus a right to possession of the
Corresponding Source of the work from the predecessor in interest, if
the predecessor has it or can get it with reasonable efforts.
You may not impose any further restrictions on the exercise of the
rights granted or affirmed under this License. For example, you may
not impose a license fee, royalty, or other charge for exercise of
rights granted under this License, and you may not initiate litigation
(including a cross-claim or counterclaim in a lawsuit) alleging that
any patent claim is infringed by making, using, selling, offering for
sale, or importing the Program or any portion of it.
11. Patents.
A "contributor" is a copyright holder who authorizes use under this
License of the Program or a work on which the Program is based. The
work thus licensed is called the contributor's "contributor version".
A contributor's "essential patent claims" are all patent claims
owned or controlled by the contributor, whether already acquired or
hereafter acquired, that would be infringed by some manner, permitted
by this License, of making, using, or selling its contributor version,
but do not include claims that would be infringed only as a
consequence of further modification of the contributor version. For
purposes of this definition, "control" includes the right to grant
patent sublicenses in a manner consistent with the requirements of
this License.
Each contributor grants you a non-exclusive, worldwide, royalty-free
patent license under the contributor's essential patent claims, to
make, use, sell, offer for sale, import and otherwise run, modify and
propagate the contents of its contributor version.
In the following three paragraphs, a "patent license" is any express
agreement or commitment, however denominated, not to enforce a patent
(such as an express permission to practice a patent or covenant not to
sue for patent infringement). To "grant" such a patent license to a
party means to make such an agreement or commitment not to enforce a
patent against the party.
If you convey a covered work, knowingly relying on a patent license,
and the Corresponding Source of the work is not available for anyone
to copy, free of charge and under the terms of this License, through a
publicly available network server or other readily accessible means,
then you must either (1) cause the Corresponding Source to be so
available, or (2) arrange to deprive yourself of the benefit of the
patent license for this particular work, or (3) arrange, in a manner
consistent with the requirements of this License, to extend the patent
license to downstream recipients. "Knowingly relying" means you have
actual knowledge that, but for the patent license, your conveying the
covered work in a country, or your recipient's use of the covered work
in a country, would infringe one or more identifiable patents in that
country that you have reason to believe are valid.
If, pursuant to or in connection with a single transaction or
arrangement, you convey, or propagate by procuring conveyance of, a
covered work, and grant a patent license to some of the parties
receiving the covered work authorizing them to use, propagate, modify
or convey a specific copy of the covered work, then the patent license
you grant is automatically extended to all recipients of the covered
work and works based on it.
A patent license is "discriminatory" if it does not include within
the scope of its coverage, prohibits the exercise of, or is
conditioned on the non-exercise of one or more of the rights that are
specifically granted under this License. You may not convey a covered
work if you are a party to an arrangement with a third party that is
in the business of distributing software, under which you make payment
to the third party based on the extent of your activity of conveying
the work, and under which the third party grants, to any of the
parties who would receive the covered work from you, a discriminatory
patent license (a) in connection with copies of the covered work
conveyed by you (or copies made from those copies), or (b) primarily
for and in connection with specific products or compilations that
contain the covered work, unless you entered into that arrangement,
or that patent license was granted, prior to 28 March 2007.
Nothing in this License shall be construed as excluding or limiting
any implied license or other defenses to infringement that may
otherwise be available to you under applicable patent law.
12. No Surrender of Others' Freedom.
If 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 convey a
covered work so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you may
not convey it at all. For example, if you agree to terms that obligate you
to collect a royalty for further conveying from those to whom you convey
the Program, the only way you could satisfy both those terms and this
License would be to refrain entirely from conveying the Program.
13. Use with the GNU Affero General Public License.
Notwithstanding any other provision of this License, you have
permission to link or combine any covered work with a work licensed
under version 3 of the GNU Affero General Public License into a single
combined work, and to convey the resulting work. The terms of this
License will continue to apply to the part which is the covered work,
but the special requirements of the GNU Affero General Public License,
section 13, concerning interaction through a network will apply to the
combination as such.
14. Revised Versions of this License.
The Free Software Foundation may publish revised and/or new versions of
the GNU General Public License from time to time. Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.
Each version is given a distinguishing version number. If the
Program specifies that a certain numbered version of the GNU General
Public License "or any later version" applies to it, you have the
option of following the terms and conditions either of that numbered
version or of any later version published by the Free Software
Foundation. If the Program does not specify a version number of the
GNU General Public License, you may choose any version ever published
by the Free Software Foundation.
If the Program specifies that a proxy can decide which future
versions of the GNU General Public License can be used, that proxy's
public statement of acceptance of a version permanently authorizes you
to choose that version for the Program.
Later license versions may give you additional or different
permissions. However, no additional obligations are imposed on any
author or copyright holder as a result of your choosing to follow a
later version.
15. Disclaimer of Warranty.
THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
16. Limitation of Liability.
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.
17. Interpretation of Sections 15 and 16.
If the disclaimer of warranty and limitation of liability provided
above cannot be given local legal effect according to their terms,
reviewing courts shall apply local law that most closely approximates
an absolute waiver of all civil liability in connection with the
Program, unless a warranty or assumption of liability accompanies a
copy of the Program in return for a fee.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.
To do so, attach the following notices to the program. It is safest
to attach them to the start of each source file to most effectively
state 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 program's name and a brief idea of what it does.>
Copyright (C) <year> <name of author>
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Also add information on how to contact you by electronic and paper mail.
If the program does terminal interaction, make it output a short
notice like this when it starts in an interactive mode:
<program> Copyright (C) <year> <name of author>
This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `show c' for details.
The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License. Of course, your program's commands
might be different; for a GUI interface, you would use an "about box".
You should also get your employer (if you work as a programmer) or school,
if any, to sign a "copyright disclaimer" for the program, if necessary.
For more information on this, and how to apply and follow the GNU GPL, see
<http://www.gnu.org/licenses/>.
The GNU General Public License does not permit incorporating your program
into proprietary programs. If your program is a subroutine library, you
may consider it more useful to permit linking proprietary applications with
the library. If this is what you want to do, use the GNU Lesser General
Public License instead of this License. But first, please read
<http://www.gnu.org/philosophy/why-not-lgpl.html>.

165
unikernel/duniverse/ocaml-caqti/COPYING.LESSER Normal file
View file

@ -0,0 +1,165 @@
GNU LESSER GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
This version of the GNU Lesser General Public License incorporates
the terms and conditions of version 3 of the GNU General Public
License, supplemented by the additional permissions listed below.
0. Additional Definitions.
As used herein, "this License" refers to version 3 of the GNU Lesser
General Public License, and the "GNU GPL" refers to version 3 of the GNU
General Public License.
"The Library" refers to a covered work governed by this License,
other than an Application or a Combined Work as defined below.
An "Application" is any work that makes use of an interface provided
by the Library, but which is not otherwise based on the Library.
Defining a subclass of a class defined by the Library is deemed a mode
of using an interface provided by the Library.
A "Combined Work" is a work produced by combining or linking an
Application with the Library. The particular version of the Library
with which the Combined Work was made is also called the "Linked
Version".
The "Minimal Corresponding Source" for a Combined Work means the
Corresponding Source for the Combined Work, excluding any source code
for portions of the Combined Work that, considered in isolation, are
based on the Application, and not on the Linked Version.
The "Corresponding Application Code" for a Combined Work means the
object code and/or source code for the Application, including any data
and utility programs needed for reproducing the Combined Work from the
Application, but excluding the System Libraries of the Combined Work.
1. Exception to Section 3 of the GNU GPL.
You may convey a covered work under sections 3 and 4 of this License
without being bound by section 3 of the GNU GPL.
2. Conveying Modified Versions.
If you modify a copy of the Library, and, in your modifications, a
facility refers to a function or data to be supplied by an Application
that uses the facility (other than as an argument passed when the
facility is invoked), then you may convey a copy of the modified
version:
a) under this License, provided that you make a good faith effort to
ensure that, in the event an Application does not supply the
function or data, the facility still operates, and performs
whatever part of its purpose remains meaningful, or
b) under the GNU GPL, with none of the additional permissions of
this License applicable to that copy.
3. Object Code Incorporating Material from Library Header Files.
The object code form of an Application may incorporate material from
a header file that is part of the Library. You may convey such object
code under terms of your choice, provided that, if the incorporated
material is not limited to numerical parameters, data structure
layouts and accessors, or small macros, inline functions and templates
(ten or fewer lines in length), you do both of the following:
a) Give prominent notice with each copy of the object code that the
Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the object code with a copy of the GNU GPL and this license
document.
4. Combined Works.
You may convey a Combined Work under terms of your choice that,
taken together, effectively do not restrict modification of the
portions of the Library contained in the Combined Work and reverse
engineering for debugging such modifications, if you also do each of
the following:
a) Give prominent notice with each copy of the Combined Work that
the Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the Combined Work with a copy of the GNU GPL and this license
document.
c) For a Combined Work that displays copyright notices during
execution, include the copyright notice for the Library among
these notices, as well as a reference directing the user to the
copies of the GNU GPL and this license document.
d) Do one of the following:
0) Convey the Minimal Corresponding Source under the terms of this
License, and the Corresponding Application Code in a form
suitable for, and under terms that permit, the user to
recombine or relink the Application with a modified version of
the Linked Version to produce a modified Combined Work, in the
manner specified by section 6 of the GNU GPL for conveying
Corresponding Source.
1) Use a suitable shared library mechanism for linking with the
Library. A suitable mechanism is one that (a) uses at run time
a copy of the Library already present on the user's computer
system, and (b) will operate properly with a modified version
of the Library that is interface-compatible with the Linked
Version.
e) Provide Installation Information, but only if you would otherwise
be required to provide such information under section 6 of the
GNU GPL, and only to the extent that such information is
necessary to install and execute a modified version of the
Combined Work produced by recombining or relinking the
Application with a modified version of the Linked Version. (If
you use option 4d0, the Installation Information must accompany
the Minimal Corresponding Source and Corresponding Application
Code. If you use option 4d1, you must provide the Installation
Information in the manner specified by section 6 of the GNU GPL
for conveying Corresponding Source.)
5. Combined Libraries.
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 that are not Applications and are not covered by this
License, and convey such a combined library under terms of your
choice, if you do both of the following:
a) Accompany the combined library with a copy of the same work based
on the Library, uncombined with any other library facilities,
conveyed under the terms of this License.
b) Give prominent notice with the combined library that part of it
is a work based on the Library, and explaining where to find the
accompanying uncombined form of the same work.
6. Revised Versions of the GNU Lesser General Public License.
The Free Software Foundation may publish revised and/or new versions
of the GNU Lesser General Public License from time to time. Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the
Library as you received it specifies that a certain numbered version
of the GNU Lesser General Public License "or any later version"
applies to it, you have the option of following the terms and
conditions either of that published version or of any later version
published by the Free Software Foundation. If the Library as you
received it does not specify a version number of the GNU Lesser
General Public License, you may choose any version of the GNU Lesser
General Public License ever published by the Free Software Foundation.
If the Library as you received it specifies that a proxy can decide
whether future versions of the GNU Lesser General Public License shall
apply, that proxy's public statement of acceptance of any version is
permanent authorization for you to choose that version for the
Library.

19
unikernel/duniverse/ocaml-caqti/COPYING.LINKING Normal file
View file

@ -0,0 +1,19 @@
LGPL-3.0 LINKING EXCEPTION
As a special exception to the GNU Lesser General Public License
version 3 ("LGPL3"), the copyright holders of this Library give you
permission to convey to a third party a Combined Work that links
statically or dynamically to this Library without providing any
Minimal Corresponding Source or Minimal Application Code as set out in
4d or providing the installation information set out in section 4e,
provided that you comply with the other provisions of LGPL3 and
provided that you meet, for the Application the terms and conditions
of the license(s) which apply to the Application.
Except as stated in this special exception, the provisions of LGPL3
will continue to comply in full to this Library. If you modify this
Library, you may apply this exception to your version of this Library,
but you are not obliged to do so. If you do not wish to do so, delete
this exception statement from your version. This exception does not
(and cannot) modify any license terms which apply to the Application,
with which you must still comply.

142
unikernel/duniverse/ocaml-caqti/README.md Normal file
View file

@ -0,0 +1,142 @@
[![CircleCI](https://circleci.com/gh/paurkedal/ocaml-caqti.svg?style=svg)](https://circleci.com/gh/paurkedal/ocaml-caqti)
## Synopsis
Caqti provides a monadic cooperative-threaded OCaml connector API for
relational databases.
The purpose of Caqti is further to help make applications independent of a
particular database system. This is achieved by defining a common
signature, which is implemented by the database drivers. Connection
parameters are specified as an URI, which is typically provided at run-time.
Caqti then loads a driver which can handle the URI, and provides a
first-class module which implements the driver API and additional
convenience functionality.
Caqti does not generate or analyze SQL but provides templating and uniform
query parameter handling, including encoding and decoding data according to
declared types. It is hoped that this agnostic choice makes it a suitable
target for higher level interfaces and code generators.
The following drivers are available:
RDBMS | URI scheme | library | Unix | MirageOS
---------- | --------------- | -------------- | ---- | --------
MariaDB | `mariadb://` | [mariadb][] | yes | no
PostgreSQL | `postgresql://` | [postgresql][] | yes | no
PostgreSQL | `pgx://` | [pgx][] | yes | yes
SQLite3 | `sqlite3://` | [sqlite3][] | yes | no
The PGX based driver is experimental and only recommended for MirageOS.
More about the drivers below.
## Documentation
### Tutorials and Examples
- The [caqti-study][] repository is a tutorial with examples, which we
will keep up to date with the latest release of Caqti. It is work in
progress; suggestions and contributions are welcome.
- [Interfacing OCaml and PostgreSQL with Caqti][BP-2018] by Bobby
Priambodo gives a gentle introduction, though the Caqti API has changed
to some extend since it was written.
- [The documented example][bikereg] in this repository can give a first
idea.
### API Documentation for Stable Releases
The stable API documentation is hosted on [https://ocaml.org](), where you
can search package by name.
A full Caqti release contains the following packages:
- [caqti](https://ocaml.org/p/caqti/latest):
Core libraries and blocking unix connector.
- [caqti-lwt](https://ocaml.org/p/caqti-lwt/latest):
Lwt support library and connector.
- [caqti-async](https://ocaml.org/p/caqti-async/latest):
Async connector.
- [caqti-eio](https://ocaml.org/p/caqti-eio/latest):
Experimental EIO connector.
- [caqti-miou](https://ocaml.org/p/caqti-miou/latest):
Experimental Miou connector.
- [caqti-mirage](https://ocaml.org/p/caqti-mirage/latest):
Experimental MirageOS connector.
- [caqti-driver-mariadb](https://ocaml.org/p/caqti-driver-mariadb):
Driver for MariaDB and MySQL using C bindings from [mariadb][].
- [caqti-driver-postgresql](https://ocaml.org/p/caqti-driver-postgresql):
Driver for PostgreSQL using C bindings from [postgresql][].
- [caqti-driver-sqlite3](https://ocaml.org/p/caqti-driver-sqlite3):
Driver for local SQlite3 databases using C bindings from [sqlite3][].
- [caqti-driver-pgx](https://ocaml.org/p/caqti-driver-pgx):
Experimental driver for PostgreSQL using the [pgx][] library.
- [caqti-tls](https://ocaml.org/p/caqti-tls):
TLS configuration currently only used by caqti-mirage, and only relevant
for pgx, since drivers based on C bindings have external TLS support.
The connector modules provide a connect functions which receives an URI,
dispatches to an appropriate driver, and returns a connection object as a
first-class module, which contains query functionality for the database.
The application can either link against the drivers it needs or the link
against the `caqti.plugin` library in order to load the appropriate driver
at runtime.
(A few package not mentioned include unreleased TLS packages and the
(semi-)deprecated packages
[caqti-type-calendar](https://ocaml.org/p/caqti-type-calendar/latest) and
[caqti-dynload](https://ocaml.org/p/caqti-dynload/latest).)
### API Documentation for Development Snapshots
Apart from the above links, the [GitHub pages][caqti-ghpages] are updated
occasionally with a rendering from the master branch. You can also build
the API reference matching your installed version using [odig][] or run
`dune build @doc` in a Git checkout.
## Running under utop
Dynamic linking does not work under utop. The workaround is to link against
the needed database driver. E.g.
```ocaml
# #require "caqti-lwt";;
# #require "caqti-driver-postgresql";;
# open Lwt.Infix;;
# open Caqti_request.Infix;;
(* Create a DB handle. *)
# module Db = (val Caqti_lwt_unix.connect (Uri.of_string "postgresql://") >>= Caqti_lwt.or_fail |> Lwt_main.run);;
module Db : Caqti_lwt.CONNECTION
(* Create a request which merely adds two parameters. *)
# let plus = Caqti_request.(Caqti_type.(t2 int int) ->! Caqti_type.int) "SELECT ? + ?";;
val plus : (int * int, int, [< `Many | `One | `Zero > `One ]) Caqti_request.t =
<abstr>
(* Run it. *)
# Db.find plus (7, 13);;
- : (int, [> Caqti_error.call_or_retrieve ]) result = Ok 20
```
## Related Software
- [ppx\_rapper](https://github.com/roddyyaga/ppx_rapper) - a syntax
extension for Caqti queries, simplifying type specifications.
## Sponsor
<a href="https://ocaml-sf.org">
<img align="left" alt="OCSF logo" src="https://ocaml-sf.org/assets/ocsf_logo.svg"/>
</a>
Thanks to the <a href="https://ocaml-sf.org">OCaml Software Foundation</a>
for economic support to the development of Caqti.
[caqti-ghpages]: http://paurkedal.github.io/ocaml-caqti/index.html
[BP-2018]: https://medium.com/@bobbypriambodo/interfacing-ocaml-and-postgresql-with-caqti-a92515bdaa11
[bikereg]: examples/bikereg.ml
[caqti-study]: https://github.com/paurkedal/caqti-study/
[odig]: http://erratique.ch/software/odig
[mariadb]: https://github.com/andrenth/ocaml-mariadb
[pgx]: https://github.com/arenadotio/pgx
[postgresql]: https://mmottl.github.io/postgresql-ocaml
[sqlite3]: https://mmottl.github.io/sqlite3-ocaml

30
unikernel/duniverse/ocaml-caqti/benchmarks/benchmark_all.ml Normal file
View file

@ -0,0 +1,30 @@
(* Copyright (C) 2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Common
module Make (Platform : PLATFORM) = struct
module Fetch_many = Benchmark_fetch_many.Make (Platform)
let cmds = [
Fetch_many.main_cmd;
]
let () =
let open Cmdliner in
exit Cmd.(eval @@ group (info (Filename.basename Sys.argv.(0))) cmds)
end

104
unikernel/duniverse/ocaml-caqti/benchmarks/benchmark_fetch_many.ml Normal file
View file

@ -0,0 +1,104 @@
(* Copyright (C) 2022--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Bechamel
open Bechamel.Toolkit
open Common
let connect_uri = Uri.of_string "postgresql://"
let fetch_many_request =
let open Caqti_template.Create in
static T.(unit -->* t3 int int (t3 float bool bool)) {|
WITH tmp (i) AS (VALUES (0), (1), (2), (3), (4), (5), (6), (7), (8), (9))
SELECT a.i, b.i, CAST(c.i AS float), e.i < c.i, e.i < d.i
FROM tmp a, tmp b, tmp c, tmp d, tmp e
|}
module Make (Platform : PLATFORM) = struct
open Platform
open Platform.Fiber.Infix
let test' _ = Staged.stage @@ fun (module C : CONNECTION) ->
run_fiber begin fun () ->
let aux (_, _, (_, _, _)) = succ in
C.fold fetch_many_request aux () 0 >>= or_fail >|= fun count ->
assert (count = 100_000)
end
let test stdenv connect_config uris =
let allocate i =
run_fiber (fun () ->
connect stdenv ~config:connect_config (List.nth uris i) >>= or_fail)
in
let free (module C : CONNECTION) =
run_fiber (fun () -> C.disconnect ())
in
Test.(make_indexed_with_resource uniq)
~name ~args:(List.mapi (fun i _ -> i) uris) ~allocate ~free test'
(* Benchmark Function *)
let benchmark context connect_config uris =
let ols =
Analyze.ols ~bootstrap:0 ~r_square:true ~predictors:Measure.[|run|]
in
let instances =
Instance.[minor_allocated; major_allocated; monotonic_clock]
in
let cfg =
(* TODO: Why does this segfault with ~kde:(Some 1000)? *)
Benchmark.cfg ~limit:2000 ~quota:(Time.second 1.0) ()
in
let raw_results =
Benchmark.all cfg instances (test context connect_config uris)
in
let results =
List.map (fun instance -> Analyze.all ols instance raw_results) instances
in
let results = Analyze.merge ols instances results in
(results, raw_results)
(* TTY Boilerplate *)
let () =
List.iter
(fun v -> Bechamel_notty.Unit.add v (Measure.unit v))
Instance.[minor_allocated; major_allocated; monotonic_clock]
let img (window, results) =
Bechamel_notty.Multiple.image_of_ols_results ~rect:window
~predictor:Measure.run results
open Notty_unix
let main {Testlib.uris; connect_config} =
run_main @@ fun context ->
let window =
match winsize Unix.stdout with
| Some (w, h) -> {Bechamel_notty.w; h}
| None -> {Bechamel_notty.w = 80; h = 1}
in
let results, _ = benchmark context connect_config uris in
img (window, results) |> eol |> output_image
let main_cmd =
let open Cmdliner in
let term = Term.(const main $ Testlib.common_args ()) in
Cmd.v (Cmd.info "fetch-many") term
end

92
unikernel/duniverse/ocaml-caqti/benchmarks/benchmark_stream.ml Normal file
View file

@ -0,0 +1,92 @@
(* Copyright (C) 2019--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Lwt.Infix
open Lwt.Syntax
let data = List.init 100_000 begin fun i ->
let x = float_of_int (i + 1) in
1.0 /. (x *. x)
end
module Stream_blocking = Caqti_platform.Stream.Make (struct
type 'a t = 'a
let return x = x
module Infix = struct
let (>>=) x f = f x
let (>|=) x f = f x
end
end)
module Stream_lwt = Caqti_platform.Stream.Make (Lwt)
let rec seq_of_list xs () =
(match xs with
| [] -> Seq.Nil
| x :: xs' -> Seq.Cons (x, seq_of_list xs'))
let test_list () =
let _ : float = List.fold_left (+.) 0.0 data in
()
let test_seq =
let seq = seq_of_list data in
fun () ->
let _ : float = Seq.fold_left (+.) 0.0 seq in
()
let test_stream_blocking =
let stream = Stream_blocking.of_list data in
fun () ->
let (_ : float) =
(Stream_blocking.fold ~f:(+.) stream 0.0 |> function
| Ok x -> x
| Error (`Congested (c : Caqti_error.counit)) -> (match c with _ -> .))
[@ocaml.warning "-56"] (* coded for backwards compatibility *)
in
()
let test_stream_lwt =
let stream = Stream_lwt.of_list data in
fun () -> Lwt_main.run begin
let* (_ : float) =
(Stream_lwt.fold ~f:(+.) stream 0.0 >|= function
| Ok x -> x
| Error (`Congested (c : Caqti_error.counit)) -> (match c with _ -> .))
[@ocaml.warning "-56"] (* coded for backwards compatibility *)
in
Lwt.return_unit
end
(*
let test_lwt_stream =
let stream = Lwt_stream.of_list data in (* OBS: Not re-iterable. *)
fun () -> Lwt_main.run begin
let* (_ : float) = Lwt_stream.fold (+.) stream 0.0 in
Lwt.return_unit
end
*)
let () =
let res = Benchmark.throughputN 30 [
"List", test_list, ();
"Seq", test_seq, ();
"Stream_blocking", test_stream_blocking, ();
"Stream_lwt", test_stream_lwt, ();
] in
print_newline ();
Benchmark.tabulate res

43
unikernel/duniverse/ocaml-caqti/benchmarks/common.ml Normal file
View file

@ -0,0 +1,43 @@
(* Copyright (C) 2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
module type PLATFORM = sig
type context
module Fiber : sig
type +'a t
module Infix : sig
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
val (>|=) : 'a t -> ('a -> 'b) -> 'b t
end
end
val name : string
val run_fiber : (unit -> 'a Fiber.t) -> 'a
val run_main : (context -> 'a) -> 'a
val or_fail : ('a, [< Caqti_error.t]) result -> 'a Fiber.t
module Stream : Caqti_stream_sig.S with type 'a fiber := 'a Fiber.t
module type CONNECTION = Caqti_connection_sig.S
with type 'a fiber := 'a Fiber.t
and type ('a, 'err) stream := ('a, 'err) Stream.t
type connection = (module CONNECTION)
val connect :
?config: Caqti_connect_config.t -> context -> Uri.t ->
(connection, [> Caqti_error.load_or_connect]) result Fiber.t
end

69
unikernel/duniverse/ocaml-caqti/benchmarks/dune Normal file
View file

@ -0,0 +1,69 @@
; Singular benchmark
(executable
(name benchmark_stream)
(modules benchmark_stream)
(libraries benchmark caqti caqti.platform lwt lwt.unix))
; Main benchmark suite with executables for concurrency flavours
(library
(name benchmark_all)
(flags (:standard -alert -caqti_unstable))
(modules
common
benchmark_fetch_many
benchmark_all)
(libraries
bechamel
bechamel-notty
caqti
caqti.plugin
notty.unix
testlib))
(executable
(name main_blocking)
(modules main_blocking)
(libraries
benchmark_all
caqti.blocking
unix))
(executable
(name main_eio_unix)
(modules main_eio_unix)
(enabled_if (>= %{ocaml_version} "5.0"))
(libraries
benchmark_all
caqti-eio.unix
caqti-tls-eio
eio
eio_main
mirage-crypto-rng.unix))
(executable
(name main_lwt_unix)
(modules main_lwt_unix)
(libraries
benchmark_all
caqti-lwt
caqti-lwt.unix
caqti-tls-lwt.unix
lwt
lwt.unix))
(executable
(name main_miou_unix)
(modules main_miou_unix)
(libraries
benchmark_all
caqti-miou
caqti_miou_unix
caqti-tls-miou
miou
miou.unix
mirage-crypto-rng-miou-unix
threads))
; TODO: Can we run async under a benchamel test?

32
unikernel/duniverse/ocaml-caqti/benchmarks/main_blocking.ml Normal file
View file

@ -0,0 +1,32 @@
(* Copyright (C) 2022--2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
include Benchmark_all.Make (struct
let name = "blocking"
module Fiber = struct
type 'a t = 'a
module Infix = struct
let (>>=) x f = f x
let (>|=) x f = f x
end
end
type context = unit
let run_fiber f = f ()
let run_main f = f ()
include Caqti_blocking
let connect ?config () uri = connect ?config uri
end)

45
unikernel/duniverse/ocaml-caqti/benchmarks/main_eio_unix.ml Normal file
View file

@ -0,0 +1,45 @@
(* Copyright (C) 2022--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Eio.Std
include Benchmark_all.Make (struct
let name = "eio-unix"
module Fiber = struct
type 'a t = 'a
module Infix = struct
let (>>=) x f = f x
let (>|=) x f = f x
end
end
type context = Caqti_eio.stdenv * Switch.t
let run_fiber f = f ()
let run_main f =
Mirage_crypto_rng_unix.use_default ();
Eio_main.run @@ fun stdenv ->
Switch.run @@ fun sw ->
f ((stdenv :> Caqti_eio.stdenv), sw)
include Caqti_eio
include Caqti_eio_unix
let connect ?config (stdenv, sw) uri = connect ?config ~sw ~stdenv uri
end)

27
unikernel/duniverse/ocaml-caqti/benchmarks/main_lwt_unix.ml Normal file
View file

@ -0,0 +1,27 @@
(* Copyright (C) 2022--2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
include Benchmark_all.Make (struct
let name = "lwt-unix"
module Fiber = Lwt
type context = unit
let run_fiber f = Lwt_main.run (f ())
let run_main f = f ()
include Caqti_lwt
include Caqti_lwt_unix
let connect ?config () uri = connect ?config uri
end)

44
unikernel/duniverse/ocaml-caqti/benchmarks/main_miou_unix.ml Normal file
View file

@ -0,0 +1,44 @@
(* Copyright (C) 2022--2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
include Benchmark_all.Make (struct
let name = "miou-unix"
module Fiber = struct
type 'a t = 'a
module Infix = struct
let (>>=) x f = f x
let (>|=) x f = f x
end
end
type context = Caqti_miou.switch
let run_fiber f = f ()
let run_main f =
Miou_unix.run @@ fun () ->
Caqti_miou.Switch.run @@ fun sw ->
let rng = Mirage_crypto_rng_miou_unix.(initialize (module Pfortuna)) in
let finally () = Mirage_crypto_rng_miou_unix.kill rng in
Fun.protect ~finally (fun () -> f sw)
include Caqti_miou
include Caqti_miou_unix
let connect ?config sw uri = connect ?config ~sw uri
end)

32
unikernel/duniverse/ocaml-caqti/caqti-async.opam Normal file
View file

@ -0,0 +1,32 @@
opam-version: "2.0"
name: "caqti-async"
maintainer: "Petter A. Urkedal <paurkedal@gmail.com>"
authors: "Petter A. Urkedal <paurkedal@gmail.com>"
license: "LGPL-3.0-or-later WITH LGPL-3.0-linking-exception"
homepage: "https://github.com/paurkedal/ocaml-caqti/"
doc: "https://paurkedal.github.io/ocaml-caqti/index.html"
bug-reports: "https://github.com/paurkedal/ocaml-caqti/issues"
depends: [
"async_kernel" {>= "v0.17.0"}
"async_unix" {>= "v0.11.0"}
"caqti" {>= "2.2.3" & < "2.3.0~"}
"core" {>= "v0.16.1"}
"core_unix"
"domain-name"
"dune" {>= "3.9"}
"ipaddr"
"logs"
"ocaml"
"alcotest" {with-test & >= "1.5.0"}
"alcotest-async" {with-test}
"cmdliner" {with-test & >= "1.1.0"}
"caqti-driver-sqlite3" {with-test}
"odoc" {with-doc}
]
build: [
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc}
]
dev-repo: "git+https://github.com/paurkedal/ocaml-caqti.git"
synopsis: "Async support for Caqti"

297
unikernel/duniverse/ocaml-caqti/caqti-async/lib/caqti_async.ml Normal file
View file

@ -0,0 +1,297 @@
(* Copyright (C) 2014--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
(* This is partly based on https://github.com/janestreet/lwt-async *)
open Async_kernel
open Async_unix
open Caqti_platform
open Core
type Caqti_error.msg += Msg_unix of Core_unix.Error.t * string * string
let () =
let pp ppf = function
| Msg_unix (err, func, arg) ->
Format.fprintf ppf "%s in %s(%S)" (Core_unix.Error.message err) func arg
| _ -> assert false
in
Caqti_error.define_msg ~pp [%extension_constructor Msg_unix]
module Fiber = struct
type 'a t = 'a Deferred.t
module Infix = struct
let (>>=) m f = Deferred.bind m ~f
let (>|=) = Deferred.(>>|)
end
open Infix
let return = Deferred.return
let catch f g =
try_with ~extract_exn:true f >>= function
| Ok y -> return y
| Error exn -> g exn
let finally f g =
try_with ~extract_exn:true f >>= function
| Ok y -> g () >|= fun () -> y
| Error exn -> g () >|= fun () -> Error.raise (Error.of_exn exn)
let cleanup f g =
try_with ~extract_exn:true f >>= function
| Ok y -> return y
| Error exn -> g () >|= fun () -> Error.raise (Error.of_exn exn)
end
open Fiber.Infix
module Stream = Caqti_platform.Stream.Make (Fiber)
module System_core = struct
module Fiber = Fiber
type stdenv = unit
let async ~sw:_ f = don't_wait_for (f ())
module Stream = Stream
module Mutex = struct
type t = (unit, Core.read_write) Mvar.t
let create = Mvar.create
let lock m = Mvar.put m ()
let unlock m = Mvar.take_now_exn m
end
module Condition = struct
include Async_kernel.Condition
type nonrec t = unit t
let wait c m = Mutex.unlock m; wait c >>= fun () -> Mutex.lock m
let signal c = signal c ()
end
module Switch = Caqti_platform.Switch.Make (Fiber)
module Log = struct
type 'a log = ('a, unit Deferred.t) Logs.msgf -> unit Deferred.t
(* Based on Logs_lwt.kmsg. *)
let kmsg ?(src = Logs.default) level msgf =
let count_it () =
(match level with
| Logs.Error -> Logs.incr_err_count ()
| Logs.Warning -> Logs.incr_warn_count ()
| _ -> ()) in
(match Logs.Src.level src with
| None -> return ()
| Some level' when Poly.(level > level') ->
count_it ();
return ()
| Some _ ->
count_it ();
let ivar = Ivar.create () in
let k () = Ivar.read ivar in
let over () = Ivar.fill_exn ivar () in
Logs.report src level ~over k msgf)
let err ?(src = Logging.default_log_src) msgf = kmsg ~src Logs.Error msgf
let warn ?(src = Logging.default_log_src) msgf = kmsg ~src Logs.Warning msgf
let info ?(src = Logging.default_log_src) msgf = kmsg ~src Logs.Info msgf
let debug ?(src = Logging.default_log_src) msgf = kmsg ~src Logs.Debug msgf
end
(* Cf. pgx_async. *)
module Sequencer = struct
type 'a t = 'a Sequencer.t
let create t = Sequencer.create ~continue_on_error:true t
let enqueue = Throttle.enqueue
end
end
module Alarm = struct
type t = unit
let schedule ~sw:_ ~stdenv:() t f =
let t_now = Mtime_clock.now () in
let dt_ns =
if Mtime.is_later t ~than:t_now then 0L else
Mtime.Span.to_uint64_ns (Mtime.span t t_now)
in
(match Int63.of_int64 dt_ns with
| None -> failwith "Arithmetic overflow while computing scheduling time."
| Some dt_ns -> Clock_ns.run_after (Time_ns.Span.of_int63_ns dt_ns) f ())
let unschedule () = ()
end
module Pool = Caqti_platform.Pool.Make (System_core) (Alarm)
module System = struct
include System_core
module Stream = Stream
module Net = struct
module Sockaddr = struct
type t = Async_unix.Unix.sockaddr
let unix s = Async_unix.Unix.ADDR_UNIX s
let tcp (addr, port) =
Async_unix.Unix.ADDR_INET
(Core_unix.Inet_addr.of_string (Ipaddr.to_string addr), port)
end
let getaddrinfo ~stdenv:() host port =
let module Ai = Async_unix.Unix.Addr_info in
let extract ai = ai.Ai.ai_addr in
Ai.get ~host:(Domain_name.to_string host) ~service:(string_of_int port)
Ai.[AI_SOCKTYPE SOCK_STREAM]
>|= List.map ~f:extract >|= (fun addrs -> Ok addrs)
module Socket = struct
type t = Reader.t * Writer.t
let output_char (_, oc) c = return (Writer.write_char oc c)
let output_string (_, oc) s = return (Writer.write oc s)
let flush (_, oc) = Writer.flushed oc
let input_char (ic, _) =
Reader.read_char ic
>|= function `Ok c -> c | `Eof -> raise End_of_file
let really_input (ic, _) s pos len =
Reader.really_read ic ~pos ~len s
>|= function `Ok -> () | `Eof _ -> raise End_of_file
let close (_ic, oc) = Writer.close oc
end
type tcp_flow = Socket.t
type tls_flow = Socket.t
let convert_io_exception exn =
(match Async_kernel.Monitor.extract_exn exn with
| Core_unix.Unix_error (err, func, arg) ->
Some (Msg_unix (err, func, arg))
| _ -> None)
let intercept_exceptions f =
Async_kernel.Monitor.try_with f >|= function
| Ok _ as r -> r
| Error exn ->
(match convert_io_exception exn with
| Some msg -> Error msg
| None -> raise exn)
let connect_tcp ~sw:_ ~stdenv:() addr =
intercept_exceptions @@ fun () ->
(match addr with
| Async_unix.Unix.ADDR_INET (addr, port) ->
Async_unix.Tcp.connect
(Tcp.Where_to_connect.of_inet_address (`Inet (addr, port)))
>|= fun (_, ic, oc) -> (ic, oc)
| Async_unix.Unix.ADDR_UNIX path ->
Async_unix.Tcp.connect
(Tcp.Where_to_connect.of_unix_address (`Unix path))
>|= fun (_, ic, oc) -> (ic, oc))
let tcp_flow_of_socket socket = Some socket
let socket_of_tls_flow ~sw:_ socket = socket
module type TLS_PROVIDER = Caqti_platform.System_sig.TLS_PROVIDER
with type 'a fiber := 'a Deferred.t
and type tcp_flow := tcp_flow
and type tls_flow := tls_flow
let tls_providers_r : (module TLS_PROVIDER) list ref = ref []
let tls_providers config =
if Caqti_connect_config.mem_name "tls" config then
(match Caqti_platform.Connector.load_library "caqti-tls-async" with
| Ok () -> ()
| Error msg ->
Logs.warn ~src:Logging.default_log_src (fun p ->
p "TLS configured but caqti-tls-async not available: %s" msg));
!tls_providers_r
let register_tls_provider p = tls_providers_r := p :: !tls_providers_r
end
end
module System_unix = struct
module Unix = struct
type file_descr = Async_unix.Fd.t
let fdinfo = Info.of_string "Caqti_async file descriptor"
let wrap_fd f ufd =
let fd = Fd.create (Fd.Kind.Socket `Active) ufd fdinfo in
let open Deferred in
f fd >>= fun r ->
Fd.(close ~file_descriptor_handling:Do_not_close_file_descriptor) fd
>>= fun () ->
return r
let poll ~stdenv:() ?(read = false) ?(write = false) ?timeout fd =
let wait_read =
if read then Async_unix.Fd.ready_to fd `Read else Deferred.never () in
let wait_write =
if write then Async_unix.Fd.ready_to fd `Write else Deferred.never () in
let wait_timeout =
(match timeout with
| Some t -> Clock.after (Time_float.Span.of_sec t)
| None -> Deferred.never ()) in
let did_read, did_write, did_timeout = ref false, ref false, ref false in
let is_ready = function
| `Ready -> true
| `Bad_fd | `Closed -> false in
Deferred.enabled [
Deferred.choice wait_read (fun st -> did_read := is_ready st);
Deferred.choice wait_write (fun st -> did_write := is_ready st);
Deferred.choice wait_timeout (fun () -> did_timeout := true);
] >>|
(fun f ->
ignore (f ());
(!did_read, !did_write, !did_timeout))
end
module Preemptive = struct
let detach f x = In_thread.run (fun () -> f x)
let run_in_main f = Thread_safe.block_on_async_exn f
end
end
module Loader = Caqti_platform_unix.Driver_loader.Make (System) (System_unix)
include Connector.Make (System) (Pool) (Loader)
open System
module type CONNECTION = Caqti_connection_sig.S
with type 'a fiber := 'a Deferred.t
and type ('a, 'e) stream := ('a, 'e) Stream.t
type connection = (module CONNECTION)
let connect = connect ~sw:Switch.eternal ~stdenv:()
let with_connection = with_connection ~stdenv:()
let connect_pool = connect_pool~sw:Switch.eternal ~stdenv:()

43
unikernel/duniverse/ocaml-caqti/caqti-async/lib/caqti_async.mli Normal file
View file

@ -0,0 +1,43 @@
(* Copyright (C) 2014--2023 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
(** Connector for Async. *)
open Async_kernel
module Stream : Caqti_stream_sig.S with type 'a fiber := 'a Deferred.t
module Pool : Caqti_pool_sig.S with type 'a fiber := 'a Deferred.t
module type CONNECTION = Caqti_connection_sig.S
with type 'a fiber := 'a Deferred.t
and type ('a, 'e) stream := ('a, 'e) Stream.t
include Caqti_connect_sig.S
with type 'a fiber := 'a Deferred.t
and type 'a with_switch := 'a
and type 'a with_stdenv := 'a
and type ('a, 'e) stream := ('a, 'e) Stream.t
and type ('a, 'e) pool := ('a, 'e) Pool.t
and type connection = (module CONNECTION)
(**/**)
module System : Caqti_platform.System_sig.S
with type 'a Fiber.t = 'a Deferred.t
and module Stream = Stream
and type stdenv = unit
and type Net.tcp_flow = Async_unix.Reader.t * Async_unix.Writer.t
and type Net.tls_flow = Async_unix.Reader.t * Async_unix.Writer.t

9
unikernel/duniverse/ocaml-caqti/caqti-async/lib/dune Normal file
View file

@ -0,0 +1,9 @@
(library
(name caqti_async)
(public_name caqti-async)
(libraries
async_kernel async_unix
caqti caqti.platform caqti.platform.unix
core core_unix
domain-name ipaddr
logs))

8
unikernel/duniverse/ocaml-caqti/caqti-async/testlib/dune Normal file
View file

@ -0,0 +1,8 @@
(library
(name testlib_async)
(libraries
alcotest
async_kernel
caqti_async
core_kernel
testlib))

64
unikernel/duniverse/ocaml-caqti/caqti-async/testlib/testlib_async.ml Normal file
View file

@ -0,0 +1,64 @@
(* Copyright (C) 2021--2023 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Async_kernel
open Core
module Fiber = struct
type 'a t = 'a Deferred.t
let return = return
let catch f g =
try_with ~extract_exn:true f >>= function
| Ok y -> return y
| Error exn -> g exn
let fail exn = Error.raise (Error.of_exn exn)
module Infix = struct
let (>>=) = (>>=)
let (>|=) = (>>|)
let (>>=?) m f = m >>= (function Ok x -> f x | Error _ as r -> return r)
let (>|=?) m f = m >|= (function Ok x -> Ok (f x) | Error _ as r -> r)
end
end
let or_fail = function
| Ok x -> return x
| Error (#Caqti_error.t as err) ->
Error.raise (Error.of_exn (Caqti_error.Exn err))
include Caqti_async
module Alcotest_cli =
Testlib.Make_alcotest_cli
(Alcotest.Unix_platform)
(struct
include Deferred
let bind m f = bind m ~f
let catch f g =
try_with ~extract_exn:true f >>= function
| Ok y -> return y
| Error exn -> g exn
end)
module List_result_fiber = struct
let rec iter_s f = function
| [] -> return (Ok ())
| x :: xs -> f x >>=? fun () -> iter_s f xs
end

21
unikernel/duniverse/ocaml-caqti/caqti-async/testlib/testlib_async.mli Normal file
View file

@ -0,0 +1,21 @@
(* Copyright (C) 2021--2023 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
include Testlib.Sig.Ground
with type 'a Fiber.t = 'a Async_kernel.Deferred.t
and module Stream = Caqti_async.Stream
and module Pool = Caqti_async.Pool

24
unikernel/duniverse/ocaml-caqti/caqti-driver-mariadb.opam Normal file
View file

@ -0,0 +1,24 @@
opam-version: "2.0"
name: "caqti-driver-mariadb"
maintainer: "Petter A. Urkedal <paurkedal@gmail.com>"
authors: "Petter A. Urkedal <paurkedal@gmail.com>"
license: "LGPL-3.0-or-later WITH LGPL-3.0-linking-exception"
homepage: "https://github.com/paurkedal/ocaml-caqti/"
doc: "https://paurkedal.github.io/ocaml-caqti/index.html"
bug-reports: "https://github.com/paurkedal/ocaml-caqti/issues"
depends: [
"alcotest" {with-test & >= "1.5.0"}
"ocaml"
"caqti" {>= "2.2.0" & < "2.3.0~"}
"cmdliner" {with-test & >= "1.1.0"}
"dune" {>= "3.9"}
"mariadb" {>= "1.3.0"}
"odoc" {with-doc}
]
build: [
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc}
]
dev-repo: "git+https://github.com/paurkedal/ocaml-caqti.git"
synopsis: "MariaDB driver for Caqti using C bindings"

642
unikernel/duniverse/ocaml-caqti/caqti-driver-mariadb/lib/caqti_driver_mariadb.ml Normal file
View file

@ -0,0 +1,642 @@
(* Copyright (C) 2017--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
[@@@alert "-caqti_private"]
open Caqti_template
open Caqti_platform
open Printf
let (|>?) = Result.bind
let cause_of_errno = function
| 1022 -> `Unique_violation
| 1048 -> `Not_null_violation
| 1052 -> `Integrity_constraint_violation__don't_match
| 1062 -> `Unique_violation
| 1169 -> `Unique_violation
| 1216 -> `Foreign_key_violation
| 1217 -> `Foreign_key_violation
| 1451 -> `Foreign_key_violation
| 1452 -> `Foreign_key_violation
| 1557 -> `Integrity_constraint_violation__don't_match
| 1586 -> `Unique_violation
| 1761 -> `Integrity_constraint_violation__don't_match
| 1762 -> `Integrity_constraint_violation__don't_match
| 1859 -> `Integrity_constraint_violation__don't_match
| 4025 -> `Check_violation
| _ -> `Unspecified__don't_match
type Caqti_error.msg += Error_msg of {errno: int; error: string}
let () =
let pp ppf = function
| Error_msg {errno; error} ->
Format.fprintf ppf "Error %d, %s." errno error
| _ ->
assert false
in
let cause = function
| Error_msg {errno; _} -> cause_of_errno errno
| _ -> assert false
in
Caqti_error.define_msg ~pp ~cause [%extension_constructor Error_msg]
module Q = struct
open Caqti_template.Create
let set_utc =
direct T.(unit -->. unit) "SET time_zone = '+00:00'"
let set_statement_timeout =
direct T.(float -->. unit) "SET max_statement_time = ?"
end
module Connect_functor
(System : Caqti_platform.System_sig.S)
(System_unix : Caqti_platform_unix.System_sig.S
with type 'a fiber := 'a System.Fiber.t
and type stdenv := System.stdenv) =
struct
open System
open System.Fiber.Infix
open System_utils.Monad_syntax (System.Fiber)
module H = Connection_utils.Make_helpers (System)
let (>>=?) m f = m >>= function Ok x -> f x | Error _ as r -> Fiber.return r
let rec fold_s_list f =
(function
| [] -> Fiber.return ()
| x :: xs -> f x >>= fun () -> fold_s_list f xs)
module type CONNECTION = Caqti_connection_sig.S
with type 'a fiber := 'a Fiber.t
and type ('a, 'err) stream := ('a, 'err) System.Stream.t
let dialect =
Dialect.create_mysql ~server_version:(Version.of_string_unsafe "") ()
let driver_info =
Caqti_driver_info.of_dialect dialect
(* We need to pass stdenv into the below wait, in order to implement
* timout for EIO, since it uses stdenv#clock. This means that our Mdb
* instance becomes dependent on stdenv and will therefore be
* instantiated for each connection. *)
module Pass_stdenv
(Connect_env : sig val stdenv : stdenv end) =
struct
open Connect_env
module Mdb = Mariadb.Nonblocking.Make
(struct
open System
module IO = struct
type 'a future = 'a Fiber.t
let (>>=) = Fiber.Infix.(>>=)
let return = Fiber.return
end
let wait db status =
Mariadb.Nonblocking.fd db |> System_unix.Unix.wrap_fd @@ fun fd ->
System_unix.Unix.poll
~stdenv
~read:(Mariadb.Nonblocking.Status.read status)
~write:(Mariadb.Nonblocking.Status.write status) fd
>|= (fun (read, write, timeout) ->
Mariadb.Nonblocking.Status.create ~read ~write ~timeout ())
end)
module Mdb_ext = struct
module Field = struct
let typename field =
(match Mdb.Field.value field with
| `Null -> "null"
| `Int _ -> "int"
| `Float _ -> "float"
| `String _ -> "string"
| `Bytes _ -> "bytes"
| `Time _ -> "time")
let bool field =
(match Mdb.Field.value field with
| `Int i -> i <> 0
| _ -> failwith "Mdb_ext.Field.float")
(* Lax conversion from float and string since:
* - Arithmetic involving integers like `1 + ?` with at least one
* parameter comes back as float.
* - An expression like `sum(1)` comes back as a string here, presumably
* as decimal from MariaDB. *)
let int field =
(match Mdb.Field.value field with
| `Int i -> i
| `Float x when fst (modf x) = 0.0 -> int_of_float x
| `String s -> int_of_string s
| _ -> failwith "Mdb_ext.Field.int")
let int32 field =
(match Mdb.Field.value field with
| `Int i -> Int32.of_int i
| `Float x -> Int32.of_float x (* cf. int *)
| `String s -> Int32.of_string s (* cf. int *)
| _ -> failwith "Mdb_ext.Field.int32")
let int64 field =
(match Mdb.Field.value field with
| `Int i -> Int64.of_int i
| `Float x -> Int64.of_float x (* cf. int *)
| `String s -> Int64.of_string s (* cf. int *)
| _ -> failwith "Mdb_ext.Field.int64")
let float field =
(match Mdb.Field.value field with
| `Int i -> float_of_int i
| `Float x -> x
| _ -> failwith "Mdb_ext.Field.float")
let string field =
(match Mdb.Field.value field with
| `String s -> s
| `Bytes s -> Bytes.to_string s
| _ -> failwith "Mdb_ext.Field.string")
end
end
let encode_field : type a. a Field_type.t -> a -> Mdb.Field.value =
fun field_type x ->
(match field_type with
| Bool -> `Int (if x then 1 else 0)
| Int -> `Int x
| Int16 -> `Int x
| Int32 -> `Int (Int32.to_int x)
| Int64 -> `Int (Int64.to_int x)
| Float -> `Float x
| String -> `String x
| Enum _ -> `String x
| Octets -> `Bytes (Bytes.of_string x)
| Pdate ->
let year, month, day = Ptime.to_date x in
`Time (Mdb.Time.date ~year ~month ~day ())
| Ptime ->
let (year, month, day), ((hour, minute, second), _) =
Ptime.to_date_time ~tz_offset_s:0 x in
let ps = snd (Ptime.Span.to_d_ps (Ptime.to_span x)) in
let tss = Int64.rem ps 1_000_000_000_000L in
let microsecond = Int64.to_int (Int64.div tss 1_000_000L) in
`Time (Mdb.Time.datetime
~year ~month ~day ~hour ~minute ~second ~microsecond ())
| Ptime_span ->
`Float (Ptime.Span.to_float_s x))
let decode_field
: type b. uri: Uri.t -> b Field_type.t -> Mdb.Field.t -> b =
fun ~uri field_type field ->
try match field_type with
| Bool -> Mdb_ext.Field.bool field
| Int -> Mdb_ext.Field.int field
| Int16 -> Mdb_ext.Field.int field
| Int32 -> Mdb_ext.Field.int32 field
| Int64 -> Mdb_ext.Field.int64 field
| Float -> Mdb.Field.float field
| String -> Mdb_ext.Field.string field
| Enum _ -> Mdb_ext.Field.string field
| Octets -> Mdb_ext.Field.string field
| Pdate ->
let t = Mdb.Field.time field in
let date = Mdb.Time.(year t, month t, day t) in
(match Ptime.of_date date with
| None -> failwith "Ptime.of_date"
| Some t -> t)
| Ptime ->
let t = Mdb.Field.time field in
let date = Mdb.Time.(year t, month t, day t) in
let time = Mdb.Time.(hour t, minute t, second t) in
let us = Mdb.Time.microsecond t in
(match Ptime.of_date_time (date, (time, 0)),
Ptime.Span.of_d_ps (0, Int64.(mul (of_int us) 1_000_000L)) with
| None, _ | _, None -> failwith "Ptime.of_date_time"
| Some t, Some tss ->
(match Ptime.add_span t tss with
| None -> failwith "Ptime.of_date_time: Overflow."
| Some t' -> t'))
| Ptime_span ->
let t = Mdb_ext.Field.float field in
(match Ptime.Span.of_float_s t with
| None -> failwith "Ptime.Span.of_float_s"
| Some t -> t)
with
| Failure _ ->
let typename = Mdb_ext.Field.typename field in
let msg = Caqti_error.Msg ("Received " ^ typename ^ ".") in
let typ = Row_type.field field_type in
Request_utils.raise_decode_rejected ~uri ~typ msg
let encode_param ~uri params t v acc =
let write_value ~uri:_ ft fv os =
assert (os <> []);
let v = encode_field ft fv in
List.iter (fun j -> params.(j) <- v) (List.hd os);
List.tl os
in
let write_null ~uri:_ _ os = List.tl os in
try
Ok (Request_utils.encode_param ~uri {write_value; write_null} t v acc)
with Caqti_error.Exn (#Caqti_error.call as err) ->
Error err
let decode_row ~uri row_type =
let read_value ~uri ft (row, j) =
let fv = decode_field ~uri ft row.(j) in
(fv, (row, j + 1))
in
let skip_null n (row, j) =
let j' = j + n in
let rec check k =
k = j' || Mdb.Field.null_value row.(k) && check (k + 1)
in
if check j then Some (row, j') else None
in
let decode =
Request_utils.decode_row ~uri {read_value; skip_null} row_type
in
fun row ->
try
let (y, (_, j)) = decode (row, 0) in
assert (j = Row_type.length row_type);
Ok (Some y)
with Caqti_error.Exn (#Caqti_error.retrieve as err) ->
Error err
module Make_connection_base
(Connection_arg : sig
val subst : Query.subst
val uri : Uri.t
val db : Mdb.t
val dynamic_capacity : int
end) =
struct
open Connection_arg
let dialect =
Dialect.create_mysql
~server_version:(Version.of_string_unsafe (Mdb.get_server_info db)) ()
let using_db_ref = ref false
let using_db f =
H.assert_single_use ~what:"MariaDB connection" using_db_ref f
let request_failed ~query (errno, error) =
Error (Caqti_error.request_failed ~uri ~query (Error_msg {errno; error}))
let response_failed ~query (errno, error) =
Error (Caqti_error.response_failed ~uri ~query (Error_msg {errno; error}))
let response_rejected ~query msg =
Error (Caqti_error.response_rejected ~uri ~query (Caqti_error.Msg msg))
module Response = struct
type ('b, +'m) t = {
query: string;
res: Mdb.Res.t;
row_type: 'b Row_type.t;
}
let reject_f ~query fmt = ksprintf (response_rejected ~query) fmt
let affected_count {res; _} = Fiber.return (Ok (Mdb.Res.affected_rows res))
let returned_count {res; _} = Fiber.return (Ok (Mdb.Res.num_rows res))
let decode_next_row ~query row_type =
let decode = decode_row ~uri row_type in
fun res ->
Mdb.Res.fetch (module Mdb.Row.Array) res >|= function
| Ok None as r -> r
| Ok (Some row) -> decode row
| Error err -> response_failed ~query err
let exec {res; query; _} =
(match Mdb.Res.num_rows res with
| 0 -> Fiber.return (Ok ())
| n -> Fiber.return (reject_f ~query "Received %d tuples for exec." n))
let find {query; res; row_type} =
(match Mdb.Res.num_rows res with
| 1 ->
decode_next_row ~query row_type res >|=
(function
| Ok None -> assert false
| Ok (Some y) -> Ok y
| Error _ as r -> r)
| n -> Fiber.return (reject_f ~query "Received %d tuples for find." n))
let find_opt {query; res; row_type} =
(match Mdb.Res.num_rows res with
| 0 -> Fiber.return (Ok None)
| 1 -> decode_next_row ~query row_type res
| n -> Fiber.return (reject_f ~query "Received %d tuples for find_opt." n))
let fold f {query; res; row_type} =
let decode = decode_next_row ~query row_type in
let rec loop acc =
decode res >>= function
| Ok None -> Fiber.return (Ok acc)
| Ok (Some y) -> loop (f y acc)
| Error _ as r -> Fiber.return r
in
loop
let fold_s f {query; res; row_type} =
let decode = decode_next_row ~query row_type in
let rec loop acc =
decode res >>= function
| Ok None -> Fiber.return (Ok acc)
| Ok (Some y) -> f y acc >>=? loop
| Error _ as r -> Fiber.return r
in
loop
let iter_s f {query; res; row_type} =
let decode = decode_next_row ~query row_type in
let rec loop () =
decode res >>= function
| Ok None -> Fiber.return (Ok ())
| Ok (Some y) -> f y >>=? loop
| Error _ as r -> Fiber.return r
in
loop ()
let to_stream {query; res; row_type} =
let decode = decode_next_row ~query row_type in
let rec loop () =
decode res >>= function
| Ok None -> Fiber.return Stream.Nil
| Error err -> Fiber.return (Stream.Error err)
| Ok (Some y) -> Fiber.return (Stream.Cons (y, loop))
in
loop
end
type prepared = {
query: string;
stmt: Mdb.Stmt.t;
param_length: int;
param_order: int list list;
quotes: Request_utils.linear_param list;
}
module Pcache =
Request_cache.Make (struct type t = prepared let weight _ = 1 end)
let pcache : Pcache.t = Pcache.create ~dynamic_capacity dialect
let pp_request_with_param ppf =
Request.make_pp_with_param ~subst ~dialect () ppf
let free_prepared prepared =
let rewrite_error = function
| Ok () -> Ok ()
| Error err ->
let query = sprintf "DEALLOCATE (%s)" prepared.query in
request_failed ~query err
in
Mdb.Stmt.close prepared.stmt >|= rewrite_error
let deallocate req =
(match Request.prepare_policy req with
| Dynamic | Static ->
(match Pcache.deallocate pcache req with
| None -> Fiber.return (Ok ())
| Some (prepared, commit) -> free_prepared prepared >|=? commit)
| Direct ->
failwith "deallocate called on oneshot request")
let deallocate_some () =
let rec loop = function
| [] -> Fiber.return (Ok ())
| prepared :: orphans ->
let*? () = free_prepared prepared in
loop orphans
in
let orphans, commit = Pcache.trim pcache in
loop orphans >|=? commit
let prepare request =
deallocate_some () >>=? fun () ->
(match Pcache.find_and_promote pcache request with
| Some prepared ->
Fiber.return (Ok prepared)
| None ->
let templ = Request.query request dialect in
let templ = Query.expand ~final:true subst templ in
let query = Request_utils.linear_query_string templ in
Mdb.prepare db query >|= function
| Error err -> request_failed ~query err
| Ok stmt ->
let param_length = Request_utils.linear_param_length templ in
let param_order, quotes =
Request_utils.linear_param_order templ in
let prepared =
{query; stmt; param_length; param_order; quotes} in
Pcache.add pcache request prepared;
Ok prepared)
let call ~f req param = using_db @@ fun () ->
Log.debug ~src:Logging.request_log_src (fun f ->
f "Sending %a" pp_request_with_param (req, param))
>>= fun () ->
let process {query; stmt; param_length; param_order; quotes} =
let param_type = Request.param_type req in
let row_type = Request.row_type req in
let params = Array.make param_length `Null in
List.iter
(fun (Request_utils.Linear_param (j, t, v)) ->
params.(j) <- encode_field t v)
quotes;
(match encode_param ~uri params param_type param param_order with
| Error _ as r -> Fiber.return r
| Ok [] ->
Mdb.Stmt.execute stmt params >>=
(function
| Error err -> Fiber.return (request_failed ~query err)
| Ok res -> f Response.{query; res; row_type})
| Ok (_ :: _) -> assert false) in
(match Request.prepare_policy req with
| Direct ->
let templ = Request.query req dialect in
let templ = Query.expand ~final:true subst templ in
let query = Request_utils.linear_query_string templ in
Mdb.prepare db query >>=
(function
| Error err -> Fiber.return (request_failed ~query err)
| Ok stmt ->
let param_length = Request_utils.linear_param_length templ in
let param_order, quotes =
Request_utils.linear_param_order templ in
let prepared =
{query; stmt; param_length; param_order; quotes} in
process prepared >>= fun process_result ->
Mdb.Stmt.close stmt >>=
(function
| Error (code, msg) ->
Log.warn (fun p ->
p "Ignoring error while closing statement: %d %s" code msg)
| Ok () -> Fiber.return ()) >|= fun () ->
process_result)
| Dynamic | Static ->
let*? prepared = prepare req in
let* process_result = process prepared in
let+ () =
Mdb.Stmt.reset prepared.stmt >>=
(function
| Ok () -> Fiber.return ()
| Error (code, msg) ->
Log.warn (fun p ->
p "Removing statement from cache due to failed reset: %d %s"
code msg) >|= fun () ->
Pcache.remove_and_discard pcache req)
in
process_result)
let disconnect () = using_db @@ fun () ->
let close_stmt prepared =
Mdb.Stmt.close prepared.stmt >>=
(function
| Ok () -> Fiber.return ()
| Error (code, msg) ->
Log.warn (fun p ->
p "Ignoring failure during disconnect: %d %s" code msg))
in
fold_s_list close_stmt (Pcache.elements pcache) >>= fun () ->
Pcache.clear_and_discard pcache;
Mdb.close db
let validate () = using_db @@ fun () ->
Mdb.ping db >|= function Ok () -> true | Error _ -> false
let check f = f true (* FIXME *)
let transaction_failed query (errno, error) =
let msg = Error_msg {errno; error} in
Fiber.return (Error (Caqti_error.request_failed ~uri ~query msg))
let start () = using_db @@ fun () ->
Mdb.autocommit db false >>=
(function
| Ok () -> Fiber.return (Ok ())
| Error err -> transaction_failed "# SET autocommit = 0" err)
let commit () = using_db @@ fun () ->
Mdb.commit db >>= fun commit_result ->
Mdb.autocommit db true >>= fun autocommit_result ->
(match commit_result, autocommit_result with
| Ok (), Ok () -> Fiber.return (Ok ())
| Error err, _ -> transaction_failed "# COMMIT" err
| Ok (), Error err -> transaction_failed "# SET autocommit = 1" err)
let rollback () = using_db @@ fun () ->
Mdb.rollback db >>=
(function
| Ok () -> Fiber.return (Ok ())
| Error err -> transaction_failed "# ROLLBACK" err)
let set_statement_timeout t =
call ~f:Response.exec Q.set_statement_timeout
(match t with
| None -> 0.0
| Some t -> max 0.000001 t)
end
type conninfo = {
host: string option;
user: string option;
pass: string option;
port: int option;
db: string option;
flags: Mdb.flag list option;
config_group: string option;
}
let parse_uri uri =
let host = Uri.host uri in
let user = Uri.user uri in
let pass = Uri.password uri in
let port = Uri.port uri in
let config_group = Uri.get_query_param uri "config-group" in
(match Uri.path uri with
| "" | "/" -> Ok None
| path ->
if Filename.dirname path <> "/" then
let msg = Caqti_error.Msg "Bad URI path." in
Error (Caqti_error.connect_rejected ~uri msg)
else
Ok (Some (Filename.basename path))) |>? fun db ->
Ok {host; user; pass; port; db; flags = None; config_group}
end
let connect ~sw:_ ~stdenv ~subst ~config uri =
let module With_stdenv = Pass_stdenv (struct let stdenv = stdenv end) in
let open With_stdenv in
Fiber.return (parse_uri uri)
>>=? fun {host; user; pass; port; db; flags; config_group} ->
let config_group = match config_group with Some g -> g | None -> "caqti" in
let socket = Uri.get_query_param uri "socket" in
let options = [Mdb.Read_default_group config_group] in
Mdb.connect ?host ?user ?pass ?db ?port ?socket ?flags ~options () >>=
(function
| Ok db ->
let module B = Make_connection_base
(struct
let subst = subst dialect
let uri = uri
let db = db
let dynamic_capacity =
Caqti_connect_config.(get dynamic_prepare_capacity config)
end)
in
let module C = struct
let driver_info = driver_info
let driver_connection = None
include B
include Connection_utils.Make_convenience (System) (B)
include Connection_utils.Make_populate (System) (B)
end in
Mdb.set_character_set db "utf8mb4" >>=
(function
| Ok () -> Fiber.return ()
| Error (err_no, err_msg) ->
Log.warn (fun f ->
f "Could not enable full Unicode coverage for this MariaDB \
connection. UTF-8 strings are likely limited to the BMP. \
set_character_set says %S (%d)" err_msg err_no))
>>= fun () ->
(* MariaDB returns local times but without time zone, so change it to
* UTC for Caqti sessions. *)
C.call ~f:(fun resp -> C.Response.exec resp) Q.set_utc () >|=
(function
| Ok () -> Ok (module C : CONNECTION)
| Error err -> Error (`Post_connect err))
| Error (errno, error) ->
Fiber.return @@
Error (Caqti_error.connect_failed ~uri (Error_msg {errno; error})))
end
let () =
Caqti_platform_unix.Driver_loader.register "mariadb" (module Connect_functor)

48
unikernel/duniverse/ocaml-caqti/caqti-driver-mariadb/lib/caqti_driver_mariadb.mli Normal file
View file

@ -0,0 +1,48 @@
(* Copyright (C) 2017--2022 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
(** Caqti driver for MariaDB (bindings).
This driver is implemented in terms of the mariadb OPAM package.
It handles URIs of the form
[mariadb://<user>:<password>@<host>:<port>/?<query>]
with the following query arguments:
- [socket=<socket>] requests a UNIX domain socket connection
- [config-group=<name>] loads additional settings from the section
[<name>] of the default configuration file. Default: ["caqti"].
Except for the latter, options are passed to the correspondingly named
arguments to the [connect] function of MariaDB.
All parts of the URL are optional, except that the chosen combination must
suffice to establish a connection.
The interface provided by this module {e should normally not be used by
applications}, but provides access to some MariaDB specifics in case they
are needed. *)
(** {1 Error Details}
The following provides access to diagnostics collected from the MariaDB
connection and statement objects. *)
type Caqti_error.msg += Error_msg of {
errno: int;
(** The error number returned by [mysql_errno] or [mysql_stmt_errno]. *)
error: string;
(** The error message returned by [mysql_error] or [mysql_stmt_errno]. *)
}

14
unikernel/duniverse/ocaml-caqti/caqti-driver-mariadb/lib/dune Normal file
View file

@ -0,0 +1,14 @@
(library
(name caqti_driver_mariadb)
(public_name caqti-driver-mariadb)
(optional)
(flags (:standard -alert -caqti_unstable))
(library_flags (:standard -linkall))
(libraries caqti caqti.platform caqti.platform.unix mariadb))
(plugin
(package caqti-driver-mariadb)
(name caqti-driver-mariadb)
(optional)
(libraries caqti-driver-mariadb)
(site (caqti plugins)))

16
unikernel/duniverse/ocaml-caqti/caqti-driver-mariadb/test/dune Normal file
View file

@ -0,0 +1,16 @@
(test
(name test_mariadb)
(package caqti-driver-mariadb)
(build_if %{lib-available:caqti-driver-mariadb})
(flags (:standard -alert -caqti_unstable))
(libraries
alcotest
caqti
caqti.blocking
caqti-driver-mariadb
testlib
testlib_blocking)
(deps ../../testsuite/uris.conf)
(action
(setenv CAQTI_TEST_URIS_FILE ../../testsuite/uris.conf
(run %{test}))))

61
unikernel/duniverse/ocaml-caqti/caqti-driver-mariadb/test/test_mariadb.ml Normal file
View file

@ -0,0 +1,61 @@
(* Copyright (C) 2021--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Testlib
open Testlib_blocking
let bad_select_req =
Caqti_template.Create.(static T.(unit -->! unit) "SELECT not_defined")
let test_error (module C : Caqti_blocking.CONNECTION) =
(match C.find bad_select_req () with
| Ok () -> Alcotest.fail "unexpected ok from bad_select"
| Error (`Request_failed
{msg = Caqti_driver_mariadb.Error_msg {errno; error = _}; _}) ->
Alcotest.(check int) "errno" 1054 errno
| Error err ->
Alcotest.failf "unexpected error from bad_select: %a" Caqti_error.pp err)
let test_cases_on_connection = [
"test_error", `Quick, test_error;
]
let mk_test (name, pool) =
let pass_conn (name, speed, f) =
let f' () =
Caqti_blocking.Pool.use (fun c -> Ok (f c)) pool |> function
| Ok () -> ()
| Error err -> Alcotest.failf "%a" Caqti_error.pp err
in
(name, speed, f')
in
let test_cases = List.map pass_conn test_cases_on_connection in
(name, test_cases)
let mk_tests {uris; connect_config = config} =
let connect_pool uri =
let pool_config = Caqti_pool_config.create ~max_size:1 () in
(match Caqti_blocking.connect_pool uri ~pool_config ~config with
| Ok pool -> (test_name_of_uri uri, pool)
| Error err -> raise (Caqti_error.Exn err))
in
let is_mariadb uri = Uri.scheme uri = Some "mariadb" in
let pools = List.map connect_pool (List.filter is_mariadb uris) in
List.map mk_test pools
let () =
Alcotest_cli.run_with_args_dependency "test_mariadb" (common_args ()) mk_tests

24
unikernel/duniverse/ocaml-caqti/caqti-driver-pgx.opam Normal file
View file

@ -0,0 +1,24 @@
opam-version: "2.0"
name: "caqti-driver-pgx"
maintainer: "Petter A. Urkedal <paurkedal@gmail.com>"
authors: [
"Petter A. Urkedal <paurkedal@gmail.com>"
]
license: "LGPL-3.0-or-later WITH LGPL-3.0-linking-exception"
homepage: "https://github.com/paurkedal/ocaml-caqti/"
doc: "https://paurkedal.github.io/ocaml-caqti/index.html"
bug-reports: "https://github.com/paurkedal/ocaml-caqti/issues"
depends: [
"ocaml" {>= "4.08"}
"caqti" {>= "2.2.0" & < "2.3.0~"}
"domain-name"
"dune" {>= "3.9"}
"ipaddr"
"pgx" {>= "2.0"}
]
build: [
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
dev-repo: "git+https://github.com/paurkedal/ocaml-caqti.git"
synopsis: "PostgreSQL driver for Caqti based on the pure-OCaml PGX library"

791
unikernel/duniverse/ocaml-caqti/caqti-driver-pgx/lib/caqti_driver_pgx.ml Normal file
View file

@ -0,0 +1,791 @@
(* Copyright (C) 2021--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
[@@@alert "-caqti_private"]
open Caqti_template
open Caqti_platform
open Postgresql_conv
open Printf
let rec find_map_list f = function
| [] -> None
| x :: xs -> (match f x with | None -> find_map_list f xs | Some _ as y -> y)
type Caqti_error.msg += Pgx_msg of string * Pgx.Error_response.t
let () =
let pp ppf = function
| Pgx_msg (msg, _) -> Format.pp_print_string ppf msg
| _ -> assert false
in
let cause = function
| Pgx_msg (_, error_response) ->
cause_of_sqlstate error_response.Pgx.Error_response.code
| _ ->
assert false
in
Caqti_error.define_msg ~pp ~cause [%extension_constructor Pgx_msg]
exception Failed_with_msg of Caqti_error.msg
let host_of_string str =
(match Domain_name.of_string str with
| Ok dom ->
(match Domain_name.host dom with
| Ok dom -> Some dom
| Error _ -> None)
| Error _ -> None)
let pg_type_name : type a. a Field_type.t -> string = function
| Bool -> "bool"
| Int -> "int8"
| Int16 -> "int2"
| Int32 -> "int4"
| Int64 -> "int8"
| Float -> "float8"
| String -> "text"
| Octets -> "bytea"
| Pdate -> "date"
| Ptime -> "timestamptz"
| Ptime_span -> "interval"
| Enum name -> name
let encode_field
: type a. a Field_type.t -> a -> Pgx.Value.t
= fun field_type x ->
(match field_type with
| Bool -> Pgx.Value.of_bool x
| Int -> Pgx.Value.of_int x
| Int16 -> Pgx.Value.of_int x
| Int32 -> Pgx.Value.of_int32 x
| Int64 -> Pgx.Value.of_int64 x
| Float -> Pgx.Value.of_float x
| String -> Pgx.Value.of_string x
| Enum _ -> Pgx.Value.of_string x
| Octets -> Pgx.Value.of_binary x
| Pdate -> Pgx.Value.of_string (Conv.iso8601_of_pdate x)
| Ptime -> Pgx.Value.of_string (pgstring_of_ptime x)
| Ptime_span -> Pgx.Value.of_string (pgstring_of_ptime_span x))
let query_string ~subst templ =
let templ = Query.expand ~final:true subst templ in
let rec extract_quotes : Query.t -> _ = function
| V (ft, v) -> fun (n, acc) -> (n + 1, encode_field ft v :: acc)
| Q s -> fun (n, acc) -> (n + 1, Pgx.Value.of_string s :: acc)
| L _ | P _ -> Fun.id
| E _ -> fun _ -> assert false
| S qs -> List_ext.fold extract_quotes qs
in
let nQ, rev_quotes = extract_quotes templ (0, []) in
let buf = Buffer.create 64 in
let rec write_query_string : Query.t -> _ = function
| L s -> fun jQ -> Buffer.add_string buf s; jQ
| V _ -> fun jQ -> bprintf buf "$%d" jQ; jQ + 1
| Q _ -> fun jQ -> bprintf buf "$%d" jQ; jQ + 1
| P j -> fun jQ -> bprintf buf "$%d" (nQ + 1 + j); jQ
| E _ -> assert false
| S qs -> List_ext.fold write_query_string qs
in
let _jQ = write_query_string templ 1 in
(Buffer.contents buf, rev_quotes)
let encode_param ~uri t param =
let write_value ~uri:_ ft fv acc = encode_field ft fv :: acc in
let write_null ~uri:_ _ acc = Pgx.Value.null :: acc in
try
Request_utils.encode_param ~uri {write_value; write_null} t param []
|> List.rev |> Result.ok
with Caqti_error.Exn (#Caqti_error.call as err) ->
Error err
let decode_field : type a. uri: Uri.t -> a Field_type.t -> Pgx.Value.t -> a =
fun ~uri field_type v ->
let wrap_conv_exn f s =
(match f s with
| y -> y
| exception Pgx.Value.Conversion_failure msg_str ->
let msg = Caqti_error.Msg msg_str in
let typ = Row_type.field field_type in
Request_utils.raise_decode_rejected ~uri ~typ msg)
in
let wrap_conv_res f s =
(match f s with
| Ok y -> y
| Error msg_str ->
let msg = Caqti_error.Msg msg_str in
let typ = Row_type.field field_type in
Request_utils.raise_decode_rejected ~uri ~typ msg)
in
(match field_type with
| Bool -> wrap_conv_exn Pgx.Value.to_bool_exn v
| Int -> wrap_conv_exn Pgx.Value.to_int_exn v
| Int16 -> wrap_conv_exn Pgx.Value.to_int_exn v
| Int32 -> wrap_conv_exn Pgx.Value.to_int32_exn v
| Int64 -> wrap_conv_exn Pgx.Value.to_int64_exn v
| Float -> wrap_conv_exn Pgx.Value.to_float_exn v
| String -> wrap_conv_exn Pgx.Value.to_string_exn v
| Enum _ -> wrap_conv_exn Pgx.Value.to_string_exn v
| Octets -> wrap_conv_exn Pgx.Value.to_binary_exn v
| Pdate ->
v |> wrap_conv_exn Pgx.Value.to_string_exn
|> wrap_conv_res Conv.pdate_of_iso8601
| Ptime ->
v |> wrap_conv_exn Pgx.Value.to_string_exn
|> wrap_conv_res Conv.ptime_of_rfc3339_utc
| Ptime_span ->
v |> wrap_conv_exn Pgx.Value.to_string_exn
|> wrap_conv_res ptime_span_of_pgstring)
let decode_row ~uri row_type =
let read_value ~uri ft = function
| [] -> assert false
| field :: fields ->
let y = decode_field ~uri ft field in
(y, fields)
in
let rec skip_null n xs =
if n = 0 then Some xs else
(match xs with
| [] -> assert false
| x :: xs' when Pgx.Value.(compare null) x = 0 -> skip_null (n - 1) xs'
| _ :: _ -> None)
in
let decode = Request_utils.decode_row ~uri {read_value; skip_null} row_type in
fun fields ->
try
let (y, fields) = decode fields in
assert (fields = []);
Ok y
with
| Caqti_error.Exn (#Caqti_error.retrieve as err) -> Error err
module Q = struct
let select_type_oid = "SELECT oid FROM pg_catalog.pg_type WHERE typname = $1"
end
type connect_arg = {
host: string option;
port: int option;
user: string option;
password: string option;
database: string option;
unix_domain_socket_dir: string option;
}
let (let/?) m f = match m with Ok x -> f x | Error _ as r -> r
let parse_uri uri =
let reject msg =
let msg = Caqti_error.Msg msg in
Error (Caqti_error.connect_rejected ~uri msg)
in
let/? host_or_unix_domain_socket_dir =
(match Uri.host uri, Uri.get_query_param uri "host" with
| None, None -> Ok None
| Some s, None | None, Some s -> Ok (Some s)
| Some _, Some _ -> reject "Conflicting host in URI.")
in
let host, unix_domain_socket_dir =
(match host_or_unix_domain_socket_dir with
| None | Some "" -> (None, None)
| Some s -> if s.[0] = '/' then (None, Some s) else (Some s, None))
in
let/? port =
(match Uri.port uri, Uri.get_query_param uri "port" with
| None, None -> Ok None
| Some i, None -> Ok (Some i)
| None, Some s ->
(try Ok (Some (int_of_string s)) with
| Failure _ -> reject "Non-integer port number in URI.")
| Some _, Some _ -> reject "Conflicting host in URI.")
in
let/? user =
(match Uri.user uri, Uri.get_query_param uri "user" with
| None, None -> Ok None
| Some s, None | None, Some s -> Ok (Some s)
| Some _, Some _ -> reject "Conflicting user in URI.")
in
let/? password =
(match Uri.password uri, Uri.get_query_param uri "password" with
| None, None -> Ok None
| Some s, None | None, Some s -> Ok (Some s)
| Some _, Some _ -> reject "Conflicting password in URI.")
in
let/? database =
(match String.split_on_char '/' (Uri.path uri),
Uri.get_query_param uri "dbname" with
| [], _ -> assert false
| [""], dbname -> Ok dbname
| [""; dbname], None -> Ok (Some dbname)
| [""; _], Some _ -> reject "Conflicting dbname in URI."
| _ -> reject "Too many path components in URI.")
in
Ok {host; port; user; password; database; unix_domain_socket_dir}
let dialect = Dialect.create_pgsql
~server_version:(Version.of_string_unsafe "")
~client_library:`pgx
()
module Connect_functor (System : Caqti_platform.System_sig.S) = struct
open System
open System.Fiber.Infix
let ( let*? ) m f = m >>= function Ok x -> f x | Error _ as r -> Fiber.return r
let ( let+? ) m f = m >|= function Ok x -> Ok (f x) | Error _ as r -> r
let ( >>=? ) = ( let*? )
let ( >|=? ) = ( let+? )
let intercept h f =
Fiber.catch
(fun () -> f () >|= fun y -> Ok y)
(function
| Failed_with_msg msg ->
Fiber.return (Error (h msg))
| Pgx.PostgreSQL_Error (msg, err) ->
Fiber.return (Error (h (Pgx_msg (msg, err))))
| End_of_file ->
Fiber.return (Error (h (Caqti_error.Msg "Unexpected EOF from server.")))
| Failure msg -> (* Raised by our Pgx.Io implementation. *)
Fiber.return (Error (h (Caqti_error.Msg msg)))
| exn ->
(match Net.convert_io_exception exn with
| Some msg -> Fiber.return (Error (h msg))
| None -> raise exn))
let intercept_request_failed ~uri ~query =
intercept (Caqti_error.request_failed ~uri ~query)
let intercept_connect_failed ~uri =
intercept (Caqti_error.connect_failed ~uri)
type ssl_config =
Ssl_config : {
impl: (module Net.TLS_PROVIDER with type tls_config = 'a);
config: 'a;
host: [`host] Domain_name.t option;
} -> ssl_config
(* We need to pass stdenv into open_connection below. This means that
* PGX will be instantiated for each connection. *)
module Pass_stdenv
(Connect_env : sig val sw : Switch.t val stdenv : stdenv end) =
struct
open Connect_env
module Pgx_with_io = Pgx.Make (struct
type 'a t = 'a Fiber.t
let return = Fiber.return
let ( >>= ) = ( >>= )
let catch = Fiber.catch
include Net
type in_channel = Socket.t
type out_channel = Socket.t
type sockaddr = Unix of string | Inet of string * int
let open_connection sockaddr =
let connect sockaddr =
Net.connect_tcp ~sw ~stdenv sockaddr
>|= Result.map (fun socket -> (socket, socket))
in
(match sockaddr with
| Unix path ->
connect (Sockaddr.unix path)
| Inet (host_or_ipaddr, port) ->
(match Ipaddr.of_string host_or_ipaddr with
| Ok ipaddr ->
connect (Sockaddr.tcp (ipaddr, port))
| Error _ ->
(match host_of_string host_or_ipaddr with
| None ->
failwith
("Cannot resolve invalid host name " ^ host_or_ipaddr)
| Some host ->
getaddrinfo ~stdenv host port >>= (function
| Ok [] ->
failwith "The host name does not resolve."
| Ok (sockaddr :: _) ->
connect sockaddr
| Error (`Msg msg) ->
failwith msg))))
>|= function Ok conn -> conn | Error msg -> raise (Failed_with_msg msg)
let output_char = Socket.output_char
let output_string = Socket.output_string
let flush = Socket.flush
let output_binary_int oc x =
let buf = Bytes.create 4 in
Bytes.set_int32_be buf 0 (Int32.of_int x);
Socket.output_string oc (Bytes.to_string buf)
let input_char = Socket.input_char
let really_input = Socket.really_input
(* This closes the output channel instead of the input channel; cf.
* Unix.open_connection. *)
let close_in = Socket.close
let input_binary_int ic =
let buf = Bytes.create 4 in
Socket.really_input ic buf 0 4 >|= fun () ->
Int32.to_int (Bytes.get_int32_be buf 0)
type nonrec ssl_config = ssl_config
let upgrade_ssl =
let upgrade ?ssl_config socket _ =
(match ssl_config, tcp_flow_of_socket socket with
| None, _ -> assert false (* we don't use `Auto *)
| _, None -> assert false (* we only upgrade once *)
| Some (Ssl_config {impl; config; host}), Some tcp_flow ->
let module Impl = (val impl) in
Impl.start_tls ~config ?host tcp_flow >|= function
| Ok tls_flow ->
let socket = socket_of_tls_flow ~sw tls_flow in
(socket, socket)
| Error msg -> raise (Failed_with_msg msg))
in
`Supported upgrade
let getlogin () = failwith "The DB user must be provided."
let debug msg = Log.debug (fun f -> f "%s" msg)
let protect f ~finally = Fiber.finally f finally
module Sequencer = struct
type 'a monad = 'a Fiber.t
include Sequencer
end
end)
end
module Make_connection_base
(Pgx_with_io : Pgx.S with type 'a Io.t = 'a Fiber.t
and type Io.ssl_config = ssl_config)
(Connection_arg : sig
val subst : Query.subst
val uri : Uri.t
val db_arg : Pgx_with_io.t
val select_type_oid : Pgx_with_io.Prepared.s
val dynamic_capacity : int
end) =
struct
open Connection_arg
let db_txn = ref None
module Response = struct
type ('b, 'm) t = {
query: string;
row_type: 'b Row_type.t;
prepared: Pgx_with_io.Prepared.s;
params: Pgx.Value.t list;
}
let returned_count _ = Fiber.return (Error `Unsupported)
let affected_count _ = Fiber.return (Error `Unsupported)
let reject ~query msg =
Error (Caqti_error.response_rejected ~uri ~query (Caqti_error.Msg msg))
let exec {query; prepared; params; _} =
intercept_request_failed ~uri ~query (fun () ->
Pgx_with_io.Prepared.execute prepared ~params) >|=
(function
| Ok [] -> Ok ()
| Ok _ ->
reject ~query "Received multiple rows where none were expected."
| Error _ as r -> r)
let find {query; row_type; prepared; params} =
intercept_request_failed ~uri ~query (fun () ->
Pgx_with_io.Prepared.execute prepared ~params) >|=
(function
| Ok [row] -> decode_row ~uri row_type row
| Ok [] ->
reject ~query "Received no rows where one was expected."
| Ok _ ->
reject ~query "Received more than one row where one was expected."
| Error _ as r -> r)
let find_opt {query; row_type; prepared; params} =
intercept_request_failed ~uri ~query (fun () ->
Pgx_with_io.Prepared.execute prepared ~params) >|=
(function
| Ok [] -> Ok None
| Ok [row] ->
decode_row ~uri row_type row |> Result.map (fun x -> Some x)
| Ok _ ->
reject ~query
"Received two or more rows where at most one was expected."
| Error _ as r -> r)
let fold f {query; row_type; prepared; params} =
let decode = decode_row ~uri row_type in
let f acc row =
Fiber.return @@ match acc with
| Ok acc ->
(match decode row with
| Ok row -> Ok (f row acc)
| Error _ as r -> r)
| Error _ as r -> r
in
fun acc ->
intercept_request_failed ~uri ~query begin fun () ->
Pgx_with_io.Prepared.execute_fold ~f prepared ~params ~init:(Ok acc)
end >|= Stdlib.Result.join
let fold_s f {query; row_type; prepared; params} =
let decode = decode_row ~uri row_type in
let f acc row =
(match acc with
| Ok acc ->
(match decode row with
| Ok row -> f row acc
| Error _ as r -> Fiber.return r)
| Error _ as r -> Fiber.return r)
in
fun acc ->
intercept_request_failed ~uri ~query begin fun () ->
Pgx_with_io.Prepared.execute_fold ~f prepared ~params ~init:(Ok acc)
end >|= Stdlib.Result.join
let iter_s f {query; row_type; prepared; params} =
let decode = decode_row ~uri row_type in
let f acc row =
(match acc with
| Ok () ->
(match decode row with
| Ok row -> f row
| Error _ as r -> Fiber.return r)
| Error _ as r -> Fiber.return r)
in
intercept_request_failed ~uri ~query begin fun () ->
Pgx_with_io.Prepared.execute_fold ~f prepared ~params ~init:(Ok ())
end >|= Stdlib.Result.join
let to_stream resp () =
fold List.cons resp [] >|= Result.map List.rev >|= function
| Ok [] -> Stream.Nil
| Ok (row :: rows) -> Stream.Cons (row, Stream.of_list rows)
| Error err -> (Stream.Error err)
end
type prepared = {
query: string;
pgx_prepared: Pgx_with_io.Prepared.s;
rev_quotes: Pgx.Value.t list;
}
module Pcache =
Request_cache.Make (struct type t = prepared let weight _ = 1 end)
let in_use = ref false
let pcache : Pcache.t = Pcache.create ~dynamic_capacity dialect
let reset _ = Fiber.return () (* FIXME *)
let using_db f =
if !in_use then
failwith "Invalid concurrent usage of PostgreSQL connection detected.";
in_use := true;
let db = match !db_txn with None -> db_arg | Some db -> db in
Fiber.cleanup
(fun () -> f db >|= fun res -> in_use := false; res)
(fun () -> reset db >|= fun _ -> in_use := false)
let type_oid_cache = Hashtbl.create 11
let field_type_oid ft =
let name = pg_type_name ft in
(match Hashtbl.find_opt type_oid_cache name with
| Some oid -> Fiber.return (Ok oid)
| None ->
let params = [Pgx.Value.of_string name] in
let*? row =
intercept_request_failed ~uri ~query:Q.select_type_oid (fun () ->
Pgx_with_io.Prepared.execute select_type_oid ~params)
in
let fail s =
let msg = Caqti_error.Msg s in
Fiber.return (Error
(Caqti_error.request_failed ~uri ~query:Q.select_type_oid msg))
in
let failf fmt = Format.kasprintf fail fmt in
(match row with
| [[v]] ->
(match Pgx.Value.to_int32 v with
| Some oid ->
Hashtbl.add type_oid_cache name oid;
Fiber.return (Ok oid)
| None ->
failf "Expected an int32 in response from OID request.")
| [] ->
failf "OID for type %a not found." Field_type.pp ft
| [_] ->
failf "Expected single field result from OID request."
| _ ->
failf "Expected at most one row from OID request."))
let type_oids param_type =
let rec loop :
type a. a Row_type.t -> Pgx.oid list ->
(Pgx.oid list, _) result Fiber.t =
(function
| Field ft -> fun acc -> field_type_oid ft >|=? fun ft -> ft :: acc
| Option t -> loop t
| Product (_, prod) ->
let rec loop_prod : type i. (i, a) Row_type.product -> _ =
(function
| Proj_end -> fun acc -> Fiber.return (Ok acc)
| Proj (t, _, prod) ->
let loop_t = loop t in
let loop_prod = loop_prod prod in
fun acc -> loop_prod acc >>=? loop_t)
in
loop_prod prod
| Annot (_, t) -> loop t)
in
loop (Row_type.option param_type) []
let pp_request_with_param ppf =
Request.make_pp_with_param ~subst ~dialect () ppf
let free_prepared prepared =
intercept_request_failed ~uri ~query:"DEALLOCATE"
(fun () -> Pgx_with_io.Prepared.close prepared.pgx_prepared)
let deallocate req =
(match Request.prepare_policy req with
| Dynamic | Static ->
(match Pcache.deallocate pcache req with
| None ->
Fiber.return (Ok ())
| Some (prepared, commit) ->
free_prepared prepared >|=? commit)
| Direct ->
failwith "deallocate called on oneshot request")
let deallocate_some () =
let rec loop = function
| [] -> Fiber.return (Ok ())
| prepared :: orphans ->
let*? () = free_prepared prepared in
loop orphans
in
let orphans, commit = Pcache.trim pcache in
loop orphans >|=? commit
let fresh_name = Request_utils.fresh_name_generator "caq"
let call ~f req param =
using_db @@ fun db ->
deallocate_some () >>=? fun () ->
Log.debug ~src:Logging.request_log_src (fun f ->
f "Sending %a" pp_request_with_param (req, param)) >>= fun () ->
let pre_prepare () =
let templ = Request.query req dialect in
let query, rev_quotes = query_string ~subst templ in
let*? param_types = type_oids (Request.param_type req) in
let+? string_oid = field_type_oid Field_type.String in
let quote_types = List.rev_map (fun _ -> string_oid) rev_quotes in
let types = List.rev_append quote_types param_types in
(query, types, rev_quotes)
in
let post_prepare pq =
(match encode_param ~uri (Request.param_type req) param with
| Error _ as r -> Fiber.return r
| Ok regular_params ->
let params = List.rev_append pq.rev_quotes regular_params in
f {
Response.row_type = Request.row_type req;
query = pq.query;
prepared = pq.pgx_prepared;
params;
})
in
(match Request.prepare_policy req with
| Dynamic | Static ->
(match Pcache.find_and_promote pcache req with
| Some pq -> Fiber.return (Ok pq)
| None ->
let*? query, types, rev_quotes = pre_prepare () in
let name = fresh_name () in
let+? pgx_prepared =
intercept_request_failed ~uri ~query (fun () ->
Pgx_with_io.Prepared.prepare ~name ~query ~types db)
in
let pq = {query; pgx_prepared; rev_quotes} in
Pcache.add pcache req pq;
pq)
>>=? post_prepare
| Direct ->
let*? query, types, rev_quotes = pre_prepare () in
Pgx_with_io.Prepared.with_prepare db ~types ~query
~f:(fun pgx_prepared ->
post_prepare {query; pgx_prepared; rev_quotes}))
let disconnect () =
using_db @@ fun _ ->
Fiber.catch
(fun () ->
(match !db_txn with
| None -> Fiber.return ()
| Some db -> Pgx_with_io.close db) >>= fun () ->
Pgx_with_io.close db_arg)
(function
| Pgx.PostgreSQL_Error (msg, _) ->
Log.err (fun f -> f "Failed to disconnect %a: %s" Uri.pp uri msg)
| exn ->
raise exn)
let validate () =
(* No need to handle exceptions here, since alive is a catch-all wrapper
* around ping. *)
using_db Pgx_with_io.alive
let check f = f true
let start () =
(match !db_txn with
| None ->
intercept_request_failed ~uri ~query:"BEGIN" begin fun () ->
Pgx_with_io.begin_work db_arg >|= fun db ->
db_txn := Some db
end
| Some _ ->
failwith "A transaction already in progress.")
let commit () =
(match !db_txn with
| Some db ->
intercept_request_failed ~uri ~query:"COMMIT" begin fun () ->
db_txn := None;
Pgx_with_io.commit db
end
| None ->
failwith "No transaction to commit.")
let rollback () =
(match !db_txn with
| Some db ->
intercept_request_failed ~uri ~query:"ROLLBACK" begin fun () ->
db_txn := None;
Pgx_with_io.rollback db
end
| None ->
failwith "No transaction to roll back.")
let set_statement_timeout t =
let t_arg =
(match t with
| None -> 0
| Some t -> max 1 (int_of_float (t *. 1000.0 +. 500.0)))
in
let query = sprintf "SET statement_timeout TO %d" t_arg in
using_db @@ fun db ->
intercept_request_failed ~uri ~query @@ fun () ->
Pgx_with_io.execute_unit db query
end
let driver_info = Caqti_driver_info.of_dialect dialect
module type CONNECTION = Caqti_connection_sig.S
with type 'a fiber := 'a Fiber.t
and type ('a, 'err) stream := ('a, 'err) System.Stream.t
let find_tls_provider ~config ?host () =
let with_config (module Tls_provider : Net.TLS_PROVIDER) =
(match Caqti_connect_config.get Tls_provider.tls_config_key config with
| None -> None
| Some config ->
Some (Ssl_config {impl = (module Tls_provider); config; host}))
in
(match find_map_list with_config (Net.tls_providers config) with
| None -> `No
| Some ssl_config -> `Always ssl_config)
let connect ~sw ~stdenv ~subst ~config uri =
(* Create PGX connection and helper functions. *)
let*? {host; port; user; password; database; unix_domain_socket_dir} =
Fiber.return (parse_uri uri)
in
let ssl =
let host = Option.bind host host_of_string in
find_tls_provider ~config ?host ()
in
let open Pass_stdenv (struct let sw = sw let stdenv = stdenv end) in
let*? db =
intercept_connect_failed ~uri
(Pgx_with_io.connect
~ssl ?host ?port ?user ?password ?database ?unix_domain_socket_dir)
in
let prepare_post_connect query =
intercept_request_failed ~uri ~query
(fun () -> Pgx_with_io.Prepared.prepare db ~query)
>|= Result.map_error (fun err -> `Post_connect err)
in
let execute_post_connect ?params query =
intercept_request_failed ~uri ~query
(fun () -> Pgx_with_io.execute ?params db query)
in
(* Run setup. *)
let*? () =
let query = "SET TimeZone TO 'UTC'" in
let reject msg =
let msg = Caqti_error.Msg msg in
let err = Caqti_error.response_rejected ~uri ~query msg in
Error (`Post_connect err)
in
execute_post_connect query >|= function
| Ok [] -> Ok ()
| Ok _ -> reject "Invalid response from setup request."
| Error err -> Error (`Post_connect err)
in
(* Return Caqti connection module. *)
let+? select_type_oid = prepare_post_connect Q.select_type_oid in
let module B = Make_connection_base (Pgx_with_io) (struct
let subst = subst dialect
let uri = uri
let db_arg = db
let select_type_oid = select_type_oid
let dynamic_capacity =
Caqti_connect_config.(get dynamic_prepare_capacity) config
end) in
let module Connection = struct
let driver_info = driver_info
let dialect = dialect
let driver_connection = None
include B
include Connection_utils.Make_convenience (System) (B)
include Connection_utils.Make_populate (System) (B)
end in
(module Connection : CONNECTION)
end
let () =
Caqti_platform.Driver_loader.register "pgx" (module Connect_functor)

39
unikernel/duniverse/ocaml-caqti/caqti-driver-pgx/lib/caqti_driver_pgx.mli Normal file
View file

@ -0,0 +1,39 @@
(* Copyright (C) 2022 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
(** PostgreSQL driver for Caqti based on pgx
This driver is implemented in terms of the pgx library.
It handles URIs of the form
{[
pgx://<user>:<password>@<host-or-directory>:<port>/<database>
]}
where [<host-or-directory>] is either a host name, an IP number, or a
directory containing the Unix domain socket of a locally running PostgreSQL
server. In the latter case, the directory must be percent-encoded, e.g.
{[
pgx://jdoe@%2fvar%2frun%2fpostgresql
]}
The interface provided by this module {e should normally not be used by
applications}, but provides access to some pgx specifics in case they are
needed. *)
(** {1 Error Details} *)
type Caqti_error.msg += Pgx_msg of string * Pgx.Error_response.t

14
unikernel/duniverse/ocaml-caqti/caqti-driver-pgx/lib/dune Normal file
View file

@ -0,0 +1,14 @@
(rule (copy# ../../shared/postgresql_conv.ml postgresql_conv.ml))
(library
(name caqti_driver_pgx)
(public_name caqti-driver-pgx)
(flags (:standard -alert -caqti_unstable))
(library_flags (:standard -linkall))
(libraries caqti caqti.platform domain-name ipaddr pgx))
(plugin
(package caqti-driver-pgx)
(name caqti-driver-pgx)
(libraries caqti-driver-pgx)
(site (caqti plugins)))

28
unikernel/duniverse/ocaml-caqti/caqti-driver-postgresql.opam Normal file
View file

@ -0,0 +1,28 @@
opam-version: "2.0"
name: "caqti-driver-postgresql"
maintainer: "Petter A. Urkedal <paurkedal@gmail.com>"
authors: [
"Petter A. Urkedal <paurkedal@gmail.com>"
"James Owen <james@cryptosense.com>"
]
license: "LGPL-3.0-or-later WITH LGPL-3.0-linking-exception"
homepage: "https://github.com/paurkedal/ocaml-caqti/"
doc: "https://paurkedal.github.io/ocaml-caqti/index.html"
bug-reports: "https://github.com/paurkedal/ocaml-caqti/issues"
depends: [
"alcotest" {with-test & >= "1.5.0"}
"ocaml"
"caqti" {>= "2.2.0" & < "2.3.0~"}
"cmdliner" {with-test & >= "1.1.0"}
"dune" {>= "3.9"}
"odoc" {with-doc}
"postgresql" {>= "5.0.0"}
"uri" {>= "4.0.0"}
]
build: [
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc}
]
dev-repo: "git+https://github.com/paurkedal/ocaml-caqti.git"
synopsis: "PostgreSQL driver for Caqti based on C bindings"

1059
unikernel/duniverse/ocaml-caqti/caqti-driver-postgresql/lib/caqti_driver_postgresql.ml Normal file
View file

File diff suppressed because it is too large Load diff

73
unikernel/duniverse/ocaml-caqti/caqti-driver-postgresql/lib/caqti_driver_postgresql.mli Normal file
View file

@ -0,0 +1,73 @@
(* Copyright (C) 2017--2023 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
(** PostgreSQL driver for Caqti (bindings).
This driver is implemented in terms of the postgresql OPAM package which
provides bindings for the PostgreSQL C client library.
It handles URIs of the form
{[
postgresql://<user>:<password>@<host>:<port>/<rest>
]}
which are passed verbatim to {!Postgresql.connection}, except as noted
below, and URIs of the form [postgresql://<query>] which are first split
into [<key> = '<value>'] form.
In addition to libpq parameters, the following will be interpreted by Caqti
and stripped of before passing the URI to libpq:
- [notice_processing] can be set to [quite] (the default) to suppress
notices or to [stderr] to let libpq emit notices to standard error.
- [use_single_row_mode] can be set to [true] to enable single row mode for
queries which may return more than one row. The default is [false]
because it is significantly faster. Single row mode is needed if query
results may exceed whan can be stored in memory, but consider batching
the results with [LIMIT] and [OFFSET] instead for better perfomance.
The interface provided by this module {e should normally not be used by
applications}, but provides access to some PostgreSQL specifics in case they
are needed. *)
(** {1 Error Details}
The following gives access to diagnostics collected from the PostgreSQL
connection and result objects. *)
type Caqti_error.msg +=
| Connect_error_msg of {
error: Postgresql.error;
(** The exception raised by postgresql-ocaml. *)
}
(** An exception was raised while attempting to connect to the database. *)
| Connection_error_msg of {
error: Postgresql.error;
(** The exception raised by postgresql-ocaml. *)
connection_status: Postgresql.connection_status;
(** The connection status reported by [PQstatus]. *)
}
(** An exception was raised while operating on the database connection. *)
| Result_error_msg of {
error_message: string;
(** The error message from [PQresultErrorMessage]. *)
sqlstate: string;
(** The SQLSTATE error field. *)
}
(** An error was reported on the result from a database operation. *)

14
unikernel/duniverse/ocaml-caqti/caqti-driver-postgresql/lib/dune Normal file
View file

@ -0,0 +1,14 @@
(rule (copy# ../../shared/postgresql_conv.ml postgresql_conv.ml))
(library
(name caqti_driver_postgresql)
(public_name caqti-driver-postgresql)
(flags (:standard -alert -caqti_unstable))
(library_flags (:standard -linkall))
(libraries caqti caqti.platform caqti.platform.unix postgresql))
(plugin
(package caqti-driver-postgresql)
(name caqti-driver-postgresql)
(libraries caqti-driver-postgresql)
(site (caqti plugins)))

15
unikernel/duniverse/ocaml-caqti/caqti-driver-postgresql/test/dune Normal file
View file

@ -0,0 +1,15 @@
(test
(name test_postgresql)
(package caqti-driver-postgresql)
(flags (:standard -alert -caqti_unstable))
(libraries
alcotest
caqti
caqti.blocking
caqti-driver-postgresql
testlib
testlib_blocking)
(deps ../../testsuite/uris.conf)
(action
(setenv CAQTI_TEST_URIS_FILE ../../testsuite/uris.conf
(run %{test}))))

62
unikernel/duniverse/ocaml-caqti/caqti-driver-postgresql/test/test_postgresql.ml Normal file
View file

@ -0,0 +1,62 @@
(* Copyright (C) 2021--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Testlib
open Testlib_blocking
let bad_select_req =
Caqti_template.Create.(static T.(unit -->! unit) "SELECT not_defined")
let test_error (module C : Caqti_blocking.CONNECTION) =
(match C.find bad_select_req () with
| Ok () -> Alcotest.fail "unexpected ok from bad_select"
| Error (`Request_failed
{msg = Caqti_driver_postgresql.Result_error_msg {sqlstate; _}; _}) ->
assert (sqlstate = "42703")
| Error err ->
Alcotest.failf "unexpected error from bad_select: %a" Caqti_error.pp err)
let test_cases_on_connection = [
"test_error", `Quick, test_error;
]
let mk_test (name, pool) =
let pass_conn (name, speed, f) =
let f' () =
Caqti_blocking.Pool.use (fun c -> Ok (f c)) pool |> function
| Ok () -> ()
| Error err -> Alcotest.failf "%a" Caqti_error.pp err
in
(name, speed, f')
in
let test_cases = List.map pass_conn test_cases_on_connection in
(name, test_cases)
let mk_tests {uris; connect_config = config} =
let connect_pool uri =
let pool_config = Caqti_pool_config.create ~max_size:1 () in
(match Caqti_blocking.connect_pool uri ~pool_config ~config with
| Ok pool -> (test_name_of_uri uri, pool)
| Error err -> raise (Caqti_error.Exn err))
in
let is_postgresql uri = Uri.scheme uri = Some "postgresql" in
let pools = List.map connect_pool (List.filter is_postgresql uris) in
List.map mk_test pools
let () =
Alcotest_cli.run_with_args_dependency "test_postgresql"
(common_args ()) mk_tests

24
unikernel/duniverse/ocaml-caqti/caqti-driver-sqlite3.opam Normal file
View file

@ -0,0 +1,24 @@
opam-version: "2.0"
name: "caqti-driver-sqlite3"
maintainer: "Petter A. Urkedal <paurkedal@gmail.com>"
authors: "Petter A. Urkedal <paurkedal@gmail.com>"
license: "LGPL-3.0-or-later WITH LGPL-3.0-linking-exception"
homepage: "https://github.com/paurkedal/ocaml-caqti/"
doc: "https://paurkedal.github.io/ocaml-caqti/index.html"
bug-reports: "https://github.com/paurkedal/ocaml-caqti/issues"
depends: [
"alcotest" {with-test & >= "1.5.0"}
"ocaml"
"caqti" {>= "2.2.0" & < "2.3.0~"}
"cmdliner" {with-test & >= "1.1.0"}
"dune" {>= "3.9"}
"odoc" {with-doc}
"sqlite3" {>= "5.0.1"}
]
build: [
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc}
]
dev-repo: "git+https://github.com/paurkedal/ocaml-caqti.git"
synopsis: "Sqlite3 driver for Caqti using C bindings"

656
unikernel/duniverse/ocaml-caqti/caqti-driver-sqlite3/lib/caqti_driver_sqlite3.ml Normal file
View file

@ -0,0 +1,656 @@
(* Copyright (C) 2017--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
[@@@alert "-caqti_private"]
open Caqti_template
open Caqti_platform
open Printf
let dialect =
let server_version =
Version.of_string_unsafe (Sqlite3.sqlite_version_info ())
in
Dialect.create_sqlite ~server_version ()
let driver_info = Caqti_driver_info.of_dialect dialect
type Caqti_connection_sig.driver_connection += Driver_connection of Sqlite3.db
let get_uri_bool uri name =
(match Uri.get_query_param uri name with
| Some ("true" | "yes") -> Some true
| Some ("false" | "no") -> Some false
| Some _ ->
ksprintf invalid_arg "Boolean expected for URI parameter %s." name
| None -> None)
let get_uri_int uri name =
(match Uri.get_query_param uri name with
| Some s ->
(try Some (int_of_string s) with
| Failure _ ->
ksprintf invalid_arg "Integer expected for URI parameter %s." name)
| None -> None)
type Caqti_error.msg += Error_msg of {
errcode: Sqlite3.Rc.t;
extended_errcode: int option;
errmsg: string option;
}
let cause_of_rc : Sqlite3.Rc.t * int option -> _ = function
| CONSTRAINT, Some 1299 -> `Not_null_violation
| CONSTRAINT, Some 787 -> `Foreign_key_violation
| CONSTRAINT, Some 2067 -> `Unique_violation
| CONSTRAINT, Some 275 -> `Check_violation
| CONSTRAINT, _ -> `Integrity_constraint_violation__don't_match
| NOMEM, _ -> `Out_of_memory
| FULL, _ -> `Disk_full
| _, _ -> `Unspecified__don't_match
let () =
let pp ppf = function
| Error_msg {errcode; errmsg; extended_errcode; _} ->
Format.pp_print_string ppf
(match errmsg with
| None -> Sqlite3.Rc.to_string errcode
| Some errmsg -> errmsg);
(match extended_errcode with
| None -> Format.pp_print_char ppf '.'
| Some erc -> Format.fprintf ppf " (ERC#%d)." erc)
| _ -> assert false
in
let cause = function
| Error_msg {errcode; extended_errcode; _} ->
cause_of_rc (errcode, extended_errcode)
| _ -> assert false
in
Caqti_error.define_msg ~pp ~cause [%extension_constructor Error_msg]
let wrap_rc =
(match Sqlite3_shim.extended_errcode_int with
| None ->
fun ?db errcode ->
let errmsg = Option.map Sqlite3.errmsg db in
Error_msg {errcode; errmsg; extended_errcode = None}
| Some extended_errcode_int ->
fun ?db errcode ->
let errmsg = Option.map Sqlite3.errmsg db in
let extended_errcode = Option.map extended_errcode_int db in
Error_msg {errcode; errmsg; extended_errcode})
let data_of_value : type a. a Field_type.t -> a -> Sqlite3.Data.t =
fun field_type x ->
(match field_type with
| Bool -> Sqlite3.Data.INT (if x then 1L else 0L)
| Int -> Sqlite3.Data.INT (Int64.of_int x)
| Int16 -> Sqlite3.Data.INT (Int64.of_int x)
| Int32 -> Sqlite3.Data.INT (Int64.of_int32 x)
| Int64 -> Sqlite3.Data.INT x
| Float -> Sqlite3.Data.FLOAT x
| String -> Sqlite3.Data.TEXT x
| Enum _ -> Sqlite3.Data.TEXT x
| Octets -> Sqlite3.Data.BLOB x
| Pdate -> Sqlite3.Data.TEXT (Conv.iso8601_of_pdate x)
| Ptime ->
(* This is the suggested time representation according to
https://sqlite.org/lang_datefunc.html, and is consistent with
current_timestamp. Three subsecond digits are significant. *)
let s = Ptime.to_rfc3339 ~space:true ~frac_s:3 ~tz_offset_s:0 x in
Sqlite3.Data.TEXT (String.sub s 0 23)
| Ptime_span ->
Sqlite3.Data.FLOAT (Ptime.Span.to_float_s x))
(* TODO: Check integer ranges? The Int64.to_* functions don't raise. *)
let value_of_data
: type a. uri: Uri.t -> a Field_type.t -> Sqlite3.Data.t -> a =
fun ~uri field_type data ->
let to_ptime_span x =
(match Ptime.Span.of_float_s x with
| Some t -> t
| None ->
let msg = Caqti_error.Msg "Interval out of range for Ptime.span." in
let typ = Row_type.field field_type in
Request_utils.raise_decode_rejected ~uri ~typ msg)
in
let cannot_convert_to ft =
let msg =
Printf.sprintf "Cannot convert %s to %s."
(Sqlite3.Data.to_string_debug data) ft
in
let typ = Row_type.field field_type in
Request_utils.raise_decode_rejected ~uri ~typ (Caqti_error.Msg msg)
in
(match field_type, data with
| Bool, Sqlite3.Data.INT y -> y <> 0L
| Bool, _ -> cannot_convert_to "bool"
| Int, Sqlite3.Data.INT y -> Int64.to_int y
| Int, _ -> cannot_convert_to "int"
| Int16, Sqlite3.Data.INT y -> Int64.to_int y
| Int16, _ -> cannot_convert_to "int"
| Int32, Sqlite3.Data.INT y -> Int64.to_int32 y
| Int32, _ -> cannot_convert_to "int32"
| Int64, Sqlite3.Data.INT y -> y
| Int64, _ -> cannot_convert_to "int64"
| Float, Sqlite3.Data.FLOAT y -> y
| Float, Sqlite3.Data.INT y -> Int64.to_float y
| Float, _ -> cannot_convert_to "float"
| String, Sqlite3.Data.TEXT y -> y
| String, _ -> cannot_convert_to "string"
| Enum _, Sqlite3.Data.TEXT y -> y
| Enum _, _ -> cannot_convert_to "enum"
| Octets, Sqlite3.Data.BLOB y -> y
| Octets, _ -> cannot_convert_to "octets"
| Pdate as field_type, Sqlite3.Data.TEXT y ->
(match Conv.pdate_of_iso8601 y with
| Ok y -> y
| Error msg ->
let msg = Caqti_error.Msg msg in
let typ = Row_type.field field_type in
Request_utils.raise_decode_rejected ~uri ~typ msg)
| Pdate, _ -> cannot_convert_to "date"
| Ptime as field_type, Sqlite3.Data.TEXT y ->
(* TODO: Improve parsing. *)
(match Conv.ptime_of_rfc3339_utc y with
| Ok y -> y
| Error msg ->
let msg = Caqti_error.Msg msg in
let typ = Row_type.field field_type in
Request_utils.raise_decode_rejected ~uri ~typ msg)
| Ptime, _ -> cannot_convert_to "time"
| Ptime_span, Sqlite3.Data.FLOAT x ->
to_ptime_span x
| Ptime_span, Sqlite3.Data.INT x ->
to_ptime_span (Int64.to_float x)
| Ptime_span, _ -> cannot_convert_to "time span")
let query_quotes q =
let rec loop : Query.t -> _ = function
| L _ | P _ | E _ -> Fun.id
| V (t, v) -> List.cons (data_of_value t v)
| Q s -> List.cons (Sqlite3.Data.TEXT s)
| S qs -> List_ext.fold loop qs
in
List.rev (loop q [])
let query_string q =
let quotes = query_quotes q in
let buf = Buffer.create 64 in
let iQ = ref 1 in
let iP0 = List.length quotes + 1 in
let rec loop : Query.t -> _ = function
| L s -> Buffer.add_string buf s
| V _ -> bprintf buf "?%d" !iQ; incr iQ
| Q _ -> bprintf buf "?%d" !iQ; incr iQ
| P i -> bprintf buf "?%d" (iP0 + i)
| E _ -> assert false
| S qs -> List.iter loop qs
in
loop q;
(quotes, Buffer.contents buf)
let bind_quotes ~uri ~db stmt oq =
let aux j x =
(match Sqlite3.bind stmt (j + 1) x with
| Sqlite3.Rc.OK -> Ok ()
| rc ->
let typ = Row_type.string in
Error (Caqti_error.encode_failed ~uri ~typ (wrap_rc ~db rc)))
in
List_ext.iteri_r aux oq
let encode_null_field ~uri ~db stmt field_type iP =
(match Sqlite3.bind stmt (iP + 1) Sqlite3.Data.NULL with
| Sqlite3.Rc.OK -> ()
| rc ->
let typ = Row_type.field field_type in
Request_utils.raise_encode_failed ~uri ~typ (wrap_rc ~db rc))
let encode_field ~uri ~db stmt field_type field_value iP =
let d = data_of_value field_type field_value in
(match Sqlite3.bind stmt (iP + 1) d with
| Sqlite3.Rc.OK -> ()
| rc ->
let typ = Row_type.field field_type in
Request_utils.raise_encode_failed ~uri ~typ (wrap_rc ~db rc))
let encode_param ~uri ~db stmt t =
let write_value ~uri ft fv iP = encode_field ~uri ~db stmt ft fv iP; iP + 1 in
let write_null ~uri ft iP = encode_null_field ~uri ~db stmt ft iP; iP + 1 in
let encode = Request_utils.encode_param ~uri {write_value; write_null} t in
fun x iP ->
try Ok (encode x iP) with
| Caqti_error.Exn (#Caqti_error.call as err) -> Error err
let decode_row ~uri ~query row_type =
let read_value ~uri ft (stmt, j) =
let fv = value_of_data ~uri ft (Sqlite3.column stmt j) in
(fv, (stmt, j + 1))
in
let skip_null n (stmt, j) =
let j' = j + n in
let rec check k =
k = j' || Sqlite3.column stmt k = Sqlite3.Data.NULL && check (k + 1)
in
if check j then Some (stmt, j') else None
in
let field_decoder = {Request_utils.read_value; skip_null} in
let decode = Request_utils.decode_row ~uri field_decoder row_type in
fun stmt ->
let (y, (_, n)) = decode (stmt, 0) in
let n' = Sqlite3.data_count stmt in
if n = n' then Some y else
let msg = sprintf "Decoded only %d of %d fields." n n' in
let msg = Caqti_error.Msg msg in
Request_utils.raise_response_rejected ~uri ~query msg
module Q = struct
open Caqti_template.Create
let start = static T.(unit -->. unit) "BEGIN"
let commit = static T.(unit -->. unit) "COMMIT"
let rollback = static T.(unit -->. unit) "ROLLBACK"
end
module Connect_functor
(System : Caqti_platform.System_sig.S)
(System_unix : Caqti_platform_unix.System_sig.S
with type 'a fiber := 'a System.Fiber.t
and type stdenv := System.stdenv) =
struct
open System
open System_unix
open System.Fiber.Infix
open System_utils.Monad_syntax (System.Fiber)
module H = Connection_utils.Make_helpers (System)
let driver_info = driver_info
module type CONNECTION = Caqti_connection_sig.S
with type 'a fiber := 'a Fiber.t
and type ('a, 'err) stream := ('a, 'err) Stream.t
module Make_connection_base
(Connection_arg : sig
val subst : Query.subst
val uri : Uri.t
val db : Sqlite3.db
val dynamic_capacity : int
end) =
struct
open Connection_arg
let using_db_ref = ref false
let using_db f =
H.assert_single_use ~what:"SQLite connection" using_db_ref f
module Response = struct
type ('b, 'm) t = {
stmt: Sqlite3.stmt;
row_type: 'b Row_type.t;
query: string;
mutable affected_count: int;
mutable has_been_executed: bool;
}
let returned_count _ = Fiber.return (Error `Unsupported)
let affected_count {affected_count; has_been_executed; query; _} =
if has_been_executed then Fiber.return (Ok affected_count) else
let msg =
Caqti_error.Msg
"Statement not executed yet, affected_count unavailable."
in
Fiber.return (Error (Caqti_error.response_rejected ~uri ~query msg))
let run_step response =
let ret = Sqlite3.step response.stmt in
if not response.has_been_executed then
begin
response.has_been_executed <- true;
response.affected_count <- Sqlite3.changes db
end;
ret
let fetch_row ({stmt; row_type; query; _} as response) =
let decode = decode_row ~uri ~query row_type in
fun () ->
(match run_step response with
| Sqlite3.Rc.DONE -> None
| Sqlite3.Rc.ROW -> decode stmt
| rc ->
Request_utils.raise_response_failed ~uri ~query (wrap_rc ~db rc))
let exec ({row_type; query; _} as response) =
assert (Row_type.unify row_type Row_type.unit <> None);
let retrieve () =
(match run_step response with
| Sqlite3.Rc.DONE -> Ok ()
| Sqlite3.Rc.ROW ->
let msg = Caqti_error.Msg "Received unexpected row for exec." in
Error (Caqti_error.response_rejected ~uri ~query msg)
| rc ->
Error (Caqti_error.response_failed ~uri ~query (wrap_rc ~db rc)))
in
Preemptive.detach retrieve ()
let find resp =
let retrieve () =
try
(match fetch_row resp () with
| None ->
let msg = Caqti_error.Msg "Received no rows for find." in
Error (Caqti_error.response_rejected ~uri ~query:resp.query msg)
| Some y ->
(match fetch_row resp () with
| None -> Ok y
| Some _ ->
let msg = "Received multiple rows for find." in
let msg = Caqti_error.Msg msg in
let query = resp.query in
Error (Caqti_error.response_rejected ~uri ~query msg)))
with Caqti_error.Exn (#Caqti_error.retrieve as err) -> Error err
in
Preemptive.detach retrieve ()
let find_opt resp =
let retrieve () =
try
(match fetch_row resp () with
| None -> Ok None
| Some y ->
(match fetch_row resp () with
| None -> Ok (Some y)
| Some _ ->
let msg = "Received multiple rows for find_opt." in
let msg = Caqti_error.Msg msg in
let query = resp.query in
Error (Caqti_error.response_rejected ~uri ~query msg)))
with Caqti_error.Exn (#Caqti_error.retrieve as err) -> Error err
in
Preemptive.detach retrieve ()
let fold f resp acc =
let fetch = fetch_row resp in
let retrieve acc =
let rec loop acc =
(match fetch () with
| None -> Ok acc
| Some y -> loop (f y acc))
in
try loop acc with
| Caqti_error.Exn (#Caqti_error.retrieve as err) -> Error err
in
Preemptive.detach retrieve acc
let fold_s f resp acc =
let fetch = fetch_row resp in
let retrieve acc =
let rec loop acc =
(match fetch () with
| None -> Ok acc
| Some y ->
(match Preemptive.run_in_main (fun () -> f y acc) with
| Ok acc -> loop acc
| Error _ as r -> r))
in
try loop acc with
| Caqti_error.Exn (#Caqti_error.retrieve as err) -> Error err
in
Preemptive.detach retrieve acc
let iter_s f resp =
let fetch = fetch_row resp in
let retrieve () =
let rec loop () =
(match fetch () with
| None -> Ok ()
| Some y ->
(match Preemptive.run_in_main (fun () -> f y) with
| Ok () -> loop ()
| Error _ as r -> r))
in
try loop () with
| Caqti_error.Exn (#Caqti_error.retrieve as err) -> Error err
in
Preemptive.detach retrieve ()
let to_stream resp =
let fetch = fetch_row resp in
let rec seq () =
(match fetch () with
| None -> Stream.Nil
| Some y -> Stream.Cons (y, Preemptive.detach seq)
| exception Caqti_error.Exn (#Caqti_error.retrieve as err) ->
Stream.Error err)
in
Preemptive.detach seq
end
module Pcache = Request_cache.Make (struct
type t = Sqlite3.stmt * Sqlite3.Data.t list * string
let weight _ = 1
end)
let pcache = Pcache.create ~dynamic_capacity dialect
let prepare req =
let prepare_helper query =
try
let stmt = Sqlite3.prepare db query in
(match Sqlite3.prepare_tail stmt with
| None -> Ok stmt
| Some stmt -> Ok stmt)
with Sqlite3.Error msg ->
let msg = Caqti_error.Msg msg in
Error (Caqti_error.request_failed ~uri ~query msg)
in
let templ = Request.query req dialect in
let templ = Query.expand subst templ in
let quotes, query = query_string templ in
Preemptive.detach prepare_helper query >|=? fun stmt ->
(stmt, quotes, query)
let pp_request_with_param ppf =
Request.make_pp_with_param ~subst ~dialect () ppf
let free_prepared (stmt, _, query) =
(match Sqlite3.finalize stmt with
| Sqlite3.Rc.OK -> Ok ()
| rc ->
let query = sprintf "DEALLOCATE (%s)" query in
Error (Caqti_error.request_failed ~uri ~query (wrap_rc ~db rc))
| exception Sqlite3.Error msg ->
let query = sprintf "DEALLOCATE (%s)" query in
let msg = Caqti_error.Msg msg in
Error (Caqti_error.request_failed ~uri ~query msg))
let deallocate req = using_db @@ fun () ->
(match Request.prepare_policy req with
| Dynamic | Static ->
(match Pcache.deallocate pcache req with
| None -> Fiber.return (Ok ())
| Some (entry, commit) ->
Preemptive.detach free_prepared entry >|=? commit)
| Direct -> failwith "deallocate called on oneshot request")
let deallocate_some () =
let rec loop = function
| [] -> Ok ()
| pcache_entry :: orphans ->
(match free_prepared pcache_entry with
| Ok () -> loop orphans
| r -> r)
in
let orphans, commit = Pcache.trim pcache in
Preemptive.detach loop orphans >|= Result.map commit
let call ~f req param = using_db @@ fun () ->
deallocate_some () >>=? fun () ->
Log.debug ~src:Logging.request_log_src (fun f ->
f "Sending %a" pp_request_with_param (req, param))
>>= fun () ->
let param_type = Request.param_type req in
let row_type = Request.row_type req in
(match Request.prepare_policy req with
| Direct -> prepare req
| Dynamic | Static ->
(match Pcache.find_and_promote pcache req with
| Some pcache_entry -> Fiber.return (Ok pcache_entry)
| None ->
prepare req >|=? fun pcache_entry ->
Pcache.add pcache req pcache_entry;
pcache_entry))
>>=? fun (stmt, quotes, query) ->
(* CHECKME: Does binding involve IO? *)
Fiber.return (bind_quotes ~uri ~db stmt quotes) >>=? fun () ->
let nQ = List.length quotes in
(match encode_param ~uri ~db stmt param_type param nQ with
| Ok nQP ->
let nP = Row_type.length param_type in
if nQP > nQ + nP then
failwith "Too many arguments passed to query; \
check that the parameter type is correct."
else
if nQP < nQ + nP then
failwith "Too few arguments passed to query; \
check that the parameter type is correct."
else
let resp = Response.{
stmt; query; row_type; has_been_executed=false; affected_count = -1;
} in
Fiber.return (Ok resp)
| Error _ as r -> Fiber.return r)
>>=? fun resp ->
(* CHECKME: Does finalize or reset involve IO? *)
let cleanup () =
(match Request.prepare_policy req with
| Direct ->
(match Sqlite3.finalize stmt with
| Sqlite3.Rc.OK -> Fiber.return ()
| rc ->
Log.warn (fun p ->
p "Ignoring error %s when finalizing statement."
(Sqlite3.Rc.to_string rc)))
| Dynamic | Static ->
(match Sqlite3.reset stmt with
| Sqlite3.Rc.OK -> Fiber.return ()
| _ ->
Log.warn (fun p ->
p "Dropping cache statement due to error.") >|= fun () ->
Pcache.remove_and_discard pcache req))
in
Fiber.finally (fun () -> f resp) cleanup
let disconnect () = using_db @@ fun () ->
let finalize_error_count = ref 0 in
let not_busy = ref false in
Preemptive.detach begin fun () ->
let uncache (stmt, _, _) =
(match Sqlite3.finalize stmt with
| Sqlite3.Rc.OK -> ()
| _ -> finalize_error_count := !finalize_error_count + 1) in
Pcache.iter uncache pcache;
not_busy := Sqlite3.db_close db
(* If this reports busy, it means we missed an Sqlite3.finalize or other
* cleanup action, so this should not happen. *)
end () >>= fun () ->
(if !finalize_error_count = 0 then Fiber.return () else
Log.warn (fun p ->
p "Finalization of %d during disconnect return error."
!finalize_error_count)) >>= fun () ->
(if !not_busy then Fiber.return () else
Log.warn (fun p -> p "Sqlite reported still busy when closing handle."))
let validate () = Fiber.return true
let check f = f true
let exec q p = call ~f:Response.exec q p
let start () = exec Q.start ()
let commit () = exec Q.commit ()
let rollback () = exec Q.rollback ()
let set_statement_timeout _ = Fiber.return (Ok ())
end
let setup ~config db =
let tweaks_version = Caqti_connect_config.(get tweaks_version) config in
if tweaks_version < (1, 8) then Fiber.return () else
Preemptive.detach (Sqlite3.exec db) "PRAGMA foreign_keys = ON"
>>= fun rc ->
if rc = Sqlite3.Rc.OK then Fiber.return () else
Log.warn (fun f ->
f "Could not turn on foreign key support: %s" (Sqlite3.Rc.to_string rc))
let connect ~sw:_ ~stdenv:_ ~subst ~config uri =
try
(* Check URI and extract parameters. *)
assert (Uri.scheme uri = Some "sqlite3");
(match Uri.userinfo uri, Uri.host uri with
| None, (None | Some "") -> ()
| _ -> invalid_arg "Sqlite URI cannot contain user or host components.");
let mode =
(match get_uri_bool uri "write", get_uri_bool uri "create" with
| Some false, Some true -> invalid_arg "Create mode presumes write."
| (Some false), (Some false | None) -> Some `READONLY
| (Some true | None), (Some true | None) -> None
| (Some true | None), (Some false) -> Some `NO_CREATE) in
let busy_timeout = get_uri_int uri "busy_timeout" in
(* Connect, configure, wrap. *)
Preemptive.detach
(fun () ->
Sqlite3.db_open ~mutex:`FULL ?mode (Uri.path uri |> Uri.pct_decode))
() >>= fun db ->
setup ~config db >|= fun () ->
(match busy_timeout with
| None -> ()
| Some timeout -> Sqlite3.busy_timeout db timeout);
let module Arg = struct
let subst = subst dialect
let uri = uri
let db = db
let dynamic_capacity =
Caqti_connect_config.(get dynamic_prepare_capacity) config
end in
let module Connection_base = Make_connection_base (Arg) in
let module Connection = struct
let driver_info = driver_info
let dialect = dialect
let driver_connection = Some (Driver_connection db)
include Connection_base
include Connection_utils.Make_convenience (System) (Connection_base)
include Connection_utils.Make_populate (System) (Connection_base)
end in
Ok (module Connection : CONNECTION)
with
| Invalid_argument msg ->
Fiber.return
(Error (Caqti_error.connect_rejected ~uri (Caqti_error.Msg msg)))
| Sqlite3.Error msg ->
Fiber.return
(Error (Caqti_error.connect_failed ~uri (Caqti_error.Msg msg)))
end
let () =
Caqti_platform_unix.Driver_loader.register "sqlite3" (module Connect_functor)

49
unikernel/duniverse/ocaml-caqti/caqti-driver-sqlite3/lib/caqti_driver_sqlite3.mli Normal file
View file

@ -0,0 +1,49 @@
(* Copyright (C) 2017--2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
(** Sqlite3 driver for Caqti (bindings).
This driver is implemented in terms of the sqlite3 OPAM package, which
provides bindings for libsqlite3. It handles URIs of the form
{[
sqlite3://<path>?create=<bool>&write=<bool>
]}
where [<path>] is passed to {!Sqlite3.db_open} and the query string is used
to determine its [mode] parameter. The [<bool>] parameters take the values
[true] and [false], and default to [true].
The interface provided by this module {e should normally not be used by
applications}, but provides access to some Sqlite3 specifics in case they
are needed. *)
(** {1 Error Details}
The following provides access to diagnostics collected from the Sqlite3
connection. *)
type Caqti_error.msg += Error_msg of {
errcode: Sqlite3.Rc.t;
(** The OCaml encoding of the error code reported by [sqlite3_errcode]. *)
extended_errcode: int option;
(** The extended result code, if available. *)
errmsg: string option;
(** The error message reportedy by [sqlite3_errmsg]. *)
}
(** {1 Access to Raw Connection Handle} *)
type Caqti_connection_sig.driver_connection += Driver_connection of Sqlite3.db

19
unikernel/duniverse/ocaml-caqti/caqti-driver-sqlite3/lib/dune Normal file
View file

@ -0,0 +1,19 @@
(library
(name caqti_driver_sqlite3)
(public_name caqti-driver-sqlite3)
(flags (:standard -thread -alert -caqti_unstable))
(library_flags (:standard -linkall))
(libraries caqti caqti.platform caqti.platform.unix sqlite3))
(plugin
(package caqti-driver-sqlite3)
(name caqti-driver-sqlite3)
(libraries caqti-driver-sqlite3)
(site (caqti plugins)))
(rule
(enabled_if (>= %{version:sqlite3} 5.2.0))
(action (copy# sqlite3_shim.5.2.ml sqlite3_shim.ml)))
(rule
(enabled_if (< %{version:sqlite3} 5.2.0))
(action (copy# sqlite3_shim.fallback.ml sqlite3_shim.ml)))

18
unikernel/duniverse/ocaml-caqti/caqti-driver-sqlite3/lib/sqlite3_shim.5.2.ml Normal file
View file

@ -0,0 +1,18 @@
(* Copyright (C) 2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
let extended_errcode_int = Some Sqlite3.extended_errcode_int

18
unikernel/duniverse/ocaml-caqti/caqti-driver-sqlite3/lib/sqlite3_shim.fallback.ml Normal file
View file

@ -0,0 +1,18 @@
(* Copyright (C) 2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
let extended_errcode_int = None

18
unikernel/duniverse/ocaml-caqti/caqti-driver-sqlite3/lib/sqlite3_shim.mli Normal file
View file

@ -0,0 +1,18 @@
(* Copyright (C) 2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
val extended_errcode_int : (Sqlite3.db -> int) option

16
unikernel/duniverse/ocaml-caqti/caqti-driver-sqlite3/test/dune Normal file
View file

@ -0,0 +1,16 @@
(test
(name test_sqlite3)
(package caqti-driver-sqlite3)
(flags (:standard -alert -caqti_unstable))
(libraries
alcotest
caqti
caqti.blocking
caqti-driver-sqlite3
testlib
testlib_blocking)
(deps ../../testsuite/uris.conf)
(locks /db/testsuite)
(action
(setenv CAQTI_TEST_URIS_FILE ../../testsuite/uris.conf
(run %{test}))))

90
unikernel/duniverse/ocaml-caqti/caqti-driver-sqlite3/test/test_sqlite3.ml Normal file
View file

@ -0,0 +1,90 @@
(* Copyright (C) 2021--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Testlib
open Testlib_blocking
module Req = Caqti_template.Create
let drop_req =
Req.(static T.(unit -->. unit)) "DROP TABLE IF EXISTS test_sqlite3"
let create_req =
Req.(direct T.(unit -->. unit))
"CREATE TABLE test_sqlite3 (integer primary key not null)"
let bad_insert_req =
Req.(static T.(unit -->! unit)) "INSERT INTO test_sqlite3 VALUES (1), (1)"
let test_error (module C : Caqti_blocking.CONNECTION) =
C.exec drop_req ()
|> Result.iter_error (Alcotest.failf "%a" Caqti_error.pp);
C.exec create_req ()
|> Result.iter_error (Alcotest.failf "%a" Caqti_error.pp);
(match C.find bad_insert_req () with
| Ok () -> Alcotest.fail "unexpected ok from bad_insert"
| Error (`Response_failed
{msg = Caqti_driver_sqlite3.Error_msg {errcode; _}; _}) ->
Alcotest.(check string) "result code"
"CONSTRAINT" (Sqlite3.Rc.to_string errcode)
| Error err ->
Alcotest.failf "unexpected error from bad_insert: %a" Caqti_error.pp err)
let trim_req =
Req.(static T.(string -->! string) "SELECT trim(?)")
let test_fun (module C : Caqti_blocking.CONNECTION) =
(match C.driver_connection with
| Some Caqti_driver_sqlite3.Driver_connection db ->
Sqlite3.create_fun1 db "trim" begin function
| TEXT s -> TEXT (String.trim s)
| x -> x
end;
assert (C.find trim_req " . " = Ok ".")
| Some _ -> assert false
| None -> assert false)
let test_cases_on_connection = [
"test_error", `Quick, test_error;
"test_fun", `Quick, test_fun;
]
let mk_test (name, pool) =
let pass_conn (name, speed, f) =
let f' () =
Caqti_blocking.Pool.use (fun c -> Ok (f c)) pool |> function
| Ok () -> ()
| Error err -> Alcotest.failf "%a" Caqti_error.pp err
in
(name, speed, f')
in
let test_cases = List.map pass_conn test_cases_on_connection in
(name, test_cases)
let mk_tests {uris; connect_config = config} =
let connect_pool uri =
let pool_config = Caqti_pool_config.create ~max_size:1 () in
(match Caqti_blocking.connect_pool uri ~pool_config ~config with
| Ok pool -> (test_name_of_uri uri, pool)
| Error err -> raise (Caqti_error.Exn err))
in
let is_sqlite3 uri = Uri.scheme uri = Some "sqlite3" in
let pools = List.map connect_pool (List.filter is_sqlite3 uris) in
List.map mk_test pools
let () =
Alcotest_cli.run_with_args_dependency "test_sqlite3" (common_args ()) mk_tests

32
unikernel/duniverse/ocaml-caqti/caqti-dynload.opam Normal file
View file

@ -0,0 +1,32 @@
opam-version: "2.0"
name: "caqti-dynload"
maintainer: "Petter A. Urkedal <paurkedal@gmail.com>"
authors: "Petter A. Urkedal <paurkedal@gmail.com>"
license: "LGPL-3.0-or-later WITH LGPL-3.0-linking-exception"
homepage: "https://github.com/paurkedal/ocaml-caqti/"
doc: "https://paurkedal.github.io/ocaml-caqti/index.html"
bug-reports: "https://github.com/paurkedal/ocaml-caqti/issues"
depends: [
"caqti" {>= "2.0.0" & < "3.0.0~"}
"dune" {>= "3.9"}
"ocaml"
"ocamlfind"
]
build: [
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
dev-repo: "git+https://github.com/paurkedal/ocaml-caqti.git"
synopsis: "Dynamic linking of Caqti drivers using findlib.dynload (deprecated)"
description: """
This package is deprecated, please use caqti.plugin instead.
This library registers a dynamic linker which will be called when
encoutering an unhandled database URI. It tries to load a findlib package
named "caqti-driver-<scheme>" where "<scheme>" is the scheme of the URI,
which is expected register a driver for the scheme.
This is a separate package to avoid the dependency on the findlib.dynload
for architectures, like MirageOS, where dynamic linking may be unavailable.
The alternative is to link drivers directly into the application.
"""

52
unikernel/duniverse/ocaml-caqti/caqti-dynload/lib/caqti_dynload.ml Normal file
View file

@ -0,0 +1,52 @@
(* Copyright (C) 2017--2018 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
let debug =
try bool_of_string (Sys.getenv "CAQTI_DEBUG_DYNLOAD")
with Not_found -> false
let backend_predicates () =
(match Sys.backend_type with
| Sys.Native -> ["native"]
| Sys.Bytecode -> ["byte"]
| Sys.Other _ -> [])
let init = lazy begin
let predicates = backend_predicates () in
Findlib.init ();
Findlib.record_package_predicates predicates;
List.iter (Findlib.record_package Record_core)
(Findlib.package_deep_ancestors predicates ["caqti"]);
if debug then
Printf.eprintf "\
[DEBUG] Caqti_dynload: recorded_predicates = %s\n\
[DEBUG] Caqti_dynload: recorded_packages.core = %s\n\
[DEBUG] Caqti_dynload: recorded_packages.load = %s\n%!"
(String.concat " " (Findlib.recorded_predicates ()))
(String.concat " " (Findlib.recorded_packages Record_core))
(String.concat " " (Findlib.recorded_packages Record_load))
end
let () = Caqti_platform.Connector.define_loader @@ fun pkg ->
Lazy.force init;
if debug then
Printf.eprintf "[DEBUG] Caqti_dynload: requested package: %s\n" pkg;
(try Ok (Fl_dynload.load_packages ~debug [pkg]) with
| Dynlink.Error err -> Error (Dynlink.error_message err)
| Findlib.No_such_package (_pkg, info) -> Error info)
module Weak_ = struct include Weak end (* for caqti-driver-mariadb *)

23
unikernel/duniverse/ocaml-caqti/caqti-dynload/lib/caqti_dynload.mli Normal file
View file

@ -0,0 +1,23 @@
(* Copyright (C) 2017--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
(** Dynamic linker for database drivers (deprecated).
@deprecated This packgae has been replaced by the caqti.plugin library. *)
[@@@alert deprecated
"This package has been replaced by the caqti.plugin library."]

5
unikernel/duniverse/ocaml-caqti/caqti-dynload/lib/dune Normal file
View file

@ -0,0 +1,5 @@
(library
(name caqti_dynload)
(public_name caqti-dynload)
(library_flags (-linkall))
(libraries caqti caqti.platform findlib.dynload))

28
unikernel/duniverse/ocaml-caqti/caqti-eio.opam Normal file
View file

@ -0,0 +1,28 @@
opam-version: "2.0"
name: "caqti-eio"
maintainer: "Petter A. Urkedal <paurkedal@gmail.com>"
authors: "Petter A. Urkedal <paurkedal@gmail.com>"
license: "LGPL-3.0-or-later WITH LGPL-3.0-linking-exception"
homepage: "https://github.com/paurkedal/ocaml-caqti/"
doc: "https://paurkedal.github.io/ocaml-caqti/index.html"
bug-reports: "https://github.com/paurkedal/ocaml-caqti/issues"
depends: [
"caqti" {>= "2.2.3" & < "2.3.0~"}
"dune" {>= "3.9"}
"eio" {>= "0.12"}
"logs"
"ocaml" {>= "5.0.0~"}
"alcotest" {with-test & >= "1.5.0"}
"caqti-driver-sqlite3" {with-test}
"cmdliner" {with-test & >= "1.1.0"}
"eio_main" {with-test}
"mirage-crypto-rng" {with-test & >= "1.2.0"}
"odoc" {with-doc}
]
build: [
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc}
]
dev-repo: "git+https://github.com/paurkedal/ocaml-caqti.git"
synopsis: "Eio support for Caqti"

23
unikernel/duniverse/ocaml-caqti/caqti-eio/lib-unix/caqti_eio_unix.ml Normal file
View file

@ -0,0 +1,23 @@
(* Copyright (C) 2022--2023 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Caqti_platform
open Caqti_platform_unix
module Loader = Driver_loader.Make (Caqti_eio.System) (System_unix)
include Connector.Make (Caqti_eio.System) (Caqti_eio.Pool) (Loader)

33
unikernel/duniverse/ocaml-caqti/caqti-eio/lib-unix/caqti_eio_unix.mli Normal file
View file

@ -0,0 +1,33 @@
(* Copyright (C) 2022--2023 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
(** Establinging Connections for Eio with Unix
This module provides database connections for applications using Eio. It
supports all database drivers.
{b The caqti-eio library should be considered unstable} for now. Eio is in
active development including its API, and the Caqti interface to it may
benefit from further revision before the first major Eio release lands. *)
include Caqti_connect_sig.S
with type 'a fiber := 'a
and type ('a, 'e) stream := ('a, 'e) Caqti_eio.Stream.t
and type ('a, 'e) pool := ('a, 'e) Caqti_eio.Pool.t
and type connection := Caqti_eio.connection
and type 'a with_switch := sw: Eio.Switch.t -> 'a
and type 'a with_stdenv := stdenv: Caqti_eio.stdenv -> 'a

12
unikernel/duniverse/ocaml-caqti/caqti-eio/lib-unix/dune Normal file
View file

@ -0,0 +1,12 @@
(library
(name caqti_eio_unix)
(public_name caqti-eio.unix)
(enabled_if (>= %{ocaml_version} "5.0"))
(libraries
caqti
caqti.platform
caqti.platform.unix
caqti-eio
eio
eio.unix
logs))

50
unikernel/duniverse/ocaml-caqti/caqti-eio/lib-unix/system_unix.ml Normal file
View file

@ -0,0 +1,50 @@
(* Copyright (C) 2022--2023 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
include Caqti_eio.System
module Unix = struct
type file_descr = Unix.file_descr
let wrap_fd f fd = f fd
let poll ~stdenv ?(read = false) ?(write = false) ?timeout fd =
let f () =
(match read, write with
| false, false ->
(false, false, false)
| true, true ->
Eio.Fiber.first
(fun () -> Eio_unix.await_readable fd; (true, false, false))
(fun () -> Eio_unix.await_writable fd; (false, true, false))
| true, false ->
Eio_unix.await_readable fd; (true, false, false)
| false, true ->
Eio_unix.await_writable fd; (false, true, false))
in
(match timeout with
| None -> f ()
| Some t ->
(match Eio.Time.with_timeout stdenv#clock t (fun () -> Ok (f ())) with
| Ok r -> r
| Error `Timeout -> (false, false, true)))
end
module Preemptive = struct
let detach f x = Eio_unix.run_in_systhread (fun () -> f x)
let run_in_main f = f () (* FIXME *)
end

39
unikernel/duniverse/ocaml-caqti/caqti-eio/lib/caqti_eio.ml Normal file
View file

@ -0,0 +1,39 @@
(* Copyright (C) 2022--2023 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Caqti_platform
module Stream = System.Stream
module System = System
type stdenv = System.stdenv
module Pool = Caqti_platform.Pool.Make (System) (System.Alarm)
module Loader = Caqti_platform.Driver_loader.Make (System)
module type CONNECTION = Caqti_connection_sig.S
with type 'a fiber := 'a
and type ('a, 'e) stream := ('a, 'e) Stream.t
type connection = (module CONNECTION)
include Connector.Make (System) (Pool) (Loader)
let or_fail = function
| Ok x -> x
| Error (#Caqti_error.t as err) -> raise (Caqti_error.Exn err)

79
unikernel/duniverse/ocaml-caqti/caqti-eio/lib/caqti_eio.mli Normal file
View file

@ -0,0 +1,79 @@
(* Copyright (C) 2022--2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
(** Establishing Connections for Eio without Unix
{b Note that} the {!connect}, {!with_connection}, and {!connect_pool}
functions from this module only provides support for caqti-driver-pgx (i.e.
the [pgx] URI scheme). The other database drivers are based on C bindings
which require UNIX facilities provided by {!Caqti_eio_unix.connect},
{!Caqti_eio_unix.with_connection}, and {!Caqti_eio_unix.connect_pool},
respectively.
{b The caqti-eio library should be considered unstable} for now. Eio is in
active development including its API, and the Caqti interface to it may
benefit from further revision before the first major Eio release lands. *)
type stdenv = <
net : [`Generic] Eio.Net.ty Eio.Std.r;
clock : float Eio.Time.clock_ty Eio.Std.r;
mono_clock : Eio.Time.Mono.ty Eio.Std.r;
>
module Stream : Caqti_stream_sig.S with type 'a fiber := 'a
(**/**) (* for private use by caqti-eio.unix *)
module System : Caqti_platform.System_sig.S
with type 'a Fiber.t = 'a
and type Switch.t = Eio.Switch.t
and type stdenv = stdenv
and module Stream = Stream
and type Net.tcp_flow =
[Eio.Flow.two_way_ty | Eio.Resource.close_ty] Eio.Resource.t
and type Net.tls_flow =
[Eio.Flow.two_way_ty | Eio.Resource.close_ty | `Tls] Eio.Resource.t
(**/**)
module Pool : sig
include Caqti_pool_sig.S with type 'a fiber := 'a
(**/**)
val create :
?config: Caqti_pool_config.t ->
?check: ('a -> (bool -> unit) -> unit) ->
?validate: ('a -> bool) ->
?log_src: Logs.Src.t ->
sw: Eio.Switch.t ->
stdenv: stdenv ->
(unit -> ('a, 'e) result) -> ('a -> unit) ->
('a, 'e) t
end
module type CONNECTION = Caqti_connection_sig.S
with type 'a fiber := 'a
and type ('a, 'e) stream := ('a, 'e) Stream.t
include Caqti_connect_sig.S
with type 'a fiber := 'a
and type 'a with_switch := sw: Eio.Switch.t -> 'a
and type 'a with_stdenv := stdenv: stdenv -> 'a
and type ('a, 'e) stream := ('a, 'e) Stream.t
and type ('a, 'e) pool := ('a, 'e) Pool.t
and type connection = (module CONNECTION)
val or_fail : ('a, [< Caqti_error.t]) result -> 'a
(** Eliminates the error-case by raising {!Caqti_error.Exn}. *)

9
unikernel/duniverse/ocaml-caqti/caqti-eio/lib/dune Normal file
View file

@ -0,0 +1,9 @@
(library
(name caqti_eio)
(public_name caqti-eio)
(enabled_if (>= %{ocaml_version} "5.0"))
(libraries
caqti
caqti.platform
eio
logs))

228
unikernel/duniverse/ocaml-caqti/caqti-eio/lib/system.ml Normal file
View file

@ -0,0 +1,228 @@
(* Copyright (C) 2022--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Caqti_platform
type Caqti_error.msg += Msg_io of Eio.Exn.err * Eio.Exn.context
let () =
let pp ppf = function
| Msg_io (err, ctx) -> Eio.Exn.pp ppf (Eio.Exn.Io (err, ctx))
| _ -> assert false
in
Caqti_error.define_msg ~pp [%extension_constructor Msg_io]
module Fiber = struct
type 'a t = 'a
module Infix = struct
let (>>=) x f = f x
let (>|=) x f = f x
end
let return x = x
let catch f g = try f () with exn -> g exn
let finally f g =
(match f () with
| y -> g (); y
| exception exn -> g (); raise exn)
let cleanup f g = try f () with exn -> g (); raise exn
end
module Stream = Caqti_platform.Stream.Make (Fiber)
module Mutex = Eio.Mutex
module Condition = struct
include Eio.Condition
let wait = await
let signal = broadcast (* does not matter for our purpose *)
end
module Log = struct
type 'a log = 'a Logs.log
let err ?(src = Logging.default_log_src) = Logs.err ~src
let warn ?(src = Logging.default_log_src) = Logs.warn ~src
let info ?(src = Logging.default_log_src) = Logs.info ~src
let debug ?(src = Logging.default_log_src) = Logs.debug ~src
end
type stdenv = <
net : [`Generic] Eio.Net.ty Eio.Std.r;
clock : float Eio.Time.clock_ty Eio.Std.r;
mono_clock : Eio.Time.Mono.ty Eio.Std.r;
>
module Switch = struct
include Eio.Switch
let run f = run f (* avoids compatibilty issues due to optional arguments *)
end
(* TODO: Log error. *)
let async = Eio.Fiber.fork
module Sequencer = struct
type 'a t = 'a * Eio.Mutex.t
let create x = (x, Eio.Mutex.create ())
let enqueue (x, mutex) f =
(* Using Eio.Mutex.use_rw without handling exceptions poisons the mutex,
* preventing recovery from e.g. a statement timeout. *)
Eio.Mutex.lock mutex;
Fun.protect ~finally:(fun () -> Eio.Mutex.unlock mutex) (fun () -> f x)
end
module Alarm = struct
type t = Eio.Cancel.t
exception Unscheduled
let schedule ~sw ~stdenv t f =
let alarm = ref None in
Eio.Fiber.fork ~sw begin fun () ->
Eio.Cancel.sub begin fun cctx ->
alarm := Some cctx;
Eio.Time.Mono.sleep_until stdenv#mono_clock t;
f ()
end
end;
Option.get !alarm
let unschedule alarm =
Eio.Cancel.cancel alarm Unscheduled
end
module Net = struct
module Sockaddr = struct
type t = Eio.Net.Sockaddr.stream
let tcp ((addr : Ipaddr.t), port) =
let addr_octets =
(match addr with
| V4 addr4 -> Ipaddr.V4.to_octets addr4
| V6 addr6 -> Ipaddr.V6.to_octets addr6)
in
`Tcp (Eio.Net.Ipaddr.of_raw addr_octets, port)
let unix path = `Unix path
end
let getaddrinfo ~stdenv host port =
try
Eio.Net.getaddrinfo_stream stdenv#net
~service:(string_of_int port) (Domain_name.to_string host)
|> Result.ok
with Eio.Exn.Io _ as exn ->
Error (`Msg (Format.asprintf "%a" Eio.Exn.pp exn))
let convert_io_exception = function
| Eio.Exn.Io (err, ctx) -> Some (Msg_io (err, ctx))
| _ -> None
module Socket = struct
type t = {
flow: [Eio.Flow.two_way_ty | Eio.Resource.close_ty] Eio.Resource.t;
ic: Eio.Buf_read.t;
oc: Eio.Buf_write.t;
}
let output_char {oc; _} c = Eio.Buf_write.char oc c
let output_string {oc; _} s = Eio.Buf_write.string oc s
let flush {oc; _} = Eio.Buf_write.flush oc
let input_char {ic; _} =
Eio.Buf_read.ensure ic 1;
let ch = Cstruct.get_char (Eio.Buf_read.peek ic) 0 in
Eio.Buf_read.consume ic 1;
ch
let really_input {ic; _} buf i n =
Eio.Buf_read.ensure ic n;
Cstruct.blit_to_bytes (Eio.Buf_read.peek ic) 0 buf i n;
Eio.Buf_read.consume ic n
let close {flow; oc; _} =
Log.debug (fun m -> m "Closing socket.");
Eio.Buf_write.close oc;
Eio.Flow.shutdown flow `Send;
Eio.Flow.close flow
end
type tcp_flow =
[Eio.Flow.two_way_ty | Eio.Resource.close_ty] Eio.Resource.t
type tls_flow =
[Eio.Flow.two_way_ty | Eio.Resource.close_ty | `Tls] Eio.Resource.t
let tcp_flow_of_socket {Socket.flow; ic; oc} =
Log.debug (fun m -> m "Enabling TLS.");
assert (Eio.Buf_write.pending_bytes oc = 0);
assert (Eio.Buf_read.buffered_bytes ic = 0);
Eio.Buf_write.close oc;
Some flow
let start_writer ~which oc flow =
Log.debug (fun m -> m "%s writer started." which);
try
while true; do
let iovecs = Eio.Buf_write.await_batch oc in
let n = Eio.Flow.single_write flow iovecs in
Eio.Buf_write.shift oc n
done
with End_of_file ->
Log.debug (fun m -> m "%s writer finished." which)
let socket_of_flow ~which ~sw flow =
let ic = Eio.Buf_read.of_flow ~max_size:4096 flow in
let oc = Eio.Buf_write.create 4096 in
Eio.Fiber.fork ~sw (fun () -> start_writer ~which oc flow);
{Socket.flow; ic; oc}
let socket_of_tls_flow ~sw flow =
socket_of_flow ~which:"TLS" ~sw (flow : tls_flow :> tcp_flow)
let connect_tcp ~sw ~stdenv sockaddr =
try
let flow =
(Eio.Net.connect ~sw stdenv#net sockaddr
:> [Eio.Flow.two_way_ty | Eio.Resource.close_ty] Eio.Resource.t)
in
Ok (socket_of_flow ~which:"TCP" ~sw flow)
with Eio.Exn.Io (err, ctx) ->
Error (Msg_io (err, ctx))
module type TLS_PROVIDER = Caqti_platform.System_sig.TLS_PROVIDER
with type 'a fiber := 'a
and type tcp_flow := tcp_flow
and type tls_flow := tls_flow
let tls_providers_r : (module TLS_PROVIDER) list ref = ref []
let register_tls_provider p = tls_providers_r := p :: !tls_providers_r
let tls_providers config =
if Caqti_connect_config.mem_name "tls" config then
(match Caqti_platform.Connector.load_library "caqti-tls-eio" with
| Ok () -> ()
| Error msg ->
Log.warn (fun p ->
p "TLS configured, but missing caqti-tls-eio: %s" msg));
!tls_providers_r
end

8
unikernel/duniverse/ocaml-caqti/caqti-eio/testlib-unix/dune Normal file
View file

@ -0,0 +1,8 @@
(library
(name testlib_eio_unix)
(enabled_if (>= %{ocaml_version} "5.0"))
(libraries
alcotest
caqti
caqti_eio_unix
testlib))

44
unikernel/duniverse/ocaml-caqti/caqti-eio/testlib-unix/testlib_eio_unix.ml Normal file
View file

@ -0,0 +1,44 @@
(* Copyright (C) 2022--2023 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
include Caqti_eio.System
include Caqti_eio
include Caqti_eio_unix
module Fiber = struct
include Fiber
let fail = raise
module Infix = struct
include Infix
let (>>=?) x f = match x with Ok x -> f x | Error _ as r -> r
let (>|=?) x f = match x with Ok x -> Ok (f x) | Error _ as r -> r
end
end
open Fiber.Infix
module Alcotest_cli =
Testlib.Make_alcotest_cli
(Alcotest.Unix_platform)
(Alcotest_engine.Monad.Identity)
module List_result_fiber = struct
let rec iter_s f = function
| [] -> Fiber.return (Ok ())
| x :: xs -> f x >>=? fun () -> iter_s f xs
end

21
unikernel/duniverse/ocaml-caqti/caqti-eio/testlib-unix/testlib_eio_unix.mli Normal file
View file

@ -0,0 +1,21 @@
(* Copyright (C) 2022--2023 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
include Testlib.Sig.Ground
with type 'a Fiber.t = 'a
and module Stream = Caqti_eio.Stream
and module Pool = Caqti_eio.Pool

30
unikernel/duniverse/ocaml-caqti/caqti-lwt.opam Normal file
View file

@ -0,0 +1,30 @@
opam-version: "2.0"
name: "caqti-lwt"
maintainer: "Petter A. Urkedal <paurkedal@gmail.com>"
authors: "Petter A. Urkedal <paurkedal@gmail.com>"
license: "LGPL-3.0-or-later WITH LGPL-3.0-linking-exception"
homepage: "https://github.com/paurkedal/ocaml-caqti/"
doc: "https://paurkedal.github.io/ocaml-caqti/index.html"
bug-reports: "https://github.com/paurkedal/ocaml-caqti/issues"
depends: [
"caqti" {>= "2.2.3" & < "2.3.0~"}
"dune" {>= "3.9"}
"domain-name"
"ipaddr"
"logs"
"mtime" {>= "2.0.0"}
"lwt" {>= "5.3.0"}
"ocaml"
"alcotest" {with-test & >= "1.5.0"}
"alcotest-lwt" {with-test & >= "1.5.0"}
"cmdliner" {with-test & >= "1.1.0"}
"caqti-driver-sqlite3" {with-test}
"odoc" {with-doc}
]
build: [
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc}
]
dev-repo: "git+https://github.com/paurkedal/ocaml-caqti.git"
synopsis: "Lwt support for Caqti"

38
unikernel/duniverse/ocaml-caqti/caqti-lwt/lib-unix/caqti_lwt_unix.ml Normal file
View file

@ -0,0 +1,38 @@
(* Copyright (C) 2014--2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Caqti_platform
module System = System
module Pool = System.Pool
module Loader = Caqti_platform_unix.Driver_loader.Make (System) (System_unix)
include Connector.Make (System) (Pool) (Loader)
let connect
?subst ?env ?config ?tweaks_version ?(sw = Caqti_lwt.Switch.eternal) uri =
connect ?subst ?env ?config ?tweaks_version ~sw ~stdenv:() uri
let with_connection = with_connection ~stdenv:()
let connect_pool
?pool_config ?post_connect ?subst ?env ?config ?tweaks_version
?(sw = Caqti_lwt.Switch.eternal) uri =
connect_pool
?pool_config ?post_connect ?subst ?env ?config ?tweaks_version
~sw ~stdenv:() uri

37
unikernel/duniverse/ocaml-caqti/caqti-lwt/lib-unix/caqti_lwt_unix.mli Normal file
View file

@ -0,0 +1,37 @@
(* Copyright (C) 2014--2023 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
(** Connecting on Unix-like platforms using Lwt
This module contains functions for connecting to databases using the
lwt.unix library, providing support for all drivers.
See also {!Caqti_lwt} for basic Lwt support. *)
(**/**) (* for test_pool_lwt.ml *)
module System = System
(**/**)
module Pool : Caqti_pool_sig.S with type 'a fiber := 'a Lwt.t
include Caqti_connect_sig.S
with type 'a fiber := 'a Lwt.t
and type ('a, 'e) stream := ('a, 'e) Caqti_lwt.Stream.t
and type ('a, 'e) pool := ('a, 'e) Pool.t
and type connection := Caqti_lwt.connection
and type 'a with_switch := ?sw: Caqti_lwt.Switch.t -> 'a
and type 'a with_stdenv := 'a

8
unikernel/duniverse/ocaml-caqti/caqti-lwt/lib-unix/dune Normal file
View file

@ -0,0 +1,8 @@
(library
(name caqti_lwt_unix)
(public_name caqti-lwt.unix)
(libraries
caqti caqti-lwt caqti.platform caqti.platform.unix
domain-name ipaddr
logs logs.lwt lwt lwt.unix
mtime mtime.clock.os))

148
unikernel/duniverse/ocaml-caqti/caqti-lwt/lib-unix/system.ml Normal file
View file

@ -0,0 +1,148 @@
(* Copyright (C) 2023--2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Lwt.Infix
type Caqti_error.msg += Msg_unix of Unix.error * string * string
let () =
let pp ppf = function
| Msg_unix (err, func, arg) ->
Format.fprintf ppf "%s in %s(%S)" (Unix.error_message err) func arg
| _ -> assert false
in
Caqti_error.define_msg ~pp [%extension_constructor Msg_unix]
module System_core = struct
include Caqti_lwt.System_core
type stdenv = unit
end
include System_core
module Alarm = struct
type t = {cancel: unit -> unit}
let schedule ~sw:_ ~stdenv:() t f =
let t_now = Mtime_clock.now () in
let delay =
if Mtime.is_later t ~than:t_now then
Lwt.pause ()
else
Lwt_unix.sleep (Mtime.Span.to_float_ns (Mtime.span t t_now) *. 1e-9)
in
let task = delay >|= f in
{cancel = (fun () -> Lwt.cancel task)}
let unschedule alarm = alarm.cancel ()
end
module Stream = Caqti_lwt.Stream
module Pool = Caqti_platform.Pool.Make (System_core) (Alarm)
module Net = struct
module type SOCKET_OPS = Caqti_platform.System_sig.SOCKET_OPS
with type 'a fiber := 'a Lwt.t
and type t = Lwt_io.input_channel * Lwt_io.output_channel
module Sockaddr = struct
type t = Unix.sockaddr
let unix s = Unix.ADDR_UNIX s
let tcp (addr, port) =
Unix.ADDR_INET (Unix.inet_addr_of_string (Ipaddr.to_string addr), port)
end
let getaddrinfo ~stdenv:() host port =
Lwt.catch
(fun () ->
let opts = Unix.[AI_SOCKTYPE SOCK_STREAM] in
Lwt_unix.getaddrinfo
(Domain_name.to_string host) (string_of_int port) opts
>|= List.map (fun ai -> ai.Unix.ai_addr) >|= Result.ok)
(function
| Not_found -> Lwt.return_ok []
| Unix.Unix_error (code, _, _) ->
Lwt.return_error
(`Msg ("Cannot resolve host name: " ^ Unix.error_message code))
| exn -> Lwt.fail exn)
let convert_io_exception = function
| Unix.Unix_error (err, fn, arg) -> Some (Msg_unix (err, fn, arg))
| _ -> None
type socket = {
fd: Lwt_unix.file_descr option;
ic: Lwt_io.input_channel;
oc: Lwt_io.output_channel;
}
module Socket = struct
type t = socket
let output_char {oc; _} data = Lwt_io.write_char oc data
let output_string {oc; _} data = Lwt_io.write oc data
let flush {oc; _} = Lwt_io.flush oc
let input_char {ic; _} = Lwt_io.read_char ic
let really_input {ic; _} data offset length =
Lwt_io.read_into_exactly ic data offset length
let close {oc; _} = Lwt_io.close oc (* CHECKME *)
end
type tcp_flow = Lwt_unix.file_descr
type tls_flow = Lwt_io.input_channel * Lwt_io.output_channel
let connect_tcp ~sw:_ ~stdenv:() sockaddr =
let domain = Unix.domain_of_sockaddr sockaddr in
let fd = Lwt_unix.socket domain Unix.SOCK_STREAM 0 in
Lwt.catch
(fun () ->
(try Lwt_unix.set_close_on_exec fd with _ -> ());
Lwt_unix.connect fd sockaddr >|= fun () ->
let ic = Lwt_io.(of_fd ~mode:input) fd in
let oc = Lwt_io.(of_fd ~mode:output) fd in
Ok {fd = Some fd; ic; oc})
(function
| Unix.Unix_error (err, fn, arg) ->
Lwt_unix.close fd >|= fun () ->
Error (Msg_unix (err, fn, arg))
| exn ->
Lwt_unix.close fd >>= fun () ->
Lwt.fail exn)
let tcp_flow_of_socket {fd; _} = fd
let socket_of_tls_flow ~sw:_ (ic, oc) = {fd = None; ic; oc}
module type TLS_PROVIDER = Caqti_platform.System_sig.TLS_PROVIDER
with type 'a fiber := 'a Lwt.t
and type tcp_flow := tcp_flow
and type tls_flow := tls_flow
let tls_providers_r : (module TLS_PROVIDER) list ref = ref []
let tls_providers config =
if Caqti_connect_config.mem_name "tls" config then
(match Caqti_platform.Connector.load_library "caqti-tls-lwt.unix" with
| Ok () -> ()
| Error msg ->
Logs.warn ~src:Caqti_platform.Logging.default_log_src (fun p ->
p "TLS configured, but missing caqti-tls-lwt.unix: %s" msg));
!tls_providers_r
let register_tls_provider p = tls_providers_r := p :: !tls_providers_r
end

35
unikernel/duniverse/ocaml-caqti/caqti-lwt/lib-unix/system.mli Normal file
View file

@ -0,0 +1,35 @@
(* Copyright (C) 2023 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
(**/**)
include Caqti_platform.System_sig.S
with type 'a Fiber.t = 'a Lwt.t
and type stdenv = unit
and module Stream = Caqti_lwt.Stream
and type Switch.t = Caqti_lwt.Switch.t
and type Net.tcp_flow = Lwt_unix.file_descr
and type Net.tls_flow = Lwt_io.input_channel * Lwt_io.output_channel
module Alarm : Caqti_platform.Pool.ALARM
with type switch := Switch.t
and type stdenv := unit
module Pool : Caqti_platform.Pool.S
with type 'a fiber := 'a Lwt.t
and type switch := Switch.t
and type stdenv := unit

44
unikernel/duniverse/ocaml-caqti/caqti-lwt/lib-unix/system_unix.ml Normal file
View file

@ -0,0 +1,44 @@
(* Copyright (C) 2023 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Lwt.Infix
module Preemptive = Lwt_preemptive
module Unix = struct
type file_descr = Lwt_unix.file_descr
let wrap_fd f fd = f (Lwt_unix.of_unix_file_descr fd)
let poll ~stdenv:() ?(read = false) ?(write = false) ?timeout fd =
let choices = []
|> (fun acc -> if read then Lwt_unix.wait_read fd :: acc else acc)
|> (fun acc -> if write then Lwt_unix.wait_write fd :: acc else acc)
|> Option.fold
~none:Fun.id ~some:(fun t acc -> Lwt_unix.timeout t :: acc) timeout
in
if choices = [] then
Lwt.fail_invalid_arg "Caqti_lwt.Unix.poll: No operation specified."
else
Lwt.catch
(fun () -> Lwt.choose choices >|= fun _ -> false)
(function
| Lwt_unix.Timeout -> Lwt.return_true
| exn -> Lwt.fail exn)
>|= fun timed_out ->
(Lwt_unix.readable fd, Lwt_unix.writable fd, timed_out)
end

78
unikernel/duniverse/ocaml-caqti/caqti-lwt/lib/caqti_lwt.ml Normal file
View file

@ -0,0 +1,78 @@
(* Copyright (C) 2022--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Caqti_platform
module Fiber = struct
type 'a t = 'a Lwt.t
module Infix = struct
let (>>=) = Lwt.Infix.(>>=)
let (>|=) = Lwt.Infix.(>|=)
end
open Infix
let return = Lwt.return
let catch = Lwt.catch
let finally = Lwt.finalize
let cleanup f g = Lwt.catch f (fun exn -> g () >>= fun () -> Lwt.fail exn)
end
module Stream = Caqti_platform.Stream.Make (Fiber)
module Switch = Caqti_platform.Switch.Make (Fiber)
module System_core = struct
module Fiber = Fiber
module Stream = Stream
module Switch = Switch
let async ~sw:_ = Lwt.async
module Mutex = Lwt_mutex
module Condition = struct
type t = unit Lwt_condition.t
let create = Lwt_condition.create
let wait c mutex = Lwt_condition.wait ~mutex c
let signal c = Lwt_condition.signal c ()
end
module Log = struct
type 'a log = 'a Logs_lwt.log
let err ?(src = Logging.default_log_src) = Logs_lwt.err ~src
let warn ?(src = Logging.default_log_src) = Logs_lwt.warn ~src
let info ?(src = Logging.default_log_src) = Logs_lwt.info ~src
let debug ?(src = Logging.default_log_src) = Logs_lwt.debug ~src
end
(* Cf. pgx_lwt. *)
module Sequencer = struct
type 'a t = 'a * Lwt_mutex.t
let create m = (m, Lwt_mutex.create ())
let enqueue (m, mutex) f = Lwt_mutex.with_lock mutex (fun () -> f m)
end
end
module type CONNECTION = Caqti_connection_sig.S
with type 'a fiber := 'a Lwt.t
and type ('a, 'e) stream := ('a, 'e) Stream.t
type connection = (module CONNECTION)
let or_fail = function
| Ok x -> Lwt.return x
| Error (#Caqti_error.t as err) -> Lwt.fail (Caqti_error.Exn err)

52
unikernel/duniverse/ocaml-caqti/caqti-lwt/lib/caqti_lwt.mli Normal file
View file

@ -0,0 +1,52 @@
(* Copyright (C) 2022--2023 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
(** Prerequisities for connecting to databases using Lwt
This module contains most of the prerequisite types and modules. Functions
to establish database connections are provided by the [caqti-lwt.unix] and
[caqti-mirage] libraries. Pool instances are also found there due to
additional OS dependencies. *)
(* A custom stream implementation instantiated for Lwt. This is similar to
* {!Lwt_seq}, except with error handling. *)
module Stream : Caqti_stream_sig.S with type 'a fiber := 'a Lwt.t
(* This should ideally be {!Lwt_switch}, but we need a way to cancel cleanup
* jobs in order to avoid a memory leaks for long-lived pools. *)
module Switch : Caqti_switch_sig.S with type 'a fiber := 'a Lwt.t
(**/**)
(* For private use by caqti-lwt.unix and caqti-mirage. *)
module System_core : sig
include Caqti_platform.System_sig.CORE
with type 'a Fiber.t = 'a Lwt.t
and module Stream = Stream
and type Switch.t = Switch.t
and type stdenv := unit
end
(**/**)
module type CONNECTION = Caqti_connection_sig.S
with type 'a fiber := 'a Lwt.t
and type ('a, 'e) stream := ('a, 'e) Stream.t
type connection = (module CONNECTION)
val or_fail : ('a, [< Caqti_error.t]) result -> 'a Lwt.t
(** Converts an error to an Lwt future failed with a {!Caqti_error.Exn}
exception holding the error. *)

4
unikernel/duniverse/ocaml-caqti/caqti-lwt/lib/dune Normal file
View file

@ -0,0 +1,4 @@
(library
(name caqti_lwt)
(public_name caqti-lwt)
(libraries logs.lwt lwt caqti.platform))

4
unikernel/duniverse/ocaml-caqti/caqti-lwt/test-unix/dune Normal file
View file

@ -0,0 +1,4 @@
(test
(name main)
(package caqti-lwt)
(libraries alcotest alcotest-lwt caqti caqti-lwt caqti-lwt.unix testlib))

22
unikernel/duniverse/ocaml-caqti/caqti-lwt/test-unix/main.ml Normal file
View file

@ -0,0 +1,22 @@
(* Copyright (C) 2021--2023 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
let () = Lwt_main.run begin
Alcotest_lwt.V1.run "caqti-lwt" [
"pool-lwt", Test_pool_lwt.test_cases;
]
end

163
unikernel/duniverse/ocaml-caqti/caqti-lwt/test-unix/test_pool_lwt.ml Normal file
View file

@ -0,0 +1,163 @@
(* Copyright (C) 2014--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Lwt.Infix
open Lwt.Syntax
module Pool = Caqti_lwt_unix.System.Pool
module Resource = struct
type t = {
id: int;
mutable use_count: int;
}
let alive = Hashtbl.create 17
let latest_id = ref 0
let create () =
incr latest_id;
Hashtbl.add alive !latest_id ();
Lwt.return_ok {id = !latest_id; use_count = 0}
let create_or_fail () =
if Random.int 4 = 0 then Lwt.return_error () else
create ()
let free resource =
assert (Hashtbl.mem alive resource.id);
Hashtbl.remove alive resource.id;
Lwt.return_unit
end
let test_n n =
Caqti_lwt.Switch.run @@ fun sw ->
let max_idle_size = Random.int 11 in
let max_size = max 1 (max_idle_size + Random.int 5) in
let max_use_count =
(match Random.bool () with
| false -> None
| true -> Some (1 + Random.int 8))
in
let pool =
let config =
Caqti_pool_config.create ~max_idle_size ~max_size ~max_use_count ()
in
Pool.create ~config ~sw ~stdenv:()
Resource.create_or_fail Resource.free
in
let wakers = Array.make n None in
let wait_count = ref 0 in
let wait_count_cond = Lwt_condition.create () in
let wake j u = Lwt.wakeup u (); wakers.(j) <- None in
for _ = 0 to 3 * n - 1 do
let j = Random.int n in
assert (Pool.size pool = Hashtbl.length Resource.alive);
(match wakers.(j) with
| None ->
let waiter, waker = Lwt.wait () in
incr wait_count;
let task (resource : Resource.t) =
(match max_use_count with
| None -> ()
| Some n -> assert (resource.use_count < n));
resource.use_count <- resource.use_count + 1;
waiter >|= fun () ->
decr wait_count;
Lwt_condition.signal wait_count_cond ();
Ok ()
in
Lwt.async begin fun () ->
Pool.use task pool >>=
(function
| Ok () -> Lwt.return_unit
| Error () ->
waiter >|= fun () ->
decr wait_count;
Lwt_condition.signal wait_count_cond ())
end;
wakers.(j) <- Some waker
| Some u -> wake j u)
done;
for j = 0 to n - 1 do
(match wakers.(j) with
| None -> ()
| Some u -> wake j u)
done;
let rec wait_for_all () =
if !wait_count = 0 then Lwt.return_unit else
Lwt_condition.wait wait_count_cond >>= wait_for_all
in
Lwt_unix.with_timeout 2.0 wait_for_all >>= fun () ->
assert (Pool.size pool <= max_idle_size);
Alcotest.(check int) "still waiting" 0 !wait_count;
Pool.drain pool >|= fun () ->
Alcotest.(check int) "pool size after drain" 0 (Pool.size pool);
Alcotest.(check int) "alive after drain" 0 (Hashtbl.length Resource.alive)
let test _ () =
test_n 0 >>= fun () ->
test_n 1 >>= fun () ->
let rec loop n_it =
if n_it = 0 then Lwt.return_unit else
test_n (Random.int (1 lsl Random.int 12)) >>= fun () ->
loop (n_it - 1)
in
loop 500
let create_gathering n =
let count = ref n in
let wait, disband = Lwt.task () in
fun () ->
decr count;
if !count > 0 then wait else
(Lwt.wakeup_later disband (); Lwt.return_unit)
let test_age _ () =
Caqti_lwt.Switch.run @@ fun sw ->
let max_size = 8 in
let max_idle_size = 4 in
let max_idle_age = Some Mtime.Span.(100 * ms) in
let pool =
let config =
Caqti_pool_config.create ~max_size ~max_idle_size ~max_idle_age ()
in
Pool.create ~config ~sw ~stdenv:() Resource.create Resource.free
in
let user_count = 8 in
let join_gathering = create_gathering user_count in
let* () =
let f _i _resource = join_gathering () >|= Result.ok in
List.init user_count f
|> List.map (fun f -> Pool.use f pool >|= Result.get_ok)
|> Lwt.join
in
Alcotest.(check int) "pool size before sleep" 4 (Pool.size pool);
let+ () =
let rec wait_while_draining timeout =
if Pool.size pool = 0 then Lwt.return_unit else
Lwt_unix.sleep 0.1 >>= fun () -> wait_while_draining (timeout -. 0.1)
in
wait_while_draining 5.0
in
Alcotest.(check int) "pool size after sleep" 0 (Pool.size pool)
let test_cases = [
Alcotest_lwt.V1.test_case "basic usage" `Quick test;
Alcotest_lwt.V1.test_case "timed cleanup" `Quick test_age;
]

9
unikernel/duniverse/ocaml-caqti/caqti-lwt/testlib-unix/dune Normal file
View file

@ -0,0 +1,9 @@
(library
(name testlib_lwt_unix)
(libraries
alcotest
caqti
caqti_lwt
caqti_lwt_unix
lwt
testlib))

44
unikernel/duniverse/ocaml-caqti/caqti-lwt/testlib-unix/testlib_lwt_unix.ml Normal file
View file

@ -0,0 +1,44 @@
(* Copyright (C) 2021--2023 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
module Fiber = struct
type 'a t = 'a Lwt.t
let return = Lwt.return
let catch = Lwt.catch
let fail = Lwt.fail
module Infix = struct
let (>>=) = Lwt.Infix.(>>=)
let (>|=) = Lwt.Infix.(>|=)
let (>>=?) = Lwt_result.Infix.(>>=)
let (>|=?) = Lwt_result.Infix.(>|=)
end
end
open Fiber.Infix
include Caqti_lwt
include Caqti_lwt_unix
module Alcotest_cli = Testlib.Make_alcotest_cli (Alcotest.Unix_platform) (Lwt)
module List_result_fiber = struct
let rec iter_s f = function
| [] -> Fiber.return (Ok ())
| x :: xs -> f x >>=? fun () -> iter_s f xs
end

21
unikernel/duniverse/ocaml-caqti/caqti-lwt/testlib-unix/testlib_lwt_unix.mli Normal file
View file

@ -0,0 +1,21 @@
(* Copyright (C) 2021--2023 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
include Testlib.Sig.Ground
with type 'a Fiber.t = 'a Lwt.t
and module Stream = Caqti_lwt.Stream
and module Pool = Caqti_lwt_unix.Pool

27
unikernel/duniverse/ocaml-caqti/caqti-miou.opam Normal file
View file

@ -0,0 +1,27 @@
opam-version: "2.0"
name: "caqti-miou"
maintainer: "Petter A. Urkedal <paurkedal@gmail.com>"
authors: "Romain Calascibetta <romain.calascibetta@gmail.com>"
license: "LGPL-3.0-or-later WITH LGPL-3.0-linking-exception"
homepage: "https://github.com/paurkedal/ocaml-caqti/"
doc: "https://paurkedal.github.io/ocaml-caqti/index.html"
bug-reports: "https://github.com/paurkedal/ocaml-caqti/issues"
depends: [
"caqti" {>= "2.2.3" & < "2.3.0~"}
"dune" {>= "3.9"}
"miou" {>= "0.3.0"}
"logs"
"ocaml" {>= "5.0.0~"}
"alcotest" {with-test & >= "1.5.0"}
"caqti-driver-sqlite3" {with-test}
"cmdliner" {with-test & >= "1.1.0"}
"mirage-crypto-rng-miou-unix" {with-test}
"odoc" {with-doc}
]
build: [
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc}
]
dev-repo: "git+https://github.com/paurkedal/ocaml-caqti.git"
synopsis: "Miou support for Caqti"

35
unikernel/duniverse/ocaml-caqti/caqti-miou/lib-unix/caqti_miou_unix.ml Normal file
View file

@ -0,0 +1,35 @@
(* Copyright (C) 2023--2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Caqti_platform
module System = System
module Pool = System.Pool
module Loader = Caqti_platform_unix.Driver_loader.Make (System) (System_unix)
include Connector.Make (System) (Pool) (Loader)
let connect ?subst ?env ?config ?tweaks_version ~sw uri =
connect ?subst ?env ?config ?tweaks_version ~sw ~stdenv:() uri
let with_connection = with_connection ~stdenv:()
let connect_pool
?pool_config ?post_connect ?subst ?env ?config ?tweaks_version ~sw uri =
connect_pool
?pool_config ?post_connect ?subst ?env ?config ?tweaks_version
~sw ~stdenv:() uri

33
unikernel/duniverse/ocaml-caqti/caqti-miou/lib-unix/caqti_miou_unix.mli Normal file
View file

@ -0,0 +1,33 @@
(* Copyright (C) 2023--2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
(** Establishing connections using miou.unix.
{b This library considered unstable for now,} and may be revised or replaced
as the effect-based libraries evolve. *)
module System = System
module Pool : Caqti_pool_sig.S with type 'a fiber := 'a
include Caqti_connect_sig.S
with type 'a fiber := 'a
and type ('a, 'e) stream := ('a, 'e) Caqti_miou.Stream.t
and type ('a, 'e) pool := ('a, 'e) Pool.t
and type connection := Caqti_miou.connection
and type 'a with_switch := sw: Caqti_miou.Switch.t -> 'a
and type 'a with_stdenv := 'a

6
unikernel/duniverse/ocaml-caqti/caqti-miou/lib-unix/dune Normal file
View file

@ -0,0 +1,6 @@
(library
(name caqti_miou_unix)
(public_name caqti-miou.unix)
(optional)
(modules caqti_miou_unix system system_unix)
(libraries caqti-miou caqti.platform.unix miou.unix ipaddr.unix))

197
unikernel/duniverse/ocaml-caqti/caqti-miou/lib-unix/system.ml Normal file
View file

@ -0,0 +1,197 @@
(* Copyright (C) 2023--2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
let error_msgf fmt = Format.kasprintf (fun msg -> Error (`Msg msg)) fmt
module type FLOW = Caqti_platform.System_sig.SOCKET_OPS with type 'a fiber = 'a
type ocaml = | and system = |
type 'a impl =
| OCaml : (module FLOW with type t = 'a) * 'a -> ocaml impl
| System : Buffer.t * Miou_unix.file_descr -> system impl
type socket = Socket : 'a impl -> socket [@@unboxed]
type Caqti_error.msg +=
| Msg_unix of Unix.error * string * string
let () =
let pp ppf = function
| Msg_unix (err, f, v) ->
Format.fprintf ppf "%s(%s): %s" f v (Unix.error_message err)
| _ -> assert false
in
Caqti_error.define_msg ~pp [%extension_constructor Msg_unix]
external reraise : exn -> 'a = "%reraise"
module System_core = struct
include Caqti_miou.System_core
type stdenv = unit
end
include System_core
module Alarm = struct
type t = Miou.Condition.t * Miou.Mutex.t
let schedule ~sw ~stdenv:_ t fn =
let t_now = Mtime_clock.now () in
let mutex = Miou.Mutex.create () and condition = Miou.Condition.create () in
let delay =
if Mtime.is_later t ~than:t_now then 0.0
else Mtime.Span.to_float_ns (Mtime.span t t_now) *. 1e-9
in
Logs.debug (fun m -> m "schedule an alarm");
let _ =
async ~sw @@ fun () ->
Logs.debug (fun m -> m "really schedule an alarm");
let sleeper = Miou.async @@ fun () ->
Logs.debug (fun m -> m "Sleep %fs" delay);
Miou_unix.sleep delay;
Logs.debug (fun m -> m "Ring the alarm");
`Continue in
let canceller =
Miou.async @@ fun () ->
Miou.Condition.wait condition mutex;
`Cancel
in
match Miou.await_first [ sleeper; canceller ] with
| Ok `Continue -> fn ()
| Ok `Cancel -> ()
| Error _exn -> ()
in
(condition, mutex)
let unschedule (condition, mutex) =
Miou.Mutex.protect mutex @@ fun () -> Miou.Condition.signal condition
end
module Stream = Caqti_miou.Stream
module Pool = Caqti_platform.Pool.Make (System_core) (Alarm)
module Net = struct
module Sockaddr = struct
type t = Unix.sockaddr
let unix v = Unix.ADDR_UNIX v
let tcp (addr, port) = Unix.ADDR_INET (Ipaddr_unix.to_inet_addr addr, port)
end
let getaddrinfo ~stdenv:() host port =
let opts = Unix.[ AI_SOCKTYPE SOCK_STREAM ] in
match
Unix.getaddrinfo (Domain_name.to_string host) (string_of_int port) opts
with
| lst -> Ok (List.map (fun ai -> ai.Unix.ai_addr) lst)
| exception Not_found -> Ok []
| exception Unix.Unix_error (err, f, v) ->
error_msgf "%s(%s): %s" f v (Unix.error_message err)
let convert_io_exception = function
| Unix.Unix_error (err, f, v) -> Some (Msg_unix (err, f, v))
| _ -> None
type tcp_flow = Miou_unix.file_descr
type tls_flow = ocaml impl
module Socket = struct
type t = socket
let output_char (Socket impl) chr = match impl with
| System (buf, _) -> Buffer.add_char buf chr
| OCaml ((module Flow), fd) -> Flow.output_char fd chr
let output_string (Socket impl) str = match impl with
| System (buf, _) -> Buffer.add_string buf str
| OCaml ((module Flow), fd) -> Flow.output_string fd str
let flush (Socket impl) = match impl with
| System (buf, fd) ->
let str = Buffer.contents buf in
Buffer.clear buf;
if String.length str > 0 then Miou_unix.write fd str
| OCaml ((module Flow), fd) -> Flow.flush fd
let input_char (Socket impl) = match impl with
| System (_, fd) ->
let buf = Bytes.make 1 '\000' in
let len = Miou_unix.read fd buf in
if len = 0 then raise End_of_file else Bytes.get buf 0
| OCaml ((module Flow), fd) ->
Flow.input_char fd
let really_input (Socket impl) buf off len =
match impl with
| System (_, fd) ->
let rec go off len =
if len > 0 then
let len' = Miou_unix.read fd buf ~off ~len in
go (off + len') (len - len')
in
go off len
| OCaml ((module Flow), fd) ->
Flow.really_input fd buf off len
let close = function
| Socket (System (_, fd)) -> Miou_unix.close fd
| Socket (OCaml ((module Flow), fd)) -> Flow.close fd
end
let socket = function
| Unix.ADDR_UNIX _ ->
let fd = Unix.socket ~cloexec:true Unix.PF_UNIX Unix.SOCK_STREAM 0 in
Ok (Miou_unix.of_file_descr ~non_blocking:true fd)
| Unix.ADDR_INET (inet_addr, _) when Unix.is_inet6_addr inet_addr ->
Ok (Miou_unix.tcpv6 ())
| _ -> Ok (Miou_unix.tcpv4 ())
let connect_tcp ~sw:_ ~stdenv:_ sockaddr =
let ( >>= ) = Result.bind in
socket sockaddr >>= fun socket ->
match Miou_unix.connect socket sockaddr with
| () -> Ok (Socket (System (Buffer.create 0x7ff, socket)))
| exception Unix.Unix_error (err, f, v) ->
Miou_unix.close socket;
Error (Msg_unix (err, f, v))
| exception exn -> Miou_unix.close socket; raise exn
let tcp_flow_of_socket (Socket impl) = match impl with
| System (_, fd) -> Some fd
| OCaml _ -> None
let socket_of_tls_flow : sw:_ -> tls_flow -> Socket.t =
fun ~sw:_ -> function
| OCaml _ as impl -> Socket impl
module type TLS_PROVIDER =
Caqti_platform.System_sig.TLS_PROVIDER
with type 'a fiber := 'a
and type tcp_flow := tcp_flow
and type tls_flow := tls_flow
let tls_providers_r : (module TLS_PROVIDER) list ref = ref []
let register_tls_provider p = tls_providers_r := p :: !tls_providers_r
let tls_providers config =
if Caqti_connect_config.mem_name "tls" config then begin
match Caqti_platform.Connector.load_library "caqti-tls-miou" with
| Ok () -> ()
| Error msg -> Log.warn (fun m -> m "TLS configured, but missing caqti-tls-miou: %s" msg)
end;
!tls_providers_r
end

61
unikernel/duniverse/ocaml-caqti/caqti-miou/lib-unix/system_unix.ml Normal file
View file

@ -0,0 +1,61 @@
(* Copyright (C) 2023--2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
module Unix = struct
type file_descr = Miou_unix.file_descr
let wrap_fd f fd = f (Miou_unix.of_file_descr ~non_blocking:true fd)
exception Timeout
let or_raise = function Ok v -> v | Error exn -> raise exn
let poll ~stdenv:() ?(read= false) ?(write= false) ?timeout fd =
let fn () = match read, write with
| false, false -> (false, false, false)
| true, true ->
let reader = Miou.async @@ fun () ->
Miou_unix.(blocking_read (to_file_descr fd));
(true, false, false) in
let writer = Miou.async @@ fun () ->
Miou_unix.(blocking_write (to_file_descr fd));
(false, true, false) in
Miou.await_first [ reader; writer ] |> or_raise
| true, false ->
Miou_unix.(blocking_read (to_file_descr fd)); (true, false, false)
| false, true ->
Miou_unix.(blocking_write (to_file_descr fd)); (false, true, false) in
match timeout with
| None -> fn ()
| Some t ->
let sleep = Miou.async @@ fun () -> Miou_unix.sleep t; raise Timeout in
match Miou.await_first [ sleep; Miou.async fn ] with
| Ok v -> v
| Error Timeout -> (false, false, true)
| Error exn -> raise exn
end
module Preemptive = struct
let detach f x =
let fn () = f x in
let prm =
if Miou.Domain.available () > 0
then Miou.call fn
else Miou.async fn in
Miou.await_exn prm
let run_in_main fn = fn ()
end

191
unikernel/duniverse/ocaml-caqti/caqti-miou/lib/caqti_miou.ml Normal file
View file

@ -0,0 +1,191 @@
(* Copyright (C) 2023--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Caqti_platform
external reraise : exn -> 'a = "%reraise"
module Fiber = struct
type 'a t = 'a
module Infix = struct
let ( >>= ) x f = f x
let ( >|= ) x f = f x
end
let return x = x
let catch f g = try f () with exn -> g exn
let finally f finally = Fun.protect ~finally f
let cleanup f g = try f () with exn -> g (); raise exn
end
module Stream = Caqti_platform.Stream.Make (Fiber)
module Log = struct
type 'a log = 'a Logs.log
let err ?(src = Logging.default_log_src) = Logs.err ~src
let warn ?(src = Logging.default_log_src) = Logs.warn ~src
let info ?(src = Logging.default_log_src) = Logs.info ~src
let debug ?(src = Logging.default_log_src) = Logs.debug ~src
end
module Sequencer = struct
type 'a t = 'a * Miou.Mutex.t
let create v = (v, Miou.Mutex.create ())
let enqueue (v, m) f = Miou.Mutex.protect m (fun () -> f v)
end
type switch =
{ stop : bool Atomic.t
; mutex : Miou.Mutex.t
; condition : Miou.Condition.t
; hooks : (unit -> unit) Miou.Sequence.t
; jobs : [ `Job of (unit -> unit) | `Check ] Miou.Queue.t }
module Switch = struct
type hook = Miou.Mutex.t * (unit -> unit) Miou.Sequence.node
type t = switch
exception Off
let create () =
{ stop= Atomic.make true
; mutex= Miou.Mutex.create ()
; condition= Miou.Condition.create ()
; hooks= Miou.Sequence.create ()
; jobs= Miou.Queue.create () }
let eternal = create ()
let release t =
Miou.Mutex.protect t.mutex @@ fun () ->
List.iter (fun fn -> fn ()) (Miou.Sequence.to_list t.hooks);
Miou.Sequence.drop t.hooks
let rec terminate orphans =
match Miou.care orphans with
| None -> ()
| Some None -> Miou.yield (); terminate orphans
| Some (Some prm) -> (
match Miou.await prm with
| Ok () -> terminate orphans
| Error exn ->
Log.err (fun m -> m "Got an unexpected error: %S" (Printexc.to_string exn));
terminate orphans)
let rec clean orphans =
match Miou.care orphans with
| None | Some None -> Miou.yield ()
| Some (Some prm) -> (
match Miou.await prm with
| Ok () -> clean orphans
| Error exn ->
Log.err (fun m -> m "Got an unexpected error: %S" (Printexc.to_string exn));
clean orphans)
let rec worker ~orphans t =
clean orphans;
let jobs = Miou.Mutex.protect t.mutex @@ fun () ->
if Miou.Queue.is_empty t.jobs && Atomic.get t.stop = false
then Miou.Condition.wait t.condition t.mutex;
Miou.Queue.(to_list (transfer t.jobs)) in
let prgm = function
| `Job fn -> ignore (Miou.async ~orphans fn)
| `Check -> clean orphans in
List.iter prgm jobs;
if Atomic.get t.stop = false
then worker ~orphans t
else terminate orphans
let worker t () =
let orphans = Miou.orphans () in
worker ~orphans t
let stop ~daemon t =
Miou.Mutex.protect t.mutex begin fun () ->
Atomic.set t.stop true;
Miou.Condition.signal t.condition
end;
match Miou.await daemon with
| Ok () -> ()
| Error exn ->
Log.err (fun m -> m "our worker finished with: %S" (Printexc.to_string exn));
reraise exn
let enqueue t fn =
Miou.Mutex.protect t.mutex @@ fun () ->
Miou.Queue.enqueue t.jobs (`Job fn);
Miou.Condition.signal t.condition
let call_if_available fn =
if Miou.Domain.available () > 0
then Miou.call fn
else Miou.async fn
let run fn =
let t = { stop= Atomic.make false
; mutex= Miou.Mutex.create ()
; condition= Miou.Condition.create ()
; hooks= Miou.Sequence.create ()
; jobs= Miou.Queue.create () } in
let daemon = call_if_available (worker t) in
match fn t with
| value -> stop ~daemon t; release t; value
| exception exn ->
Log.debug (fun m -> m "our function finished with: %S" (Printexc.to_string exn));
stop ~daemon t; release t; reraise exn
let on_release_cancellable t fn =
Miou.Mutex.protect t.mutex @@ fun () ->
let hook = Miou.Sequence.(add Left) t.hooks fn in
(t.mutex, hook)
let remove_hook (mutex, hook) =
Miou.Mutex.protect mutex @@ fun () ->
Miou.Sequence.remove hook
let check t =
if Atomic.get t.stop then raise Off
else Miou.Mutex.protect t.mutex @@ fun () ->
Miou.Queue.enqueue t.jobs `Check;
Miou.Condition.signal t.condition
end
module System_core = struct
module Fiber = Fiber
module Stream = Stream
module Switch = Switch
module Mutex = Miou.Mutex
module Condition = Miou.Condition
module Log = Log
module Sequencer = Sequencer
let async ~sw fn = Switch.enqueue sw fn
end
module type CONNECTION = Caqti_connection_sig.S
with type 'a fiber := 'a
and type ('a, 'e) stream := ('a, 'e) Stream.t
type connection = (module CONNECTION)
let or_fail = function
| Ok x -> x
| Error (#Caqti_error.t as err) -> raise (Caqti_error.Exn err)

49
unikernel/duniverse/ocaml-caqti/caqti-miou/lib/caqti_miou.mli Normal file
View file

@ -0,0 +1,49 @@
(* Copyright (C) 2023--2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
(** Prerequisites for establishing connections under miou.
The connection functions can be found in caqti-miou.unix.
{b This library considered unstable for now,} and may be revised or replaced
as the effect-based libraries evolve. *)
type switch
module Stream : Caqti_stream_sig.S with type 'a fiber := 'a
module Switch : Caqti_switch_sig.S
with type 'a fiber := 'a
and type t = switch
(**/**)
(* For private use by Caqti. *)
module System_core : sig
include Caqti_platform.System_sig.CORE
with type 'a Fiber.t = 'a
and module Stream = Stream
and type Switch.t = Switch.t
and type stdenv := unit
end
(**/**)
module type CONNECTION = Caqti_connection_sig.S
with type 'a fiber := 'a
and type ('a, 'e) stream := ('a, 'e) Stream.t
type connection = (module CONNECTION)
val or_fail : ('a, [< Caqti_error.t ]) result -> 'a

6
unikernel/duniverse/ocaml-caqti/caqti-miou/lib/dune Normal file
View file

@ -0,0 +1,6 @@
(library
(name caqti_miou)
(public_name caqti-miou)
(optional)
(modules caqti_miou)
(libraries logs caqti caqti.platform miou))

5
unikernel/duniverse/ocaml-caqti/caqti-miou/test-unix/dune Normal file
View file

@ -0,0 +1,5 @@
(test
(name main)
(package caqti-miou)
(enabled_if (>= %{ocaml_version} "5.0"))
(libraries logs.threaded alcotest caqti caqti-miou caqti-miou.unix testlib))

23
unikernel/duniverse/ocaml-caqti/caqti-miou/test-unix/main.ml Normal file
View file

@ -0,0 +1,23 @@
(* Copyright (C) 2023--2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
let () = Logs_threaded.enable ()
let () =
Alcotest.run "caqti-miou" [
"pool-miou", Test_pool_miou.test_cases;
]

228
unikernel/duniverse/ocaml-caqti/caqti-miou/test-unix/test_pool_miou.ml Normal file
View file

@ -0,0 +1,228 @@
(* Copyright (C) 2023--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
module Pool = Caqti_miou_unix.System.Pool
module Resource = struct
type t = {
id: int;
use_count: int Atomic.t;
}
let alive = Hashtbl.create 17
let alive_mutex = Mutex.create ()
let with_alive_locked f =
Mutex.lock alive_mutex;
Fun.protect ~finally:(fun () -> Mutex.unlock alive_mutex) f
let latest_id = Atomic.make 0
let create () =
let id = Atomic.fetch_and_add latest_id 1 in
with_alive_locked (fun () -> Hashtbl.add alive id ());
Ok {id; use_count = Atomic.make 0}
let create_or_fail () =
if Random.int 4 = 0 then Error () else
create ()
let free resource =
with_alive_locked begin fun () ->
assert (Hashtbl.mem alive resource.id);
Hashtbl.remove alive resource.id
end
end
exception Timeout
let with_timeout ts fn =
let prm0 = Miou.async fn in
let prm1 = Miou.async @@ fun () -> Miou_unix.sleep ts; raise Timeout in
match Miou.await_first [ prm0; prm1 ] with
| Ok value -> value
| Error Timeout -> raise Timeout
| Error exn ->
Logs.err (fun m -> m "Unexpected exception: %S" (Printexc.to_string exn));
raise exn
let test_n n =
Caqti_miou.Switch.run @@ fun sw ->
let max_idle_size = Random.int 11 in
let max_size = max 1 (max_idle_size + Random.int 5) in
let max_use_count =
(match Random.bool () with
| false -> None
| true -> Some (1 + Random.int 8))
in
let pool =
let config =
Caqti_pool_config.create ~max_idle_size ~max_size ~max_use_count ()
in
Pool.create ~config ~sw ~stdenv:()
Resource.create_or_fail Resource.free
in
let wakers = Array.make n None in
let wait_count = ref 0 in
let wait_count_cond = Miou.Condition.create () in
let wait_count_mutex = Miou.Mutex.create () in
let wake j c =
ignore (Miou.Computation.try_return c ());
wakers.(j) <- None in
for _ = 0 to 3 * n - 1 do
let j = Random.int n in
(* NOTE(dinosaure): This assertion is not necessarily true when another
domain may be in charge of the asynchronous functions and these are not
actually launched immediately. *)
(* assert (Pool.size pool = Hashtbl.length Resource.alive); *)
(match wakers.(j) with
| None ->
let c = Miou.Computation.create () in
Miou.Mutex.protect wait_count_mutex (fun () -> incr wait_count);
let task (resource : Resource.t) =
begin match max_use_count with
| None -> ()
| Some n -> assert (Atomic.get resource.use_count < n) end;
Atomic.incr resource.use_count;
ignore (Miou.Computation.await c);
Miou.Mutex.protect wait_count_mutex begin fun () ->
decr wait_count;
Miou.Condition.signal wait_count_cond
end;
Ok ()
in
Caqti_miou.System_core.async ~sw begin fun () ->
begin match Pool.use task pool with
| Ok () -> ()
| Error () ->
ignore (Miou.Computation.await c);
Miou.Mutex.protect wait_count_mutex begin fun () ->
decr wait_count;
Miou.Condition.signal wait_count_cond
end;
end
end;
wakers.(j) <- Some c
| Some c -> wake j c)
done;
for j = 0 to n - 1 do
(match wakers.(j) with
| None -> Miou.yield ()
| Some c -> wake j c)
done;
let rec wait_for_all () =
Miou.Mutex.lock wait_count_mutex;
while !wait_count > 0 do
Miou.Condition.wait wait_count_cond wait_count_mutex;
done;
let n = !wait_count in
Miou.Mutex.unlock wait_count_mutex;
if n > 0 then wait_for_all ()
in
(* NOTE(dinosaure): see the note below, we need to give a better chance to
wait all tasks. *)
with_timeout 5.0 wait_for_all;
if not (Pool.size pool <= max_idle_size) then begin
(* TODO: Remove condition and CI config after fixing #126. *)
if Sys.getenv_opt "CAQTI_DEBUGGING_ISSUE_126" = Some "true" then
Alcotest.failf "%d resources left in pool, expected at most %d"
(Pool.size pool) max_idle_size
end;
Alcotest.(check int) "still waiting" 0 !wait_count;
Pool.drain pool;
Alcotest.(check int) "pool size after drain" 0 (Pool.size pool);
Alcotest.(check int) "alive after drain" 0 (Hashtbl.length Resource.alive)
let test () =
Miou_unix.run @@ fun () ->
test_n 0;
test_n 1;
(* NOTE(dinosaure): For a simple core, the miou pattern is not the most
optimised: it's basically a scheduler within a scheduler. So the [Switch]
ends up in the role of a small scheduler which will execute tasks with
[async], whereas Miou is a scheduler. The aim is for the [Switch] to
execute tasks in another domain. In this case, the test execution time is
reasonable, but for a simple core, this repetition of task management slows
down the process. We therefore limit the number of tasks to be performed
for a single core.
We could offer another [Switch] implementation depending on the number of
domains available. However, this choice can only be made dynamically. It is
more reasonable to consider that with miou, we have at least 2 cores
available. *)
let max =
if Miou.Domain.available () > 0
then 12 else 6 in
let rec loop n_it =
if n_it > 0 then begin
test_n (Random.int (1 lsl max));
loop (n_it - 1)
end
in
loop 500
let create_gathering n =
let count = Atomic.make n in
let c = Miou.Computation.create () in
fun () ->
let v = Atomic.fetch_and_add count (-1) in
Logs.debug (fun m -> m "count:%d" (v - 1));
if v - 1 > 0 then Miou.Computation.await_exn c
else begin
assert (Miou.Computation.try_return c ());
Logs.debug (fun m -> m "signal others")
end
let test_age _ =
Miou_unix.run @@ fun () ->
Caqti_miou.Switch.run @@ fun sw ->
let max_size = 8 in
let max_idle_size = 4 in
let max_idle_age = Some Mtime.Span.(100 * ms) in
let pool =
let config =
Caqti_pool_config.create ~max_size ~max_idle_size ~max_idle_age ()
in
Pool.create ~config ~sw ~stdenv:() Resource.create Resource.free
in
let user_count = 8 in
let join_gathering = create_gathering user_count in
let f _i _resource =
Ok (join_gathering ()) in
let jobs = List.init user_count f in
let launch job =
Caqti_miou_unix.System.async ~sw @@ fun () ->
ignore (Pool.use job pool) in
List.iter launch jobs;
(* NOTE(dinosaure): miou does not effectively launch jobs. So, [Pool.use]
is not yet effectively executed. At this stage, [Pool.size] should be
equal to [0] but, due to the fact the a domain is probably used to launch
these jobs, it can be higher than [0]. *)
(* Alcotest.(check int) "pool size before sleep" 4 (Pool.size pool); *)
let rec wait_while_draining timeout =
if Pool.size pool > 0 then begin
Miou_unix.sleep 0.1; Miou.yield ();
wait_while_draining (timeout -. 0.1)
end
in
wait_while_draining 5.0;
Alcotest.(check int) "pool size after sleep" 0 (Pool.size pool)
let test_cases = [
Alcotest.test_case "basic usage" `Quick test;
Alcotest.test_case "timed cleanup" `Quick test_age;
]

4
unikernel/duniverse/ocaml-caqti/caqti-miou/testlib-unix/dune Normal file
View file

@ -0,0 +1,4 @@
(library
(name testlib_miou_unix)
(optional)
(libraries alcotest caqti_miou caqti_miou_unix testlib))

45
unikernel/duniverse/ocaml-caqti/caqti-miou/testlib-unix/testlib_miou_unix.ml Normal file
View file

@ -0,0 +1,45 @@
(* Copyright (C) 2023--2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
include Caqti_miou.System_core
include Caqti_miou
include Caqti_miou_unix
module Fiber = struct
include Fiber
let fail = raise
module Infix = struct
include Infix
let (>>=?) = Result.bind
let (>|=?) x f = Result.map f x
end
end
module Alcotest_cli =
Testlib.Make_alcotest_cli
(Alcotest.Unix_platform)
(Alcotest_engine.Monad.Identity)
module List_result_fiber = struct
open Fiber.Infix
let rec iter_s f = function
| [] -> Fiber.return (Ok ())
| x :: xs -> f x >>=? fun () -> iter_s f xs
end

21
unikernel/duniverse/ocaml-caqti/caqti-miou/testlib-unix/testlib_miou_unix.mli Normal file
View file

@ -0,0 +1,21 @@
(* Copyright (C) 2023--2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
include Testlib.Sig.Ground
with type 'a Fiber.t = 'a
and module Stream = Caqti_miou.Stream
and module Pool = Caqti_miou_unix.Pool

34
unikernel/duniverse/ocaml-caqti/caqti-mirage.opam Normal file
View file

@ -0,0 +1,34 @@
opam-version: "2.0"
name: "caqti-mirage"
maintainer: "Petter A. Urkedal <paurkedal@gmail.com>"
authors: "Petter A. Urkedal <paurkedal@gmail.com>"
license: "LGPL-3.0-or-later WITH LGPL-3.0-linking-exception"
homepage: "https://github.com/paurkedal/ocaml-caqti/"
doc: "https://paurkedal.github.io/ocaml-caqti/index.html"
bug-reports: "https://github.com/paurkedal/ocaml-caqti/issues"
depends: [
"caqti" {>= "2.2.0" & < "2.3.0~"}
"caqti-lwt" {>= "2.1.0" & < "2.3.0~"}
"caqti-tls" {>= "2.1.0" & < "2.3.0~"}
"dns-client" {>= "7.0.0"}
"dns-client-mirage" {>= "7.0.0"}
"domain-name"
"dune" {>= "3.9"}
"ipaddr"
"logs"
"lwt" {>= "5.3.0"}
"mirage-channel"
"mirage-sleep"
"ocaml"
"odoc" {with-doc}
"tls"
"tls-mirage" {>= "1.0.0"}
"tcpip" {>= "8.1.0"}
]
build: [
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc}
]
dev-repo: "git+https://github.com/paurkedal/ocaml-caqti.git"
synopsis: "MirageOS support for Caqti including TLS"

1
unikernel/duniverse/ocaml-caqti/caqti-mirage/dune Normal file
View file

@ -0,0 +1 @@
(dirs :standard \ unikernel)

260
unikernel/duniverse/ocaml-caqti/caqti-mirage/lib/caqti_mirage.ml Normal file
View file

@ -0,0 +1,260 @@
(* Copyright (C) 2022--2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Lwt.Infix
open Caqti_platform
module type SOCKET_OPS =
Caqti_platform.System_sig.SOCKET_OPS with type 'a fiber := 'a Lwt.t
module Make
(STACK : Tcpip.Stack.V4V6)
(DNS : Dns_client_mirage.S) =
struct
module TCP = STACK.TCP
module TLS = Tls_mirage.Make (TCP)
module TCP_channel = Mirage_channel.Make (TCP)
module TLS_channel = Mirage_channel.Make (TLS)
module System_core = struct
include Caqti_lwt.System_core
type stdenv = {
stack: STACK.t;
dns: DNS.t;
}
end
module Alarm = struct
type t = {cancel: unit -> unit}
let schedule ~sw ~stdenv:_ t f =
let t_now = Mtime_clock.now () in
let dt_ns =
if Mtime.is_later t ~than:t_now then 0L else
Mtime.Span.to_uint64_ns (Mtime.span t t_now)
in
let task = Mirage_sleep.ns dt_ns >|= f in
let hook =
Caqti_lwt.Switch.on_release_cancellable sw
(fun () -> Lwt.cancel task; Lwt.return_unit)
in
{cancel = (fun () -> Caqti_lwt.Switch.remove_hook hook; Lwt.cancel task)}
let unschedule alarm = alarm.cancel ()
end
module Pool = Caqti_platform.Pool.Make (System_core) (Alarm)
module System = struct
include System_core
module Pool = Pool
module Net = struct
module Sockaddr = struct
type t = [`Tcp of Ipaddr.t * int | `Unix of string]
let unix s = `Unix s
let tcp (host, port) = `Tcp (host, port)
end
let getaddrinfo_ipv4 dns host port =
let extract (_, ips) =
Ipaddr.V4.Set.elements ips
|> List.map (fun ip -> `Tcp (Ipaddr.V4 ip, port))
in
DNS.getaddrinfo dns Dns.Rr_map.A host >|= Result.map extract
let getaddrinfo_ipv6 dns host port =
let extract (_, ips) =
Ipaddr.V6.Set.elements ips
|> List.map (fun ip -> `Tcp (Ipaddr.V6 ip, port))
in
DNS.getaddrinfo dns Dns.Rr_map.Aaaa host >|= Result.map extract
let getaddrinfo ~stdenv:{stack; dns} host port =
let laddrs = STACK.IP.configured_ips (STACK.ip stack) in
(match
List.exists Ipaddr.(function V4 _ -> true | V6 _ -> false) laddrs,
List.exists Ipaddr.(function V4 _ -> false | V6 _ -> true) laddrs
with
| true, true ->
getaddrinfo_ipv4 dns host port >>= fun r4 ->
getaddrinfo_ipv6 dns host port >|= fun r6 ->
(match r4, r6 with
| Ok addrs4, Ok addrs6 -> Ok (addrs4 @ addrs6)
| Ok addrs, Error _ | Error _, Ok addrs -> Ok addrs
| Error (`Msg msg4), Error (`Msg msg6) ->
if String.equal msg4 msg6 then Error (`Msg msg4) else
Error (`Msg ("IPv4: " ^ msg4 ^ " IPv6: " ^ msg6)))
| true, false -> getaddrinfo_ipv4 dns host port
| false, true -> getaddrinfo_ipv6 dns host port
| false, false ->
Lwt.return (Error (`Msg "No IP address assigned to host.")))
let convert_io_exception = function
| Failure msg -> Some (Caqti_error.Msg msg) (* Channel.S.error *)
| _ -> None
module Make_stream_ops (Channel : Mirage_channel.S) = struct
type t = Channel.t
let output_char channel c =
Channel.write_char channel c;
Lwt.return_unit
let output_string channel s =
Channel.write_string channel s 0 (String.length s);
Lwt.return_unit
let flush channel =
Channel.flush channel >>= function
| Ok () -> Lwt.return_unit
| Error err ->
Lwt.fail_with (Format.asprintf "%a" Channel.pp_write_error err)
let input_char channel =
Channel.read_char channel >>= 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 channel buf off len =
Channel.read_exactly ~len channel >>= 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 channel =
Channel.close channel >>= function
| Ok () -> Lwt.return_unit
| Error err ->
Lwt.fail_with (Format.asprintf "%a" Channel.pp_write_error err)
end
module TCP_stream_ops = Make_stream_ops (TCP_channel)
module TLS_stream_ops = Make_stream_ops (TLS_channel)
module Socket = struct
type t = V : {
tcp_flow: TCP_channel.flow option;
ops: (module SOCKET_OPS with type t = 'a);
channel: 'a;
} -> t
let output_char (V {ops = (module Ops); channel; _}) =
Ops.output_char channel
let output_string (V {ops = (module Ops); channel; _}) =
Ops.output_string channel
let flush (V {ops = (module Ops); channel; _}) =
Ops.flush channel
let input_char (V {ops = (module Ops); channel; _}) =
Ops.input_char channel
let really_input (V {ops = (module Ops); channel; _}) =
Ops.really_input channel
let close (V {ops = (module Ops); channel; _}) =
Ops.close channel
end
type tcp_flow = TCP_channel.flow
type tls_flow = Tls_flow : {
ops: (module SOCKET_OPS with type t = 'a);
channel: 'a;
} -> tls_flow
let connect_tcp ~sw:_ ~stdenv:{stack; _} sockaddr =
(match sockaddr with
| `Unix _ ->
Lwt.return_error
(Caqti_error.Msg "Unix sockets are not available under MirageOS.")
| `Tcp (ipaddr, port) ->
TCP.create_connection (STACK.tcp stack) (ipaddr, port) >|=
(function
| Ok flow ->
let channel = TCP_channel.create flow in
Ok (Socket.V {
tcp_flow = Some flow;
ops = (module TCP_stream_ops);
channel;
})
| Error err ->
let msg = Format.asprintf "%a" TCP.pp_error err in
Error (Caqti_error.Msg msg)))
let tcp_flow_of_socket (Socket.V {tcp_flow; _}) = tcp_flow
let socket_of_tls_flow ~sw:_ (Tls_flow {ops; channel}) =
Socket.V {tcp_flow = None; ops; channel}
module type TLS_PROVIDER = Caqti_platform.System_sig.TLS_PROVIDER
with type 'a fiber := 'a Lwt.t
and type tcp_flow := tcp_flow
and type tls_flow := tls_flow
module Tls_provider = struct
type tls_config = Tls.Config.client
let tls_config_key = Caqti_tls.Config.client
let start_tls ~config ?host flow =
TLS.client_of_flow config ?host flow >|=
(function
| Ok tls_flow ->
Ok (Tls_flow {
ops = (module TLS_stream_ops);
channel = TLS_channel.create tls_flow;
})
| Error err ->
let msg = Format.asprintf "%a" TLS.pp_write_error err in
Error (Caqti_error.Msg msg))
end
let tls_providers_r : (module TLS_PROVIDER) list ref =
ref [(module Tls_provider : TLS_PROVIDER)]
let tls_providers _ = !tls_providers_r
let register_tls_provider p = tls_providers_r := p :: !tls_providers_r
end
end
module Loader = Caqti_platform.Driver_loader.Make (System)
include Connector.Make (System) (Pool) (Loader)
let connect
?subst ?env ?config ?tweaks_version ?(sw = Caqti_lwt.Switch.eternal)
stack dns uri =
connect ?subst ?env ?config ?tweaks_version ~sw ~stdenv:{stack; dns} uri
let with_connection ?subst ?env ?config ?tweaks_version stack dns uri f =
with_connection ?subst ?env ?config ?tweaks_version ~stdenv:{stack; dns} uri f
let connect_pool
?pool_config ?post_connect ?subst ?env ?config ?tweaks_version
?(sw = Caqti_lwt.Switch.eternal) stack dns uri =
connect_pool
?pool_config ?post_connect ?subst ?env ?config ?tweaks_version
~sw ~stdenv:{stack; dns} uri
end

41
unikernel/duniverse/ocaml-caqti/caqti-mirage/lib/caqti_mirage.mli Normal file
View file

@ -0,0 +1,41 @@
(* Copyright (C) 2022--2023 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
(** Functions for connecting to databases from MirageOS unikernels
This module contains functions for connecting to databases using the
MirageOS platform libraries, providing support for PGX but not drivers based
on bindings.
See also {!Caqti_lwt} for basic Lwt support.
{b The caqti-mirage library is experimental at this point.} Feedback from
MirageOS users on the current API is very welcome. *)
module Make :
functor (STACK : Tcpip.Stack.V4V6) ->
functor (DNS : Dns_client_mirage.S) ->
sig
module Pool : Caqti_pool_sig.S with type 'a fiber := 'a Lwt.t
include Caqti_connect_sig.S
with type 'a fiber := 'a Lwt.t
and type ('a, 'e) stream := ('a, 'e) Caqti_lwt.Stream.t
and type ('a, 'e) pool := ('a, 'e) Pool.t
and type connection := Caqti_lwt.connection
and type 'a with_switch := ?sw: Caqti_lwt.Switch.t -> 'a
and type 'a with_stdenv := STACK.t -> DNS.t -> 'a
end

Some files were not shown because too many files have changed in this diff Show more