├── .gitignore ├── .travis.yml ├── CHANGES ├── LICENSE ├── Makefile ├── OCamlMakefile ├── README.md ├── TODO ├── lib ├── META ├── Makefile ├── Makefile.orm ├── ae_db.ml ├── ae_db.mli ├── appengine.nickel ├── appengine_backend.ml ├── appengine_cache.ml ├── appengine_get.ml ├── appengine_save.ml ├── buildjava.sh ├── custom_unix_stubs.c ├── db.ml ├── db.mli ├── sig.ml ├── sql_backend.ml ├── sql_cache.ml ├── sql_delete.ml ├── sql_get.ml ├── sql_init.ml ├── sql_save.ml ├── syntax │ ├── Makefile │ ├── p4_hash.ml │ ├── p4_orm_appengine.ml │ ├── p4_orm_sqlite.ml │ ├── p4_utils.ml │ ├── pa_hash.ml │ └── pa_orm.ml ├── weakid.ml └── weakid.mli ├── lib_test ├── Makefile ├── Makefile.debug ├── alltypes.ml ├── array_simple.ml ├── bib.ml ├── bibtex.ml ├── big_list.ml ├── delete.ml ├── foreign.ml ├── foreign_and_variant.ml ├── foreign_tuple.ml ├── get_set.ml ├── hash.ml ├── large_string.ml ├── list_foreign.ml ├── list_list.ml ├── list_mutate.ml ├── list_share.ml ├── list_simple.ml ├── list_tuple.ml ├── nested_option.ml ├── nested_tuple.ml ├── object_simple.ml ├── option_rec.ml ├── photo.ml ├── record_mutate.ml ├── recursive.ml ├── recursive_mutate.ml ├── simple.ml ├── stress.ml ├── stress_mutate.ml ├── suite.ml ├── test_utils.ml ├── tuple.ml ├── variant.ml └── variant_nested.ml ├── opam └── orm.godiva /.gitignore: -------------------------------------------------------------------------------- 1 | ._d/ 2 | ._bcdi/ 3 | ._ncdi/ 4 | *.annot 5 | *.cmo 6 | *.so 7 | *.o 8 | *.cma 9 | *.cmx 10 | *.cmi 11 | *.swp 12 | *.opt 13 | *.a 14 | *.cmxa 15 | *.db 16 | *.cmj 17 | *.cmja 18 | *.jo 19 | lib/appengine_datastore.ml 20 | lib/appengine_datastore.mli 21 | lib/appengine_datastore.c 22 | lib/org 23 | doc/ 24 | lib/pack 25 | c_*.ml 26 | pc_*.ml 27 | pi_*.ml 28 | *_debug.ml 29 | *_debug.mli 30 | *.dot 31 | lib_test/run_test 32 | lib/p4_hash.ml 33 | lib/p4_hash.mli 34 | /Makefile.config 35 | run_test 36 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: required 3 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh 4 | script: bash -ex .travis-opam.sh 5 | env: 6 | - OCAML_VERSION=4.00 7 | - OCAML_VERSION=4.01 8 | - OCAML_VERSION=4.02 9 | -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | 0.7.1 2 | * Fix contains for string gets (#6, by @mvalle) 3 | * Add TravisCI (#9, by @mvalle and @samoht) 4 | 5 | 0.7.0 (Oct 2012): 6 | * Support (and require) type_conv-108.07.00 or greater. 7 | 8 | 0.6.4 (Sep 2012): 9 | * Fix toplevel usage in META file. 10 | 11 | 0.6.3 (Sep 2012): 12 | * Update to dyntype 0.8.4 13 | 14 | 0.6.2 (Jan 2011): 15 | * abstract table index of type x to `ORMID_x.t` 16 | * generate a unified module representation ORM_x for all the generated functions (useful to make functors). 17 | * add lazy getters. 18 | * add order_by. 19 | 20 | 0.6.1 (Jan 2011): 21 | * Use dyntype 0.7.2 22 | * Fix save and get for big lists (ie more than 64 elements) 23 | 24 | 0.6.0 (Sep 2010): 25 | * Fix annoying bug when assigning the empty list to a mutable list. 26 | * Use the new dyntype's interface to create custom ID generator. 27 | * Allow non-recursive deletion of values. 28 | * Add x_get_by_id to retrieve values by id directly. 29 | * Experimental support for Google Appengine datastore. 30 | 31 | 0.5.1 (Mar 2010): 32 | * Fix database sharing of lists for small sizes. 33 | * Rename `True|`False to `T|`F to fix syntax conflict. 34 | * Fix variant phantom types of RW/RO handles. 35 | * Make generated SQL more robust against older SQLite. 36 | 37 | 0.5 (Feb 2010): 38 | * Simplify layout and use the dyntype library. 39 | * Many, many bugfixes and test suite improvements. 40 | * Breakdown core into smaller sub-libraries for value, hash, type 41 | comparison, and weak table generation. 42 | 43 | 0.4 (Oct 2009): 44 | * Add a hash function generation library for most ML types. 45 | * Sub-typing checking improvements. 46 | * Fixed mutable records not hashing correctly. 47 | * Add a t_id function to return an int64 UUID for a value. 48 | * Add debug "none" keyword to disable debug explicitly. 49 | * Store type in database to ensure safe attachment at runtime. 50 | * More debugging in SQL mode for index/trigger creation. 51 | 52 | 0.3 (Oct 2009): 53 | * Add support for index (both lookup and unique). 54 | * Rewrite to a camlp4 (3.11+) code base and remove old extension. 55 | 56 | 0.2 (May 2009): 57 | * Add support for unique indices of groups of fields. 58 | * Add a 'real' function for floating point datatypes. 59 | 60 | 0.1 (May 2009): 61 | * Add support for custom WHERE clauses in queries. 62 | * Custom busy functions and control over the SQL transaction type. 63 | * Many bug fixes for foreign operations and new tests. 64 | * Initial release. 65 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2009-2012 Anil Madhavapeddy 3 | * Copyright (c) 2009-2012 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | -include Makefile.config 2 | 3 | .PHONY: all 4 | all: 5 | $(MAKE) -C lib/ 6 | 7 | .PHONY: test 8 | test: all 9 | $(MAKE) -C lib/ 10 | $(MAKE) -C lib_test/ run 11 | 12 | .PHONY: install 13 | install: all 14 | $(MAKE) -C lib/ install 15 | 16 | .PHONY: uninstall 17 | uninstall: 18 | $(MAKE) -C lib/ uninstall 19 | 20 | .PHONY: reinstall 21 | reinstall: 22 | $(MAKE) uninstall 23 | $(MAKE) install 24 | 25 | .PHONY: clean 26 | clean: 27 | $(MAKE) -C lib/ clean 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | The ORM library provides a storage backend to persist ML values. This backend is integrated seamlessly with OCaml and currently uses SQLite (although other backends are easily possible). The user does not have to worry about writing any SQL queries manually. 2 | 3 | Installation 4 | ============ 5 | 6 | You can download the latest distribution from Github at . It also depends on the following libraries: 7 | 8 | * `dyntype` : version 0.9.0+, available from 9 | 10 | * `ocaml-sqlite3`: version 1.5.7+, available from . Earlier versions had crash bugs which are easily triggered by the ORM library, so please ensure you are up-to-date before reporting bugs. 11 | 12 | * `type-conv`: version 108.07.00+, available from 13 | 14 | * `sqlite3`: version 3.6.22+, available from . Earlier versions had crash bugs which are easily triggered by the ORM library, so please ensure you are up-to-date before reporting bugs. Note that you may also need `pkg-config` installed for this to compile, so on MacOS X do `brew install pkg-config sqlite3` to get the latest dependencies for the OCaml bindings. 15 | 16 | The library installs an ocamlfind META file, so use it with the `orm.syntax` package. To compile a file `foo.ml` with the ORM and findlib, do: 17 | 18 | ocamlfind ocamlopt -syntax camlp4o -package orm.syntax -c t.ml 19 | 20 | To link it into a standalone executable: 21 | 22 | ocamlfind ocamlopt -syntax camlp4o -linkpkg -package orm.syntax t.ml 23 | 24 | You can report issues using the Github issue tracker at , or mail the authors at . If you use the ORM somewhere, feel free to drop us a short line and we can add your project to the Wiki as well. 25 | 26 | We recommend installation via the OPAM package manager, available at . Simply do `opam install orm`. 27 | 28 | Usage 29 | ===== 30 | 31 | For each type definition `t` annotated with the keyword `orm`, a tuple of functions to persist and query the saved values are automatically generated: 32 | 33 | (* User-defined datatype *) 34 | type t = ... with orm 35 | 36 | (* Auto-generated signatures *) 37 | val t_init: string -> (t, [ `RW ]) db 38 | val t_init_read_only: string -> (t, [ `RO ]) db 39 | val t_get: (t, [< `RW | `RO ]) db -> ... -> t list 40 | val t_save: (t, [ `RW ]) db -> t -> unit 41 | val t_delete: (t, [ `RW ]) db -> t -> unit 42 | 43 | Example 44 | ------- 45 | 46 | This example define a basic ML types corresponding to a photo gallery: 47 | 48 | type image = string 49 | and gallery = { 50 | name: string; 51 | date: float; 52 | contents: image list; 53 | } with orm 54 | 55 | We hold an `image` as a binary string, and a gallery is a named list of images. First, init functions are generated for both `image` and `gallery`: 56 | 57 | val image_init : string -> (image, [ `RW ]) db 58 | val gallery_init : string -> (gallery, [ `RW ]) db 59 | val image_init_read_only : string -> (image, [ `RO ]) db 60 | val gallery_init_read_only : string -> (gallery, [ `RO ]) db 61 | 62 | Query functions are generated with signatures matching the various fields in the record or object, for example: 63 | 64 | val gallery_get : (gallery, [< `RO | `RW ]) db -> 65 | ?name:[ `Eq string | `Contains string] -> 66 | ?date:[ `Le float | `Ge float | `Eq float | `Neq float] -> 67 | ?custom:(gallery -> bool) -> 68 | gallery list 69 | 70 | let my_pics db = gallery_get ~name:(`Contains "Anil") db 71 | let my_pics db = gallery_get ~custom:(fun g -> String.lowercase g.name = "anil") db 72 | 73 | To use this, you simply pass the database handle and specify any constraints to the optional variables. More complex functions can be specified using the `custom` function which filters the full result set (as seen in the second example above). 74 | 75 | Be aware that custom functions currently disable the query optimizer and force a full scan. We are investigating ways of exposing relational operations in a future release, and ideas (or even better, patches) are always appreciated. 76 | 77 | How It Works 78 | ------------ 79 | 80 | Intuitively, calling `gallery_init` will: 81 | 82 | 1. use `dyntype.type-of` to translate the type definitions into: 83 | 84 | let type_of_image = Ext ( "image", String ) 85 | let type_of_gallery = 86 | Ext("gallery", Dict [ 87 | ("name", String); ("date", Float) ; ("contents", Enum type_of_image) 88 | ]) 89 | 90 | 2. use some basic inductive rules to generate the database schema: 91 | 92 | CREATE TABLE image (__id__ INTEGER PRIMARY KEY, image TEXT); 93 | CREATE TABLE gallery (__id__ INTEGER PRIMARY KEY, gallery__name TEXT, 94 | gallery__date REAL, gallery__contents__0 INTEGER); 95 | CREATE TABLE gallery__contents__0 (__id__ INTEGER PRIMARY KEY, 96 | __next__ INTEGER, __size__ INTEGER, gallery__contents__0 INTEGER); 97 | 98 | Second, using `dyntype.value`, any value of type `image` or `gallery` can be translated into a value of type `Value.t`. Save functions can be then defined with the signature: 99 | 100 | val image_save : (image, [ `RW ]) db -> image -> unit 101 | val gallery_save : (gallery, [ 'RW ]) db -> gallery -> unit 102 | 103 | Finally, using `Dyntype.type-of`, functions to access the database are generated, with the signature: 104 | 105 | val image_get : (image, [< `RO | `RW ]) db -> 106 | ?value:[`Contains of string | `Eq of string] ] -> 107 | ?custom:(image -> bool) -> 108 | image list 109 | 110 | val gallery_get : (gallery, [< `RO | `RW ]) db -> 111 | ?name:[ `Eq string | `Contains string] -> 112 | ?date:[ `Le float | `Ge float | `Eq float | `Neq float] -> 113 | ?custom:(gallery -> bool) -> 114 | gallery list 115 | 116 | For both types, we are generating: 117 | 118 | 1. arguments that can be easily translated into an optimized SQL queries; 119 | 2. a more general (and thus slow) custom query function directly written in OCaml. 120 | 121 | On one hand, (1) is achieved by generating optional labelled arguments with the OCaml type corresponding to what `Dyntype.type_of` generated. This allows the programmer to specify a conjunction of type-safe constraints for his queries. For example, the field `name` is of type string which is associated to the constraint of type `Eq of string | Contains of string`. Values of this type can then be mapped to SQL equality or the `LIKE` operator. 122 | 123 | On the other hand, (2) is achieved using a SQLite extension to define custom SQL functions; in our case we register an OCaml callback directly. This is relatively slow as it bypasses the query optimizer, but allows the programmer to define very complex queries. 124 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | Known issues and TODO list before a 1.0 release. Until then, the 2 | ORM is a work-in-progress and anything is subject to change dramatically! 3 | 4 | Issues: 5 | ------- 6 | 7 | - ORM: 8 | * no type-conv signature generator yet 9 | * handle type t = { x : M.t } 10 | * handle type 'a t = { x : 'a } 11 | 12 | Interface changes: 13 | ----------------- 14 | 15 | - Add a x_fold function to match the x_get function 16 | 17 | - Sqlite CONSTRAINT errors for uniqueness violations (e.g. on a unique 18 | indexed field) need to be exposed better than just throwing up the 19 | CONSTRAINT error which is really hard to track down. 20 | 21 | Optimization: 22 | ------------ 23 | 24 | - Bind sqlite3_profile to make that information available. 25 | 26 | Nice to have: 27 | ------------ 28 | 29 | - A field name of "id" in a record will cause an error; type 30 | checker should reject these or rewrite them into something different. 31 | 32 | - Warn on reserved keywords in types (id, from) which are not 33 | valid SQL field names (or transform them to be safe). 34 | 35 | - Add foreign key constraints for sanity checking in debug mode. 36 | Not strictly needed, but an additional integrity check 37 | 38 | - Generate smart ocamldoc; not sure if this is possible with camlp4 39 | extensions without a custom doc generator. 40 | -------------------------------------------------------------------------------- /lib/META: -------------------------------------------------------------------------------- 1 | name = "orm" 2 | version = "0.7.1" 3 | description = "An Object-Relational Mapper (ORM) to persist and retrieve data" 4 | 5 | archive(byte) = "orm.cma" 6 | archive(byte,plugin) = "orm.cma" 7 | archive(native) = "orm.cmxa" 8 | archive(native,plugin) = "orm.cmxs" 9 | requires = "num, sqlite3, unix, dyntype" 10 | 11 | package "syntax" ( 12 | requires = "dyntype.syntax, camlp4, dyntype, orm" 13 | description = "Syntax extension for ORM" 14 | archive(syntax, preprocessor) = "pa_orm.cma" 15 | archive(syntax, toploop) = "pa_orm.cma" 16 | ) 17 | -------------------------------------------------------------------------------- /lib/Makefile: -------------------------------------------------------------------------------- 1 | .DEFAULT: all 2 | 3 | all: 4 | $(MAKE) -C syntax $@ 5 | $(MAKE) -f Makefile.orm $@ 6 | 7 | clean: 8 | $(MAKE) -C syntax $@ 9 | $(MAKE) -f Makefile.orm $@ 10 | 11 | install: all 12 | $(SUDO) $(MAKE) -f Makefile.orm libinstall 13 | 14 | uninstall: 15 | $(SUDO) ocamlfind remove orm 16 | 17 | reinstall: 18 | $(MAKE) uninstall 19 | $(MAKE) install 20 | -------------------------------------------------------------------------------- /lib/Makefile.orm: -------------------------------------------------------------------------------- 1 | export OCAMLMAKEFILE = ../OCamlMakefile 2 | 3 | ANNOTATE = yes 4 | SOURCES = custom_unix_stubs.c weakid.ml sql_backend.ml sql_init.ml sql_save.ml sql_get.ml sql_delete.ml sql_cache.ml db.ml sig.ml 5 | RESULT = orm 6 | PACKS = sqlite3 dyntype.syntax 7 | LIB_PACK_NAME = orm 8 | 9 | LIBINSTALL_FILES = orm.cmx orm.cmxa orm.cma orm.cmi orm.a dllorm_stubs.so liborm_stubs.a syntax/pa_orm.cma 10 | 11 | .PHONY: all 12 | all: ncl dcl 13 | @ : 14 | 15 | include $(OCAMLMAKEFILE) 16 | -------------------------------------------------------------------------------- /lib/ae_db.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2010 Thomas Gazagnaire 3 | * Copyright (c) 2010 Anil Madhavapeddy 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | type ('a, +'b) t = Appengine_backend.state 19 | let of_state x = x 20 | let to_state x = x 21 | -------------------------------------------------------------------------------- /lib/ae_db.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2010 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | type ('a, +'b) t 18 | val of_state : Appengine_backend.state -> ('a, 'b) t 19 | val to_state : ('a, 'b) t -> Appengine_backend.state 20 | -------------------------------------------------------------------------------- /lib/appengine.nickel: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | -------------------------------------------------------------------------------- /lib/appengine_backend.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2009-2010 3 | * Anil Madhavapeddy 4 | * Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open Appengine_datastore 20 | open Printf 21 | 22 | type transaction_mode = [ `Deferred |`Immediate |`Exclusive ] 23 | 24 | type state = { 25 | name : string; 26 | svc: datastore_service; 27 | } 28 | 29 | type env = [ 30 | `Debug of string list 31 | | `Dot of string 32 | | `Index of (string * string list) list 33 | | `Unique of (string * string list) list ] list 34 | 35 | let debug db (env:env) ty n e = 36 | let in_env s = List.exists (function | `Debug sl -> List.mem s sl | _ -> false) env in 37 | let d () = Printf.eprintf "%s(%s): %s\n%!" n db e in 38 | let b () = () in 39 | if match ty with 40 | |`Sql -> in_env "sql" || in_env "all" 41 | |`Cache -> in_env "cache" || in_env "all" 42 | |`Bind -> in_env "bind" || in_env "all" 43 | then d() else b() 44 | 45 | let new_state name = 46 | let svc = (new datastore_service_factory `Null)#getDatastoreService in 47 | { name = name; svc = svc; } 48 | -------------------------------------------------------------------------------- /lib/appengine_cache.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2009-2010 3 | * Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | open Sqlite3 19 | open Sql_backend 20 | 21 | let global_count = ref 0 22 | 23 | let clean_list : (unit -> unit) list ref = ref [] 24 | let flush_list : (string -> unit) list ref = ref [] 25 | let sync_list : (string -> string -> int64 -> unit) list ref = ref [] 26 | 27 | let clean_all env name = 28 | debug (name ^ ":*") env `Cache "cache" (Printf.sprintf "clean_all(%i)" (List.length !clean_list)); 29 | List.iter (fun f -> f ()) !clean_list 30 | 31 | let flush_all env name = 32 | debug (name ^ ":*") env `Cache "cache" (Printf.sprintf "flush_all(%s,%i)" name (List.length !flush_list)); 33 | List.iter (fun f -> f name) !flush_list 34 | 35 | let sync_all env name table id = 36 | debug (name ^ ":*") env `Cache "cache" (Printf.sprintf "sync_all(%s,%s,%Ld,%i)" name table id (List.length !sync_list)); 37 | List.iter (fun f -> f name table id) !sync_list 38 | 39 | 40 | module Trigger = struct 41 | 42 | let name table = 43 | Printf.sprintf "SYNC_CACHE_%s" table 44 | 45 | (* custom function needs to be registred for each connection *) 46 | let create_function ~env ~db table = 47 | let trigger_fn = function 48 | | Data.INT id -> sync_all env db.name table id; Data.NULL 49 | | _ -> failwith (name table) in 50 | create_fun1 db.db (name table) trigger_fn 51 | 52 | (* trigger needs to be registred once per pair (database * type) *) 53 | let install ~env ~db table = 54 | let sync_trigger = Printf.sprintf 55 | "CREATE TRIGGER IF NOT EXISTS %s_update_cache AFTER DELETE ON %s FOR EACH ROW BEGIN SELECT %s(OLD.__id__); END;" 56 | table table (name table) in 57 | exec_sql ~tag:"cache" ~env ~db sync_trigger [] (db_must_step db) 58 | 59 | end 60 | 61 | type ('a, 'b) t = { 62 | type_name : string; 63 | tbl : (string, 'a) Hashtbl.t; 64 | create : int -> 'a; 65 | to_weakid : 'a -> 'b -> int64; 66 | of_weakid : 'a -> int64 -> 'b list; 67 | mem : 'a -> 'b -> bool; 68 | mem_weakid : 'a -> int64 -> bool; 69 | add : 'a -> 'b -> int64 -> unit; 70 | remove : 'a -> 'b -> unit; 71 | replace : 'a -> 'b -> int64 -> unit; 72 | dump : 'a -> string; 73 | } 74 | 75 | let string_of_t string_of_a t = 76 | let tbls = Hashtbl.fold (fun db a acc -> (db, a) :: acc) t.tbl [] in 77 | let tbls = List.map (fun (db, a) -> Printf.sprintf "(%s, %s)" db (string_of_a a)) tbls in 78 | let tbl = String.concat "," tbls in 79 | Printf.sprintf "%s_cache={%s}" t.type_name tbl 80 | 81 | module type Sig = sig 82 | type tbl 83 | type elt 84 | val create : string -> (tbl, elt) t 85 | end 86 | 87 | module Make (H : Hashtbl.HashedType) : Sig with type tbl = Weakid.Make(H).t and type elt = Weakid.Make(H).elt = struct 88 | 89 | module W = Weakid.Make(H) 90 | 91 | type tbl = W.t 92 | type elt = W.elt 93 | 94 | let clean t = 95 | let to_remove = ref [] in 96 | Hashtbl.iter (fun k v -> if W.length v = 0 then to_remove := k :: !to_remove) t.tbl; 97 | List.iter (fun k -> Hashtbl.remove t.tbl k) !to_remove 98 | 99 | let flush t name = 100 | let to_remove = ref [] in 101 | Hashtbl.iter (fun k v -> if k = name then (to_remove := k :: !to_remove; W.clear v)) t.tbl; 102 | List.iter (fun k -> Hashtbl.remove t.tbl k) !to_remove 103 | 104 | let sync t name table id = 105 | let aux w = 106 | let vs = t.of_weakid w id in 107 | List.iter (t.remove w) vs in 108 | if t.type_name = table then 109 | Hashtbl.iter (fun k v -> if k = name then aux v) t.tbl 110 | 111 | let create name = 112 | let tbl = Hashtbl.create 32 in 113 | let t = { 114 | type_name = name; 115 | tbl = tbl; 116 | create = W.create; 117 | to_weakid = W.to_weakid; 118 | of_weakid = W.of_weakid; 119 | mem = W.mem; 120 | mem_weakid = W.mem_weakid; 121 | add = W.add; 122 | remove = W.remove; 123 | replace = W.replace; 124 | dump = W.dump; 125 | } in 126 | clean_list := (fun () -> clean t) :: !clean_list; 127 | flush_list := (flush t) :: !flush_list; 128 | sync_list := (sync t) :: !sync_list; 129 | t 130 | end 131 | 132 | let with_table env t db fn = 133 | incr global_count; 134 | if !global_count mod 10000 = 0 then clean_all env db; 135 | let tbl = 136 | if Hashtbl.mem t.tbl db then 137 | Hashtbl.find t.tbl db 138 | else begin 139 | let w = t.create 128 in 140 | Hashtbl.replace t.tbl db w; 141 | let s = new_state db in 142 | Trigger.install ~env ~db:s t.type_name; 143 | w 144 | end in 145 | fn tbl 146 | 147 | let debug env t db s = 148 | debug (db ^ ":*") env `Cache "cache" (Printf.sprintf "calling %s(%s)" s db) 149 | 150 | let to_weakid env t db elt = 151 | debug env t db "to_weakid"; 152 | with_table env t db (fun tbl -> t.to_weakid tbl elt) 153 | 154 | let of_weakid env t db id = 155 | debug env t db "of_weakid"; 156 | with_table env t db (fun tbl -> t.of_weakid tbl id) 157 | 158 | let mem env t db elt = 159 | debug env t db "mem"; 160 | with_table env t db (fun tbl -> t.mem tbl elt) 161 | 162 | let mem_weakid env t db id = 163 | debug env t db "mem_weakid"; 164 | with_table env t db (fun tbl -> t.mem_weakid tbl id) 165 | 166 | let add env t db elt = 167 | debug env t db "add"; 168 | with_table env t db (fun tbl -> t.add tbl elt) 169 | 170 | let remove env t db elt = 171 | debug env t db "remove"; 172 | with_table env t db (fun tbl -> t.remove tbl elt) 173 | 174 | let replace env t db elt id = 175 | debug env t db "replace"; 176 | with_table env t db (fun tbl -> t.replace tbl elt id) 177 | -------------------------------------------------------------------------------- /lib/appengine_get.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2009-2010 Anil Madhavapeddy 3 | * Copyright (c) 2009 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | open Printf 19 | open Appengine_datastore 20 | 21 | (* 22 | let string_of_constraint (name, c) = 23 | let make name = String.concat "__" name in 24 | let bool name = function 25 | | `T -> make name, "=", Some (Data.INT 1L) 26 | | `F -> make name, "=", Some (Data.INT 0L) 27 | and int_like name conv = function 28 | | `Eq i -> make name, "=", Some (conv i) 29 | | `Neq i -> make name, "!=", Some (conv i) 30 | | `Le i -> make name, "<", Some (conv i) 31 | | `Ge i -> make name, ">", Some (conv i) 32 | | `Leq i -> make name, "<=", Some (conv i) 33 | | `Geq i -> make name, ">=", Some (conv i) 34 | and string name = function 35 | | `Eq s -> make name, "IS", Some (Data.TEXT s) 36 | | `Contains s -> make name, "IS", Some (Data.TEXT (sprintf "*%s*" s)) in 37 | match c with 38 | | `Bool b -> bool name b 39 | | `String s -> string name s 40 | | `Float f -> int_like name (fun f -> Data.FLOAT f) f 41 | | `Char c -> int_like name (fun c -> Data.INT (Int64.of_int (Char.code c))) c 42 | | `Int i -> int_like name (fun i -> Data.INT (Int64.of_int i)) i 43 | | `Int32 i -> int_like name (fun i -> Data.INT (Int64.of_int32 i)) i 44 | | `Int64 i -> int_like name (fun i -> Data.INT i) i 45 | | `Big_int i -> int_like name (fun i -> Data.TEXT (Big_int.string_of_big_int i)) i 46 | *) 47 | 48 | let of_jlong (j:CadmiumObj.jObject) = (new lang_long (`Cd'initObj j))#longValue 49 | let of_jbool (j:CadmiumObj.jObject) = (new lang_bool (`Cd'initObj j))#booleanValue 50 | let of_jfloat (j:CadmiumObj.jObject) = (new lang_float (`Cd'initObj j))#floatValue 51 | let of_jstring (j:CadmiumObj.jObject) = (new lang_string (`Cd'initObj j))#toString 52 | 53 | let foldIter fn i o = 54 | let r = ref i in 55 | while o#hasNext do 56 | r := fn !r o#next 57 | done; 58 | List.rev !r 59 | 60 | let foldIter2 fn i o l = 61 | let r = ref i in 62 | List.iter (fun l' -> 63 | if o#hasNext then 64 | r := fn !r o#next l' 65 | else 66 | Printf.printf "foldIter2 fail\n%!" 67 | ) l; 68 | List.rev !r 69 | 70 | let rec to_value prop ty = 71 | let cl = prop#getClass#getName in 72 | match ty, cl with 73 | | Type.Unit, _ -> Value.Unit 74 | | Type.Int _, _ -> Value.Int (of_jlong prop) 75 | | Type.Bool, _ -> Value.Bool (of_jbool prop) 76 | | Type.Char, _ | Type.String, _ -> Value.String (of_jstring prop) 77 | | Type.Enum ty', "java.util.ArrayList" -> 78 | let l = new util_arraylist (`Cd'initObj prop) in 79 | Value.Enum (foldIter (fun a v -> to_value v ty' :: a) [] l#iterator) 80 | | Type.Tuple tyl, "java.util.ArrayList" -> 81 | let l = new util_arraylist (`Cd'initObj prop) in 82 | Value.Tuple (foldIter2 (fun a v ty' -> (to_value v ty') :: a) [] l#iterator tyl) 83 | | tyl, "java.lang.String" -> 84 | Json.of_string tyl (of_jstring prop) 85 | | ty,cl -> Printf.printf "Unknown ty/cl: %s %s, returning null\n%!" (Type.to_string ty) cl; failwith "" 86 | 87 | let entity_to_value n ty (ent:entity) = 88 | let ty_fields = match ty with 89 | | Type.Dict ts -> List.map (fun (k,_,v) -> (k,v)) ts 90 | | x -> Printf.printf "ent_to_val: %s\n%!" (Type.to_string x); failwith "" 91 | in 92 | let ps = foldIter (fun a o -> 93 | let key = (new lang_string (`Cd'initObj o))#toString in 94 | let prop = ent#getProperty key in 95 | let v = to_value prop (List.assoc key ty_fields) in 96 | (key,v) :: a 97 | ) [] ent#getProperties#keySet#iterator in 98 | Value.Ext ((n,0L), Value.Dict ps) 99 | 100 | let get_values ~env ~db ?id ?(constraints=[]) ?custom_fn (t:Type.t) = 101 | (* let gql = String.concat " AND " (List.map string_of_constraint constraints) in *) 102 | match t with 103 | | Type.Rec (n, t) 104 | | Type.Ext (n, t) -> 105 | let gql = n in 106 | let query = new query (`String gql) in 107 | let pq = db.Appengine_backend.svc#prepare query in 108 | let iter = pq#asIterator in 109 | foldIter (fun a o -> 110 | let ent = new entity (`Cd'initObj o) in 111 | (0L, entity_to_value n t ent) :: a 112 | ) [] iter 113 | | _ -> failwith "TODO" 114 | -------------------------------------------------------------------------------- /lib/appengine_save.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2009-2010 3 | * Anil Madhavapeddy 4 | * Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open Printf 20 | 21 | open Appengine_datastore 22 | 23 | let fail fmt = 24 | let xfn f = Printf.printf "FAIL: %s\n%!" f; failwith "" in 25 | kprintf xfn fmt 26 | 27 | let to_jlong i = (new lang_long (`Long i) :> CadmiumObj.jObject) 28 | let to_jbool b = (new lang_bool (`Bool b) :> CadmiumObj.jObject) 29 | let to_jfloat v = (new lang_float (`Float v) :> CadmiumObj.jObject) 30 | let to_jstring s = (new lang_string (`String s) :> CadmiumObj.jObject) 31 | let to_jlist fn l = 32 | let v = new lang_vector (`Int (Int32.of_int (List.length l))) in 33 | List.iter (fun e -> v#addElement (fn e)) l; 34 | (v :> CadmiumObj.jObject) 35 | 36 | let to_entity ty va = 37 | match ty, va with 38 | | (Type.Ext (n, Type.Dict ts)), (Value.Ext (_, Value.Dict vs)) -> 39 | let ent = new entity (`String n) in 40 | List.iter (fun (f, v) -> 41 | match v with 42 | | Value.Unit -> ent#setProperty f (to_jlong 0L) 43 | | Value.Int i -> ent#setProperty f (to_jlong i) 44 | | Value.Bool b -> ent#setProperty f (to_jbool b) 45 | | Value.Float v -> ent#setProperty f (to_jfloat v) 46 | | Value.String s -> ent#setProperty f (to_jstring s) 47 | | Value.Tuple vl 48 | | Value.Enum vl -> 49 | let l = to_jlist (function 50 | | Value.Int i -> to_jlong i 51 | | Value.Bool b -> to_jbool b 52 | | Value.Float v -> to_jfloat v 53 | | Value.String s -> to_jstring s 54 | | Value.Unit -> to_jlong 0L 55 | | x -> to_jstring (Json.to_string x) 56 | ) vl in 57 | ent#setProperty f l 58 | | v -> ent#setProperty f (to_jstring (Json.to_string v)) 59 | ) vs; 60 | ent 61 | | ty, va -> fail "to_entity: ty=%s va=%s" (Type.to_string ty) (Value.to_string va) 62 | 63 | let update_value ~env ~db ty va = 64 | let ent = to_entity ty va in 65 | let _ = db.Appengine_backend.svc#put ent in 66 | () 67 | -------------------------------------------------------------------------------- /lib/buildjava.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash -ex 2 | # build and install the appengine java backend 3 | 4 | OCAMLJAVA=${OCAMLJAVA:-ocamljava.opt} 5 | JAVAC=${JAVAC:-javac} 6 | JAVA=${JAVA:-java} 7 | SUDO=${SUDO:-sudo} 8 | OCAMLFIND=${OCAMLFIND:-ocamlfind} 9 | 10 | SOURCES_ML="appengine_datastore.ml appengine_backend.ml weakid.ml appengine_save.ml appengine_get.ml ae_db.ml" 11 | SOURCES_MLI="appengine_datastore.mli weakid.mli ae_db.mli" 12 | SOURCES_CMJ=$(echo ${SOURCES_ML} | sed -e 's/\.ml/.cmj/g') 13 | 14 | CADMIUM_DIR=${CADMIUM_DIR:-~/src/oss/java/ocaml-appengine/dist} 15 | PATH_appengine=${CADMIUM_DIR}/appengine-api-1.0-sdk-1.3.1.jar 16 | PATH_ocamlrun=${CADMIUM_DIR}/ocamlrun.jar 17 | PATH_ocamlwrap=${CADMIUM_DIR}/ocamlwrap.jar 18 | PATH_ocamlrun_servlet=${CADMIUM_DIR}/ocamlrun-servlet.jar 19 | 20 | OCAMLBCFLAGS="-classpath ${PATH_ocamlwrap}:${PATH_ocamlrun_servlet}:${PATH_appengine}:. -I +cadmium -provider fr.x9c.cadmium.primitives.cadmiumservlet.Servlets -provider org.openmirage.orm.prims.Appengine_datastore" 21 | 22 | rm -rf org 23 | mkdir -p org/openmirage/orm/prims 24 | env CLASSPATH=${PATH_ocamlwrap}:${PATH_appengine} ${JAVA} fr.x9c.nickel.Main --java-dir=org/openmirage/orm/prims --java-package=org.openmirage.orm.prims appengine.nickel 25 | ${JAVAC} -target 1.6 -cp ${PATH_ocamlrun}:${PATH_appengine} org/openmirage/orm/prims/Appengine_datastore.java 26 | ${OCAMLJAVA} -i -I +cadmium appengine_datastore.ml > appengine_datastore.mli 27 | ${OCAMLJAVA} ${OCAMLBCFLAGS} -for-pack Orm -java-package org.openmirage.orm -c -annot -I +cadmium -I +site-lib/dyntype -I +site-lib/shelf ${SOURCES_MLI} ${SOURCES_ML} 28 | 29 | ${OCAMLJAVA} -pack ${SOURCES_CMJ} -o orm.cmj 30 | 31 | jar cvf orm_ae.jar org 32 | 33 | ODIR=`${OCAMLFIND} printconf path`/orm 34 | ${SUDO} mkdir -p ${ODIR} 35 | ${SUDO} cp orm.cmj orm.cmi orm.jo orm_ae.jar ${ODIR}/ 36 | -------------------------------------------------------------------------------- /lib/custom_unix_stubs.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2009 Anil Madhavapeddy 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | */ 16 | 17 | #include 18 | #include 19 | #include 20 | 21 | #include 22 | #include 23 | #include 24 | #include 25 | #include 26 | #include 27 | #include 28 | 29 | CAMLprim value orm_unix_realpath(value path) 30 | { 31 | char buffer[PATH_MAX]; 32 | char *r; 33 | r = realpath(String_val(path), buffer); 34 | if (r == NULL) uerror("realpath", path); 35 | return copy_string(buffer); 36 | } 37 | -------------------------------------------------------------------------------- /lib/db.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2010 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | type ('a, +'b) t = Sql_backend.state 18 | let of_state x = x 19 | let to_state x = x 20 | -------------------------------------------------------------------------------- /lib/db.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2010 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | type ('a, +'b) t 18 | val of_state : Sql_backend.state -> ('a, 'b) t 19 | val to_state : ('a, 'b) t -> Sql_backend.state 20 | -------------------------------------------------------------------------------- /lib/sig.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2011 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module type ID = sig 18 | type t 19 | val of_int64: int64 -> t 20 | val to_int64: t -> int64 21 | end 22 | 23 | module Make_ID (A : sig end) : ID = struct 24 | type t = int64 25 | let of_int64 x = x 26 | let to_int64 x = x 27 | end 28 | 29 | module type T = sig 30 | type t 31 | type id 32 | type 'a get_params 33 | type order_by 34 | val init : string -> (t, [`RW]) Db.t 35 | val init_read_only : string -> (t, [`RO]) Db.t 36 | val save : db:(t, [`RW]) Db.t -> t -> unit 37 | val get : (?custom:(t -> bool) -> ?order_by:order_by -> (t, [< `RO|`RW]) Db.t -> t list) get_params 38 | val lazy_get : (?custom:(t -> bool) -> ?order_by:order_by -> (t, [< `RO|`RW]) Db.t -> (unit -> t option)) get_params 39 | val get_by_id : id:[`Eq of id] -> (t, [< `RO|`RW]) Db.t -> t 40 | val delete : ?recursive:bool -> db:(t, [`RW]) Db.t -> t -> unit 41 | val id : db:(t, [< `RO|`RW]) Db.t -> t -> id 42 | end 43 | -------------------------------------------------------------------------------- /lib/sql_backend.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2009-2010 3 | * Anil Madhavapeddy 4 | * Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open Sqlite3 20 | open Printf 21 | open Dyntype 22 | 23 | (* Maximum number of JOINS *) 24 | let max_join = 64 25 | 26 | type transaction_mode = [ `Deferred |`Immediate |`Exclusive ] 27 | 28 | type state = { 29 | uuid : int; 30 | name : string; 31 | db : db; 32 | mutable in_transaction: int; 33 | busyfn: db -> unit; 34 | mode: transaction_mode; 35 | } 36 | 37 | type env = [ 38 | `Debug of string list 39 | | `Dot of string 40 | | `Index of (string * string list) list 41 | | `Unique of (string * string list) list ] list 42 | 43 | let debug db (env:env) ty n e = 44 | let in_env s = List.exists (function | `Debug sl -> List.mem s sl | _ -> false) env in 45 | let d () = Printf.eprintf "%s(%s): %s\n%!" n db e in 46 | let b () = () in 47 | if match ty with 48 | |`Sql -> in_env "sql" || in_env "all" 49 | |`Cache -> in_env "cache" || in_env "all" 50 | |`Bind -> in_env "bind" || in_env "all" 51 | then d() else b() 52 | 53 | let default_busyfn (db:Sqlite3.db) = 54 | print_endline "WARNING: busy"; 55 | Unix.sleep 1 56 | 57 | let new_state name = { 58 | uuid = Random.int 100; 59 | name = name; 60 | db = db_open name; 61 | in_transaction = 0; 62 | busyfn = default_busyfn; 63 | mode = `Deferred 64 | } 65 | 66 | let raise_sql_error x = 67 | raise (Sqlite3.Error (Rc.to_string x)) 68 | 69 | let try_finally fn finalfn = 70 | try 71 | let r = fn () in 72 | finalfn (); 73 | r 74 | with e -> begin 75 | print_endline (sprintf "WARNING: exception: %s" (Printexc.to_string e)); 76 | finalfn (); 77 | raise e 78 | end 79 | 80 | (* retry until a non-BUSY error code is returned *) 81 | let rec db_busy_retry db fn = 82 | match fn () with 83 | | Rc.BUSY -> 84 | db.busyfn db.db; 85 | db_busy_retry db fn; 86 | | x -> x 87 | 88 | (* make sure an OK is returned from the database *) 89 | let db_must_ok db fn = 90 | match db_busy_retry db fn with 91 | | Rc.OK -> () 92 | | x -> raise_sql_error x 93 | 94 | (* make sure a DONE is returned from the database *) 95 | let db_must_done db fn = 96 | match db_busy_retry db fn with 97 | | Rc.DONE -> () 98 | | x -> raise_sql_error x 99 | 100 | let db_must_bind db stmt pos data = 101 | db_must_ok db (fun () -> Sqlite3.bind stmt pos data) 102 | 103 | let db_must_reset db stmt = 104 | db_must_ok db (fun () -> Sqlite3.reset stmt) 105 | 106 | let db_must_step db stmt = 107 | db_must_done db (fun () -> Sqlite3.step stmt) 108 | 109 | (* request a transaction *) 110 | let transaction db fn = 111 | let m = match db.mode with 112 | | `Deferred -> "DEFERRED" 113 | | `Immediate -> "IMMEDIATE" 114 | | `Exclusive -> "EXCLUSIVE" in 115 | try_finally 116 | (fun () -> 117 | if db.in_transaction = 0 then 118 | db_must_ok db (fun () -> exec db.db (sprintf "BEGIN %s TRANSACTION" m)); 119 | db.in_transaction <- db.in_transaction + 1; 120 | fn (); 121 | ) (fun () -> 122 | if db.in_transaction = 1 then 123 | db_must_ok db (fun () -> exec db.db "END TRANSACTION"); 124 | db.in_transaction <- db.in_transaction - 1 125 | ) 126 | 127 | (* iterate over a result set *) 128 | let step_map db stmt iterfn = 129 | let stepfn () = Sqlite3.step stmt in 130 | let rec fn a = match db_busy_retry db stepfn with 131 | | Sqlite3.Rc.ROW -> fn (iterfn stmt :: a) 132 | | Sqlite3.Rc.DONE -> a 133 | | x -> raise_sql_error x in 134 | fn [] 135 | 136 | let lazy_map db stmt (iterfn : Sqlite3.stmt -> 'a) : unit -> 'a option = 137 | let stepfn () = Sqlite3.step stmt in 138 | let empty = ref false in 139 | let fn () = 140 | if !empty then 141 | None 142 | else 143 | match db_busy_retry db stepfn with 144 | | Sqlite3.Rc.ROW -> Some (iterfn stmt) 145 | | Sqlite3.Rc.DONE -> empty := true; None 146 | | x -> raise_sql_error x in 147 | fn 148 | 149 | 150 | let list_foldi fn accu l = 151 | let accu, _ = List.fold_left (fun (accu, i) x -> fn accu i x, i + 1) (accu, 0) l in accu 152 | 153 | let list_mapi fn l = list_foldi (fun accu i x -> fn i x :: accu) [] l 154 | 155 | let map_strings sep fn sl = String.concat sep (List.map fn sl) 156 | 157 | let map_stringsi sep fn sl = String.concat sep (list_mapi fn sl) 158 | 159 | (* List version of Array.iteri *) 160 | let list_iteri fn = 161 | let p = ref 0 in 162 | List.iter (fun x -> fn !p x; incr p) 163 | 164 | let string_of_data = function 165 | | Data.NULL -> "NULL" 166 | | Data.NONE -> "NONE" 167 | | Data.INT i -> Int64.to_string i 168 | | Data.TEXT t -> t 169 | | Data.FLOAT f -> string_of_float f 170 | | Data.BLOB _ -> "" 171 | 172 | module Name = struct 173 | let default = "val" 174 | let tuple n i = sprintf "%s__%i" n (i+1) 175 | let sum n r i = if n = "" then sprintf "%s__%i" r (i+1) else sprintf "%s__%s__%i" n r (i+1) 176 | let dict n f = if n = "" then f else sprintf "%s__%s" n f 177 | let option n = sprintf "%s__0" n 178 | let option_is_set n = sprintf "%s__0__isset" n 179 | let enum n = sprintf "%s__0" n 180 | end 181 | 182 | exception Process_error of Type.t * string 183 | let process_error t s = 184 | Printf.printf "ERROR(%s): %s\n%!" (Type.to_string t) s; 185 | raise (Process_error (t, s)) 186 | 187 | let with_valid_type fn t = 188 | let module T = Type in 189 | match t with 190 | | T.Ext (v, t) | T.Rec (v, t) -> fn v t 191 | | _ -> process_error t "This is not a well-formed type" 192 | 193 | let is_enum = function 194 | | Type.List _ | Type.Array _ -> true 195 | | _ -> false 196 | 197 | let get_enum_type = function 198 | | Type.List t | Type.Array t -> t 199 | | t -> process_error t "This is not a enum type" 200 | 201 | let get_internal_type = with_valid_type (fun name t -> t) 202 | 203 | let nb_of_qmarks str = 204 | let q = ref 0 in 205 | for i = 0 to String.length str - 1 do 206 | if str.[i] = '?' then incr q 207 | done; 208 | !q 209 | 210 | let exec_sql ~tag ~env ~db sql binds fn = 211 | let name = Printf.sprintf "%s:%d" db.name db.uuid in 212 | debug name env `Sql tag sql; 213 | if (nb_of_qmarks sql <> List.length binds) then 214 | failwith (Printf.sprintf "Wrong number of ? in '%s'" sql); 215 | let stmt = prepare db.db sql in 216 | list_iteri (fun i v -> 217 | debug name env `Bind tag (string_of_data v); 218 | db_must_bind db stmt (i+1) v 219 | ) binds; 220 | fn stmt 221 | 222 | (* Build up the list of fields from a Type.t *) 223 | let field_names_of_type ~id t = 224 | let module T = Type in 225 | let rec aux name = function 226 | | T.Unit | T.Int _ | T.Char | T.Bool | T.String | T.Float | T.Var _ | T.Rec _ | T.Ext _ | T.List _ | T.Array _ | T.Arrow _ -> 227 | [ if name = "" then Name.default else name ] 228 | | T.Option t -> Name.option_is_set name :: aux (Name.option name) t 229 | | T.Tuple tl -> list_foldi (fun accu i t -> accu @ aux (Name.tuple name i) t) [] tl 230 | | T.Dict (_,tl) -> List.fold_left (fun accu (n,_,t) -> accu @ aux (Name.dict name n) t) [] tl 231 | | T.Sum (_,tl) -> 232 | "__row__" :: List.fold_left 233 | (fun accu (r,tl) -> list_foldi (fun accu i t -> accu @ aux (Name.sum name r i) t) accu tl) 234 | [] tl in 235 | if id then "__id__" :: aux "" t else aux "" t 236 | 237 | (* Build up the list of field types from a Type.t *) 238 | let field_types_of_type ~id t = 239 | let module T = Type in 240 | let rec aux = function 241 | | T.Unit | T.Int _ | T.Char | T.Bool 242 | | T.Var _ | T.Rec _ | T.Ext _ | T.List _ | T.Array _ -> [ "INTEGER" ] 243 | | T.Float -> [ "FLOAT" ] 244 | | T.String -> [ "STRING" ] 245 | | T.Arrow _ -> [ "BLOB" ] 246 | | T.Tuple tl -> List.fold_left (fun accu t -> accu @ aux t) [] tl 247 | | T.Dict (_,tl) -> List.fold_left (fun accu (_,_,t) -> accu @ aux t) [] tl 248 | | T.Sum (_,tl) -> "TEXT" :: List.fold_left (fun accu (_,tl) -> accu @ List.fold_left (fun accu t -> accu @ aux t) [] tl) [] tl 249 | | T.Option t -> "INTEGER" :: aux t in 250 | if id then "INTEGER" :: aux t else aux t 251 | 252 | type table = [ `Enum | `Foreign ] 253 | 254 | (* Return the sub-tables for a Type.t and the links between them *) 255 | let subtables_of_type t = 256 | let module T = Type in 257 | let default f = if f = "" then Name.default else f in 258 | let (>>) (l1, l2) (l3, l4) = ( l1 @ l3, l2 @ l4 ) in 259 | let rec aux ?parent ~field name ((tables,_) as accu) = function 260 | | T.Unit | T.Int _ | T.Char | T.Bool 261 | | T.Float | T.String | T.Arrow _ -> accu 262 | | T.Option t -> aux ?parent ~field:(Name.option field) (Name.option name) accu t 263 | | T.Tuple tl -> list_foldi (fun accu i t -> aux ?parent ?field:(Name.tuple field i) (Name.tuple name i) accu t) accu tl 264 | | T.Dict (_,tl) -> List.fold_left (fun accu (n,_,t) -> aux ?parent ?field:(Name.dict field n) (Name.dict name n) accu t) accu tl 265 | | T.Sum (_,tl) -> 266 | List.fold_left 267 | (fun accu (r,tl) -> list_foldi (fun accu i t -> aux ?parent ?field:(Name.sum field r i) (Name.sum name r i) accu t) accu tl) 268 | accu tl 269 | | T.Var v -> ( [], match parent with Some p -> [p, default field, `Foreign, v] | _ -> [] ) >> accu 270 | | T.Rec (v,s) 271 | | T.Ext (v,s) as t -> 272 | let res = ( [v, Type.unroll tables t], match parent with Some p -> [p, default field, `Foreign, v] | _ -> [] ) in 273 | if List.mem_assoc v tables then accu else aux ~parent:v ~field:"" v (res >> accu) s 274 | | T.List s | T.Array s as t -> 275 | let name = Name.enum name in 276 | let res = ( [name, Type.unroll tables t], match parent with Some p -> [p, default field, `Enum, name] | _ -> [] ) in 277 | res >> (aux ~parent:name ~field:"" name accu s) in 278 | aux ~field:"" "" ([], []) t 279 | 280 | let enum_subtables_of_type t = 281 | let _, links = subtables_of_type t in 282 | List.filter (function (_, _, `Enum, _) -> true | _ -> false) links 283 | 284 | (* Build up the list of fields from a Value.t *) 285 | let field_names_of_value ~id v = 286 | let module V = Value in 287 | let rec aux name = function 288 | | V.Unit | V.Int _ | V.String _ | V.Bool _ | V.Float _ | V.Var _ | V.Rec _ | V.Ext _ | V.Enum _ | V.Arrow _ -> 289 | [ if name = "" then Name.default else name ] 290 | | V.Null -> [ Name.option_is_set name ] 291 | | V.Value v -> Name.option_is_set name :: aux (Name.option name) v 292 | | V.Tuple vs -> list_foldi (fun accu i v -> accu @ aux (Name.tuple name i) v) [] vs 293 | | V.Dict vs -> List.fold_left (fun accu (n,v) -> accu @ aux (Name.dict name n) v) [] vs 294 | | V.Sum (r,vs) -> "__row__" :: list_foldi (fun accu i v -> accu @ aux (Name.sum name r i) v) [] vs in 295 | if id then "__id__" :: aux "" v else aux "" v 296 | 297 | let subtables_of_value v = 298 | let module V = Value in 299 | let rec aux name accu = function 300 | | V.Unit | V.Int _ | V.String _ | V.Bool _ | V.Float _ | V.Arrow _ | V.Null | V.Var _ -> accu 301 | | V.Value v -> aux (Name.option name) accu v 302 | | V.Tuple vs -> list_foldi (fun accu i v -> aux (Name.tuple name i) accu v) accu vs 303 | | V.Dict vs -> List.fold_left (fun accu (n,v) -> aux (Name.dict name n) accu v) accu vs 304 | | V.Sum (r,vs) -> list_foldi (fun accu i v -> aux (Name.sum name r i) accu v) accu vs 305 | | V.Ext((n,i),v) 306 | | V.Rec((n,i),v) -> aux n ((n,[v]) :: accu) v 307 | | V.Enum vs -> let name = Name.enum name in List.fold_left (aux name) ((name,vs) :: accu) vs in 308 | aux "" [] v 309 | -------------------------------------------------------------------------------- /lib/sql_cache.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2009-2010 3 | * Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | open Sqlite3 19 | open Sql_backend 20 | 21 | let global_count = ref 0 22 | 23 | let clean_list : (unit -> unit) list ref = ref [] 24 | let flush_list : (string -> unit) list ref = ref [] 25 | let sync_list : (string -> string -> int64 -> unit) list ref = ref [] 26 | 27 | let clean_all env name = 28 | debug (name ^ ":*") env `Cache "cache" (Printf.sprintf "clean_all(%i)" (List.length !clean_list)); 29 | List.iter (fun f -> f ()) !clean_list 30 | 31 | let flush_all env name = 32 | debug (name ^ ":*") env `Cache "cache" (Printf.sprintf "flush_all(%s,%i)" name (List.length !flush_list)); 33 | List.iter (fun f -> f name) !flush_list 34 | 35 | let sync_all env name table id = 36 | debug (name ^ ":*") env `Cache "cache" (Printf.sprintf "sync_all(%s,%s,%Ld,%i)" name table id (List.length !sync_list)); 37 | List.iter (fun f -> f name table id) !sync_list 38 | 39 | 40 | module Trigger = struct 41 | 42 | let name table = 43 | Printf.sprintf "SYNC_CACHE_%s" table 44 | 45 | (* custom function needs to be registred for each connection *) 46 | let create_function ~env ~db table = 47 | let trigger_fn = function 48 | | Data.INT id -> sync_all env db.name table id; Data.NULL 49 | | _ -> failwith (name table) in 50 | create_fun1 db.db (name table) trigger_fn 51 | 52 | (* trigger needs to be registred once per pair (database * type) *) 53 | let install ~env ~db table = 54 | let sync_trigger = Printf.sprintf 55 | "CREATE TRIGGER IF NOT EXISTS %s_update_cache AFTER DELETE ON %s FOR EACH ROW BEGIN SELECT %s(OLD.__id__); END;" 56 | table table (name table) in 57 | exec_sql ~tag:"cache" ~env ~db sync_trigger [] (db_must_step db) 58 | 59 | end 60 | 61 | (* 'a = 'b Weaktbl.t *) 62 | type ('a, 'b) t = { 63 | type_name : string; 64 | tbl : (string, 'a) Hashtbl.t; 65 | create : int -> 'a; 66 | to_weakid : 'a -> 'b -> int64; 67 | of_weakid : 'a -> int64 -> 'b list; 68 | mem : 'a -> 'b -> bool; 69 | mem_weakid : 'a -> int64 -> bool; 70 | add : 'a -> 'b -> int64 -> unit; 71 | remove : 'a -> 'b -> unit; 72 | replace : 'a -> 'b -> int64 -> unit; 73 | dump : 'a -> string; 74 | } 75 | 76 | let string_of_t string_of_a t = 77 | let tbls = Hashtbl.fold (fun db a acc -> (db, a) :: acc) t.tbl [] in 78 | let tbls = List.map (fun (db, a) -> Printf.sprintf "(%s, %s)" db (string_of_a a)) tbls in 79 | let tbl = String.concat "," tbls in 80 | Printf.sprintf "%s_cache={%s}" t.type_name tbl 81 | 82 | module type Sig = sig 83 | type tbl 84 | type elt 85 | val create : string -> (tbl, elt) t 86 | end 87 | 88 | module Make (H : Hashtbl.HashedType) : Sig with type tbl = Weakid.Make(H).t and type elt = Weakid.Make(H).elt = struct 89 | 90 | module W = Weakid.Make(H) 91 | 92 | type tbl = W.t 93 | type elt = W.elt 94 | 95 | let clean t = 96 | let to_remove = ref [] in 97 | Hashtbl.iter (fun k v -> if W.length v = 0 then to_remove := k :: !to_remove) t.tbl; 98 | List.iter (fun k -> Hashtbl.remove t.tbl k) !to_remove 99 | 100 | let flush t name = 101 | let to_remove = ref [] in 102 | Hashtbl.iter (fun k v -> if k = name then (to_remove := k :: !to_remove; W.clear v)) t.tbl; 103 | List.iter (fun k -> Hashtbl.remove t.tbl k) !to_remove 104 | 105 | let sync t name table id = 106 | let aux w = 107 | let vs = t.of_weakid w id in 108 | List.iter (t.remove w) vs in 109 | if t.type_name = table then 110 | Hashtbl.iter (fun k v -> if k = name then aux v) t.tbl 111 | 112 | let create name = 113 | let tbl = Hashtbl.create 32 in 114 | let t = { 115 | type_name = name; 116 | tbl = tbl; 117 | create = W.create; 118 | to_weakid = W.to_weakid; 119 | of_weakid = W.of_weakid; 120 | mem = W.mem; 121 | mem_weakid = W.mem_weakid; 122 | add = W.add; 123 | remove = W.remove; 124 | replace = W.replace; 125 | dump = W.dump; 126 | } in 127 | clean_list := (fun () -> clean t) :: !clean_list; 128 | flush_list := (flush t) :: !flush_list; 129 | sync_list := (sync t) :: !sync_list; 130 | t 131 | end 132 | 133 | let with_table env t db fn = 134 | incr global_count; 135 | if !global_count mod 10000 = 0 then clean_all env db; 136 | let tbl = 137 | if Hashtbl.mem t.tbl db then 138 | Hashtbl.find t.tbl db 139 | else begin 140 | let w = t.create 128 in 141 | Hashtbl.replace t.tbl db w; 142 | let s = new_state db in 143 | Trigger.install ~env ~db:s t.type_name; 144 | w 145 | end in 146 | fn tbl 147 | 148 | let debug env t db s = 149 | debug (db ^ ":*") env `Cache "cache" (Printf.sprintf "calling %s(%s)" s db) 150 | 151 | let to_weakid env t db elt = 152 | debug env t db "to_weakid"; 153 | with_table env t db (fun tbl -> t.to_weakid tbl elt) 154 | 155 | let of_weakid env t db id = 156 | debug env t db "of_weakid"; 157 | with_table env t db (fun tbl -> t.of_weakid tbl id) 158 | 159 | let mem env t db elt = 160 | debug env t db "mem"; 161 | with_table env t db (fun tbl -> t.mem tbl elt) 162 | 163 | let mem_weakid env t db id = 164 | debug env t db "mem_weakid"; 165 | with_table env t db (fun tbl -> t.mem_weakid tbl id) 166 | 167 | let add env t db elt = 168 | debug env t db "add"; 169 | with_table env t db (fun tbl -> t.add tbl elt) 170 | 171 | let remove env t db elt = 172 | debug env t db "remove"; 173 | with_table env t db (fun tbl -> t.remove tbl elt) 174 | 175 | let replace env t db elt id = 176 | debug env t db "replace"; 177 | with_table env t db (fun tbl -> t.replace tbl elt id) 178 | -------------------------------------------------------------------------------- /lib/sql_delete.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2009 Anil Madhavapeddy 3 | * Copyright (c) 2009 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | open Printf 19 | open Sqlite3 20 | open Sql_backend 21 | open Dyntype 22 | open Value 23 | 24 | let exec_sql ~env ~db = exec_sql ~tag:"delete" ~db ~env 25 | 26 | let foreign_ids ~env ~db (table, id) = 27 | 28 | let aux accu (parent, field) = 29 | let sql = sprintf "SELECT * FROM %s WHERE %s=?;" parent field in 30 | let ids = exec_sql ~env ~db sql [ Data.INT id ] (fun stmt -> step_map db stmt (fun stmt -> column stmt 0)) in 31 | List.fold_left (fun accu -> function Data.INT id -> (parent, id) :: accu | _ -> accu) accu ids in 32 | 33 | let all_parents = 34 | let sql = "SELECT parent, field FROM __links__ WHERE child=?;" in 35 | let fn stmt = let r = row_data stmt in match r.(0), r.(1) with 36 | | Data.TEXT p, Data.TEXT f -> (p, f) 37 | | _ -> failwith "is_referenced" in 38 | exec_sql ~env ~db sql [Data.TEXT table] (fun stmt -> step_map db stmt fn) in 39 | 40 | List.fold_left aux [] all_parents 41 | 42 | let list_union l1 l2 = 43 | List.fold_left (fun accu elt -> if List.mem elt l1 then accu else elt :: accu) l1 l2 44 | 45 | let get_ids ~env ~db var v = 46 | let rec mem = function 47 | | Unit | Int _ | String _ | Bool _ | Float _ | Arrow _ | Null -> false 48 | | Var m -> m=var 49 | | Value w -> mem w 50 | | Tuple vs 51 | | Enum vs 52 | | Sum (_,vs) -> List.exists mem vs 53 | | Dict vs -> List.exists (fun (_,w) -> mem w) vs 54 | | Ext (_,w) 55 | | Rec (_,w) -> mem w in 56 | let rec aux name ((foreigns, internals) as accu) v = 57 | if not (mem v) then 58 | accu 59 | else match v with 60 | | Unit | Int _ | String _ | Bool _ | Float _ | Arrow _ | Null | Var _ -> accu 61 | | Value v -> aux (Name.option name) accu v 62 | | Tuple vs -> list_foldi (fun accu i v -> aux (Name.tuple name i) accu v) accu vs 63 | | Dict vs -> List.fold_left (fun accu (n,v) -> aux (Name.dict name n) accu v) accu vs 64 | | Sum (r,vs) -> list_foldi (fun accu i v -> aux (Name.sum name r i) accu v) accu vs 65 | | Enum vs -> List.fold_left (aux name) accu vs 66 | | Ext ((n,i), w) 67 | | Rec ((n,i), w) -> 68 | let new_foreigns = list_union (foreign_ids ~env ~db (n,i)) foreigns in 69 | let new_internals = list_union [ n,i ] internals in 70 | aux n (new_foreigns, new_internals) w in 71 | aux "" ([], []) (Rec (var, v)) 72 | 73 | let string_of_ids ids = 74 | let aux (p,i) = sprintf "(%s:%Ld)" p i in 75 | String.concat "; " (List.map aux ids) 76 | 77 | let delete_value ~env ~db ~recursive v = 78 | 79 | let process (table, id) = 80 | let sql = sprintf "DELETE FROM %s WHERE __id__=?" table in 81 | exec_sql ~env ~db sql [ Data.INT id ] (db_must_step db) in 82 | 83 | let rec aux ~recurse ~deleted = function 84 | | Null | Unit | Int _ | Bool _ | Float _ | String _ | Arrow _ | Var _ -> () 85 | | Value t -> aux ~recurse ~deleted t 86 | | Ext (var, w) when recurse -> 87 | if not (List.mem var deleted) then begin 88 | let delete = List.length (foreign_ids ~env ~db var) = 0 in 89 | if delete then begin 90 | process var; 91 | aux ~recurse:recursive ~deleted:(var::deleted) w; 92 | end 93 | end else 94 | aux ~recurse:recursive ~deleted w 95 | | Rec (var, w) when recurse -> 96 | if not (List.mem var deleted) then begin 97 | let externals, internals = get_ids ~env ~db var w in 98 | let foreign_ids = List.filter (fun x -> not (List.mem x internals)) externals in 99 | let delete = List.length foreign_ids = 0 in 100 | (* Printf.printf "externals: %s\ninternals: %s\nforeigns: %s\n%!" (string_of_ids externals) (string_of_ids internals) (string_of_ids foreign_ids); *) 101 | if delete then begin 102 | List.iter process internals; 103 | aux ~recurse:recursive ~deleted:(internals @ deleted) w 104 | end 105 | end else 106 | aux ~recurse:recursive ~deleted w 107 | | Sum (_,tl) 108 | | Tuple tl 109 | | Enum tl -> List.iter (aux ~recurse ~deleted) tl 110 | | Dict tl -> List.iter (fun (_,t) -> aux ~recurse ~deleted t) tl 111 | | Ext _ | Rec _ -> () in 112 | 113 | aux ~recurse:true ~deleted:[] v 114 | -------------------------------------------------------------------------------- /lib/sql_get.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2009 Anil Madhavapeddy 3 | * Copyright (c) 2009 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | open Printf 19 | open Sqlite3 20 | open Sql_backend 21 | 22 | open Dyntype 23 | module T = Type 24 | module V = Value 25 | 26 | exception Sql_process_error of T.t * Data.t * string 27 | 28 | let process_error v d s = 29 | Printf.printf "ERROR(%s): %s - %s\n%!" s (T.to_string v) (string_of_data d); 30 | raise (Sql_process_error (v, d, s)) 31 | 32 | let exec_sql ~env ~db = exec_sql ~tag:"get" ~db ~env 33 | 34 | let process getter ~env ~db ~constraints ?order_by name field_names fn = 35 | let where_str = String.concat " AND " (List.map (function | (n,c,None) -> sprintf "%s %s" n c | (n,c,Some _) -> sprintf "%s %s ?" n c) constraints) in 36 | let where = if where_str = "" then "" else sprintf " WHERE %s" where_str in 37 | let order_by = match order_by with None -> "" | Some str -> sprintf " ORDER BY %s" str in 38 | let sql = sprintf "SELECT %s FROM %s%s%s;" (String.concat "," field_names) name where order_by in 39 | let binds = List.rev (List.fold_left (function accu -> function (_,_,None) -> accu | (_,_,Some c) -> c :: accu) [] constraints) in 40 | exec_sql ~env ~db sql binds (fun stmt -> getter db stmt fn) 41 | 42 | (* The eta-expansion is needed to make the program compile ... *) 43 | let strict_process ~env ~db ~constraints ?order_by name field_names fn = 44 | process step_map ~env ~db ~constraints ?order_by name field_names fn 45 | 46 | (* The eta-expansion is needed to make the program compile ... *) 47 | let lazy_process ~env ~db ~constraints ?order_by name field_names fn = 48 | process lazy_map ~env ~db ~constraints ?order_by name field_names fn 49 | 50 | let string_of_constraint (name, c) = 51 | let make name = String.concat "__" name in 52 | let bool name = function 53 | | `T -> make name, "=", Some (Data.INT 1L) 54 | | `F -> make name, "=", Some (Data.INT 0L) 55 | and int_like name conv = function 56 | | `Eq i -> make name, "=", Some (conv i) 57 | | `Neq i -> make name, "!=", Some (conv i) 58 | | `Le i -> make name, "<", Some (conv i) 59 | | `Ge i -> make name, ">", Some (conv i) 60 | | `Leq i -> make name, "<=", Some (conv i) 61 | | `Geq i -> make name, ">=", Some (conv i) 62 | and direct name conv = function 63 | | `Eq i -> make name, "=", Some (conv i) 64 | and string name = function 65 | | `Eq s -> make name, "IS", Some (Data.TEXT s) 66 | | `Contains s -> make name, "LIKE", Some (Data.TEXT (sprintf "%%%s%%" s)) in 67 | match c with 68 | | `Bool b -> bool name b 69 | | `String s -> string name s 70 | | `Float f -> int_like name (fun f -> Data.FLOAT f) f 71 | | `Char c -> int_like name (fun c -> Data.INT (Int64.of_int (Char.code c))) c 72 | | `Int i -> int_like name (fun i -> Data.INT (Int64.of_int i)) i 73 | | `Int32 i -> int_like name (fun i -> Data.INT (Int64.of_int32 i)) i 74 | | `Int64 i -> int_like name (fun i -> Data.INT i) i 75 | | `Opaque_id i -> direct name (fun i -> Data.INT i) i 76 | | `Big_int i -> int_like name (fun i -> Data.TEXT (Big_int.string_of_big_int i)) i 77 | 78 | (* force a lazy list into a normal list *) 79 | let force next = 80 | let accu = ref [] in 81 | let rec loop () = 82 | match next () with 83 | | None -> List.rev !accu 84 | | Some e -> accu := e :: !accu; loop () in 85 | loop () 86 | 87 | (* Build up the list of fields actually needed to save the row *) 88 | let rec parse_row ~env ~db ~skip ~name ~type_env ~vars t row n = 89 | match t, row.(n) with 90 | | T.Unit , Data.INT 0L -> V.Unit, n + 1 91 | | T.Int _ , Data.INT i 92 | | T.Char , Data.INT i -> V.Int i, n + 1 93 | | T.Bool , Data.INT 0L -> V.Bool false, n + 1 94 | | T.Bool , Data.INT 1L -> V.Bool true, n + 1 95 | | T.Float , Data.FLOAT f -> V.Float f, n + 1 96 | | T.String , Data.TEXT t -> V.String t, n + 1 97 | | T.String , Data.INT t -> V.String (Int64.to_string t), n + 1 98 | | T.String , Data.FLOAT f -> V.String (string_of_float f), n + 1 99 | | T.Array t , Data.NULL -> V.Enum [], n + 1 100 | | T.Array t , Data.INT id -> V.Enum (get_enum_values ~env ~db ~id ~type_env ~vars (Name.enum name) t), n + 1 101 | | T.List t , Data.NULL -> V.Enum [], n + 1 102 | | T.List t , Data.INT id -> V.Enum (get_enum_values ~env ~db ~id ~type_env ~vars (Name.enum name) t), n + 1 103 | | T.Arrow _ , Data.BLOB b -> V.Arrow b, n + 1 104 | | T.Option t, Data.INT r -> 105 | let res, j = parse_row ~env ~db ~skip:(r=0L) ~name:(Name.option name) ~type_env ~vars t row (n + 1) in 106 | (if r=0L then V.Null else V.Value res), j 107 | | T.Tuple tl, _ -> 108 | let tuple, n = list_foldi (fun (accu, n1) i t -> 109 | let res, n2 = parse_row ~env ~db ~skip ~name:(Name.tuple name i) ~type_env ~vars t row n1 in 110 | res :: accu, n2 111 | ) ([], n) tl in 112 | V.Tuple (List.rev tuple), n 113 | | T.Dict (_,tl), _ -> 114 | let dict, n = List.fold_left (fun (accu, n1) (f,_,t) -> 115 | let res, n2 = parse_row ~env ~db ~skip ~name:(Name.dict name f) ~type_env ~vars t row n1 in 116 | (f, res) :: accu, n2 117 | ) ([], n) tl in 118 | V.Dict (List.rev dict), n 119 | | T.Sum (_,tl), Data.TEXT r -> 120 | let row, n = List.fold_left (fun (accu, n1) (rn, tl) -> 121 | list_foldi (fun (accu, n2) i t -> 122 | let res, n3 = parse_row ~skip:(rn<>r) ~env ~db ~name:(Name.sum "" rn i) ~type_env ~vars t row n2 in 123 | (if rn<>r then accu else res :: accu), n3 124 | ) (accu, n1) tl) 125 | ([], n + 1) tl in 126 | V.Sum (r, List.rev row), n 127 | | T.Ext (v,_), Data.INT i 128 | | T.Rec (v,_), Data.INT i 129 | | T.Var v, Data.INT i -> 130 | if List.mem (v,i) vars then 131 | V.Var (v,i), n + 1 132 | else begin 133 | let vars = match t with T.Rec _ | T.Var _ -> (v,i) :: vars | _ -> vars in 134 | match force (lazy_get_values ~env ~db ~id:i ~type_env ~vars t) with 135 | | [_,v] -> v, n + 1 136 | | [] -> process_error t row.(n) "No value found" 137 | | _ -> process_error t row.(n) "Too many values found" 138 | end 139 | | _ when skip -> V.Null, n + 1 140 | | _ -> process_error t row.(n) (sprintf "%s: unknown" name) 141 | 142 | and lazy_get_values ~env ~db ?id ?(type_env=[]) ?(vars=[]) ?(constraints=[]) ?order_by ?custom_fn t = 143 | 144 | let name, s, type_env = 145 | match t with 146 | | T.Rec (n, s) 147 | | T.Ext (n, s) -> n, s, (n,s) :: type_env 148 | | T.Var n -> n, List.assoc n type_env, type_env 149 | | _ -> failwith "TODO" in 150 | 151 | let value_of_row row = 152 | let id = match row.(0) with Data.INT i -> i | _ -> failwith "TODO:4" in 153 | let r, _ = parse_row ~env ~db ~skip:false ~name ~type_env ~vars s row 1 in 154 | if List.mem (name, id) (V.free_vars r) then 155 | id, V.Rec ((name,id), r) 156 | else 157 | id, V.Ext ((name,id), r) in 158 | 159 | let value_of_stmt stmt = 160 | value_of_row (row_data stmt) in 161 | 162 | let _custom = ref None in 163 | let custom fn = 164 | let custom_name = sprintf "%s_custom" name in 165 | let custom_str = sprintf "%s(%s)" custom_name (String.concat "," (field_names_of_type ~id:true s)) in 166 | create_funN db.db custom_name (fun row -> let _,v = value_of_row row in if fn v then Data.INT 1L else Data.INT 0L); 167 | _custom := Some custom_name; 168 | [ custom_str, "", None ] in 169 | 170 | let constraints = 171 | (match id with None -> [] | Some id -> [ "__id__", "=", Some (Data.INT id) ]) @ 172 | (match custom_fn with None -> [] | Some fn -> custom fn) @ 173 | List.map string_of_constraint constraints in 174 | 175 | let res = lazy_process ~env ~db ~constraints ?order_by name (field_names_of_type ~id:true s) value_of_stmt in 176 | let res () = 177 | match res () with 178 | | Some x -> Some x 179 | | None -> 180 | (* deregister the function when all the rows have been loaded *) 181 | (match !_custom with None -> () | Some name -> delete_function db.db name); 182 | None in 183 | res 184 | 185 | and get_enum_values ~env ~db ~id ~type_env ~vars name t = 186 | let aux stmt = 187 | let row = row_data stmt in 188 | let id = match row.(0) with Data.INT i -> i | s -> process_error t s "__id__" in 189 | let next = match row.(1) with Data.INT i -> Some i | Data.NULL -> None | s -> process_error t s "__next__" in 190 | let next_chunk = match row.(2) with Data.INT i -> Some i | Data.NULL -> None | s -> process_error t s "__next_chunk__" in 191 | let size = match row.(3) with Data.INT i -> Int64.to_int i | s -> process_error t s "__size__" in 192 | let v, _ = parse_row ~env ~db ~skip:false ~name ~type_env ~vars t row 4 in 193 | id, next, next_chunk, size, v in 194 | 195 | let get_chunk first_id = 196 | let constraints = [ "__id__", "=", Some (Data.INT first_id) ] in 197 | let field_names = "__id__" :: "__next__" :: "__next_chunk__" :: "__size__" :: field_names_of_type ~id:false t in 198 | match strict_process ~env ~db ~constraints name field_names aux with 199 | | [ _ , None , None , _ , v ] -> None, [ v ] 200 | | [ id, Some next, next_chunk, size, _ ] -> 201 | let size = min size max_join in 202 | let rec joints i = 203 | if i = 0 204 | then sprintf "%s AS __t0__" name :: joints (i+1) 205 | else if i = size 206 | then [] 207 | else sprintf "%s AS __t%i__ ON __t%i__.__next__=__t%i__.__id__" name i (i-1) i :: joints (i+1) in 208 | let names = field_names_of_type ~id:false t in 209 | let rec field_names i = 210 | if i = size 211 | then [] 212 | else List.map (fun f -> sprintf "__t%i__.%s" i f) names @ field_names (i+1) in 213 | let table_name = String.concat " JOIN " (joints 0) in 214 | let constraints = [ 215 | (match next_chunk with 216 | | None -> sprintf "__t%i__.__next__" (size-1), "ISNULL", None; 217 | | Some next_id -> sprintf "__t%i__.__next__" (size-1), "=" , Some (Data.INT next_id)); 218 | "__t0__.__id__","=", Some (Data.INT first_id); 219 | ] in 220 | let fn (stmt : Sqlite3.stmt) : V.t list = 221 | let row = row_data stmt in 222 | let rec aux n = 223 | if n >= Array.length row 224 | then [] 225 | else 226 | let v, m = parse_row ~env ~db ~skip:false ~name ~type_env ~vars t row n in 227 | v :: aux m in 228 | aux 0 in 229 | begin match strict_process ~env ~db ~constraints table_name (field_names 0) fn with 230 | | [r] -> next_chunk, r 231 | | [] -> process_error t Data.NULL "No result found" 232 | | rs -> process_error t Data.NULL "Too many results found" 233 | end 234 | | l -> 235 | let aux (id, next, next_chunk, size, v) = 236 | Printf.sprintf "(%Ld,%s,%s,%i,%s)" 237 | id 238 | (match next with None -> "NULL" | Some n -> Int64.to_string n) 239 | (match next_chunk with None -> "NULL" | Some n -> Int64.to_string n) 240 | size 241 | (Value.to_string v) in 242 | process_error t Data.NULL (Printf.sprintf "get_enum_values{%s}" (String.concat ";" (List.map aux l))) in 243 | 244 | let result = ref [[]] in 245 | let stop = ref false in 246 | let first_id = ref id in 247 | while not !stop do 248 | let n, r = get_chunk !first_id in 249 | (match n with 250 | | None -> stop := true; 251 | | Some k -> first_id := k); 252 | result := r :: !result; 253 | done; 254 | List.concat (List.rev !result) 255 | 256 | let get_values ~env ~db ?id ?(type_env=[]) ?(vars=[]) ?(constraints=[]) ?order_by ?custom_fn t = 257 | force (lazy_get_values ~env ~db ?id ~type_env ~vars ~constraints ?order_by ?custom_fn t) 258 | -------------------------------------------------------------------------------- /lib/sql_init.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2009 Anil Madhavapeddy 3 | * Copyright (c) 2009 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | open Printf 19 | open Dyntype 20 | open Type 21 | open Sql_backend 22 | open Sqlite3 23 | 24 | exception Sql_process_error of Type.t * string 25 | exception Subtype_error of string * string 26 | 27 | let process_error t s = 28 | Printf.printf "ERROR(%s): %s\n%!" s (to_string t); 29 | raise (Sql_process_error (t,s)) 30 | 31 | let exec_sql ~env ~db = exec_sql ~tag:"init" ~env ~db 32 | 33 | let init_and_check_types_table ~mode ~env ~db tables = 34 | let create = "CREATE TABLE IF NOT EXISTS __types__ (n TEXT, t TEXT)" in 35 | let select = "SELECT t FROM __types__ WHERE n=?" in 36 | let insert = "INSERT INTO __types__ (n,t) VALUES (?,?)" in 37 | 38 | (* Create the __types__ table *) 39 | if mode = `RW then 40 | exec_sql ~env ~db create [] (db_must_step db); 41 | 42 | (* Insert the type t of table n into __types__ *) 43 | let process (n, t) = 44 | let aux = function 45 | | [] when mode = `RW -> 46 | exec_sql ~env ~db insert [Data.TEXT n; Data.TEXT (Type.to_string t)] (db_must_step db) 47 | | [] -> () 48 | | [Data.TEXT x] -> 49 | if not (t <: (Type.of_string x)) then begin 50 | Printf.printf "%s\n%!" (string_of_last_type_error ()); 51 | raise (Subtype_error (Type.to_string t, x)); 52 | end else if mode = `RW && not (Type.of_string x <: t) then begin 53 | Printf.printf "%s\n%!" (string_of_last_type_error ()); 54 | raise (Subtype_error (x, Type.to_string t)); 55 | end 56 | | _ -> process_error t "create_types_table:1" in 57 | exec_sql ~env ~db select [Data.TEXT n] (fun stmt -> aux (step_map db stmt (fun stmt -> column stmt 0))) in 58 | 59 | List.iter process tables 60 | 61 | let init_links_table ~mode ~env ~db t table_links = 62 | let create = "CREATE TABLE IF NOT EXISTS __links__ (parent TEXT, field TEXT, child TEXT)" in 63 | let select = "SELECT child FROM __links__ WHERE parent=? AND field=? AND child=?" in 64 | let insert = "INSERT INTO __links__ (parent, field, child) VALUES (?,?,?)" in 65 | 66 | (* Create the __links__ table *) 67 | if mode = `RW then begin 68 | exec_sql ~env ~db create [] (db_must_step db) 69 | end; 70 | 71 | (* Insert the link 'p is a parent of n' into __links__ *) 72 | let process (p, f, _, n) = 73 | let aux = function 74 | | [] when mode = `RW -> 75 | exec_sql ~env ~db insert [Data.TEXT p; Data.TEXT f; Data.TEXT n] (db_must_step db) 76 | | [] -> () 77 | | [Data.TEXT x] -> () 78 | | _ -> process_error t "create_links_table:1" in 79 | exec_sql ~env ~db select [Data.TEXT p; Data.TEXT f; Data.TEXT n] (fun stmt -> aux (step_map db stmt (fun stmt -> column stmt 0))) in 80 | 81 | List.iter process table_links 82 | 83 | let create_tables ~mode ~env ~db tables = 84 | 85 | let process (name, t) = 86 | let t_internal = if is_enum t then get_enum_type t else get_internal_type t in 87 | let field_names = field_names_of_type ~id:false t_internal in 88 | let field_types = field_types_of_type ~id:false t_internal in 89 | let fields = List.map2 (sprintf "%s %s") field_names field_types in 90 | let extra = if is_enum t then "__next__ INTEGER,__next_chunk__ INTEGER,__size__ INTEGER," else "" in 91 | let sql = 92 | sprintf "CREATE TABLE IF NOT EXISTS %s (__id__ INTEGER PRIMARY KEY AUTOINCREMENT, %s%s);" name extra (String.concat "," fields) in 93 | exec_sql ~env ~db sql [] (db_must_step db); 94 | 95 | if is_enum t then begin 96 | let sql = sprintf "CREATE UNIQUE INDEX IF NOT EXISTS idx_%s_enum ON %s (__id__,__next__);" name name in 97 | exec_sql ~env ~db sql [] (db_must_step db) 98 | end in 99 | 100 | if mode = `RW then 101 | List.iter process tables 102 | 103 | let init_custom_indexes ~mode ~env ~db tables = 104 | let process kind (t, fs) = 105 | if List.mem_assoc t tables then begin 106 | let sql = match kind with 107 | | `U -> sprintf "CREATE UNIQUE INDEX IF NOT EXISTS idx_%s_%s ON %s (%s);" t (String.concat "_" fs) t (String.concat "," fs) 108 | | `I -> sprintf "CREATE INDEX IF NOT EXISTS idx_%s_%s ON %s (%s);" t (String.concat "_" fs) t (String.concat "," fs) in 109 | exec_sql ~env ~db sql [] (db_must_step db) 110 | end in 111 | 112 | (* Process indices *) 113 | if mode = `RW then begin 114 | List.iter (function 115 | | `Unique l -> List.iter (process `U) l 116 | | `Index l -> List.iter (process `I) l 117 | | _ -> () 118 | ) env; 119 | end 120 | 121 | let init_triggers ~mode ~env ~db ~table_links ~tables = 122 | 123 | (* Trigger to clean-up automatically the enum tables *) 124 | let gc (table, field, kind, enum) = 125 | assert (kind = `Enum); 126 | let trigger_name = Printf.sprintf "CLEAN_UP_%s" enum in 127 | let trigger_fn oldv newv = 128 | if oldv <> newv then begin 129 | (* very-small-step GC *) 130 | let gc_select = 131 | match newv with 132 | | Data.NULL -> 133 | Printf.sprintf 134 | "SELECT __id__ FROM %s as __e0__ WHERE (SELECT __id__ FROM %s as __e1__ WHERE __e1__.__next__=__e0__.__id__) IS NULL AND (SELECT __id__ FROM %s WHERE %s=__e0__.__id__) IS NULL;" 135 | enum enum table field 136 | | _ -> 137 | Printf.sprintf 138 | "SELECT __id__ FROM %s as __e0__ WHERE __e0__.__id__ != %s AND (SELECT __id__ FROM %s as __e1__ WHERE __e1__.__next__=__e0__.__id__) IS NULL AND (SELECT __id__ FROM %s WHERE %s=__e0__.__id__) IS NULL;" 139 | enum (Data.to_string newv) enum table field in 140 | let gc_delete = function 141 | | Data.INT id -> 142 | let delete = Printf.sprintf "DELETE FROM %s WHERE __id__=%Ld" enum id in 143 | exec_sql ~env ~db delete [] (db_must_step db); 144 | | _ -> failwith "gc" in 145 | let ids = exec_sql ~env ~db gc_select [] (fun stmt -> step_map db stmt (fun stmt -> column stmt 0)) in 146 | List.iter gc_delete ids; 147 | end; 148 | Data.NULL in 149 | let gc_trigger = Printf.sprintf 150 | "CREATE TRIGGER IF NOT EXISTS %s_%s_cleanup AFTER UPDATE OF %s ON %s FOR EACH ROW BEGIN SELECT %s(OLD.%s,NEW.%s); END;" 151 | table field field table trigger_name field field in 152 | create_fun2 db.db trigger_name trigger_fn; 153 | exec_sql ~env ~db gc_trigger [] (db_must_step db) in 154 | 155 | if mode = `RW then begin 156 | List.iter gc (List.filter (fun (_,_,k,_) -> k=`Enum) table_links) 157 | end 158 | 159 | let init_tables ~mode ~env ~db t = 160 | let tables, table_links = subtables_of_type t in 161 | init_and_check_types_table ~mode ~env ~db tables; 162 | init_links_table ~mode ~env ~db t table_links; 163 | create_tables ~mode ~env ~db tables; 164 | init_custom_indexes ~mode ~env ~db tables; 165 | init_triggers ~mode ~env ~db ~table_links ~tables 166 | 167 | 168 | (* wrapper for realpath(2) *) 169 | external unix_realpath : string -> string = "orm_unix_realpath" 170 | let canonical_name file = 171 | try 172 | unix_realpath file 173 | with _ -> ( 174 | Filename.concat (unix_realpath (Filename.dirname file)) (Filename.basename file) 175 | ) 176 | 177 | let database_exists ~env ~db = 178 | let sql = "SELECT * FROM sqlite_master WHERE name = '__types__' AND type = 'table'" in 179 | exec_sql ~env ~db sql [] (fun stmt -> List.length (step_map db stmt (fun stmt -> column stmt 0)) = 1) 180 | -------------------------------------------------------------------------------- /lib/sql_save.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2009-2010 3 | * Anil Madhavapeddy 4 | * Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open Printf 20 | open Sqlite3 21 | open Sql_backend 22 | open Dyntype 23 | open Value 24 | 25 | exception Sql_process_error of Value.t * string 26 | 27 | let process_error t s = 28 | Printf.printf "ERROR(%s): %s\n%!" s (to_string t); 29 | raise (Sql_process_error (t,s)) 30 | 31 | let exec_sql ~env ~db sql binds fn = 32 | exec_sql ~tag:"save" ~env ~db sql binds fn 33 | 34 | let assert_exists ~env ~db table_name id = 35 | let select = sprintf "SELECT * FROM %s WHERE __id__=?" table_name in 36 | exec_sql ~env ~db select [Data.INT id] 37 | (fun stmt -> 38 | if not (List.length (step_map db stmt (fun stmt -> column stmt 0)) = 1) then 39 | failwith (sprintf "%s:%Ld doesn't exist" table_name id) 40 | ) 41 | 42 | (* Return a fresh ID in the given table (and reserve it to update it later) *) 43 | let empty_row ~env ~db table_name : int64 = 44 | let insert = sprintf "INSERT INTO %s (__id__) VALUES (NULL);" table_name in 45 | exec_sql ~env ~db insert [] (db_must_step db); 46 | let id = last_insert_rowid db.db in 47 | debug (Printf.sprintf "%s:%d" db.name db.uuid) env `Sql "save" (Printf.sprintf "last_insert_rowid = %Ld" id); 48 | (* assert_exists ~env ~db table_name id; *) 49 | id 50 | 51 | 52 | (* Insert/update a specific row in a specific table *) 53 | let process_row ~env ~db table_name field_names field_values v = 54 | let qmarks = List.map (fun _ -> "?") field_names in 55 | let constraints = 56 | List.map2 (fun f v -> if v = Data.NULL then sprintf "%s ISNULL" f else sprintf "%s=?" f) field_names field_values in 57 | let insert = sprintf "INSERT INTO %s (%s) VALUES (%s);" table_name (String.concat "," field_names) (String.concat "," qmarks) in 58 | let select = sprintf "SELECT __id__ FROM %s WHERE %s;" table_name (String.concat " AND " constraints) in 59 | let fn stmt = step_map db stmt (fun stmt -> column stmt 0) in 60 | match exec_sql ~env ~db select (List.filter (fun v -> v <> Data.NULL) field_values) fn with 61 | | [Data.INT i ] -> i 62 | | [] -> exec_sql ~env ~db insert field_values (db_must_step db); last_insert_rowid db.db 63 | | ds -> process_error v (sprintf "Found {%s}" (String.concat "," (List.map string_of_data ds))) 64 | 65 | (* Cut a list into chunks of size [chunk_size] *) 66 | (* The result is in the reverse order *) 67 | let cut_into_chunks chunk_size l = 68 | let rec aux chunks n accu = function 69 | | [] -> (List.rev accu) :: chunks 70 | | h::t -> 71 | if n mod chunk_size = 0 then 72 | aux ((List.rev (h :: accu)) :: chunks) (n+1) [] t 73 | else 74 | aux chunks (n+1) (h :: accu) t in 75 | aux [] 1 [] l 76 | 77 | 78 | (* 79 | let _ = 80 | cut_into_chunks 3 [1;2;3;4;5;6;7;8] 81 | *) 82 | 83 | let combine chunks = 84 | let rec one list accu (a,b) = match list with 85 | | (c,d)::t when b=c -> one t ((a,d)::accu) (a,b) 86 | | _ :: t -> one t accu (a,b) 87 | | [] -> accu in 88 | let rec merge l1 l2 = 89 | List.fold_left (one l2) [] l1 in 90 | let rec aux = function 91 | | [] -> [] 92 | | [l] -> l 93 | | l1::l2::t -> aux ((merge l1 l2)::t) in 94 | aux chunks 95 | 96 | (* 97 | let _ = 98 | combine [ 99 | [ (1,2); (1,3) ]; 100 | [ (2,4); (3,5); (5,6); ]; 101 | [ (4,5); (5,6); (7,8); ]; 102 | ] 103 | *) 104 | 105 | (* Insert a collection of rows in a specific table *) 106 | let process_enum_rows ~env ~db table_name field_names field_values_enum v = 107 | 108 | let get_chunk chunk next_chunks = 109 | let join = 110 | sprintf "%s as __t0__" table_name :: 111 | list_mapi (fun i _ -> sprintf "%s AS __t%i__ ON __t%i__.__next__=__t%i__.__id__" table_name (i+1) i (i+1)) (List.tl chunk) in 112 | let constraints = 113 | List.flatten (list_mapi (fun i _ -> List.map (fun f -> sprintf "__t%i__.%s=?" i f) field_names) chunk) 114 | @ (match next_chunks with 115 | | [] -> [sprintf "__t%i__.__next__ ISNULL" (List.length chunk - 1)] 116 | | l -> [sprintf "(%s)" (String.concat " OR " (List.map (sprintf "__t%i__.__next__ = %Ld" (List.length chunk - 1)) l))]) in 117 | let binds = 118 | List.flatten chunk in 119 | let select = sprintf "SELECT __t0__.__id__ FROM %s WHERE %s;" 120 | (String.concat " JOIN " join) 121 | (String.concat " AND " constraints) in 122 | let fn stmt = step_map db stmt (fun stmt -> column stmt 0) in 123 | match exec_sql ~env ~db select binds fn with 124 | | [] -> raise Not_found 125 | | l -> List.map (function Data.INT i -> i | k -> process_error v "get_chunk") l in 126 | 127 | let get_by_chunks () = 128 | let next_chunks = ref [] in 129 | let chunks = Array.of_list (cut_into_chunks max_join field_values_enum) in 130 | try 131 | for i = 0 to Array.length chunks - 1 do 132 | next_chunks := get_chunk chunks.(i) !next_chunks; 133 | done; 134 | !next_chunks 135 | with _ -> [] in 136 | 137 | (* The array is in reverse order *) 138 | let ids = Array.create (List.length field_values_enum) (-1L) in 139 | let get_id n = 140 | if n < 0 then 141 | Data.NULL 142 | else 143 | Data.INT ids.(n) in 144 | let first () = 145 | match ids.(List.length field_values_enum - 1) with 146 | | -1L -> process_error v "Empy enum" 147 | | i -> i in 148 | 149 | match get_by_chunks () with 150 | | [i] -> i 151 | | [] -> 152 | let rec save i = function 153 | | [] -> first () 154 | | field_values :: t -> 155 | let id = process_row ~env ~db 156 | table_name 157 | ("__next__" :: "__next_chunk__" :: "__size__" :: field_names) 158 | (get_id (i-1) :: get_id (i-max_join) :: Data.INT (Int64.of_int (i+1)) :: field_values) 159 | v in 160 | ids.(i) <- id; 161 | save (i+1) t in 162 | save 0 (List.rev field_values_enum) 163 | | ds -> process_error v (sprintf "Found {%s}" (String.concat "," (List.map Int64.to_string ds))) 164 | 165 | let rec value_of_field ~env ~db name v = 166 | match v with 167 | | Unit -> [ Data.INT 0L ] 168 | | Null -> [ Data.INT 0L ] 169 | | Value v -> Data.INT 1L :: value_of_field ~env ~db (Name.option name) v 170 | | Int i -> [ Data.INT i ] 171 | | Bool b -> if b then [ Data.INT 1L ] else [ Data.INT 0L ] 172 | | Float f -> [ Data.FLOAT f ] 173 | | String s -> [ Data.TEXT s ] 174 | | Arrow a -> [ Data.BLOB a ] 175 | | Enum [] -> [ Data.NULL ] 176 | | Enum (h::tl) -> 177 | let id = process_enum_rows ~env ~db 178 | (Name.enum name) 179 | (field_names_of_value ~id:false h) 180 | (List.map (value_of_field ~env ~db (Name.enum name)) (h::tl)) v in 181 | [ Data.INT id ] 182 | | Tuple tl -> list_foldi (fun accu i t -> accu @ value_of_field ~env ~db (Name.tuple name i) t) [] tl 183 | | Dict tl -> List.fold_left (fun accu (n,t) -> accu @ value_of_field ~env ~db (Name.dict name n) t) [] tl 184 | | Sum (r,tl) -> Data.TEXT r :: list_foldi (fun accu i t -> accu @ value_of_field ~env ~db (Name.sum name r i) t) [] tl 185 | | Var (_,i) 186 | | Rec ((_,i),_) 187 | | Ext ((_,i),_) -> [ Data.INT i ] 188 | 189 | let replace_row ~env ~db table_name id field_names field_values = 190 | (* assert_exists ~env ~db table_name id; *) 191 | let field_names = List.map (fun f -> sprintf "%s=?" f) field_names in 192 | let replace = sprintf "UPDATE %s SET %s WHERE __id__=%Ld;" table_name (String.concat "," field_names) id in 193 | exec_sql ~env ~db replace field_values (db_must_step db) 194 | 195 | let rec update_value ~env ~db v = 196 | match v with 197 | | Ext ((n,i), s) 198 | | Rec ((n,i), s) -> 199 | let field_names = field_names_of_value ~id:false s in 200 | let field_values = value_of_field ~env ~db n s in 201 | replace_row ~env ~db n i field_names field_values; 202 | update_value ~env ~db s 203 | | Enum el -> List.iter (update_value ~env ~db) el 204 | | Tuple tl -> List.iter (update_value ~env ~db) tl 205 | | Dict tl -> List.iter (fun (_,s) -> update_value ~env ~db s) tl 206 | | Sum (r, tl) -> List.iter (update_value ~env ~db) tl 207 | | Value s -> update_value ~env ~db s 208 | | _ -> () 209 | -------------------------------------------------------------------------------- /lib/syntax/Makefile: -------------------------------------------------------------------------------- 1 | OCAMLMAKEFILE = ../../OCamlMakefile 2 | ANNOTATE = yes 3 | 4 | SOURCES = p4_hash.ml pa_hash.ml p4_utils.ml p4_orm_sqlite.ml p4_orm_appengine.ml pa_orm.ml 5 | PACKS = dyntype dyntype.syntax 6 | RESULT = pa_orm 7 | USE_CAMLP4 = yes 8 | 9 | .PHONY: all 10 | all: dcl 11 | @ : 12 | 13 | include $(OCAMLMAKEFILE) 14 | -------------------------------------------------------------------------------- /lib/syntax/p4_hash.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | (* 3 | * Copyright (c) 2009 Anil Madhavapeddy 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | open Camlp4 19 | open PreCast 20 | open Ast 21 | open Syntax 22 | open Printf 23 | 24 | let hash_of n = "hash_of_" ^ n 25 | 26 | let hash_variant s = 27 | let accu = ref 0 in 28 | for i = 0 to String.length s - 1 do 29 | accu := 223 * !accu + Char.code s.[i] 30 | done; 31 | (* reduce to 31 bits *) 32 | accu := !accu land (1 lsl 31 - 1); 33 | (* make it signed for 64 bits architectures *) 34 | if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu 35 | 36 | exception Type_not_supported of ctyp 37 | 38 | let list_foldi fn accu l = 39 | let accu, _ = List.fold_left (fun (accu, i) x -> fn accu i x, i + 1) (accu, 0) l in accu 40 | 41 | (* generate tuple and avoid singleton tuples *) 42 | let patt_tuple_of_list _loc = function 43 | | [] -> <:patt< >> 44 | | [x] -> x 45 | | h::t -> PaTup( _loc, List.fold_left (fun accu p -> <:patt< $accu$, $p$ >>) h t) 46 | 47 | let rec t ~envfn depth ctyp = 48 | let _loc = loc_of_ctyp ctyp in 49 | let default = <:expr< Hashtbl.hash x >> in 50 | let again y = if depth > 10 then 51 | <:expr< do { ignore(x); 0 } >> 52 | else 53 | t ~envfn (depth+1) y in 54 | 55 | let combine_tuple tds = 56 | let tys = list_of_ctyp tds [] in 57 | let vn p = sprintf "c%d" p in 58 | let mcp = patt_tuple_of_list _loc ( 59 | List.rev ( 60 | list_foldi 61 | (fun a i t -> 62 | <:patt< $lid:vn i$ >> :: a 63 | ) [] tys 64 | ) 65 | ) in 66 | let ext p t = <:expr< let x = $lid:vn p$ in $again t$ >> in 67 | let ex = match tys with 68 | | hd :: tl -> 69 | list_foldi (fun a i t -> 70 | <:expr< _combine $a$ $ext (i+1) t$ >> ) (ext 0 hd) tl 71 | | _ -> assert false in 72 | (mcp, ex) in 73 | 74 | match ctyp with 75 | <:ctyp< unit >> | <:ctyp< int >> 76 | | <:ctyp< int32 >> | <:ctyp< int64 >> 77 | | <:ctyp< float >> | <:ctyp< bool >> 78 | | <:ctyp< char >> | <:ctyp< string >> -> default 79 | 80 | | <:ctyp< option $t$ >> -> 81 | <:expr< match x with [ None -> 0 | Some x -> $again t$ ] >> 82 | 83 | (* records *) 84 | | <:ctyp< { $fs$ } >> -> 85 | let rec fn acc = function 86 | | <:ctyp< $t1$; $t2$ >> -> fn (fn acc t1) t2 87 | | <:ctyp< $lid:id$ : mutable $t$ >> -> acc 88 | | <:ctyp< $lid:id$ : $t$ >> -> (id,t) :: acc 89 | | _ -> assert false in 90 | let ext id t = <:expr< (let x = x.$lid:id$ in $again t$) >> in 91 | (match fn [] fs with 92 | [] -> <:expr< 0 >> 93 | | [(fid,t)] -> ext fid t 94 | | (fid,t) :: tl -> 95 | List.fold_left (fun a (fid,t) -> 96 | <:expr< _combine $a$ $ext fid t$ >> 97 | ) (ext fid t) tl 98 | ) 99 | 100 | (* variants *) 101 | | <:ctyp< [< $rf$ ] >> | <:ctyp< [> $rf$ ] >> 102 | | <:ctyp< [= $rf$ ] >> | <:ctyp< [ $rf$ ] >> -> 103 | 104 | let mcs = List.map (function 105 | | <:ctyp< $uid:id$ of $t$ >> -> 106 | let patt, ex = combine_tuple t in 107 | <:match_case< $uid:id$ $patt$ -> $ex$ >> 108 | | <:ctyp< `$uid:id$ of $t$ >> -> 109 | let patt, ex = combine_tuple t in 110 | <:match_case< `$uid:id$ $patt$ -> $ex$ >> 111 | | <:ctyp< $uid:id$ >> -> <:match_case< $uid:id$ -> $`int:hash_variant id$ >> 112 | | <:ctyp< `$uid:id$ >> -> <:match_case< `$uid:id$ -> $`int:hash_variant id$ >> 113 | | _ -> assert false 114 | ) (list_of_ctyp rf []) in 115 | <:expr< match x with [ $mcOr_of_list mcs$ ] >> 116 | 117 | (* objects have a reliable hash function *) 118 | | <:ctyp< < $_$ > >> -> default 119 | 120 | (* tuples *) 121 | | <:ctyp< ( $tup:tp$ ) >> -> 122 | let patt, ex = combine_tuple tp in 123 | <:expr< match x with [ $patt$ -> $ex$ ] >> 124 | 125 | (* enums *) 126 | | <:ctyp< list $t$ >> -> 127 | <:expr< List.fold_left (fun a x -> _combine a $again t$) 0 x >> 128 | 129 | | <:ctyp< array $t$ >> -> 130 | <:expr< Array.fold_left (fun a x -> _combine a $again t$) 0 x >> 131 | 132 | | <:ctyp< $lid:id$ >> -> 133 | begin match envfn id with 134 | | None -> <:expr< ($lid:hash_of id$ x) >> 135 | | Some ctyp -> <:expr< $again ctyp$ >> 136 | end 137 | 138 | | <:ctyp< $_$ -> $_$ >> -> default 139 | 140 | | _ -> raise (Type_not_supported ctyp) 141 | 142 | let gen1 ~envfn ctyp = 143 | let _loc = loc_of_ctyp ctyp in 144 | <:expr< 145 | let _combine acc h = ((acc lsl 5) + acc) + h in 146 | $t ~envfn 0 ctyp$ 147 | >> 148 | 149 | let gen ctyp = 150 | let _loc = loc_of_ctyp ctyp in 151 | (* make a list of all the terms *) 152 | let rec fn ty acc = 153 | match ty with 154 | Ast.TyAnd (_loc, tyl, tyr) -> 155 | fn tyl (fn tyr acc) 156 | | Ast.TyDcl (_loc, id, _, ty, []) -> 157 | (id,ty) :: acc 158 | | _ -> assert false in 159 | let env = fn ctyp [] in 160 | let envfn = fun id -> if List.mem_assoc id env then Some (List.assoc id env) else None in 161 | let bis = List.map (fun (id,ctyp) -> 162 | <:binding< 163 | $lid:hash_of id$ (x : $lid:id$) = $gen1 ~envfn ctyp$ >> 164 | ) env in 165 | <:str_item< value $biAnd_of_list bis$ >> 166 | -------------------------------------------------------------------------------- /lib/syntax/p4_orm_appengine.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | (* 3 | * Copyright (c) 2009-2010 4 | * Anil Madhavapeddy 5 | * Thomas Gazagnaire 6 | * 7 | * Permission to use, copy, modify, and distribute this software for any 8 | * purpose with or without fee is hereby granted, provided that the above 9 | * copyright notice and this permission notice appear in all copies. 10 | * 11 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 12 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 13 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 14 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 15 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 16 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 17 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 18 | *) 19 | 20 | open Camlp4 21 | open PreCast 22 | open Ast 23 | 24 | open P4_utils 25 | 26 | open Pa_dyntype 27 | 28 | let init n = n ^ "_init" 29 | let initRO n = n ^ "_init_read_only" 30 | let save n = n ^ "_save" 31 | let get n = n ^ "_get" 32 | let delete n = n ^ "_delete" 33 | let id n = n ^ "_id" 34 | let cache n = n ^ "_cache" 35 | 36 | let env_to_env _loc env = 37 | let sl_of_sl sl = 38 | expr_list_of_list _loc (List.map (fun s -> <:expr< $str:s$ >>) sl) in 39 | let aux = function 40 | | `Unique l -> <:expr< `Unique $expr_list_of_list _loc (List.map (fun (x,y) -> <:expr< ($str:x$, $sl_of_sl y$) >>) l)$ >> 41 | | `Index l -> <:expr< `Index $expr_list_of_list _loc (List.map (fun (x,y) -> <:expr< ($str:x$, $sl_of_sl y$) >>) l)$ >> 42 | | `Debug l -> <:expr< `Debug $sl_of_sl l$ >> 43 | | `Dot f -> <:expr< `Dot $str:f$ >> 44 | | `Mode _ -> assert false in 45 | expr_list_of_list _loc (List.map aux env) 46 | 47 | let init_binding env tds (_loc, n, t) = 48 | <:binding< $lid:init n$ __name__ : Orm.Ae_db.t $lid:n$ [=`RW] = 49 | let __db__ = Orm.Appengine_backend.new_state __name__ in 50 | Orm.Ae_db.of_state __db__ 51 | >> 52 | 53 | let initRO_binding env tds (_loc, n, t) = 54 | <:binding< $lid:initRO n$ __name__ : Orm.Ae_db.t $lid:n$ [=`RO] = 55 | let __db__ = Orm.Appengine_backend.new_state __name__ in 56 | Orm.Ae_db.of_state __db__ 57 | >> 58 | 59 | let save_binding env tds (_loc, n, t) = 60 | <:binding< $lid:save n$ __db__ $lid:n$ = 61 | let __db__ = Orm.Ae_db.to_state __db__ in 62 | let __ty__ = $lid:P4_type.type_of n$ in 63 | let __val__ = $lid:P4_value.value_of n$ $lid:n$ in 64 | Orm.Appengine_save.update_value ~env:__env__ ~db:__db__ __ty__ __val__ 65 | >> 66 | 67 | let get_binding env tds (_loc, n, t) = 68 | <:binding< $lid:get n$ = 69 | $P4_orm_sqlite.Get.fun_of_name _loc tds n <:expr< 70 | fun ?custom: (__custom_fn__) -> 71 | fun (__db__ : Orm.Ae_db.t $lid:n$ [<`RO|`RW]) -> 72 | let __db__ = Orm.Ae_db.to_state __db__ in 73 | let __constraints__ = $P4_orm_sqlite.Get.constraints_of_args _loc tds n$ in 74 | let __custom_fn__ = match __custom_fn__ with [ 75 | None -> None 76 | | Some fn -> Some (fun __v__ -> fn ($lid:P4_value.of_value n$ __v__)) 77 | ] in 78 | List.map 79 | (fun (__id__, __v__) -> $lid:P4_value.of_value n$ __v__) 80 | (Orm.Appengine_get.get_values ~env:__env__ ~db:__db__ ~constraints:__constraints__ ?custom_fn:__custom_fn__ $lid:P4_type.type_of n$) 81 | 82 | >>$ 83 | >> 84 | 85 | let gen env tds = 86 | let _loc = loc_of_ctyp tds in 87 | 88 | let ts = list_of_ctyp_decl tds in 89 | let init_bindings = List.map (init_binding env tds) ts in 90 | let initRO_bindings = List.map (initRO_binding env tds) ts in 91 | let save_bindings = List.map (save_binding env tds) ts in 92 | let get_bindings = List.map (get_binding env tds) ts in 93 | <:str_item< 94 | $P4_hash.gen tds$; 95 | $P4_type.gen tds$; 96 | $P4_value.gen tds$; 97 | 98 | value __env__ : Orm.Appengine_backend.env = $env_to_env _loc env$; 99 | value $biAnd_of_list init_bindings$; 100 | value $biAnd_of_list initRO_bindings$; 101 | value rec $biAnd_of_list save_bindings$; 102 | value rec $biAnd_of_list get_bindings$; 103 | >> 104 | -------------------------------------------------------------------------------- /lib/syntax/p4_orm_sqlite.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | (* 3 | * Copyright (c) 2009-2010 4 | * Anil Madhavapeddy 5 | * Thomas Gazagnaire 6 | * 7 | * Permission to use, copy, modify, and distribute this software for any 8 | * purpose with or without fee is hereby granted, provided that the above 9 | * copyright notice and this permission notice appear in all copies. 10 | * 11 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 12 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 13 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 14 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 15 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 16 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 17 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 18 | *) 19 | 20 | open Camlp4 21 | open PreCast 22 | open Ast 23 | 24 | open P4_utils 25 | 26 | open Pa_dyntype 27 | open Dyntype 28 | 29 | let init n = n ^ "_init" 30 | let initRO n = n ^ "_init_read_only" 31 | let save n = n ^ "_save" 32 | let get n = n ^ "_get" 33 | let lazy_get n = n ^ "_lazy_get" 34 | let delete n = n ^ "_delete" 35 | let id n = n ^ "_id" 36 | let cache n = n ^ "_cache" 37 | let get_by i n = n ^ "_get_by_" ^ i 38 | let ormid n = "ORMID_" ^ n 39 | 40 | let env_to_env _loc env = 41 | let sl_of_sl sl = 42 | expr_list_of_list _loc (List.map (fun s -> <:expr< $str:s$ >>) sl) in 43 | let aux = function 44 | | `Unique l -> <:expr< `Unique $expr_list_of_list _loc (List.map (fun (x,y) -> <:expr< ($str:x$, $sl_of_sl y$) >>) l)$ >> 45 | | `Index l -> <:expr< `Index $expr_list_of_list _loc (List.map (fun (x,y) -> <:expr< ($str:x$, $sl_of_sl y$) >>) l)$ >> 46 | | `Debug l -> <:expr< `Debug $sl_of_sl l$ >> 47 | | `Dot f -> <:expr< `Dot $str:f$ >> 48 | | `Mode _ -> assert false in 49 | expr_list_of_list _loc (List.map aux env) 50 | 51 | let init_binding env tds (_loc, n, t) = 52 | <:binding< $lid:init n$ __name__ : Orm.Db.t $lid:n$ [=`RW] = 53 | let __name__ = Orm.Sql_init.canonical_name __name__ in 54 | let __db__ = Orm.Sql_backend.new_state __name__ in 55 | let () = if not (Orm.Sql_init.database_exists ~env:__env__ ~db:__db__) then Orm.Sql_cache.flush_all __env__ __name__ else () in 56 | let () = Orm.Sql_init.init_tables ~mode:`RW ~env:__env__ ~db:__db__ $lid:P4_type.type_of n$ in 57 | let () = List.iter (Orm.Sql_cache.Trigger.create_function ~env:__env__ ~db:__db__) (Dyntype.Type.foreigns $lid:P4_type.type_of n$) in 58 | Orm.Db.of_state __db__ 59 | >> 60 | 61 | let initRO_binding env tds (_loc, n, t) = 62 | <:binding< $lid:initRO n$ __name__ : Orm.Db.t $lid:n$ [=`RO] = 63 | let __name__ = Orm.Sql_init.canonical_name __name__ in 64 | let __db__ = Orm.Sql_backend.new_state __name__ in 65 | let () = if not (Orm.Sql_init.database_exists ~env:__env__ ~db:__db__) then Orm.Sql_cache.flush_all __env__ __name__ else () in 66 | let () = Orm.Sql_init.init_tables ~mode:`RO ~env:__env__ ~db:__db__ $lid:P4_type.type_of n$ in 67 | let () = List.iter (Orm.Sql_cache.Trigger.create_function ~env:__env__ ~db:__db__) (Dyntype.Type.foreigns $lid:P4_type.type_of n$) in 68 | Orm.Db.of_state __db__ 69 | >> 70 | 71 | let gen_id _loc n = 72 | <:expr< fun $lid:n$ -> 73 | if Orm.Sql_cache.mem __env__ $lid:cache n$ id_seed.Orm.Sql_backend.name $lid:n$ then 74 | Orm.Sql_cache.to_weakid __env__ $lid:cache n$ id_seed.Orm.Sql_backend.name $lid:n$ 75 | else ( 76 | let id = Orm.Sql_save.empty_row ~env:__env__ ~db:id_seed $str:n$ in 77 | do { Orm.Sql_cache.add __env__ $lid:cache n$ id_seed.Orm.Sql_backend.name $lid:n$ id; id } 78 | ) >> 79 | 80 | let id_seed _loc = None, <:ctyp< Orm.Sql_backend.state >> 81 | 82 | let save_binding env tds (_loc, n, t) = 83 | <:binding< $lid:save n$ = 84 | if Dyntype.Type.is_mutable $lid:P4_type.type_of n$ then ( 85 | fun ~db: (db: Orm.Db.t $lid:n$ [=`RW]) -> 86 | let db = Orm.Db.to_state db in 87 | fun __n__ -> 88 | let v = $lid:P4_value.value_of n$ ~id_seed:db __n__ in 89 | Orm.Sql_save.update_value ~env:__env__ ~db v 90 | ) else ( 91 | fun ~db -> 92 | let db = Orm.Db.to_state db in 93 | fun __n__ -> 94 | if not (Orm.Sql_cache.mem __env__ $lid:cache n$ db.Orm.Sql_backend.name __n__) then ( 95 | let v = $lid:P4_value.value_of n$ ~id_seed:db __n__ in 96 | Orm.Sql_save.update_value ~env:__env__ ~db v 97 | ) else () 98 | ) 99 | >> 100 | 101 | module Get = struct 102 | (* This type is computed at preprocessing time, so no information is available on the external type variabales *) 103 | let pp_type_of _loc tds name = 104 | let tys = P4_type.create tds in 105 | let _, _, t = List.find (fun (_, n, _) -> n = name) tys in 106 | t 107 | 108 | let map_type fn t = 109 | let module T = Dyntype.Type in 110 | let rec aux name accu t = 111 | (match fn name t with None -> [] | Some r -> [r]) 112 | @ match t with 113 | | T.Unit | T.Sum _ | T.Var _ | T.Arrow _ 114 | | T.Bool | T.Float | T.Char | T.String | T.Int _ | T.Option _ | T.List _ | T.Array _ 115 | -> accu 116 | | T.Dict (_,d) when name = [] 117 | -> List.fold_left (fun accu (n,_,t) -> aux [n] accu t) accu d 118 | | T.Dict _ -> accu 119 | | T.Tuple t when name = [] 120 | -> fst (List.fold_left (fun (accu, i) t -> aux ["value"; string_of_int i] accu t, i+1) (accu, 1) t) 121 | | T.Tuple t -> fst (List.fold_left (fun (accu, i) t -> aux (name @ [string_of_int i]) accu t, i+1) (accu, 1) t) 122 | | T.Rec (n,t) | T.Ext (n,t) when name = [] 123 | -> aux [] accu t 124 | | T.Rec (n,t) | T.Ext (n,t) 125 | -> accu in 126 | aux [] [] t 127 | 128 | let arg_names_of_type t = 129 | let module T = Dyntype.Type in 130 | let fn name = function 131 | | T.Bool | T.Float | T.Char | T.String | T.Int _ -> Some (if name = [] then "value" else String.concat "_" name) 132 | | _ -> None in 133 | map_type fn t 134 | 135 | let variant_names_of_type _loc tds n = 136 | let t = pp_type_of _loc tds n in 137 | let ctyps = List.map (fun n -> <:ctyp< `$lid:n$ >>) (arg_names_of_type t) in 138 | <:ctyp< [= $tyOr_of_list ctyps$ ] >> 139 | 140 | let match_case_of_type _loc tds n = 141 | let t = pp_type_of _loc tds n in 142 | let match_cases = 143 | List.map (fun n -> <:match_case< Some `$lid:n$ -> Some $str:n$ >>) (arg_names_of_type t) in 144 | <:match_case< 145 | $mcOr_of_list match_cases$ | _ -> None 146 | >> 147 | 148 | let fun_of_type _loc t body = 149 | List.fold_left (fun accu n -> <:expr< fun ? $lid:n$ -> $accu$ >>) body (arg_names_of_type t) 150 | 151 | let ctyp_of_arg _loc t = 152 | let module T = Dyntype.Type in 153 | let int_like t = 154 | <:ctyp< [= `Eq of $lid:t$ | `Neq of $lid:t$ | `Le of $lid:t$ | `Ge of $lid:t$ | `Leq of $lid:t$ | `Geq of $lid:t$ ] >> in 155 | let fn _ = function 156 | | T.Bool -> Some (<:ctyp< [=`T|`F] >>) 157 | | T.Float -> Some (int_like "float") 158 | | T.Char -> Some (int_like "char") 159 | | T.String -> Some (<:ctyp< [=`Eq of string | `Contains of string ] >>) 160 | | T.Int (Some i) when i + 1 = Sys.word_size -> Some (int_like "int") 161 | | T.Int (Some i) when i <= 32 -> Some (int_like "int32") 162 | | T.Int (Some i) when i <= 64 -> Some (int_like "int64") 163 | | T.Int _ -> Some (int_like "Big_int.big_int") 164 | | _ -> None in 165 | map_type fn t 166 | 167 | let sig_of_type _loc t = 168 | List.fold_left2 169 | (fun accu n ctyp -> <:ctyp< ? $lid:n$ : $ctyp$ -> $accu$ >> ) 170 | <:ctyp< 'get_result >> 171 | (arg_names_of_type t) 172 | (ctyp_of_arg _loc t) 173 | 174 | 175 | let fun_of_name _loc tds n body = 176 | let t = pp_type_of _loc tds n in 177 | fun_of_type _loc t body 178 | 179 | let sig_of_name _loc tds n = 180 | let t = pp_type_of _loc tds n in 181 | sig_of_type _loc t 182 | 183 | let constraints_of_args _loc tds n = 184 | let t = pp_type_of _loc tds n in 185 | let make name str = 186 | let name_str = match name with [] -> "value" | l -> String.concat "_" l in 187 | let name_lst = expr_list_of_list _loc (List.map (fun s -> <:expr< $str:s$ >>) name) in 188 | <:expr< match $lid:name_str$ with [ None -> [] | Some x -> [ ($name_lst$, `$uid:str$ x) ] ] >> in 189 | let module T = Dyntype.Type in 190 | let fn name = function 191 | | T.Bool -> Some (make name "Bool") 192 | | T.Float -> Some (make name "Float") 193 | | T.Char -> Some (make name "Char") 194 | | T.Int (Some i) when i + 1 = Sys.word_size -> Some (make name "Int") 195 | | T.Int (Some i) when i <= 32 -> Some (make name "Int32") 196 | | T.Int (Some i) when i <= 64 -> Some (make name "Int64") 197 | | T.Int _ -> Some (make name "Big_int") 198 | | T.String -> Some (make name "String") 199 | | _ -> None in 200 | List.fold_left (fun accu expr -> <:expr< $expr$ @ $accu$ >>) <:expr< [] >> (map_type fn t) 201 | end 202 | 203 | let get_by_id_binding env tds (_loc, n, t) = 204 | <:binding< $lid:get_by "id" n$ = 205 | fun ~id (__db__ : Orm.Db.t $lid:n$ [<`RO|`RW]) -> 206 | let __db__ = Orm.Db.to_state __db__ in 207 | let id = match id with [ `Eq id -> `Eq ($uid:ormid n$.to_int64 id) ] in 208 | let constraints = [ ( ["__id__"], (`Opaque_id id) ) ] in 209 | match Orm.Sql_get.get_values ~env:__env__ ~db:__db__ ~constraints $lid:P4_type.type_of n$ with [ 210 | [ (__id__, __v__) ] -> 211 | if Dyntype.Type.is_mutable $lid:P4_type.type_of n$ then ( 212 | let __n__ = $lid:P4_value.of_value n$ __v__ in 213 | do { Orm.Sql_cache.add __env__ $lid:cache n$ __db__.Orm.Sql_backend.name __n__ __id__; __n__ } 214 | ) else ( 215 | if Orm.Sql_cache.mem_weakid __env__ $lid:cache n$ __db__.Orm.Sql_backend.name __id__ then ( 216 | let __n__ = List.hd (Orm.Sql_cache.of_weakid __env__ $lid:cache n$ __db__.Orm.Sql_backend.name __id__) in 217 | __n__ 218 | ) else ( 219 | let __n__ = $lid:P4_value.of_value n$ __v__ in 220 | do { Orm.Sql_cache.replace __env__ $lid:cache n$ __db__.Orm.Sql_backend.name __n__ __id__; __n__ } 221 | ) 222 | ) 223 | | _ -> raise Not_found 224 | ] 225 | >> 226 | 227 | let get_binding env tds (_loc, n, t) = 228 | <:binding< $lid:get n$ = 229 | if Dyntype.Type.is_mutable $lid:P4_type.type_of n$ then ( 230 | $Get.fun_of_name _loc tds n <:expr< 231 | fun ?custom: (__custom_fn__) -> 232 | fun ?order_by -> 233 | fun (__db__ : Orm.Db.t $lid:n$ [<`RO|`RW]) -> 234 | let __db__ = Orm.Db.to_state __db__ in 235 | let __order_by__ = match order_by with [ $Get.match_case_of_type _loc tds n$ ] in 236 | let __constraints__ = $Get.constraints_of_args _loc tds n$ in 237 | let __custom_fn__ = match __custom_fn__ with [ 238 | None -> None 239 | | Some fn -> Some (fun __v__ -> fn ($lid:P4_value.of_value n$ __v__)) 240 | ] in 241 | List.map 242 | (fun (__id__, __v__) -> 243 | let __n__ = $lid:P4_value.of_value n$ __v__ in 244 | do { Orm.Sql_cache.add __env__ $lid:cache n$ __db__.Orm.Sql_backend.name __n__ __id__; __n__ } 245 | ) (Orm.Sql_get.get_values ~env:__env__ ~db:__db__ ~constraints:__constraints__ 246 | ?order_by:__order_by__ ?custom_fn:__custom_fn__ $lid:P4_type.type_of n$) 247 | >>$ 248 | ) else ( 249 | $Get.fun_of_name _loc tds n <:expr< 250 | fun ?custom: (__custom_fn__) -> 251 | fun ?order_by -> 252 | fun __db__ -> 253 | let __db__ = Orm.Db.to_state __db__ in 254 | let __order_by__ = match order_by with [ $Get.match_case_of_type _loc tds n$ ] in 255 | let __constraints__ = $Get.constraints_of_args _loc tds n$ in 256 | let __custom_fn__ = match __custom_fn__ with [ 257 | None -> None 258 | | Some fn -> Some (fun __v__ -> fn ($lid:P4_value.of_value n$ __v__)) 259 | ] in 260 | List.map 261 | (fun (__id__, __v__) -> 262 | if Orm.Sql_cache.mem_weakid __env__ $lid:cache n$ __db__.Orm.Sql_backend.name __id__ then ( 263 | let __n__ = List.hd (Orm.Sql_cache.of_weakid __env__ $lid:cache n$ __db__.Orm.Sql_backend.name __id__) in 264 | __n__ 265 | ) else ( 266 | let __n__ = $lid:P4_value.of_value n$ __v__ in 267 | do { Orm.Sql_cache.replace __env__ $lid:cache n$ __db__.Orm.Sql_backend.name __n__ __id__; __n__ } ) 268 | ) (Orm.Sql_get.get_values ~env:__env__ ~db:__db__ ~constraints:__constraints__ 269 | ?order_by:__order_by__ ?custom_fn:__custom_fn__ $lid:P4_type.type_of n$) 270 | >>$ 271 | ) >> 272 | 273 | (* XXX: TODO; would be nice to avoid code duplication here ... *) 274 | let lazy_get_binding env tds (_loc, n, t) = 275 | <:binding< $lid:lazy_get n$ = 276 | if Dyntype.Type.is_mutable $lid:P4_type.type_of n$ then ( 277 | $Get.fun_of_name _loc tds n <:expr< 278 | fun ?custom: (__custom_fn__) -> 279 | fun ?order_by -> 280 | fun (__db__ : Orm.Db.t $lid:n$ [<`RO|`RW]) -> 281 | let __db__ = Orm.Db.to_state __db__ in 282 | let __order_by__ = match order_by with [ $Get.match_case_of_type _loc tds n$ ] in 283 | let __constraints__ = $Get.constraints_of_args _loc tds n$ in 284 | let __custom_fn__ = match __custom_fn__ with [ 285 | None -> None 286 | | Some fn -> Some (fun __v__ -> fn ($lid:P4_value.of_value n$ __v__)) 287 | ] in 288 | let __next__ = 289 | Orm.Sql_get.lazy_get_values ~env:__env__ ~db:__db__ ~constraints:__constraints__ 290 | ?order_by:__order_by__ ?custom_fn:__custom_fn__ $lid:P4_type.type_of n$ in 291 | (fun () -> 292 | match __next__ () with [ 293 | Some (__id__, __v__) -> 294 | let __n__ = $lid:P4_value.of_value n$ __v__ in 295 | do { Orm.Sql_cache.add __env__ $lid:cache n$ __db__.Orm.Sql_backend.name __n__ __id__; Some __n__ } 296 | | None -> None ]) 297 | >>$ 298 | ) else ( 299 | $Get.fun_of_name _loc tds n <:expr< 300 | fun ?custom: (__custom_fn__) -> 301 | fun ?order_by -> 302 | fun __db__ -> 303 | let __db__ = Orm.Db.to_state __db__ in 304 | let __order_by__ = match order_by with [ $Get.match_case_of_type _loc tds n$ ] in 305 | let __constraints__ = $Get.constraints_of_args _loc tds n$ in 306 | let __custom_fn__ = match __custom_fn__ with [ 307 | None -> None 308 | | Some fn -> Some (fun __v__ -> fn ($lid:P4_value.of_value n$ __v__)) 309 | ] in 310 | let __next__ = 311 | Orm.Sql_get.lazy_get_values ~env:__env__ ~db:__db__ ~constraints:__constraints__ 312 | ?order_by:__order_by__ ?custom_fn:__custom_fn__ $lid:P4_type.type_of n$ in 313 | (fun () -> 314 | match __next__ () with [ 315 | Some (__id__, __v__) -> 316 | if Orm.Sql_cache.mem_weakid __env__ $lid:cache n$ __db__.Orm.Sql_backend.name __id__ then ( 317 | let __n__ = List.hd (Orm.Sql_cache.of_weakid __env__ $lid:cache n$ __db__.Orm.Sql_backend.name __id__) in 318 | Some __n__ 319 | ) else ( 320 | let __n__ = $lid:P4_value.of_value n$ __v__ in 321 | do { Orm.Sql_cache.replace __env__ $lid:cache n$ __db__.Orm.Sql_backend.name __n__ __id__; Some __n__ } ) 322 | | None -> None ]) 323 | >>$ 324 | ) >> 325 | 326 | let delete_binding env tds (_loc, n, t) = 327 | <:binding< $lid:delete n$ = 328 | fun ?(recursive=True) -> fun ~db: (__db__: Orm.Db.t $lid:n$ [=`RW]) -> 329 | let db = Orm.Db.to_state __db__ in 330 | fun __n__ -> 331 | if Orm.Sql_cache.mem __env__ $lid:cache n$ db.Orm.Sql_backend.name __n__ then ( 332 | Orm.Sql_delete.delete_value ~env:__env__ ~db ~recursive ($lid:P4_value.value_of n$ ~id_seed:db __n__) 333 | ) else () 334 | >> 335 | 336 | let id_binding env tds (_loc, n, t) = 337 | <:binding< $lid:id n$ = 338 | fun ~db: (__db__: Orm.Db.t $lid:n$ [<`RO|`RW]) -> 339 | let db = Orm.Db.to_state __db__ in 340 | fun __n__ -> 341 | $uid:ormid n$.of_int64 (Orm.Sql_cache.to_weakid __env__ $lid:cache n$ db.Orm.Sql_backend.name __n__) 342 | >> 343 | 344 | let cache_binding env tds (_loc, n, t) = 345 | <:binding< $lid:cache n$ = $uid:"Cache_" ^ n$.create $str:n$ >> 346 | 347 | let cache_module env tds (_loc, n, t) = 348 | <:str_item< 349 | module $uid:"Cache_" ^ n$ = Orm.Sql_cache.Make( 350 | struct 351 | type __t__ = $lid:n$; 352 | type t = __t__; 353 | value equal = (==); 354 | value hash = $lid:P4_hash.hash_of n$; 355 | end) 356 | >> 357 | 358 | let ormid_module env tds (_loc, n, t) = 359 | <:str_item< 360 | module $uid:"ORMID_" ^ n$ = Orm.Sig.Make_ID(struct end); 361 | >> 362 | 363 | let orm_module env tds (_loc, n, t) = 364 | <:str_item< 365 | module $uid:"ORM_" ^ n$ : Orm.Sig.T 366 | with type t = $lid:n$ 367 | and type id = $uid:"ORMID_" ^ n$.t 368 | and type get_params 'get_result = 369 | $Get.sig_of_name _loc tds n$ 370 | and type order_by = 371 | $Get.variant_names_of_type _loc tds n$ = 372 | struct 373 | 374 | type __t__ = $lid:n$; 375 | type t = __t__; 376 | type id = $uid:"ORMID_" ^ n$.t; 377 | type get_params 'get_result = 378 | $Get.sig_of_name _loc tds n$; 379 | type order_by = 380 | $Get.variant_names_of_type _loc tds n$; 381 | 382 | value init = $lid:init n$; 383 | value init_read_only = $lid:initRO n$; 384 | value save = $lid:save n$; 385 | value get = $lid:get n$; 386 | value get_by_id = $lid:get_by "id" n$; 387 | value lazy_get = $lid:lazy_get n$; 388 | value delete = $lid:delete n$; 389 | value id = $lid:id n$; 390 | 391 | end 392 | >> 393 | 394 | let gen env tds = 395 | let _loc = loc_of_ctyp tds in 396 | 397 | let ts = list_of_ctyp_decl tds in 398 | let init_bindings = List.map (init_binding env tds) ts in 399 | let initRO_bindings = List.map (initRO_binding env tds) ts in 400 | let save_bindings = List.map (save_binding env tds) ts in 401 | let get_bindings = List.map (get_binding env tds) ts in 402 | let lazy_get_bindings = List.map (lazy_get_binding env tds) ts in 403 | let get_by_id_bindings = List.map (get_by_id_binding env tds) ts in 404 | let delete_bindings = List.map (delete_binding env tds) ts in 405 | let id_bindings = List.map (id_binding env tds) ts in 406 | let cache_bindings = List.map (cache_binding env tds) ts in 407 | let cache_modules = List.map (cache_module env tds) ts in 408 | let orm_modules = List.map (orm_module env tds) ts in 409 | let ormid_modules = List.map (ormid_module env tds) ts in 410 | 411 | <:str_item< 412 | value __env__ : Orm.Sql_backend.env = $env_to_env _loc env$; 413 | 414 | $P4_hash.gen tds$; 415 | $stSem_of_list cache_modules$; 416 | value $biAnd_of_list cache_bindings$; 417 | 418 | $P4_type.gen tds$; 419 | $P4_value.gen ~gen_id ~id_seed tds$; 420 | 421 | $stSem_of_list ormid_modules$; 422 | 423 | value $biAnd_of_list init_bindings$; 424 | value $biAnd_of_list initRO_bindings$; 425 | value rec $biAnd_of_list save_bindings$; 426 | value rec $biAnd_of_list get_bindings$; 427 | value rec $biAnd_of_list lazy_get_bindings$; 428 | value rec $biAnd_of_list get_by_id_bindings$; 429 | value $biAnd_of_list delete_bindings$; 430 | value $biAnd_of_list id_bindings$; 431 | 432 | $stSem_of_list orm_modules$; 433 | >> 434 | -------------------------------------------------------------------------------- /lib/syntax/p4_utils.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | (* 4 | * Copyright (c) 2009 Anil Madhavapeddy 5 | * Copyright (c) 2009 Thomas Gazagnaire 6 | * 7 | * Permission to use, copy, modify, and distribute this software for any 8 | * purpose with or without fee is hereby granted, provided that the above 9 | * copyright notice and this permission notice appear in all copies. 10 | * 11 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 12 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 13 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 14 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 15 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 16 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 17 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 18 | *) 19 | 20 | open Camlp4 21 | open PreCast 22 | open Ast 23 | open Syntax 24 | 25 | (* module PP = Camlp4.Printers.OCaml.Make(Syntax) 26 | let pp = new PP.printer () 27 | let debug_ctyp ty = Format.eprintf "DEBUG CTYP: %a@." pp#ctyp ty *) 28 | 29 | (* convenience function to wrap the TyDcl constructor since I cant 30 | find an appropriate quotation to use for this *) 31 | let declare_type name ty = 32 | let _loc = loc_of_ctyp ty in 33 | Ast.TyDcl (_loc, name, [], ty, []) 34 | 35 | (* defines the Ast.binding for a function of form: 36 | let fun_name ?(opt_arg1) ?(opt_arg2) ident1 ident2 = function_body ... 37 | *) 38 | let function_with_label_args ~fun_name ~idents ~function_body ~return_type opt_args = 39 | let _loc = loc_of_expr function_body in 40 | let opt_args = opt_args @ (List.map (fun x -> <:patt< $lid:x$ >>) idents) in 41 | <:binding< $lid:fun_name$ = 42 | $List.fold_right (fun b a -> 43 | <:expr $a$ >> 44 | ) opt_args <:expr< ( $function_body$ : $return_type$ ) >> 45 | $ >> 46 | 47 | (* convert a list of bindings into an expr fragment: 48 | let x = 1 in y = 2 in z = 3 in () 49 | *) 50 | let biList_to_expr bindings final = 51 | let _loc = loc_of_expr final in 52 | List.fold_right (fun b a -> 53 | <:expr< let $b$ in $a$ >> 54 | ) bindings final 55 | 56 | (* build something like 'f ?x1 ?x2 ?x3 ... xn' *) 57 | let apply _loc f label_args = 58 | let make x = Ast.ExId (_loc, Ast.IdLid (_loc, x)) in 59 | let make_label x = Ast.ExOlb (_loc, x, Ast.ExNil _loc) in 60 | let rec aux = function 61 | | [] -> make f 62 | | h::t -> Ast.ExApp (_loc, aux t , make_label h) in 63 | aux (List.rev label_args) 64 | 65 | let access_array _loc a i = 66 | let make x = Ast.ExId (_loc, Ast.IdLid (_loc, x)) in 67 | Ast.ExAre (_loc, make a, Ast.ExInt (_loc, string_of_int i)) 68 | 69 | let ctyp_is_list = function 70 | | <:ctyp< list $c$ >> 71 | | <:ctyp< array $c$ >> -> true 72 | | _ -> false 73 | 74 | (* List.map with the integer position passed to the function *) 75 | let mapi fn = 76 | let pos = ref 0 in 77 | List.map (fun x -> 78 | incr pos; 79 | fn !pos x 80 | ) 81 | 82 | let make_function _loc ?opt_args ?label_args ?return_type ~name ~args ~body () = 83 | let opt_args = match opt_args with 84 | | None -> [] 85 | | Some opts -> List.map (fun o -> <:patt< ? $lid:o$ >>) opts in 86 | let label_args = match label_args with 87 | | None -> [] 88 | | Some labs -> List.map (fun l -> <:patt< ~ $lid:l$ >>) labs in 89 | let args = List.map (fun a -> <:patt< $lid:a$ >>) args in 90 | let body = match return_type with 91 | | None -> body 92 | | Some rtyp -> <:expr< ( $body$ : $rtyp$ ) >> in 93 | <:binding< $lid:name$ = $List.fold_right (fun b a -> <:expr< fun $b$ -> $a$ >>) (opt_args @ label_args @ args) body$ >> 94 | 95 | let list_of_ctyp_decl tds = 96 | let rec aux accu = function 97 | | Ast.TyAnd (loc, tyl, tyr) -> aux (aux accu tyl) tyr 98 | | Ast.TyDcl (loc, id, _, ty, []) -> (loc, id, ty) :: accu 99 | | _ -> failwith "list_of_ctyp_decl: unexpected type" 100 | in aux [] tds 101 | 102 | let expr_list_of_list _loc exprs = 103 | match List.rev exprs with 104 | | [] -> <:expr< [] >> 105 | | h::t -> List.fold_left (fun accu x -> <:expr< [ $x$ :: $accu$ ] >>) <:expr< [ $h$ ] >> t 106 | 107 | let patt_list_of_list _loc patts = 108 | match List.rev patts with 109 | | [] -> <:patt< [] >> 110 | | h::t -> List.fold_left (fun accu x -> <:patt< [ $x$ :: $accu$ ] >>) <:patt< [ $h$ ] >> t 111 | 112 | let expr_tuple_of_list _loc = function 113 | | [] -> <:expr< >> 114 | | [x] -> x 115 | | h::t -> ExTup (_loc, List.fold_left (fun accu n -> <:expr< $accu$, $n$ >>) h t) 116 | 117 | let patt_tuple_of_list _loc = function 118 | | [] -> <:patt< >> 119 | | [x] -> x 120 | | h::t -> PaTup (_loc, List.fold_left (fun accu n -> <:patt< $accu$, $n$ >>) h t) 121 | -------------------------------------------------------------------------------- /lib/syntax/pa_hash.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | (* 3 | * Copyright (c) 2009 Anil Madhavapeddy 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | open Camlp4 19 | open PreCast 20 | open Ast 21 | open Syntax 22 | 23 | open Pa_type_conv 24 | 25 | let _ = 26 | add_generator "hash" 27 | (fun _ tds -> 28 | let _loc = loc_of_ctyp tds in 29 | <:str_item< $P4_hash.gen tds$ >> 30 | ) 31 | -------------------------------------------------------------------------------- /lib/syntax/pa_orm.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | (* 3 | * Copyright (c) 2009 Anil Madhavapeddy 4 | * Copyright (c) 2009 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open Printf 20 | open Lexing 21 | 22 | open Camlp4 23 | open PreCast 24 | open Ast 25 | 26 | open Pa_type_conv 27 | 28 | module Key = struct 29 | 30 | (* Extend grammar with options for SQL tables *) 31 | type mode = [ 32 | | `Sqlite 33 | | `Appengine 34 | ] 35 | 36 | type t = [ 37 | | `Debug of string list 38 | | `Dot of string 39 | | `Index of (string * string list) list 40 | | `Unique of (string * string list) list 41 | | `Mode of mode 42 | ] 43 | 44 | let string_of_key (k:t) = match k with 45 | | `Unique sl -> "unique: " ^ ( String.concat "," (List.map (fun (x,y) -> sprintf "(%s:%s)" x (String.concat "," y)) sl)) 46 | | `Index sl -> "index: " ^ ( String.concat "," (List.map (fun (x,y) -> sprintf "(%s:%s)" x (String.concat "," y)) sl)) 47 | | `Debug d -> "debug: " ^ (String.concat "," d) 48 | | `Dot f -> "dot: " ^ f 49 | | `Mode `Sqlite -> "mode: sqlite" 50 | | `Mode `Appengine -> "mode: appengine" 51 | 52 | 53 | let orm_parms = Gram.Entry.mk "orm_parms" 54 | EXTEND Gram 55 | 56 | GLOBAL: orm_parms; 57 | 58 | orm_svars: [[ l = LIST1 [ `LIDENT(x) -> x ] SEP "," -> l ]]; 59 | 60 | orm_table: [[ x = LIDENT; "<"; y = orm_svars; ">" -> (x, y) ]]; 61 | 62 | orm_tables: [[ l = LIST1 [ orm_table ] SEP "," -> l ]]; 63 | 64 | orm_param: [[ 65 | "unique"; ":" ; x = orm_tables -> `Unique x 66 | | "index"; ":" ; x = orm_tables -> `Index x 67 | | "debug"; ":" ; x = orm_svars -> `Debug x 68 | | "dot"; ":" ; x = STRING -> `Dot x 69 | | "mode"; ":" ; "sql" -> `Mode `Sqlite 70 | | "mode"; ":" ; "appengine" -> `Mode `Appengine 71 | ]]; 72 | 73 | orm_parms: [ 74 | [ l = LIST0 [ orm_param ] SEP ";" -> (l : t list) ] 75 | ]; 76 | 77 | END 78 | end 79 | 80 | let _ = 81 | add_generator_with_arg "orm" Key.orm_parms 82 | (fun args _ tds -> 83 | let _loc = loc_of_ctyp tds in 84 | let args = match args with None -> [] |Some x -> x in 85 | let mode, keys = List.partition (function `Mode _ -> true |_ -> false) args in 86 | match mode with 87 | | [] | [`Mode `Sqlite] -> P4_orm_sqlite.gen keys tds 88 | | [`Mode `Appengine] -> P4_orm_appengine.gen keys tds 89 | | _ -> failwith "unknown orm:mode argument" 90 | ) 91 | -------------------------------------------------------------------------------- /lib/weakid.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mirage/orm/24c2e0e3157853b2328d09feacdbe637e34d354c/lib/weakid.ml -------------------------------------------------------------------------------- /lib/weakid.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2010 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** Weak hash tables *) 18 | 19 | module type S = sig 20 | type key 21 | type 'a t 22 | val create : int -> 'a t 23 | val clear : 'a t -> unit 24 | val add : 'a t -> key -> 'a -> unit 25 | val replace : 'a t -> key -> 'a -> unit 26 | val remove : 'a t -> key -> unit 27 | val merge : 'a t -> key -> 'a -> 'a 28 | val find : 'a t -> key -> 'a 29 | val find_all : 'a t -> key -> 'a list 30 | val mem : 'a t -> key -> bool 31 | val iter : 'a t -> (key -> 'a -> unit) -> unit 32 | val fold : 'a t -> (key -> 'a -> 'b -> 'b) -> 'b -> 'b 33 | val count : 'a t -> int 34 | val stats : 'a t -> int * int * int * int * int * int 35 | val to_list : 'a t -> (key * 'a) list 36 | end 37 | 38 | module Weak_keys : functor (H : Hashtbl.HashedType) -> S with type key = H.t 39 | module Weak_values : functor (H : Hashtbl.HashedType) -> S with type key = H.t 40 | 41 | module type Sig = sig 42 | type t 43 | type elt 44 | val clear : t -> unit 45 | val length : t -> int 46 | val create : int -> t 47 | val to_weakid : t -> elt -> int64 48 | val of_weakid : t -> int64 -> elt list 49 | val mem : t -> elt -> bool 50 | val mem_weakid : t -> int64 -> bool 51 | val add : t -> elt -> int64 -> unit 52 | val fresh : t -> elt -> int64 53 | val remove : t -> elt -> unit 54 | val replace : t -> elt -> int64 -> unit 55 | val dump : t -> string 56 | end 57 | 58 | 59 | module Make : functor (H : Hashtbl.HashedType) -> Sig with type elt = H.t 60 | -------------------------------------------------------------------------------- /lib_test/Makefile: -------------------------------------------------------------------------------- 1 | OCAMLMAKEFILE=../OCamlMakefile 2 | ANNOTATE=yes 3 | 4 | .PHONY: run 5 | run: dnc 6 | ./$(RESULT) -verbose 7 | 8 | .PHONY: slow 9 | slow: dnc 10 | env SLOW=1 ./$(RESULT) -verbose 11 | 12 | export INCDIRS = ../lib 13 | export LIBDIRS = ../lib 14 | export LIBS = orm 15 | export CLIBS = sqlite3 16 | export PACKS = unix sqlite3 oUnit dyntype num 17 | export PPFLAGS = $(shell ocamlfind query dyntype.syntax -predicates \ 18 | syntax,preprocessor -format "-I %d %a" -r) \ 19 | -I ../lib/syntax pa_orm.cma 20 | 21 | RESULT= run_test 22 | TESTS= simple tuple variant alltypes foreign recursive array_simple \ 23 | foreign_and_variant foreign_tuple list_foreign list_simple \ 24 | list_tuple list_list nested_tuple nested_option variant_nested \ 25 | stress record_mutate list_mutate recursive_mutate photo object_simple \ 26 | bibtex bib large_string hash get_set list_share delete big_list stress_mutate \ 27 | option_rec 28 | 29 | TRASH= *.db 30 | SOURCES= test_utils.ml $(TESTS:%=%.ml) suite.ml 31 | ANNOTATE=yes 32 | 33 | pc_%: 34 | $(MAKE) -f Makefile.debug $@ 35 | 36 | p_%: 37 | $(MAKE) -f Makefile.debug $@ 38 | 39 | pi_%: 40 | $(MAKE) -f Makefile.debug $@ 41 | 42 | i_%: 43 | $(MAKE) -f Makefile.debug $@ 44 | 45 | -include $(OCAMLMAKEFILE) 46 | -------------------------------------------------------------------------------- /lib_test/Makefile.debug: -------------------------------------------------------------------------------- 1 | # Makefile to build and run the test files in a variety of ways 2 | 3 | P4INC = `ocamlfind query orm.syntax -predicates syntax,preprocessor -format "-I %d %a" -r` 4 | PACKS= -package unix,sqlite3,oUnit,orm.syntax 5 | 6 | TESTS := alltypes foreign_and_variant list_foreign list_simple nested_tuple simple_option \ 7 | tuple variant_tuple simple_alltypes \ 8 | array_simple foreign_nested list_list list_tuple recursive simple_twodefs variant \ 9 | foreign foreign_tuple list_recursive nested_option simple variant_nested 10 | # delete 11 | 12 | .PHONY: all 13 | all: $(TESTS:%=pr_%) $(TESTS:%=r_%) $(TESTS:%=pi_%) $(TESTS:%=i_%) 14 | @ : 15 | 16 | # p_% prints out the process ML file to stdout 17 | .PHONY: p_% 18 | p_%: 19 | camlp4o $(P4INC) -parser o -printer o $*.ml 20 | 21 | # top_% makes a top-level for the ML file 22 | top_%: pc_% 23 | ocamlfind ocamlmktop $(PACKS) -linkpkg -o $@ -I ../ sql_access.cma pc_$*.cmo 24 | 25 | # pc_% compiles it via a temporary ML file (pc_%.ml) so that locations in generated code can be 26 | # seen in error messages as a debugging aid 27 | pc_%: %.ml 28 | camlp4o $(P4INC) -printer o $*.ml > $@.ml 29 | ocamlfind ocamlc -verbose -linkpkg -g -annot -o $@ $(PACKS) $@.ml 30 | 31 | # pr_% compiles and runs the code via the intermediate ML file 32 | pr_%: pc_% 33 | @./$< 34 | 35 | # c_% compiles the ML file directly by invoking camlp4 as -pp (how it is used in production) 36 | c_%: %.ml 37 | ocamlfind ocamlc -verbose -o $@ -linkpkg -g $(PACKS) \ 38 | -pp "camlp4o $(P4INC) " $*.ml 39 | 40 | nc_%: %.ml 41 | ocamlfind ocamlopt -o $@ -linkpkg $(PACKS) \ 42 | -pp "camlp4o $(P4INC) " $*.ml 43 | 44 | # r_% runs the executable generated by directly compiling with the p4 extension 45 | r_%: c_% 46 | @./$< 47 | 48 | # i_% displays the inferred OCaml interface of the generated functions 49 | .PHONY: i_% 50 | i_%: %.ml 51 | ocamlfind ocamlc -i -verbose -linkpkg -g $(PACKS) \ 52 | -pp "camlp4o $(P4INC) " $*.ml 53 | 54 | # pi_% prints to a temporary file and then displays the Ocaml interface 55 | pi_%: %.ml 56 | camlp4o $(P4INC) -printer o $*.ml > $@.ml 57 | ocamlfind ocamlc -verbose -i -linkpkg -g $(PACKS) $@.ml 58 | 59 | .PHONY: clean 60 | clean: 61 | rm -f pc_* c_* pi_* *.cmo *.cma *.db *.cmi top_* 62 | -------------------------------------------------------------------------------- /lib_test/alltypes.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | open Printf 4 | open OUnit 5 | open Test_utils 6 | 7 | let name = "alltypes.db" 8 | 9 | type x = { 10 | one: char; 11 | two: string; 12 | three: int; 13 | four: int32; 14 | five: bool; 15 | six: int64; 16 | seven: unit; 17 | eight: string option; 18 | nine: float; 19 | ten: (int * string); 20 | eleven: string list; 21 | twelve: (char * int32 * unit) option; 22 | thirteen: (char * (string * int64) option); 23 | } 24 | and y=int with orm 25 | 26 | let name = "alltypes.db" 27 | let x = { one='a'; two="foo"; three=1; four=2l; 28 | five=true; six=3L; seven=(); eight=(Some "bar"); 29 | nine=6.9; ten=(100,"hello"); eleven=["aa";"bb";"cc"]; 30 | twelve=(Some ('t',9l,())); thirteen=('d', (Some ("abc",999L))) } 31 | 32 | let test_init () = 33 | ignore(open_db x_init name); 34 | ignore(open_db ~rm:false x_init name); 35 | ignore(open_db ~rm:false x_init name) 36 | 37 | let test_save () = 38 | let db = open_db x_init name in 39 | x_save db x 40 | 41 | let test_update () = 42 | let db = open_db x_init name in 43 | x_save db x; 44 | x_save db x 45 | 46 | let test_get () = 47 | let db = open_db ~rm:false x_init name in 48 | let i = x_get db in 49 | "2 in db" @? (List.length i = 1); 50 | let i = List.hd i in 51 | "values match" @? (i.six = x.six) 52 | 53 | let test_save_get () = 54 | let db = open_db x_init name in 55 | x_save db x; 56 | let i = x_get db in 57 | "1 in db" @? (List.length i = 1); 58 | let i = List.hd i in 59 | "structural values equal" @? ( x = i); 60 | "physical values equal" @? ( x == i) 61 | 62 | let suite = [ 63 | "alltypes_init" >:: test_init; 64 | "alltypes_save" >:: test_save; 65 | "alltypes_update" >:: test_update; 66 | "alltypes_get" >:: test_get; 67 | "alltypes_save_get" >:: test_save_get; 68 | ] 69 | -------------------------------------------------------------------------------- /lib_test/array_simple.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type s = { 4 | foo: int array; 5 | bar: string 6 | } with orm 7 | 8 | open OUnit 9 | open Test_utils 10 | 11 | let name = "array_simple.db" 12 | let t1 = { foo=[|1|]; bar="t1" } 13 | let t2 = { foo=[|1;2;3|]; bar="t2" } 14 | let t3 = { foo=[||]; bar="t3" } 15 | 16 | let test_init () = 17 | ignore(open_db s_init name); 18 | ignore(open_db ~rm:false s_init name); 19 | ignore(open_db ~rm:false s_init name) 20 | 21 | let test_save () = 22 | let db = open_db s_init name in 23 | s_save db t1; 24 | s_save db t2; 25 | s_save db t3 26 | 27 | let test_update () = 28 | let db = open_db s_init name in 29 | s_save db t1; 30 | s_save db t2; 31 | s_save db t3; 32 | s_save db t1; 33 | s_save db t2; 34 | s_save db t3 35 | 36 | let test_get () = 37 | let db = open_db ~rm:false s_init name in 38 | let i = s_get db in 39 | "3 in db" @? (List.length i = 3); 40 | let i = List.hd (List.rev i) in 41 | "values match" @? (i.bar = t3.bar && (i.foo = t3.foo)) 42 | 43 | let test_save_get () = 44 | let db = open_db s_init name in 45 | s_save db t3; 46 | let i = s_get db in 47 | "1 in db" @? (List.length i = 1); 48 | let i = List.hd i in 49 | "structural values equal" @? ( t3 = i); 50 | "physical values equal" @? ( t3 == i) 51 | 52 | let test_delete () = 53 | let db = open_db s_init name in 54 | s_save db t1; 55 | s_save db t2; 56 | s_save db t3; 57 | "3 in db" @? (List.length (s_get db) = 3); 58 | s_delete db t2; 59 | "2 in db" @? (List.length (s_get db) = 2); 60 | (match s_get db with 61 | [a1;a3] -> "equal" @? (a3=t3 && a1=t1) 62 | |_ -> assert false); 63 | s_delete db t1; 64 | s_delete db t3; 65 | "0 in db" @? (List.length (s_get db) = 0) 66 | 67 | let suite = [ 68 | "array_simple_init" >:: test_init; 69 | "array_simple_save" >:: test_save; 70 | "array_simple_update" >:: test_update; 71 | "array_simple_get" >:: test_get; 72 | "array_simple_save_get" >:: test_save_get; 73 | "array_simple_delete" >:: test_delete; 74 | ] 75 | -------------------------------------------------------------------------------- /lib_test/bib.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | open Printf 4 | 5 | type t = 6 | |Book 7 | |In_proceedings 8 | |In_book 9 | |In_collection 10 | |Article 11 | |Proceedings 12 | |Webpage 13 | |Tech_report 14 | |Phd_thesis 15 | |Masters_thesis 16 | |Unpublished 17 | |Misc 18 | 19 | and ent = { 20 | ty: t; 21 | key: string; 22 | authors: string list; 23 | year: int option; 24 | title: string; 25 | misc: (string * string) list 26 | } with orm 27 | 28 | open OUnit 29 | open Test_utils 30 | 31 | let name = "bib.db" 32 | 33 | let test_init () = 34 | ignore(open_db ent_init name); 35 | ignore(open_db ~rm:false ent_init name); 36 | ignore(open_db ~rm:false ent_init name) 37 | 38 | let test_save () = 39 | let b = { ty=Book; key="akey"; authors=["Anil";"Thomas"]; year=(Some 2010); title="Do ORMs ever work?"; misc=["key","val"; "key2","val2"] } in 40 | let b2 = { ty=Book; key="23467"; authors=["Anil";"Thomas"]; year=(Some 2010); title="Do ORMs ever work?"; misc=["key","val"; "key2","val2"] } in 41 | let db = open_db ent_init name in 42 | ent_save db b; 43 | ent_save db b2 44 | 45 | let test_get () = 46 | let db = open_db ent_init_read_only ~rm:false name in 47 | let _ = ent_get db in 48 | () 49 | 50 | let suite = [ 51 | "bib_init" >:: test_init; 52 | "bib_save" >:: test_save; 53 | "bib_get" >:: test_get; 54 | ] 55 | -------------------------------------------------------------------------------- /lib_test/bibtex.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | open Printf 4 | 5 | type entry_type = string 6 | and key = string 7 | and atom = 8 | | Id of string 9 | | String of string 10 | and command = 11 | | Comment of string 12 | | Preamble of atom list 13 | | Abbrev of string * atom list 14 | | Entry of entry_type * key * (string * atom list) list 15 | with orm 16 | 17 | open OUnit 18 | open Test_utils 19 | 20 | let name = "bibtex.db" 21 | 22 | let test_init () = 23 | ignore(open_db command_init name); 24 | ignore(open_db ~rm:false command_init name); 25 | ignore(open_db ~rm:false command_init name) 26 | 27 | let test_save () = 28 | let b = Entry ("article", "foo123", [ "str", [Id "x"; String "y"] ]) in 29 | let db = open_db command_init name in 30 | command_save db b 31 | 32 | let suite = [ 33 | "bibtex_init" >:: test_init; 34 | "bibtex_save" >:: test_save; 35 | ] 36 | -------------------------------------------------------------------------------- /lib_test/big_list.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | let db = "big_list.db" 4 | 5 | open Test_utils 6 | open OUnit 7 | 8 | type t = int list with orm 9 | 10 | let rec genl acc = function 11 | | 0 -> acc 12 | | n -> genl (n::acc) (n-1) 13 | 14 | let big_save () = 15 | let db = open_db t_init db in 16 | for i = 2 to 5 do 17 | let l = genl [] (i*100) in 18 | t_save ~db l 19 | done 20 | 21 | let big_get () = 22 | let db = open_db ~rm:false t_init db in 23 | let all = t_get db in 24 | let item i = 25 | (List.exists (fun l -> List.length l = i) all) in 26 | 27 | "cardinal" @? (List.length all = 4); 28 | "items:200" @? item 200; 29 | "items:300" @? item 200; 30 | "items:400" @? item 200; 31 | "items:500" @? item 200 32 | 33 | 34 | let suite = [ 35 | "big_save" >:: big_save; 36 | "big_get" >:: big_get; 37 | ] 38 | -------------------------------------------------------------------------------- /lib_test/delete.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | open Test_utils 4 | open OUnit 5 | 6 | type t = string with orm 7 | type u = int * t with orm 8 | 9 | let t = "foo" 10 | let u = (3, t) 11 | 12 | let name = "delete.db" 13 | 14 | let test_delete () = 15 | let dbt = open_db t_init name in 16 | let dbu = open_db ~rm:false u_init name in 17 | 18 | let check n (t, u) = 19 | (Printf.sprintf "%d: %d t in db" n t) @? (List.length (t_get dbt) = t); 20 | (Printf.sprintf "%d: %d u in db" n u) @? (List.length (u_get dbu) = u) in 21 | 22 | u_save dbu u; 23 | check 0 (1, 1); 24 | 25 | (* recursive delete should delete all non-referenced sub-values *) 26 | u_delete dbu u; 27 | check 1 (0, 0); 28 | 29 | (* non-recursive delete should delete only the parent value *) 30 | u_save dbu u; 31 | u_delete ~recursive:false ~db:dbu u; 32 | check 2 (1, 0) 33 | 34 | let suite = [ 35 | "delete" >:: test_delete; 36 | ] 37 | -------------------------------------------------------------------------------- /lib_test/foreign.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type t = { 4 | foo: string; 5 | bar: int64; 6 | xyz: char; 7 | } and x = { 8 | first: t; 9 | second: t; 10 | third: int; 11 | } with orm ( 12 | unique: t, t; 13 | index: x 14 | ) 15 | 16 | let name = "foreign.db" 17 | let s1 = { foo="hello"; bar=100L; xyz='a' } 18 | let s2 = { foo="world"; bar=200L; xyz='z' } 19 | let x = { first=s1; second=s2; third=111 } 20 | 21 | open Test_utils 22 | open OUnit 23 | 24 | let test_init () = 25 | ignore(open_db t_init name); 26 | ignore(open_db ~rm:false x_init name); 27 | ignore(open_db ~rm:false x_init name) 28 | 29 | let test_save () = 30 | let db = open_db x_init name in 31 | x_save db x 32 | 33 | let test_update () = 34 | let db = open_db x_init name in 35 | x_save db x; 36 | x_save db x 37 | 38 | let test_get () = 39 | let db = open_db ~rm:false x_init name in 40 | let i = x_get db in 41 | "1 in db" @? (List.length i = 1); 42 | let i = List.hd i in 43 | "values match" @? (i.first = x.first && (i.second = x.second)) 44 | 45 | let test_save_get () = 46 | let db = open_db x_init name in 47 | x_save db x; 48 | let i = x_get db in 49 | "1 in db" @? (List.length i = 1); 50 | match i with 51 | [i] -> 52 | "structural values equal" @? ( x = i); 53 | "physical values equal" @? ( x == i) 54 | |_ -> assert false 55 | 56 | let suite = [ 57 | "foreign_init" >:: test_init; 58 | "foreign_save" >:: test_save; 59 | "foreign_update" >:: test_update; 60 | "foreign_get" >:: test_get; 61 | "foreign_save_get" >:: test_save_get; 62 | ] 63 | -------------------------------------------------------------------------------- /lib_test/foreign_and_variant.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type v = 4 | | Alice 5 | | Bob of int 6 | | Charlie of (int * int64) 7 | and s = { 8 | foo: string; 9 | bar: int64; 10 | xyz: v; 11 | } and x = { 12 | first: s; 13 | second: s; 14 | third: int; 15 | } with orm 16 | 17 | open OUnit 18 | open Test_utils 19 | 20 | let name = "foreign_and_variant.db" 21 | 22 | let v = Charlie (1002,1003L) 23 | let s = { foo="s1"; bar=99L; xyz=v } 24 | let x = { first=s; second=s; third=99 } 25 | 26 | let test_init () = 27 | ignore(open_db v_init name); 28 | ignore(open_db ~rm:false s_init name); 29 | ignore(open_db ~rm:false x_init name) 30 | 31 | let test_save () = 32 | let db = open_db x_init name in 33 | x_save db x 34 | 35 | let test_update () = 36 | let db = open_db x_init name in 37 | x_save db x; 38 | x_save db x 39 | 40 | let test_get () = 41 | let db = open_db ~rm:false x_init name in 42 | let i = x_get db in 43 | "1 in db" @? (List.length i = 1); 44 | match i with 45 | | [a] -> 46 | "values match" @? (a.first = x.first) 47 | | _ -> assert false 48 | 49 | let test_save_get () = 50 | let db = open_db x_init name in 51 | x_save db x; 52 | match x_get db with 53 | [i] -> "structurally equal after get" @? ( x == i) 54 | |_ -> assert false 55 | 56 | let suite = [ 57 | "foreign_and_variant_init" >:: test_init; 58 | "foreign_and_variant_save" >:: test_save; 59 | "foreign_and_variant_update" >:: test_update; 60 | "foreign_and_variant_update" >:: test_update; 61 | "foreign_and_variant_get" >:: test_get; 62 | "foreign_and_variant_save_get" >:: test_save_get; 63 | ] 64 | -------------------------------------------------------------------------------- /lib_test/foreign_tuple.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type t = { 4 | foo: string; 5 | bar: int64; 6 | } and x = { 7 | first: (string * int64 * t); 8 | second: t; 9 | third: int; 10 | } with orm 11 | 12 | open OUnit 13 | open Test_utils 14 | 15 | let s = { foo="f1"; bar=59L } 16 | let x = { first=("first",3434L,s); second=s; third=99 } 17 | 18 | let name = "foreign_tuple.db" 19 | 20 | let test_init () = 21 | ignore(open_db x_init name); 22 | ignore(open_db ~rm:false t_init name); 23 | ignore(open_db ~rm:false x_init name) 24 | 25 | let test_save () = 26 | let db = open_db x_init name in 27 | x_save db x 28 | 29 | let test_update () = 30 | let db = open_db x_init name in 31 | x_save db x; 32 | x_save db x 33 | 34 | let test_get () = 35 | let db = open_db ~rm:false x_init name in 36 | let i = x_get db in 37 | "1 in db" @? (List.length i = 1); 38 | let i = List.hd i in 39 | "values match" @? (i.first = x.first && (i.second = x.second)) 40 | 41 | let test_save_get () = 42 | let db = open_db x_init name in 43 | x_save db x; 44 | let i = x_get db in 45 | "1 in db" @? (List.length i = 1); 46 | match i with 47 | [i] -> 48 | "structural values equal" @? ( x = i); 49 | "physical values equal" @? ( x == i) 50 | |_ -> assert false 51 | 52 | let suite = [ 53 | "foreign_tuple_init" >:: test_init; 54 | "foreign_tuple_save" >:: test_save; 55 | "foreign_tuple_update" >:: test_update; 56 | "foreign_tuple_get" >:: test_get; 57 | "foreign_tuple_save_get" >:: test_save_get; 58 | ] 59 | -------------------------------------------------------------------------------- /lib_test/get_set.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type t = { 4 | mutable x : string; 5 | mutable y : string; 6 | z : bool; 7 | } with orm() 8 | 9 | let get db x = 10 | t_get db ~x:x 11 | 12 | let get_true db = 13 | t_get ~z:(`T) db 14 | 15 | let set db x y = 16 | let t = List.hd (get db x) in 17 | t.y <- y; 18 | t_save db t 19 | 20 | (* 21 | * The following should fail to compile 22 | let fail () = 23 | let t = { x="hello"; y="world" } in 24 | let db = t_init_read_only "foo" in 25 | t_save db t 26 | *) 27 | -------------------------------------------------------------------------------- /lib_test/hash.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type p = 4 | |One of int array * string * float * bool * (char list) 5 | |Two of (int * int * int) 6 | |Three of x option list 7 | 8 | and pp = [ `Poly1 | `Poly2 | `Poly3 of int ] 9 | 10 | and t = { 11 | t1: int; 12 | mutable t2: string; 13 | t3: x 14 | } 15 | 16 | and x = { 17 | x1: t array; 18 | x2: int64 19 | } 20 | 21 | and 22 | f = { 23 | mutable f1: int; 24 | mutable f2: string list; 25 | f3: string; 26 | f4: int64; 27 | f5: char array; 28 | } 29 | 30 | and tu = ( int * f * pp ) 31 | 32 | with hash 33 | 34 | type o = < x: int; y: string; z: (int -> string) > with hash 35 | 36 | module FH = Hashtbl.Make(struct 37 | let hash = hash_of_f 38 | let equal = (=) 39 | let compare = compare 40 | type t = f 41 | end) 42 | 43 | let rs () = 44 | Random.self_init (); 45 | let len = Random.int 30 in 46 | let s = String.create len in 47 | for i = 0 to len - 1 do 48 | String.set s i (Char.chr (Random.int 25 + 97)) 49 | done; 50 | s 51 | 52 | open OUnit 53 | 54 | let test_replace () = 55 | let h = FH.create 1 in 56 | let fg () = { f1=(Random.int 100000); f2=[rs(); rs(); rs()]; f3=rs(); f4=(Random.int64 1000000L); f5=[|'a';'b'|] } in 57 | for i = 1 to 10000 do 58 | let f = fg () in 59 | FH.add h f (); 60 | "hash len ok" @? (FH.length h = i); 61 | FH.replace h f (); 62 | "hash len ok after replace" @? (FH.length h = i); 63 | f.f1 <- Random.int 100000; 64 | f.f2 <- [ rs (); rs (); rs ()]; 65 | FH.replace h f (); 66 | "hash len ok after replace mutate" @? (FH.length h = i); 67 | done 68 | 69 | let suite = [ 70 | "hash_replace" >:: test_replace 71 | ] 72 | -------------------------------------------------------------------------------- /lib_test/large_string.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | open Printf 4 | 5 | type x = { 6 | name: string; 7 | body: string 8 | } with orm 9 | 10 | open OUnit 11 | open Test_utils 12 | 13 | let name = "large_string.db" 14 | let size = 10000000 15 | let x1 = { name = "x1"; body = String.make size 'x' } 16 | let x2 = { name = "x2"; body = String.make size 'y' } 17 | let x3 = { name = "x3"; body = String.make size 'z' } 18 | 19 | let test_init () = 20 | ignore(open_db x_init name); 21 | ignore(open_db ~rm:false x_init name); 22 | ignore(open_db ~rm:false x_init name) 23 | 24 | let test_save () = 25 | let db = open_db x_init name in 26 | let _ = open_db ~rm:false x_init_read_only name in 27 | x_save db x1; 28 | x_save db x2; 29 | x_save db x3 30 | 31 | let test_update () = 32 | let db = open_db x_init name in 33 | List.iter (fun i -> 34 | x_save db x1; 35 | x_save db x2; 36 | x_save db x3; 37 | ) [1;2;3;4;5;6;7;8;9;10] 38 | 39 | let suite = [ 40 | "large_string_init" >:: test_init; 41 | "large_string_save" >:: test_save; 42 | "large_string_update" >:: test_update; 43 | ] 44 | -------------------------------------------------------------------------------- /lib_test/list_foreign.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type s = { 4 | foo: int; 5 | bar: string 6 | } and x = { 7 | one: s list; 8 | } with orm 9 | 10 | let t1 = {foo=1; bar="t1"} 11 | let t2 = {foo=2; bar="t2"} 12 | let x1 = {one=[t1;t2;t1] } 13 | let x2 = {one=[]} 14 | 15 | let name = "list_foreign.db" 16 | 17 | open OUnit 18 | open Test_utils 19 | 20 | let test_init () = 21 | ignore(open_db x_init name); 22 | ignore(open_db ~rm:false x_init name); 23 | ignore(open_db ~rm:false s_init name) 24 | 25 | let test_save () = 26 | let db = open_db x_init name in 27 | x_save db x1; 28 | x_save db x2 29 | 30 | let test_update () = 31 | let db = open_db x_init name in 32 | x_save db x1; 33 | x_save db x2; 34 | x_save db x1; 35 | x_save db x2 36 | 37 | let test_get () = 38 | let dbx = open_db ~rm:false x_init name in 39 | let dbs = open_db ~rm:false s_init name in 40 | "2 x in db" @? (List.length (x_get dbx) = 2); 41 | "2 s in db" @? (List.length (s_get dbs) = 2) 42 | 43 | let test_save_get () = 44 | let db = open_db x_init name in 45 | x_save db x1; 46 | let i = x_get db in 47 | "1 in db" @? (List.length i = 1); 48 | let i = List.hd i in 49 | "structural values equal" @? ( x1 = i); 50 | "physical values equal" @? ( x1 == i) 51 | 52 | let suite = [ 53 | "list_foreign_init" >:: test_init; 54 | "list_foreign_save" >:: test_save; 55 | "list_foreign_update" >:: test_update; 56 | "list_foreign_get" >:: test_get; 57 | "list_foreign_save_get" >:: test_save_get; 58 | ] 59 | -------------------------------------------------------------------------------- /lib_test/list_list.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type x = { 4 | foo: int list list; 5 | bar: string 6 | } with orm 7 | 8 | open OUnit 9 | open Test_utils 10 | 11 | let name = "list_list.db" 12 | 13 | let x1 = {foo=[[1]]; bar="t1" } 14 | let x2 = {foo=[[2;3;4];[6;7]] ;bar="t2"} 15 | let x3 = {foo=[]; bar="t3" } 16 | 17 | let test_init () = 18 | ignore(open_db x_init name); 19 | ignore(open_db ~rm:false x_init name); 20 | ignore(open_db ~rm:false x_init name) 21 | 22 | let test_save () = 23 | let db = open_db x_init name in 24 | x_save db x1; 25 | x_save db x2; 26 | x_save db x3 27 | 28 | let test_update () = 29 | let db = open_db x_init name in 30 | x_save db x1; 31 | x_save db x2; 32 | x_save db x2; 33 | x_save db x1; 34 | x_save db x2; 35 | x_save db x3 36 | 37 | let test_get () = 38 | let db = open_db ~rm:false x_init name in 39 | "3 x in db" @? (List.length (x_get db) = 3) 40 | 41 | let test_save_get () = 42 | let db = open_db x_init name in 43 | x_save db x1; 44 | x_save db x2; 45 | x_save db x3; 46 | match x_get db with 47 | |[a1;a2;a3] -> 48 | "structural values equal" @? ( x1 = a1); 49 | "physical values equal" @? ( x1 == a1); 50 | "structural values equal" @? ( x2 = a2); 51 | "physical values equal" @? ( x2 == a2); 52 | "structural values equal" @? ( x3 = a3); 53 | "physical values equal" @? ( x3 == a3) 54 | |_ -> assert false 55 | 56 | let suite = [ 57 | "list_list_init" >:: test_init; 58 | "list_list_save" >:: test_save; 59 | "list_list_update" >:: test_update; 60 | "list_list_update" >:: test_update; 61 | "list_list_get" >:: test_get; 62 | "list_list_save_get" >:: test_save_get; 63 | ] 64 | -------------------------------------------------------------------------------- /lib_test/list_mutate.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type x = { 4 | foo: int; 5 | mutable bar: (string * string) list 6 | } with orm 7 | 8 | open Test_utils 9 | open OUnit 10 | 11 | let name = "list_mutate.db" 12 | 13 | let test_mutate_basic () = 14 | let db = open_db x_init name in 15 | let l = [ "foo1","bar1"; "foo2","bar2" ] in 16 | let t1 = {foo=1; bar=l } in 17 | x_save db t1; 18 | let l = ("foo3","bar3") :: l in 19 | t1.bar <- l; 20 | x_save db t1; 21 | match x_get db with 22 | | [x] -> "eq" @? (x.bar = ["foo3","bar3"; "foo1","bar1"; "foo2","bar2" ]) 23 | | [] -> failwith "no x" 24 | | x -> failwith (Printf.sprintf "too many x: %d" (List.length x)) 25 | 26 | let test_mutate_empty () = 27 | let db = open_db x_init name in 28 | let l = [ "foo1", "bar1" ] in 29 | let t1 = { foo = 1; bar = l } in 30 | x_save db t1; 31 | t1.bar <- []; 32 | x_save db t1 33 | 34 | let suite = [ 35 | "list_mutate_basic" >:: test_mutate_basic; 36 | "list_mutate_empty" >:: test_mutate_empty; 37 | ] 38 | -------------------------------------------------------------------------------- /lib_test/list_share.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type x = { 4 | foo: string list; 5 | } with orm 6 | 7 | open OUnit 8 | open Test_utils 9 | 10 | let name = "list_share.db" 11 | let x1 = { foo=["a";"p";"w"] } 12 | let x2 = { foo=["g";"m";"p"] } 13 | let x3 = { foo=["m";"p";"z"] } 14 | let x4 = { foo=["p"] } 15 | 16 | let test_init () = 17 | ignore(open_db x_init name); 18 | ignore(open_db ~rm:false x_init name); 19 | ignore(open_db ~rm:false x_init name) 20 | 21 | let test_save () = 22 | let db = open_db x_init name in 23 | x_save db x1; 24 | x_save db x2; 25 | x_save db x3; 26 | x_save db x4 27 | 28 | let test_update () = 29 | let db = open_db x_init name in 30 | x_save db x1; 31 | x_save db x1; 32 | x_save db x2; 33 | x_save db x2; 34 | x_save db x3; 35 | x_save db x3; 36 | x_save db x4; 37 | x_save db x4 38 | 39 | let test_get () = 40 | let db = open_db ~rm:false x_init name in 41 | "4 x in db" @? (List.length (x_get db) = 4) 42 | 43 | let test_save_get () = 44 | let db = open_db x_init name in 45 | x_save db x1; 46 | let i = x_get db in 47 | "1 in db" @? (List.length i = 1); 48 | let i = List.hd i in 49 | "structural values equal" @? ( x1 = i); 50 | "physical values equal" @? ( x1 == i) 51 | 52 | let suite = [ 53 | "list_share_init" >:: test_init; 54 | "list_share_save" >:: test_save; 55 | "list_share_update" >:: test_update; 56 | "list_share_get" >:: test_get; 57 | "list_share_save_get" >:: test_save_get; 58 | ] 59 | -------------------------------------------------------------------------------- /lib_test/list_simple.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type x = { 4 | foo: string list; 5 | bar: (char * string) list; 6 | pla: bool; 7 | } with orm(debug:none) 8 | 9 | open OUnit 10 | open Test_utils 11 | 12 | let name = "list_simple.db" 13 | let x1 = { foo=["a1";"a2";"a3";"a4"]; bar=[ ('a',"AA"); ('b',"BB"); ('c',"CC") ] ; pla=true } 14 | 15 | let test_init () = 16 | ignore(open_db x_init name); 17 | ignore(open_db ~rm:false x_init name); 18 | ignore(open_db ~rm:false x_init name) 19 | 20 | let test_save () = 21 | let db = open_db x_init name in 22 | x_save db x1 23 | 24 | let test_update () = 25 | let db = open_db x_init name in 26 | x_save db x1; 27 | x_save db x1 28 | 29 | let test_get () = 30 | let db = open_db ~rm:false x_init name in 31 | "1 x in db" @? (List.length (x_get db) = 1) 32 | 33 | let test_save_get () = 34 | let db = open_db x_init name in 35 | x_save db x1; 36 | let i = x_get db in 37 | "1 in db" @? (List.length i = 1); 38 | let i = List.hd i in 39 | "structural values equal" @? ( x1 = i); 40 | "physical values equal" @? ( x1 == i) 41 | 42 | let suite = [ 43 | "list_simple_init" >:: test_init; 44 | "list_simple_save" >:: test_save; 45 | "list_simple_update" >:: test_update; 46 | "list_simple_get" >:: test_get; 47 | "list_simple_save_get" >:: test_save_get; 48 | ] 49 | -------------------------------------------------------------------------------- /lib_test/list_tuple.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type x = { 4 | foo: (int * char list) list; 5 | bar: string 6 | } with orm 7 | 8 | open OUnit 9 | open Test_utils 10 | 11 | let x1 = {foo=[(1,['x';'y'])] ; bar="hello world" } 12 | let x2 = {foo=[(2,[]); (3,['a';'b';'c']); (4,['a'])] ; bar="world hello" } 13 | let x3 = {foo=[] ; bar="world hello" } 14 | 15 | let name = "list_tuple.db" 16 | 17 | let test_init () = 18 | ignore(open_db x_init name); 19 | ignore(open_db ~rm:false x_init name); 20 | ignore(open_db ~rm:false x_init name) 21 | 22 | let test_save () = 23 | let db = open_db x_init name in 24 | x_save db x1; 25 | x_save db x2; 26 | x_save db x3 27 | 28 | let test_update () = 29 | let db = open_db x_init name in 30 | x_save db x1; 31 | x_save db x2; 32 | x_save db x2; 33 | x_save db x1; 34 | x_save db x2; 35 | x_save db x3 36 | 37 | let test_get () = 38 | let db = open_db ~rm:false x_init name in 39 | "3 x in db" @? (List.length (x_get db) = 3) 40 | 41 | let test_save_get () = 42 | let db = open_db x_init name in 43 | x_save db x1; 44 | x_save db x2; 45 | x_save db x3; 46 | match x_get db with 47 | |[a1;a2;a3] -> 48 | "structural values equal" @? ( x1 = a1); 49 | "physical values equal" @? ( x1 == a1); 50 | "structural values equal" @? ( x2 = a2); 51 | "physical values equal" @? ( x2 == a2); 52 | "structural values equal" @? ( x3 = a3); 53 | "physical values equal" @? ( x3 == a3) 54 | |_ -> assert false 55 | 56 | let suite = [ 57 | "list_tuple_init" >:: test_init; 58 | "list_tuple_save" >:: test_save; 59 | "list_tuple_update" >:: test_update; 60 | "list_tuple_get" >:: test_get; 61 | "list_tuple_save_get" >:: test_save_get; 62 | ] 63 | -------------------------------------------------------------------------------- /lib_test/nested_option.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type x = { 4 | foo: int option option; 5 | bar: string option option option 6 | } with orm 7 | 8 | open OUnit 9 | open Test_utils 10 | 11 | let x = { foo=(Some (Some 1)); bar=(Some (Some (Some "hello world"))) } 12 | let name = "nested_option.db" 13 | 14 | let test_init () = 15 | ignore(open_db x_init name); 16 | ignore(open_db ~rm:false x_init name); 17 | ignore(open_db ~rm:false x_init name) 18 | 19 | let test_save () = 20 | let db = open_db x_init name in 21 | x_save db x 22 | 23 | let test_update () = 24 | let db = open_db x_init name in 25 | x_save db x; 26 | x_save db x 27 | 28 | let test_get () = 29 | let db = open_db ~rm:false x_init name in 30 | let i = x_get db in 31 | "1 in db" @? (List.length i = 1); 32 | let i = List.hd i in 33 | "values match" @? (i = x) 34 | 35 | let test_save_get () = 36 | let db = open_db x_init name in 37 | x_save db x; 38 | let i = x_get db in 39 | "1 in db" @? (List.length i = 1); 40 | let i = List.hd i in 41 | "structural values equal" @? ( x = i); 42 | "physical values equal" @? ( x == i) 43 | 44 | let suite = [ 45 | "nested_option_init" >:: test_init; 46 | "nested_option_save" >:: test_save; 47 | "nested_option_update" >:: test_update; 48 | "nested_option_update" >:: test_update; 49 | "nested_option_get" >:: test_get; 50 | "nested_option_save_get" >:: test_save_get; 51 | ] 52 | -------------------------------------------------------------------------------- /lib_test/nested_tuple.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type x = { 4 | foo: (int32 * int64 * string * (string * bool option)); 5 | bar: string * char; 6 | } with orm 7 | 8 | open OUnit 9 | open Test_utils 10 | 11 | let x = {foo=(5l, 10L, "tt", ("xx", Some true)) ; bar=("hello",'w') } 12 | let name = "nested_tuple.db" 13 | 14 | let test_init () = 15 | ignore(open_db x_init name); 16 | ignore(open_db ~rm:false x_init name); 17 | ignore(open_db ~rm:false x_init name) 18 | 19 | let test_save () = 20 | let db = open_db x_init name in 21 | x_save db x 22 | 23 | let test_update () = 24 | let db = open_db x_init name in 25 | x_save db x; 26 | x_save db x 27 | 28 | let test_get () = 29 | let db = open_db ~rm:false x_init name in 30 | let i = x_get db in 31 | "1 in db" @? (List.length i = 1); 32 | let i = List.hd i in 33 | "values match" @? (i = x) 34 | 35 | let test_save_get () = 36 | let db = open_db x_init name in 37 | x_save db x; 38 | let i = x_get db in 39 | "1 in db" @? (List.length i = 1); 40 | let i = List.hd i in 41 | "structural values equal" @? ( x = i); 42 | "physical values equal" @? ( x == i) 43 | 44 | let suite = [ 45 | "nested_tuple_init" >:: test_init; 46 | "nested_tuple_save" >:: test_save; 47 | "nested_tuple_update" >:: test_update; 48 | "nested_tuple_get" >:: test_get; 49 | "nested_tuple_save_get" >:: test_save_get; 50 | ] 51 | -------------------------------------------------------------------------------- /lib_test/object_simple.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | open Printf 4 | 5 | type x = < 6 | foo: int; 7 | bar: string 8 | > with 9 | orm() 10 | 11 | open OUnit 12 | open Test_utils 13 | 14 | let name = "object_simple.db" 15 | 16 | let r = Random.int 100 17 | let x b = object 18 | method foo = r 19 | method bar="hello "^b 20 | end 21 | 22 | let x1 = x "world" 23 | let x2 = x "sky" 24 | 25 | let test_init () = 26 | ignore(open_db x_init name); 27 | ignore(open_db ~rm:false x_init name); 28 | ignore(open_db ~rm:false x_init name) 29 | 30 | let test_id () = 31 | let db = open_db x_init name in 32 | x_save db x1; 33 | let i = x_id db x1 in 34 | "id is 1" @? (ORMID_x.to_int64 i = 1L); 35 | assert_raises ~msg:"test_id_not_found" Not_found 36 | (fun () -> x_id db x2) 37 | 38 | let test_save () = 39 | let db = open_db x_init name in 40 | let _ = open_db ~rm:false x_init_read_only name in 41 | x_save db x1; 42 | x_save db x2 43 | 44 | let test_update () = 45 | let db = open_db x_init name in 46 | x_save db x1; 47 | x_save db x1 48 | 49 | let test_get () = 50 | let db = open_db ~rm:false x_init name in 51 | let i = x_get db in 52 | "1 in db" @? (List.length i = 1); 53 | let i = List.hd i in 54 | "values match" @? (i#foo = x1#foo && (i#bar = x1#bar)) 55 | 56 | let suite = [ 57 | "object_simple_init" >:: test_init; 58 | "object_simple_id" >:: test_id; 59 | "object_simple_save" >:: test_save; 60 | "object_simple_update" >:: test_update; 61 | "object_simple_get" >:: test_get; 62 | ] 63 | -------------------------------------------------------------------------------- /lib_test/option_rec.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | open OUnit 4 | open Test_utils 5 | 6 | type page = { 7 | parent : page option; (* the optional parent, None -> root page *) 8 | title : string; 9 | } with orm 10 | 11 | let rec p1 = { 12 | parent = None; 13 | title = "root page"; 14 | } 15 | and p2 = { 16 | parent = Some p1; 17 | title = "child page"; 18 | } 19 | and p3 = { 20 | parent = Some p1; 21 | title = "child page 2"; 22 | };; 23 | 24 | let db_name = "option_rec.db" 25 | 26 | let save () = 27 | let db = open_db page_init db_name in 28 | page_save db p1; 29 | page_save db p2; 30 | page_save db p3 31 | 32 | let get () = 33 | let db = page_init db_name in 34 | let pages = page_get db in () 35 | 36 | let suite = [ 37 | "save" >:: save; 38 | "get" >:: get; 39 | ] 40 | -------------------------------------------------------------------------------- /lib_test/photo.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | open Printf 4 | 5 | type exif_val = 6 | Exif_string of string 7 | | Exif_int of int64 8 | | Exif_float of float 9 | and 10 | photo = { 11 | filename: string; 12 | metadata: (string * exif_val) list; 13 | } with orm 14 | 15 | open OUnit 16 | open Test_utils 17 | 18 | type image = string (* filename *) 19 | (* XXX TODO: be able to wrap image in a module *) 20 | 21 | let type_of_image = type_of_photo 22 | 23 | (* marshalling to the database from a image *) 24 | let value_of_image ~id_seed (img:image) : Dyntype.Value.t = 25 | (* printf "reading exif data from file: %s\n%!" img; *) 26 | let exif = [ "date", (Exif_string ("today " ^ img)) ] in 27 | let filename = img ^ ".jpg" in 28 | value_of_photo ~id_seed { filename=filename; metadata=exif } 29 | 30 | (* marshalling from the database into an image type *) 31 | let image_of_value (v:Dyntype.Value.t) : image = 32 | let p = photo_of_value v in 33 | (* printf "retrieving file from database: %s\n%!" p.filename; *) 34 | p.filename 35 | 36 | let hash_of_image = Hashtbl.hash 37 | 38 | type gallery = { 39 | date: float; 40 | contents: image list 41 | } with orm 42 | 43 | let name = "photo.db" 44 | 45 | let test_init () = 46 | ignore(open_db gallery_init name); 47 | ignore(open_db ~rm:false gallery_init name) 48 | 49 | let test_gallery () = 50 | let files = [ "p1"; "p2"; "p3" ] in 51 | let g = { date= 12345.0 ; contents = files } in 52 | let db = open_db gallery_init name in 53 | gallery_save db g; 54 | gallery_save db g; 55 | "list eq 3" @? (List.length (List.hd (gallery_get db)).contents = 3) 56 | 57 | let suite = [ 58 | "photo_init" >:: test_init; 59 | "photo_save" >:: test_gallery; 60 | ] 61 | -------------------------------------------------------------------------------- /lib_test/record_mutate.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type x = { 4 | mutable foo: string; 5 | mutable bar: string option 6 | } with orm 7 | 8 | open Test_utils 9 | open OUnit 10 | 11 | module H = Hashtbl.Make ( 12 | struct 13 | type t = x 14 | let equal = (==) 15 | let compare = (==) 16 | let hash _ = 0 17 | end ) 18 | 19 | let name = "record_mutate.db" 20 | 21 | let test_mutate_nodb () = 22 | let t1 = { foo="foo"; bar=None } in 23 | let r = ref t1 in 24 | "phys eq" @? (!r == t1); 25 | t1.bar <- Some "bar"; 26 | "phys eq after mutate" @? (!r == t1) 27 | 28 | let test_mutate_nodb_hash () = 29 | let t1 = { foo="foo"; bar=None } in 30 | let h = H.create 1 in 31 | for i = 0 to 10000; do 32 | H.add h { foo=(Printf.sprintf "foo%d" i); bar=None } (Random.int64 1000L) 33 | done; 34 | H.add h t1 1L; 35 | "in hash1" @? (H.find h t1 = 1L); 36 | t1.bar <- Some "bar"; 37 | "in hash2" @? (H.find h t1 = 1L) 38 | 39 | let test_mutate_basic () = 40 | let db = open_db x_init name in 41 | let t1 = { foo="foo"; bar=None } in 42 | x_save db t1; 43 | t1.foo <- "foo2"; 44 | x_save db t1 45 | 46 | (* same as previous, but changes bar *) 47 | let test_mutate_option () = 48 | let db = open_db x_init name in 49 | let t1 = { foo="foo"; bar=None } in 50 | x_save db t1; 51 | t1.bar <- Some "bar"; 52 | x_save db t1 53 | 54 | let suite = [ 55 | "record_mutate_nodb" >:: test_mutate_nodb; 56 | "record_mutate_nodb_hash" >:: test_mutate_nodb_hash; 57 | "record_mutate_basic" >:: test_mutate_basic; 58 | "record_mutate_option" >:: test_mutate_option; 59 | ] 60 | -------------------------------------------------------------------------------- /lib_test/recursive.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type y = char with orm 4 | 5 | type t = { 6 | t1: string; 7 | t2: x option 8 | } and x = { 9 | x1: t option; 10 | x2: y 11 | } with orm 12 | 13 | type z = t with orm 14 | 15 | type a = { a : y } with orm 16 | 17 | open Test_utils 18 | open OUnit 19 | 20 | let name = "recursive.db" 21 | 22 | let vy = 'a' 23 | let rec vt = { t1= "hello"; t2=(Some vx) } 24 | and vx = { x1=(Some vt); x2=vy } 25 | let vz = vt 26 | let va = { a = vy } 27 | 28 | let test_init () = 29 | ignore(open_db t_init name); 30 | ignore(open_db ~rm:false x_init name); 31 | ignore(open_db ~rm:false x_init name) 32 | 33 | let test_save () = 34 | let db = open_db x_init name in 35 | x_save db vx 36 | 37 | let test_update () = 38 | let dbx = open_db x_init name in 39 | let dbt = open_db ~rm:false t_init name in 40 | x_save dbx vx; 41 | t_save dbt vt; 42 | x_save dbx vx; 43 | t_save dbt vt 44 | 45 | let test_get () = 46 | let db = open_db ~rm:false x_init name in 47 | let i = x_get db in 48 | "1 in db" @? (List.length i = 1); 49 | let i = List.hd i in 50 | "values match" @? (i.x2 = vx.x2) 51 | 52 | let test_save_get () = 53 | let db = open_db x_init name in 54 | x_save db vx; 55 | let i = x_get db in 56 | "1 in db" @? (List.length i = 1); 57 | let i = List.hd i in 58 | "physical values equal" @? ( vx == i) 59 | 60 | (* We have: vz => vt <=> vx => vy <= va *) 61 | (* Deletion should be possible if no reference exists to the recursive cycle *) 62 | (* the value belongs to. *) 63 | (* For instance, deleting vx while vz is still in the database should not be *) 64 | (* possible. However, deleting vz should delete vt and vx as well, but let vy *) 65 | (* is in the dabatase as va is referencing it. *) 66 | let test_delete () = 67 | let dbz = open_db z_init name in 68 | let dbt = open_db ~rm:false t_init name in 69 | let dbx = open_db ~rm:false x_init name in 70 | let dby = open_db ~rm:false y_init name in 71 | let dba = open_db ~rm:false a_init name in 72 | 73 | let check n (z, t, x, y, a) = 74 | (Printf.sprintf "%d: %d z in db" n z) @? (List.length (z_get dbz) = z); 75 | (Printf.sprintf "%d: %d t in db" n t) @? (List.length (t_get dbt) = t); 76 | (Printf.sprintf "%d: %d x in db" n x) @? (List.length (x_get dbx) = x); 77 | (Printf.sprintf "%d: %d y in db" n y) @? (List.length (y_get dby) = y); 78 | (Printf.sprintf "%d: %d a in db" n a) @? (List.length (a_get dba) = a) in 79 | 80 | z_save dbz vz; 81 | a_save dba va; 82 | 83 | (* 0. basic sanity checks before doing the delete test *) 84 | check 0 (1, 1, 1, 1, 1); 85 | 86 | (* 1. deleting vx should not be possible *) 87 | x_delete dbx vx; 88 | check 1 (1, 1, 1, 1, 1); 89 | 90 | (* 2. deleting vz should delete vt and vx as well and let vy in the database *) 91 | z_delete dbz vz; 92 | check 2 (0, 0, 0, 1, 1); 93 | 94 | z_save dbz vz; 95 | check 3 (1, 1, 1, 1, 1); 96 | 97 | (* 3. after deleting va and the vz, all the values should be deleted *) 98 | a_delete dba va; 99 | check 4 (1, 1, 1, 1, 0); 100 | z_delete dbz vz; 101 | check 5 (0, 0, 0, 0, 0) 102 | 103 | let suite = [ 104 | "recursive_init" >:: test_init; 105 | "recursive_save" >:: test_save; 106 | "recursive_update" >:: test_update; 107 | "recursive_get" >:: test_get; 108 | "recursive_save_get" >:: test_save_get; 109 | "recursive_delete" >:: test_delete; 110 | ] 111 | -------------------------------------------------------------------------------- /lib_test/recursive_mutate.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type t = { 4 | t1: string; 5 | t2: x option; 6 | mutable t3: char; 7 | } 8 | and x = { 9 | x1: t option; 10 | mutable x2: char; 11 | x3: int64 12 | } 13 | with orm 14 | 15 | open Test_utils 16 | open OUnit 17 | 18 | 19 | let rec x_equal ~depth u v = 20 | depth = 0 || 21 | (match u.x1, v.x1 with 22 | | None, None -> true 23 | | Some t1, Some t2 -> t_equal ~depth:(depth-1) t1 t2 24 | | _ -> false) 25 | && u.x2 = v.x2 26 | && u.x3 = v.x3 27 | 28 | and t_equal ~depth u v = 29 | depth = 0 || 30 | u.t1 = v.t1 31 | && (match u.t2, v.t2 with 32 | | None, None -> true 33 | | Some x1, Some x2 -> x_equal ~depth:(depth-1) x1 x2 34 | | _ -> false) 35 | && u.t3 = v.t3 36 | 37 | let name = "recursive_mutate.db" 38 | 39 | let rec vt = { t1= "hello"; t2=(Some vx); t3='z' } 40 | and vx = { x1=(Some vt); x2='z'; x3=1L } 41 | 42 | let test_init () = 43 | ignore(open_db x_init name); 44 | ignore(open_db ~rm:false t_init name); 45 | ignore(open_db ~rm:false x_init name) 46 | 47 | let test_save () = 48 | let db = open_db x_init name in 49 | x_save db vx 50 | 51 | let test_update () = 52 | let dbt = open_db t_init name in 53 | let dbx = open_db ~rm:false x_init name in 54 | x_save dbx vx; 55 | t_save dbt vt; 56 | x_save dbx vx; 57 | t_save dbt vt 58 | 59 | let test_get () = 60 | let db = open_db ~rm:false x_init name in 61 | let i = x_get db in 62 | "1 in db" @? (List.length i = 1); 63 | let i = List.hd i in 64 | "values match" @? (i.x2 = vx.x2) 65 | 66 | let test_save_get () = 67 | let db = open_db x_init name in 68 | x_save db vx; 69 | let i = x_get db in 70 | "1 in db" @? (List.length i = 1); 71 | let i = List.hd i in 72 | "values equal" @? ( x_equal ~depth:10 vx i) 73 | 74 | let test_delete () = 75 | let db = open_db x_init name in 76 | let dbt = open_db ~rm:false t_init_read_only name in 77 | x_save db vx; 78 | "1 x in db" @? (List.length (x_get db) = 1); 79 | "1 s in db" @? (List.length (t_get dbt) = 1); 80 | x_delete db vx; 81 | "0 x in db" @? (List.length (x_get db) = 0); 82 | "0 s in db" @? (List.length (t_get dbt) = 0) 83 | 84 | let suite = [ 85 | "recursive_mutate_init" >:: test_init; 86 | "recursive_mutate_save" >:: test_save; 87 | "recursive_mutate_update" >:: test_update; 88 | "recursive_mutate_get" >:: test_get; 89 | "recursive_mutate_save_get" >:: test_save_get; 90 | "recursive_mutate_delete" >:: test_delete; 91 | ] 92 | -------------------------------------------------------------------------------- /lib_test/simple.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | open Printf 4 | 5 | type x = { 6 | foo: int; 7 | bar: string 8 | } with 9 | orm 10 | 11 | open OUnit 12 | open Test_utils 13 | 14 | let name = "simple.db" 15 | 16 | let x = { foo = (Random.int 100); bar="hello world" } 17 | let x2 = { foo = (Random.int 100); bar="bye world" } 18 | 19 | let test_init () = 20 | ignore(open_db x_init name); 21 | ignore(open_db ~rm:false x_init name); 22 | ignore(open_db ~rm:false x_init name) 23 | 24 | let test_order () = 25 | let db = open_db x_init name in 26 | x_save db x; 27 | x_save db x2; 28 | match x_get ~order_by:`foo db with 29 | | [y1; y2] -> "query is ordered" @? (y1.foo <= y2.foo) 30 | | _ -> "get error" @? false 31 | 32 | let test_id () = 33 | let db = open_db x_init name in 34 | x_save db x; 35 | let i = x_id db x in 36 | "id is 1" @? (ORMID_x.to_int64 i = 1L); 37 | let x' = x_get_by_id (`Eq i) db in 38 | "bar eq" @? (x'.bar = x.bar); 39 | let x2 = { foo=100; bar="x2222" } in 40 | assert_raises ~msg:"test_id_not_found" Not_found (fun () -> x_id db x2); 41 | assert_raises ~msg:"test_id_not_found2" Not_found (fun () -> x_get_by_id ~id:(`Eq (ORMID_x.of_int64 5L)) db) 42 | 43 | let test_save () = 44 | let db = open_db x_init name in 45 | let _ = open_db ~rm:false x_init_read_only name in 46 | x_save db x; 47 | x_save db x 48 | 49 | let test_update () = 50 | let db = open_db x_init name in 51 | x_save db x; 52 | x_save db x 53 | 54 | let test_subtype () = 55 | let module A = struct 56 | type x = { 57 | foo: int64; 58 | } with orm 59 | end in 60 | let db = open_db ~rm:false A.x_init_read_only name in 61 | let i = A.x_get ~foo:(`Eq (Int64.of_int x.foo)) db in 62 | "2 in db" @? (List.length i = 1); 63 | let i = List.hd i in 64 | "values match" @? (i.A.foo = Int64.of_int x.foo) 65 | 66 | let test_get () = 67 | let db = open_db x_init name in 68 | x_save db x; 69 | x_save db x2; 70 | let i = x_get ~bar:(`Eq "hello world") db in 71 | "1 in db" @? (List.length i = 1); 72 | let i = List.hd i in 73 | "values match" @? (i.foo = x.foo && (i.bar = x.bar)) 74 | 75 | let test_contains_get () = 76 | let db = open_db x_init name in 77 | x_save db x; 78 | x_save db x2; 79 | let i = x_get ~bar:(`Contains "hello") db in 80 | "1 in db" @? (List.length i = 1); 81 | let i = List.hd i in 82 | "values match" @? (i.foo = x.foo && (i.bar = x.bar)) 83 | 84 | let test_custom_get () = 85 | let db = open_db x_init name in 86 | x_save db x; 87 | x_save db x2; 88 | let nb = ref 0 in 89 | let subs = ref [] in 90 | let i = x_get ~custom:(fun x -> let s = String.sub x.bar 3 2 in subs := s :: !subs; if s="lo" then (incr nb; true) else false) db in 91 | (Printf.sprintf "1 in db (nb=%d, subs={%s})" !nb (String.concat ", " !subs)) @? (List.length i = 1) 92 | 93 | let test_save_get () = 94 | let db = open_db x_init name in 95 | x_save db x; 96 | let i = x_get db in 97 | "1 in db" @? (List.length i = 1); 98 | let i = List.hd i in 99 | "structurally equal after get" @? ( x == i) 100 | 101 | let test_delete () = 102 | let db = open_db ~rm:false x_init name in 103 | let x1 = match x_get db with [x] -> x |_ -> assert false in 104 | let x2 = { foo = (Random.int 100); bar="x2" } in 105 | let x3 = { foo = (Random.int 100); bar="x3" } in 106 | "1 in db" @? (List.length (x_get db) = 1); 107 | x_delete db x1; 108 | "0 in db" @? (List.length (x_get db) = 0); 109 | x_save db x1; 110 | x_save db x2; 111 | x_save db x3; 112 | "3 in db" @? (List.length (x_get db) = 3); 113 | x_delete db x2; 114 | "2 in db" @? (List.length (x_get db) = 2); 115 | match x_get db with 116 | [a1;a3] -> "equal" @? (a3=x3 && a1=x1) 117 | |_ -> assert false 118 | 119 | let test_lazy_get () = 120 | let db = open_db x_init name in 121 | x_save db x; 122 | x_save db x2; 123 | let next = x_lazy_get db in 124 | (match next () with 125 | | Some a1 -> "1 in db" @? (x.bar = a1.bar) 126 | | _ -> "1 in db" @? false); 127 | (match next () with 128 | | Some a2 -> "2 in db" @? (x2.bar = a2.bar) 129 | | _ -> "2 in db" @? false); 130 | (match next () with 131 | | None -> "nothing in db" @? true 132 | | _ -> "nothing in db" @? false); 133 | (match next () with 134 | | None -> "really nothing in db" @? true 135 | | _ -> "really nothing in db" @? false) 136 | 137 | let suite = [ 138 | "simple_order" >:: test_order; 139 | "simple_init" >:: test_init; 140 | "simple_id" >:: test_id; 141 | "simple_save" >:: test_save; 142 | "simple_update" >:: test_update; 143 | "simple_get" >:: test_get; 144 | "simple_contains_get" >:: test_contains_get; 145 | "simple_lazy_get" >:: test_lazy_get; 146 | "simple_custom_get" >:: test_custom_get; 147 | "simple_subtype" >:: test_subtype; 148 | "simple_save_get" >:: test_save_get; 149 | "simple_delete" >:: test_delete; 150 | ] 151 | -------------------------------------------------------------------------------- /lib_test/stress.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type t = { a : int; b : int } with orm 4 | 5 | open OUnit 6 | open Printf 7 | open Test_utils 8 | 9 | let time = Unix.gettimeofday 10 | 11 | let name = "stress.db" 12 | 13 | let time_of fn = 14 | let t1 = time () in 15 | let r = fn () in 16 | let t2 = time () in 17 | t2 -. t1, r 18 | 19 | let test_bench name () = 20 | let db = open_db t_init name in 21 | let t0 = time () in 22 | for i=0 to 4000 do 23 | let x = { a=Random.int 10; b=i } in 24 | t_save db x; 25 | if i mod 4000 = 0 then Printf.printf "Saved %i records in %.2fs\n%!" i ((time ()) -. t0); 26 | done; 27 | let t,all = time_of (fun () -> t_get db) in (* get all the elements in the database *) 28 | printf "timing %s (total: %i elements): %!" name (List.length all); 29 | printf "full_get: %f %!" t; 30 | (* 31 | let t1 = time () in 32 | let l1 = t_get ~a:(`Eq 5) db in 33 | let t2 = time () in 34 | let l2 = t_get ~fn:(fun t -> t#a = 5) db in 35 | let t3 = time () in 36 | Printf.printf "get_where: %.4f (filtered: %i elements); get_custom: %.4f (filtered: %i elements)\n%!" 37 | (t2 -. t1) (List.length l1) (t3 -. t2) (List.length l2) 38 | *) 39 | printf "\n%!" 40 | 41 | (* One result with big tables: 42 | 43 | timing (total: 229733 elements): 44 | get_where: 0.1541 (filtered: 23157 elements); 45 | get_custom: 0.6346 (filtered: 23157 elements) 46 | 47 | *) 48 | 49 | let test_cache () = 50 | let db = open_db t_init name in 51 | for i = 0 to 1000 do 52 | let x = { a=Random.int 10; b=i } in 53 | t_save db x; 54 | if i mod 1000 = 0 then Printf.printf ".%!" 55 | done; 56 | for i = 0 to 10 do 57 | List.iter (fun x -> ignore(t_id db x)) (t_get db) 58 | done 59 | 60 | let suite = [ 61 | "stress_bench" >:: test_bench "stress"; 62 | "stress_memory_bench" >:: test_bench ":memory:"; 63 | "stress_cache" >:: test_cache; 64 | ] 65 | -------------------------------------------------------------------------------- /lib_test/stress_mutate.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type t = { a : int; mutable b : int } with orm 4 | 5 | open OUnit 6 | open Printf 7 | open Test_utils 8 | 9 | let name = "stress_mutate.db" 10 | 11 | let test_mutate () = 12 | let db = t_init name in 13 | let t1 = { a=1; b=0 } in 14 | for i= 0 to 4000 do 15 | t1.b <- i; 16 | t_save db t1; 17 | done 18 | 19 | let suite = [ 20 | "stress_mutate" >:: test_mutate; 21 | ] 22 | -------------------------------------------------------------------------------- /lib_test/suite.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | open Printf 3 | 4 | let suites = [ 5 | Simple.suite; 6 | Object_simple.suite; 7 | Tuple.suite; 8 | Variant.suite; 9 | Variant_nested.suite; 10 | Alltypes.suite; 11 | Foreign.suite; 12 | Recursive.suite; 13 | Array_simple.suite; 14 | Foreign_and_variant.suite; 15 | Foreign_tuple.suite; 16 | List_simple.suite; 17 | List_foreign.suite; 18 | List_tuple.suite; 19 | List_list.suite; 20 | List_share.suite; 21 | Nested_tuple.suite; 22 | Nested_option.suite; 23 | Record_mutate.suite; 24 | List_mutate.suite; 25 | Big_list.suite; 26 | Recursive_mutate.suite; 27 | Photo.suite; 28 | Bibtex.suite; 29 | Bib.suite; 30 | Delete.suite; 31 | Option_rec.suite; 32 | ] 33 | 34 | let slow_suites = [ 35 | Large_string.suite; 36 | Stress_mutate.suite; 37 | Stress.suite; 38 | Hash.suite; 39 | ] 40 | 41 | let _ = 42 | let s = try 43 | if Sys.getenv "SLOW" <> "" then 44 | slow_suites 45 | else suites 46 | with Not_found -> suites in 47 | run_test_tt_main ("ORM" >::: (List.flatten s)) 48 | -------------------------------------------------------------------------------- /lib_test/test_utils.ml: -------------------------------------------------------------------------------- 1 | let open_db ?(rm=true) fn name = 2 | if Sys.file_exists name && rm then Sys.remove name; 3 | try fn name 4 | with exn -> Printexc.print_backtrace stdout; raise exn 5 | -------------------------------------------------------------------------------- /lib_test/tuple.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type x = { 4 | foo: int32; 5 | bar: string * char 6 | } with orm 7 | 8 | open OUnit 9 | open Test_utils 10 | 11 | let name = "tuple.db" 12 | let x = { foo = 1000l ; bar = ("hello",'w') } 13 | 14 | let test_init () = 15 | ignore(open_db x_init name); 16 | ignore(open_db ~rm:false x_init name); 17 | ignore(open_db ~rm:false x_init name) 18 | 19 | let test_save () = 20 | let db = open_db x_init name in 21 | x_save db x 22 | 23 | let test_update () = 24 | let db = open_db x_init name in 25 | x_save db x; 26 | x_save db x 27 | 28 | let test_get () = 29 | let db = open_db ~rm:false x_init name in 30 | let i = x_get db in 31 | "1 in db" @? (List.length i = 1); 32 | let i = List.hd i in 33 | "values match" @? (i.foo = x.foo && (i.bar = x.bar)) 34 | 35 | let test_save_get () = 36 | let db = open_db x_init name in 37 | x_save db x; 38 | let i = x_get db in 39 | "1 in db" @? (List.length i = 1); 40 | let i = List.hd i in 41 | "structural values equal" @? ( x = i); 42 | "physical values equal" @? ( x == i) 43 | 44 | let suite = [ 45 | "tuple_init" >:: test_init; 46 | "tuple_save" >:: test_save; 47 | "tuple_update" >:: test_update; 48 | "tuple_update" >:: test_update; 49 | "tuple_get" >:: test_get; 50 | "tuple_save_get" >:: test_save_get; 51 | ] 52 | -------------------------------------------------------------------------------- /lib_test/variant.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type s = 4 | |Foo 5 | |Bar of int 6 | |Xyz of string 7 | |Blah of (int * char) 8 | and x = { 9 | foo: s; 10 | bar: s; 11 | } with orm 12 | 13 | open OUnit 14 | open Test_utils 15 | 16 | let string_of_s = function 17 | |Foo -> "Foo" 18 | |Bar i -> "Bar " ^ (string_of_int i) 19 | |Xyz z -> "Xyz " ^ z 20 | |_ -> "??" 21 | 22 | let name = "variant.db" 23 | 24 | let x1 = { foo=Foo; bar=(Bar 1) } 25 | let x2 = { foo=(Xyz "hello"); bar=Foo } 26 | 27 | let test_init () = 28 | ignore(open_db s_init name); 29 | ignore(open_db ~rm:false x_init name); 30 | ignore(open_db ~rm:false x_init name) 31 | 32 | let test_save () = 33 | let db = open_db x_init name in 34 | x_save db x1; 35 | x_save db x2 36 | 37 | let test_update () = 38 | let db = open_db x_init name in 39 | x_save db x1; 40 | x_save db x2; 41 | x_save db x1; 42 | x_save db x2 43 | 44 | let test_get () = 45 | let db = open_db ~rm:false x_init name in 46 | let i = x_get db in 47 | "2 in db" @? (List.length i = 2); 48 | match i with 49 | | [a1;a2] -> 50 | "x1 values match" @? (a1.foo = x1.foo && (a1.bar = x1.bar)); 51 | "x2 values match" @? (a2.foo = x2.foo && (a2.bar = x2.bar)) 52 | | _ -> assert false 53 | 54 | let test_save_get () = 55 | let db = open_db x_init name in 56 | x_save db x1; 57 | match x_get db with 58 | [i] -> "structurally equal after get" @? ( x1 == i) 59 | |_ -> assert false 60 | 61 | let suite = [ 62 | "variant_init" >:: test_init; 63 | "variant_save" >:: test_save; 64 | "variant_update" >:: test_update; 65 | "variant_update" >:: test_update; 66 | "variant_get" >:: test_get; 67 | "variant_save_get" >:: test_save_get; 68 | ] 69 | -------------------------------------------------------------------------------- /lib_test/variant_nested.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4orf *) 2 | 3 | type n = 4 | | Non of int64 5 | | NTwo 6 | | Nthree of string 7 | | Nfour of x 8 | and x = 9 | | XONE 10 | | Xtwo of n 11 | | Xthree of int 12 | and t = { 13 | foo: x; 14 | bar: n; 15 | xyz: char; 16 | } with orm 17 | 18 | open OUnit 19 | open Test_utils 20 | 21 | let t1 = {foo = XONE; bar = Nfour (Xthree 34); xyz = 'a' } 22 | let t2 = {foo = Xtwo (Nfour XONE) ; bar = Nfour (Xthree 12) ;xyz = 'b' } 23 | let t3 = {foo = Xtwo (Nfour (Xthree 32)) ; bar = Nfour XONE ; xyz = 'X' } 24 | 25 | let name = "variant_nested.db" 26 | 27 | let test_save () = 28 | let db = open_db t_init name in 29 | t_save db t1; 30 | t_save db t2; 31 | t_save db t3 32 | 33 | let test_subtype () = 34 | let module A = struct 35 | type n = 36 | | Non of int64 37 | | NTwo 38 | | Nthree of string 39 | | Nfour of x 40 | and x = 41 | | XONE 42 | | Xtwo of n 43 | | Xthree of int64 44 | and t = { 45 | bar: n; 46 | xyz: int64; 47 | } with orm 48 | end in 49 | let db = open_db ~rm:false A.t_init_read_only name in 50 | let ts = A.t_get db in 51 | "3 in db" @? (List.length ts = 3); 52 | let t = List.hd (List.filter (fun t -> t.A.bar = A.Nfour A.XONE) ts) in 53 | "value match" @? (t.A.xyz = 88L) 54 | 55 | let suite = [ 56 | "variant_nested_save" >:: test_save; 57 | "variant_nested_subtype" >:: test_subtype 58 | ] 59 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "anil@recoil.org" 3 | authors: ["Anil Madhavapeddy" "Thomas Gazagnaire"] 4 | homepage: "https://github.com/mirage/orm" 5 | bug-reports: "https://github.com/mirage/orm/issues" 6 | dev-repo: "https://github.com/mirage/orm.git" 7 | tags: "org:mirage" 8 | 9 | build: [make] 10 | build-test: [make "test"] 11 | install: [make "install"] 12 | remove: ["ocamlfind" "remove" "orm"] 13 | 14 | depends: [ 15 | "ocamlfind" {build} 16 | "ocamlbuild" {build} 17 | "sqlite3" 18 | "dyntype" {>= "0.9.0"} 19 | "ounit" {test} 20 | ] 21 | -------------------------------------------------------------------------------- /orm.godiva: -------------------------------------------------------------------------------- 1 | Package: godi-orm 2 | Version: 0.5.1 3 | Revision: 0 4 | Depends: godi-ocaml (>= 3.11), godi-dyntype (>= 0.7), godi-sqlite3 (>= 1.5.7), godi-type-conv (>= 1.6.10) 5 | Build-Depends: godi-findlib (>= 1.2.5) 6 | Sources: http://download.github.com/mirage-orm-3c0a0e5.tar.gz 7 | Homepage: http://github.com/mirage/orm 8 | Maintainer: Thomas Gazagnaire 9 | Docfiles: README.md, LICENSE 10 | Description: Object Relational Mapper extension 11 | . 12 | --------------------------------------------------------------------------------