(* An object oriented interface to ldap
Copyright (C) 2004 Eric Stokes, and The California State University
at Northridge
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)
open Ldap_types
open Ldap_funclient
open Ldap_schemaparser
open String
(* types used throughout the library *)
(* add types *)
type op = string * string list
type op_lst = op list
type referral_policy = [ `RETURN
| `FOLLOW ]
(* change type for ldap entry *)
type changetype = [ `ADD | `DELETE | `MODIFY | `MODDN | `MODRDN ]
class type ldapentry_t =
object
method add : op_lst -> unit
method delete : op_lst -> unit
method replace : op_lst -> unit
method modify : (modify_optype * string * string list) list -> unit
method attributes : string list
method exists : string -> bool
method get_value : string -> string list
method diff : ldapentry_t -> (modify_optype * string * string list) list
method changes : (modify_optype * string * string list) list
method changetype : changetype
method set_changetype : changetype -> unit
method flush_changes : unit
method dn : string
method set_dn : string -> unit
method print : unit
end;;
class type ldapcon_t =
object
method add : ldapentry_t -> unit
method bind :
?cred:string -> ?meth:Ldap_funclient.authmethod -> string -> unit
method delete : string -> unit
method modify :
string ->
(Ldap_types.modify_optype * string * string list) list -> unit
method modrdn : string -> ?deleteoldrdn:bool -> string -> unit
method rawschema : ldapentry_t
method schema : Ldap_schemaparser.schema
method search :
?scope:Ldap_types.search_scope ->
?attrs:string list ->
?attrsonly:bool -> ?base:string -> string -> ldapentry_t list
method search_a :
?scope:Ldap_types.search_scope ->
?attrs:string list ->
?attrsonly:bool -> ?base:string -> string -> (?abandon:bool -> unit -> ldapentry_t)
method unbind : unit
method update_entry : ldapentry_t -> unit
end
let format_entry e =
Format.open_box 0;
Format.open_box 2;
Format.print_string ("<ldapentry_t " ^ (String.escaped e#dn));
Format.force_newline ();
let length_attrs = List.length e#attributes in
let j = ref 0 in
List.iter
(fun a ->
let length = List.length (e#get_value a) in
let i = ref 0 in
Format.print_string (Printf.sprintf "(\"%s\", " (String.escaped a));
Format.open_box 0;
Format.print_string "[";
List.iter
(fun v ->
if !i < length - 1 then
(Format.print_string (Printf.sprintf "\"%s\";" (String.escaped v));
Format.print_break 1 0)
else
Format.print_string (Printf.sprintf "\"%s\"" (String.escaped v));
i := !i + 1)
(e#get_value a);
Format.print_string "]";
Format.close_box ();
(if !j < length_attrs - 1 then
(Format.print_string ");";
Format.force_newline ())
else
Format.print_string ")");
j := !j + 1)
(e#attributes);
Format.close_box ();
Format.print_string ">";
Format.close_box ()
let format_entries lst =
let length = List.length lst in
let i = ref 0 in
Format.open_box 0;
Format.print_string "[";
if length > 3 then
try
List.iter
(fun e ->
if !i > 49 then failwith "limit"
else if !i < length - 1 then begin
Format.print_string ("<ldapentry_t " ^ (String.escaped e#dn) ^ ">; ");
Format.print_cut ();
i := !i + 1
end else
Format.print_string ("<ldapentry_t " ^ (String.escaped e#dn) ^ ">"))
lst
with Failure "limit" -> Format.print_string "..."
else
List.iter
(fun e ->
if !i < length - 1 then begin
format_entry e;
Format.print_break 1 0;
i := !i + 1
end else
format_entry e)
lst;
Format.print_string "]";
Format.close_box ()
module CaseInsensitiveString =
(struct
type t = string * string
let of_string s = (s, String.lowercase s)
let to_string x = fst x
let compare x y = String.compare (snd x) (snd y)
end
:
sig
type t
val of_string: string -> t
val to_string: t -> string
val compare: t -> t -> int
end);;
module OrdOid =
struct
type t = Oid.t
let compare = Oid.compare
end;;
module OrdStr =
struct
type t = CaseInsensitiveString.t
let compare = CaseInsensitiveString.compare
end;;
(* types for a set of Oids, and a set of strings *)
module Strset = Set.Make (OrdStr)
module Setstr = Set.Make (OrdOid)
(********************************************************************************)
(********************************************************************************)
(********************************************************************************)
(* ldap entry object *)
class ldapentry =
object (self)
val mutable dn = ""
val mutable data = Hashtbl.create 50
val mutable changes = []
val mutable changetype = `ADD
method private push_change (t:modify_optype) lst =
match changetype with
`MODIFY -> (match lst with
[] -> ()
| (attr, values) :: tail ->
changes <- (t, attr, values) :: changes; self#push_change t tail)
| _ -> ()
method changetype = changetype;
method set_changetype (typ:changetype) = changetype <- typ
method flush_changes = changes <- []
method changes = changes
method exists x = Hashtbl.mem data (lowercase x)
method add (x:op_lst) =
let rec do_add (x:op_lst) =
match x with
[] -> ()
| (name, value) :: lst ->
let lcname = lowercase name in
try
Ulist.addlst (Hashtbl.find data lcname) value; do_add lst
with Not_found ->
let current = Ulist.create 5 in
Hashtbl.add data lcname current; Ulist.addlst current value; do_add lst
in
do_add x; self#push_change `ADD x
method diff (entry: ldapentry_t) =
let diff_entries e1 e2 : (modify_optype * string * string list) list =
let rec setOfList ?(set=Strset.empty) list =
match list with
a :: tail -> setOfList ~set:(Strset.add a set) tail
| [] -> set
in
let ciStringlst list =
List.rev_map
CaseInsensitiveString.of_string
list
in
let e1attrs = setOfList (ciStringlst e1#attributes) in
let e2attrs = setOfList (ciStringlst e2#attributes) in
let add_attrs =
Strset.fold
(fun attr mods ->
let attr = CaseInsensitiveString.to_string attr in
(`REPLACE, attr, e1#get_value attr) :: mods)
(Strset.diff e1attrs (Strset.inter e1attrs e2attrs))
[]
in
let remove_attrs =
Strset.fold
(fun attr mods ->
let attr = CaseInsensitiveString.to_string attr in
(`DELETE, attr, []) :: mods)
(Strset.diff e2attrs (Strset.inter e2attrs e1attrs))
[]
in
let sync_attrs =
Strset.fold
(fun attr mods ->
let attr = CaseInsensitiveString.to_string attr in
let e1vals = setOfList (ciStringlst (e1#get_value attr)) in
let e2vals = setOfList (ciStringlst (e2#get_value attr)) in
if (not (Strset.is_empty (Strset.diff e1vals (Strset.inter e1vals e2vals)))) ||
(not (Strset.is_empty (Strset.diff e2vals (Strset.inter e1vals e2vals))))
then
(`REPLACE, attr, e1#get_value attr) :: mods
else
mods)
(Strset.inter e1attrs (Strset.inter e1attrs e2attrs))
[]
in
List.rev_append remove_attrs (List.rev_append sync_attrs add_attrs)
in
(diff_entries self entry)
method delete (x:op_lst) =
let rec do_delete x =
match x with
[] -> ()
| (attr, values) :: lst ->
let lcname = lowercase attr in
match values with
[] -> Hashtbl.remove data lcname;do_delete lst
| _ ->
(try List.iter (Ulist.remove (Hashtbl.find data lcname)) values
with Not_found -> ());
(match Ulist.tolst (Hashtbl.find data lcname) with
[] -> Hashtbl.remove data lcname
| _ -> ());
do_delete lst
in
do_delete x; self#push_change `DELETE x
method replace (x:op_lst) =
let rec do_replace x =
match x with
[] -> ()
| (attr, values) :: lst -> let n = Ulist.create 5 in
Ulist.addlst n values; Hashtbl.replace data (lowercase attr) n;
do_replace lst;
in
do_replace x; self#push_change `REPLACE x
method modify (x: (modify_optype * string * string list) list) =
let rec do_modify x =
match x with
[] -> ()
| (`ADD, attr, values) :: t -> self#add [(attr, values)];do_modify t
| (`DELETE, attr, values) :: t -> self#delete [(attr, values)];do_modify t
| (`REPLACE, attr, values) :: t -> self#replace [(attr, values)];do_modify t
in
do_modify x
method attributes =
let keys hash =
let cur = ref [] in
let key k _ = cur := k :: !cur in
Hashtbl.iter key hash; !cur
in
keys data
method get_value attr = Ulist.tolst (Hashtbl.find data (lowercase attr))
method set_dn x = dn <- x
method dn = dn
method print =
print_endline "THIS METHOD IS DEPRECATED, use Ldif_oo, or rely on the toplevel printers";
print_endline ("dn: " ^ self#dn);
(List.iter
(fun a ->
(List.iter
(fun b -> print_endline (a ^ ": " ^ b))
(self#get_value a)))
self#attributes)
end
type changerec =
[`Modification of string * ((Ldap_types.modify_optype * string * string list) list)
| `Addition of ldapentry
| `Delete of string
| `Modrdn of string * int * string]
(********************************************************************************)
(********************************************************************************)
(********************************************************************************)
let to_entry ent =
let rec add_attrs attrs entry =
match attrs with
{attr_type = name; attr_vals = values} :: tail ->
entry#add [(name, values)]; add_attrs tail entry
| [] -> entry#set_changetype `MODIFY; entry
in
match ent with
`Entry {sr_dn = dn; sr_attributes = attrs} ->
let entry = new ldapentry in
entry#set_dn dn; add_attrs attrs entry
| `Referral refs ->
let entry = new ldapentry in
entry#set_dn "referral";
entry#add [("ref", refs)];
entry#add [("objectclass", ["referral"])];
entry
let of_entry ldapentry =
let rec extract_attrs ?(converted=[]) entry attrs =
match attrs with
[] -> converted
| attr :: tail ->
extract_attrs
~converted:({attr_type=attr;
attr_vals=(entry#get_value attr)} :: converted)
entry
tail
in
{sr_dn=(ldapentry#dn);
sr_attributes=(extract_attrs ldapentry ldapentry#attributes)}
let iter (f: ldapentry -> unit) (res: ?abandon:bool -> unit -> ldapentry) =
try
while true
do
f (res ());
done
with
LDAP_Failure (`SUCCESS, _, _) -> ()
| exn -> (try ignore (res ~abandon:true ()) with _ -> ());raise exn
let rev_map (f: ldapentry -> 'a) (res: ?abandon:bool -> unit -> ldapentry) =
let lst = ref [] in
(try while true
do
lst := (f (res ())) :: !lst
done
with
LDAP_Failure (`SUCCESS, _, _) -> ()
| exn -> (try ignore (res ~abandon:true ()) with _ -> ());raise exn);
!lst
let map (f: ldapentry -> 'a) (res: ?abandon:bool -> unit -> ldapentry) =
List.rev (rev_map f res)
let fold (f:ldapentry -> 'a -> 'a) (v:'a) (res: ?abandon:bool -> unit -> ldapentry) =
let value = ref v in
try
while true
do
value := (f (res ()) !value)
done;
!value
with
LDAP_Failure (`SUCCESS, _, _) -> !value
| exn -> (try ignore (res ~abandon:true ()) with _ -> ());raise exn
(* a connection to an ldap server *)
class ldapcon ?(connect_timeout=1) ?(referral_policy=`RETURN) ?(version = 3) hosts =
object (self)
val mutable bdn = ""
val mutable pwd = ""
val mutable mth = `SIMPLE
val mutable bound = true
val mutable reconnect_successful = true
val mutable con = init ~connect_timeout:connect_timeout ~version:version hosts
method private reconnect =
if bound then unbind con;
bound <- false;
reconnect_successful <- false;
con <- init ~connect_timeout:connect_timeout ~version:version hosts;
bound <- true;
bind_s ~who: bdn ~cred: pwd ~auth_method: mth con;
reconnect_successful <- true;
method unbind = if bound then (unbind con;bound <- false)
method update_entry (e:ldapentry) =
if not (reconnect_successful && bound) then self#reconnect;
try self#modify e#dn (List.rev e#changes); e#flush_changes
with LDAP_Failure(`SERVER_DOWN, _, _) -> self#reconnect;self#update_entry e
method bind ?(cred = "") ?(meth:authmethod = `SIMPLE) dn =
if not bound then begin
con <- init ~connect_timeout:connect_timeout ~version: version hosts;
bound <- true
end;
bind_s ~who: dn ~cred: cred ~auth_method: meth con;
reconnect_successful <- true;
bdn <- dn; pwd <- cred; mth <- meth
method add (entry: ldapentry) =
if not (reconnect_successful && bound) then self#reconnect;
try add_s con (of_entry entry)
with LDAP_Failure(`SERVER_DOWN, _, _) ->
self#reconnect;self#add entry
method delete dn =
if not (reconnect_successful && bound) then self#reconnect;
try delete_s con dn
with LDAP_Failure(`SERVER_DOWN, _, _) ->
self#reconnect;self#delete dn
method modify dn mods =
if not (reconnect_successful && bound) then self#reconnect;
try modify_s con dn mods
with LDAP_Failure(`SERVER_DOWN, _, _) ->
self#reconnect;self#modify dn mods
method modrdn dn ?(deleteoldrdn = true) ?(newsup: string option=None) newrdn =
if not (reconnect_successful && bound) then self#reconnect;
try modrdn_s con ~dn ~newdn:newrdn ~deleteoldrdn ~newsup
with LDAP_Failure(`SERVER_DOWN, _, _) ->
self#reconnect;self#modrdn dn ~deleteoldrdn:deleteoldrdn newrdn
method search
?(scope = `SUBTREE)
?(attrs = [])
?(attrsonly = false)
?(base = "")
?(sizelimit = 0l)
?(timelimit = 0l)
filter =
if not (reconnect_successful && bound) then self#reconnect;
try
List.rev_map to_entry
(search_s
~scope ~base ~attrs
~attrsonly ~sizelimit
~timelimit con filter)
with LDAP_Failure(`SERVER_DOWN, _, _) ->
self#reconnect;
self#search
~scope ~attrs ~attrsonly
~base ~sizelimit ~timelimit filter
method search_a
?(scope = `SUBTREE)
?(attrs = [])
?(attrsonly = false)
?(base = "")
?(sizelimit = 0l)
?(timelimit = 0l)
filter =
(* a function which is returned by search_a, calling it will give
the next entry due from the async search. The first_entry
argument is there to maintain the semantics of ldapcon's
transparent reconnection system. When search_a is called, we
fetch the first entry, and pass it in to this function. We do
this because, we will not know if the server actually recieved
our search until we read the first entry. *)
let fetch_result con (msgid:msgid) first_entry ?(abandon=false) () =
if abandon then
(Ldap_funclient.abandon con msgid;
self#reconnect;
to_entry (`Entry {sr_dn="";sr_attributes=[]}))
else
match !first_entry with (* are we on the first entry of the search? *)
`No -> to_entry (get_search_entry con msgid)
| `Yes e ->
first_entry := `No;
to_entry e
| `NoResults -> (* this search has no results *)
raise
(LDAP_Failure
(`SUCCESS, "success",
{ext_matched_dn = ""; ext_referral = None}))
in
if not (reconnect_successful && bound) then self#reconnect;
try
let first_entry = ref `No in
let msgid =
search
~scope ~base ~attrs ~attrsonly
~sizelimit ~timelimit
con filter
in
(* make sure the server is really still there *)
(try first_entry := `Yes (get_search_entry con msgid)
with LDAP_Failure (`SUCCESS, _, _) ->
(* the search is already complete and has no results *)
first_entry := `NoResults);
fetch_result con msgid first_entry
with LDAP_Failure(`SERVER_DOWN, _, _) ->
self#reconnect;
self#search_a
~scope ~attrs ~attrsonly ~base
~sizelimit ~timelimit filter
method schema =
if not (reconnect_successful && bound) then self#reconnect;
try
if version = 3 then
let schema_base = (match (self#search
~base: ""
~scope: `BASE
~attrs: ["subschemasubentry"]
"(objectclass=*)")
with
[e] -> List.hd (e#get_value "subschemasubentry")
| _ -> raise Not_found) in
(match (self#search
~base: schema_base
~scope: `BASE
~attrs: ["objectClasses";"attributeTypes";
"matchingRules";"ldapSyntaxes"]
"(objectclass=subschema)") with
[e] ->
readSchema
(e#get_value "objectclasses")
(e#get_value "attributetypes")
| _ -> raise Not_found)
else
raise Not_found
with LDAP_Failure(`SERVER_DOWN, _, _) -> self#reconnect;self#schema
method rawschema =
if not (reconnect_successful && bound) then self#reconnect;
try
if version = 3 then
let schema_base = (match (self#search
~base: ""
~scope: `BASE
~attrs: ["subschemasubentry"]
"(objectclass=*)") with
[e] -> List.hd (e#get_value "subschemasubentry")
| _ -> raise Not_found) in
(match (self#search
~base: schema_base
~scope: `BASE
~attrs: ["objectClasses";"attributeTypes";
"matchingRules";"ldapSyntaxes"]
"(objectclass=*)") with
[e] -> e
| _ -> raise Not_found)
else
raise Not_found
with LDAP_Failure(`SERVER_DOWN, _, _) -> self#reconnect;self#rawschema
end;;
(********************************************************************************)
(********************************************************************************)
(********************************************************************************)
(* A schema checking entry:
An entry which validates its validity against the server's
schema *)
(* schema checking flavor *)
type scflavor = Optimistic (* attempt to find objectclasses which make illegal
attributes legal, delete them if no objectclass can
be found *)
| Pessimistic (* delete any illegal attributes, do not add
objectclasses to make them legal*)
(* for the schema checker, should never be seen by
the user *)
exception Invalid_objectclass of string
exception Invalid_attribute of string
exception Single_value of string
exception Objectclass_is_required
let attrToOid schema (attr:Lcstring.t) =
try (Hashtbl.find schema.attributes attr).at_oid (* try canonical name first *)
with Not_found ->
(match (Hashtbl.fold
(fun k v matches ->
if (List.exists
(fun n -> attr = (Lcstring.of_string n))
v.at_name)
then
v.at_oid :: matches
else matches)
schema.attributes [])
with
[] -> raise (Invalid_attribute (Lcstring.to_string attr))
| [oid] -> oid
| _ -> raise (Invalid_attribute
("this attribute mapps to multiple oids: " ^
(Lcstring.to_string attr))));;
let oidToAttr schema (attr:Oid.t) =
List.hd (Hashtbl.find schema.attributes_byoid attr).at_name;;
let ocToOid schema (oc:Lcstring.t) =
try (Hashtbl.find schema.objectclasses oc).oc_oid
with Not_found -> raise (Invalid_objectclass (Lcstring.to_string oc));;
let oidToOc schema (oc:Oid.t) =
List.hd (Hashtbl.find schema.objectclasses_byoid oc).oc_name
let getOc schema (oc:Lcstring.t) =
try Hashtbl.find schema.objectclasses oc
with Not_found -> raise (Invalid_objectclass (Lcstring.to_string oc));;
let getAttr schema (attr:Lcstring.t) =
try Hashtbl.find schema.attributes attr
with Not_found -> raise (Invalid_attribute (Lcstring.to_string attr));;
let equateAttrs schema a1 a2 = (attrToOid schema a1) = (attrToOid schema a2)
let rec setOfList ?(set=Setstr.empty) list =
match list with
a :: tail -> setOfList ~set:(Setstr.add a set) tail
| [] -> set
class scldapentry schema =
object (self)
inherit ldapentry as super
val schemaAttrs = Hashtbl.create 50
val schema = schema
val mutable consistent = false
(* the set of all attibutes actually present *)
val mutable present = Setstr.empty
(* the set of all musts from all objectclasses on the entry *)
val mutable must = Setstr.empty
(* the set of all mays from all objectclasses on the entry *)
val mutable may = Setstr.empty
(* the set of required objectclasses *)
val mutable requiredOcs = Setstr.empty
(* present objectclasses *)
val mutable presentOcs = Setstr.empty
(* must + may *)
val mutable all_allowed = Setstr.empty
(* must - (present * must) *)
val mutable missingAttrs = Setstr.empty
(* requiredOcs - (presentOcs * requiredOcs) *)
val mutable missingOcs = Setstr.empty
(* any objectclass which depends on a missing objectclass *)
val mutable illegalOcs = Setstr.empty
(* present - (present * all_allowed) *)
val mutable illegalAttrs = Setstr.empty
(* schema checking is best expressed as set manipulations.
I can ascert this having implimented it in other ways *)
method private update_condition =
let generate_present attrs schema =
setOfList (List.rev_map (attrToOid schema) attrs) in
let rec generate_mustmay ocs schema set must =
match ocs with
oc :: tail ->
let musts = setOfList
(List.rev_map
(fun attr -> attrToOid schema attr)
(if must then (getOc schema oc).oc_must
else (getOc schema oc).oc_may))
in
generate_mustmay tail schema (Setstr.union musts set) must
| [] -> set
in
let rec lstRequired schema (oc: Lcstring.t) =
oc :: (List.flatten (List.rev_map
(fun sup -> lstRequired schema sup)
(getOc schema oc).oc_sup))
in
let rec generate_requiredocs schema ocs =
setOfList
(List.rev_map
(ocToOid schema)
(List.flatten (List.rev_map (lstRequired schema) ocs)))
in
let generate_illegal_oc missing schema ocs =
let is_illegal_oc missing schema oc =
let supchain = lstRequired schema oc in
List.exists
(fun mis ->
List.exists ((=) mis)
supchain)
missing
in
List.filter (is_illegal_oc missing schema) ocs
in
present <- (generate_present
(List.rev_map (Lcstring.of_string) super#attributes)
schema);
must <- (generate_mustmay
(List.rev_map
(Lcstring.of_string)
(try super#get_value "objectclass"
with Not_found -> raise Objectclass_is_required))
schema
Setstr.empty
true);
may <- (generate_mustmay
(List.rev_map
(Lcstring.of_string)
(try super#get_value "objectclass"
with Not_found -> raise Objectclass_is_required))
schema
Setstr.empty
false);
all_allowed <- Setstr.union must may;
missingAttrs <- Setstr.diff must (Setstr.inter must present);
illegalAttrs <- Setstr.diff present (Setstr.inter all_allowed present);
requiredOcs <- (generate_requiredocs
schema
(List.rev_map
(Lcstring.of_string)
(try super#get_value "objectclass"
with Not_found -> raise Objectclass_is_required)));
presentOcs <- (setOfList
(List.rev_map
(fun attr -> ocToOid schema (Lcstring.of_string attr))
(try super#get_value "objectclass"
with Not_found -> raise Objectclass_is_required)));
missingOcs <- Setstr.diff requiredOcs (Setstr.inter requiredOcs presentOcs);
illegalOcs <- (setOfList
(List.rev_map
(ocToOid schema)
(generate_illegal_oc
(List.rev_map
(fun x -> Lcstring.of_string (oidToOc schema x))
(Setstr.elements missingOcs))
schema
(List.rev_map
(Lcstring.of_string)
(try super#get_value "objectclass"
with Not_found -> raise Objectclass_is_required)))));
if Setstr.is_empty (Setstr.union missingAttrs illegalAttrs) then
consistent <- true
else
consistent <- false
method private drive_updatecon =
try self#update_condition
with
Invalid_objectclass(s) -> super#delete [("objectclass",[s])];self#drive_updatecon
| Invalid_attribute(s) -> super#delete [(s,[])];self#drive_updatecon
| Objectclass_is_required -> super#add [("objectclass", ["top"])]
method private reconsile_illegal flavor =
let find_in_oc oc attr = (List.exists
((=) (Lcstring.of_string attr))
oc.oc_must) ||
(List.exists
((=) (Lcstring.of_string attr))
oc.oc_may) in
let find_oc schema attr =
let oc = ref (Lcstring.of_string "") in
Hashtbl.iter
(fun key valu ->
if (find_in_oc valu attr) then oc := key)
schema.objectclasses;
if !oc = (Lcstring.of_string "") then raise Not_found;
!oc
in
match flavor with
Optimistic ->
if not (Setstr.is_empty illegalAttrs) then
((List.iter (* add necessary objectclasses *)
(fun oc -> super#add [("objectclass",[(Lcstring.to_string oc)])])
(List.rev_map
(fun attr ->
try find_oc schema attr
with Not_found -> raise (Invalid_attribute attr))
(List.rev_map (oidToAttr schema) (Setstr.elements illegalAttrs))));
self#drive_updatecon);
(* add any objectclasses the ones we just added are dependant on *)
if not (Setstr.is_empty missingOcs) then
((List.iter
(fun oc -> super#add [("objectclass", [oc])])
(List.rev_map (oidToOc schema) (Setstr.elements missingOcs)));
self#drive_updatecon);
| Pessimistic ->
(List.iter
(fun oc -> super#delete [("objectclass",[oc])])
(List.rev_map (oidToOc schema) (Setstr.elements illegalOcs)));
self#drive_updatecon;
(List.iter (* remove disallowed attributes *)
(fun attr -> super#delete [(attr, [])])
(List.rev_map (oidToAttr schema) (Setstr.elements illegalAttrs)));
self#drive_updatecon
method private drive_reconsile flavor =
try self#reconsile_illegal flavor
with Invalid_attribute(a) -> (* remove attributes for which there is no objectclass *)
(super#delete [(a, [])];
self#drive_updatecon;
self#drive_reconsile flavor)
(* for debugging *)
method private getCondition =
let printLst lst = List.iter print_endline lst in
print_endline "MAY";
printLst (List.rev_map (oidToAttr schema) (Setstr.elements may));
print_endline "PRESENT";
printLst (List.rev_map (oidToAttr schema) (Setstr.elements present));
(* printLst (Setstr.elements present);*)
print_endline "MUST";
printLst (List.rev_map (oidToAttr schema) (Setstr.elements must));
(* printLst (Setstr.elements must);*)
print_endline "MISSING";
printLst (List.rev_map (oidToAttr schema) (Setstr.elements missingAttrs));
(* printLst (Setstr.elements missingAttrs);*)
print_endline "ILLEGAL";
printLst (List.rev_map (oidToAttr schema) (Setstr.elements illegalAttrs));
print_endline "REQUIREDOCS";
(* printLst (List.rev_map (oidToOc schema) (Setstr.elements requiredOcs));*)
printLst (List.rev_map Oid.to_string (Setstr.elements requiredOcs));
print_endline "PRESENTOCS";
(* printLst (List.rev_map (oidToOc schema) (Setstr.elements presentOcs));*)
printLst (List.rev_map Oid.to_string (Setstr.elements presentOcs));
print_endline "MISSINGOCS";
(* printLst (List.rev_map (oidToOc schema) (Setstr.elements missingOcs));*)
printLst (List.rev_map Oid.to_string (Setstr.elements missingOcs));
print_endline "ILLEGALOCS";
(* printLst (List.rev_map (oidToOc schema) (Setstr.elements illegalOcs))*)
printLst (List.rev_map Oid.to_string (Setstr.elements illegalOcs));
(* for debugging *)
method private getData = (must, may, present, missingOcs)
method of_entry ?(scflavor=Pessimistic) (e:ldapentry) =
super#set_dn (e#dn);
super#set_changetype `ADD;
(List.iter
(fun attr ->
try
(super#add
(try
self#single_val_check [(attr, (e#get_value attr))] true;
[(attr, (e#get_value attr))]
with (* remove single valued attributes *)
Single_value _ -> [(attr, [List.hd (e#get_value attr)])]))
with (* single_val_check may encounter unknown attributes *)
Invalid_attribute _ | Invalid_objectclass _ -> ())
e#attributes);
self#drive_updatecon;
self#drive_reconsile scflavor
(* raise an exception if the user attempts to have more than
one value in a single valued attribute. *)
method private single_val_check (x:op_lst) consider_present =
let check op =
let attr = getAttr schema (Lcstring.of_string (fst op)) in
(if attr.at_single_value then
(match op with
(attr, v1 :: v2 :: tail) -> false
| (attr, v1 :: tail) ->
(if consider_present && (super#exists attr) then
false
else true)
| _ -> true)
else true)
in
match x with
op :: tail -> (if not (check op) then
raise (Single_value (fst op))
else self#single_val_check tail consider_present)
| [] -> ()
method add x =
self#single_val_check x true;super#add x;
self#drive_updatecon;self#drive_reconsile Optimistic
method delete x =
super#delete x;self#drive_updatecon;self#drive_reconsile Pessimistic
method replace x =
self#single_val_check x false;super#replace x;
self#drive_updatecon;self#drive_reconsile Optimistic
method modify x =
let filter_mod x op =
List.rev_map
(fun (_, a, v) -> (a, v))
(List.filter
(function (the_op, _, _) when the_op = op -> true | _ -> false) x)
in
self#single_val_check (filter_mod x `ADD) true;
self#single_val_check (filter_mod x `REPLACE) false;
super#modify x;
self#drive_updatecon;
self#drive_reconsile Pessimistic
method get_value x =
try super#get_value x with Not_found ->
if (Setstr.mem (attrToOid schema (Lcstring.of_string x)) missingAttrs) then
["required"]
else
raise Not_found
method attributes =
List.rev_append
super#attributes
(List.rev_map
(fun a -> oidToAttr schema a)
(Setstr.elements missingAttrs))
method list_missing = Setstr.elements missingAttrs
method list_allowed = Setstr.elements all_allowed
method list_present = Setstr.elements present
method is_missing x =
Setstr.mem (attrToOid schema (Lcstring.of_string x)) missingAttrs
method is_allowed x =
Setstr.mem (attrToOid schema (Lcstring.of_string x)) all_allowed
end;;
(********************************************************************************)
(********************************************************************************)
(********************************************************************************)
(* a high level interface for accounts, and services in the directory *)
type generator = {gen_name:string;
required:string list;
genfun:(ldapentry_t -> string list)};;
type service = {svc_name: string;
static_attrs: (string * (string list)) list;
generate_attrs: string list;
depends: string list};;
type generation_error = Missing_required of string list
| Generator_error of string
exception No_generator of string;;
exception Generation_failed of generation_error;;
exception No_service of string;;
exception Service_dep_unsatisfiable of string;;
exception Generator_dep_unsatisfiable of string * string;;
exception Cannot_sort_dependancies of (string list);;
let diff_values convert_to_oid convert_from_oid attr attrvals svcvals =
(attr, (List.rev_map
convert_from_oid
(Setstr.elements
(Setstr.diff
svcvals
(Setstr.inter svcvals attrvals)))))
(* compute the intersection of values between an attribute and a service,
you need to pass this function as an argument to apply_set_op_to_values *)
let intersect_values convert_to_oid convert_from_oid attr attrvals svcvals =
(attr, (List.rev_map
convert_from_oid
(Setstr.elements
(Setstr.inter svcvals attrvals))))
(* this function allows you to apply a set operation to the values of an attribute, and
the static values on a service *)
let apply_set_op_to_values schema (attr:string) e svcval opfun =
let lc = String.lowercase in
let convert_to_oid = (match lc ((getAttr schema (Lcstring.of_string attr)).at_equality) with
"objectidentifiermatch" ->
(fun oc -> ocToOid schema (Lcstring.of_string oc))
| "caseexactia5match" -> Oid.of_string
| _ -> (fun av -> Oid.of_string (lc av)))
in
let convert_from_oid = (match lc ((getAttr schema (Lcstring.of_string attr)).at_equality) with
"objectidentifiermatch" -> (fun av -> oidToOc schema av)
| "caseexactia5match" -> Oid.to_string
| _ -> Oid.to_string)
in
let attrvals = setOfList
(List.rev_map
convert_to_oid
(try e#get_value attr with Not_found -> []))
in
let svcvals = setOfList (List.rev_map convert_to_oid (snd svcval))
in
opfun convert_to_oid convert_from_oid attr attrvals svcvals
class ldapaccount
schema
(generators:(string, generator) Hashtbl.t)
(services:(string, service) Hashtbl.t) =
object (self)
inherit scldapentry schema as super
val mutable toGenerate = Setstr.empty
val mutable neededByGenerators = Setstr.empty
val services = services
val generators = generators
(* evaluates the set of missing attributes to see if any of
them can be generated, if so, it adds them to be generated *)
method private resolve_missing =
(* computes the set of generateable attributes *)
let generate_togenerate generators missing togenerate =
(* generators have dependancies. Some of the dependancies can
also be generated. We can generate a dependancy if the following
conditions are met.
1. The dependancy is in the generators hash (it has a generation function)
2. The dependancy is allowed by the schema (it is either a must or may of
an objectclass currently on the object)
3. The dependancy is not already present (if it is present already then it
has already been satisfied, and there is no need to generate it) *)
let find_generatable_dep generators generator =
(List.rev_map
(fun e -> attrToOid schema (Lcstring.of_string e))
(List.filter
(fun g ->
if ((Hashtbl.mem generators g) &&
(not (Setstr.mem
(attrToOid schema (Lcstring.of_string g))
(setOfList self#list_present)))) then
true
else false)
(List.filter (* we can only add it if it is allowed by the schema *)
(fun attr -> super#is_allowed attr)
(Hashtbl.find generators generator).required)))
in
(* collect a flat list of all generatable dependancies *)
let rec find_generatable_deps generators genlst =
(List.flatten
(List.rev_map
(find_generatable_dep generators)
genlst))
in
(* the set we are currently generating, union the set of missing attributes which we
can generate. *)
let generateing = (List.filter
(fun gen ->
if (Hashtbl.mem generators (lowercase (oidToAttr schema gen))) then
true
else false)
(List.rev_append
missing
(Setstr.elements togenerate)))
in
(* the total set of generatable at any point in time is. The set
we are already generating, unioned with any generatable dependancies, unioned
with the set of missing attributes (required by the schema) which can be generated.
Note, the last union is done in the generateing expression above. *)
setOfList
(List.rev_append generateing (find_generatable_deps
generators
(List.rev_map
(fun e -> lowercase (oidToAttr schema e))
generateing)))
in
let generate_missing togen generators =
setOfList
(Hashtbl.fold
(fun key valu requiredlst ->
if Setstr.mem (attrToOid schema (Lcstring.of_string valu.gen_name)) togen then
List.rev_append
requiredlst
(List.rev_map
(fun x -> try
attrToOid schema (Lcstring.of_string x)
with Invalid_attribute a ->
raise (Generator_dep_unsatisfiable (key, a)))
valu.required)
else
requiredlst)
generators [])
in
toGenerate <- generate_togenerate generators super#list_missing toGenerate;
neededByGenerators <- generate_missing toGenerate generators;
method list_missing =
let allmissing =
Setstr.union neededByGenerators (setOfList super#list_missing)
in
Setstr.elements
(Setstr.diff
allmissing
(Setstr.inter
allmissing
(Setstr.union
toGenerate
(setOfList super#list_present))))
method attributes =
(List.rev_map (oidToAttr schema)
(Setstr.elements
(Setstr.union toGenerate
(setOfList
(List.rev_map
(fun a -> attrToOid schema (Lcstring.of_string a))
super#attributes)))))
method is_missing x = (not (Setstr.mem
(attrToOid schema (Lcstring.of_string x))
toGenerate))
|| (super#is_missing x)
method generate =
let sort_genlst generators unsatisfied =
let satisfied alreadysatisfied present deps =
List.for_all
(fun dep ->
(List.mem dep alreadysatisfied) ||
(List.mem (attrToOid schema (Lcstring.of_string dep)) (present)))
deps
in
let rec sort present ordtogen unsatisfied =
match unsatisfied with
[] -> ordtogen
| todo ->
let (aresat, notyet) =
(List.partition
(fun attr ->
(satisfied ordtogen present
(Hashtbl.find generators attr).required))
todo)
in
match aresat with
[] -> raise (Cannot_sort_dependancies notyet)
| _ -> sort present (ordtogen @ aresat) notyet
in
sort (self#list_present) [] unsatisfied
in
match self#list_missing with
[] ->
(List.iter
(fun attr ->
self#add [(attr, (Hashtbl.find generators attr).genfun (self:>ldapentry_t))])
(sort_genlst generators
(List.rev_map
(fun elt -> String.lowercase (oidToAttr schema elt))
(Setstr.elements toGenerate))));
toGenerate <- Setstr.empty
| a -> raise (Generation_failed
(Missing_required (List.rev_map (oidToAttr schema) a)))
method get_value x =
if (Setstr.mem (attrToOid schema (Lcstring.of_string x)) toGenerate) then
["generate"]
else
super#get_value x
(* adapt the passed in service to the current state of the entry
this may result in a service with applies no changes. The entry
may already have the service. *)
method adapt_service svc =
{svc_name=svc.svc_name;
static_attrs=(List.filter
(fun cons ->
match cons with
(attr, []) -> false
| _ -> true)
(List.rev_map
(fun cons -> apply_set_op_to_values schema (fst cons) self cons diff_values)
svc.static_attrs));
generate_attrs=(List.filter
(fun attr ->
(try (ignore (super#get_value attr));false
with Not_found -> true))
svc.generate_attrs);
depends=svc.depends}
(* add a service to the account, if they already satisfy the service
then do nothing *)
method add_service svc =
let service = try Hashtbl.find services (lowercase svc)
with Not_found -> raise (No_service svc) in
(try List.iter (self#add_service) service.depends
with (No_service x) -> raise (Service_dep_unsatisfiable x));
let adaptedsvc = self#adapt_service service in
(let do_adds a =
let singlevalu =
(List.filter
(fun attr -> (getAttr schema
(Lcstring.of_string (fst attr))).at_single_value) a)
in
let multivalued =
(List.filter
(fun attr -> not (getAttr schema
(Lcstring.of_string (fst attr))).at_single_value) a)
in
self#add multivalued;
self#replace singlevalu
in
do_adds adaptedsvc.static_attrs);
(match adaptedsvc.generate_attrs with
[] -> ()
| a -> List.iter (self#add_generate) a)
method delete_service svc =
let find_deps services service =
(Hashtbl.fold
(fun serv svcstruct deplst ->
if (List.exists ((=) service) svcstruct.depends) then
serv :: deplst
else
deplst)
services [])
in
let service = try Hashtbl.find services (lowercase svc)
with Not_found -> raise (No_service svc) in
(List.iter (self#delete_service) (find_deps services svc));
(List.iter
(fun e -> match e with
(attr, []) -> ()
| a -> (try (ignore (super#get_value (fst a)));super#delete [a]
with Not_found -> ()))
(List.rev_map
(fun cons ->
apply_set_op_to_values schema (fst cons) self cons intersect_values)
service.static_attrs));
(List.iter
(fun attr ->
(try (match self#get_value attr with
["generate"] -> self#delete_generate attr
| _ -> super#delete [(attr, [])])
with Not_found -> ()))
service.generate_attrs)
method service_exists service =
let service = (try (Hashtbl.find services service)
with Not_found -> raise (No_service service))
in
match self#adapt_service service with
{svc_name=s;
static_attrs=[];
generate_attrs=[];
depends=d} -> (match d with
[] -> true
| d -> List.for_all self#service_exists d)
| _ -> false
method services_present =
Hashtbl.fold
(fun k v l ->
if self#service_exists v.svc_name then
v.svc_name :: l
else l)
services []
method of_entry ?(scflavor=Pessimistic) e = super#of_entry ~scflavor e;self#resolve_missing
method add_generate x =
(if (Hashtbl.mem generators (lowercase x)) then
toGenerate <- Setstr.add (attrToOid schema (Lcstring.of_string x)) toGenerate
else raise (No_generator x));
self#resolve_missing
method delete_generate x =
let find_dep attr generators =
(Hashtbl.fold
(fun key valu deplst ->
if (List.exists ((=) attr) valu.required) then
key :: deplst
else
deplst)
generators [])
in
(List.iter (self#delete_generate) (find_dep x generators));
toGenerate <-
Setstr.remove
(attrToOid schema (Lcstring.of_string x)) toGenerate
method add x = (* add x, remove all attributes in x from the list of generated attributes *)
super#add x;
(List.iter
(fun a ->
toGenerate <- (Setstr.remove
(attrToOid schema (Lcstring.of_string (fst a)))
toGenerate))
x);
self#resolve_missing
method delete x = super#delete x;self#resolve_missing
method replace x = (* replace x, removeing it from the list of generated attrs *)
super#replace x;
(List.iter
(fun a ->
toGenerate <- (Setstr.remove
(attrToOid schema (Lcstring.of_string (fst a)))
toGenerate))
x);
self#resolve_missing
end;;