Skip to content
Browse files

[enhance] compiler, dbgen, mongo: Handle query options on mongo acces…

…s generation
  • Loading branch information...
1 parent 71e1ad4 commit e59cccd7a791cbe80d434d2a000ab2d53a65928a @BourgerieQuentin BourgerieQuentin committed
Showing with 75 additions and 36 deletions.
  1. +59 −20 opa/pass_MongoAccessGeneration.ml
  2. +16 −16 stdlib/database/mongo/db.opa
View
79 opa/pass_MongoAccessGeneration.ml
@@ -121,10 +121,11 @@ module Generator = struct
| DbAst.QNot (DbAst.QAnd (q1, q2)) ->
DbAst.QOr (prepare_query (DbAst.QNot q1), prepare_query (DbAst.QNot q2))
+ let empty_query gamma annotmap = C.list (annotmap, gamma) []
+
let query_to_expr gamma annotmap query =
- let empty_query annotmap = C.list (annotmap, gamma) [] in
match query with
- | None -> empty_query annotmap
+ | None -> empty_query gamma annotmap
| Some (_todo, query) ->
let query = prepare_query query in
let rec aux annotmap query =
@@ -144,7 +145,7 @@ module Generator = struct
| DbAst.QIn _ -> "$in"
| _ -> assert false
in
- let annotmap, query = empty_query annotmap in
+ let annotmap, query = empty_query gamma annotmap in
add_to_document gamma annotmap name e query
| DbAst.QFlds flds ->
List.fold_left
@@ -156,11 +157,11 @@ module Generator = struct
let annotmap, query = aux annotmap query in
add_to_document gamma annotmap name query acc
)
- (empty_query annotmap)
+ (empty_query gamma annotmap)
flds
| DbAst.QNot query ->
let annotmap, query = aux annotmap query in
- let annotmap, empty = empty_query annotmap in
+ let annotmap, empty = empty_query gamma annotmap in
add_to_document gamma annotmap "$not" query empty
| DbAst.QAnd (q1, q2)
| DbAst.QOr (q1, q2) ->
@@ -176,10 +177,35 @@ module Generator = struct
QmlAnnotMap.find_ty (Annot.annot (QmlAst.Label.expr q1)) annotmap
in
let annotmap, query = C.list ~ty (annotmap, gamma) [q1; q2] in
- let annotmap, empty = empty_query annotmap in
+ let annotmap, empty = empty_query gamma annotmap in
add_to_document gamma annotmap name query empty
in aux annotmap query
+ let query_add_order gamma annotmap order query =
+ match order with
+ | None -> annotmap, query
+ | Some order ->
+ let annotmap, eorder =
+ List.fold_left
+ (fun (annotmap, acc) (fld, expr) ->
+ let name = BaseFormat.sprintf "%a" QmlAst.Db.pp_field fld in
+ let annotmap, expr =
+ let annotmap, up = C.int annotmap 1 in
+ let annotmap, pup =
+ let annotmap, any = QmlAstCons.TypedPat.any annotmap in
+ QmlAstCons.TypedPat.record annotmap ["up", any] in
+ let annotmap, down = C.int annotmap (-1) in
+ let annotmap, pdown =
+ let annotmap, any = QmlAstCons.TypedPat.any annotmap in
+ QmlAstCons.TypedPat.record annotmap ["down", any] in
+ C.match_ annotmap expr [(pup, up); (pdown, down)]
+ in add_to_document gamma annotmap name expr acc)
+ (empty_query gamma annotmap) order
+ in
+ let annotmap, metaquery = empty_query gamma annotmap in
+ let annotmap, metaquery = add_to_document gamma annotmap "$query" query metaquery in
+ add_to_document gamma annotmap "$orderby" eorder metaquery
+
let update_to_expr ?(set=true) gamma annotmap = function
| DbAst.UExpr e ->
let annotmap, uexpr = opa2doc gamma annotmap e () in
@@ -427,16 +453,28 @@ module Generator = struct
| _ -> ()
in
let ty = node.DbSchema.ty in
- let uniq, nb, query =
+ let annotmap, skip, limit, query, order, uniq =
match query0 with
- | None -> false, 0, None
- | Some ((uniq, (query, _opt)) as _x) ->
- uniq,
- (if uniq then 1 else 5000),
- Some (
+ | None ->
+ let annotmap, limit = C.int annotmap 1 in
+ let annotmap, skip = C.int annotmap 0 in
+ annotmap, skip, limit, None, None, false
+ | Some ((uniq, (query, opt)) as _x) ->
+ let annotmap, limit =
+ match opt.DbAst.limit with
+ | None -> C.int annotmap 0
+ | Some i -> annotmap, i
+ in let annotmap, skip =
+ match opt.DbAst.skip with
+ | None -> C.int annotmap 0
+ | Some i -> annotmap, i
+ in let query = Some (
match setkind with
| DbSchema.Map _ -> uniq, DbAst.QFlds [(["_id"], query)]
- | _ -> uniq, query)
+ | _ -> uniq, query
+ )
+ in
+ annotmap, skip, limit, query, opt.DbAst.sort, uniq
in
(* DbSet.build *)
let (annotmap, build, query, args) =
@@ -448,23 +486,24 @@ module Generator = struct
let dataty =
match setkind with
| DbSchema.DbSet ty -> ty
- | DbSchema.Map _ -> QmlAstCons.Type.next_var () (* Dummy type variable, should never use*)
+ | DbSchema.Map _ -> QmlAstCons.Type.next_var ()
+ (* Dummy type variable, should never use*)
in
(* query *)
- let (annotmap, query) = query_to_expr gamma annotmap query in
- let (annotmap, nb) = C.int annotmap nb in
- let (annotmap, default) = node.DbSchema.default annotmap in
+ let annotmap, query = query_to_expr gamma annotmap query in
+ let annotmap, query = query_add_order gamma annotmap order query in
+ let annotmap, default = node.DbSchema.default annotmap in
begin match kind with
| DbAst.Default | DbAst.Option ->
let annotmap, build =
OpaMapToIdent.typed_val ~label ~ty:[dataty] Api.DbSet.build annotmap gamma in
- (annotmap, build, query, [default; nb])
+ (annotmap, build, query, [default; skip; limit])
| DbAst.Valpath ->
let annotmap, build =
OpaMapToIdent.typed_val ~label ~ty:[dataty; dataty] Api.DbSet.build_vpath annotmap gamma
in
let annotmap, read_map = get_read_map setkind uniq annotmap gamma in
- (annotmap, build, query, [default; nb; read_map])
+ (annotmap, build, query, [default; skip; limit; read_map])
| DbAst.Ref ->
let annotmap, read_map = get_read_map setkind uniq annotmap gamma in
let wty, (annotmap, write_map) =
@@ -487,7 +526,7 @@ module Generator = struct
let annotmap, build =
OpaMapToIdent.typed_val ~label ~ty:[wty; dataty] Api.DbSet.build_rpath annotmap gamma
in
- (annotmap, build, query, [default; nb; read_map; write_map])
+ (annotmap, build, query, [default; skip; limit; read_map; write_map])
| _ -> assert false
end
View
32 stdlib/database/mongo/db.opa
@@ -415,9 +415,9 @@ type dbset('a) = { reply: Mongo.reply default : 'a}
* {1 Interface}
*/
-@package DbSet = {{
+DbSet = {{
- index(db:DbMongo.t, path:list(string), idx) =
+ @package index(db:DbMongo.t, path:list(string), idx) =
id = List.to_string_using("", "", ".", path)
key = List.map((name -> ~{name value={Int32=1}}), idx)
opt = 0
@@ -430,22 +430,22 @@ type dbset('a) = { reply: Mongo.reply default : 'a}
do Log.error("DbGen/Mongo", "(failure) Error when creating index {idx} at {path}")
error("Error when creating index")
- indexes(db:DbMongo.t, path:list(string), idxs) =
+ @package indexes(db:DbMongo.t, path:list(string), idxs) =
List.iter(index(db, path, _), idxs)
- build(db:DbMongo.t, path:list(string), selector, default:'a, nb):dbset('a) =
+ @package build(db:DbMongo.t, path:list(string), selector, default:'a, skip, limit):dbset('a) =
#<Ifstatic:DBGEN_DEBUG>
do Log.notice("DbGen/Mongo", "DbSet.build : Selector {selector}")
#<End>
id = List.to_string_using("", "", ".", path)
- reply=MongoDriver.query(db.db, 0, "{db.name}.{id}", 0, nb, selector, none)
+ reply=MongoDriver.query(db.db, 0, "{db.name}.{id}", skip, limit, selector, none)
match reply with
| {none} ->
do Log.error("DbGen/Query", "(failure) Read tn {id} set doesn't returns anything")
error("DbSet build error")
| {some=reply} -> ~{reply default}
- update(db:DbMongo.t, path:list(string), selector, update) =
+ @package update(db:DbMongo.t, path:list(string), selector, update) =
id = List.to_string_using("", "", ".", path)
tag = Bitwise.lor(0, MongoCommon.UpsertBit)
tag = Bitwise.lor(tag, MongoCommon.MultiUpdateBit)
@@ -501,7 +501,7 @@ type dbset('a) = { reply: Mongo.reply default : 'a}
to_list(dbset:dbset('a)) = fold([], dbset)(acc, a -> a +> acc)
- to_map(dbset:dbset('a)):map('key, 'value) =
+ @package to_map(dbset:dbset('a)):map('key, 'value) =
fold_doc(Map.empty, dbset, (map:map('key, 'value), doc:Bson.document ->
match List.extract_p(x -> x.name == "_id", doc) with
| ({some=kdoc}, vdoc) ->
@@ -529,7 +529,7 @@ type dbset('a) = { reply: Mongo.reply default : 'a}
)
)
- map_to_uniq(dbset:dbset('a)):option('value) =
+ @package map_to_uniq(dbset:dbset('a)):option('value) =
fold_doc(none, dbset, (opt, doc ->
do @assert(Option.is_none(opt))
match List.extract_p(x -> x.name == "_id", doc) with
@@ -544,37 +544,37 @@ type dbset('a) = { reply: Mongo.reply default : 'a}
)
)
- map_to_uniq_def(dbset:dbset('a)):'value =
+ @package map_to_uniq_def(dbset:dbset('a)):'value =
match map_to_uniq(dbset) with
| {some=v:'value} -> v
| {none} -> @unsafe_cast(dbset.default)
- set_to_uniq(dbset:dbset('a)):option('a) =
+ @package set_to_uniq(dbset:dbset('a)):option('a) =
match to_list(dbset) with
| [] -> none
| [uniq] -> some(uniq)
| _ -> do @assert(false) error("___")
- set_to_uniq_def(dbset:dbset('a)):'a =
+ @package set_to_uniq_def(dbset:dbset('a)):'a =
match set_to_uniq(dbset) with
| {none} -> dbset.default
| {some = uniq} -> uniq
- add_to_document(doc, name, value, ty):Bson.document =
+ @package add_to_document(doc, name, value, ty):Bson.document =
List.append(doc, Bson.opa_to_document(name, value, ty))
- build_vpath(db:DbMongo.t, path:list(string), selector, default:'b, nb,
+ @package build_vpath(db:DbMongo.t, path:list(string), selector, default:'b, skip, limit,
read_map:dbset('a) -> option('b)):DbMongo.private.val_path('b) =
{
id = DbMongo.path_to_id(path)
- read() = read_map(build(db, path, selector, @unsafe_cast(default), nb)):option('b)
+ read() = read_map(build(db, path, selector, @unsafe_cast(default), skip, limit)):option('b)
default = default
more = void
}
// [selector |
- build_rpath(db:DbMongo.t, path:list(string), selector, default:'b, nb,
+ @package build_rpath(db:DbMongo.t, path:list(string), selector, default:'b, skip, limit,
read_map:dbset('a) -> option('b), write_map:'b -> Bson.document):DbMongo.private.ref_path('b) =
- vpath = build_vpath(db, path, selector, default, nb, read_map)
+ vpath = build_vpath(db, path, selector, default, skip, limit, read_map)
write(data) =
do update(db, path, selector,
[{name="$set"; value={Document = write_map(data)}}]

0 comments on commit e59cccd

Please sign in to comment.
Something went wrong with that request. Please try again.