Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Refactor CouchDB methods

  • Loading branch information...
commit 588e1da29198bbd6d7e5d191933c8a38dbba4d0a 1 parent dd2f2b6
@VictorNicollet authored
View
12 src/async.ml
@@ -50,7 +50,7 @@ module Make = functor(DB:CouchDB.CONFIG) -> struct
They depend on CouchDB for doing the work. *)
module MyDB = CouchDB.Database(DB)
- module MyTable = CouchDB.Table(MyDB)(Id)(Task)
+ module Tbl = CouchDB.Table(MyDB)(Id)(Task)
module Design = struct
module Database = MyDB
let name = "async"
@@ -86,11 +86,9 @@ module Make = functor(DB:CouchDB.CONFIG) -> struct
end)
let save_task delay name args =
- let id = Id.gen () in
let! time = ohmctx (#time) in
let time = match delay with None -> time | Some delay -> time +. delay in
- let task = Task.({ time ; calls = 0 ; name ; args }) in
- let! _ = ohm $ MyTable.transaction id (MyTable.insert task) in
+ let! _ = ohm $ Tbl.create Task.({ time ; calls = 0 ; name ; args }) in
return ()
module TaskView = CouchDB.DocView(struct
@@ -118,7 +116,7 @@ module Make = functor(DB:CouchDB.CONFIG) -> struct
let unlock = now +. delay in
let task = lock unlock task in
- let! result = ohm $ MyTable.put id task in
+ let! result = ohm $ Tbl.Raw.put id task in
match result with
| `collision -> find_next (retries-1)
| `ok -> return $ Some (id,task)
@@ -131,7 +129,7 @@ module Make = functor(DB:CouchDB.CONFIG) -> struct
(* Specify a reschedule operation in case we're interrupted by [raise Reschedule] *)
let () = reschedule := (
- let! _ = ohm $ MyTable.transaction id (MyTable.insert (unlock task)) in
+ let! _ = ohm $ Tbl.set id (unlock task) in
return (log "Ohm.Async: reschedule %s" (Id.str id))
) in
@@ -141,7 +139,7 @@ module Make = functor(DB:CouchDB.CONFIG) -> struct
in
let! () = ohm $ call task.Task.args in
- let! _ = ohm $ MyTable.transaction id MyTable.remove in
+ let! () = ohm $ Tbl.delete id in
return None
View
33 src/couchDB.mli
@@ -37,6 +37,8 @@ module type READ_TABLE = sig
val get : id -> (#ctx, elt option) Run.t
+ val using : id -> (elt -> 'a) -> (#ctx,'a option) Run.t
+
val parse : id -> 'a Parser.t -> (#ctx,'a option) Run.t
val all_ids : count:int -> id option -> (#ctx,id list * id option) Run.t
@@ -49,20 +51,27 @@ module type TABLE = sig
val create : elt -> (#ctx,id) Run.t
- val put : id -> elt -> (#ctx,[> `ok | `collision]) Run.t
- val delete : id -> (#ctx,[> `ok | `collision]) Run.t
+ val ensure : id -> elt Lazy.t -> (#ctx,elt) Run.t
+
+ val delete : id -> (#ctx,unit) Run.t
+ val delete_if : id -> (elt -> bool) -> (#ctx,unit) Run.t
- type ('ctx,'a) update = id -> ('ctx,'a * [`put of elt | `keep | `delete]) Run.t
+ val update : id -> (elt -> elt) -> (#ctx,unit) Run.t
- val transaction : id -> (#ctx as 'ctx,'a) update -> ('ctx,'a) Run.t
+ val set : id -> elt -> (#ctx,unit) Run.t
+
+ module Raw : sig
+ val put : id -> elt -> (#ctx,[> `ok | `collision]) Run.t
+ val delete : id -> (#ctx,[> `ok | `collision]) Run.t
+ val transaction :
+ id
+ -> (id -> (#ctx as 'ctx,'a * [`put of elt | `keep | `delete]) Run.t)
+ -> ('ctx,'a) Run.t
+ end
- val insert : elt -> (#ctx, elt) update
- val remove : (#ctx, elt option) update
- val update : (elt -> elt) -> (#ctx, elt option) update
- val ensure : elt Lazy.t -> (#ctx,elt) update
+ type ('ctx,'a) update = elt option -> ('ctx,'a * [`put of elt | `keep | `delete]) Run.t
- val remove_if : (elt -> bool) -> (#ctx, elt option) update
- val if_exists : (elt -> 'a * [`put of elt | `keep | `delete]) -> (#ctx,'a option) update
+ val transact : id -> (#ctx as 'ctx,'a) update -> ('ctx,'a) Run.t
end
@@ -246,8 +255,8 @@ module Convenience : sig
functor (Id:ID) ->
functor (Type:Fmt.FMT) ->
sig
- module MyTable : TABLE with type id = Id.t and type elt = Type.t
- module Design : DESIGN
+ module Tbl : TABLE with type id = Id.t and type elt = Type.t
+ module Design : DESIGN
end
end
View
2  src/couchDB_convenience.ml
@@ -24,7 +24,7 @@ module Table =
functor (Type:Fmt.FMT) ->
struct
module Db = Database(C)
- module MyTable = ImplTable.Table(Db)(Id)(Type)
+ module Tbl = ImplTable.Table(Db)(Id)(Type)
module Design = struct
module Database = Db
let name = C.db
View
401 src/couchDB_table.ml
@@ -32,6 +32,12 @@ module Database = functor (Config:ImplTypes.CONFIG) -> struct
| Some doc -> Run.return (Some doc.ImplCache.json)
end (ImplCache.get (ImplCache.CacheKey.make database id))
+ let using id f =
+ Run.map begin function
+ | None -> None
+ | Some json -> Some (f json)
+ end (get id)
+
let parse id elt_parser =
Run.bind begin function
| None -> Run.return None
@@ -99,173 +105,162 @@ module Database = functor (Config:ImplTypes.CONFIG) -> struct
Run.return (first,next)
- let put id json =
-
- let key = ImplCache.CacheKey.make database id in
- let url = ImplCache.CacheKey.url key in
-
- (* Extract previously available data from the cache, if any. *)
- ImplCache.get_if_exists key |> Run.bind begin fun cached ->
-
- let rev, ct =
- match cached with None | Some None -> None, None | Some (Some cached) ->
- let rev = cached.ImplCache.rev in
- let ct =
- try Some (Json.to_object (fun ~opt ~req -> req "ct") cached.ImplCache.json)
- with _ -> None
- in
- rev, ct
- in
-
- (* Keep "ut" and "ct" timers on every object for debugging *)
- Run.context |> Run.bind begin fun ctx ->
-
- let update_time = Json.String (Util.string_of_time (ctx # time)) in
- let create_time = BatOption.default update_time ct in
-
- (* The JSON to be written to the database. *)
- let json =
- json
- |> json_replace "ct" create_time
- |> json_replace "ut" update_time
- |> (match rev with
- | None -> identity
- | Some rev -> json_replace "_rev" (Json.String rev))
- |> json_replace "_id" (Id.to_json id)
- in
-
- (* Send the new document to the database now. *)
-
- let json_str = Json.serialize json in
-
- let rec retry retries =
- try Util.logreq "PUT %s %s" url json_str ;
- let response = Http_client.Convenience.http_put url json_str in
- try let rev =
- Json.unserialize response
- |> Json.to_object (fun ~opt ~req -> Json.to_string (req "rev"))
- in Run.return (`ok (Some rev))
- with _ -> Run.return (`ok None)
- with
- | Http_client.Http_error (409,_) ->Run.return `collision
- | Http_client.Http_error (status,desc) as exn ->
- Util.log "CouchDB.put: `%s %s` : %d %s" url json_str status desc ;
- if retries <= 0 then raise exn else retry (retries-1)
- | Http_client.Http_protocol error as exn ->
- Util.log "CouchDB.put: HTTP error (%s) on %s\n%s" (Printexc.to_string error)
- url json_str ;
- if retries <= 0 then raise exn else retry (retries-1)
- | exn ->
- if retries <= 0 then raise exn else retry (retries-1)
-
+ module Raw = struct
+
+ let put id json =
+
+ let key = ImplCache.CacheKey.make database id in
+ let url = ImplCache.CacheKey.url key in
+
+ (* Extract previously available data from the cache, if any. *)
+ ImplCache.get_if_exists key |> Run.bind begin fun cached ->
+
+ let rev, ct =
+ match cached with None | Some None -> None, None | Some (Some cached) ->
+ let rev = cached.ImplCache.rev in
+ let ct =
+ try Some (Json.to_object (fun ~opt ~req -> req "ct") cached.ImplCache.json)
+ with _ -> None
+ in
+ rev, ct
in
- retry 5 |> Run.bind begin function
- | `collision -> Run.bind (fun () -> Run.return `collision) (ImplCache.remove key)
- | `ok rev -> Run.bind (fun () -> Run.return `ok)
- (ImplCache.cache_values [key,Some (ImplCache.cached_of_json json)])
+ (* Keep "ut" and "ct" timers on every object for debugging *)
+ Run.context |> Run.bind begin fun ctx ->
+
+ let update_time = Json.String (Util.string_of_time (ctx # time)) in
+ let create_time = BatOption.default update_time ct in
+
+ (* The JSON to be written to the database. *)
+ let json =
+ json
+ |> json_replace "ct" create_time
+ |> json_replace "ut" update_time
+ |> (match rev with
+ | None -> identity
+ | Some rev -> json_replace "_rev" (Json.String rev))
+ |> json_replace "_id" (Id.to_json id)
+ in
+
+ (* Send the new document to the database now. *)
+
+ let json_str = Json.serialize json in
+
+ let rec retry retries =
+ try Util.logreq "PUT %s %s" url json_str ;
+ let response = Http_client.Convenience.http_put url json_str in
+ try let rev =
+ Json.unserialize response
+ |> Json.to_object (fun ~opt ~req -> Json.to_string (req "rev"))
+ in Run.return (`ok (Some rev))
+ with _ -> Run.return (`ok None)
+ with
+ | Http_client.Http_error (409,_) ->Run.return `collision
+ | Http_client.Http_error (status,desc) as exn ->
+ Util.log "CouchDB.put: `%s %s` : %d %s" url json_str status desc ;
+ if retries <= 0 then raise exn else retry (retries-1)
+ | Http_client.Http_protocol error as exn ->
+ Util.log "CouchDB.put: HTTP error (%s) on %s\n%s" (Printexc.to_string error)
+ url json_str ;
+ if retries <= 0 then raise exn else retry (retries-1)
+ | exn ->
+ if retries <= 0 then raise exn else retry (retries-1)
+
+ in
+
+ retry 5 |> Run.bind begin function
+ | `collision -> Run.bind (fun () -> Run.return `collision) (ImplCache.remove key)
+ | `ok rev -> Run.bind (fun () -> Run.return `ok)
+ (ImplCache.cache_values [key,Some (ImplCache.cached_of_json json)])
+ end
end
end
- end
+ let delete id =
+
+ let key = ImplCache.CacheKey.make database id in
+
+ let rec remove ?(retries=5) rev =
+ let url = ImplCache.CacheKey.url key ^ "?rev=" ^ rev in
+ try Util.logreq "DELETE %s" url ;
+ ignore (Http_client.Convenience.http_delete url) ;
+ Run.bind (fun () -> Run.return `ok) (ImplCache.cache_values [key,None])
+ with
+ | Http_client.Http_error (409,_) ->
+ Run.bind (fun () -> Run.return `collision) (ImplCache.remove key)
+ | Http_client.Http_error (status,desc) as exn ->
+ Util.log "CouchDB.delete: `%s` : %d %s" url status desc ;
+ if retries <= 0 then raise exn else remove ~retries:(retries-1) rev
+ | exn ->
+ Util.log "CouchDB.delete : `%s` : %s" url (Printexc.to_string exn) ;
+ if retries <= 0 then raise exn else remove ~retries:(retries-1) rev
+
+ in
+
+ ImplCache.get key |> Run.bind begin function
+ | None -> Run.return `ok
+ | Some doc -> match doc.ImplCache.rev with
+ | None -> Run.bind (fun () -> Run.return `ok) (ImplCache.cache_values [key,None])
+ | Some rev -> remove rev
+ end
+
+ let transaction id update =
+
+ let rec loop retries =
+ if retries <= 0 then raise ImplCache.CouchDB_error else
+ update id |> Run.bind begin fun (returned,operation) ->
+
+ let confirm action =
+ action |> Run.bind begin function
+ | `ok -> Run.return returned
+ | `collision -> Run.bind (fun _ -> loop (retries-1)) (get id)
+ end
+ in
+
+ match operation with
+ | `keep -> Run.return returned
+ | `put doc -> confirm (put id doc)
+ | `delete -> confirm (delete id)
+ end
+ in
+
+ (* Try the transaction this many times *)
+ loop 10
+
+ end
+
let rec create elt =
let id = Id.gen () in
- put id elt |> Run.bind (function
+ Raw.put id elt |> Run.bind (function
| `collision -> create elt
| `ok -> Run.return id)
- type ('ctx,'a) update = id -> ('ctx,'a * [`put of elt | `keep | `delete]) Run.t
-
- let delete id =
-
- let key = ImplCache.CacheKey.make database id in
-
- let rec remove ?(retries=5) rev =
- let url = ImplCache.CacheKey.url key ^ "?rev=" ^ rev in
- try Util.logreq "DELETE %s" url ;
- ignore (Http_client.Convenience.http_delete url) ;
- Run.bind (fun () -> Run.return `ok) (ImplCache.cache_values [key,None])
- with
- | Http_client.Http_error (409,_) ->
- Run.bind (fun () -> Run.return `collision) (ImplCache.remove key)
- | Http_client.Http_error (status,desc) as exn ->
- Util.log "CouchDB.delete: `%s` : %d %s" url status desc ;
- if retries <= 0 then raise exn else remove ~retries:(retries-1) rev
- | exn ->
- Util.log "CouchDB.delete : `%s` : %s" url (Printexc.to_string exn) ;
- if retries <= 0 then raise exn else remove ~retries:(retries-1) rev
-
- in
+ type ('ctx,'a) update = elt option -> ('ctx,'a * [`put of elt | `keep | `delete]) Run.t
- ImplCache.get key |> Run.bind begin function
- | None -> Run.return `ok
- | Some doc -> match doc.ImplCache.rev with
- | None -> Run.bind (fun () -> Run.return `ok) (ImplCache.cache_values [key,None])
- | Some rev -> remove rev
- end
+ let transact id update =
+ Raw.transaction id (get |- Run.bind update)
- let transaction id update =
-
- let rec loop retries =
- if retries <= 0 then raise ImplCache.CouchDB_error else
- update id |> Run.bind begin fun (returned,operation) ->
-
- let confirm action =
- action |> Run.bind begin function
- | `ok -> Run.return returned
- | `collision -> Run.bind (fun _ -> loop (retries-1)) (get id)
- end
- in
-
- match operation with
- | `keep -> Run.return returned
- | `put doc -> confirm (put id doc)
- | `delete -> confirm (delete id)
- end
- in
-
- (* Try the transaction this many times *)
- loop 10
+ let ensure id eval =
+ transact id (function
+ | Some obj -> Run.return (obj,`keep)
+ | None -> let obj = Lazy.force eval in
+ Run.return (obj,`put obj))
- (* These are mere shortcuts that don't depend on the nature of the
- monad. You could write them without knowing how the monad is implemented. *)
-
- let insert elt =
- let m = Run.return (elt, `put elt) in
- fun _ -> m
-
- let remove id =
- Run.map (fun e -> e, `delete) (get id)
-
- let update f id =
- let apply = function
- | None -> None, `keep
- | Some e -> let e' = f e in
- Some e', `put e'
- in
- Run.map apply (get id)
+ let delete id =
+ Raw.transaction id (fun _ -> Run.return ((),`delete))
- let ensure elt id =
- let ensure = function
- | None -> let elt = Lazy.force elt in elt, `put elt
- | Some e -> e, `keep
- in
- Run.map ensure (get id)
+ let delete_if id pred =
+ transact id (function
+ | Some e when pred e -> Run.return ((),`delete)
+ | _ -> Run.return ((),`keep))
- let remove_if cond id =
- let rm opt =
- opt, match opt with
- | None -> `keep
- | Some e -> if cond e then `delete else `keep
- in
- Run.map rm (get id)
+ let update id f =
+ transact id (function
+ | Some e -> Run.return ((),`put (f e))
+ | None -> Run.return ((),`keep))
- let if_exists f id =
- let act = function
- | None -> None, `keep
- | Some e -> let r, o = f e in Some r, o
- in
- Run.map act (get id)
+ let set id elt =
+ Raw.transaction id (fun _ -> Run.return ((),`put elt))
end
@@ -289,6 +284,12 @@ struct
let get id = Database.parse (Id.to_id id) elt_parser
+ let using id f =
+ Run.map begin function
+ | None -> None
+ | Some elt -> Some (f elt)
+ end (get id)
+
let parse id p = Database.parse (Id.to_id id) p
let all_ids ~count start =
@@ -307,66 +308,58 @@ struct
include ReadTable(Database)(Id)(Type)
- let put id elt =
- Database.put (Id.to_id id) (Type.to_json elt)
+ module Raw = struct
- let create elt =
- Run.map Id.of_id (Database.create (Type.to_json elt))
+ let put id elt = Database.Raw.put (Id.to_id id) (Type.to_json elt)
+ let delete id = Database.Raw.delete (Id.to_id id)
- let delete id = Database.delete (Id.to_id id)
+ let transaction id update =
+ Database.Raw.transaction (Id.to_id id) begin fun id ->
+ let translate (result,action) =
+ let action = match action with
+ | `keep -> `keep
+ | `delete -> `delete
+ | `put elt -> `put (Type.to_json elt)
+ in ( result, action )
+ in
+ Run.map translate (update (Id.of_id id))
+ end
- type ('ctx,'a) update = id -> ('ctx,'a * [`put of elt | `keep | `delete]) Run.t
+ end
+
+ type ('ctx,'a) update = elt option -> ('ctx,'a * [`put of elt | `keep | `delete]) Run.t
+
+ let transact id update =
+
+ let update json =
+ Run.map
+ (function
+ | x, `put elt -> (x,`put (Type.to_json elt))
+ | x, `keep -> (x,`keep)
+ | x, `delete -> (x,`delete))
+ (update (BatOption.map Type.of_json json))
+ in
- let transaction id update =
- Database.transaction (Id.to_id id) begin fun id ->
- let translate (result,action) =
- let action = match action with
- | `keep -> `keep
- | `delete -> `delete
- | `put elt -> `put (Type.to_json elt)
- in ( result, action )
- in
- Run.map translate (update (Id.of_id id))
- end
+ Database.transact (Id.to_id id) update
- (* These are mere shortcuts that don't depend on the nature of the
- monad. You could write them without knowing how the monad is implemented. *)
-
- let insert elt =
- let m = Run.return (elt, `put elt) in
- fun _ -> m
-
- let remove id =
- Run.map (fun e -> e, `delete) (get id)
-
- let update f id =
- let apply = function
- | None -> None, `keep
- | Some e -> let e' = f e in
- Some e', `put e'
- in
- Run.map apply (get id)
+ let create elt =
+ Run.map Id.of_id (Database.create (Type.to_json elt))
- let ensure elt id =
- let ensure = function
- | None -> let elt = Lazy.force elt in elt, `put elt
- | Some e -> e, `keep
- in
- Run.map ensure (get id)
+ let ensure id eval =
+ transact id (function
+ | Some obj -> Run.return (obj,`keep)
+ | None -> let obj = Lazy.force eval in
+ Run.return (obj,`put obj))
+ let delete id =
+ Database.delete (Id.to_id id)
- let remove_if cond id =
- let rm opt =
- opt, match opt with
- | None -> `keep
- | Some e -> if cond e then `delete else `keep
- in
- Run.map rm (get id)
+ let delete_if id pred =
+ Database.delete_if (Id.to_id id) (Type.of_json |- pred)
- let if_exists f id =
- let act = function
- | None -> None, `keep
- | Some e -> let r, o = f e in Some r, o
- in
- Run.map act (get id)
+ let update id f =
+ Database.update (Id.to_id id) (Type.of_json |- f |- Type.to_json)
+ let set id elt =
+ Database.set (Id.to_id id) (Type.to_json elt)
+
end
View
28 src/couchDB_types.ml
@@ -16,6 +16,7 @@ module type READ_TABLE = sig
type elt
val get : id -> (#ctx, elt option) Run.t
+ val using : id -> (elt -> 'a) -> (#ctx,'a option) Run.t
val parse : id -> 'a CouchDB_parser.t -> (#ctx,'a option) Run.t
val all_ids : count:int -> id option -> (#ctx,id list * id option) Run.t
@@ -28,20 +29,27 @@ module type TABLE = sig
val create : elt -> (#ctx,id) Run.t
- val put : id -> elt -> (#ctx,[> `ok | `collision]) Run.t
- val delete : id -> (#ctx,[> `ok | `collision]) Run.t
+ val ensure : id -> elt Lazy.t -> (#ctx,elt) Run.t
- type ('ctx,'a) update = id -> ('ctx,'a * [`put of elt | `keep | `delete]) Run.t
+ val delete : id -> (#ctx,unit) Run.t
+ val delete_if : id -> (elt -> bool) -> (#ctx,unit) Run.t
- val transaction : id -> (#ctx as 'ctx,'a) update -> ('ctx,'a) Run.t
+ val update : id -> (elt -> elt) -> (#ctx,unit) Run.t
- val insert : elt -> (#ctx, elt) update
- val remove : (#ctx, elt option) update
- val update : (elt -> elt) -> (#ctx, elt option) update
- val ensure : elt Lazy.t -> (#ctx,elt) update
+ val set : id -> elt -> (#ctx,unit) Run.t
- val remove_if : (elt -> bool) -> (#ctx, elt option) update
- val if_exists : (elt -> 'a * [`put of elt | `keep | `delete]) -> (#ctx,'a option) update
+ module Raw : sig
+ val put : id -> elt -> (#ctx,[> `ok | `collision]) Run.t
+ val delete : id -> (#ctx,[> `ok | `collision]) Run.t
+ val transaction :
+ id
+ -> (id -> (#ctx as 'ctx,'a * [`put of elt | `keep | `delete]) Run.t)
+ -> ('ctx,'a) Run.t
+ end
+
+ type ('ctx,'a) update = elt option -> ('ctx,'a * [`put of elt | `keep | `delete]) Run.t
+
+ val transact : id -> (#ctx as 'ctx,'a) update -> ('ctx,'a) Run.t
end
View
12 src/reset.ml
@@ -27,16 +27,12 @@ struct
>
end)
- module MyTable = CouchDB.Table(DB)(Id)(Reset)
+ module Tbl = CouchDB.Table(DB)(Id)(Reset)
let _default = Util.string_of_time (Unix.gettimeofday ())
let _get () =
- let time = function
- | Some value -> value # time
- | None -> _default
- in
- MyTable.get id |> Run.map time
+ Run.map (BatOption.default _default) (Tbl.using id (#time))
let _initial = Run.eval (new CouchDB.init_ctx) (_get ())
@@ -46,12 +42,12 @@ struct
method t = "rset"
method time = Util.string_of_time (ctx # time)
end in
- MyTable.transaction id (MyTable.insert reset)
+ Tbl.set id reset
|> Run.map (fun _ -> Util.log "Reset.perform : request sent")
end
let resetting () =
- Run.eval (new CouchDB.init_ctx) (_get () |> Run.map (fun x -> x <> _initial))
+ Run.eval (new CouchDB.init_ctx) (_get () |> Run.map ((<>) _initial))
let check () =
if resetting () then begin
Please sign in to comment.
Something went wrong with that request. Please try again.