Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Use new CouchDB interface

  • Loading branch information...
commit c7d07d8f19cab2732f9023350754f6d00b81002c 1 parent 1eaa839
@VictorNicollet authored
View
23 ohmCouchExport/ohmCouchExport.ml
@@ -86,7 +86,7 @@ struct
end)
module MyDB = CouchDB.Database(Db)
- module MyTable = CouchDB.Table(MyDB)(MyId)(Data)
+ module Tbl = CouchDB.Table(MyDB)(MyId)(Data)
module Design = struct
module Database = MyDB
@@ -95,7 +95,7 @@ struct
let create ?size ?(init=Config.empty) () =
let! time = ohmctx (#time) in
- MyTable.create (object
+ Tbl.create (object
method size = BatOption.map (fun s -> (0,s)) size
method data = init
method time = time
@@ -114,7 +114,7 @@ struct
method finished = old # finished
method size = BatOption.map (fun (n,s) -> n + steps, s) (old # size)
end in
- Run.map ignore (MyTable.transaction id (MyTable.update f))
+ Tbl.update id f
let finish id =
let! time = ohmctx (#time) in
@@ -124,7 +124,7 @@ struct
method data = old # data
method size = old # size
end in
- Run.map ignore (MyTable.transaction id (MyTable.update f))
+ Tbl.update id f
let compute_progress data =
match data # size with
@@ -133,28 +133,27 @@ struct
| None -> None
let progress id =
- Run.map (BatOption.bind compute_progress) (MyTable.get id)
+ Run.map (BatOption.bind compute_progress) (Tbl.get id)
- let delete id =
- Run.map ignore MyTable.(transaction id remove)
+ let delete id = Tbl.delete id
let finished id =
- Run.map (BatOption.map (#finished)) (MyTable.get id)
+ Tbl.using id (#finished)
- let is_finished data =
+ let if_finished data =
if data # finished then Some (data # data) else None
let download id =
- Run.map (BatOption.bind is_finished) (MyTable.get id)
+ Run.map (BatOption.bind if_finished) (Tbl.get id)
let get_state = function
| None -> `Missing
- | Some data -> match is_finished data with
+ | Some data -> match if_finished data with
| Some whole -> `Complete whole
| None -> `Incomplete (compute_progress data)
let state id =
- Run.map get_state (MyTable.get id)
+ Tbl.get id |> Run.map get_state
module LastTouchedView = CouchDB.MapView(struct
module Key = Fmt.Float
View
32 ohmCouchPollUrl/ohmCouchPollUrl.ml
@@ -68,7 +68,6 @@ module Make = functor(Config:CONFIG) -> struct
(* Minor operations on the metadata *)
let poll ~delay source =
- let id = Id.gen () in
let info = PollInfo.({
fetched = 0.0 ;
wait = delay ;
@@ -77,21 +76,16 @@ module Make = functor(Config:CONFIG) -> struct
gc = 0 ;
errors = 0 ;
}) in
- let! _ = ohm $ Run.edit_context Config.couchDB
- (InfoTable.transaction id (InfoTable.insert info)) in
- return id
+ Run.edit_context Config.couchDB
+ (InfoTable.create info)
let disable id =
- let update info = PollInfo.({ info with gc = 999 }) in
- let! _ = ohm $ Run.edit_context Config.couchDB
- (InfoTable.transaction id (InfoTable.update update)) in
- return ()
+ Run.edit_context Config.couchDB
+ (InfoTable.update id (fun info -> PollInfo.({ info with gc = 999 })))
let insist id =
- let update info = PollInfo.({ info with fetched = 0.0 }) in
- let! _ = ohm $ Run.edit_context Config.couchDB
- (InfoTable.transaction id (InfoTable.update update)) in
- return ()
+ Run.edit_context Config.couchDB
+ (InfoTable.update id (fun info -> PollInfo.({ info with fetched = 0.0 })))
let get id =
let! data = ohm_req_or (return None) $
@@ -124,9 +118,8 @@ module Make = functor(Config:CONFIG) -> struct
in
if info.PollInfo.digest = digest then return (`keep,digest) else
let content = Lazy.force lazy_content in
- let insert = ContentData.({content}) in
- let! _ = ohm $ Run.edit_context Config.couchDB
- (ContentTable.transaction id (ContentTable.insert insert)) in
+ let! () = ohm $ Run.edit_context Config.couchDB
+ (ContentTable.set id ContentData.({content})) in
let! keep = ohm $ Signals.change_call (id,info.PollInfo.source,content) in
return begin
if keep then `keep, digest else (
@@ -147,9 +140,8 @@ module Make = functor(Config:CONFIG) -> struct
(* "lock" the task to avoid multiple processing *)
let fetched = Unix.gettimeofday () in
- let update info = PollInfo.({ info with fetched }) in
- let! _ = ohm $ Run.edit_context Config.couchDB
- (InfoTable.transaction id (InfoTable.update update)) in
+ let! () = ohm $ Run.edit_context Config.couchDB
+ (InfoTable.update id (fun info -> PollInfo.({ info with fetched }))) in
(* Perform the processing *)
let! status, digest = ohm $ download id info in
@@ -163,8 +155,8 @@ module Make = functor(Config:CONFIG) -> struct
gc = (1 + info.gc) * gc ;
errors = (1 + info.errors) * err
}) in
- let! _ = ohm $ Run.edit_context Config.couchDB
- (InfoTable.transaction id (InfoTable.update update)) in
+ let! () = ohm $ Run.edit_context Config.couchDB
+ (InfoTable.update id update) in
return None
View
8 ohmCouchProof/ohmCouchProof.ml
@@ -44,18 +44,16 @@ module Make = functor(Db:CouchDB.DATABASE) -> struct
type json t = < key : string >
end)
- module MyTable = CouchDB.Table(Db)(Id)(Key)
+ module Tbl = CouchDB.Table(Db)(Id)(Key)
let id = Id.of_string "key"
let key =
Run.eval (new CouchDB.init_ctx) begin
- let! found = ohm $ MyTable.get id in
+ let! found = ohm $ Tbl.get id in
match found with Some found -> return (found # key) | None ->
let key = generate () in
- let! _ = ohm $ MyTable.transaction id
- (MyTable.insert (object method key = key end))
- in
+ let! () = ohm $ Tbl.set id (object method key = key end) in
return key
end
View
73 ohmCouchTabular/ohmCouchTabular.ml
@@ -342,8 +342,7 @@ module Make = functor(T:TABULAR) -> struct
hint = hint
}) in
- let! _ = ohm $ LineTable.transaction (LineId.of_id id) (LineTable.insert line) in
- return ()
+ LineTable.set (LineId.of_id id) line
let update_at_key lid ?(hint=false) ?evaluator key =
@@ -383,13 +382,9 @@ module Make = functor(T:TABULAR) -> struct
let remove item =
let id = LineId.of_id (item # id) in
- let checked_remove id =
- (* Check whether the version is still the one to be removed!
- Maybe another process came around and updated the line to another version. *)
- let! line = ohm_req_or (return ((),`keep)) $ LineTable.get id in
- if line.LineData.version <> version then return ((),`keep) else return ((), `delete)
- in
- LineTable.transaction id checked_remove
+ (* Check whether the version is still the one to be removed!
+ Maybe another process came around and updated the line to another version. *)
+ LineTable.delete_if id (fun line -> line.LineData.version = version)
in
let! _ = ohm $ Run.list_map remove sample in
@@ -427,22 +422,27 @@ module Make = functor(T:TABULAR) -> struct
let lid = ListId.of_id (next # id) in
(* Determine what should be done, and lock the task. *)
- let! what = ohm_req_or (return false) $ decay (ListTable.transaction lid begin fun lid ->
- let abort = return (None, `keep) in
- let! list = ohm_req_or abort $ ListTable.get lid in
- if list.ListData.next > Unix.gettimeofday () then
+ let! what = ohm_req_or (return false) $ decay
+ (ListTable.Raw.transaction lid begin fun lid ->
+
+ let abort = return (None, `keep) in
+ let! list = ohm_req_or abort $ ListTable.get lid in
+
+ if list.ListData.next > Unix.gettimeofday () then
(* Concurrent access : abort. *)
- abort
- else
- let! task, lock = req_or abort $ start_processing list in
- return (Some task, `put lock)
- end) in
+ abort
+ else
+ let! task, lock = req_or abort $ start_processing list in
+ return (Some task, `put lock)
+
+ end)
+ in
(* Perform the task and determine if something should be done next. *)
let! continue = ohm $ process_update lid what in
(* Unlock the task. *)
- let! () = ohm $ decay (ListTable.transaction lid begin fun lid ->
+ let! () = ohm $ decay (ListTable.Raw.transaction lid begin fun lid ->
let! list = ohm_req_or (return ((), `keep)) $ ListTable.get lid in
return ((), `put (finish_processing what continue list))
end) in
@@ -454,19 +454,15 @@ module Make = functor(T:TABULAR) -> struct
(* Publish the API *)
let set_list lid ~columns ~source ~filter =
- decay $ ListTable.transaction lid begin fun lid ->
- let! current = ohm $ ListTable.get lid in
- let updated = update_or_create_list ~columns ~source ~filter current in
- return ((), `put updated)
+ decay $ ListTable.replace lid begin fun current ->
+ update_or_create_list ~columns ~source ~filter current
end
let set_columns lid columns =
- decay $ ListTable.transaction lid begin fun lid ->
- let! current = ohm_req_or (return ((), `keep)) $ ListTable.get lid in
+ decay $ ListTable.update lid begin fun current ->
let source = current.ListData.source in
let filter = current.ListData.filter in
- let updated = update_or_create_list ~columns ~source ~filter (Some current) in
- return ((), `put updated)
+ update_or_create_list ~columns ~source ~filter (Some current)
end
let get_list lid =
@@ -483,16 +479,13 @@ module Make = functor(T:TABULAR) -> struct
let schedule_list item =
let lid = ListId.of_id (item # id) in
- decay $ ListTable.transaction lid begin fun lid ->
- let! current = ohm $ ListTable.get lid in
- match current with
- | None -> return ((), `keep)
- | Some list -> return ((), `put (schedule_update_at key list))
+ decay $ ListTable.transact lid begin function
+ | None -> return ((), `keep)
+ | Some list -> return ((), `put (schedule_update_at key list))
end
in
- let! _ = ohm $ Run.list_map schedule_list lists in
- return ()
+ Run.list_iter schedule_list lists
let update_all key =
@@ -500,18 +493,14 @@ module Make = functor(T:TABULAR) -> struct
let lists = List.map (#value |- ListId.of_id) lists in
let schedule_list lid =
- decay $ ListTable.transaction lid begin fun lid ->
- let! current = ohm $ ListTable.get lid in
- match current with
- | None -> return ((), `keep)
- | Some list -> return ((), `put (schedule_update_at key list))
+ decay $ ListTable.transact lid begin function
+ | None -> return ((), `keep)
+ | Some list -> return ((), `put (schedule_update_at key list))
end
in
- let! _ = ohm $ Run.list_map schedule_list lists in
- return ()
+ Run.list_iter schedule_list lists
-
let hint lid key evaluator =
update_at_key lid ~hint:true ~evaluator key
View
8 ohmCouchUnique/ohmCouchUnique.ml
@@ -35,14 +35,14 @@ module Make = functor (DB:CouchDB.DATABASE) -> struct
let get value =
let id = Id.gen () in
let fresh = lazy (object method id = id end) in
- MyTable.transaction value (MyTable.ensure fresh) |> Run.map id_of
+ Run.map id_of (MyTable.ensure value fresh)
let remove value =
- MyTable.transaction value MyTable.remove |> Run.map ignore
+ MyTable.delete value
let remove_atomic value current_id =
let has_id uniq = uniq # id = current_id in
- MyTable.transaction value (MyTable.remove_if has_id) |> Run.map ignore
+ MyTable.delete_if value has_id
module Design = struct
module Database = DB
@@ -68,7 +68,7 @@ module Make = functor (DB:CouchDB.DATABASE) -> struct
| None -> return (id, `put (object method id = id end))
| Some x -> return (id_of x, `keep)
in
- MyTable.transaction value update
+ MyTable.Raw.transaction value update
end
View
78 ohmCouchVersioned/ohmCouchVersioned.ml
@@ -202,7 +202,7 @@ module Make = functor (Versioned:VERSIONED) -> struct
in
let! obj = ohm_req_or (return ()) $
- Run.edit_context Versioned.couchDB (ObjectTable.transaction oid update) in
+ Run.edit_context Versioned.couchDB (ObjectTable.Raw.transaction oid update) in
let! () = ohm $ Signals.explicit_reflect_call (oid, obj) in
let! () = ohm $ Signals.update_call (oid, obj) in
@@ -254,7 +254,7 @@ module Make = functor (Versioned:VERSIONED) -> struct
in
let! oid, obj = ohm_req_or (return None) $
- Run.edit_context Versioned.couchDB (ObjectTable.transaction oid update) in
+ Run.edit_context Versioned.couchDB (ObjectTable.Raw.transaction oid update) in
let! () = ohm $ Signals.update_call (oid, obj) in
return (Some (oid, obj))
@@ -271,8 +271,7 @@ module Make = functor (Versioned:VERSIONED) -> struct
end in
let! () = ohm begin
- let! version = ohm $ Run.edit_context Versioned.couchDB
- (VersionTable.transaction vid (VersionTable.insert version)) in
+ let! () = ohm $ Run.edit_context Versioned.couchDB (VersionTable.set vid version) in
Signals.version_create_call (vid,version)
end in
@@ -293,41 +292,43 @@ module Make = functor (Versioned:VERSIONED) -> struct
let! ctx = ohmctx identity in
let oid = Versioned.Id.of_id id in
- let! () = ohm $ Run.edit_context Versioned.couchDB (ObjectTable.transaction oid begin fun oid ->
+ let! () = ohm $ Run.edit_context Versioned.couchDB
+ (ObjectTable.Raw.transaction oid begin fun oid ->
- let! original = ohm_req_or (return ((),`keep)) $ ObjectTable.get oid in
-
- Run.with_context ctx begin
-
- let! initial = ohm_req_or (return ((),`keep)) $ migrator oid original # initial in
-
- let () = Util.log "Migrate : %s : %s/%s" name db (Id.to_string id) in
-
- let! versions = ohm $ get_versions oid in
+ let! original = ohm_req_or (return ((),`keep)) $ ObjectTable.get oid in
- let! current = ohm $ apply_versions versions oid initial in
- let! reflected = ohm $ Versioned.reflect oid current in
-
- let time = List.fold_left (fun t (_,v) -> max (v # time) t) 0.0 versions in
-
- let obj = object
- method initial = initial
- method current = current
- method reflected = reflected
- method time = time
- end in
-
- return ((), `put obj)
-
- end
- end) in
-
+ Run.with_context ctx begin
+
+ let! initial = ohm_req_or (return ((),`keep)) $ migrator oid original # initial in
+
+ let () = Util.log "Migrate : %s : %s/%s" name db (Id.to_string id) in
+
+ let! versions = ohm $ get_versions oid in
+
+ let! current = ohm $ apply_versions versions oid initial in
+ let! reflected = ohm $ Versioned.reflect oid current in
+
+ let time = List.fold_left (fun t (_,v) -> max (v # time) t) 0.0 versions in
+
+ let obj = object
+ method initial = initial
+ method current = current
+ method reflected = reflected
+ method time = time
+ end in
+
+ return ((), `put obj)
+
+ end
+ end) in
+
return ()
in
-
+
let source idopt =
Run.edit_context Versioned.couchDB begin
- let! list, next = ohm $ ObjectTable.all_ids ~count:10 (BatOption.map Versioned.Id.of_id idopt) in
+ let! list, next = ohm $ ObjectTable.all_ids ~count:10
+ (BatOption.map Versioned.Id.of_id idopt) in
return (List.map Versioned.Id.to_id list, BatOption.map Versioned.Id.to_id next)
end
in
@@ -344,16 +345,11 @@ module Make = functor (Versioned:VERSIONED) -> struct
let! versions = ohm $ VersionByIdView.doc_query
~startkey:(id,0.0) ~endkey:(id,max_float) ()
in
- let remove_version vid =
- VersionTable.transaction vid VersionTable.remove |> Run.map ignore in
- let! _ = ohm $ Run.list_iter
- (#id |- VersionId.of_id |- remove_version) versions
- in
+ let remove_version vid = VersionTable.delete vid in
+ let! _ = ohm $ Run.list_iter (#id |- VersionId.of_id |- remove_version) versions in
(* Remove the object itself *)
- let! _ = ohm $ ObjectTable.transaction oid ObjectTable.remove in
-
- return ()
+ ObjectTable.delete oid
end
module Id = ObjectId
Please sign in to comment.
Something went wrong with that request. Please try again.