Source file ldap_mutex.ml
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
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
open Ldap_ooclient
open Ldap_types
exception Ldap_mutex of string * exn
class type mutex_t =
object
method lock: unit
method unlock: unit
end
class type object_lock_table_t =
object
method lock: dn -> unit
method unlock: dn -> unit
end
let addmutex ldap mutexdn =
let mt = new ldapentry in
let mtrdn = List.hd (Ldap_dn.of_string mutexdn) in
mt#set_dn mutexdn;
mt#add [("objectclass", ["top";"mutex"]);
(mtrdn.attr_type, mtrdn.attr_vals)];
try ldap#add mt
with exn -> raise (Ldap_mutex ("addmutex", exn))
exception Locked
let rec lock (ldap:ldapcon) mutexdn lockval =
try
let obj =
try
ldap#search
~base:mutexdn
~scope:`BASE
"objectclass=*"
with LDAP_Failure (`NO_SUCH_OBJECT, _, _) -> []
in
if List.length obj = 0 then begin
addmutex ldap mutexdn;
lock ldap mutexdn lockval
end
else if List.length obj = 1 then
while true
do
try
ldap#modify (List.hd obj)#dn lockval;
raise Locked
with
LDAP_Failure (`TYPE_OR_VALUE_EXISTS, _, _)
| LDAP_Failure (`OBJECT_CLASS_VIOLATION, _, _) ->
ignore (Unix.select [] [] [] 0.25)
done
else failwith "huge error, multiple objects with the same dn"
with
Locked -> ()
| (Ldap_mutex _) as exn -> raise exn
| exn -> raise (Ldap_mutex ("lock", exn))
let rec unlock (ldap:ldapcon) mutexdn unlockval =
try
let obj =
try
ldap#search
~base:mutexdn
~scope:`BASE
"objectclass=*"
with LDAP_Failure (`NO_SUCH_OBJECT, _, _) -> []
in
if List.length obj = 0 then begin
addmutex ldap mutexdn;
unlock ldap mutexdn unlockval
end
else if List.length obj = 1 then
try
ldap#modify
(List.hd obj)#dn unlockval
with LDAP_Failure (`NO_SUCH_ATTRIBUTE, _, _) -> ()
with
(Ldap_mutex _) as exn -> raise exn
| exn -> raise (Ldap_mutex ("unlock", exn))
class mutex ldapurls binddn bindpw mutexdn =
object (_self)
val ldap =
let ldap = new ldapcon ldapurls in
ldap#bind binddn ~cred:bindpw;
ldap
method private addmutex = addmutex ldap mutexdn
method lock = lock ldap mutexdn [(`ADD, "mutexlocked", ["locked"])]
method unlock = unlock ldap mutexdn [(`DELETE, "mutexlocked", [])]
end
let apply_with_mutex mutex f =
mutex#lock;
try
let result = f () in
mutex#unlock;
result
with exn -> (try mutex#unlock with _ -> ());raise exn
class object_lock_table ldapurls binddn bindpw mutextbldn =
object (_self)
val ldap =
let ldap = new ldapcon ldapurls in
ldap#bind binddn ~cred:bindpw;
ldap
method private addmutex = addmutex ldap mutextbldn
method lock dn = lock ldap mutextbldn [(`ADD, "lockedObject", [Ldap_dn.to_string dn])]
method unlock dn = unlock ldap mutextbldn [(`DELETE, "lockedObject", [Ldap_dn.to_string dn])]
end