ldap-2.5.1/0000755000175000017500000000000014652453725014054 5ustar kit_ty_katekit_ty_kateldap-2.5.1/.gitignore0000644000175000017500000000003614652453725016043 0ustar kit_ty_katekit_ty_kate/_build .merlin /ldap.install ldap-2.5.1/COPYING0000644000175000017500000000143414652453725015111 0ustar kit_ty_katekit_ty_kateCopyright (C) 2004 Eric Stokes, Matthew Backes, 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 ldap-2.5.1/Changelog0000644000175000017500000006305214652453725015674 0ustar kit_ty_katekit_ty_kate2.5.1 (31/07/2024) ------------------ * Fix double escaping of backslashes (by @glondu) 2.5.0 (30/07/2024) ------------------ * Disable implicit transitive dependencies when building * Use camlp-streams to remove a deprecation warning in OCaml 4.14 (by @glondu) * Switch from using pcre to re (pure OCaml regexp implementation) (co-authored by @glondu) 2.4.2 (25/10/2020) ------------------ * Upgrade to dune 2.7 * Cleanup: Remove every warnings (tested from OCaml 4.03 to 4.11) * Drop the OCaml 4.02 compatibility * Setup a documentation website at https://kit-ty-kate.github.io/ocamldap * Add new module Ldif_types to host an exeption raised in Ldif_changerec_parser.changerec instead of `Failure "end"` 2.4.1 ----- * Switched from jbuilder to dune * Fix suspicious int literal (by @hhugo) * Fix up mli to conform to ocamldoc levels (avoiding 0) (by @bluddy) 2.4.0 ----- * Switched from OASIS to jbuilder * ocamldap is now a meta-package in opam that pulls a newly created ldap package. 2.3.0 ----- * Enable OCaml >= 4.02 compatibility * Enable safe-string compatibility * Backport fixes from 2.1.8 * Use OASIS to build the documentation * Bug fixed: Ldap_protocol doesn't handle SASL correctly (RFC 4511 4.2.2) (Patch by David Allsopp) * Added paged result control (Patch by Christian Wills) * Fix: Add Str to the build dependencies 2.2 --- * OCaml 4 compatibility * Modularize the library in sub-libraries: ldap ldap.ldif ldap.toplevel * Use oasis * Repository cleaning * Maintainer changed * Switch from svn to git 2.1.8 ----- * Fix (See c89bddc) 2.1.7 ----- * Fixed a bug in search_a, if a search results in zero results an exception (LDAP_Failure (`SUCCESS, ..)) was being raised by the search_a function instead of by the closure which it returnes. 2.1.7 handles this case correctly, the exception is only raised by the closure which is returned. 2.1.6 ----- * Fixed a bug in the filter parser, it was rejecting filters of the form uid=cn=... which are valid filters. * fixed several bugs in the output of ldif change records * Ldap_ooclient.fold now runs in constant stack space in the presence of arbitrarially complex exception handlers. * Ldap_ooclient.ldapcon.search_a makes an effort to detect if the server is really still there before returning the cursor function. It does this by trying to download the first object. This should eliminate errors when starting an async search with a connection which has timed out (it will now reconnect automatically). * Ldap_ooclient.ldapcon.search_a, the cursor now does a reconnect when the operation is abandoned. This clears a lot of common problems, however one gotcha is that all currently active async operations will be ended if one of them abandons. This is usually not a problem however, since an abandon is almost always caused by a serious error. 2.1.5 ----- * Fixed a bug in the delete method of ldapentry, it would not correctly process a list of deleteions in a certian case * Added two new functions to ldif_oo, read_ldif_file, and write_ldif_file. The former reads all the entries in an ldif file into a list of entries, while the latter writes all the entries in the given list to an ldif file. * Added an object locking table to ldap_mutex, which allows individual objects to be locked (advisory locking like POSIX flock) * Applied a patch which makes the toplevel printers to pass all data through String.escaped, and which adds a close bracket which was missing in some cases.Thanks to Victor Seletsky for this patch. * Changed the toplevel printer to print a max of 50 entries, to avoid overwhelming emacs. At some point I want to make this configurable. * Added a function to return the canonical dn to Ldap_dn. * Improved (drastically) the ldap_strerror, and ldap_perror functions, they now print out something which looks exactly like the string representation of an LDAP_Failure exception in the toplevel. Avid users of the toplevel will hopefully appreciate this as much as I do. 2.1.4 ----- * Changed the type of the result of the low level ldif parser (Ldif_parser) to produce search_result_entry instead of its own type. This allows better cross module communication, and simplified the Ldif_oo module's job a bit. * Fixed a bug in the ldif pretty printer. It would print values containing only white space, or with leading white space without base64 encoding them, this is an error. * 2.5x decoder speedup. (4.0 MB/s sustained on an 800Mhz G4). The bytecode decoder is now 10% faster than the original native code compiled decoder released in 2.0, and it is 14 times faster than Perl's Net::LDAP library. * Fixed a bug in the ssl readbyte implementation which could cause data loss to occurr if peeking very far ahead. * The print method of ldapentry is now deprecated 2.1.3 ----- * Added toplevel pretty printers for Oid.t, Lcstring.t, and ldapentry_t * fixed in readbyte_of_fd, upon reading the C code for this function I realized that under some conditions Unix.in_channel_of_fd may fail. I was not aware of this previously. We now catch the resulting Sys_error, and change it to a Transport_error. It is very unlikely that this would ever happen. * Added a parser and pretty printer for extended ldif as used by openldap. ldif change records can now be read and written from and to nice data structures. I implemented this because I needed to read replogs from slurpd. * Fixed the ldap_url module, it will now raise Invalid_ldap_url when it fails to parse the url, instead of raising a generic exception such as Failure. * Fixed the regular expression for safe-string to actually detect non safe strings, which will be base64 encoded. * Fixed the encoding/decoding of substring filters, which did not perfectly follow the standard. * Fixed a bug in the filter grammar which would not allow multiple substring components * Fixed multiple bugs in the changerec parser and lexer * Added a new module, ldap_mutex, which implements mutexes in an ldap database using it's build in test and set mechanism. You can use this to implement advisory locking around various database operations such as the allocation of unique ids, and transactions. * Added documentation for the ldap_toplevel module, and improved the modify command. 2.1.2 ----- * fixed a bug in the encoding of substring filters, the length was not being computed correctly. * fixed a bug in diff, when syncing attributes it was not considering values which were not on the master, but were on the replica. This has been fixed. * added a dn parser and pretty printer which conforms to rfc 2253 * added an exception Invalid_filter to the filter parser, it will raise this exception whenever there is an error. In addition to a string the exception contains an int, which indicates at which charachter the parser failed. * fixed a bug in the filter parser which allowed it to accept filters with garbage at the end. * exposed the escaping functions for attribute values in the dn parser, and the filter parser. These functions are intended to be used when you are manually manipulating stringified versions of the dn or filter via regular expressions or other means. * added some functions which are designed to be used from the toplevel for quick searches, and modifies. These are a work in progress. 2.1.1 ----- * Changed Lcstring to work like it used to, added a new module CaseInsensitiveString which does case preserving case insensitive comparisons. 2.1.0 ----- * ocaml-ssl is now required * BER Decoder - Improved decoding performance, 2x speedup. Beats OpenLDAP 2.2's decoder by about 5% (tested on PPC Mac OS 10.3, and Intel Linux) - Fixed decoding of negative integers - Fixed decoding of error codes to comply with rfc2251. Unknown error codes will now be returned as `OTHER according to the rfc. - Fixed buggy decoding of ldap controls. They were not well tested until now, and several misinterpertations of the standard existed. - Fixed a bug which only happens when controls are asserted, some operations with optional values at the end would fail to decode when the control was present because of improper boundry setting. Boundries are now set at the end of each operation. * BER Encoder - Fixed several bugs in the encoding of two's complement integers where the sign bit was not being handled correctly. This never effected ldap clients, but severly limited the functionality of ldap servers. They would be unable to respond to requests with message id 128, which would cause most clients to hang - Fixed discrepancies between the ldap_errorcode variant type, and the type recognized by encode_ldapresultcode. They are not the same type, and no exception can be raised, the compiler will prove that client code doesn't send a variant which cannot be recognized. * ldap_funclient - Studied OpenLDAP's client library in depth, and adapted msgid allocation to look exactly like theirs. This will expose fewer bugs in ldap servers. - Changed the msgid type to an int32 (this should not be a visible change, it is an opaque type). - Refactored readbyte implementations, moved them to lber.ml, and tightened their exception handling. * ldap_ooclient - connect_timeout is now available as an optional argument to ldapcon. - added a method called "diff" to the ldapentry higharchy. It takes an entry and returns a list of differences between itself and the specified entry in the form of a modify record. * ldap_funserver - Deal with protocol errors according to rfc2251 - Use the new readbyte implementations in lber.ml instead of a custom one - Implemented a logging harness. You pass in a function (optional) to init which takes a log level, and a string. The server will send your function log lines which exactly match the log format of OpenLDAP. The default function does nothing with the log lines. A parser for this log format is in the works and will be released as a seperate library. * LDIF Parser improvements - Improved the performance of write_entry, and to_string in Ldif_oo - Fixed a bug in the LDIF parser which could cause it to return the wrong line count when it finds a syntax error. * RFC 2252 schema parser/lexer - Fixed a typo in the lexer which would cause it not to correctly lex non numeric OIDs - Fixed bad lexing of X- attributes. There was an error in the definition of qdstring which would cause the lexer to eat all of the X- attributes in one pass. Tested fix with Active Directory 2003, OpenLDAP, and Novell eDirectory. - Changed the type of the attribute length field in the attribute record of the schema parser to be an Int64. The standard does not define the numeric range, and vendors (Novell) use huge numbers. * Schema Checker - Handled the case where the entry being checked does not have the objectclass attribute. Objectclass: top will be now be added in this case. - Fixed a bug in the "of_entry" method. It did not do a full schema check after importing the entry, so after calling of_entry the scldapentry was not proven to be valid. * Url Parser - Fixed a bug which could cause the url parser to return the wrong hostname if the hostname specified contained illegal characters. * Error Handling - moved err2string to a new module Ldap_error, which will contain functions for doing various things with LDAP_Failure exceptions. This WILL break existing applications which use err2string, however it is a simple matter of opening Ldap_error to fix them. - Implemented ldap_perror, and ldap_strerror functions, which either print, or return nicely formatted strings describing an LDAP_Failure exception. 2.0.3 ----- * Handle additional Unix_error exceptions as reconnection events, including EPIPE, ECONNRESET, and ECONNABORTED. Not handling these exceptions caused the library not to autoreconnect when the connection was dropped under certian circumstances. 2.0.2 ----- * Fixed a bug in the way delete was encoded which prevented it from working 2.0.1 ----- * Fixed a major bug in async calls. 2.0 --- * Complete reimplementation of the low levels. - Pure Ocaml lber, and ldap protocol implementation. Ocamldap is no longer a C binding. - Server side as well as client side encoding/decoding functions. You can now make ldap servers with Ocamldap, as well as be a client! - No code optimization has been done yet, however the decoding performance is within 50% of the C library on the same hardware! Encoding performance has not been tested yet. * Some api changes to support additional error information, referrals and enhanced client side reliability. Minimal OO api changes, fairly significant lower level api changes * Module name reorganization. Painful, but it can only get worse if we let it stay the way it was. These two changes are the main reason for the 2.0 stamp. * Greatly simplified build system * All portions of the library are now covered by the LGPL license 1.6.5 ----- * added a configure script generated with autoconf which aids portability 1.6.4 ----- * Fixed a typo (DOH!) in ooldap which could cause crashes in some rare cases when the library is not used exactly as intended. 1.6.3 ----- * Fixed a subtle bug in transparent reconnections which would occurr if your ldap server did not come back up fast after the connection failed. It would cause LDAP_Failure `STRONG_AUTH_REQUIRED to be raised for every operation after the server went down. There are still some bugs which I have not found. Spesifically, it is not a good idea to call unbind, and then use the object again. I've gotten libldap to die with an ascertion failure from doing this. However so far I can't identify the pattern. This isn't really a supported operation, and it has been very stable otherwise. 1.6.2 ----- * The new map, and search_s routines were not being tail call optimized in the byte code environment. This made doing long searches in the toplevel loop impossible. * added a new method to ldapentry and subclasses. modify. Useful in many ways. It takes a regular Ocamldap modify structure, so it can help with migration. I think the most useful thing about it is that the changes method outputs an Ocamldap modify structure, so you can sync changes between entries by calling changes, and then using modify to move them to another entry. 1.6.1 ----- * fixed a bug in the new code. was not checking the result of ldap_result, which resulted in an ascert failure when the connection was dropped. It is supposed to generate an exception. 1.6.0 ----- * reimplemented the glue code for search. The new code uses the async calls, and has some efficency problems removed. The low level api is broken in a small way by this, the type of entry has changed. attributes are now a list, instead of an array. * Added an async search call to the high level OO environment. search_a. It returns a function of type (unit -> ldapentry) which you can call to get your results. Also added iterator functions which are compatible with this new call. iter, map, rev_map, and fold. They take a (unit -> ldapentry) function, and a user supplied function and iterate just like the list operators. See the newly improved testoo.ml program. * Gutted the old build system and switched to OCamlMakefile for a better building experiance. Also, now actually build the glue code as a .so, so you don't need to build a custom toplevel in order to use ocamldap in it. Yaaaaah. * REMOVED the finalization function on ldapcon in the high level api.This was causing problems in that it would try to finalize the object whenever I returned a closure from one of it's methods. Caused many Bus Errors and Segfaults, took an hour with valgrind to actually figure out what was going on. found no work around, so. Release your ldap objects manually on pain of memory and fd leaks. sorry :( * Referrals are broken again! However, this is a step in the right direction, because I now have control over them. I'm going to be doing a lot of thinking about how to handle them. Right now if you have a referral in your directory you will get LDAP_Failure `LOCAL_ERROR at the end of your async search. You can just consider it success. This is what search_s does, all the iter functions will do it for you. 1.5.0 ----- * The library now depends on findlib, and ocamlnet. It will not compile without them. * added two new methods to ldapaccount service_exists, and services present, which allow the user to inspect what services are on an object. * Fixed a bug in ldapaccount. When computing whether it is possible to generate a dependancy of a generator it was not being taken into account whether the dependancy was allowed by the schema. ldapaccount, and scldapentry generally try to avoid adding objectclasses for you, because some attributes are allowed by so many objectclasses, and inference will pick the first one which allows the attribute. For things like "cn" you can end up with some very strange objectclasses on your objects. As a result attributes on which a generator is dependant, which could also be generated, but are not currently allowed, are no longer considered. * in the ldif parser added support for reading entries with base64 values (Matthew Backes) * added a new method to ooldif, write_entry, which writes an entry to ldif with base64 support. * added two new methods to ooldif, to_string, and of_string to write an entry to an ldif string, and read an entry from an ldif string * added rudimentry support for referrals. Don't raise an exception when we get LDAP_REFERRAL back from ldap_search_s. It seems that openldap's libldap follows referrals transparently, which could be both good and bad. Either way, referrals will need futher invesigation. 1.4.6 ----- * fixed a bug in the ldif parser which prevented the last entry in an ldif file from being read. * fixed the ldif parser so that a file with just a dn is a valid ldif file. * added an unbind method to ldapcon, for explicit deallocation of sockets. * added a finalisation function to ldapcon which calls unbind. It IS safe to call unbind explicitly, the object will handle the case that it is unbound twice gracefully. * fixed a bug in delete service which could cause it not to delete all the attribute values that it should. 1.4.5 ----- * fixed a bug in transparent reconnections which would cause an infinite loop. 1.4.4 ----- * exposed an exception called "Cannot_sort_dependancies of string list" which indicates that circular dependancies have been detected among the attributes of the list. The exception will be raised when calling the generate method of an ldapaccount 1.4.3 ----- * changed the way the delta between an object and a service is computed. Instead of always doing a case sensitive match of the attribute values we now look up the matching rule in the schema and try to apply something close. We currently understand objectIdentifierMatch, caseIgnoreMatch, and caseExactIA5Match. I will probably add more later. 1.4.2 ----- * adds modrdn support in ooldap, which was horribly omitted previously * fixed a bug in the service code with respect to single valued attributes, and static service attributes. Previously, an object which needed to have a static attribute to satisfy a service would always get it be adding a second value. This won't work for single value attributes for obvious reasons. The fix is to check if the attribute is single valued, and if it is, replace it, otherwise, add it. 1.4.1 ----- * fixes a bug in the schema parser. X-.* attributes were not previously supported. 1.4.1 adds support for them. 1.4.0 ----- * added two new classes to the Ooldap module. - scldapentry understands the directory schema, and makes use of it in various ways. It is a subclass of ldapentry - ldapaccount is built on top of scldapentry. It understands the schema, and how to generate certian attributes (based on functions you give it). It also has a the ability to group attributes together into things it calls services, which can be added and removed atomically. 1.3.2 ----- * fixed massive memory leaks in the search C glue code 1.3.1 ----- * fixed some serious bugs in the C glue code which could cause the garbage collector to go nuts. * performance improvements in the way entry objects are arranged this will improve performance for searching, local modifications and the ldif parser. I haven't done another test, but the ldif parser spitting out entries is most likely just as fast as the engine (~26s for a 50MB ldif file on a PPC7450 800Mhz). 1.3.0 ----- * Added an rfc2252 schema parser, and an interface to grab schema's from the server, see ooldap.mli, the method schema. See schemaparser.ml for the structure of the record returned. * performance enhancements to the ldif parser, ~3x improvement in parseing speed. Native code can parse a 50MB ldif file in ~38 seconds, bytecode takes about 1m45s for the same file. Obviously different files yeild different results. There is further room for improvement in the building of the entry objects. The engine alone in native code parses the 50MB file in ~26 seconds, so the rest is the overhead of building the entry objects. All tests were performed on an 800Mhz G4. * Fixed a bug with update_entry which caused changes to be applied in reverse order. This often breaks the symantics when replace is involved. 1.2.0 ----- * Added support for transparently reconnecting to servers which have dropped the connection. Often servers will have an idle time out for connections. This is avaliable in the object oriented api only. It should create the illusion that the connection was never dropped. It can also be usefull in the case where one server in a failover cluster goes down. As long as something is there to take its place, the user of the api will never know that a server went down. This feature is experimental, but should work :). This is great for interactive sessions. * Added a standards compliant ldif parser. You can send it a stream of ldif, and by calling a method, get back an ldapentry object. See ooldif.mli for details. The known bugs are, its a bit slow, and it won't do anything with base64 encoded values. If you wish to decode them, do it yourself for now. Things of note, the parser is "picky" in that it tries to follow the rfc to the letter, it will generally not accept malformed ldif. Some users may consider that annoying, but we actually used it to find several errors in our directory server :), so it has advantages too. * Changed make dep to preprecess using cpp instead of camlp4o, due to strange undocumented changes in 3.07. I really need to look into this and fix it. * Changed the get_value method of ldapentry to raise Not_found instead of return the empty list when it is queried for an attribute which doesn't exist. Please complain if this annoys you. 1.1.2 ----- * Added a patch from Sylvain Le Gall to ease packaging for debian. * Added another patch from Sylvain Le Gall which adds support for making documentation with ocamldoc. 1.1.1 ----- * fixed the makefile to properly honor CFLAGS. This makes it possible to build on systems where the ldap libraries are in a nonstandard place * added findlib support. make install now installs a package called "ocamldap". 1.1.0 ----- * Eric Stokes has taken over maintanence of the project * added a new object oriented interface modeled after Net::LDAP in perl. * added an optional argument to init which allows selection of the protocal version. It defaults to 3. 1.0 --- * added fixes from Eric Stokes: * added make dep to build dependencies * modified print_entry to print more ldif like output (it does not break up long lines correctly yet) 0.3.1 ----- * added fixes from Eric Stokes: * updated varcc with the latest version from labgtk * fixed ocamldap_tags.var to work with the new varcc * changed build scripts to allow compilation under 3.06 * added ifdefs to remove kerberos support if not avaliable 0.3 --- * added kerberos binding methods * added modrdn methods * most function arguments are lists now * fixed crash bug in search_s 0.2 --- * add, modify, and delete are implemented * all ldap error codes are supported with the help of varcc * silly bugs fixed in bind and unbind 0.1 --- * first Release by Miles Egan * only synchronous searches are supported ldap-2.5.1/README0000644000175000017500000000260614652453725014740 0ustar kit_ty_katekit_ty_kateocamldap - Ocamldap is an implementation of the Light Weight Directory Access Protocol ====================================================================================== --------------------------------------------------------------------------- Synopsis --------------------------------------------------------------------------- Ocamldap is an ldap toolkit. It can be used by ocaml programs to communicate with ldap servers, and to build your own ldap servers. --------------------------------------------------------------------------- Features --------------------------------------------------------------------------- * Ocamldap supports the core ldap-client functions, including search, add, modify, and delete. * object oriented interface with additional features. Such as, nice data structures for local ldap entries which record local modifications and can sync them with the server, fewer arguments needed to perform simple tasks, and transparent reconnection of dropped connections. * Ocamldap includes an ldif parser, which allows you to read ldif files into entry objects. It also supports ldif change records. * Ocamldap has a method call to grab the schema of an ldapv3 server * Basic ldap server functionality (ldap_funserver) allows you to easily construct your own ldap servers. Perfect for meta directories, and other cool projects. Someday maybe your main database :-) ldap-2.5.1/dune-project0000644000175000017500000000014414652453725016375 0ustar kit_ty_katekit_ty_kate(lang dune 2.7) (name ldap) (version 2.5.1) (formatting disabled) (implicit_transitive_deps false) ldap-2.5.1/ldap.opam0000644000175000017500000000145614652453725015660 0ustar kit_ty_katekit_ty_kateopam-version: "2.0" version: "2.5.1" synopsis: "Implementation of the Light Weight Directory Access Protocol" maintainer: ["Kate "] authors: ["Eric Stokes "] license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" tags: ["ldap"] homepage: "https://github.com/kit-ty-kate/ocamldap" doc: "https://kit-ty-kate.github.io/ocamldap" bug-reports: "https://github.com/kit-ty-kate/ocamldap/issues" depends: [ "dune" {>= "2.7"} "ocaml" {>= "4.03.0"} "ocamlnet" {>= "3.6.0"} "re" {>= "1.3.0"} "camlp-streams" {>= "5.0.1"} "ssl" {>= "0.5.3"} ] conflicts: [ "ocamldap" {!= "transition"} ] build: [ [ "dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} ] ] dev-repo: "git+https://github.com/kit-ty-kate/ocamldap.git" ldap-2.5.1/src/0000755000175000017500000000000014652453725014643 5ustar kit_ty_katekit_ty_kateldap-2.5.1/src/ldap/0000755000175000017500000000000014652453725015563 5ustar kit_ty_katekit_ty_kateldap-2.5.1/src/ldap/dune0000644000175000017500000000041514652453725016441 0ustar kit_ty_katekit_ty_kate(ocamlyacc ldap_dnparser ldap_filterparser) (ocamllex ldap_schemalexer ldap_urllexer ldap_filterlexer ldap_dnlexer) (library (name ldap) (public_name ldap) (wrapped false) (modules_without_implementation ldap_urlparser) (libraries str camlp-streams re ssl)) ldap-2.5.1/src/ldap/lber.ml0000644000175000017500000006732714652453725017060 0ustar kit_ty_katekit_ty_kate(* these are the Basic Encoding Rules, standardized by the ITU-T in X.690 all comments containing "sec. x.x.x.x" are section numbers referring to sections in x.690 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 *) exception Decoding_error of string exception Encoding_error of string type readbyte_error = End_of_stream | Transport_error | Peek_error | Request_too_large | Not_implemented exception Readbyte_error of readbyte_error (* our sole interface with the data is to read and write a byte. the user of the encodeing functions herin will pass a function of the type readbyte, or writebyte to us when the encoding function is called. We will use that function to get or set raw data *) type readbyte = ?peek:bool -> int -> string type writebyte = (char -> unit) (* note on syntax. In this program I use some somewhat little used, but very useful syntatic notations for numbers in Ocaml. eg. 0b11000000, the 0b indicates a binary number, everything after it is the number. eg. 0b1100_0000, the _ has no meaning, it is just a seperator, however, seperating the nibbles in this way makes binary numbers very readable *) (* X.690 sec. 8.1.1 structure of an encoding *) type ber_class = Universal | Application | Context_specific | Private type ber_length = Definite of int | Indefinite (* all the meta info about a ber value *) type ber_val_header = {ber_class: ber_class; ber_primitive: bool; ber_tag: int; ber_length: ber_length} (* readbyte implementations. A readbyte is a higher order function which creates functions which provide a uniform way for decoding functions to read data without having to know anything about where it comes from. To OO people it can essentially be viewed as a functional version of a class, it exposes "methods", and hides data and code. the Lber module includes several readbyte implementations, which allow the decoding functions to read data from sockets, SSL sockets, other readbyte classes (with imposed read barriers), and from simple strings. *) (* return a readbyte implementation which uses another readbyte, but allows setting a read boundry. Useful for constructing views of the octet stream which end at the end of a ber structure. This is essential for reading certian structures because length is only encoded in the toplevel in order to save space. This function is the secret of Ocamldap's performance. *) let readbyte_of_ber_element limit (rb:readbyte) = let peek_counter = ref 1 and byte_counter = ref 0 in match limit with Definite limit -> let f ?(peek=false) length = if not peek then if !byte_counter + length <= limit then ( peek_counter := 1; byte_counter := !byte_counter + length; rb length ) else raise (Readbyte_error End_of_stream) else if !peek_counter + length <= limit && !byte_counter < limit then ( peek_counter := !peek_counter + length; rb ~peek:true length ) else raise (Readbyte_error End_of_stream) in f | Indefinite -> (* let peek_saw_eoc_octets = ref false and saw_eoc_octets = ref false and eoc_buf = String.create 1 and eoc_buf_len = ref 0 in let f ?(peek=false) length = if !eoc_buf_len = 0 then if peek && !peek_saw_eoc_octets then raise (Readbyte_error End_of_stream) else if !saw_eoc_octets then raise (Readbyte_error End_of_stream) else let b = rb ~peek:peek 1 in if (int_of_char b) = 0b0000_0000 then let b1 = rb ~peek:peek 1 in if (int_of_char b1) = 0b0000_0000 then ((if peek then peek_saw_eoc_octets := true else saw_eoc_octets := true); raise (Readbyte_error End_of_stream)) else (eoc_buf.[0] <- b1; eoc_buf_len := 1; String.make 1 b) else String.make 1 b else (eoc_buf_len := 0; eoc_buf) in f *) raise (Readbyte_error Not_implemented) (* return a readbyte implementation which works using a string *) let readbyte_of_string _octets = (* let strm = Stream.of_string octets in let peek_counter = ref 1 in let limit = ref 0 in let f ?(peek=false) length = let rec last lst = match lst with h :: [] -> h | h :: t -> last t | [] -> failwith "readbyte bug in \"last\" function!" in if not peek then ( peek_counter := 1; (* reset the peek counter when we really read a byte *) try String.make 1 (Stream.next strm) with Stream.Failure -> raise (Readbyte_error End_of_stream) ) else let elts = (Stream.npeek !peek_counter strm) in if List.length elts = !peek_counter then (peek_counter := !peek_counter + 1; (String.make 1 (last elts))) else raise (Readbyte_error End_of_stream) (* if there are not enough elements in the stream, fail *) in f *) raise (Readbyte_error Not_implemented) let readbyte_of_readfun rfun = let bufsize = 16384 in (* must be this for ssl *) let buf = Bytes.create (bufsize * 2) in let buf_len = ref 0 in let buf_pos = ref 0 in let peek_pos = ref 0 in let peek_buf_len = ref 0 in let read buf off len = try rfun buf off len with _ -> raise (Readbyte_error Transport_error) in let read_at_least_nbytes buf off len nbytes = let total = ref 0 in while !total < nbytes do let rd = read buf (!total + off) (len - !total) in if rd <= 0 then raise (Readbyte_error Transport_error); total := !total + rd; done; !total in let rec rb ?(peek=false) length = if length <= 0 then raise (Invalid_argument "Readbyte.length"); if length > bufsize then ( if length > Sys.max_string_length then raise (Readbyte_error Request_too_large); let result = Bytes.create length in let total = ref 0 in while !total < length do let nbytes_to_read = if length - !total < bufsize then length - !total else bufsize in let iresult = rb ~peek nbytes_to_read in String.blit iresult 0 result !total nbytes_to_read; total := !total + nbytes_to_read done; Bytes.to_string result ) else if not peek then ( if length <= !buf_len - !buf_pos then ( let result = Bytes.sub_string buf !buf_pos length in buf_pos := !buf_pos + length; peek_pos := !buf_pos; result ) else ( let result = Bytes.create length in let nbytes_really_in_buffer = (!buf_len - !buf_pos) + !peek_buf_len in let nbytes_in_buffer = if nbytes_really_in_buffer > length then length else nbytes_really_in_buffer in let nbytes_to_read = length - nbytes_in_buffer in if nbytes_in_buffer > 0 then Bytes.blit buf !buf_pos result 0 nbytes_in_buffer; if nbytes_to_read > 0 then ( let nbytes_read = read_at_least_nbytes buf 0 bufsize nbytes_to_read in Bytes.blit buf 0 result nbytes_in_buffer nbytes_to_read; buf_pos := nbytes_to_read; buf_len := nbytes_read; peek_pos := !buf_pos; peek_buf_len := 0; Bytes.to_string result ) else ( Bytes.blit buf 0 buf (!buf_pos + length) (nbytes_really_in_buffer - length); buf_len := (nbytes_really_in_buffer - length); buf_pos := 0; peek_pos := !buf_pos; peek_buf_len := 0; Bytes.to_string result ) ) ) (* if not peek *) else ( if length <= (!buf_len + !peek_buf_len) - !peek_pos then ( let result = Bytes.sub_string buf !peek_pos length in peek_pos := !peek_pos + length; result ) else ( if length + !peek_pos > 2 * bufsize then raise (Readbyte_error Peek_error); let result = Bytes.create length in let nbytes_in_buffer = (!buf_len + !peek_buf_len) - !peek_pos in let nbytes_to_read = length - nbytes_in_buffer in let read_start_pos = !peek_pos + nbytes_in_buffer in Bytes.blit buf !peek_pos result 0 nbytes_in_buffer; let nbytes_read = read_at_least_nbytes buf read_start_pos (bufsize - (!buf_len + !peek_buf_len)) nbytes_to_read in Bytes.blit buf read_start_pos result nbytes_in_buffer nbytes_read; peek_buf_len := !peek_buf_len + nbytes_read; peek_pos := !peek_pos + length; Bytes.to_string result ) ) in rb (* a readbyte implementation which reads from an FD. It implements a peek buffer, so it can garentee that it will work with readbyte_of_ber_element, even with blocking fds. *) let readbyte_of_fd fd = readbyte_of_readfun (fun buf off len -> try Unix.read fd buf off len with exn -> (try Unix.close fd with _ -> ());raise exn) (* a readbyte implementation which reads from an SSL socket. It is otherwise the same as rb_of_fd *) let readbyte_of_ssl fd = readbyte_of_readfun (fun buf off len -> try Ssl.read fd buf off len with exn -> (try Ssl.shutdown fd with _ -> ());raise exn) let decode_ber_length ?(peek=false) (readbyte:readbyte) = (* sec. 8.1.3.3, the definite length form *) let octet = int_of_char (readbyte ~peek:peek 1).[0] in if octet = 0b1111_1111 then (* sec/ 8.1.3.5c *) raise (Decoding_error "illegal initial length octet") else if octet = 0b1000_0000 then (* sec. 8.1.3.6 indefinite form *) Indefinite else if octet land 0b1000_0000 = 0b0000_0000 then (* sec. 8.1.3.4, definite length, short form *) Definite (octet land 0b0111_1111) else (* sec. 8.1.3.5, definite length, long form *) let rec decode_multioctet_length (readbyte:readbyte) numoctets remainingoctets value = if numoctets > 4 then raise (Decoding_error "length cannot be represented"); if remainingoctets = 0 then Definite value else let octet = int_of_char (readbyte ~peek:peek 1).[0] in if ((numoctets = 4) && (remainingoctets = 4) && (octet land 0b1000_0000 = 0b1000_0000)) (* we have only 31 bits *) then raise (Decoding_error "length cannot be represented") else decode_multioctet_length readbyte numoctets (remainingoctets - 1) (value + (octet lsl ((numoctets - (numoctets - remainingoctets) - 1) * 8))) in let numoctets = octet land 0b0111_1111 in decode_multioctet_length readbyte numoctets numoctets 0 let decode_ber_header ?(peek=false) (readbyte:readbyte) = let leading_octet = int_of_char (readbyte ~peek:peek 1).[0] in let ber_tag = (* sec. 8.1.2.2c *) if leading_octet land 0b0001_1111 = 0b0001_1111 then (* sec. 8.1.2.4 multi octet tag encoding *) let rec decode_multioctet_tag (readbyte:readbyte) tag_value = let octet = int_of_char (readbyte ~peek:peek 1).[0] in if octet land 0b1000_0000 = 0b0000_0000 then tag_value + (octet land 0b0111_1111) else decode_multioctet_tag readbyte (tag_value + (octet land 0b0111_1111)) in decode_multioctet_tag readbyte 0 else (* sec. 8.1.2.2 single octet tag encoding *) leading_octet land 0b0001_1111 in let ber_length = decode_ber_length ~peek:peek readbyte in {ber_class = (* sec. 8.1.2.2a table 1 *) (match leading_octet land 0b1100_0000 with 0b0000_0000 -> Universal | 0b0100_0000 -> Application | 0b1000_0000 -> Context_specific | 0b1100_0000 -> Private | _ -> raise (Decoding_error "ber_class, decoder bug")); ber_primitive = (* sec. 8.1.2.5 *) (match leading_octet land 0b0100_0000 with 0b0100_0000 -> false (* value is constructed *) | 0b0000_0000 -> true | _ -> raise (Decoding_error "ber_primitive, decoder bug")); (* value is primative *) ber_tag = ber_tag; ber_length = ber_length} let encode_ber_header {ber_class=cls;ber_primitive=pri;ber_tag=tag;ber_length=len} = let buf = Buffer.create 3 in let rec encode_multioctet_tag tag buf = if tag > 127 then (Buffer.add_char buf (char_of_int 255); encode_multioctet_tag (tag - 127) buf) else Buffer.add_char buf (char_of_int tag) in let long_form_length len buf = (* sec 8.1.3.5 encode the length in up to 1 + 4 octets *) if len < 255 then (* fits in 8 bits? *) (Buffer.add_char buf (char_of_int 0b1000_0001); (* long form with one octet *) Buffer.add_char buf (char_of_int len)) else if len < 65535 then (* fits in 16 bits? *) (Buffer.add_char buf (char_of_int 0b1000_0010); (* long form with two octets *) Buffer.add_char buf (char_of_int ((len land 0b11111111_00000000) lsr 8)); Buffer.add_char buf (char_of_int (len land 0b00000000_11111111))) else if len < 16777215 then (* fits in 24 bits? *) (Buffer.add_char buf (char_of_int 0b1000_0011); (* long form in three octets *) Buffer.add_char buf (char_of_int ((len land 0b11111111_00000000_00000000) lsr 16)); Buffer.add_char buf (char_of_int ((len land 0b00000000_11111111_00000000) lsr 8)); Buffer.add_char buf (char_of_int (len land 0b00000000_00000000_11111111))) else (* can't currently encode anything bigger than 31 bits *) (Buffer.add_char buf (char_of_int 0b1000_0100); Buffer.add_char buf (char_of_int ((len land 0b00111111_00000000_00000000_00000000) lsr 24)); Buffer.add_char buf (char_of_int ((len land 0b00000000_11111111_00000000_00000000) lsr 16)); Buffer.add_char buf (char_of_int ((len land 0b00000000_00000000_11111111_00000000) lsr 8)); Buffer.add_char buf (char_of_int (len land 0b00000000_00000000_00000000_11111111))); in Buffer.add_char buf (* deal with the header *) (char_of_int ((match cls with Universal -> 0b0000_0000 | Application -> 0b0100_0000 | Context_specific -> 0b1000_0000 | Private -> 0b1100_0000) lor (if pri then 0b0000_0000 else 0b0010_0000) lor (if tag > 31 then 0b0001_1111 else tag))); if tag > 31 then encode_multioctet_tag tag buf; (match len with (* deal with the length *) Definite len -> if len < 127 then Buffer.add_char buf (char_of_int len) else long_form_length len buf; | Indefinite -> raise (Encoding_error "indefinite length encoding not implemented")); Buffer.contents buf let read_contents ?(peek=false) (readbyte:readbyte) len = let rec readuntileoc (readbyte:readbyte) buf = let octet1 = (readbyte ~peek 1).[0] in if (int_of_char octet1) = 0b0000_0000 then let octet2 = (readbyte ~peek 1).[0] in if (int_of_char octet2) = 0b0000_0000 then Buffer.contents buf else (Buffer.add_char buf octet1;Buffer.add_char buf octet2; readuntileoc readbyte buf) else (Buffer.add_char buf octet1;readuntileoc readbyte buf) in match len with Definite n -> if n = 0 then "" else readbyte ~peek n | Indefinite -> readuntileoc readbyte (Buffer.create 5) (* sec. 8.2 *) let decode_ber_bool ?(peek=false) ?(cls=Universal) ?(tag=1) ?(contents=None) (readbyte:readbyte) = let decode_ber_bool' contents = if (int_of_char contents.[0]) = 0 then false else true in match contents with None -> (match decode_ber_header ~peek:peek readbyte with {ber_class=c;ber_tag=t;ber_length=bool_length;_} when c=cls && t=tag -> decode_ber_bool' (read_contents ~peek:peek readbyte bool_length) | _ -> raise (Decoding_error "expected bool")) | Some contents -> decode_ber_bool' contents let encode_ber_bool ?(cls=Universal) ?(tag=1) value = let buf = Buffer.create 3 in Buffer.add_string buf (encode_ber_header {ber_class=cls;ber_primitive=true;ber_tag=tag;ber_length=Definite 1}); Buffer.add_char buf (if value then char_of_int 1 else char_of_int 0); Buffer.contents buf (* sec 8.3 *) let decode_ber_int32 ?(peek=false) ?(cls=Universal) ?(tag=2) ?(contents=None) (readbyte:readbyte) = let decode_ber_int32' contents = let length = String.length contents in if length > 5 then raise (Decoding_error "integer overflow, use bigger decode function?") else if length > 0 then let c i = Int32.of_int (int_of_char i) in let rec convert octets l i v = if i <= l then convert octets l (i + 1) (Int32.logor v (Int32.shift_left (c octets.[i]) (8 * (l - i)))) else v in let v = convert contents (length - 1) 0 0l in if (Int32.logand (c contents.[0]) 0b10000000l) = 0b10000000l then (* the number should be negative, fix it. For a less than 4 byte encoding, we need to set all the bits left of the data to 1. This operation will have no effect on a 4 byte encoding *) (Int32.logor (Int32.shift_left (-1l) (length * 8)) v) else v else raise (Decoding_error "integer, no contents octets") (* sec 8.3.1 *) in match contents with None -> (* we have not yet read the header, and unpacked the contents *) (match decode_ber_header ~peek:peek readbyte with {ber_class=c;ber_tag=t;ber_length=int_length;_} when c=cls && t=tag -> decode_ber_int32' (read_contents ~peek:peek readbyte int_length) | _ -> raise (Decoding_error "expected int")) | Some contents -> decode_ber_int32' contents (* we already have the contents *) let encode_ber_int32 ?(cls=Universal) ?(tag=2) value = let to_char i = char_of_int (Int32.to_int i) in let encode_positive_int32 value = let buf = Buffer.create 4 in (if value < 0b01111111l then (* fits in 7 bits + sign bit? *) Buffer.add_char buf (to_char value) (* byte one, MSB *) else if value < 0b01111111_11111111l then (* fits in 15 bits + sign bit? *) (Buffer.add_char buf (* byte one, MSB *) (to_char (Int32.shift_right (Int32.logand value 0b01111111_00000000l) 8)); Buffer.add_char buf (* byte two *) (to_char (Int32.logand value 0b00000000_11111111l))) else if value < 0b01111111_11111111_11111111l then (* fits in 23 bits + sign bit? *) (Buffer.add_char buf (* byte one, MSB *) (to_char (Int32.shift_right (Int32.logand value 0b01111111_00000000_00000000l) 16)); Buffer.add_char buf (* byte two *) (to_char (Int32.shift_right (Int32.logand value 0b00000000_11111111_00000000l) 8)); Buffer.add_char buf (* byte three *) (to_char (Int32.logand value 0b00000000_00000000_11111111l))) else (* use 31 bits + sign bit *) (Buffer.add_char buf (* byte one, MSB *) (to_char (Int32.shift_right (Int32.logand value 0b01111111_00000000_00000000_00000000l) 24)); Buffer.add_char buf (* byte two *) (to_char (Int32.shift_right (Int32.logand value 0b00000000_11111111_00000000_00000000l) 16)); Buffer.add_char buf (* byte three *) (to_char (Int32.shift_right (Int32.logand value 0b00000000_00000000_11111111_00000000l) 8)); Buffer.add_char buf (* byte four *) (to_char (Int32.logand value 0b00000000_00000000_00000000_11111111l)))); buf in let encode_negative_int32 value = let buf = Buffer.create 4 in (* We must manually set the sign bit for the first octet of the encoding. So we must turn the real sign bit off, and set the first bit of the first octet in the encoded stream, because it will become the sign bit on the other side. *) (if value > 0b11111111_11111111_11111111_10000000l then (* fits in 7 bits + sign bit *) Buffer.add_char buf (* byte one, MSB *) (to_char (Int32.logor (* flip what WILL be the sign bit in the encoded byte ON *) 0b1000_0000l (Int32.logand (* flip the sign bit for the WHOLE word OFF *) 0b00000000_00000000_00000000_11111111l value))) else if value > 0b11111111_11111111_10000000_00000000l then (* fits in 15 bits + sign bit *) (Buffer.add_char buf (* byte one, MSB *) (to_char (Int32.logor (* flip what WILL be the sign bit in the encoded byte ON *) 0b1000_0000l (Int32.shift_right (Int32.logand (* this mask also accomplishes flipping the sign bit OFF *) 0b00000000_00000000_11111111_00000000l value) 8))); Buffer.add_char buf (to_char (Int32.logand 0b00000000_00000000_00000000_11111111l value))) (* byte two *) else if value > 0b11111111_10000000_00000000_00000000l then (* fits in 23 bits + sign bit *) (Buffer.add_char buf (* byte one, MSB *) (to_char (Int32.logor (* flip what WILL be the sign bit in the encoded byte ON *) 0b1000_0000l (Int32.shift_right (Int32.logand (* this mask also accomplishes flipping the sign bit OFF *) 0b00000000_11111111_00000000_00000000l value) 16))); Buffer.add_char buf (* byte two *) (to_char (Int32.shift_right (Int32.logand (* this mask also accomplishes flipping the sign bit OFF *) 0b00000000_00000000_11111111_00000000l value) 8)); Buffer.add_char buf (* byte three *) (to_char (Int32.logand (* this mask also accomplishes flipping the sign bit OFF *) 0b00000000_00000000_00000000_11111111l value))) else (* fits in 31 bits + sign bit *) (Buffer.add_char buf (* byte one, MSB *) (to_char (Int32.logor (* flip what WILL be the sign bit in the encoded byte ON *) 0b1000_0000l (Int32.shift_right (Int32.logand (* this mask also accomplishes flipping the sign bit OFF *) 0b01111111_00000000_00000000_00000000l value) 24))); Buffer.add_char buf (* byte two *) (to_char (Int32.shift_right (Int32.logand (* this mask also accomplishes flipping the sign bit OFF *) 0b00000000_11111111_00000000_00000000l value) 16)); Buffer.add_char buf (* byte three *) (to_char (Int32.shift_right (Int32.logand (* this mask also accomplishes flipping the sign bit OFF *) 0b00000000_00000000_11111111_00000000l value) 8)); Buffer.add_char buf (* byte four *) (to_char (Int32.logand (* this mask also accomplishes flipping the sign bit OFF *) 0b00000000_00000000_00000000_11111111l value)))); buf in let buf = if value < 0l then (* if its less than zero we must encode differently *) encode_negative_int32 value else encode_positive_int32 value in let buf1 = Buffer.create 5 in Buffer.add_string buf1 (encode_ber_header {ber_class=cls; ber_tag=tag; ber_primitive=true; ber_length=Definite (Buffer.length buf)}); Buffer.add_buffer buf1 buf; Buffer.contents buf1 (* sec. 8.4 *) let decode_ber_enum ?(peek=false) ?(cls=Universal) ?(tag=10) ?(contents=None) (readbyte:readbyte) = decode_ber_int32 ~peek:peek ~cls:cls ~tag:tag ~contents:contents readbyte let encode_ber_enum ?(cls=Universal) ?(tag=10) value = encode_ber_int32 ~cls:cls ~tag:tag value (* sec 8.7 *) let decode_ber_octetstring ?(peek=false) ?(cls=Universal) ?(tag=4) ?(contents=None) (readbyte:readbyte) = match contents with None -> (* have not yet read the header, or unpacked the contents *) (match decode_ber_header readbyte with {ber_class=c;ber_tag=t;ber_length=octetstring_length;_} when c=cls && t=tag -> read_contents ~peek readbyte octetstring_length | _ -> raise (Decoding_error "expected octetstring")) | Some contents -> contents let encode_ber_octetstring ?(cls=Universal) ?(tag=4) string = let len = String.length string in let buf = Buffer.create (len + 3) in Buffer.add_string buf (encode_ber_header {ber_class=cls; ber_tag=tag; ber_primitive=true; ber_length=Definite len}); Buffer.add_string buf string; Buffer.contents buf let encode_ber_null ?(cls=Universal) ?(tag=5) () = encode_ber_header {ber_class=cls; ber_tag=tag; ber_primitive=true; ber_length=Definite 0} let decode_ber_null ?(peek=false) ?(cls=Universal) ?(tag=5) ?(contents=None) (readbyte:readbyte) = let decode_ber_null' _contents = () in (* TODO: Is this normal?! *) match contents with None -> (match decode_ber_header ~peek:peek readbyte with {ber_class=c; ber_tag=t; ber_length=l; _} when c=cls && t=tag && l=Definite 0 -> decode_ber_null' None | _ -> raise (Decoding_error "expected null")) | Some contents -> decode_ber_null' contents let rec encode_berval_list ?(buf=Buffer.create 50) efun lst = match lst with hd :: [] -> Buffer.add_string buf (efun hd); Buffer.contents buf | hd :: tl -> (encode_berval_list ~buf:(Buffer.add_string buf (efun hd);buf) efun tl) | [] -> Buffer.contents buf let rec decode_berval_list ?(lst=[]) dfun (readbyte:readbyte) = try decode_berval_list ~lst:((dfun readbyte) :: lst) dfun readbyte with Readbyte_error End_of_stream -> lst ldap-2.5.1/src/ldap/lber.mli0000644000175000017500000001547614652453725017227 0ustar kit_ty_katekit_ty_kate(* This library implements the subset of the basic encoding rules necessary to implement the ldap protocol. See ITU-T X.680 and X.690 for a description of ASN.1, and the basic encoding rules. Copyright (C) 2004 Eric Stokes, Matthew Backes, 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 *) (** This library implements the subset of ber *) exception Decoding_error of string exception Encoding_error of string type readbyte_error = End_of_stream | Transport_error | Peek_error | Request_too_large | Not_implemented exception Readbyte_error of readbyte_error type readbyte = ?peek:bool -> int -> string type writebyte = char -> unit type ber_class = Universal | Application | Context_specific | Private type ber_length = Definite of int | Indefinite type ber_val_header = { ber_class : ber_class; ber_primitive : bool; ber_tag : int; ber_length : ber_length; } (** return a readbyte function for a string, currently not implemented *) val readbyte_of_string : string -> readbyte (** return a readbyte implementation which uses another readbyte, but allows setting a read boundry. Useful for constructing views of the octet stream which end at the end of a ber structure. This is essential for reading certian structures because length is only encoded in the toplevel in order to save space. Currently only implemented for definite lengths. @raise Readbyte_error in the event of a an io error, or the end of file *) val readbyte_of_ber_element : ber_length -> readbyte -> readbyte (** a readbyte implementation which reads from an FD. It implements a peek buffer, so it can garentee that it will work with rb_of_ber_element, even with blocking fds. @raise Readbyte_error in the event of a an io error, or the end of file *) val readbyte_of_fd: Unix.file_descr -> readbyte (** a readbyte implementation which reads from an SSL socket. It is otherwise the same as readbyte_of_fd. @raise Readbyte_error in the event of a an io error, or the end of file *) val readbyte_of_ssl: Ssl.socket -> readbyte (** decoding and encoding of the ber header *) val decode_ber_header : ?peek:bool -> readbyte -> ber_val_header val encode_ber_header : ber_val_header -> string (** reads the contents octets *) val read_contents : ?peek:bool -> readbyte -> ber_length -> string (** ENCODING and DECODING Functions Explanation of optional arguments: The optional arguments are there to deal with a number of situations, cls, and tag are for context specific or application situations where it is expected that the value will not be marked with the class and tag defined in X.680. Contents is there for akward situations which arise because of the choice structure. Normally the decode functions will always read the header for you, however with the choice structure this is impossible. In this case you should read the header manually, determine which decode function to call, unpack the contents with read_contents, and send them in the contents optional. If contents is not None, then readbyte will never be called, and no attempt will be made to read the header or length. *) (** Encoding/Decoding of the boolean primative ASN.1 type. Encode function encodes a valid ber type, including the header and length octets. *) val decode_ber_bool : ?peek:bool -> ?cls:ber_class -> ?tag:int -> ?contents:string option -> readbyte -> bool val encode_ber_bool : ?cls:ber_class -> ?tag:int -> bool -> string (** Encoding/Decoding of the integer primative ASN.1 type. Note, in this library, integers are represented as 32 bit values. In ASN.1 there is no practical limit to the size of an integer, later on, this library may provide an encoder/decoder to Int64, and Bigints, however for now, this will have to do. Encode function encodes a valid ber type, including the header and length octets *) val decode_ber_int32 : ?peek:bool -> ?cls:ber_class -> ?tag:int -> ?contents:string option -> readbyte -> int32 val encode_ber_int32 : ?cls:ber_class -> ?tag:int -> int32 -> string (** Encoding/Decoding of enum primative ASN.1 type. Enums are simply integers, the same drawbacks apply as for decode_ber_int32. Encode function encodes a valid ber type, including the header and length octets *) val decode_ber_enum : ?peek:bool -> ?cls:ber_class -> ?tag:int -> ?contents:string option -> readbyte -> int32 val encode_ber_enum : ?cls:ber_class -> ?tag:int -> int32 -> string (** Encoding/Decoding of octetstring ASN.1 types. The Nested or "segmented" version of the octetstring encoding described in X.690 is not yet supported. Encode function encodes a valid ber type, including the header and length octets *) val decode_ber_octetstring : ?peek:bool -> ?cls:ber_class -> ?tag:int -> ?contents:string option -> readbyte -> string val encode_ber_octetstring : ?cls:ber_class -> ?tag:int -> string -> string (** Encoding/Decoding of Null ASN.1 type. Almost useful as an assertion-type operation *) val decode_ber_null : ?peek: bool -> ?cls:ber_class -> ?tag:int -> ?contents:string option -> readbyte -> unit val encode_ber_null : ?cls:ber_class -> ?tag:int -> unit -> string (** this function is for encoding lists of bervals, a common case. you pass it a list of things to encode, and an encoding function, and it will apply the encoding function to each element in the list, storing the resulting encoding in a buffer (which you may either pass in or not) *) val encode_berval_list : ?buf:Buffer.t -> ('a -> string) -> 'a list -> string (** this is the reverse of the above, it takes a readbyte structure, and returns a list of decoded elements, processed according to the decoder function you pass in. Note, that you MUST pass a readbyte structure built with readbyte_of_string, OR, your reabyte function must raise Stream.Failure when you reach the end of input. Otherwise this function will explode. That said, it is usually not practical to pass anything but a readbyte created by readbyte_of_string so this should not be a huge problem. *) val decode_berval_list : ?lst:'a list -> (readbyte -> 'a) -> readbyte -> 'a list ldap-2.5.1/src/ldap/ldap_dn.ml0000644000175000017500000001003514652453725017515 0ustar kit_ty_katekit_ty_kate(* Utility functions for operating on dns 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_dnlexer open Printf exception Invalid_dn of int * string let of_string dn_string = let lexbuf = Lexing.from_string dn_string in try Ldap_dnparser.dn lexdn lexbuf with Parsing.Parse_error -> raise (Invalid_dn (lexbuf.Lexing.lex_curr_pos, "parse error")) | Failure msg -> raise (Invalid_dn (lexbuf.Lexing.lex_curr_pos, msg)) let hexpair_of_char c = let hexify i = match i with 0 -> '0' | 1 -> '1' | 2 -> '2' | 3 -> '3' | 4 -> '4' | 5 -> '5' | 6 -> '6' | 7 -> '7' | 8 -> '8' | 9 -> '9' | 10 -> 'a' | 11 -> 'b' | 12 -> 'c' | 13 -> 'd' | 14 -> 'e' | 15 -> 'f' | n -> raise (Invalid_argument ("invalid hex digit: " ^ (string_of_int n))) in let i = int_of_char c in let buf = Bytes.create 2 in Bytes.set buf 0 (hexify (i lsr 4)); Bytes.set buf 1 (hexify (i land 0b0000_1111)); Bytes.to_string buf let escape_value valu = let strm = Stream.of_string valu in let buf = Buffer.create ((String.length valu) + 10) in let rec escape strm buf = try match Stream.next strm with (',' | '=' | '+' | '<' | '>' | '#' | ';' | '\\' | '"') as c -> Buffer.add_char buf '\\'; Buffer.add_char buf c; escape strm buf | ' ' -> if Stream.peek strm = None then begin Buffer.add_string buf "\\ "; escape strm buf end else begin Buffer.add_char buf ' '; escape strm buf end | c -> if (int_of_char c) < (int_of_char ' ') || (int_of_char c) > (int_of_char '~') then begin Buffer.add_string buf ("\\" ^ (hexpair_of_char c)); escape strm buf end else begin Buffer.add_char buf c;escape strm buf end with Stream.Failure -> Buffer.contents buf in match Stream.peek strm with Some ' ' -> Buffer.add_string buf "\\ "; Stream.junk strm; escape strm buf | Some _c -> escape strm buf | None -> "" let to_string dn = let dn_to_strcomponents dn = List.map (fun {attr_type=attr;attr_vals=vals} -> let rec string_values s attr vals = match vals with valu :: [] -> sprintf "%s%s=%s" s attr (escape_value valu) | valu :: tl -> string_values (sprintf "%s%s=%s+" s attr (escape_value valu)) attr tl | [] -> s in if List.length vals = 0 then raise (Invalid_dn (0, "invalid dn structure. no attribute " ^ "value specified for attribute: " ^ attr)) else string_values "" attr vals) dn in let rec components_to_dn s comps = match comps with comp :: [] -> sprintf "%s%s" s comp | comp :: tl -> components_to_dn (sprintf "%s%s," s comp) tl | [] -> s in components_to_dn "" (dn_to_strcomponents dn) let canonical_dn dn = String.lowercase_ascii (to_string (of_string dn)) ldap-2.5.1/src/ldap/ldap_dn.mli0000644000175000017500000000431214652453725017667 0ustar kit_ty_katekit_ty_kate(* Utility functions for operating on dns 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 *) (** operations on ldap dns *) (** raised when something goes wrong with conversion to or from a string. The integer argument is the charachter which the lexer was looking at then the failure ocurred. In the case of to_string the integer argument will always be zero. *) exception Invalid_dn of int * string (** Given a string representation of a dn, return a structured representation. unescapes any escape sequences present. *) val of_string : string -> Ldap_types.dn (** Given a structural representation of a dn, return a string representation. Performs all the necessary escaping to correctly represent any structured representation. *) val to_string : Ldap_types.dn -> string (** Escape a string which you intend to be part of a VALUE in the dn. Do not use on the whole dn, just an attribute value. It is NOT necessary to use this if you intend to call to_string on your dn. It will be done for you as part of the conversion process. This function is exposed for the case where you find it easier to manipulate the dn via a regular expression, or other string based means, and you find it necessary to escape values. *) val escape_value : string -> string (** returns the canonical dn. A simple string compare can tell you accurately whether two canonical dns are equal or not. *) val canonical_dn : string -> string ldap-2.5.1/src/ldap/ldap_dnlexer.mll0000644000175000017500000000423414652453725020735 0ustar kit_ty_katekit_ty_kate(* lexer for rfc2252 format schemas 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_dnparser [@@@ocaml.warning "-26"] } let whsp = [ '\t' ' ' ]* let alpha = [ 'a' - 'z' 'A' - 'Z' ] let digit = [ '0' - '9' ] let hexchar = [ '0' - '9' 'A' - 'F' 'a' - 'f' ] let keychar = [ 'a' - 'z' 'A' - 'Z' '0' - '9' '-' ] let attributetype = (alpha keychar*) as attribute let oid = [ '0' - '9' '.' ]+ let special = [ ',' '=' '+' '<' '>' '#' ';' ] let quotechar = [^ '\\' '"' ] let hexpair = hexchar hexchar let hexstring = hexpair + let stringchar = [^ '\\' '"' ] # special let pair = '\\' (special | ' ' | '\\' | '"' | hexpair) (* According to the rfc this is the set of possible values for an attribute value We don't implement it directly, instead we split each one into a seperate token to make unescaping easier string = (stringchar | pair)* | '#' hexstring | '"' (quotechar | pair)* '"' *) rule lexdn = parse whsp '=' whsp {Equals} | whsp '+' whsp {Plus} | whsp (',' | ';') whsp {Comma} | oid {Oid (Lexing.lexeme lexbuf)} | attributetype {AttributeType (Lexing.lexeme lexbuf)} | stringchar* ([^ ' '] # special) {String (Lexing.lexeme lexbuf)} | (stringchar | pair)* (pair | ([^ ' '] # special)) {StringWithPair (Lexing.lexeme lexbuf)} | '#' hexstring {HexString (Lexing.lexeme lexbuf)} | '"' (quotechar | pair)* '"' {QuoteString (Lexing.lexeme lexbuf)} | eof {End_of_input} ldap-2.5.1/src/ldap/ldap_dnparser.mly0000644000175000017500000000731114652453725021126 0ustar kit_ty_katekit_ty_kate/* a parser for rfc2254 ldap filters 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 let unhex hex = match hex with '0' -> 0 | '1' -> 1 | '2' -> 2 | '3' -> 3 | '4' -> 4 | '5' -> 5 | '6' -> 6 | '7' -> 7 | '8' -> 8 | '9' -> 9 | 'a' -> 10 | 'b' -> 11 | 'c' -> 12 | 'd' -> 13 | 'e' -> 14 | 'f' -> 15 | _ -> failwith "invalid hex digit" let unescape_hexpair hex1 hex2 = (char_of_int ((lor) ((lsl) (unhex hex1) 4) (unhex hex2))) let unescape_stringwithpair s = let strm = Stream.of_string s in let buf = Buffer.create (String.length s) in let rec unescape strm buf = try match Stream.next strm with '\\' -> (match Stream.next strm with (',' | '=' | '+' | '<' | '>' | '#' | ';' | '\\' | '"' | ' ') as c -> Buffer.add_char buf c; unescape strm buf | ('0' .. '9' | 'A' .. 'F' | 'a' .. 'f') as hex1 -> let hex2 = Stream.next strm in Buffer.add_char buf (unescape_hexpair hex1 hex2); unescape strm buf | _ -> failwith "invalid escape sequence") | c -> Buffer.add_char buf c;unescape strm buf with Stream.Failure -> Buffer.contents buf in unescape strm buf let unescape_quotestring s = unescape_stringwithpair (String.sub s 1 ((String.length s) - 2)) let unescape_hexstring s = let strm = Stream.of_string s in let buf = Buffer.create (String.length s) in let rec unescape strm buf = try let hex1 = Stream.next strm in let hex2 = Stream.next strm in Buffer.add_char buf (unescape_hexpair hex1 hex2); unescape strm buf with Stream.Failure -> Buffer.contents buf in match Stream.next strm with '#' -> unescape strm buf | _ -> failwith "invalid hexstring" %} %token Equals Plus Comma End_of_input %token AttributeType %token Oid %token String %token StringWithPair %token HexString %token QuoteString %type dn %start dn %% attrval: AttributeType {$1} | Oid {$1} | String {$1} | StringWithPair {unescape_stringwithpair $1} | HexString {unescape_hexstring $1} | QuoteString {unescape_quotestring $1} ; attrname: AttributeType {$1} | Oid {$1} ; dn: attrname Equals attrval Plus dn {match $5 with {attr_type=attr_name;attr_vals=vals} :: tl -> if $1 = attr_name then {attr_type=attr_name;attr_vals=($3 :: vals)} :: tl else failwith ("invalid multivalued rdn, expected: " ^ $1) | [] -> [{attr_type=$1;attr_vals=[$3]}]} | attrname Equals attrval Comma dn {{attr_type=$1;attr_vals=[$3]} :: $5} | attrname Equals attrval End_of_input {[{attr_type=$1;attr_vals=[$3]}]} | End_of_input {[]} ; ldap-2.5.1/src/ldap/ldap_error.ml0000644000175000017500000000531214652453725020247 0ustar kit_ty_katekit_ty_kateopen Ldap_types let err2string code = match code with `SUCCESS -> "`SUCCESS" | `OPERATIONS_ERROR -> "`OPERATIONS_ERROR" | `PROTOCOL_ERROR -> "`PROTOCOL_ERROR" | `TIMELIMIT_EXCEEDED -> "`TIMELIMIT_EXCEEDED" | `SIZELIMIT_EXCEEDED -> "`SIZELIMIT_EXCEEDED" | `COMPARE_FALSE -> "`COMPARE_FALSE" | `COMPARE_TRUE -> "`COMPARE_TRUE" | `AUTH_METHOD_NOT_SUPPORTED -> "`AUTH_METHOD_NOT_SUPPORTED" | `STRONG_AUTH_REQUIRED -> "`STRONG_AUTH_REQUIRED" | `REFERRAL -> "`REFERRAL" | `ADMINLIMIT_EXCEEDED -> "`ADMINLIMIT_EXCEEDED" | `UNAVAILABLE_CRITICAL_EXTENSION -> "`UNAVAILABLE_CRITICAL_EXTENSION" | `CONFIDENTIALITY_REQUIRED -> "`CONFIDENTIALITY_REQUIRED" | `SASL_BIND_IN_PROGRESS -> "`SASL_BIND_IN_PROGRESS" | `NO_SUCH_ATTRIBUTE -> "`NO_SUCH_ATTRIBUTE" | `UNDEFINED_TYPE -> "`UNDEFINED_TYPE" | `INAPPROPRIATE_MATCHING -> "`INAPPROPRIATE_MATCHING" | `CONSTRAINT_VIOLATION -> "`CONSTRAINT_VIOLATION" | `TYPE_OR_VALUE_EXISTS -> "`TYPE_OR_VALUE_EXISTS" | `INVALID_SYNTAX -> "`INVALID_SYNTAX" | `NO_SUCH_OBJECT -> "`NO_SUCH_OBJECT" | `ALIAS_PROBLEM -> "`ALIAS_PROBLEM" | `INVALID_DN_SYNTAX -> "`INVALID_DN_SYNTAX" | `ALIAS_DEREF_PROBLEM -> "`ALIAS_DEREF_PROBLEM" | `INAPPROPRIATE_AUTH -> "`INAPPROPRIATE_AUTH" | `INVALID_CREDENTIALS -> "`INVALID_CREDENTIALS" | `INSUFFICIENT_ACCESS -> "`INSUFFICIENT_ACCESS" | `BUSY -> "`BUSY" | `UNAVAILABLE -> "`UNAVAILABLE" | `UNWILLING_TO_PERFORM -> "`UNWILLING_TO_PERFORM" | `LOOP_DETECT -> "`LOOP_DETECT" | `NAMING_VIOLATION -> "`NAMING_VIOLATION" | `OBJECT_CLASS_VIOLATION -> "`OBJECT_CLASS_VIOLATION" | `NOT_ALLOWED_ON_NONLEAF -> "`NOT_ALLOWED_ON_NONLEAF" | `NOT_ALLOWED_ON_RDN -> "`NOT_ALLOWED_ON_RDN" | `ALREADY_EXISTS -> "`ALREADY_EXISTS" | `NO_OBJECT_CLASS_MODS -> "`NO_OBJECT_CLASS_MODS" | `LOCAL_ERROR -> "`LOCAL_ERROR" | `SERVER_DOWN -> "`SERVER_DOWN" | `OTHER -> "`OTHER" | _ -> raise (LDAP_Decoder "invalid error code") let ldap_strerror msg ldaperror = match ldaperror with LDAP_Failure (code, error, {ext_matched_dn=mdn;ext_referral=refs}) -> "LDAP_Failure (" ^ (String.concat ", " [(err2string code); "\"" ^ (String.concat ": " (List.filter (function "" -> false | _ -> true) [error; msg])) ^ "\""; "{ext_matched_dn = " ^ "\"" ^ mdn ^ "\"; ext_referral = " ^ (match refs with Some lst -> "[" ^ (String.concat "; " lst) ^ "]" | None -> "None") ^ "})"]) | _ -> failwith "not an ldap error" let ldap_perror error ldaperror = prerr_endline (ldap_strerror error ldaperror) ldap-2.5.1/src/ldap/ldap_error.mli0000644000175000017500000000242014652453725020415 0ustar kit_ty_katekit_ty_kate(** given an ldap error code return a string describing it *) val err2string : [> `ADMINLIMIT_EXCEEDED | `ALIAS_DEREF_PROBLEM | `ALIAS_PROBLEM | `ALREADY_EXISTS | `AUTH_METHOD_NOT_SUPPORTED | `BUSY | `COMPARE_FALSE | `COMPARE_TRUE | `CONFIDENTIALITY_REQUIRED | `CONSTRAINT_VIOLATION | `INAPPROPRIATE_AUTH | `INAPPROPRIATE_MATCHING | `INSUFFICIENT_ACCESS | `INVALID_CREDENTIALS | `INVALID_DN_SYNTAX | `INVALID_SYNTAX | `LOCAL_ERROR | `LOOP_DETECT | `NAMING_VIOLATION | `NOT_ALLOWED_ON_NONLEAF | `NOT_ALLOWED_ON_RDN | `NO_OBJECT_CLASS_MODS | `NO_SUCH_ATTRIBUTE | `NO_SUCH_OBJECT | `OBJECT_CLASS_VIOLATION | `OPERATIONS_ERROR | `OTHER | `PROTOCOL_ERROR | `REFERRAL | `SASL_BIND_IN_PROGRESS | `SERVER_DOWN | `SIZELIMIT_EXCEEDED | `STRONG_AUTH_REQUIRED | `SUCCESS | `TIMELIMIT_EXCEEDED | `TYPE_OR_VALUE_EXISTS | `UNAVAILABLE | `UNAVAILABLE_CRITICAL_EXTENSION | `UNDEFINED_TYPE | `UNWILLING_TO_PERFORM ] -> string (** return a string with a human readable description of an LDAP_Failure exception *) val ldap_strerror : string -> exn -> string (** print to stderr a string with a human readable description of an LDAP_Failure exception *) val ldap_perror : string -> exn -> unit ldap-2.5.1/src/ldap/ldap_filter.ml0000644000175000017500000001452314652453725020407 0ustar kit_ty_katekit_ty_kate(* Ldap filter parser driver. 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_filterparser open Ldap_filterlexer open Str exception Invalid_filter of int * string (* escape a string to be put in a string representation of a search filter *) let star_rex = Re.compile (Re.char '*') let lparen_rex = Re.compile (Re.char '(') let rparen_rex = Re.compile (Re.char ')') let backslash_rex = Re.compile (Re.char '\\') let null_rex = Re.compile (Re.char '\000') let escape_filterstring s = (Re.replace_string star_rex ~by:"\\2a" (Re.replace_string lparen_rex ~by:"\\28" (Re.replace_string rparen_rex ~by:"\\29" (Re.replace_string null_rex ~by:"\\00" (Re.replace_string backslash_rex ~by:"\\5c" s))))) let of_string f = let lxbuf = Lexing.from_string f in try filter_and_eof lexfilter lxbuf with Parsing.Parse_error -> raise (Invalid_filter (lxbuf.Lexing.lex_curr_pos, "parse error")) | Failure msg -> raise (Invalid_filter (lxbuf.Lexing.lex_curr_pos, msg)) let double_star_rex = regexp "\\*\\*" let to_string (f:filter) = let rec to_string' buf f = match f with `And lst -> Buffer.add_string buf "(&"; List.iter (fun f_component -> to_string' buf f_component) lst; Buffer.add_char buf ')' | `Or lst -> Buffer.add_string buf "(|"; List.iter (fun f_component -> to_string' buf f_component) lst; Buffer.add_char buf ')' | `Not f_component -> Buffer.add_string buf "(!"; to_string' buf f_component; Buffer.add_char buf ')' | `EqualityMatch {attributeDesc=attrname;assertionValue=valu} -> Buffer.add_char buf '('; Buffer.add_string buf attrname; Buffer.add_char buf '='; Buffer.add_string buf (escape_filterstring valu); Buffer.add_char buf ')' | `Substrings {attrtype=attrname; substrings={substr_initial=initial; substr_any=any; substr_final=final}} -> Buffer.add_char buf '('; Buffer.add_string buf attrname; Buffer.add_char buf '='; Buffer.add_string buf (global_replace double_star_rex "*" ((match initial with [s] -> (escape_filterstring s) ^ "*" | [] -> "" | _ -> raise (Invalid_filter (0, "multiple substring components cannot be represented"))) ^ (match any with [] -> "" | lst -> List.fold_left (fun f s -> f ^ "*" ^ (escape_filterstring s) ^ "*") "" lst) ^ (match final with [s] -> "*" ^ (escape_filterstring s) | [] -> "" | _ -> raise (Invalid_filter (0, "multiple substring components cannot be represented"))))); Buffer.add_char buf ')'; | `GreaterOrEqual {attributeDesc=attrname;assertionValue=valu} -> Buffer.add_char buf '('; Buffer.add_string buf attrname; Buffer.add_string buf ">="; Buffer.add_string buf (escape_filterstring valu); Buffer.add_char buf ')' | `LessOrEqual {attributeDesc=attrname;assertionValue=valu} -> Buffer.add_char buf '('; Buffer.add_string buf attrname; Buffer.add_string buf "<="; Buffer.add_string buf (escape_filterstring valu); Buffer.add_char buf ')' | `ApproxMatch {attributeDesc=attrname;assertionValue=valu} -> Buffer.add_char buf '('; Buffer.add_string buf attrname; Buffer.add_string buf "~="; Buffer.add_string buf (escape_filterstring valu); Buffer.add_char buf ')' | `Present attr -> Buffer.add_char buf '('; Buffer.add_string buf attr; Buffer.add_string buf "=*"; Buffer.add_char buf ')' | `ExtensibleMatch {matchingRule=rul;ruletype=rtype; matchValue=matchval;dnAttributes=dnattrs} -> Buffer.add_char buf '('; (match rtype with Some attrname -> Buffer.add_string buf attrname; (if dnattrs then Buffer.add_string buf ":dn"); (match rul with Some r -> Buffer.add_char buf ':'; Buffer.add_string buf r | None -> ()); Buffer.add_string buf ":="; Buffer.add_string buf (escape_filterstring matchval) | None -> ((if dnattrs then Buffer.add_string buf ":dn"); (match rul with Some r -> Buffer.add_char buf ':'; Buffer.add_string buf r; Buffer.add_string buf ":="; Buffer.add_string buf (escape_filterstring matchval) | None -> raise (Invalid_filter (0, "matchingRule is required if type is unspecified"))))); Buffer.add_char buf ')' in let buf = Buffer.create 100 in to_string' buf f; Buffer.contents buf ldap-2.5.1/src/ldap/ldap_filter.mli0000644000175000017500000000424114652453725020554 0ustar kit_ty_katekit_ty_kate(** operations on ldap search filters 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 *) (** raised when something goes wrong in to_string or of_string. The integer argument is, in the case of of_string, the position in the string at which the error occurred. It has no meaning in to_string, and may take any value. *) exception Invalid_filter of int * string (** turn the string representation into the internal representation defined in ldap_types.ml. This representation is suitable for sending on the wire, and can also have all sorts of operations performed on it. play around with it in the toplevel to get a feel for it *) val of_string : string -> Ldap_types.filter (** turn an internal representaion of a filter into a string representaion compliant with rfc2254*) val to_string : Ldap_types.filter -> string (** escape a string which is intended to be the VALUE of an attribute assertion in a filter. Do not use this on a whole filter, it will destroy all the meta chars. Use it only on the VALUE part of the assertion. It is NOT necessary to use this function if you intend to call to_string, escaping will be done for you in that case. This function is exposed because you may want to manipulate a filter with a regular expression, or other string means, and you may find it necessary to escape values manually in that case. *) val escape_filterstring : string -> string ldap-2.5.1/src/ldap/ldap_filterlexer.mll0000644000175000017500000000700414652453725021617 0ustar kit_ty_katekit_ty_kate(* a lexer for rfc2254 human readable search filters 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_filterparser open Ldap_types let star = Re.compile (Re.char '*') let substr_proto = {substr_initial=[];substr_any=[];substr_final=[]} let to_substr v = let substrs = Re.split star v in (if v.[0] = '*' then (* pcre puts the empty string on the front of the list if the delimeter is the first char in the string *) let substrs = List.tl substrs in if v.[(String.length v) - 1] = '*' then {substr_proto with substr_any=substrs} else {substr_initial=[]; substr_final=[(List.hd (List.rev substrs))]; substr_any=(try List.rev (List.tl (List.rev substrs)) with _ -> [])} else if v.[(String.length v) - 1] = '*' then {substr_initial=(try [List.hd substrs] with _ -> []); substr_any=(try List.tl substrs with _ -> []); substr_final=[]} else {substr_initial=(try [List.hd substrs] with _ -> []); substr_final=(try [List.hd (List.rev substrs)] with _ -> []); substr_any=(try (List.rev (List.tl (List.rev (List.tl substrs)))) with _ -> [])}) } let lparen = '(' let rparen = ')' let andop = '&' let orop = '|' let notop = '!' let equalop = '=' let colonequalop = ":=" let approxop = '~' equalop let gteop = '>' equalop let lteop = '<' equalop let star = '*' let attr = [ '0' - '9' 'a' - 'z' 'A' - 'Z' ] + let hexdigit = [ '0' - '9' 'a' - 'f' 'A' - 'F' ] let escape = '\\' hexdigit hexdigit let value = escape | ( [ '\t' ' ' '!' - '~' ] # [ '(' ')' '&' '|' '*' ] ) let values = value + let colon = ':' let oid = ( [ '0' - '9' '.' ] + as oid) let dn = colon "dn" let matchingrule = colon oid let extendedmatchattr = (attr as a) matchingrule let extendeddnattr = (attr as a) dn (matchingrule)? let substrany = star (values star) + let substr = substrany | values substrany | substrany values | values substrany values | values star | star values | values star values rule lexfilter = parse lparen {LPAREN} | rparen {RPAREN} | andop {AND} | orop {OR} | notop {NOT} | (attr as a) equalop (substr as v) {ATTREQUALSUB (a, to_substr v)} | (attr as a) equalop star {ATTRPRESENT a} | (attr as a) equalop (values as v) {ATTREQUAL (a, v)} | (attr as a) gteop (values as v) {ATTRGTE (a, v)} | (attr as a) lteop (values as v) {ATTRLTE (a, v)} | (attr as a) approxop (values as v) {ATTRAPPROX (a, v)} | extendedmatchattr colonequalop (values as v) {ATTREXTENDEDMATCH (a, oid, v)} | extendeddnattr colonequalop (values as v) {ATTREXTENDEDDN (a, oid, v)} | eof {EOF} ldap-2.5.1/src/ldap/ldap_filterparser.mly0000644000175000017500000000643214652453725022015 0ustar kit_ty_katekit_ty_kate/* a parser for rfc2254 ldap filters 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 let star_escape_rex = Re.compile (Re.str "\\2a") let lparen_escape_rex = Re.compile (Re.str "\\28") let rparen_escape_rex = Re.compile (Re.str "\\29") let backslash_escape_rex = Re.compile (Re.str "\\5c") let null_escape_rex = Re.compile (Re.str "\\00") let unescape s = (Re.replace_string star_escape_rex ~by:"*" (Re.replace_string lparen_escape_rex ~by:"(" (Re.replace_string rparen_escape_rex ~by:")" (Re.replace_string null_escape_rex ~by:"\000" (Re.replace_string backslash_escape_rex ~by:"\\" s))))) %} %token WHSP LPAREN RPAREN AND OR NOT EOF %token ATTREQUAL %token ATTREQUALSUB %token ATTRGTE %token ATTRLTE %token ATTRAPPROX %token ATTRPRESENT %token ATTREXTENDEDMATCH %token ATTREXTENDEDDN %start filter_and_eof %type filter_and_eof %% filterlist: filterlist filter {$2 :: $1} | filter {[$1]} ; filter: LPAREN AND filterlist RPAREN {`And $3} | LPAREN OR filterlist RPAREN {`Or $3} | LPAREN NOT filter RPAREN {`Not $3} | LPAREN filter RPAREN {$2} | ATTREQUALSUB {`Substrings {attrtype=(fst $1);substrings=(snd $1)}} | ATTREQUAL {`EqualityMatch {attributeDesc=(fst $1);assertionValue=(unescape (snd $1))}} | ATTRGTE {`GreaterOrEqual {attributeDesc=(fst $1);assertionValue=(unescape (snd $1))}} | ATTRLTE {`LessOrEqual {attributeDesc=(fst $1);assertionValue=(unescape (snd $1))}} | ATTRPRESENT {`Present $1} | ATTRAPPROX {`ApproxMatch {attributeDesc=(fst $1);assertionValue=(unescape (snd $1))}} | ATTREXTENDEDMATCH {let (a, oid, v) = $1 in `ExtensibleMatch {matchingRule=(Some (unescape oid)); ruletype=(Some (unescape a)); matchValue=(unescape v); dnAttributes=false}} | ATTREXTENDEDDN {let (a, oid, v) = $1 in `ExtensibleMatch {matchingRule=(match oid with Some s -> Some (unescape s) | None -> None); ruletype=(Some (unescape a)); matchValue=(unescape v); dnAttributes=true}} ; /* used to enforce EOF at the end of the filter */ filter_and_eof: filter EOF {$1} ; ldap-2.5.1/src/ldap/ldap_funclient.ml0000644000175000017500000004040314652453725021105 0ustar kit_ty_katekit_ty_kate(* A functional client 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_protocol open Lber open Unix open Sys type msgid = Int32.t type ld_socket = Ssl of Ssl.socket | Plain of file_descr type conn = { mutable rb: readbyte; mutable socket: ld_socket; (* communications channel to the ldap server *) mutable current_msgid: Int32.t; (* the largest message id allocated so far *) pending_messages: (int32, ldap_message Queue.t) Hashtbl.t; protocol_version: int; } type modattr = modify_optype * string * string list type result = search_result_entry list type entry = search_result_entry type authmethod = [ `SIMPLE | `SASL ] type search_result = [ `Entry of entry | `Referral of (string list) | `Success of (Ldap_types.ldap_controls option) ] type page_control = [ `Noctrl | `Initctrl of int | `Subctrl of (int * string) ] let ext_res = {ext_matched_dn=""; ext_referral=None} let _ = Ssl.init () (* limits us to Int32.max_int active async operations at any one time *) let find_free_msgid con = let msgid = con.current_msgid in (if msgid = Int32.max_int then con.current_msgid <- 0l else con.current_msgid <- Int32.succ con.current_msgid); msgid (* allocate a message id from the free message id pool *) let allocate_messageid con = let msgid = find_free_msgid con in Hashtbl.replace con.pending_messages msgid (Queue.create ()); msgid let free_messageid con msgid = try Hashtbl.remove con.pending_messages msgid with Not_found -> raise (LDAP_Failure (`LOCAL_ERROR, "free_messageid: invalid msgid", ext_res)) (* send an ldapmessage *) let send_message con msg = let write ld_socket buf off len = match ld_socket with Ssl s -> (try Ssl.write s buf off len with Ssl.Write_error _ -> raise (Unix_error (EPIPE, "Ssl.write", ""))) | Plain s -> Unix.write s buf off len in let e_msg = Ldap_protocol.encode_ldapmessage msg in let e_msg = Bytes.of_string e_msg in let len = Bytes.length e_msg in let written = ref 0 in try while !written < len do written := ((write con.socket e_msg !written (len - !written)) + !written) done with Unix_error (EBADF, _, _) | Unix_error (EPIPE, _, _) | Unix_error (ECONNRESET, _, _) | Unix_error (ECONNABORTED, _, _) | Sys_error _ -> (raise (LDAP_Failure (`SERVER_DOWN, "the connection object is invalid, data cannot be written", ext_res))) (* recieve an ldapmessage for a particular message id (messages for all other ids will be read and queued. They can be retreived later) *) let receive_message con msgid = let q_for_msgid con msgid = try Hashtbl.find con.pending_messages msgid with Not_found -> raise (LDAP_Failure (`LOCAL_ERROR, "invalid message id", ext_res)) in let rec read_message con msgid = let msg = decode_ldapmessage con.rb in if msg.messageID = msgid then msg else (let q = q_for_msgid con msg.messageID in Queue.add msg q; read_message con msgid) in let q = q_for_msgid con msgid in try if Queue.is_empty q then read_message con msgid else Queue.take q with Readbyte_error Transport_error -> raise (LDAP_Failure (`SERVER_DOWN, "read error", ext_res)) | Readbyte_error End_of_stream -> raise (LDAP_Failure (`LOCAL_ERROR, "bug in ldap decoder detected", ext_res)) exception Timeout let init ?(connect_timeout = 1) ?(version = 3) hosts = if ((version < 2) || (version > 3)) then raise (LDAP_Failure (`LOCAL_ERROR, "invalid protocol version", ext_res)) else let fd = let addrs = (List.flatten (List.map (fun (mech, host, port) -> try (List.rev_map (fun addr -> (mech, addr, port)) (Array.to_list ((gethostbyname host).h_addr_list))) with Not_found -> []) (List.map (fun host -> (match Ldap_url.of_string host with {url_mech=mech;url_host=(Some host);url_port=(Some port);_} -> (mech, host, int_of_string port) | {url_mech=mech;url_host=(Some host);url_port=None;_} -> (mech, host, 389) | _ -> raise (LDAP_Failure (`LOCAL_ERROR, "invalid ldap url", ext_res)))) hosts))) in let rec open_con addrs = let previous_signal = ref Signal_default in match addrs with (mech, addr, port) :: tl -> (try if mech = `PLAIN then let s = socket PF_INET SOCK_STREAM 0 in try previous_signal := signal sigalrm (Signal_handle (fun _ -> raise Timeout)); ignore (alarm connect_timeout); connect s (ADDR_INET (addr, port)); ignore (alarm 0); set_signal sigalrm !previous_signal; Plain s with exn -> close s;raise exn else (previous_signal := signal sigalrm (Signal_handle (fun _ -> raise Timeout)); ignore (alarm connect_timeout); let ssl = Ssl (Ssl.open_connection (Ssl.SSLv23 [@ocaml.alert "-deprecated"]) (ADDR_INET (addr, port))) in ignore (alarm 0); set_signal sigalrm !previous_signal; ssl) with Unix_error (ECONNREFUSED, _, _) | Unix_error (EHOSTDOWN, _, _) | Unix_error (EHOSTUNREACH, _, _) | Unix_error (ECONNRESET, _, _) | Unix_error (ECONNABORTED, _, _) | Ssl.Connection_error _ | Timeout -> ignore (alarm 0); set_signal sigalrm !previous_signal; open_con tl) | [] -> raise (LDAP_Failure (`SERVER_DOWN, "", ext_res)) in open_con addrs in {rb=(match fd with Ssl s -> Lber.readbyte_of_ssl s | Plain s -> Lber.readbyte_of_fd s); socket=fd; current_msgid=1l; pending_messages=(Hashtbl.create 3); protocol_version=version} (* sync auth_method types between the two files *) let bind_s ?(who = "") ?(cred = "") ?(auth_method = `SIMPLE) con = let _ = auth_method in (* TODO: usused?? *) let msgid = allocate_messageid con in (try send_message con {messageID=msgid; protocolOp=Bind_request {bind_version=con.protocol_version; bind_name=who; bind_authentication=(Simple cred)}; controls=None}; match receive_message con msgid with {protocolOp=Bind_response {bind_result={result_code=`SUCCESS;_};_};_} -> () | {protocolOp=Bind_response {bind_result=res;_};_} -> raise (LDAP_Failure (res.result_code, res.error_message, {ext_matched_dn=res.matched_dn; ext_referral=res.ldap_referral})) | _ -> raise (LDAP_Failure (`LOCAL_ERROR, "invalid server response", ext_res)) with exn -> free_messageid con msgid;raise exn); free_messageid con msgid let search ?(base = "") ?(scope = `SUBTREE) ?(aliasderef=`NEVERDEREFALIASES) ?(sizelimit=0l) ?(timelimit=0l) ?(attrs = []) ?(attrsonly = false) ?(page_control = `Noctrl) con filter = let msgid = allocate_messageid con in let build_res_ctrl size cookie = {Ldap_types.criticality = false; Ldap_types.control_details=(`Paged_results_control {Ldap_types.size; Ldap_types.cookie})} in let controls = match (page_control) with | `Noctrl -> None | `Initctrl size | `Subctrl (size,_) when size < 1 -> raise (Ldap_types.LDAP_Failure(`LOCAL_ERROR, "invalid page size", ext_res)) | `Initctrl size -> Some [(build_res_ctrl size "")] | `Subctrl (size,cookie) -> Some [(build_res_ctrl size cookie)] in try let e_filter = (try Ldap_filter.of_string filter with _ -> (raise (LDAP_Failure (`LOCAL_ERROR, "bad search filter", ext_res)))) in send_message con {messageID=msgid; protocolOp=Search_request {baseObject=base; scope=scope; derefAliases=aliasderef; sizeLimit=sizelimit; timeLimit=timelimit; typesOnly=attrsonly; filter=e_filter; s_attributes=attrs}; controls}; msgid with exn -> free_messageid con msgid;raise exn let get_search_entry con msgid = try match receive_message con msgid with {protocolOp=Search_result_entry e;_} -> `Entry e | {protocolOp=Search_result_reference r;_} -> `Referral r | {protocolOp=Search_result_done {result_code=`SUCCESS;_};_} -> raise (LDAP_Failure (`SUCCESS, "success", ext_res)) | {protocolOp=Search_result_done res;_} -> raise (LDAP_Failure (res.result_code, res.error_message, {ext_matched_dn=res.matched_dn; ext_referral=res.ldap_referral})) | _ -> raise (LDAP_Failure (`LOCAL_ERROR, "unexpected search response", ext_res)) with exn -> free_messageid con msgid;raise exn let get_search_entry_with_controls con msgid = try match receive_message con msgid with {Ldap_types.protocolOp=Ldap_types.Search_result_entry e;_} -> `Entry e | {Ldap_types.protocolOp=Ldap_types.Search_result_reference r;_} -> `Referral r | {Ldap_types.protocolOp=Ldap_types.Search_result_done {Ldap_types.result_code=`SUCCESS;_};Ldap_types.controls=cntrls;_} -> `Success cntrls | {Ldap_types.protocolOp=Ldap_types.Search_result_done res;_} -> raise (Ldap_types.LDAP_Failure (res.Ldap_types.result_code, res.Ldap_types.error_message, {Ldap_types.ext_matched_dn=res.Ldap_types.matched_dn; ext_referral=res.Ldap_types.ldap_referral})) | _ -> raise (Ldap_types.LDAP_Failure (`LOCAL_ERROR, "unexpected search response", ext_res)) with exn -> free_messageid con msgid;raise exn let abandon con msgid = let my_msgid = allocate_messageid con in try free_messageid con msgid; send_message con {messageID=my_msgid; protocolOp=(Abandon_request msgid); controls=None} with exn -> free_messageid con my_msgid;raise exn let search_s ?(base = "") ?(scope = `SUBTREE) ?(aliasderef=`NEVERDEREFALIASES) ?(sizelimit=0l) ?(timelimit=0l) ?(attrs = []) ?(attrsonly = false) con filter = let msgid = search ~base:base ~scope:scope ~aliasderef:aliasderef ~sizelimit:sizelimit ~timelimit:timelimit ~attrs:attrs ~attrsonly:attrsonly con filter in let result = ref [] in (try while true do result := (get_search_entry con msgid) :: !result done with LDAP_Failure (`SUCCESS, _, _) -> () | LDAP_Failure (code, msg, ext) -> raise (LDAP_Failure (code, msg, ext)) | exn -> (try abandon con msgid with _ -> ());raise exn); free_messageid con msgid; !result let add_s con (entry: entry) = let msgid = allocate_messageid con in (try send_message con {messageID=msgid; protocolOp=Add_request entry; controls=None}; match receive_message con msgid with {protocolOp=Add_response {result_code=`SUCCESS;_};_} -> () | {protocolOp=Add_response res;_} -> raise (LDAP_Failure (res.result_code, res.error_message, {ext_matched_dn=res.matched_dn; ext_referral=res.ldap_referral})) | _ -> raise (LDAP_Failure (`LOCAL_ERROR, "invalid add response", ext_res)) with exn -> free_messageid con msgid;raise exn); free_messageid con msgid let delete_s con ~dn = let msgid = allocate_messageid con in (try send_message con {messageID=msgid; protocolOp=Delete_request dn; controls=None}; match receive_message con msgid with {protocolOp=Delete_response {result_code=`SUCCESS;_};_} -> () | {protocolOp=Delete_response res;_} -> raise (LDAP_Failure (res.result_code, res.error_message, {ext_matched_dn=res.matched_dn; ext_referral=res.ldap_referral})) | _ -> raise (LDAP_Failure (`LOCAL_ERROR, "invalid delete response", ext_res)) with exn -> free_messageid con msgid;raise exn); free_messageid con msgid let unbind con = try (match con.socket with Ssl s -> Ssl.shutdown s | Plain s -> close s) with _ -> () let modify_s con ~dn ~mods = let rec convertmods ?(converted=[]) mods = match mods with (op, attr, values) :: tl -> (convertmods ~converted:({mod_op=op; mod_value={attr_type=attr; attr_vals=values}} :: converted) tl) | [] -> converted in let msgid = allocate_messageid con in (try send_message con {messageID=msgid; protocolOp=Modify_request {mod_dn=dn; modification=convertmods mods}; controls=None}; match receive_message con msgid with {protocolOp=Modify_response {result_code=`SUCCESS;_};_} -> () | {protocolOp=Modify_response res;_} -> raise (LDAP_Failure (res.result_code, res.error_message, {ext_matched_dn=res.matched_dn; ext_referral=res.ldap_referral})) | _ -> raise (LDAP_Failure (`LOCAL_ERROR, "invalid modify response", ext_res)) with exn -> free_messageid con msgid;raise exn); free_messageid con msgid let modrdn_s ?(deleteoldrdn=true) ?(newsup=None) con ~dn ~newdn = let _ = newsup in (* TODO: not used?? *) let msgid = allocate_messageid con in (try send_message con {messageID=msgid; protocolOp=Modify_dn_request {modn_dn=dn; modn_newrdn=newdn; modn_deleteoldrdn=deleteoldrdn; modn_newSuperior=None}; controls=None}; match receive_message con msgid with {protocolOp=Modify_dn_response {result_code=`SUCCESS;_};_} -> () | {protocolOp=Modify_dn_response res;_} -> raise (LDAP_Failure (res.result_code, res.error_message, {ext_matched_dn=res.matched_dn; ext_referral=res.ldap_referral})) | _ -> raise (LDAP_Failure (`LOCAL_ERROR, "invalid modify dn response", ext_res)) with exn -> free_messageid con msgid;raise exn); free_messageid con msgid ldap-2.5.1/src/ldap/ldap_funclient.mli0000644000175000017500000002100114652453725021247 0ustar kit_ty_katekit_ty_kate(* a functional 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 *) (** a functional ldap client interface *) open Ldap_types type msgid type conn type modattr = modify_optype * string * string list type result = Ldap_types.search_result_entry list type entry = Ldap_types.search_result_entry type authmethod = [ `SIMPLE | `SASL ] type search_result = [ `Entry of entry | `Referral of string list | `Success of (ldap_controls option) ] type page_control = [ `Noctrl | `Initctrl of int | `Subctrl of (int * string) ] (** Initializes the conn data structure, and opens a connection to the server. init [["ldap://rrhost.example.com/";"ldap://backup.example.com:1389"]]. init is round robin dns aware, if dns returns multiple mappings it will try each one before finially failing. It also takes a list of hostnames, so you can specify backup servers to try. SSL and TLS are supported if selected at compile time. @param version the protocol version to use to connect, default is version 3. And actually, version 2 will probably not work correctly without some tweaking. @raise LDAP_Failure any failure to connect to the server will result in LDAP_Failure with the result_code set to `LOCAL_ERROR. @raise Failure May raise Failure "int_of_string" if you pass it a malformed url. May also raise various lexer errors under the same conditions. *) val init : ?connect_timeout:int -> ?version:int -> string list -> conn (** close the connection to the server. You may not use the conn after you have unbound, if you do you will get an exception. *) val unbind : conn -> unit (** authenticatite to the server. In this version only simple binds are supported, however the ldap_protocol.ml module DOES implement sasl binds. It would be fairly easy to support them here. We eventually will. @param who the dn to bind as @param cred the credentials to authenticate with. For `SIMPLE binds this is a password, but for `SASL binds it can be nearly anything. Perhaps a hash of the thumb print of your first born is sufficent. @param auth_method either `SIMPLE (the default) or `SASL @raise LDAP_Failure for bind errors such as `INVALID_CREDENTIALS @raise Decoding_error for decoder errors (unlikely, probably a bug) @raise Encoding_error for encoder errors (unlikely, probably a bug) *) val bind_s : ?who:string -> ?cred:string -> ?auth_method:[> `SIMPLE ] -> conn -> unit (** Search for the given entry with the specified base node and search scope, optionally limiting the returned attributes to those listed in 'attrs'. aliasderef sets the server's alias dereferencing policy, sizelimit is the number of entries to return, timelimit is the number of seconds to allow the search to run for, attrsonly tells the server not to return the values. This is the asyncronus version of search (it does not block) you will need to call the get_search_entry function below to actually get any data back. This function will return a msgid which you must use when you call get_search_entry. @param base The dn of the object in the tree to use as the base object, the search will only cover children of this object, and will be further governed by scope. @param scope The depth in the tree to look for the requested object. There are three possible values, `BASE, `ONELEVEL, and `SUBTREE. `BASE means to only search the base object, the search will return exactly 1 or 0 objects. `ONELEVEL means to search one level under the base, only immediate children of the base object will be considered. `SUBTREE means to search the entire tree under the base object. @param aliasderef Controls when aliases are dereferenced. @param sizelimit The maximum number of objects to return @param timelimit The maximum time, in seconds, that the search will be allowed to run before terminateing. @param attrs The list of attribute types (names) to include [[]] (the default) means all. @param attrsonly return only attribute types (names), not any of the values @raise LDAP_Failure for immediate errors (bad filter, etc) @raise Decoding_error for decoder errors (unlikely, probably a bug) @raise Encoding_error for encoder errors (unlikely, probably a bug) *) val search : ?base:string -> ?scope:Ldap_types.search_scope -> ?aliasderef:Ldap_types.alias_deref -> ?sizelimit:int32 -> ?timelimit:int32 -> ?attrs:string list -> ?attrsonly:bool -> ?page_control:page_control -> conn -> string -> msgid (** fetch a search entry from the wire using the given msgid. The entry could be a search entry, OR it could be a referral structure. @raise LDAP_Failure for all results other than `SUCCESS (except referrals) @raise Decoding_error for decoder errors (unlikely, probably a bug) @raise Encoding_error for encoder errors (unlikely, probably a bug) *) val get_search_entry : conn -> msgid -> [> `Entry of Ldap_types.search_result_entry | `Referral of string list ] (** fetch a search entry from the wire using the given msgid. The entry could be a search entry, OR it could be a referral structure. The version supports passing ldap_controls (like page control) through on success. Returning an entry of type `SUCCESS was thus needed. @raise LDAP_Failure for all results other than `SUCCESS (except referrals) @raise Decoding_error for decoder errors (unlikely, probably a bug) @raise Encoding_error for encoder errors (unlikely, probably a bug) *) val get_search_entry_with_controls : conn -> msgid -> [> `Entry of Ldap_types.search_result_entry | `Referral of string list | `Success of (ldap_controls option) ] (** abandon the async request attached to msgid. @raise Encoding_error for encoder errors (unlikely, probably a bug) *) val abandon : conn -> msgid -> unit (** This is the syncronus version of search. It blocks until the search is complete, and returns a list of objects. It is exactly the same in all other ways. *) val search_s : ?base:string -> ?scope:Ldap_types.search_scope -> ?aliasderef:Ldap_types.alias_deref -> ?sizelimit:int32 -> ?timelimit:int32 -> ?attrs:string list -> ?attrsonly:bool -> conn -> string -> [> `Entry of Ldap_types.search_result_entry | `Referral of string list ] list (** add entry to the directory @raise LDAP_Failure for all results other than `SUCCESS @raise Decoding_error for decoder errors (unlikely, probably a bug) @raise Encoding_error for encoder errors (unlikely, probably a bug) *) val add_s : conn -> entry -> unit (** delete the entry named by dn from the directory @raise LDAP_Failure for all results other than `SUCCESS @raise Decoding_error for decoder errors (unlikely, probably a bug) @raise Encoding_error for encoder errors (unlikely, probably a bug) *) val delete_s : conn -> dn:string -> unit (** apply the list of modifications to the named entry @param dn The dn of the object to modify @param mods The list of modifications to apply @raise LDAP_Failure for all results other than `SUCCESS @raise Decoding_error for decoder errors (unlikely, probably a bug) @raise Encoding_error for encoder errors (unlikely, probably a bug) *) val modify_s : conn -> dn:string -> mods:(Ldap_types.modify_optype * string * string list) list -> unit (** change the rdn, and optionally the superior entry of dn @param deleteoldrdn Delete the old rdn value, (default true) @param newsup The new superior dn of the object (default None) @param dn The dn of the object to modify @param newrdn The new rdn value (eg. cn=bob) @raise LDAP_Failure for all results other than `SUCCESS @raise Decoding_error for decoder errors (unlikely, probably a bug) @raise Encoding_error for encoder errors (unlikely, probably a bug) *) val modrdn_s : ?deleteoldrdn:bool -> ?newsup:'a option -> conn -> dn:string -> newdn:string -> unit ldap-2.5.1/src/ldap/ldap_funserver.ml0000644000175000017500000004056414652453725021145 0ustar kit_ty_katekit_ty_kate(* 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 Lber open Ldap_types open Ldap_protocol open Unix open Printf exception Server_error of string exception Finished type connection_id = int type backendInfo = { bi_op_bind : (connection_id -> ldap_message -> ldap_message) option; bi_op_unbind : (connection_id -> ldap_message -> unit) option; bi_op_search : (connection_id -> ldap_message -> (unit -> ldap_message)) option; bi_op_compare : (connection_id -> ldap_message -> ldap_message) option; bi_op_modify : (connection_id -> ldap_message -> ldap_message) option; bi_op_modrdn : (connection_id -> ldap_message -> ldap_message) option; bi_op_add : (connection_id -> ldap_message -> ldap_message) option; bi_op_delete : (connection_id -> ldap_message -> ldap_message) option; bi_op_abandon : (connection_id -> ldap_message -> unit) option; bi_op_extended : (connection_id -> ldap_message -> ldap_message) option; bi_init : (unit -> unit) option; bi_close : (unit -> unit) option; } type log_level = [ `GENERAL | `CONNECTION | `OPERATIONS | `ERROR | `TRACE ] type opcnt = int type pending_operations = (unit -> unit) list type server_info = { si_listening_socket: file_descr; si_client_sockets: (file_descr, connection_id * opcnt * pending_operations * readbyte) Hashtbl.t; si_backend: backendInfo; si_log: (log_level -> string -> unit); mutable si_current_connection_id: int; } let allocate_connection_id si = if si.si_current_connection_id < max_int then (si.si_current_connection_id <- si.si_current_connection_id + 1; si.si_current_connection_id) else (si.si_current_connection_id <- 1;1) let log_result conn_id op_nr si msg = let log_search_result {result_code=err;error_message=text;_} = si.si_log `OPERATIONS (sprintf "conn=%d op=%d SEARCH RESULT tag=0 err=%d nentries=0 text=%s" conn_id op_nr (Ldap_protocol.encode_resultcode err) text) in let log_normal_result {result_code=err;error_message=text;_} = si.si_log `OPERATIONS (sprintf "conn=%d op=%d RESULT tag=0 err=%d text=%s" conn_id op_nr (Ldap_protocol.encode_resultcode err) text) in match msg.protocolOp with Bind_response {bind_result=result;_} | Modify_response result | Add_response result | Delete_response result | Modify_dn_response result | Compare_response result -> log_normal_result result | Search_result_done result -> log_search_result result | _ -> () let send_message si conn_id op_nr fd msg = let e_msg = encode_ldapmessage msg in let e_msg = Bytes.of_string e_msg in let len = Bytes.length e_msg in let written = ref 0 in try while !written < len do written := ((write fd e_msg !written (len - !written)) + !written) done; log_result conn_id op_nr si msg with Unix_error (_, _, _) -> (try close fd with _ -> ()); raise (Server_error "data cannot be written") let keys h = Hashtbl.fold (fun k _v l -> k :: l) h [] let init ?(log=(fun _ _ -> ())) ?(port=389) bi = let s = let s = socket PF_INET SOCK_STREAM 0 in setsockopt s SO_REUSEADDR true; bind s (ADDR_INET (inet_addr_any, port)); listen s 500; s in (match bi.bi_init with Some f -> f () | None -> ()); {si_listening_socket=s; si_client_sockets=Hashtbl.create 10; si_current_connection_id=0; si_log=log; si_backend=bi} let shutdown si = (match si.si_backend.bi_close with Some f -> f () | None -> ()); close si.si_listening_socket; List.iter (fun fd -> close fd) (keys si.si_client_sockets); Hashtbl.clear si.si_client_sockets; si.si_log `GENERAL "stopped." let dispatch_request si conn_id op_nr rb fd = let bi = si.si_backend in let not_imp msg op = {messageID=msg.messageID; protocolOp=op; controls=None} in let not_implemented = {result_code=`OTHER; matched_dn=""; error_message="Not Implemented"; ldap_referral=None} in let message = decode_ldapmessage rb in match message with {protocolOp=Bind_request {bind_name=dn;bind_authentication=auth;_};_} -> si.si_log `OPERATIONS (sprintf "conn=%d op=%d BIND dn=\"%s\" method=128" conn_id op_nr dn); si.si_log `OPERATIONS (sprintf "conn=%d op=%d BIND dn=\"%s\" mech=%s ssf=0" conn_id op_nr dn (match auth with Simple _ -> "SIMPLE" | Sasl _ -> "SASL")); (match bi.bi_op_bind with Some f -> (fun () -> send_message si conn_id op_nr fd (f conn_id message); raise Finished) | None -> (fun () -> send_message si conn_id op_nr fd (not_imp message (Bind_response {bind_result=not_implemented; bind_serverSaslCredentials=None})); raise Finished)) | {protocolOp=Unbind_request;_} -> si.si_log `OPERATIONS (sprintf "conn=%d op=%d UNBIND" conn_id op_nr); (match bi.bi_op_unbind with Some f -> (fun () -> f conn_id message;raise Finished) | None -> (fun () -> raise Finished)) | {protocolOp=(Search_request {baseObject=base; scope=scope; derefAliases=deref; sizeLimit=_sizelimit; timeLimit=_timelimit; typesOnly=_attrsonly; filter=filter; s_attributes=attrs});_} -> si.si_log `OPERATIONS (sprintf "conn=%d op=%d SRCH base=\"%s\" scope=%d deref=%d filter=\"%s\"" conn_id op_nr base (match scope with `BASE -> 0 | `ONELEVEL -> 1 | `SUBTREE -> 2) (match deref with `NEVERDEREFALIASES -> 0 | `DEREFINSEARCHING -> 1 | `DEREFFINDINGBASE -> 2 | `DEREFALWAYS -> 3) (Ldap_filter.to_string filter)); (match attrs with [] -> () | lst -> si.si_log `OPERATIONS (sprintf "conn=%d op=%d SRCH attr=%s" conn_id op_nr (List.fold_left (fun s attr -> if s = "" then attr else (attr ^ " " ^ s)) "" lst))); (match bi.bi_op_search with Some f -> let get_srch_result = f conn_id message in (fun () -> let msg = get_srch_result () in send_message si conn_id op_nr fd msg; match msg.protocolOp with Search_result_done _ -> raise Finished | _ -> ()) | None -> (fun () -> send_message si conn_id op_nr fd (not_imp message (Search_result_done not_implemented)); raise Finished)) | {protocolOp=Modify_request {mod_dn=modify;modification=modlst};_} -> si.si_log `OPERATIONS (sprintf "conn=%d op=%d MOD dn=\"%s\"" conn_id op_nr modify); si.si_log `OPERATIONS (sprintf "conn=%d op=%d MOD attr=\"%s\"" conn_id op_nr (List.fold_left (fun s attr -> if s = "" then attr.mod_value.attr_type else (attr.mod_value.attr_type ^ " " ^ s)) "" modlst)); (match bi.bi_op_modify with Some f -> (fun () -> send_message si conn_id op_nr fd (f conn_id message); raise Finished) | None -> (fun () -> send_message si conn_id op_nr fd (not_imp message (Modify_response not_implemented)); raise Finished)) | {protocolOp=Add_request {sr_dn=dn;_};_} -> si.si_log `OPERATIONS (sprintf "conn=%d op=%d ADD dn=\"%s\"" conn_id op_nr dn); (match bi.bi_op_add with Some f -> (fun () -> send_message si conn_id op_nr fd (f conn_id message); raise Finished) | None -> (fun () -> send_message si conn_id op_nr fd (not_imp message (Add_response not_implemented)); raise Finished)) | {protocolOp=Delete_request dn;_} -> si.si_log `OPERATIONS (sprintf "conn=%d op=%d DEL dn=\"%s\"" conn_id op_nr dn); (match bi.bi_op_delete with Some f -> (fun () -> send_message si conn_id op_nr fd (f conn_id message); raise Finished) | None -> (fun () -> send_message si conn_id op_nr fd (not_imp message (Delete_response not_implemented)); raise Finished)) | {protocolOp=Modify_dn_request {modn_dn=dn;_};_} -> si.si_log `OPERATIONS (sprintf "conn=%d op=%d MODRDN dn=\"%s\"" conn_id op_nr dn); (match bi.bi_op_modrdn with Some f -> (fun () -> send_message si conn_id op_nr fd (f conn_id message); raise Finished) | None -> (fun () -> send_message si conn_id op_nr fd (not_imp message (Modify_dn_response not_implemented)); raise Finished)) | {protocolOp=Compare_request {cmp_dn=dn;cmp_ava=ava};_} -> si.si_log `OPERATIONS (sprintf "conn=%d op=%d CMP dn=\"%s\" attr=\"%s\"" conn_id op_nr dn ava.attributeDesc); (match bi.bi_op_compare with Some f -> (fun () -> send_message si conn_id op_nr fd (f conn_id message); raise Finished) | None -> (fun () -> send_message si conn_id op_nr fd (not_imp message (Compare_response not_implemented)); raise Finished)) | {protocolOp=Abandon_request msgid;_} -> si.si_log `OPERATIONS (sprintf "conn=%d op=%d ABANDON msgid=%ld" conn_id op_nr msgid); (match bi.bi_op_abandon with Some f -> (fun () -> f conn_id message;raise Finished) | None -> (fun () -> raise Finished)) | {protocolOp=Extended_request _;_} -> (match bi.bi_op_extended with Some f -> (fun () -> send_message si conn_id op_nr fd (f conn_id message); raise Finished) | None -> (fun () -> send_message si conn_id op_nr fd (not_imp message (Extended_response {ext_result=not_implemented; ext_responseName=None; ext_response=None})); raise Finished)) | _ -> raise (Server_error "invalid operation") let string_of_sockaddr sockaddr = match sockaddr with ADDR_UNIX addr -> addr | ADDR_INET (ip, port) -> (sprintf "%s:%d" (string_of_inet_addr ip) port) let run si = let pending_writes si = (* do we have data to write? *) Hashtbl.fold (fun k (_, _, ops_pending, _) pending -> match ops_pending with [] -> pending | _ -> k :: pending) si.si_client_sockets [] in let process_read reading writing excond (fd:file_descr) = if Hashtbl.mem si.si_client_sockets fd then (* an existing client has requested a new operation *) let (conn_id, op_nr, pending_ops, rb) = Hashtbl.find si.si_client_sockets fd in try try Hashtbl.replace si.si_client_sockets fd (conn_id, (op_nr + 1), (dispatch_request si conn_id op_nr rb fd) :: pending_ops, rb) with LDAP_Decoder e | Decoding_error e -> (* handle protocol errors *) send_message si conn_id 0 fd (* send a notice of disconnection *) {messageID=0l; protocolOp=Extended_response {ext_result={result_code=`PROTOCOL_ERROR; matched_dn=""; error_message=e; ldap_referral=None}; ext_responseName=(Some "1.3.6.1.4.1.1466.20036"); ext_response=None}; controls=None}; raise (Readbyte_error Transport_error) (* close the connection *) with Readbyte_error Transport_error -> (match si.si_backend.bi_op_unbind with Some f -> f conn_id {messageID=0l;protocolOp=Unbind_request;controls=None} | None -> ()); (* remove the client from our table of clients, and from the list of readable/writable fds, that way we don't try to do a write to them, even though we may have pending writes *) Hashtbl.remove si.si_client_sockets fd; reading := List.filter ((<>) fd) !reading; writing := List.filter ((<>) fd) !writing; excond := List.filter ((<>) fd) !excond; (try close fd with _ -> ()); si.si_log `CONNECTION (sprintf "conn=%d fd=0 closed" conn_id) else (* a new connection has come in, accept it *) let (newfd, sockaddr) = accept fd in let rb = readbyte_of_fd newfd in let connid = allocate_connection_id si in Hashtbl.add si.si_client_sockets newfd (connid, 0, [], rb); si.si_log `CONNECTION (sprintf "conn=%d fd=0 ACCEPT from IP=%s (IP=%s)" connid (string_of_sockaddr sockaddr) (string_of_sockaddr (getsockname fd))) in let process_write reading writing excond (fd: file_descr) = if Hashtbl.mem si.si_client_sockets fd then let (conn_id, op_nr, pending_ops, rb) = Hashtbl.find si.si_client_sockets fd in try match pending_ops with [] -> () | hd :: tl -> try hd () with Finished -> Hashtbl.replace si.si_client_sockets fd (conn_id, op_nr, tl, rb) with Server_error "data cannot be written" -> (match si.si_backend.bi_op_unbind with Some f -> f conn_id {messageID=0l;protocolOp=Unbind_request;controls=None} | None -> ()); Hashtbl.remove si.si_client_sockets fd; reading := List.filter ((<>) fd) !reading; writing := List.filter ((<>) fd) !writing; excond := List.filter ((<>) fd) !excond; si.si_log `CONNECTION (sprintf "conn=%d fd=0 closed" conn_id) else raise (Server_error "socket to write to not found") in si.si_log `GENERAL "starting"; while true do let fds = keys si.si_client_sockets in let reading = ref [] and writing = ref [] and excond = ref [] in let (rd, wr, ex) = select (si.si_listening_socket :: fds) (pending_writes si) (* nothing to write? don't bother *) fds (-1.0) in reading := rd;writing := wr;excond := ex; (* service connections which are ready to be read *) List.iter (process_read reading writing excond) !reading; (* service connections which are ready to be written to *) List.iter (process_write reading writing excond) !writing; (* Process out of band data *) List.iter (process_read reading writing excond) !excond done ldap-2.5.1/src/ldap/ldap_funserver.mli0000644000175000017500000000641614652453725021314 0ustar kit_ty_katekit_ty_kate(* 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 *) (** A functional ldap server construction kit *) open Ldap_types (** raised whenever an error occurrs in the server *) exception Server_error of string type connection_id = int (** This structure is the guts of the ldap server. For each operation that you implement put the function (or closure) of the correct type in this structure. Any functions you set as None will return `UNWILLING_TO_PERFORM, with the error string set to "not implemented". bi_init will be called (if it is provided) before the server is brought up, and bi_close (if it is provided) will be called before the server is brought down. This interface is based loosely on the back-end api in OpenLDAP.*) type backendInfo = { bi_op_bind : (connection_id -> ldap_message -> ldap_message) option; bi_op_unbind : (connection_id -> ldap_message -> unit) option; bi_op_search : (connection_id -> ldap_message -> (unit -> ldap_message)) option; bi_op_compare : (connection_id -> ldap_message -> ldap_message) option; bi_op_modify : (connection_id -> ldap_message -> ldap_message) option; bi_op_modrdn : (connection_id -> ldap_message -> ldap_message) option; bi_op_add : (connection_id -> ldap_message -> ldap_message) option; bi_op_delete : (connection_id -> ldap_message -> ldap_message) option; bi_op_abandon : (connection_id -> ldap_message -> unit) option; bi_op_extended : (connection_id -> ldap_message -> ldap_message) option; bi_init : (unit -> unit) option; bi_close : (unit -> unit) option; } type log_level = [ `GENERAL | `CONNECTION | `OPERATIONS | `ERROR | `TRACE ] (** This abstract type contains the server context. It has the listening, socket, all the connected client sockets, and some internal data structures. *) type server_info (** Initialize the server, create the listening socket and return the server context, which you will pass to serv to process connections. log is a string -> log_level -> unit function to which log messages will be sent. *) val init : ?log:(log_level -> string -> unit) -> ?port:int -> backendInfo -> server_info (** Shutdown the server *) val shutdown : server_info -> unit (** Using the supplied server context, begin processing ldap operations. This function should never terminate unless there is an exceptional condition, in which case the exception will be raised. In many cases it is safe to restart the server process when an exception happens. *) val run : server_info -> unit ldap-2.5.1/src/ldap/ldap_mutex.ml0000644000175000017500000000607314652453725020265 0ustar kit_ty_katekit_ty_kateopen Ldap_ooclient open Ldap_types (* ldap mutexes *) 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 (* the mutex is locked already *) LDAP_Failure (`TYPE_OR_VALUE_EXISTS, _, _) | LDAP_Failure (`OBJECT_CLASS_VIOLATION, _, _) -> (* this is so evil *) ignore (Unix.select [] [] [] 0.25) (* wait 1/4 of a second *) 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 ldap-2.5.1/src/ldap/ldap_mutex.mli0000644000175000017500000000347514652453725020441 0ustar kit_ty_katekit_ty_kate(** functions for implementing mutexes on top of LDAP's built in test and set mechanism. In order to use this module you must load mutex.schema, which is an rfc2252 format schema file. raised when a mutex operation fails. The string argument contains the name of the method which failed, and the exception contains details about what failed. *) exception Ldap_mutex of string * exn (** the class type of a single mutex, used for performing advisory locking of some action *) class type mutex_t = object method lock: unit method unlock: unit end (** the class type of an object lock table which allows for advisory locking of objects by dn *) class type object_lock_table_t = object method lock: Ldap_types.dn -> unit method unlock: Ldap_types.dn -> unit end (** new mutex ldapurls binddn bindpw mutexdn *) class mutex: string list -> string -> string -> string -> object (** lock the mutex. This WILL block if the mutex is already locked *) method lock: unit (** unlock the mutex *) method unlock: unit end (** used to apply some function, first locking the mutex, unlocking it only after the function has been applied. If the function generates any exception, this wrapper catches that exception, and unlocks the mutex before reraising the exception. Generally garentees that the mutex will always be used consistantly when performing an action. *) val apply_with_mutex: mutex -> (unit -> 'a) -> 'a (** new object_lock_table ldapurls binddn bindpw mutexdn *) class object_lock_table: string list -> string -> string -> string -> object (** lock the specified dn, if it is already locked, then block until the lock can be aquired *) method lock: Ldap_types.dn -> unit (** unlock the specified dn, if it is not locked do nothing *) method unlock: Ldap_types.dn -> unit end ldap-2.5.1/src/ldap/ldap_ooclient.ml0000644000175000017500000013747014652453725020745 0ustar kit_ty_katekit_ty_kate(* 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 (* 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;; let format_entry e = Format.open_box 0; Format.open_box 2; Format.print_string (" 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 () exception Limit 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 raise Limit else if !i < length - 1 then begin Format.print_string ("; "); Format.print_cut (); i := !i + 1 end else Format.print_string ("")) lst with 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_ascii 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 (String.lowercase_ascii x) method add (x:op_lst) = let rec do_add (x:op_lst) = match x with [] -> () | (name, value) :: lst -> let lcname = String.lowercase_ascii 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 = String.lowercase_ascii 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 (String.lowercase_ascii 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 (String.lowercase_ascii 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 _referral_policy = referral_policy (* TODO: not used?? *) 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 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_ascii 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 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 (String.lowercase_ascii (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 -> String.lowercase_ascii (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_ascii (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 (String.lowercase_ascii 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 (String.lowercase_ascii 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 (String.lowercase_ascii 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;; ldap-2.5.1/src/ldap/ldap_ooclient.mli0000644000175000017500000006503014652453725021106 0ustar kit_ty_katekit_ty_kate(* 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 *) (** an object oriented ldap client interface *) open Ldap_types (** {1 Basic Data Types} *) (** the type of an operation, eg. [("cn", ["foo";"bar"])] *) type op = string * string list type op_lst = op list (** The policy the client should take when it encounteres a referral. This is currently not used *) type referral_policy = [ `FOLLOW | `RETURN ] (** The change type of an ldapentry. This controls some aspects of it's behavior *) type changetype = [ `ADD | `DELETE | `MODDN | `MODIFY | `MODRDN ] (** {1 Local Representation of LDAP Objects} *) (** The base type of an ldap entry represented in memory. *) class type ldapentry_t = object method add : op_lst -> unit method attributes : string list method changes : (Ldap_types.modify_optype * string * string list) list method changetype : changetype method delete : op_lst -> unit method dn : string method diff : ldapentry_t -> (modify_optype * string * string list) list method exists : string -> bool method flush_changes : unit method get_value : string -> string list method modify : (Ldap_types.modify_optype * string * string list) list -> unit method print : unit method replace : op_lst -> unit method set_changetype : changetype -> unit method set_dn : string -> unit end (** this object represents a remote object within local memory. It records all local changes made to it (if it's changetype is set to `MODIFY), and can commit them to the server at a later time via {!Ldap_ooclient.ldapcon.update_entry}. *) class ldapentry : object (** add values to an attribute (or create a new attribute). Does not change the server until you update *) method add : op_lst -> unit (** return a list of the type (name) of all the attributes present on the object *) method attributes : string list (** return a list of changes made to the object in a the format of a modify operation. For example, you can apply the changes to another ldapentry object using the {!Ldap_ooclient.ldapentry.modify} method *) method changes : (Ldap_types.modify_optype * string * string list) list (** return the changetype of the object *) method changetype : changetype (** delete attributes from the object, does not change the directory until you update *) method delete : op_lst -> unit (** return the dn of the object *) method dn : string (** given an ldapentry, return the differences between the current entry and the specified entry in the form of a modify operation which would make the specified entry the same as the current entry. *) method diff : ldapentry_t -> (modify_optype * string * string list) list (** query whether the attribute type (name) exists in the object *) method exists : string -> bool (** clear all accumulated changes *) method flush_changes : unit (** get the value of an attribute @raise Not_found If the attribute does not exist. *) method get_value : string -> string list (** Apply modifications to object in memory, does not change the database until you update using {!Ldap_ooclient.ldapcon.update_entry} *) method modify : (Ldap_types.modify_optype * string * string list) list -> unit (** @deprecated print an ldif like representation of the object to stdout, see Ldif_oo for standards compliant ldif. Usefull for toplevel sessions. *) method print : unit (** replace values in the object, does not change the database until you call update *) method replace : op_lst -> unit (** set the changetype of the object *) method set_changetype : changetype -> unit (** set the dn of the object *) method set_dn : string -> unit end (** {1 Miscallaneous} *) (** toplevel formatter for ldapentry, prints the whole entry with a nice structure. Each attribute is in the correct syntax to be copied and pasted into a modify operation. *) val format_entry : < attributes : string list; dn : string; get_value : string -> string list; .. > -> unit (** format lists of entries, in this case only print the dn *) val format_entries : < attributes : string list; dn : string; get_value : string -> string list; .. > list -> unit (** The type of an ldap change record, used by extended LDIF *) type changerec = [`Modification of string * ((Ldap_types.modify_optype * string * string list) list) | `Addition of ldapentry | `Delete of string | `Modrdn of string * int * string] (** {1 Communication with Ldap_funclient} *) (** See {!Ldap_funclient} *) (** given a search_result_entry as returned by ldap_funclient, produce an ldapentry containing either the entry, or the referral object *) val to_entry : [< `Entry of Ldap_types.search_result_entry | `Referral of string list ] -> ldapentry (** given an ldapentry as returned by ldapcon, or constructed manually, produce a search_result_entry suitable for ldap_funclient, or ldap_funserver. *) val of_entry : ldapentry -> search_result_entry (** {1 Interacting with LDAP Servers} *) (** This class abstracts a connection to an LDAP server (or servers), an instance will be connected to the server you specify and can be used to perform operations on that server. {2 Example} [new ldapcon ~connect_timeout:5 ~version:3 ["ldap://first.ldap.server";"ldap://second.ldap.server"]]. In addition to specifying multiple urls, if DNS names are given, and those names are bound to multiple addresses, then all possible addresses will be tried. {2 Example} [new ldapcon ["ldaps://rrldap.csun.edu"]] is equivelant to [new ldapcon ["ldap://130.166.1.30";"ldap://130.166.1.31";"ldap://130.166.1.32"]] This means that if any host in the rr fails, the ldapcon will transparently move on to the next host, and you will never know the difference. @raise LDAP_Failure All methods raise {!Ldap_types.LDAP_Failure} on error @param connect_timeout Default [1], an integer which specifies how long to wait for any given server in the list to respond before trying the next one. After all the servers have been tried for [connect_timeout] seconds [LDAP_Failure (`SERVER_DOWN, ...)] will be raised. @param referral_policy In a future version of ocamldap this will be used to specify what you would like to do in the event of a referral. Currently it does nothing and is ignored see {!Ldap_ooclient.referral_policy}. @param version The protocol version to use, the default is [3], the other recognized value is [2]. *) class ldapcon : ?connect_timeout:int -> ?referral_policy:[> `RETURN ] -> ?version:int -> string list -> object (** {1 Authentication} *) (** bind to the database using dn. {2 Simple Bind Example} [ldap#bind ~cred:"password" "cn=foo,ou=people,ou=auth,o=bar"] To bind anonymously, omit ~cred, and leave dn blank eg. {2 Example} [ldap#bind ""] @param cred The credentials to provide for binding. Default [""]. @param meth The method to use when binding See {!Ldap_funclient.authmethod} the default is [`SIMPLE]. If [`SASL] is used then [dn] and [~cred] Are interperted according to the chosen SASL mechanism. SASL binds have not been tested extensively. *) method bind : ?cred:string -> ?meth:Ldap_funclient.authmethod -> string -> unit (** Deauthenticate and close the connection to the server *) method unbind : unit (** {1 Searching} *) (** Search the directory syncronously for an entry which matches the search criteria. {2 Example} [ldap#search ~base:"dc=foo,dc=bar" ~attrs:["cn"] "uid=*"] @param scope Default [`SUBTREE], defines the scope of the search. see {!Ldap_types.search_scope} @param attrs Default [[]] (means all attributes) @param attrsonly Default [false] If true, asks the server to return only the attribute names, not their values. @param base Default [""], The search base, which is the dn of the object from which you want to start your search. Only that object, and it's children will be included in the search. Further controlled by [~scope]. @param timelimit The time limit (in seconds) to allow the search to run for. Default [0l], which means there is no user specified time limit, the server may still impose one. @param sizelimit The max number of entries to return from the search (in number of entries) *) method search : ?scope:Ldap_types.search_scope -> ?attrs:string list -> ?attrsonly:bool -> ?base:string -> ?sizelimit:Int32.t -> ?timelimit:Int32.t -> string -> ldapentry list (** Search the directory asyncronously, otherwise the same as search. *) method search_a : ?scope:Ldap_types.search_scope -> ?attrs:string list -> ?attrsonly:bool -> ?base:string -> ?sizelimit:Int32.t -> ?timelimit:Int32.t -> string -> (?abandon:bool -> unit -> ldapentry) (** Fetch the raw (unparsed) schema from the directory using the standard mechanism (requires protocol version 3) *) method rawschema : ldapentry (** Fetch and parse the schema from the directory via the standard mechanism (requires version 3). Return a structured representation of the schema indexed by canonical name, and oid. *) method schema : Ldap_schemaparser.schema (** {1 Making Modifications} *) (** add an entry to the database *) method add : ldapentry -> unit (** Delete the object named by dn from the database *) method delete : string -> unit (** Modify the entry named by dn, applying mods {2 Example} [ldap#modify "uid=foo,ou=people,dc=bar,dc=baz" [(`DELETE, "cn", ["foo";"bar"])]] *) method modify : string -> (Ldap_types.modify_optype * string * string list) list -> unit (** Syncronize changes made locally to an ldapentry with the directory. *) method update_entry : ldapentry -> unit (** Modify the rdn of the object named by dn, if the protocol version is 3 you may additionally change the superior, the rdn will be changed to the attribute represented (as a string) by newrdn, {2 Example With New Superior} [ldap#modrdn ~newsup:(Some "o=csun") "cn=bob,ou=people,o=org" "uid=bperson"] After this example "cn=bob,ou=people,o=org" will end up as "uid=bperson,o=csun". @param deleteoldrdn Default [true], delete the old rdn value as part of the modrdn. @param newsup Default [None], only valid when the protocol version is 3, change the object's location in the tree, making its superior equal to the specified object. *) method modrdn : string -> ?deleteoldrdn:bool -> ?newsup:string option -> string -> unit end (** {1 Iterators Over Streams of ldapentry Objects} *) (** given a source of ldapentry objects (unit -> ldapentry), such as the return value of ldapcon#search_a, apply f (first arg) to each entry See List.iter *) val iter : (ldapentry -> unit) -> (?abandon:bool -> unit -> ldapentry) -> unit (** given a source of ldapentry objects (unit -> ldapentry), such as the return value of ldapcon#search_a apply f (first arg) to each entry in reverse, and return a list containing the result of each application. See List.map *) val rev_map : (ldapentry -> 'a) -> (?abandon:bool -> unit -> ldapentry) -> 'a list (** same as rev_map, but does it in order *) val map : (ldapentry -> 'a) -> (?abandon:bool -> unit -> ldapentry) -> 'a list (** given a source of ldapentry objects (unit -> ldapentry), such as the return value of ldapcon#search_a compute (f eN ... (f e2 (f e1 intial))) see List.fold_right. *) val fold : (ldapentry -> 'a -> 'a) -> 'a -> (?abandon:bool -> unit -> ldapentry) -> 'a (** {1 Schema Aware ldapentry Derivatives} *) (** {2 General Schema Aware Entry} *) (** {!Ldap_ooclient.scldapentry}, A schema aware derivative of {!Ldap_ooclient.ldapentry}. It contains an rfc2252 schema checker, and given the database schema, it can be used to garentee that operations performed in memory are valid against a standards compliant database. It has numerious uses, translation between two databases with different schemas an example of where it finds natural usage. For an example application @see tdir *) (** an ordered oid type, for placing oids in sets *) module OrdOid : sig type t = Ldap_schemaparser.Oid.t val compare : t -> t -> int end (** A set of Oids @deprecated the name is historical, and may be changed *) module Setstr : sig type elt = OrdOid.t type t = Set.Make(OrdOid).t val empty : t val is_empty : t -> bool val mem : elt -> t -> bool val add : elt -> t -> t val singleton : elt -> t val remove : elt -> t -> t val union : t -> t -> t val inter : t -> t -> t val diff : t -> t -> t val compare : t -> t -> int val equal : t -> t -> bool val subset : t -> t -> bool val iter : (elt -> unit) -> t -> unit val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a val for_all : (elt -> bool) -> t -> bool val exists : (elt -> bool) -> t -> bool val filter : (elt -> bool) -> t -> t val partition : (elt -> bool) -> t -> t * t val cardinal : t -> int val elements : t -> elt list val min_elt : t -> elt val max_elt : t -> elt val choose : t -> elt val split : elt -> t -> t * bool * t end (** The type of schema checking to perform in {!Ldap_ooclient.scldapentry}. Normally this is picked automatically, however it can be overridden in some cases. *) type scflavor = Optimistic (** Add missing attributes to make the object consistant, or add objectclasses in order to make illegal attribues legal *) | Pessimistic (** Delete objectclasses which must attributes which are missing, and delete illegal attributes. *) (** given a name of an attribute name (canonical or otherwise), return its oid @raise Invalid_attribute If the attribute is not found in the schema. *) val attrToOid : Ldap_schemaparser.schema -> Ldap_schemaparser.Lcstring.t -> Ldap_schemaparser.Oid.t (** given the oid of an attribute, return its canonical name @raise Invalid_attribute If the attribute is not found in the schema. *) val oidToAttr : Ldap_schemaparser.schema -> Ldap_schemaparser.Oid.t -> string (** given a name of an objectclass (canonical or otherwise), return its oid. @raise Invalid_objectclass If the objectclass is not found in the schema. *) val ocToOid : Ldap_schemaparser.schema -> Ldap_schemaparser.Lcstring.t -> Ldap_schemaparser.Oid.t (** given the oid of an objectclass, return its canonical name @raise Invalid_objectclass If the objectclass is not found in the schema. *) val oidToOc : Ldap_schemaparser.schema -> Ldap_schemaparser.Oid.t -> string (** get an objectclass structure by one of its names (canonical or otherwise, however getting it by canonical name is currently much faster) @raise Invalid_objectclass If the objectclass is not found in the schema. *) val getOc : Ldap_schemaparser.schema -> Ldap_schemaparser.Lcstring.t -> Ldap_schemaparser.objectclass (** get an attr structure by one of its names (canonical or otherwise, however getting it by canonical name is currently much faster) @raise Invalid_attribute If the attribute is not found in the schema. *) val getAttr : Ldap_schemaparser.schema -> Ldap_schemaparser.Lcstring.t -> Ldap_schemaparser.attribute (** equate attributes by oid. This allows non canonical names to be handled correctly, for example "uid" and "userID" are actually the same attribute. @raise Invalid_attribute If either attribute is not found in the schema. *) val equateAttrs : Ldap_schemaparser.schema -> Ldap_schemaparser.Lcstring.t -> Ldap_schemaparser.Lcstring.t -> bool exception Invalid_objectclass of string exception Invalid_attribute of string exception Single_value of string exception Objectclass_is_required class scldapentry : Ldap_schemaparser.schema -> object (** {2 New Methods} *) (** Returns true if the attributed specified is allowed by the current set of objectclasses present on the entry. *) method is_allowed : string -> bool (** Returns true if the attribute specified is a must, but is not currently present. *) method is_missing : string -> bool (** Return a list of all attributes allowed on the entry (by oid) *) method list_allowed : Setstr.elt list (** Return a list of all missing attributes (by oid) *) method list_missing : Setstr.elt list (** Return a list of all present attributes. In contrast to the [attributes] method, this method ignores missing required attributes and just returns those attributes which are actually present. *) method list_present : Setstr.elt list (** Given an {!Ldap_ooclient.ldapentry} copy all of it's data into the current object, and perform a schema check. @param scflavor Default [Pessimistic] The schema checking bias, see {!Ldap_ooclient.scflavor} *) method of_entry : ?scflavor:scflavor -> ldapentry -> unit (** {2 Inherited Methods} *) (** Add values to the entry, just as {!Ldap_ooclient.ldapentry.add}, However, after the add is complete the schema checker is run in [Optimistic] mode. see {!Ldap_ooclient.scflavor} *) method add : op_lst -> unit (** Same as {!Ldap_ooclient.ldapentry.add}, except that the schema checker is run in [Pessimistic] mode after the operation is complete. see {!Ldap_ooclient.scflavor} *) method delete : op_lst -> unit (** Same as {!Ldap_ooclient.ldapentry.replace} except that once the replace has completed the schema checker is run again in [Optimistic] mode. See {!Ldap_ooclient.scflavor} *) method replace : op_lst -> unit (** Same as {!Ldap_ooclient.ldapentry.attributes}, except that the returned list contains attributes which may not yet exist on the entry. For example musts which are not yet present will be listed. *) method attributes : string list (** Same as {!Ldap_ooclient.ldapentry.exists} except that it refrences attributes which may not yet exist. For example musts which are not yet present. *) method exists : string -> bool (** Same as {!Ldap_ooclient.ldapentry.get_value}, except that attributes which do not yet exists may be referenced. For example a must which has not yet been satisfied will return [["required"]] when [get_value] is called on it. *) method get_value : string -> string list (** Same as {!Ldap_ooclient.ldapentry.modify} except that the schema checker is run in [Pessimistic] mode after the modification is applied. see {!Ldap_ooclient.scflavor}. *) method modify : (Ldap_types.modify_optype * string * string list) list -> unit (** Same as {!Ldap_ooclient.ldapentry.changes} except that changes made by the schema checker may also be listed. *) method changes : (Ldap_types.modify_optype * string * string list) list (** Same as {!Ldap_ooclient.ldapentry.changetype} *) method changetype : changetype (** Same as {!Ldap_ooclient.ldapentry.dn} *) method dn : string (** Same as {!Ldap_ooclient.ldapentry.flush_changes} *) method flush_changes : unit (** Same as {!Ldap_ooclient.ldapentry.diff} *) method diff : ldapentry_t -> (Ldap_types.modify_optype * string * string list) list (** @deprecated Same as {!Ldap_ooclient.ldapentry.print}, except that it prints attributes which may not yet be present on the object. For example, if the object has unsatisfied musts, it will print "attrname: required" for that attribute. *) method print : unit (** Same as {!Ldap_ooclient.ldapentry.set_changetype} *) method set_changetype : changetype -> unit (** Same as {!Ldap_ooclient.ldapentry.set_dn} *) method set_dn : string -> unit end (** {1 Schema Aware Entry for Account Managment} *) (** A derivative of {!Ldap_ooclient.scldapentry} which includes abstractions for managing user accounts in the directory. This class is experimantal, and may be drastically changed in the next version. As with all experimental code, use with caution. A few of its features. {ul {- Loosely dependant attributes: Many attributes are derived from others via a function. ldapaccount allows you to codify that relationship by providing an attribute generator ({!Ldap_ooclient.generator}) for the attribute, which will be used to derive it's value except in the case that it is specified explicitly} {- Attribute and Generator Grouping: via the service abstraction. Allows you to group attributes together with generators and default values in interesting ways. You can then assign the whole grouping a name, and refer to it by that name. See {!Ldap_ooclient.service}} {- Difference Based: Service operations are difference based, all applications of service operations compute the delta between the current object, and what the service requires. The minumum set of changes necessary to satisfy the service are applied to the object.} {- Idempotentcy: As a result of being difference based, Service operations are itempotent. For example, adding a service twice has no effect on the object. It will not queue changes for modification to the directory, and it will not change the object in memory. Deleting a service twice has no effect...etc}} *) (** The structure of a generator *) type generator = { gen_name : string; (** The name of the generator, this should also be its key in the hashtbl *) required : string list; (** A list of names of attributes which are required by this generator. The names need not be canonical. *) genfun : ldapentry_t -> string list; (** A function which returns a list of values for the attribute, given the entire object. *) } (** The structure of a service *) type service = { svc_name : string; (** The name of the service, should also be its key in the hashtbl. *) static_attrs : (string * string list) list; (** A list of attributes and values which must be present for the service to be satisfied. *) generate_attrs : string list; (** A list of attributes to generate. *) depends : string list; (** A list of services on which this service depends. *) } (** The type of error raised by attribute generators *) type generation_error = Missing_required of string list | Generator_error of string (** You've asked it to generate an attribute (in a service) which doesn't have a generator *) exception No_generator of string (** Generator has failed because of some kind of error *) exception Generation_failed of generation_error (** The service you're talking about doesn't exist *) exception No_service of string (** A service which the one you tried to add depends on doesn't exists *) exception Service_dep_unsatisfiable of string (** Your generator depends on an attribute which isn't in the schema *) exception Generator_dep_unsatisfiable of string * string (** You have detached cycles in your generator dependancy lists *) exception Cannot_sort_dependancies of string list class ldapaccount : Ldap_schemaparser.schema -> (string, generator) Hashtbl.t -> (string, service) Hashtbl.t -> object (** {2 Account Manipulation Methods} *) (** add the named service to the object, this also adds all the services depended upon by the named service. *) method add_service : string -> unit (** Delete the named service. This will also delete all services which depend on it, either directly or indirectly *) method delete_service : string -> unit (** Run service through the delta engine to find out what changes would actually be applied to this object *) method adapt_service : service -> service (** Tests whether the named service is satisfied by the current entry. A service is satisfied if no changes would result from adding it to the entry. *) method service_exists : string -> bool (** Return a list of all the named services which are satisfied by the current entry. *) method services_present : string list (** add the named attribute to the list of attributes to be generated *) method add_generate : string -> unit (** Delete the named attribute from the list of attributes to generate *) method delete_generate : string -> unit (** Run the generation functions on the list of attributes to be generated, saving the results in the entry. You must run this method in order to run any generators at all. *) method generate : unit (** {2 Inherited Methods} *) (** Unless explicitly stated, these methods do exactly the same thing as in {!Ldap_ooclient.scldapentry} *) (** Missing attributes may be marked for generation. *) method add : op_lst -> unit method attributes : string list method changes : (Ldap_types.modify_optype * string * string list) list method changetype : changetype method delete : op_lst -> unit method dn : string method diff : ldapentry_t -> (Ldap_types.modify_optype * string * string list) list method exists : string -> bool method flush_changes : unit (** If a missing attribute is marked for generation its value will be ["generate"] instead of ["required"] *) method get_value : string -> string list method is_allowed : string -> bool method is_missing : string -> bool method list_allowed : Setstr.elt list method list_missing : Setstr.elt list method list_present : Setstr.elt list method modify : (Ldap_types.modify_optype * string * string list) list -> unit method of_entry : ?scflavor:scflavor -> ldapentry -> unit (** @deprecated Missing required attributes which will be generated are shown as "attrname: generate" instead of "attrname: required" *) method print : unit method replace : op_lst -> unit method set_changetype : changetype -> unit method set_dn : string -> unit end ldap-2.5.1/src/ldap/ldap_protocol.ml0000644000175000017500000013501414652453725020762 0ustar kit_ty_katekit_ty_kate(* An implementation of the ldap protocol, both client and server functions are implemented Copyright (C) 2004 Eric Stokes, Matthew Backes, 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 Lber open Ldap_types let encode_resultcode (code:ldap_resultcode) = match code with `SUCCESS -> 0 | `OPERATIONS_ERROR -> 1 | `PROTOCOL_ERROR -> 2 | `TIMELIMIT_EXCEEDED -> 3 | `SIZELIMIT_EXCEEDED -> 4 | `COMPARE_FALSE -> 5 | `COMPARE_TRUE -> 6 | `AUTH_METHOD_NOT_SUPPORTED -> 7 | `STRONG_AUTH_REQUIRED -> 8 | `REFERRAL -> 10 | `ADMINLIMIT_EXCEEDED -> 11 | `UNAVAILABLE_CRITICAL_EXTENSION -> 12 | `CONFIDENTIALITY_REQUIRED -> 13 | `SASL_BIND_IN_PROGRESS -> 14 | `NO_SUCH_ATTRIBUTE -> 16 | `UNDEFINED_TYPE -> 17 | `INAPPROPRIATE_MATCHING -> 18 | `CONSTRAINT_VIOLATION -> 19 | `TYPE_OR_VALUE_EXISTS -> 20 | `INVALID_SYNTAX -> 21 | `NO_SUCH_OBJECT -> 32 | `ALIAS_PROBLEM -> 33 | `INVALID_DN_SYNTAX -> 34 | `IS_LEAF -> 35 | `ALIAS_DEREF_PROBLEM -> 36 | `INAPPROPRIATE_AUTH -> 48 | `INVALID_CREDENTIALS -> 49 | `INSUFFICIENT_ACCESS -> 50 | `BUSY -> 51 | `UNAVAILABLE -> 52 | `UNWILLING_TO_PERFORM -> 53 | `LOOP_DETECT -> 54 | `NAMING_VIOLATION -> 64 | `OBJECT_CLASS_VIOLATION -> 65 | `NOT_ALLOWED_ON_NONLEAF -> 66 | `NOT_ALLOWED_ON_RDN -> 67 | `ALREADY_EXISTS -> 68 | `NO_OBJECT_CLASS_MODS -> 69 | `AFFECTS_MULTIPLE_DSAS -> 71 | `OTHER -> 80 | `SERVER_DOWN -> 80 | `LOCAL_ERROR -> 80 | `ENCODING_ERROR -> 80 | `DECODING_ERROR -> 80 | `TIMEOUT -> 80 | `AUTH_UNKNOWN -> 80 | `FILTER_ERROR -> 80 | `USER_CANCELLED -> 80 | `PARAM_ERROR -> 80 | `NO_MEMORY -> 80 | `CONNECT_ERROR -> 80 | `NOT_SUPPORTED -> 80 | `CONTROL_NOT_FOUND -> 80 | `NO_RESULTS_RETURNED -> 80 | `MORE_RESULTS_TO_RETURN -> 80 | `CLIENT_LOOP -> 80 | `REFERRAL_LIMIT_EXCEEDED -> 80 | `UNKNOWN_ERROR i -> i let decode_resultcode code = match code with 0 -> `SUCCESS | 1 -> `OPERATIONS_ERROR | 2 -> `PROTOCOL_ERROR | 3 -> `TIMELIMIT_EXCEEDED | 4 -> `SIZELIMIT_EXCEEDED | 5 -> `COMPARE_FALSE | 6 -> `COMPARE_TRUE | 7 -> `AUTH_METHOD_NOT_SUPPORTED | 8 -> `STRONG_AUTH_REQUIRED | 10 -> `REFERRAL | 11 -> `ADMINLIMIT_EXCEEDED | 12 -> `UNAVAILABLE_CRITICAL_EXTENSION | 13 -> `CONFIDENTIALITY_REQUIRED | 14 -> `SASL_BIND_IN_PROGRESS | 16 -> `NO_SUCH_ATTRIBUTE | 17 -> `UNDEFINED_TYPE | 18 -> `INAPPROPRIATE_MATCHING | 19 -> `CONSTRAINT_VIOLATION | 20 -> `TYPE_OR_VALUE_EXISTS | 21 -> `INVALID_SYNTAX | 32 -> `NO_SUCH_OBJECT | 33 -> `ALIAS_PROBLEM | 34 -> `INVALID_DN_SYNTAX | 35 -> `IS_LEAF | 36 -> `ALIAS_DEREF_PROBLEM | 48 -> `INAPPROPRIATE_AUTH | 49 -> `INVALID_CREDENTIALS | 50 -> `INSUFFICIENT_ACCESS | 51 -> `BUSY | 52 -> `UNAVAILABLE | 53 -> `UNWILLING_TO_PERFORM | 54 -> `LOOP_DETECT | 64 -> `NAMING_VIOLATION | 65 -> `OBJECT_CLASS_VIOLATION | 66 -> `NOT_ALLOWED_ON_NONLEAF | 67 -> `NOT_ALLOWED_ON_RDN | 68 -> `ALREADY_EXISTS | 69 -> `NO_OBJECT_CLASS_MODS | 71 -> `AFFECTS_MULTIPLE_DSAS | 80 -> `OTHER | i -> `UNKNOWN_ERROR i let decode_control_type s = match s with | "1.2.840.113556.1.4.319" -> `Paged_results_control | x -> `Unknown_type x let encode_control_type c = match c.control_details with | `Paged_results_control _ -> "1.2.840.113556.1.4.319" | _ -> raise (LDAP_Encoder "encode_ldapcontrol: unknown control type") (* encode a standard sequence header *) let encode_seq_hdr ?(cls=Universal) ?(tag=16) length = encode_ber_header {ber_class=cls; ber_tag=tag; ber_primitive=false; ber_length=Definite length} let encode_ldapcontrol control = let en_type = encode_ber_octetstring (encode_control_type control) in let build_final_str hdr_len part_list = let en_ctrl_hdr = encode_seq_hdr ~cls:Universal ~tag:16 hdr_len in let body = String.concat "" part_list in String.concat "" [en_ctrl_hdr; body] in match control.control_details with | `Unknown_value c_val -> let header_len = (String.length en_type) + (String.length c_val) in build_final_str header_len [en_type; c_val] | `Paged_results_control ctrl_val -> let en_size = encode_ber_int32 (Int32.of_int ctrl_val.size) in let en_cookie = encode_ber_octetstring ctrl_val.cookie in let control_val_length = (String.length en_size) + (String.length en_cookie) in let control_val_hdr = encode_seq_hdr ~cls:Universal ~tag:16 control_val_length in let control_value = String.concat "" [control_val_hdr; en_size; en_cookie] in let control_w_hdr = encode_ber_octetstring ~cls:Universal ~tag:4 control_value in let header_len = (String.length en_type) + (String.length control_w_hdr) in build_final_str header_len [en_type; control_w_hdr] let encode_ldapcontrol_list control_list = let all_encoded_ctrls = List.fold_left (fun str ctrl -> String.concat str [(encode_ldapcontrol ctrl)]) "" control_list in let all_ctrls_header = encode_seq_hdr ~cls:Context_specific ~tag:0 ((String.length all_encoded_ctrls)) in String.concat "" [all_ctrls_header; all_encoded_ctrls] let decode_ldapcontrol rb = match decode_ber_header rb with {ber_class=Universal;ber_tag=16;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in let control_type_string = decode_ber_octetstring rb in let controlType = decode_control_type control_type_string in (* not handling criticality *) let _ = decode_ber_header rb in let criticality = false in let control_details = begin match controlType with | `Paged_results_control -> begin try let _ = decode_ber_header rb in let size = Int32.to_int (decode_ber_int32 rb) in let cookie = decode_ber_octetstring rb in `Paged_results_control {size=size; cookie=cookie} with Readbyte_error End_of_stream -> `Unknown_value "" end | `Unknown_type _ -> `Unknown_value "" end in {criticality=criticality;control_details=control_details} | _ -> raise (LDAP_Decoder "decode_ldapcontrol: expected sequence") let decode_ldapcontrols rb = try let rb = (* set the context to this control *) match decode_ber_header rb with {ber_class=Context_specific;ber_tag=0;ber_length=control_length;_} -> readbyte_of_ber_element control_length rb | _ -> raise (LDAP_Decoder "decode_ldapcontrol: expected control (controls [0])") in let rec decode_ldapcontrols' ?(controls=[]) rb = try decode_ldapcontrols' ~controls:((decode_ldapcontrol rb) :: controls) rb with Readbyte_error End_of_stream -> match controls with [] -> None | controls -> Some (List.rev controls) (* return them in order *) in decode_ldapcontrols' rb with Readbyte_error End_of_stream -> None let encode_components_of_ldapresult {result_code=resultcode; matched_dn=dn;error_message=msg; ldap_referral=refs} = let result_code = encode_ber_enum (Int32.of_int (encode_resultcode resultcode)) in let matched_dn = encode_ber_octetstring dn in let error_message = encode_ber_octetstring msg in let ldap_referral = (match refs with Some refs -> let buf = Buffer.create 100 in List.iter (fun ref -> Buffer.add_string buf (encode_ber_octetstring ref)) refs; let hdr = Buffer.create 101 in Buffer.add_string hdr (encode_ber_header {ber_class=Context_specific; ber_tag=3; ber_primitive=false; ber_length=Definite (Buffer.length buf)}); Buffer.add_buffer hdr buf; Some (Buffer.contents hdr) | None -> None) in let buf = Buffer.create 100 in Buffer.add_string buf result_code; Buffer.add_string buf matched_dn; Buffer.add_string buf error_message; (match ldap_referral with Some s -> Buffer.add_string buf s | None -> ()); Buffer.contents buf let encode_ldapresult ?(cls=Universal) ?(tag=16) ldapresult = let components = encode_components_of_ldapresult ldapresult in let len = String.length components in let buf = Buffer.create (len + 20) in Buffer.add_string buf (encode_ber_header {ber_class=cls; ber_tag=tag; ber_primitive=false; ber_length=(Definite len)}); Buffer.add_string buf components; Buffer.contents buf let decode_components_of_ldapresult rb = let resultCodeval = decode_ber_enum rb in let matched_dn = decode_ber_octetstring rb in let error_message = decode_ber_octetstring rb in let referrals = try (match decode_ber_header ~peek:true rb with {ber_class=Context_specific;ber_tag=3;ber_length=referral_length;_} -> ignore (decode_ber_header rb); let rb = readbyte_of_ber_element referral_length rb in (match decode_berval_list decode_ber_octetstring rb with [] -> None | lst -> Some lst) | _ -> None) with Readbyte_error End_of_stream -> None in {result_code=(decode_resultcode (Int32.to_int resultCodeval)); matched_dn=matched_dn; error_message=error_message; ldap_referral=referrals} let encode_bindrequest {bind_version=ver;bind_name=dn;bind_authentication=auth} = let buf = Buffer.create 100 in let version = encode_ber_int32 (Int32.of_int ver) in let dn = encode_ber_octetstring dn in let auth = (match auth with Simple pwd -> encode_ber_octetstring ~cls:Context_specific ~tag:0 pwd | Sasl {sasl_mechanism=mech;sasl_credentials=cred} -> let buf = Buffer.create 10 in let mech = encode_ber_octetstring mech in let cred = (match cred with Some cred -> Some (encode_ber_octetstring cred) | None -> None) in let hdr = encode_seq_hdr ~cls:Context_specific ~tag:3 ((String.length mech) + (match cred with Some cred -> String.length cred | None -> 0)) in Buffer.add_string buf hdr; Buffer.add_string buf mech; (match cred with Some cred -> Buffer.add_string buf cred | None -> ()); Buffer.contents buf) in let hdr = (encode_ber_header {ber_class=Application; ber_tag=0; ber_primitive=false; ber_length=Definite ((String.length version) + (String.length dn) + (String.length auth))}) in Buffer.add_string buf hdr; Buffer.add_string buf version; Buffer.add_string buf dn; Buffer.add_string buf auth; Buffer.contents buf let decode_bindrequest rb = let version = decode_ber_int32 rb in let dn = decode_ber_octetstring rb in let cred = (match decode_ber_header rb with {ber_class=Context_specific;ber_tag=0;ber_length=cred_length;_} -> (* simple *) Simple (decode_ber_octetstring ~contents:(Some (read_contents rb cred_length)) rb) | {ber_class=Context_specific;ber_tag=3;ber_length=cred_length;_} -> (* sasl *) let rb = readbyte_of_ber_element cred_length rb in let sasl_mech = decode_ber_octetstring rb in let sasl_cred = (try Some (decode_ber_octetstring rb) with Readbyte_error End_of_stream -> None) in Sasl {sasl_mechanism=sasl_mech;sasl_credentials=sasl_cred} | _ -> raise (LDAP_Decoder "decode_bindrequest: unknown authentication method")) in Bind_request {bind_version=Int32.to_int version; bind_name=dn; bind_authentication=cred} let encode_bindresponse {bind_result=result;bind_serverSaslCredentials=saslcred} = let encoded_result = encode_components_of_ldapresult result in let encoded_saslcred = match saslcred with | Some s -> Some (encode_ber_octetstring ~cls:Context_specific ~tag:7 s) | None -> None in let len = (String.length encoded_result) + (match encoded_saslcred with Some s -> (String.length s) | None -> 0) in let buf = Buffer.create (len + 20) in Buffer.add_string buf (encode_ber_header {ber_class=Application; ber_tag=1;ber_primitive=false; ber_length=Definite len}); Buffer.add_string buf encoded_result; (match encoded_saslcred with Some s -> Buffer.add_string buf s | None -> ()); Buffer.contents buf let decode_bindresponse rb = let result = decode_components_of_ldapresult rb in let saslcred = try Some (decode_ber_octetstring rb) with Readbyte_error End_of_stream -> None in Bind_response {bind_result=result; bind_serverSaslCredentials=saslcred} let decode_unbindrequest rb = (* some clients do not properly encode the length octets, which will cause decoding of null values to fail. In short, it is never OK to omit completely the length octets, however some clients (namely openldap) do it anyway *) (try ignore (decode_ber_null rb) with Readbyte_error End_of_stream -> ()); Unbind_request let encode_unbindrequest () = encode_ber_null () (* not really a sequence *) let decode_attributevalueassertion rb = let attributeDesc = decode_ber_octetstring rb in let assertionValue = decode_ber_octetstring rb in {attributeDesc=attributeDesc; assertionValue=assertionValue} let encode_substringfilter {attrtype=attr; substrings={substr_initial=initial; substr_any=any;substr_final=final}} = let encode_component ctype vals = match vals with [] -> "" | vals -> let tag = match ctype with `INITIAL -> 0 | `ANY -> 1 | `FINAL -> 2 in let buf = Buffer.create (List.fold_left (fun s v -> s + (String.length v) + 3) 0 vals) in List.iter (fun v -> Buffer.add_string buf (encode_ber_octetstring ~cls:Context_specific ~tag v)) vals; Buffer.contents buf in let e_attr = encode_ber_octetstring attr in let e_initial = encode_component `INITIAL initial in let e_any = encode_component `ANY any in let e_final = encode_component `FINAL final in let component_len = (String.length e_initial) + (String.length e_any) + (String.length e_final) in let component_buf = Buffer.create (component_len + 3) in Buffer.add_string component_buf (encode_ber_header {ber_class=Universal;ber_tag=16;ber_primitive=false; ber_length=(Definite component_len)}); Buffer.add_string component_buf e_initial; Buffer.add_string component_buf e_any; Buffer.add_string component_buf e_final; let len = ((Buffer.length component_buf) + (String.length e_attr)) in let buf = Buffer.create (len + 3) in Buffer.add_string buf (encode_ber_header {ber_class=Context_specific;ber_tag=4;ber_primitive=false; ber_length=(Definite len)}); Buffer.add_string buf e_attr; Buffer.add_buffer buf component_buf; Buffer.contents buf let decode_substringfilter rb = let rec decode_substring_components skel rb = try match decode_ber_header ~peek:true rb with {ber_class=Context_specific;ber_tag=0;_} -> decode_substring_components {skel with substr_initial=((decode_ber_octetstring ~cls:Context_specific ~tag:0 rb) :: skel.substr_initial)} rb | {ber_class=Context_specific;ber_tag=1;_} -> decode_substring_components {skel with substr_any=((decode_ber_octetstring ~cls:Context_specific ~tag:1 rb) :: skel.substr_any)} rb | {ber_class=Context_specific;ber_tag=2;_} -> decode_substring_components {skel with substr_final=((decode_ber_octetstring ~cls:Context_specific ~tag:2 rb) :: skel.substr_final)} rb | _ -> raise (LDAP_Decoder "decode_substringfilter: invalid substring component") with Readbyte_error End_of_stream -> skel in let attrtype = decode_ber_octetstring rb in let components = (match decode_ber_header rb with {ber_class=Universal;ber_tag=16;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in let skel = {substr_initial=[];substr_any=[];substr_final=[]} in let result = decode_substring_components skel rb in if result = skel then raise (LDAP_Decoder "decode_substringfilter: invalid substring filter") else result | _ -> raise (LDAP_Decoder "decode_substringfilter: expected sequence of choice")) in {attrtype=attrtype; substrings=components} let encode_matchingruleassertion {matchingRule=mrule;ruletype=mruletype; matchValue=valu;dnAttributes=dnattrs} = let olen s = match s with Some s -> String.length s | None -> 0 in let oadd buf encoded = (match encoded with Some e -> Buffer.add_string buf e | None -> ()) in let oencode tag valu = match valu with Some s -> Some (encode_ber_octetstring ~cls:Context_specific ~tag:tag s) | None -> None in let e_mrule = oencode 1 mrule in let e_mruletype = oencode 2 mruletype in let e_valu = encode_ber_octetstring ~cls:Context_specific ~tag:3 valu in let e_dnattrs = encode_ber_bool ~cls:Context_specific ~tag:4 dnattrs in let len = (olen e_mrule) + (olen e_mruletype) + (String.length e_valu) + (String.length e_dnattrs) in let buf = Buffer.create (len + 10) in Buffer.add_string buf (encode_ber_header {ber_class=Context_specific;ber_tag=9; ber_primitive=false;ber_length=(Definite len)}); oadd buf e_mrule; oadd buf e_mruletype; Buffer.add_string buf e_valu; Buffer.add_string buf e_dnattrs; Buffer.contents buf let decode_matchingruleassertion rb = let matchingrule = (match decode_ber_header ~peek:true rb with {ber_class=Context_specific;ber_tag=0;ber_length=_len;_} -> Some (decode_ber_octetstring ~cls:Context_specific ~tag:1 rb) | _ -> None) in let ruletype = (match decode_ber_header ~peek:true rb with {ber_class=Context_specific;ber_tag=1;ber_length=_len;_} -> Some (decode_ber_octetstring ~cls:Context_specific ~tag:2 rb) | _ -> None) in let matchvalue = decode_ber_octetstring rb in let dnattributes = try decode_ber_bool rb with Readbyte_error End_of_stream -> false in {matchingRule=matchingrule; ruletype=ruletype; matchValue=matchvalue; dnAttributes=dnattributes} let rec encode_ldapfilter filter = let encode_complex lst hdr = let encoded_lst = encode_berval_list encode_ldapfilter lst in let len = String.length encoded_lst in let buf = Buffer.create (len + 10) in Buffer.add_string buf (encode_ber_header {hdr with ber_length=(Definite len)}); Buffer.add_string buf encoded_lst; Buffer.contents buf in let encode_simple attr valu hdr = let e_attr = encode_ber_octetstring attr in let e_valu = encode_ber_octetstring valu in let len = (String.length e_attr) + (String.length e_valu) in let buf = Buffer.create (len + 10) in Buffer.add_string buf (encode_ber_header {hdr with ber_length=(Definite len)}); Buffer.add_string buf e_attr; Buffer.add_string buf e_valu; Buffer.contents buf in let hdr = {ber_class=Context_specific;ber_tag=0; ber_primitive=false;ber_length=Definite 0} in match filter with `And lst -> encode_complex lst hdr | `Or lst -> encode_complex lst {hdr with ber_tag=1} | `Not f -> encode_complex [f] {hdr with ber_tag=2} | `EqualityMatch {attributeDesc=attr;assertionValue=valu} -> encode_simple attr valu {hdr with ber_tag=3} | `Substrings substrs -> encode_substringfilter substrs | `GreaterOrEqual {attributeDesc=attr;assertionValue=valu} -> encode_simple attr valu {hdr with ber_tag=5} | `LessOrEqual {attributeDesc=attr;assertionValue=valu} -> encode_simple attr valu {hdr with ber_tag=6} | `Present attr -> encode_ber_octetstring ~cls:Context_specific ~tag:7 attr | `ApproxMatch {attributeDesc=attr;assertionValue=valu} -> encode_simple attr valu {hdr with ber_tag=8} | `ExtensibleMatch extn -> encode_matchingruleassertion extn let rec decode_ldapfilter rb = match decode_ber_header rb with {ber_class=Context_specific;ber_tag=0;ber_length=len;_} -> (* and *) let rb = readbyte_of_ber_element len rb in `And (decode_berval_list decode_ldapfilter rb) | {ber_class=Context_specific;ber_tag=1;ber_length=len;_} -> (* or *) let rb = readbyte_of_ber_element len rb in `Or (decode_berval_list decode_ldapfilter rb) | {ber_class=Context_specific;ber_tag=2;ber_length=_len;_} -> (* not *) `Not (decode_ldapfilter rb) | {ber_class=Context_specific;ber_tag=3;ber_length=_len;_} -> (* equality match *) `EqualityMatch (decode_attributevalueassertion rb) | {ber_class=Context_specific;ber_tag=4;ber_length=_len;_} -> (* substring match *) `Substrings (decode_substringfilter rb) | {ber_class=Context_specific;ber_tag=5;ber_length=_len;_} -> (* greater than or equal *) `GreaterOrEqual (decode_attributevalueassertion rb) | {ber_class=Context_specific;ber_tag=6;ber_length=_len;_} -> (* less than or equal *) `LessOrEqual (decode_attributevalueassertion rb) | {ber_class=Context_specific;ber_tag=7;ber_length=len;_} -> (* present *) `Present (decode_ber_octetstring ~contents:(Some (read_contents rb len)) rb) | {ber_class=Context_specific;ber_tag=8;ber_length=_len;_} -> (* approx *) `ApproxMatch (decode_attributevalueassertion rb) | {ber_class=Context_specific;ber_tag=9;ber_length=_len;_} -> (* extensible match *) `ExtensibleMatch (decode_matchingruleassertion rb) | _ -> raise (LDAP_Decoder "decode_filter: expected filter part") let encode_attributedescriptionlist attrs = let e_attrs = encode_berval_list encode_ber_octetstring attrs in let len = String.length e_attrs in let buf = Buffer.create (len + 10) in Buffer.add_string buf (encode_ber_header {ber_class=Universal;ber_tag=16; ber_primitive=false;ber_length=(Definite len)}); Buffer.add_string buf e_attrs; Buffer.contents buf let decode_attributedescriptionlist rb = match decode_ber_header rb with {ber_class=Universal;ber_tag=16;_} -> decode_berval_list decode_ber_octetstring rb | _ -> raise (LDAP_Decoder "decode_attributedescriptionlist: expected sequence") let encode_searchrequest {baseObject=base;scope=scope; derefAliases=deref;sizeLimit=sizelimit; timeLimit=timelimit;typesOnly=typesonly; filter=filter;s_attributes=attributes} = let e_base = encode_ber_octetstring base in let e_scope = encode_ber_enum (match scope with `BASE -> 0l | `ONELEVEL -> 1l | `SUBTREE -> 2l) in let e_deref = encode_ber_enum (match deref with `NEVERDEREFALIASES -> 0l | `DEREFINSEARCHING -> 1l | `DEREFFINDINGBASE -> 2l | `DEREFALWAYS -> 3l) in let e_sizelimit = encode_ber_int32 sizelimit in let e_timelimit = encode_ber_int32 timelimit in let e_typesonly = encode_ber_bool typesonly in let e_filter = encode_ldapfilter filter in let e_attributes = encode_attributedescriptionlist attributes in let len = (String.length e_base) + (String.length e_scope) + (String.length e_deref) + (String.length e_sizelimit) + (String.length e_timelimit) + (String.length e_typesonly) + (String.length e_filter) + (String.length e_attributes) in let buf = Buffer.create (len + 10) in Buffer.add_string buf (encode_ber_header {ber_class=Application;ber_tag=3; ber_primitive=false;ber_length=(Definite len)}); Buffer.add_string buf e_base; Buffer.add_string buf e_scope; Buffer.add_string buf e_deref; Buffer.add_string buf e_sizelimit; Buffer.add_string buf e_timelimit; Buffer.add_string buf e_typesonly; Buffer.add_string buf e_filter; Buffer.add_string buf e_attributes; Buffer.contents buf let decode_searchrequest rb = let base = decode_ber_octetstring rb in let scope = (match decode_ber_enum rb with 0l -> `BASE | 1l -> `ONELEVEL | 2l -> `SUBTREE | _ -> raise (LDAP_Decoder "decode_searchrequest: invalid scope")) in let deref = (match decode_ber_enum rb with 0l -> `NEVERDEREFALIASES | 1l -> `DEREFINSEARCHING | 2l -> `DEREFFINDINGBASE | 3l -> `DEREFALWAYS | _ -> raise (LDAP_Decoder "decode_searchrequest: invalid deref policy")) in let sizelimit = decode_ber_int32 rb in let timelimit = decode_ber_int32 rb in let typesonly = decode_ber_bool rb in let filter = decode_ldapfilter rb in let attributes = decode_attributedescriptionlist rb in Search_request {baseObject=base; scope=scope; derefAliases=deref; sizeLimit=sizelimit; timeLimit=timelimit; typesOnly=typesonly; filter=filter; s_attributes=attributes} let encode_attribute {attr_type=attrtype;attr_vals=attrvals} = let e_attrtype = encode_ber_octetstring attrtype in let e_attrvals = let vals = encode_berval_list encode_ber_octetstring attrvals in let len = String.length vals in let buf = Buffer.create (len + 10) in Buffer.add_string buf (encode_ber_header {ber_class=Universal;ber_tag=17; ber_primitive=false;ber_length=(Definite len)}); Buffer.add_string buf vals; Buffer.contents buf in let len = (String.length e_attrtype) + (String.length e_attrvals) in let buf = Buffer.create (len + 10) in Buffer.add_string buf (encode_ber_header {ber_class=Universal;ber_tag=16; ber_primitive=false;ber_length=(Definite len)}); Buffer.add_string buf e_attrtype; Buffer.add_string buf e_attrvals; Buffer.contents buf let decode_attribute rb = match decode_ber_header rb with {ber_class=Universal;ber_tag=16;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in let attrtype = decode_ber_octetstring rb in let attrvals = match decode_ber_header rb with {ber_class=Universal;ber_tag=17;_} -> decode_berval_list decode_ber_octetstring rb | _ -> raise (LDAP_Decoder "decode_attribute: expected set") in {attr_type=attrtype;attr_vals=attrvals} | _ -> raise (LDAP_Decoder "decode_attributes: expected sequence") (* also used to encode addrequest. Forgive the naming conventions, trying to follow the ASN.1 closely, but not copy some of its problems at the same time. They have a few seperate implementations of entry, all the same encoding, but with different names, and different ASN.1 code! *) let encode_searchresultentry ?(tag=4) {sr_dn=dn;sr_attributes=attributes} = let e_dn = encode_ber_octetstring dn in let e_attributes = let valu = encode_berval_list encode_attribute attributes in let len = String.length valu in let buf = Buffer.create (len + 10) in Buffer.add_string buf (encode_ber_header {ber_class=Universal;ber_tag=16; ber_primitive=false;ber_length=(Definite len)}); Buffer.add_string buf valu; Buffer.contents buf in let len = (String.length e_dn) + (String.length e_attributes) in let buf = Buffer.create 50 in Buffer.add_string buf (encode_ber_header {ber_class=Application;ber_tag=tag; ber_primitive=false;ber_length=(Definite len)}); Buffer.add_string buf e_dn; Buffer.add_string buf e_attributes; Buffer.contents buf let decode_searchresultentry rb = let dn = decode_ber_octetstring rb in let attributes = match decode_ber_header rb with {ber_class=Universal;ber_tag=16;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_berval_list decode_attribute rb | _ -> raise (LDAP_Decoder "decode_searchresultentry: expected squenece") in Search_result_entry {sr_dn=dn;sr_attributes=attributes} let encode_searchresultdone = encode_ldapresult ~cls:Application ~tag:5 let decode_searchresultdone rb = Search_result_done (decode_components_of_ldapresult rb) let encode_searchresultreference srf = let refs = encode_berval_list encode_ber_octetstring srf in let len = String.length refs in let buf = Buffer.create (len + 10) in Buffer.add_string buf (encode_ber_header {ber_class=Application;ber_tag=19; ber_primitive=false;ber_length=(Definite len)}); Buffer.add_string buf refs; Buffer.contents buf let decode_searchresultreference rb = Search_result_reference (decode_berval_list decode_ber_octetstring rb) let encode_modification {mod_op=op;mod_value=attr} = let e_op = encode_ber_enum (match op with `ADD -> 0l | `DELETE -> 1l | `REPLACE -> 2l) in let e_attr = encode_attribute attr in let len = (String.length e_op) + (String.length e_attr) in let buf = Buffer.create (len + 10) in Buffer.add_string buf (encode_ber_header {ber_class=Universal;ber_tag=16;ber_primitive=false; ber_length=(Definite len)}); Buffer.add_string buf e_op; Buffer.add_string buf e_attr; Buffer.contents buf let decode_modification rb = match decode_ber_header rb with {ber_class=Universal;ber_tag=16;ber_length=len;_} -> (* sequence is specified *) let rb = readbyte_of_ber_element len rb in let op = (match decode_ber_enum rb with 0l -> `ADD | 1l -> `DELETE | 2l -> `REPLACE | _ -> raise (LDAP_Decoder "decode_modification: unknown operation")) in let attr = decode_attribute rb in {mod_op=op;mod_value=attr} | {ber_class=_cls;ber_tag=tag;ber_length=_len;_} -> raise (LDAP_Decoder ("decode_modification: expected sequence, or enum, " ^ ("tag: " ^ (string_of_int tag)))) let encode_modifyrequest {mod_dn=dn;modification=mods} = let e_dn = encode_ber_octetstring dn in let e_mods = let vals = encode_berval_list encode_modification mods in let len = String.length vals in let buf = Buffer.create (len + 10) in Buffer.add_string buf (encode_ber_header {ber_class=Universal;ber_tag=16;ber_primitive=false; ber_length=(Definite len)}); Buffer.add_string buf vals; Buffer.contents buf in let len = (String.length e_dn) + (String.length e_mods) in let buf = Buffer.create (len + 10) in Buffer.add_string buf (encode_ber_header {ber_class=Application;ber_tag=6; ber_primitive=false;ber_length=(Definite len)}); Buffer.add_string buf e_dn; Buffer.add_string buf e_mods; Buffer.contents buf let decode_modifyrequest rb = let dn = decode_ber_octetstring rb in let mods = match decode_ber_header rb with {ber_class=Universal;ber_tag=16;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_berval_list decode_modification rb | _ -> raise (LDAP_Decoder "decode_modifyrequest: expected sequence") in Modify_request {mod_dn=dn;modification=mods} let encode_modifyresponse = encode_ldapresult ~cls:Application ~tag:7 let decode_modifyresponse rb = Modify_response (decode_components_of_ldapresult rb) (* the types from search are reused. I refuse to duplicate them each type countless times like the ASN.1 specification does *) let encode_addrequest = encode_searchresultentry ~tag:8 let decode_addrequest rb = let res = decode_searchresultentry rb in match res with Search_result_entry res -> Add_request res | _ -> raise (LDAP_Decoder "decode_addrequest: invalid addrequest") let encode_addresponse = encode_ldapresult ~cls:Application ~tag:9 let decode_addresponse rb = Add_response (decode_components_of_ldapresult rb) let encode_deleterequest req = encode_ber_octetstring ~cls:Application ~tag:10 req let decode_deleterequest len rb = Delete_request (decode_ber_octetstring ~contents:(Some (read_contents rb len)) rb) let encode_deleteresponse = encode_ldapresult ~cls:Application ~tag:11 let decode_deleteresponse rb = Delete_response (decode_components_of_ldapresult rb) let encode_modifydnrequest {modn_dn=dn;modn_newrdn=newrdn; modn_deleteoldrdn=deleteold; modn_newSuperior=newsup} = let e_dn = encode_ber_octetstring dn in let e_newrdn = encode_ber_octetstring newrdn in let e_deleteold = encode_ber_bool deleteold in let e_newsup = (match newsup with Some s -> Some (encode_ber_octetstring s) | None -> None) in let len = (String.length e_dn) + (String.length e_newrdn) + (String.length e_deleteold) + (match e_newsup with Some s -> String.length s | None -> 0) in let buf = Buffer.create (len + 10) in Buffer.add_string buf (encode_ber_header {ber_class=Application;ber_tag=12;ber_primitive=false; ber_length=(Definite len)}); Buffer.add_string buf e_dn; Buffer.add_string buf e_newrdn; Buffer.add_string buf e_deleteold; (match e_newsup with Some s -> Buffer.add_string buf s | None -> ()); Buffer.contents buf let decode_modifydnrequest rb = let dn = decode_ber_octetstring rb in let newrdn = decode_ber_octetstring rb in let deleteoldrdn = decode_ber_bool rb in let newsup = (try Some (decode_ber_octetstring ~cls:Context_specific ~tag:0 rb) with Readbyte_error End_of_stream -> None) in Modify_dn_request {modn_dn=dn;modn_newrdn=newrdn; modn_deleteoldrdn=deleteoldrdn; modn_newSuperior=newsup} let encode_modifydnresponse = encode_ldapresult ~cls:Application ~tag:13 let decode_modifydnresponse rb = Modify_dn_response (decode_components_of_ldapresult rb) let encode_comparerequest {cmp_dn=dn; cmp_ava={attributeDesc=attr;assertionValue=valu}} = let e_dn = encode_ber_octetstring dn in let e_attr = encode_ber_octetstring attr in let e_valu = encode_ber_octetstring valu in let len = (String.length e_dn) + (String.length e_attr) + (String.length e_valu) in let buf = Buffer.create (len + 10) in Buffer.add_string buf (encode_ber_header {ber_class=Application;ber_tag=14; ber_primitive=false;ber_length=(Definite len)}); Buffer.add_string buf e_dn; Buffer.add_string buf e_attr; Buffer.add_string buf e_valu; Buffer.contents buf let decode_comparerequest rb = let dn = decode_ber_octetstring rb in let attr = decode_ber_octetstring rb in let valu = decode_ber_octetstring rb in Compare_request {cmp_dn=dn;cmp_ava={attributeDesc=attr;assertionValue=valu}} let encode_compareresponse = encode_ldapresult ~cls:Application ~tag:15 let decode_compareresponse rb = Compare_response (decode_components_of_ldapresult rb) let encode_abandonrequest msgid = let e_msgid = encode_ber_int32 msgid in let len = String.length e_msgid in let buf = Buffer.create (len + 10) in Buffer.add_string buf (encode_ber_header {ber_class=Application;ber_tag=16;ber_primitive=false; ber_length=(Definite len)}); Buffer.add_string buf e_msgid; Buffer.contents buf let decode_abandonrequest rb = Abandon_request (decode_ber_int32 rb) let encode_extendedrequest {ext_requestName=reqname;ext_requestValue=reqval} = let e_reqname = encode_ber_octetstring reqname in let e_reqval = (match reqval with Some s -> Some (encode_ber_octetstring s) | None -> None) in let len = (String.length e_reqname) + (match e_reqval with Some s -> String.length s | None -> 0) in let buf = Buffer.create (len + 10) in Buffer.add_string buf (encode_ber_header {ber_class=Application;ber_tag=23;ber_primitive=false; ber_length=(Definite len)}); Buffer.add_string buf e_reqname; (match e_reqval with Some s -> Buffer.add_string buf s | None -> ()); Buffer.contents buf let decode_extendedrequest rb = let reqname = decode_ber_octetstring ~cls:Context_specific ~tag:0 rb in let reqval = try Some (decode_ber_octetstring ~cls:Context_specific ~tag:1 rb) with Readbyte_error End_of_stream -> None in Extended_request {ext_requestName=reqname;ext_requestValue=reqval} let encode_extendedresponse {ext_result=result;ext_responseName=resname;ext_response=res} = let e_result = encode_components_of_ldapresult result in let e_resname = (match resname with Some s -> Some (encode_ber_octetstring s) | None -> None) in let e_res = (match res with Some s -> Some (encode_ber_octetstring s) | None -> None) in let len = (String.length e_result) + (match e_resname with Some s -> String.length s | None -> 0) + (match e_res with Some s -> String.length s | None -> 0) in let buf = Buffer.create (len + 10) in Buffer.add_string buf (encode_ber_header {ber_class=Application;ber_tag=24;ber_primitive=false; ber_length=(Definite len)}); Buffer.add_string buf e_result; (match e_resname with Some s -> Buffer.add_string buf s | None -> ()); (match e_res with Some s -> Buffer.add_string buf s | None -> ()); Buffer.contents buf let decode_extendedresponse rb = let result = decode_components_of_ldapresult rb in let responsename = ref None in let response = ref None in (try responsename := Some (decode_ber_octetstring ~cls:Context_specific ~tag:10 rb); response := Some (decode_ber_octetstring ~cls:Context_specific ~tag:11 rb) with Readbyte_error End_of_stream -> ()); Extended_response {ext_result=result; ext_responseName=(!responsename); ext_response=(!response)} let encode_ldapmessage {messageID=msgid;protocolOp=protocol_op;controls=controls} = let encoded_op = match protocol_op with Bind_request br -> encode_bindrequest br | Bind_response br -> encode_bindresponse br | Unbind_request -> encode_unbindrequest () | Search_request sr -> encode_searchrequest sr | Search_result_entry sre -> encode_searchresultentry sre | Search_result_done srd -> encode_searchresultdone srd | Search_result_reference a -> encode_searchresultreference a | Modify_request mreq -> encode_modifyrequest mreq | Modify_response res -> encode_modifyresponse res | Add_request sre -> encode_addrequest sre | Add_response res -> encode_addresponse res | Delete_request req -> encode_deleterequest req | Delete_response res -> encode_deleteresponse res | Modify_dn_request req -> encode_modifydnrequest req | Modify_dn_response res -> encode_modifydnresponse res | Compare_request req -> encode_comparerequest req | Compare_response res -> encode_compareresponse res | Abandon_request req -> encode_abandonrequest req | Extended_request req -> encode_extendedrequest req | Extended_response res -> encode_extendedresponse res in match controls with | Some ctrl_lst -> let en_ctrl_lst = encode_ldapcontrol_list ctrl_lst in let buf = Buffer.create ((String.length encoded_op) + 20 + (String.length en_ctrl_lst)) in let msgid = encode_ber_int32 msgid in Buffer.add_string buf (encode_seq_hdr ( (String.length encoded_op) + (String.length msgid) + (String.length en_ctrl_lst))); Buffer.add_string buf msgid; Buffer.add_string buf encoded_op; Buffer.add_string buf en_ctrl_lst; Buffer.contents buf | None -> let buf = Buffer.create ((String.length encoded_op) + 20) in let msgid = encode_ber_int32 msgid in Buffer.add_string buf (encode_seq_hdr ((String.length encoded_op) + (String.length msgid))); Buffer.add_string buf msgid; Buffer.add_string buf encoded_op; Buffer.contents buf let decode_ldapmessage rb = match decode_ber_header rb with {ber_class=Universal;ber_tag=16;ber_length=total_length;_} -> (* set up our context to be this message *) let rb = readbyte_of_ber_element total_length rb in let messageid = decode_ber_int32 rb in let protocol_op = match decode_ber_header rb with {ber_class=Application;ber_tag=0;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_bindrequest rb | {ber_class=Application;ber_tag=1;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_bindresponse rb | {ber_class=Application;ber_tag=2;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_unbindrequest rb | {ber_class=Application;ber_tag=3;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_searchrequest rb | {ber_class=Application;ber_tag=4;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_searchresultentry rb | {ber_class=Application;ber_tag=5;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_searchresultdone rb | {ber_class=Application;ber_tag=19;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_searchresultreference rb | {ber_class=Application;ber_tag=6;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_modifyrequest rb | {ber_class=Application;ber_tag=7;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_modifyresponse rb | {ber_class=Application;ber_tag=8;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_addrequest rb | {ber_class=Application;ber_tag=9;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_addresponse rb | {ber_class=Application;ber_tag=10;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_deleterequest len rb | {ber_class=Application;ber_tag=11;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_deleteresponse rb | {ber_class=Application;ber_tag=12;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_modifydnrequest rb | {ber_class=Application;ber_tag=13;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_modifydnresponse rb | {ber_class=Application;ber_tag=14;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_comparerequest rb | {ber_class=Application;ber_tag=15;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_compareresponse rb | {ber_class=Application;ber_tag=16;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_abandonrequest rb | {ber_class=Application;ber_tag=23;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_extendedrequest rb | {ber_class=Application;ber_tag=24;ber_length=len;_} -> let rb = readbyte_of_ber_element len rb in decode_extendedresponse rb | _ -> raise (LDAP_Decoder "protocol error") in let controls = decode_ldapcontrols rb in {messageID=messageid;protocolOp=protocol_op;controls=controls} | _ -> raise (LDAP_Decoder "decode_ldapmessage: expected sequence") ldap-2.5.1/src/ldap/ldap_protocol.mli0000644000175000017500000000321214652453725021125 0ustar kit_ty_katekit_ty_kate(* an implementation of the ldap wire protocol 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 *) (** an implementation of the ldap wire protocol *) open Ldap_types open Lber (** return the int asociated with the specified result code *) val encode_resultcode : ldap_resultcode -> int (** return the result code for the specified int, error codes which do not map to a code defined within the standard (or any of our own internal ones) will be represented as (`UNKNOWN_ERROR of int), where int is the unknown error code. *) val decode_resultcode : int -> ldap_resultcode (** encode a value of type ldap_message using lber and return a string which is ready to be put on the wire *) val encode_ldapmessage : ldap_message -> string (** decode an ldap_message from the wire, and build/return a structure of type ldap_message *) val decode_ldapmessage : readbyte -> ldap_message ldap-2.5.1/src/ldap/ldap_schemalexer.mll0000644000175000017500000001430314652453725021572 0ustar kit_ty_katekit_ty_kate(* lexer for rfc2252 format schemas 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 *) { type token = Lparen | Rparen | Numericoid of string | Name of string list | Desc of string | Obsolete | Equality of string | Ordering of string | Substr of string | Syntax of string * Int64.t | Single_value | Collective | No_user_modification | Usage of string | Sup of string list | Abstract | Structural | Auxiliary | Must of string list | May of string list | Xstring of string let quote = Str.regexp "'" let spacerex = Str.regexp " *" let stripspace buf = Str.global_replace spacerex "" buf let extract buf i chop = String.sub buf i ((String.length buf) - i - chop);; let splitoidlst buf regex = Str.split regex buf;; let stripquote buf = Str.global_replace quote "" buf let stripquotes lst = List.map (fun item -> stripquote item) lst [@@@ocaml.warning "-26"] } (* conversion definitions, from rfc 2252. I've tried to keep the names the same, or close. I've changed some names to make them more descriptive *) let alpha = [ 'a' - 'z' 'A' - 'Z' ] let digit = [ '0' - '9' ] let hdigit = [ 'a' - 'f' 'A' - 'F' '0' - '9' ] let k = [ 'a' - 'z' 'A' - 'Z' '0' - '9' '-' ';' ] let p = [ 'a' - 'z' 'A' - 'Z' '0' - '9' '"' '(' ')' '+' ',' '-' '.' '/' ':' '?' ' ' ] let utf8 = [ '\t' ' ' '!' - '&' '(' - '~' ] (* for now, this works, need to read about this *) let xstring = [ 'A' - 'Z' '-' ';' '_' ] + let whsp = ' ' + let dstring = utf8 * let qdstring = (whsp)? '\'' (dstring as qdstringval) '\'' (whsp)? let qdstringlist = qdstring + let qdstrings = qdstring | ( (whsp)? '(' qdstringlist ')' (whsp)? ) let letterstring = alpha + let numericstring = digit + let anhstring = k + let keystring = alpha anhstring * let printablestring = p + let space = ' ' + let descr = keystring let qdescr = whsp ''' (descr as qdescrval) ''' whsp let qdescrlist = qdescr ( ''' descr ''' whsp ) * let numericoid = numericstring ( '.' numericstring ) * let oid = descr | numericoid let woid = ( whsp )? oid ( whsp )? let oidlist = ( woid ( '$' woid ) * ) as oidlst let oids = woid as oidlst | whsp '(' ( oidlist as oidlst ) ')' whsp (* violates rfc2252 to support Microsoft Active Directory, but at least is not ambigous *) let noidlen = whsp ( ( numericoid ( '{' numericstring '}' ) ? ) as oid ) | whsp ''' ( ( numericoid ( '{' numericstring '}' ) ? ) as oid ) ''' | whsp ''' ( keystring as oid ) ''' let attributeUsage = "userApplication" | "directoryOperation" | "distributedOperation" | "dSAOperation" rule lexattr = parse '(' whsp {Lparen} | "NAME" qdescr {Name [qdescrval]} | "NAME" whsp '(' (qdescrlist as namelst) ')' whsp {Name (stripquotes (splitoidlst namelst (Str.regexp " *")))} | "DESC" qdstring {Desc qdstringval} | "OBSOLETE" whsp {Obsolete} | "SUP" whsp (woid as sup) {Sup [(stripspace sup)]} | "EQUALITY" whsp (woid as equality) {Equality (stripspace equality)} | "ORDERING" whsp (woid as ord) {Ordering (stripspace ord)} | "SUBSTR" whsp (woid as substr) {Substr (stripspace substr)} | "SYNTAX" noidlen whsp {match (splitoidlst oid (Str.regexp "{")) with [syntax] -> Syntax (syntax, Int64.zero) | [syntax;length] -> Syntax (syntax, Int64.of_string (extract length 0 1)) | _ -> failwith "syntax error"} | "SINGLE-VALUE" whsp {Single_value} | "COLLECTIVE" whsp {Collective} | "NO-USER-MODIFICATION" whsp {No_user_modification} | "USAGE" whsp attributeUsage whsp {Usage (extract (Lexing.lexeme lexbuf) 6 1)} | "X-" xstring qdstrings {Xstring (Lexing.lexeme lexbuf)} | oid whsp {Numericoid (extract (Lexing.lexeme lexbuf) 0 1)} | ')' {Rparen} and lexoc = parse '(' whsp {Lparen} | "NAME" qdescr {Name [qdescrval]} | "NAME" whsp '(' (qdescrlist as namelst) ')' whsp {Name (stripquotes (splitoidlst namelst (Str.regexp " *")))} | "DESC" qdstring {Desc qdstringval} | "OBSOLETE" whsp {Obsolete} | "SUP" whsp (woid as sup) {Sup [(stripspace sup)]} | "SUP" whsp '(' oidlist ')' whsp {Sup (List.rev_map stripspace (splitoidlst oidlst (Str.regexp " *\\$ *")))} | "ABSTRACT" whsp {Abstract} | "STRUCTURAL" whsp {Structural} | "AUXILIARY" whsp {Auxiliary} | "MUST" whsp (woid as must) {Must [(stripspace must)]} | "MUST" whsp '(' oidlist ')' whsp {Must (List.rev_map stripspace (splitoidlst oidlst (Str.regexp " *\\$ *")))} | "MAY" whsp (woid as may) {May [(stripspace may)]} | "MAY" whsp '(' oidlist ')' whsp {May (List.rev_map stripspace (splitoidlst oidlst (Str.regexp " *\\$ *")))} | "X-" xstring qdstrings {Xstring (Lexing.lexeme lexbuf)} | oid whsp {Numericoid (extract (Lexing.lexeme lexbuf) 0 1)} | ')' {Rparen} ldap-2.5.1/src/ldap/ldap_schemaparser.ml0000644000175000017500000002410314652453725021572 0ustar kit_ty_katekit_ty_kate(* A parser for rfc2252 format schema definitionsa 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_schemalexer;; module Oid = (struct type t = string let of_string s = s let to_string oid = oid let compare x y = String.compare (to_string x) (to_string y) end : sig type t val of_string: string -> t val to_string: t -> string val compare: t -> t -> int end);; let format_oid id = Format.open_box 0; Format.print_string (""); Format.close_box () module Lcstring = (struct type t = string let of_string s = String.lowercase_ascii s let to_string x = x let compare x y = String.compare x y end : sig type t val of_string: string -> t val to_string: t -> string val compare: t -> t -> int end);; let format_lcstring id = Format.open_box 0; Format.print_string (""); Format.close_box () type octype = Abstract | Structural | Auxiliary;; type objectclass = {oc_name: string list; oc_oid:Oid.t; oc_desc:string; oc_obsolete:bool; oc_sup:Lcstring.t list; oc_must:Lcstring.t list; oc_may:Lcstring.t list; oc_type:octype; oc_xattr:string list} type attribute = {at_name:string list; at_desc:string; at_oid:Oid.t; at_equality:string; at_ordering:string; at_substr:Oid.t; at_syntax:Oid.t; at_length: Int64.t; at_obsolete:bool; at_single_value:bool; at_collective:bool; at_no_user_modification:bool; at_usage:string; at_sup:Lcstring.t list; at_xattr:string list};; type schema = {objectclasses: (Lcstring.t, objectclass) Hashtbl.t; objectclasses_byoid: (Oid.t, objectclass) Hashtbl.t; attributes: (Lcstring.t, attribute) Hashtbl.t; attributes_byoid: (Oid.t, attribute) Hashtbl.t};; exception Depth let schema_print_depth = ref 10 let format_schema s = let indent = 3 in let printtbl tbl = let i = ref 0 in try Hashtbl.iter (fun aname _aval -> if !i < !schema_print_depth then begin Format.print_string (""); Format.print_break 1 indent; i := !i + 1 end else raise Depth) tbl with Depth -> Format.print_string "..." in Format.open_box 0; Format.print_string "{objectclasses = ;"; Format.print_break 0 1; Format.print_string "objectclasses_byoid = ;"; Format.print_break 0 1; Format.print_string "attributes = ;"; Format.print_break 0 1; Format.print_string "attributes_byoid = }"; Format.close_box () exception Parse_error_oc of Lexing.lexbuf * objectclass * string;; exception Parse_error_at of Lexing.lexbuf * attribute * string;; exception Syntax_error_oc of Lexing.lexbuf * objectclass * string;; exception Syntax_error_at of Lexing.lexbuf * attribute * string;; let readSchema oclst attrlst = let empty_oc = {oc_name=[];oc_oid=Oid.of_string "";oc_desc="";oc_obsolete=false;oc_sup=[]; oc_must=[];oc_may=[];oc_type=Abstract;oc_xattr=[]} in let empty_attr = {at_name=[];at_oid=Oid.of_string "";at_desc="";at_equality="";at_ordering=""; at_usage=""; at_substr=Oid.of_string "";at_syntax=Oid.of_string ""; at_length=0L;at_obsolete=false;at_single_value=false; at_collective=false;at_no_user_modification=false;at_sup=[];at_xattr=[]} in let readOc lxbuf oc = let rec readOptionalFields lxbuf oc = try match (lexoc lxbuf) with Name s -> readOptionalFields lxbuf {oc with oc_name=s} | Desc s -> readOptionalFields lxbuf {oc with oc_desc=s} | Obsolete -> readOptionalFields lxbuf {oc with oc_obsolete=true} | Sup s -> (readOptionalFields lxbuf {oc with oc_sup=(List.rev_map (Lcstring.of_string) s)}) | Ldap_schemalexer.Abstract -> readOptionalFields lxbuf {oc with oc_type=Abstract} | Ldap_schemalexer.Structural -> readOptionalFields lxbuf {oc with oc_type=Structural} | Ldap_schemalexer.Auxiliary -> readOptionalFields lxbuf {oc with oc_type=Auxiliary} | Must s -> (readOptionalFields lxbuf {oc with oc_must=(List.rev_map (Lcstring.of_string) s)}) | May s -> (readOptionalFields lxbuf {oc with oc_may=(List.rev_map (Lcstring.of_string) s)}) | Xstring t -> (readOptionalFields lxbuf {oc with oc_xattr=(t :: oc.oc_xattr)}) | Rparen -> oc | _ -> raise (Parse_error_oc (lxbuf, oc, "unexpected token")) with Failure(_) -> raise (Parse_error_oc (lxbuf, oc, "Expected right parenthesis")) in let readOid lxbuf oc = try match (lexoc lxbuf) with Numericoid(s) -> readOptionalFields lxbuf {oc with oc_oid=Oid.of_string s} | _ -> raise (Parse_error_oc (lxbuf, oc, "missing required field, numericoid")) with Failure(_) -> raise (Syntax_error_oc (lxbuf, oc, "Syntax error")) in let readLparen lxbuf oc = try match (lexoc lxbuf) with Lparen -> readOid lxbuf oc | _ -> raise (Parse_error_oc (lxbuf, oc, "Expected left paren")) with Failure(_) -> raise (Syntax_error_oc (lxbuf, oc, "Syntax error")) in readLparen lxbuf oc in let rec readOcs oclst schema = match oclst with a :: l -> let oc = readOc (Lexing.from_string a) empty_oc in List.iter (fun n -> Hashtbl.add schema.objectclasses (Lcstring.of_string n) oc) oc.oc_name; Hashtbl.add schema.objectclasses_byoid oc.oc_oid oc;readOcs l schema | [] -> () in let readAttr lxbuf attr = let rec readOptionalFields lxbuf attr = try match (lexattr lxbuf) with Name s -> readOptionalFields lxbuf {attr with at_name=s} | Desc s -> readOptionalFields lxbuf {attr with at_desc=s} | Obsolete -> readOptionalFields lxbuf {attr with at_obsolete=true} | Sup s -> readOptionalFields lxbuf {attr with at_sup=(List.rev_map (Lcstring.of_string) s)} | Equality s -> readOptionalFields lxbuf {attr with at_equality=s} | Substr s -> readOptionalFields lxbuf {attr with at_substr=Oid.of_string s} | Ordering s -> readOptionalFields lxbuf {attr with at_ordering=s} | Syntax (s, l) -> readOptionalFields lxbuf {attr with at_syntax=Oid.of_string s;at_length=l} | Single_value -> readOptionalFields lxbuf {attr with at_single_value=true} | Collective -> readOptionalFields lxbuf {attr with at_collective=true} | No_user_modification -> readOptionalFields lxbuf {attr with at_no_user_modification=true} | Usage s -> readOptionalFields lxbuf {attr with at_usage=s} | Rparen -> attr | Xstring t -> (readOptionalFields lxbuf {attr with at_xattr=(t :: attr.at_xattr)}) | _ -> raise (Parse_error_at (lxbuf, attr, "unexpected token")) with Failure(f) -> raise (Parse_error_at (lxbuf, attr, f)) in let readOid lxbuf attr = try match (lexoc lxbuf) with Numericoid(s) -> readOptionalFields lxbuf {attr with at_oid=Oid.of_string s} | _ -> raise (Parse_error_at (lxbuf, attr, "missing required field, numericoid")) with Failure(_) -> raise (Syntax_error_at (lxbuf, attr, "Syntax error")) in let readLparen lxbuf attr = try match (lexoc lxbuf) with Lparen -> readOid lxbuf attr | _ -> raise (Parse_error_at (lxbuf, attr, "Expected left paren")) with Failure(_) -> raise (Syntax_error_at (lxbuf, attr, "Syntax error")) in readLparen lxbuf attr in let rec readAttrs attrlst schema = match attrlst with a :: l -> let attr = readAttr (Lexing.from_string a) empty_attr in List.iter (fun n -> Hashtbl.add schema.attributes (Lcstring.of_string n) attr) attr.at_name; Hashtbl.add schema.attributes_byoid attr.at_oid attr;readAttrs l schema | [] -> () in let schema = {objectclasses=Hashtbl.create 500; objectclasses_byoid=Hashtbl.create 500; attributes=Hashtbl.create 5000; attributes_byoid=Hashtbl.create 5000} in readAttrs attrlst schema; readOcs oclst schema; schema;; ldap-2.5.1/src/ldap/ldap_schemaparser.mli0000644000175000017500000000560014652453725021744 0ustar kit_ty_katekit_ty_kate(** A library for parsing rfc2252 schemas as returned by directory servers *) module Oid : sig type t val of_string : string -> t val to_string : t -> string val compare : t -> t -> int end val format_oid : Oid.t -> unit module Lcstring : sig type t val of_string : string -> t val to_string : t -> string val compare : t -> t -> int end val format_lcstring : Lcstring.t -> unit type octype = Abstract | Structural | Auxiliary (** The type representing an objectclass definition *) type objectclass = { oc_name : string list; oc_oid : Oid.t; oc_desc : string; oc_obsolete : bool; oc_sup : Lcstring.t list; oc_must : Lcstring.t list; oc_may : Lcstring.t list; oc_type : octype; oc_xattr : string list; } (** The type representing an attribute definition *) type attribute = { at_name : string list; at_desc : string; at_oid : Oid.t; at_equality : string; at_ordering : string; at_substr : Oid.t; at_syntax : Oid.t; at_length : Int64.t; at_obsolete : bool; at_single_value : bool; at_collective : bool; at_no_user_modification : bool; at_usage : string; at_sup : Lcstring.t list; at_xattr : string list; } (** The type representing the whole schema. Consists of hashtbls indexed by two useful keys. For both attributes and objectclasses there exists a hashtbl indexed by OID, and one indexed by lower case canonical name. There exist functions in Ldap_ooclient to look up attributes and objectclasses by non canonical names if that is necessary for you to do. see attrToOid, and ocToOid. They will find the oid of an attribute or objectclass given any name, not just the canonical one. Not that this is somewhat (like several orders of magnitude) slower than lookups by canonical name.*) type schema = { objectclasses : (Lcstring.t, objectclass) Hashtbl.t; objectclasses_byoid : (Oid.t, objectclass) Hashtbl.t; attributes : (Lcstring.t, attribute) Hashtbl.t; attributes_byoid : (Oid.t, attribute) Hashtbl.t; } (** This reference controls the dept of printing for the schema in the toplevel. The default is 10 keys from each table will be printed. OID tables are not currently printed. *) val schema_print_depth : int ref (** A formatter for the schema, prints the structure, and expands the hashtbls to show the keys. The number of keys printed is controled by schema_print_depth. *) val format_schema : schema -> unit exception Parse_error_oc of Lexing.lexbuf * objectclass * string exception Parse_error_at of Lexing.lexbuf * attribute * string exception Syntax_error_oc of Lexing.lexbuf * objectclass * string exception Syntax_error_at of Lexing.lexbuf * attribute * string (** readSchema attribute_list objectclass_list, parse the schema into a schema type given a list of attribute definition lines, and objectclass definition lines. *) val readSchema : string list -> string list -> schema ldap-2.5.1/src/ldap/ldap_txooclient.ml0000644000175000017500000001614714652453725021316 0ustar kit_ty_katekit_ty_kateopen Ldap_mutex open Ldap_ooclient open Ldap_types type txn = { mutable dead: bool; entries: (string, (ldapentry_t * ldapentry_t)) Hashtbl.t } exception Rollback of exn * ((ldapentry_t * ldapentry_t) list) exception Txn_commit_failure of string * exn * ldapentry_t list option exception Txn_rollback_failure of string * exn class ldapadvisorytxcon ?(connect_timeout=1) ?(referral_policy=`RETURN) ?(version = 3) hosts binddn bindpw mutextbldn = let copy_entry entry = let new_entry = new ldapentry in new_entry#set_dn (entry#dn); List.iter (fun attr -> new_entry#add [(attr, entry#get_value attr)]) entry#attributes; new_entry in object (self) inherit ldapcon ~connect_timeout ~referral_policy ~version hosts as super initializer super#bind binddn ~cred:bindpw val lock_table = new object_lock_table hosts binddn bindpw mutextbldn method private check_dead txn = if txn.dead then raise (LDAP_Failure (`LOCAL_ERROR, "this transaction is dead, create a new one", {ext_matched_dn="";ext_referral=None})) method begin_txn = {dead=false;entries=Hashtbl.create 1} method associate_entry txn (entry: ldapentry_t) = self#check_dead txn; let dn = Ldap_dn.canonical_dn entry#dn in if Hashtbl.mem txn.entries dn then raise (LDAP_Failure (`LOCAL_ERROR, "dn: " ^ dn ^ " is already part of this transaction", {ext_matched_dn="";ext_referral=None})) else if entry#changes = [] then begin lock_table#lock (Ldap_dn.of_string dn); Hashtbl.add txn.entries dn ((copy_entry entry), (entry :> ldapentry_t)) end else raise (LDAP_Failure (`LOCAL_ERROR, "this entry has been changed since it was downloaded " ^ "commit your current changes, and then add the entry to " ^ "this transaction", {ext_matched_dn="";ext_referral=None})) method associate_entries txn entries = List.iter (self#associate_entry txn) entries method disassociate_entry txn (entry: ldapentry_t) = self#check_dead txn; let dn = Ldap_dn.canonical_dn entry#dn in if Hashtbl.mem txn.entries dn then begin Hashtbl.remove txn.entries dn; lock_table#unlock (Ldap_dn.of_string dn); end else raise (LDAP_Failure (`LOCAL_ERROR, "dn: " ^ dn ^ " is not part of this transaction", {ext_matched_dn="";ext_referral=None})) method disassociate_entries txn entries = List.iter (self#disassociate_entry txn) entries method commit_txn txn = self#check_dead txn; txn.dead <- true; try List.iter (fun (_, e) -> lock_table#unlock (Ldap_dn.of_string e#dn)) (Hashtbl.fold (fun _k (original_entry, modified_entry) successful_so_far -> try (match modified_entry#changetype with `MODIFY -> super#update_entry modified_entry | `ADD -> super#add modified_entry | `DELETE -> super#delete modified_entry#dn | `MODRDN -> super#modrdn original_entry#dn (Ldap_dn.to_string [(List.hd (Ldap_dn.of_string modified_entry#dn))]) | `MODDN -> let dn = Ldap_dn.of_string modified_entry#dn in super#modrdn original_entry#dn (Ldap_dn.to_string [List.hd dn]) ~newsup:(Some (Ldap_dn.to_string (List.tl dn)))); (original_entry, modified_entry) :: successful_so_far with exn -> raise (Rollback (exn, successful_so_far))) txn.entries []) with Rollback (exn, successful_so_far) -> (Hashtbl.iter (fun _k (_, e) -> e#flush_changes) txn.entries); (match ((Hashtbl.iter (* rollback everything in memory *) (fun _k (original_entry, modified_entry) -> match modified_entry#changetype with `MODIFY -> modified_entry#modify (original_entry#diff modified_entry) | `ADD -> () | `DELETE -> () | `MODRDN -> if not (List.mem (original_entry, modified_entry) successful_so_far) then modified_entry#set_dn original_entry#dn | `MODDN -> if not (List.mem (original_entry, modified_entry) successful_so_far) then modified_entry#set_dn original_entry#dn) txn.entries); (List.fold_left (* rollback in the directory only what we commited *) (fun not_rolled_back (original_entry, modified_entry) -> try (match modified_entry#changetype with `MODIFY -> super#update_entry modified_entry | `ADD -> super#delete modified_entry#dn | `DELETE -> super#add modified_entry | `MODRDN -> super#modrdn (modified_entry#dn) (Ldap_dn.to_string [List.hd (Ldap_dn.of_string original_entry#dn)]) | `MODDN -> super#modrdn (modified_entry#dn) (Ldap_dn.to_string [List.hd (Ldap_dn.of_string original_entry#dn)]) ~newsup:(Some (Ldap_dn.to_string (List.tl (Ldap_dn.of_string original_entry#dn))))); not_rolled_back with _ -> modified_entry :: not_rolled_back) [] successful_so_far)) with [] -> Hashtbl.iter (fun _k (e, _) -> lock_table#unlock (Ldap_dn.of_string e#dn)) txn.entries; (Hashtbl.iter (fun _k (_, e) -> e#flush_changes) txn.entries); raise (Txn_commit_failure ("rollback successful", exn, None)) | not_rolled_back -> Hashtbl.iter (fun _k (e, _) -> lock_table#unlock (Ldap_dn.of_string e#dn)) txn.entries; (Hashtbl.iter (fun _k (_, e) -> e#flush_changes) txn.entries); raise (Txn_commit_failure ("rollback failed", exn, Some not_rolled_back))) method rollback_txn txn = txn.dead <- true; Hashtbl.iter (fun _k (original_entry, modified_entry) -> try lock_table#unlock (Ldap_dn.of_string original_entry#dn); modified_entry#modify (original_entry#diff modified_entry); modified_entry#flush_changes with exn -> raise (Txn_rollback_failure ("rollback failed", exn))) txn.entries end ldap-2.5.1/src/ldap/ldap_txooclient.mli0000644000175000017500000000661614652453725021467 0ustar kit_ty_katekit_ty_kateopen Ldap_ooclient (** the abstract type of a transaction *) type txn (** raised when a commit fails, contains a list of entries which were not rolled back successfully only if rollback failed as well, otherwise None *) exception Txn_commit_failure of string * exn * ldapentry_t list option (** raised when an explicit rollback fails *) exception Txn_rollback_failure of string * exn (** A subclass of ldapcon which implements an experimental interface to draft_zeilenga_ldap_txn. A draft standard for multi object transactions over the ldap protocol. This class can only implement advisory transactions because it must depend on the advisory locking mechanisms for the transactions to be consistant. You use this class by calling begin_txn to get a transaction id, and then associating a set of ldapentry objects with the transaction by calling associate_entry_with_txn. You are then free to modify those entries in any way you like, and when you are done, you can either call commit_txn, or rollback_txn. Commit will commit the changes of all the entries associated with the transaction to the database. For other writers which obey advisory locking the commit operation is atomic. For readers which are willing to obey advisory locking is atomic. If the commit fails, a full rollback occurrs, including all changes made to the directory. For example in a set of N entries in a transaction, if the modificiation of the nth entry fails to commit, then the modifications to all the previous entries, which have already been made in the directory, are undone. It is important to note that if advisory locking is not obeyed, rollback may not be successful. Rollback undoes all the changes you've made in memory, and unlocks all the objects in the transaction. After a transaction object has been commited or rolled back it is considered "dead", and cannot be used again. *) class ldapadvisorytxcon : ?connect_timeout:int -> ?referral_policy:[> `RETURN ] -> ?version:int -> string list -> string -> string -> string -> (* hosts binddn bindpw mutextbldn *) object method add : ldapentry -> 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 -> ?newsup:string option -> string -> unit method rawschema : ldapentry method schema : Ldap_schemaparser.schema method search : ?scope:Ldap_types.search_scope -> ?attrs:string list -> ?attrsonly:bool -> ?base:string -> ?sizelimit:Int32.t -> ?timelimit:Int32.t -> string -> ldapentry list method search_a : ?scope:Ldap_types.search_scope -> ?attrs:string list -> ?attrsonly:bool -> ?base:string -> ?sizelimit:Int32.t -> ?timelimit:Int32.t -> string -> (?abandon:bool -> unit -> ldapentry) method unbind : unit method update_entry : ldapentry -> unit method begin_txn : txn method associate_entry : txn -> ldapentry_t -> unit method associate_entries : txn -> ldapentry_t list -> unit method disassociate_entry : txn -> ldapentry_t -> unit method disassociate_entries : txn -> ldapentry_t list -> unit method commit_txn : txn -> unit method rollback_txn : txn -> unit end ldap-2.5.1/src/ldap/ldap_types.ml0000644000175000017500000002134214652453725020263 0ustar kit_ty_katekit_ty_kate(* Common data types from rfc 2251 used throughout the library 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 *) (** Common data types used by ocamldap. Most of these types are taken from the ASN.1 specification for LDAP as defined in rfc2251 @see rfc2251*) (** An encoding error has occurred, the argument contains a description of the error This is likely a bug, so it should be reported *) exception LDAP_Encoder of string (** A decoding error has occurred, the argument contains a description of the error. This MAY be a bug, but it may also be that the server you are talking to is non standard. Please report these right away in any case.*) exception LDAP_Decoder of string type ldap_resultcode = [ `SUCCESS | `OPERATIONS_ERROR | `PROTOCOL_ERROR | `TIMELIMIT_EXCEEDED | `SIZELIMIT_EXCEEDED | `COMPARE_FALSE | `COMPARE_TRUE | `AUTH_METHOD_NOT_SUPPORTED | `STRONG_AUTH_REQUIRED | `REFERRAL | `ADMINLIMIT_EXCEEDED | `UNAVAILABLE_CRITICAL_EXTENSION | `CONFIDENTIALITY_REQUIRED | `SASL_BIND_IN_PROGRESS | `NO_SUCH_ATTRIBUTE | `UNDEFINED_TYPE | `INAPPROPRIATE_MATCHING | `CONSTRAINT_VIOLATION | `TYPE_OR_VALUE_EXISTS | `INVALID_SYNTAX | `NO_SUCH_OBJECT | `ALIAS_PROBLEM | `INVALID_DN_SYNTAX | `IS_LEAF | `ALIAS_DEREF_PROBLEM | `INAPPROPRIATE_AUTH | `INVALID_CREDENTIALS | `INSUFFICIENT_ACCESS | `BUSY | `UNAVAILABLE | `UNWILLING_TO_PERFORM | `LOOP_DETECT | `NAMING_VIOLATION | `OBJECT_CLASS_VIOLATION | `NOT_ALLOWED_ON_NONLEAF | `NOT_ALLOWED_ON_RDN | `ALREADY_EXISTS | `NO_OBJECT_CLASS_MODS | `AFFECTS_MULTIPLE_DSAS | `OTHER | `SERVER_DOWN | `LOCAL_ERROR | `ENCODING_ERROR | `DECODING_ERROR | `TIMEOUT | `AUTH_UNKNOWN | `FILTER_ERROR | `USER_CANCELLED | `PARAM_ERROR | `NO_MEMORY | `CONNECT_ERROR | `NOT_SUPPORTED | `CONTROL_NOT_FOUND | `NO_RESULTS_RETURNED | `MORE_RESULTS_TO_RETURN | `CLIENT_LOOP | `REFERRAL_LIMIT_EXCEEDED | `UNKNOWN_ERROR of int ] type ldap_result = { result_code: ldap_resultcode; matched_dn: string; error_message: string; ldap_referral: (string list) option; } (** extended information to return with the LDAP_Failure exception. Contains the remaining values which are defined by the protocol ext_matched_dn: the matched dn. Commonly set by `NO_SUCH_OBJECT. ext_referral: a list of ldapurls returned by the server when you attempted to do a write operation. If you use Ldap_ooclient with referrals set to follow you will never see this*) type ldap_ext_return = { ext_matched_dn: string; ext_referral: string list option; } (** The exception raised to indicate all types of failure in the higher level libraries Ldap_funclient, and Ldap_ooclient. example [LDAP_Failure (`NO_SUCH_OBJECT, "no such object", {ext_matched_dn=Some "o=csun";ext_referral=None})] *) exception LDAP_Failure of ldap_resultcode * string * ldap_ext_return type saslCredentials = { sasl_mechanism: string; sasl_credentials: string option; } type authentication = Simple of string | Sasl of saslCredentials type bind_request = { bind_version: int; bind_name: string; bind_authentication: authentication; } type bind_response = { bind_result: ldap_result; bind_serverSaslCredentials: string option; } type attribute = { attr_type: string; attr_vals: string list; } type dn = attribute list (** the type used to encode and decode a search entry. Also the type returned by search_s and search_a in Ldap_funclient *) type search_result_entry = { sr_dn: string; sr_attributes: attribute list; } (** a type defining the scope of a search filter *) type search_scope = [ `BASE (** search only at the base *) | `ONELEVEL (** search one level below the base *) | `SUBTREE (** search the entire tree under the base *)] type alias_deref = [ `NEVERDEREFALIASES | `DEREFINSEARCHING | `DEREFFINDINGBASE | `DEREFALWAYS ] type attribute_value_assertion = { attributeDesc: string; assertionValue: string; } type matching_rule_assertion = { matchingRule: string option; ruletype: string option; matchValue: string; dnAttributes: bool; (* default false *) } type substring_component = { (* at least one must be specified *) substr_initial: string list; substr_any: string list; substr_final: string list; } type substring_filter = { attrtype: string; substrings: substring_component; } type filter = [ `And of filter list | `Or of filter list | `Not of filter | `EqualityMatch of attribute_value_assertion | `Substrings of substring_filter | `GreaterOrEqual of attribute_value_assertion | `LessOrEqual of attribute_value_assertion | `Present of string | `ApproxMatch of attribute_value_assertion | `ExtensibleMatch of matching_rule_assertion ] type search_request = { baseObject: string; scope: search_scope; derefAliases: alias_deref; sizeLimit: int32; timeLimit: int32; typesOnly: bool; filter: filter; s_attributes: string list; } type modify_optype = [ `ADD | `DELETE | `REPLACE ] type modify_op = { mod_op: modify_optype; mod_value: attribute; } type modify_request = { mod_dn: string; modification: modify_op list } type modify_dn_request = { modn_dn: string; modn_newrdn: string; modn_deleteoldrdn: bool; modn_newSuperior: string option } type compare_request = { cmp_dn: string; cmp_ava: attribute_value_assertion; } type extended_request = { ext_requestName: string; ext_requestValue: string option; } type extended_response = { ext_result: ldap_result; ext_responseName: string option; ext_response: string option; } type protocol_op = Bind_request of bind_request | Bind_response of bind_response | Unbind_request | Search_request of search_request | Search_result_entry of search_result_entry | Search_result_reference of string list | Search_result_done of ldap_result | Modify_request of modify_request | Modify_response of ldap_result | Add_request of search_result_entry | Add_response of ldap_result | Delete_request of string | Delete_response of ldap_result | Modify_dn_request of modify_dn_request | Modify_dn_response of ldap_result | Compare_request of compare_request | Compare_response of ldap_result | Abandon_request of Int32.t | Extended_request of extended_request | Extended_response of extended_response type paged_results_control_value = { size: int; cookie: string; } type control_details = [`Paged_results_control of paged_results_control_value |`Unknown_value of string ] type ldap_control = { criticality: bool; control_details: control_details; } type ldap_controls = ldap_control list type ldap_message = { messageID: Int32.t; protocolOp: protocol_op; controls: ldap_controls option; } type con_mech = [ `SSL | `PLAIN ] type ldap_url = { url_mech: con_mech; url_host: string option; url_port: string option; url_dn: string option; url_attributes: (string list) option; url_scope: search_scope option; url_filter: filter option; url_ext: ((bool * string * string) list) option; } (** see draft-zeilenga-ldap-grouping-xx Ldap grouping is a way of telling the server that a set of ldap operations is related, its most interesting application is transactions across multiple objects. This draft is not yet implemented by any present day ldap server *) type ldap_grouping_type = [ `LDAP_GROUP_TXN ] (** a cookie that is sent with every ldap operation which is part of a group *) type ldap_grouping_cookie ldap-2.5.1/src/ldap/ldap_types.mli0000644000175000017500000002134314652453725020435 0ustar kit_ty_katekit_ty_kate(* Common data types from rfc 2251 used throughout the library 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 *) (** Common data types used by ocamldap. Most of these types are taken from the ASN.1 specification for LDAP as defined in rfc2251 @see rfc2251 *) (** An encoding error has occurred, the argument contains a description of the error This is likely a bug, so it should be reported *) exception LDAP_Encoder of string (** A decoding error has occurred, the argument contains a description of the error. This MAY be a bug, but it may also be that the server you are talking to is non standard. Please report these right away in any case.*) exception LDAP_Decoder of string type ldap_resultcode = [ `SUCCESS | `OPERATIONS_ERROR | `PROTOCOL_ERROR | `TIMELIMIT_EXCEEDED | `SIZELIMIT_EXCEEDED | `COMPARE_FALSE | `COMPARE_TRUE | `AUTH_METHOD_NOT_SUPPORTED | `STRONG_AUTH_REQUIRED | `REFERRAL | `ADMINLIMIT_EXCEEDED | `UNAVAILABLE_CRITICAL_EXTENSION | `CONFIDENTIALITY_REQUIRED | `SASL_BIND_IN_PROGRESS | `NO_SUCH_ATTRIBUTE | `UNDEFINED_TYPE | `INAPPROPRIATE_MATCHING | `CONSTRAINT_VIOLATION | `TYPE_OR_VALUE_EXISTS | `INVALID_SYNTAX | `NO_SUCH_OBJECT | `ALIAS_PROBLEM | `INVALID_DN_SYNTAX | `IS_LEAF | `ALIAS_DEREF_PROBLEM | `INAPPROPRIATE_AUTH | `INVALID_CREDENTIALS | `INSUFFICIENT_ACCESS | `BUSY | `UNAVAILABLE | `UNWILLING_TO_PERFORM | `LOOP_DETECT | `NAMING_VIOLATION | `OBJECT_CLASS_VIOLATION | `NOT_ALLOWED_ON_NONLEAF | `NOT_ALLOWED_ON_RDN | `ALREADY_EXISTS | `NO_OBJECT_CLASS_MODS | `AFFECTS_MULTIPLE_DSAS | `OTHER | `SERVER_DOWN | `LOCAL_ERROR | `ENCODING_ERROR | `DECODING_ERROR | `TIMEOUT | `AUTH_UNKNOWN | `FILTER_ERROR | `USER_CANCELLED | `PARAM_ERROR | `NO_MEMORY | `CONNECT_ERROR | `NOT_SUPPORTED | `CONTROL_NOT_FOUND | `NO_RESULTS_RETURNED | `MORE_RESULTS_TO_RETURN | `CLIENT_LOOP | `REFERRAL_LIMIT_EXCEEDED | `UNKNOWN_ERROR of int ] type ldap_result = { result_code: ldap_resultcode; matched_dn: string; error_message: string; ldap_referral: (string list) option; } (** extended information to return with the LDAP_Failure exception. Contains the remaining values which are defined by the protocol ext_matched_dn: the matched dn. Commonly set by `NO_SUCH_OBJECT. ext_referral: a list of ldapurls returned by the server when you attempted to do a write operation. If you use Ldap_ooclient with referrals set to follow you will never see this*) type ldap_ext_return = { ext_matched_dn: string; ext_referral: string list option; } (** The exception raised to indicate all types of failure in the higher level libraries Ldap_funclient, and Ldap_ooclient. example [LDAP_Failure (`NO_SUCH_OBJECT, "no such object", {ext_matched_dn=Some "o=csun";ext_referral=None})] *) exception LDAP_Failure of ldap_resultcode * string * ldap_ext_return type saslCredentials = { sasl_mechanism: string; sasl_credentials: string option; } type authentication = Simple of string | Sasl of saslCredentials type bind_request = { bind_version: int; bind_name: string; bind_authentication: authentication; } type bind_response = { bind_result: ldap_result; bind_serverSaslCredentials: string option; } type attribute = { attr_type: string; attr_vals: string list; } type dn = attribute list (** the type used to encode and decode a search entry. Also the type returned by search_s and search_a in Ldap_funclient *) type search_result_entry = { sr_dn: string; sr_attributes: attribute list; } (** a type defining the scope of a search filter *) type search_scope = [ `BASE (** search only at the base *) | `ONELEVEL (** search one level below the base *) | `SUBTREE (** search the entire tree under the base *)] type alias_deref = [ `NEVERDEREFALIASES | `DEREFINSEARCHING | `DEREFFINDINGBASE | `DEREFALWAYS ] type attribute_value_assertion = { attributeDesc: string; assertionValue: string; } type matching_rule_assertion = { matchingRule: string option; ruletype: string option; matchValue: string; dnAttributes: bool; (* default false *) } type substring_component = { (* at least one must be specified *) substr_initial: string list; substr_any: string list; substr_final: string list; } type substring_filter = { attrtype: string; substrings: substring_component; } type filter = [ `And of filter list | `Or of filter list | `Not of filter | `EqualityMatch of attribute_value_assertion | `Substrings of substring_filter | `GreaterOrEqual of attribute_value_assertion | `LessOrEqual of attribute_value_assertion | `Present of string | `ApproxMatch of attribute_value_assertion | `ExtensibleMatch of matching_rule_assertion ] type search_request = { baseObject: string; scope: search_scope; derefAliases: alias_deref; sizeLimit: int32; timeLimit: int32; typesOnly: bool; filter: filter; s_attributes: string list; } type modify_optype = [ `ADD | `DELETE | `REPLACE ] type modify_op = { mod_op: modify_optype; mod_value: attribute; } type modify_request = { mod_dn: string; modification: modify_op list } type modify_dn_request = { modn_dn: string; modn_newrdn: string; modn_deleteoldrdn: bool; modn_newSuperior: string option } type compare_request = { cmp_dn: string; cmp_ava: attribute_value_assertion; } type extended_request = { ext_requestName: string; ext_requestValue: string option; } type extended_response = { ext_result: ldap_result; ext_responseName: string option; ext_response: string option; } type protocol_op = Bind_request of bind_request | Bind_response of bind_response | Unbind_request | Search_request of search_request | Search_result_entry of search_result_entry | Search_result_reference of string list | Search_result_done of ldap_result | Modify_request of modify_request | Modify_response of ldap_result | Add_request of search_result_entry | Add_response of ldap_result | Delete_request of string | Delete_response of ldap_result | Modify_dn_request of modify_dn_request | Modify_dn_response of ldap_result | Compare_request of compare_request | Compare_response of ldap_result | Abandon_request of Int32.t | Extended_request of extended_request | Extended_response of extended_response type paged_results_control_value = { size: int; cookie: string; } type control_details = [`Paged_results_control of paged_results_control_value |`Unknown_value of string ] type ldap_control = { criticality: bool; control_details: control_details; } type ldap_controls = ldap_control list type ldap_message = { messageID: Int32.t; protocolOp: protocol_op; controls: ldap_controls option; } type con_mech = [ `SSL | `PLAIN ] type ldap_url = { url_mech: con_mech; url_host: string option; url_port: string option; url_dn: string option; url_attributes: (string list) option; url_scope: search_scope option; url_filter: filter option; url_ext: ((bool * string * string) list) option; } (** see draft-zeilenga-ldap-grouping-xx Ldap grouping is a way of telling the server that a set of ldap operations is related, its most interesting application is transactions across multiple objects. This draft is not yet implemented by any present day ldap server *) type ldap_grouping_type = [ `LDAP_GROUP_TXN ] (** a cookie that is sent with every ldap operation which is part of a group *) type ldap_grouping_cookie ldap-2.5.1/src/ldap/ldap_url.ml0000644000175000017500000000240014652453725017713 0ustar kit_ty_katekit_ty_kate(* a quick and dirty rfc 2255 ldap url lexer for referral processing Will only parse a subset of the ldapurl 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_urllexer exception Invalid_ldap_url of int * string let of_string s = let lx = Lexing.from_string s in try lexurl lx with | SyntaxError -> raise (Invalid_ldap_url (lx.Lexing.lex_last_pos, "syntax error")) | exn -> raise (Invalid_ldap_url (lx.Lexing.lex_last_pos, Printexc.to_string exn)) ldap-2.5.1/src/ldap/ldap_url.mli0000644000175000017500000000264714652453725020101 0ustar kit_ty_katekit_ty_kate(* a quick and dirty rfc 2255 ldap url lexer for referral processing Will only parse a subset of the ldapurl 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 *) (** a library for parsing a subset of the ldapurl syntax *) (** will be raised in the event of a parse or type error. The integer is the location of the error, measured in charachters from the left, and the string is a description of the error. The current lexer does not correctly set the charachter location, however future lexers will. *) exception Invalid_ldap_url of int * string (** internalize the url contained in the string argument *) val of_string : string -> Ldap_types.ldap_url ldap-2.5.1/src/ldap/ldap_urllexer.mll0000644000175000017500000000500614652453725021134 0ustar kit_ty_katekit_ty_kate(* a quick and dirty rfc 2255 ldap url lexer for referral processing Will only parse a subset of the ldapurl 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 type lexeme = SCHEME | COLONSLASHSLASH | PORT of string | HOST of string | DN of string | IDENT of string | SCOPE of string | FILTER of string | QUESTION | EQUAL | CRITICAL | SLASH | WHSP | COMMA exception SyntaxError } let port = ['0' - '9']+ let host = ['-' '.' '0' - '9' 'a' - 'z' 'A' - 'Z']+ let dn = [',' '=' '0' - '9' 'a' - 'z' 'A' - 'Z']+ let attribute = ['a' - 'z' 'A' - 'Z' '0' - '9']+ let filter = [' ' '(' ')' '&' '|' '!' '~' '=' '>' '<' '.' '\\' '0' - '9' 'a' - 'z' 'A' - 'Z'] + let scope = "base" | "one" | "sub" rule lexurl = parse | (("ldap" 's'?) as mech) "://" (host as host)? (':' (port as port))? '/'? eof {{url_mech=(match mech with "ldap" -> `PLAIN | "ldaps" -> `SSL | _ -> failwith "invalid mechanism") ; url_host=host; url_port=port; url_dn=None; url_attributes=None; url_scope=None; url_filter=None; url_ext=None}} | _ | eof { raise SyntaxError } (* rule lexurl = parse "ldap" {SCHEME} | "://" {COLONSLASHSLASH} | port {PORT (Lexing.lexeme lexbuf)} | host {HOST (Lexing.lexeme lexbuf)} | dn {DN (Lexing.lexeme lexbuf)} | attribute {IDENT (Lexing.lexeme lexbuf)} | scope {SCOPE (Lexing.lexeme lexbuf)} | filter {FILTER (Lexing.lexeme lexbuf)} | ',' {COMMA} | '?' {QUESTION} | '=' {EQUAL} | ':' {COLON} | '!' {CRITICAL} | '/' {SLASH} | ' '* {WHSP} *) ldap-2.5.1/src/ldap/ldap_urlparser.mli0000644000175000017500000000051214652453725021303 0ustar kit_ty_katekit_ty_katetype token = | SCHEME | COLONSLASHSLASH | SLASH | QUESTION | EQUAL | COLON | COMMA | WHSP | CRITICAL | HOST of (string) | PORT of (string) | DN of (string) | IDENT of (string) | SCOPE of (string) | FILTER of (string) val ldapurl : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Ldap_types.ldap_url ldap-2.5.1/src/ldap/ulist.ml0000644000175000017500000000265314652453725017263 0ustar kit_ty_katekit_ty_kate(* case insensitive, case perserving, unique lists based on hash tables 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 *) type t = (string, string) Hashtbl.t;; let create n = Hashtbl.create n;; let mem lst item = Hashtbl.mem lst (String.lowercase_ascii item);; let add lst item = let lcitem = String.lowercase_ascii item in if (Hashtbl.mem lst lcitem) = false then Hashtbl.add lst lcitem item; ();; let addlst lst lst1 = List.iter (fun i -> add lst i) lst1;; let remove lst item = Hashtbl.remove lst (String.lowercase_ascii item);; let iter func lst = Hashtbl.iter (fun key _v -> func key) lst;; let tolst lst = Hashtbl.fold (fun _k v l -> v :: l) lst [];; ldap-2.5.1/src/ldif/0000755000175000017500000000000014652453725015561 5ustar kit_ty_katekit_ty_kateldap-2.5.1/src/ldif/dune0000644000175000017500000000047614652453725016446 0ustar kit_ty_katekit_ty_kate(ocamlyacc ldif_changerec_parser) (ocamllex ldif_changerec_lexer) (library (name ldif) (public_name ldap.ldif) (wrapped false) (modules_without_implementation ldif_types) (libraries camlp-streams ldap threads netstring)) ; TODO: remove threads. See https://gitlab.camlcity.org/gerd/lib-ocamlnet3/issues/14 ldap-2.5.1/src/ldif/ldif_changerec_lexer.mll0000644000175000017500000000341314652453725022404 0ustar kit_ty_katekit_ty_kate(* lexer for extended ldif 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 Ldif_changerec_parser open Netencoding } let nl = '\n' let whsp = ' ' * let mustsp = ' ' + let alphanum = ['0' - '9' 'a' - 'z' 'A' - 'Z'] let anyprintablechar = ['\t' ' ' - '~'] let attrname = alphanum + let attrval = (anyprintablechar | '\n' ' ') + rule lexcr = parse | "dn:" mustsp ([' ' - '~']+ as dn) nl {Dn dn} | "changetype:" mustsp "modify" nl {Change_type_modify} | "changetype:" mustsp "delete" nl {Change_type_delete} | "changetype:" mustsp "modrdn" nl {Change_type_modrdn} | "changetype:" mustsp "add" nl {Change_type_add} | "add:" mustsp (attrname as name) nl {Add name} | "delete:" mustsp (attrname as name) nl {Delete name} | "replace:" mustsp (attrname as name) nl {Replace name} | (attrname as attr) ':' mustsp (attrval as valu) nl {Attr (attr, valu)} | (attrname as attr) "::" mustsp (attrval as valu) nl {Attr (attr, Base64.decode valu)} | '-' nl {Dash} | nl + {Newline} | eof {End_of_input} ldap-2.5.1/src/ldif/ldif_changerec_oo.ml0000644000175000017500000000641314652453725021531 0ustar kit_ty_katekit_ty_kate(* create an ldap changerec factory from a channel attached to an ldif changerec source default is stdin and stdout. Copyright (C) 2004 Eric Stokes, Matthew Backes, 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_ooclient open Ldif_changerec_parser open Ldif_changerec_lexer exception Invalid_changerec of string exception End_of_changerecs let iter f cr = try while true do f cr#read_changerec done with End_of_changerecs -> () let rec fold f cr a = try fold f cr (f a cr#read_changerec) with End_of_changerecs -> a let insert_change buf cr = match cr with `Modification (dn, mod_op) -> Buffer.add_string buf ("dn: " ^ dn ^ "\n"); Buffer.add_string buf "changetype: modify\n"; List.iter (fun (op, attr, vals) -> (match op with `ADD -> Buffer.add_string buf ("add: " ^ attr ^ "\n") | `DELETE -> Buffer.add_string buf ("delete: " ^ attr ^ "\n") | `REPLACE -> Buffer.add_string buf ("replace: " ^ attr ^ "\n")); List.iter (fun valu -> Buffer.add_string buf (attr ^ ": " ^ valu ^ "\n")) vals; Buffer.add_string buf "-\n") mod_op; Buffer.add_string buf "\n"; buf | `Addition e -> Ldif_oo.entry2ldif ~ext:true buf e; | `Delete dn -> Buffer.add_string buf ("dn: " ^ dn ^ "\n"); Buffer.add_string buf "changetype: delete\n"; buf | `Modrdn (dn, deleteoldrdn, newrdn) -> Buffer.add_string buf ("dn: " ^ dn ^ "\n"); Buffer.add_string buf "changetype: modrdn\n"; Buffer.add_string buf ("deleteoldrdn: " ^ (string_of_int deleteoldrdn) ^ "\n"); Buffer.add_string buf ("newrdn: " ^ newrdn ^ "\n"); buf class change ?(in_ch=stdin) ?(out_ch=stdout) () = object (_self) val lxbuf = Lexing.from_channel in_ch val buf = Buffer.create 1 method read_changerec = try changerec lexcr lxbuf with Ldif_types.Changerec_parser_end -> raise End_of_changerecs | Failure s -> raise (Invalid_changerec s) method of_string (s:string) = let lx = Lexing.from_string s in try changerec lexcr lx with Ldif_types.Changerec_parser_end -> raise End_of_changerecs | Failure s -> raise (Invalid_changerec s) method to_string (e:changerec) = let res = Buffer.contents (insert_change buf e) in Buffer.clear buf;res method write_changerec (e:changerec) = ignore (insert_change buf e); Buffer.output_buffer out_ch buf; Buffer.clear buf end ldap-2.5.1/src/ldif/ldif_changerec_oo.mli0000644000175000017500000000353214652453725021701 0ustar kit_ty_katekit_ty_kate(* create an ldap entry factory from a channel attached to an ldif source default is stdin and stdout. Copyright (C) 2004 Eric Stokes, Matthew Backes, 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 *) (** an object oriented interface to the ldif parser *) (** an exception raised when there is a parse error *) exception Invalid_changerec of string (** raised at the end of the change records *) exception End_of_changerecs (** Ldif_changerec.iter f change, iterate accross all change entries in the specified change object, applying f to each one *) val iter : ('a -> unit) -> < read_changerec : 'a; .. > -> unit (** Ldif_changerec.fold f change value, for each change entry en in the change object fold computes f (... (f (f value e1) e2) ...) en *) val fold : ('a -> 'b -> 'a) -> < read_changerec : 'b; .. > -> 'a -> 'a class change: ?in_ch:in_channel -> ?out_ch:out_channel -> unit -> object method read_changerec: Ldap_ooclient.changerec method of_string: string -> Ldap_ooclient.changerec method to_string: Ldap_ooclient.changerec -> string method write_changerec: Ldap_ooclient.changerec -> unit end ldap-2.5.1/src/ldif/ldif_changerec_parser.mly0000644000175000017500000000631514652453725022602 0ustar kit_ty_katekit_ty_kate/* a parser for extended ldif 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_ooclient let check_attrs attr attrs = List.rev_map (fun (declared_attr, valu) -> if declared_attr = attr then valu else failwith ("declared attribute " ^ "modifies the wrong" ^ "attribute, " ^ "attribute: " ^ attr ^ "declared: " ^ declared_attr)) attrs let check_empty op attr = match op with `DELETE -> (op, attr, []) | `ADD -> failwith "non sensical empty add" | `REPLACE -> failwith "non sensical empty replace" %} %token End_of_input Change_type_add Change_type_modrdn %token Change_type_modify Change_type_delete Dash Newline %token AttributeType Dn Add Delete Replace %token Attr %type changerec %start changerec %% operation: Add {(`ADD, $1)} | Delete {(`DELETE, $1)} | Replace {(`REPLACE, $1)} ; attrlst: Attr attrlst {$1 :: $2} | Attr {[$1]} newline: Newline {} | End_of_input {} modificationterminator: Dash newline {} | newline {} ; modifications: operation attrlst Dash modifications {let (op, attr) = $1 in (op, attr, check_attrs attr $2) :: $4} | operation Dash modifications {let (op, attr) = $1 in (check_empty op attr) :: $3} | operation attrlst modificationterminator {let (op, attr) = $1 in [(op, attr, check_attrs attr $2)]} | operation modificationterminator {let (op, attr) = $1 in [(check_empty op attr)]} ; entry: Attr entry {let (a, v) = $1 in (a, [v]) :: $2} | Attr newline {let (a, v) = $1 in [(a, [v])]} changerec: Dn Change_type_modify modifications {`Modification ($1, List.rev $3)} | Dn Change_type_add entry {let e = new ldapentry in e#set_dn $1;e#add $3;`Addition e} | Dn Change_type_delete newline {`Delete $1} | Dn Change_type_modrdn Attr Attr newline {`Modrdn ($1, int_of_string (snd $3), snd $4)} | End_of_input {raise Ldif_types.Changerec_parser_end} ; ldap-2.5.1/src/ldif/ldif_oo.ml0000644000175000017500000000741714652453725017537 0ustar kit_ty_katekit_ty_kate(* An object oriented interface for parsing Lightweight Directory Interchange Format file Copyright (C) 2004 Eric Stokes, Matthew Backes, 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 Netencoding open Ldap_ooclient open Ldif_parser let safe_string_regex = Str.regexp "^[\x01-\x09\x0b-\x0c\x0e-\x7f]+$" let password_regex = Str.regexp_case_fold ".*p\\(ass\\)?w\\(or\\)?d$" let empty_regex = Str.regexp "^ *$\\|^ *.*$" let safe_val buf s = if (Str.string_match safe_string_regex s 0) && (not (Str.string_match empty_regex s 0)) then begin Buffer.add_string buf ": "; Buffer.add_string buf s end else begin Buffer.add_string buf ":: "; Buffer.add_string buf (Base64.encode s) end let safe_attr_val buf a v = if Str.string_match password_regex a 0 then begin Buffer.add_string buf a; Buffer.add_string buf ":: "; Buffer.add_string buf (Base64.encode v) end else begin Buffer.add_string buf a; safe_val buf v end let entry2ldif ?(ext=false) outbuf e = Buffer.add_string outbuf "dn"; safe_val outbuf e#dn; if ext then Buffer.add_string outbuf "\nchangetype: add"; Buffer.add_char outbuf '\n'; (List.iter (fun attr -> (List.iter (fun value -> safe_attr_val outbuf attr value; Buffer.add_char outbuf '\n') (e#get_value attr))) e#attributes); Buffer.add_char outbuf '\n'; outbuf let iter (f: ('a -> unit)) ldif = try while true do f ldif#read_entry done with End -> () let fold f ldif v = let objects = let objects = ref [] in try while true do objects := (ldif#read_entry) :: !objects done; !objects with End -> !objects in List.fold_left f v objects class ldif ?(in_ch=stdin) ?(out_ch=stdout) () = object (_self) val in_ch = {stream=(Stream.of_channel in_ch);buf=Buffer.create 256;line=1} val out_ch = out_ch val outbuf = Buffer.create 50 method read_entry = Ldap_ooclient.to_entry (`Entry (ldif_attrval_record in_ch)) method of_string s = let strm = {stream=(Stream.of_string s);buf=Buffer.create 256;line=1} in Ldap_ooclient.to_entry (`Entry (ldif_attrval_record strm)) method to_string (e:ldapentry_t) = try let contents = Buffer.contents (entry2ldif outbuf e) in Buffer.clear outbuf; contents with exn -> Buffer.clear outbuf; raise exn method write_entry (e:ldapentry_t) = try Buffer.output_buffer out_ch (entry2ldif outbuf e); Buffer.clear outbuf with exn -> Buffer.clear outbuf; raise exn end let read_ldif_file file = let fd = open_in file in try let ldif = new ldif ~in_ch:fd () in let entries = fold (fun l e -> e :: l) ldif [] in close_in fd; entries with exn -> close_in fd;raise exn let write_ldif_file file entries = let fd = open_out file in try let ldif = new ldif ~out_ch:fd () in List.iter ldif#write_entry entries; close_out fd with exn -> close_out fd;raise exn ldap-2.5.1/src/ldif/ldif_oo.mli0000644000175000017500000000445714652453725017711 0ustar kit_ty_katekit_ty_kate(* create an ldap entry factory from a channel attached to an ldif source default is stdin and stdout. Copyright (C) 2004 Eric Stokes, Matthew Backes, 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 *) (** an object oriented interface to the ldif parser *) (** Ldif_oo.iter f ldif, iterate accross all ldif entries in the specified ldif object, applying f to each one *) val iter : ('a -> unit) -> < read_entry : 'a; .. > -> unit (** Ldif_oo.fold f ldif value, for each ldif entry en in the ldif object fold computes f (... (f (f value e1) e2) ...) en *) val fold : ('a -> 'b -> 'a) -> < read_entry : 'b; .. > -> 'a -> 'a (** if you need a fast, low level interface to to_string, this function will write ldif directly into a buffer. Setting ext to true (defaul false) will write extended ldif. Extended ldif should be parsed using the Ldif_changerec_oo module. *) val entry2ldif : ?ext:bool -> Buffer.t -> < attributes : string list; dn : string; get_value : string -> string list; .. > -> Buffer.t (** read all the entries in the named ldif file and return them in a list *) val read_ldif_file : string -> Ldap_ooclient.ldapentry list (** write all the entries in the given list to the named file in ldif format *) val write_ldif_file : string -> Ldap_ooclient.ldapentry list -> unit class ldif: ?in_ch:in_channel -> ?out_ch:out_channel -> unit -> object method read_entry: Ldap_ooclient.ldapentry method of_string: string -> Ldap_ooclient.ldapentry method to_string: Ldap_ooclient.ldapentry -> string method write_entry: Ldap_ooclient.ldapentry -> unit end ldap-2.5.1/src/ldif/ldif_parser.ml0000644000175000017500000001606014652453725020410 0ustar kit_ty_katekit_ty_kate(* A lexer and parser for ldif format files 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 Netencoding exception Illegal_char of char * int exception End type stream_rec = {stream: char Stream.t;buf:Buffer.t;mutable line: int} let optval o = match o with Some(c) -> c | None -> raise End let rec read_comment s = let check_next s = match (optval (Stream.peek s.stream)) with ' ' | '#' -> (Stream.junk s.stream);read_comment s (* line folded, or another comment *) | _ -> () in match (optval (Stream.peek s.stream)) with '\n' -> (Stream.junk s.stream);s.line <- s.line + 1;check_next s | '\r' -> (Stream.junk s.stream);(Stream.junk s.stream); s.line <- s.line + 1;check_next s | _ -> (Stream.junk s.stream);read_comment s let comment s = match (optval (Stream.peek s.stream)) with '#' -> (Stream.junk s.stream);read_comment s | _ -> () let sep s = match (optval (Stream.peek s.stream)) with '\n' -> (Stream.junk s.stream);s.line <- s.line + 1;"\n" | '\r' -> (Stream.junk s.stream);(Stream.junk s.stream);s.line <- s.line + 1;"\n" | c -> raise (Illegal_char (c,s.line));; let seps s = try (while true do ignore (sep s) done) with Illegal_char(_,_) -> ();; let digit s = match (optval (Stream.peek s.stream)) with '0'..'9' -> (Stream.next s.stream) | c -> raise (Illegal_char (c,s.line));; let safe_char s = match (optval (Stream.peek s.stream)) with ' '..'~' -> (Stream.next s.stream) | c -> raise (Illegal_char (c,s.line));; let safe_init_char s = match (optval (Stream.peek s.stream)) with '!'..'9'|';'..'~' -> (Stream.next s.stream) | c -> raise (Illegal_char (c,s.line));; let alpha s = match (optval (Stream.peek s.stream)) with 'a'..'z'|'A'..'Z' -> (Stream.next s.stream) | c -> raise (Illegal_char (c,s.line));; let safe_chars s = let rec do_safe_chars s = try while true do Buffer.add_char s.buf (safe_char s) done with Illegal_char('\n',_) -> (match (Stream.npeek 2 s.stream) with ['\n';' '] -> (Stream.junk s.stream);(Stream.junk s.stream); s.line <- s.line + 1; (do_safe_chars s) | _ -> ()) | Illegal_char('\r',_) -> (match (Stream.npeek 3 s.stream) with ['\r';'\n';' '] -> (Stream.junk s.stream);(Stream.junk s.stream);(Stream.junk s.stream); s.line <- s.line + 1; (do_safe_chars s) | _ -> ()) | Illegal_char(_,_) -> () | End -> () in do_safe_chars s;; let safe_string s = Buffer.clear s.buf; Buffer.add_char s.buf (safe_init_char s); safe_chars s; Buffer.contents s.buf;; let attr_type_char s = match (optval (Stream.peek s.stream)) with 'A'..'Z'|'a'..'z'|'0'..'9'|'-' -> (Stream.next s.stream) | c -> raise (Illegal_char (c, s.line));; let attr_type_chars s = try while true do Buffer.add_char s.buf (attr_type_char s) done; with Illegal_char(_,_) -> () let option s = Buffer.clear s.buf; Buffer.add_char s.buf (attr_type_char s); attr_type_chars s; Buffer.contents s.buf;; let rec options s = match (optval (Stream.peek s.stream)) with ';' -> let thisone = (Stream.junk s.stream);(option s) in thisone ^ (options s) | ':' -> "" | c -> raise (Illegal_char (c, s.line));; (* syntax error *) let attributeType s = Buffer.clear s.buf; Buffer.add_char s.buf (alpha s); attr_type_chars s; Buffer.contents s.buf;; let attributeDescription s = let name = (attributeType s) in let _options = (match (optval (Stream.peek s.stream)) with ';' -> options s (* there are options *) | _ -> "") in let _colon = (match (optval (Stream.peek s.stream)) with ':' -> (Stream.junk s.stream);"" | _ -> failwith "Parse, error. Missing colon in attribute spec") in name let value_spec s = match (optval (Stream.peek s.stream)) with ':' -> (Stream.junk s.stream); (match (optval (Stream.peek s.stream)) with ' ' -> (Stream.junk s.stream); (Base64.decode (safe_string s)) | c -> raise (Illegal_char (c, s.line))) | '<' -> (Stream.junk s.stream);(match (optval (Stream.peek s.stream)) with ' ' -> (Stream.junk s.stream);(safe_string s) (* a url *) | c -> raise (Illegal_char (c, s.line))) | ' ' -> (Stream.junk s.stream);(safe_string s) | c -> raise (Illegal_char (c, s.line)) let rec attrval_spec ?(attrs=[]) s = let lc = String.lowercase_ascii in try ignore (sep s);attrs with Illegal_char(_,_) -> let attr = (attributeDescription s) in let valu = (value_spec s) in let _sep = (sep s) in (match attrs with | {attr_type=name;attr_vals=vals} :: tl -> if (lc attr) = (lc name) then attrval_spec ~attrs:({attr_type=name; attr_vals=(valu :: vals)} :: tl) s else attrval_spec ~attrs:({attr_type=attr;attr_vals=[valu]} :: attrs) s | [] -> attrval_spec ~attrs:[{attr_type=attr;attr_vals=[valu]}] s) | End -> attrs let distinguishedName s = match (optval (Stream.peek s.stream)) with ':' -> (Stream.junk s.stream); (match (optval (Stream.peek s.stream)) with ' ' -> (Stream.junk s.stream); (Base64.decode (safe_string s)) | c -> raise (Illegal_char (c, s.line))) | ' ' -> (Stream.junk s.stream);safe_string s | c -> raise (Illegal_char (c, s.line)) let dn_spec s = match (Stream.npeek 3 s.stream) with ['d';'n';':'] -> (Stream.junk s.stream); (Stream.junk s.stream); (Stream.junk s.stream); (distinguishedName s) | _ -> failwith ("invalid dn on line: " ^ (string_of_int s.line)) let ldif_attrval_record s = let _ = comment s in let _ = seps s in let dn = dn_spec s in let _ = try seps s with End -> () in (* just a dn is a valid ldif file *) let attrs = attrval_spec s in {sr_dn=dn;sr_attributes=attrs} ldap-2.5.1/src/ldif/ldif_types.mli0000644000175000017500000000003714652453725020426 0ustar kit_ty_katekit_ty_kateexception Changerec_parser_end ldap-2.5.1/src/toplevel/0000755000175000017500000000000014652453725016475 5ustar kit_ty_katekit_ty_kateldap-2.5.1/src/toplevel/dune0000644000175000017500000000020114652453725017344 0ustar kit_ty_katekit_ty_kate(library (name toplevel) (public_name ldap.toplevel) (modes byte) (wrapped false) (libraries ldap ldif compiler-libs)) ldap-2.5.1/src/toplevel/ldap_toplevel.ml0000644000175000017500000000407014652453725021662 0ustar kit_ty_katekit_ty_kate(* Functions which resemble the command line tools, useful in the interactive environment 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_ooclient let eval s = let l = Lexing.from_string s in let ph = !Toploop.parse_toplevel_phrase l in assert(Toploop.execute_phrase false Format.err_formatter ph) ;; eval "#install_printer Ldap_ooclient.format_entries;;";; eval "#install_printer Ldap_ooclient.format_entry;;";; eval "#install_printer Ldap_schemaparser.format_oid;;";; eval "#install_printer Ldap_schemaparser.format_lcstring;;";; eval "#install_printer Ldap_schemaparser.format_schema;;";; let ldap_cmd_harness ~h ~d ~w f = let ldap = new ldapcon [h] in try ldap#bind d ~cred:w; let res = f ldap in ldap#unbind; res with exn -> ldap#unbind;raise exn ;; let ldapsearch ?(s=`SUBTREE) ?(a=[]) ?(b="") ?(d="") ?(w="") ~h filter = ldap_cmd_harness ~h ~d ~w (fun ldap -> ldap#search ~base:b ~scope:s ~attrs:a filter) ;; let ldapmodify ~h ~d ~w mods = ldap_cmd_harness ~h ~d ~w (fun ldap -> List.iter (fun (dn, ldmod) -> ldap#modify dn ldmod) mods) ;; let ldapadd ~h ~d ~w entries = ldap_cmd_harness ~h ~d ~w (fun ldap -> List.iter (fun entry -> ldap#add entry) entries) ;; ldap-2.5.1/src/toplevel/ldap_toplevel.mli0000644000175000017500000000512014652453725022030 0ustar kit_ty_katekit_ty_kate(* Functions which resemble the command line tools which many users are familar with, useful in the interactive environment 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 *) (** Functions which resemble the command line tools which many users are familar with, useful in the interactive environment *) (** connect to the specified host and perform a search. @param h The ldapurl which names the host and port to connect to @param d The dn of the object you with to bind as, default anonymous @param w The credentials of the object you wish to bind as, default anonymous @param s The scope of the search, default `SUBTREE @param b The base of the search The final argument is the search filter *) val ldapsearch : ?s:Ldap_types.search_scope -> ?a:string list -> ?b:string -> ?d:string -> ?w:string -> h:string -> string -> Ldap_ooclient.ldapentry list (** connect to the specified host and perform one or more modifications. @param h The ldapurl which names the host and port to connect to @param d The dn of the object you with to bind as, default anonymous @param w The credentials of the object you wish to bind as, default anonymous The final argument is a list of (dn, modification) pairs which you want to apply *) val ldapmodify : h:string -> d:string -> w:string -> (string * (Ldap_types.modify_optype * string * string list) list) list -> unit (** connect to the specified host and add the specified objects. @param h The ldapurl which names the host and port to connect to @param d The dn of the object you with to bind as, default anonymous @param w The credentials of the object you wish to bind as, default anonymous The final argument is a list of objects you wish to add *) val ldapadd : h:string -> d:string -> w:string -> Ldap_ooclient.ldapentry list -> unit ldap-2.5.1/tests/0000755000175000017500000000000014652453725015216 5ustar kit_ty_katekit_ty_kateldap-2.5.1/tests/ldap/0000755000175000017500000000000014652453725016136 5ustar kit_ty_katekit_ty_kateldap-2.5.1/tests/ldap/dune0000644000175000017500000000035114652453725017013 0ustar kit_ty_katekit_ty_kate(executables (names test page_result_control_test lber_tests) (libraries ldap)) (rule (alias runtest) (deps test.exe) (action (progn (run %{exe:page_result_control_test.exe}) (run %{exe:lber_tests.exe})))) ldap-2.5.1/tests/ldap/lber_tests.ml0000644000175000017500000000271214652453725020640 0ustar kit_ty_katekit_ty_kateopen Lber let encode_decode_int32 i = let e_i32 = encode_ber_int32 i in let rb = readbyte_of_string e_i32 in decode_ber_int32 rb let rec test_positive_encode_decode_int32 i = if i < Int32.max_int then let result = try encode_decode_int32 i with exn -> print_endline ("unhandled exception: " ^ (Printexc.to_string exn) ^ " with int: " ^ (Int32.to_string i)); exit 0 in if result <> i then failwith ("I encode: " ^ (Int32.to_string i) ^ " and I get: " ^ (Int32.to_string result)) else ((if Int32.rem i 1000000l = 0l then print_endline ("i:" ^ (Int32.to_string i))); test_positive_encode_decode_int32 (Int32.succ i)) let rec test_negative_encode_decode_int32 i = if i > Int32.min_int then let result = try encode_decode_int32 i with exn -> print_endline ("unhandled exception: " ^ (Printexc.to_string exn) ^ " with int: " ^ (Int32.to_string i)); exit 0 in if result <> i then failwith ("I encode: " ^ (Int32.to_string i) ^ " and I get: " ^ (Int32.to_string result)) else ((if Int32.rem i (-1000000l) = 0l then print_endline ("i:" ^ (Int32.to_string i))); test_negative_encode_decode_int32 (Int32.pred i)) let main () = (* print_endline "testing integer encoder/decoder with positive numbers"; test_positive_encode_decode_int32 0l; *) print_endline "testing integer encoder/decoder with negative numbers"; test_negative_encode_decode_int32 0l ;; main () ldap-2.5.1/tests/ldap/page_result_control_test.ml0000644000175000017500000000551614652453725023610 0ustar kit_ty_katekit_ty_kateopen Printf (* Build this test with the following command: ocamlc -g -o page_result_control_test -package str -package ldap -thread -linkpkg page_result_control_test.ml *) let default_server = "ldap://x500.bund.de" let default_base = "o=Bund,c=DE" let default_who = "" let default_cred = "" let default_page_size = 200 let get_page_control controls = List.fold_left (fun cur_res control -> match cur_res with | None -> begin match control.Ldap_types.control_details with | `Paged_results_control _ -> Some control | _ -> None end | Some x -> Some x) None controls let rec entry_list_builder_helper accum search_function page_size msgid conn = let cur_entry = try Ldap_funclient.get_search_entry_with_controls conn msgid with _ -> failwith "error" in begin match cur_entry with | `Success None -> accum (* This means we are done, if we are not using page control...but we are so we never reach here in this case *) | `Success (Some controls) -> (* do recursive call with cookie *) let pg_control = get_page_control controls in begin match pg_control with | None -> (*printf "Error: couldn't get page control\n";*) [] | Some c -> begin match c.Ldap_types.control_details with | `Paged_results_control value -> let mycookie=value.Ldap_types.cookie in if mycookie = "" then accum (* This means we are done. *) else let new_msgid = search_function (`Subctrl (page_size,mycookie)) in entry_list_builder_helper accum search_function page_size new_msgid conn | `Unknown_value _ -> (*printf "Error: unknown ldap control value: %s\n" s;*) [] end end | `Entry e -> entry_list_builder_helper (e::accum) search_function page_size msgid conn | `Referral _ -> entry_list_builder_helper accum search_function page_size msgid conn (*ignore referrals and continue *) end let entry_list_builder search_function page_size msgid conn = entry_list_builder_helper [] search_function page_size msgid conn let search_function conn page_control = Ldap_funclient.search ~base:default_base ~scope:`SUBTREE ~attrs:["dc"] ~page_control conn "(objectclass=*)" let () = match try Some (Ldap_funclient.init [default_server]) with Ldap_types.LDAP_Failure _ | Unix.Unix_error _ -> None with | Some conn -> Ldap_funclient.bind_s conn ~who:default_who ~cred:default_cred ~auth_method:`SIMPLE; let msgid = search_function conn (`Initctrl default_page_size) in let elist = entry_list_builder (search_function conn) default_page_size msgid conn in printf "got %d entries\n" (List.length elist) | None -> prerr_endline "Couldn't connect to the server, abort." ldap-2.5.1/tests/ldap/test.ml0000644000175000017500000000475714652453725017464 0ustar kit_ty_katekit_ty_kate(* a test program for ldap_funclient 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 *) (* $Id$ *) open Ldap_types open Ldap_funclient open Arg let ldif_buffer = Buffer.create 3124 let print_entry e = match e with `Entry {sr_dn=dn;sr_attributes=attrs} -> Buffer.add_string ldif_buffer "dn: "; Buffer.add_string ldif_buffer dn; Buffer.add_string ldif_buffer "\n"; List.iter (fun {attr_type=name;attr_vals=vals} -> List.iter (fun aval -> Buffer.add_string ldif_buffer name; Buffer.add_string ldif_buffer ": "; Buffer.add_string ldif_buffer aval; Buffer.add_string ldif_buffer "\n") vals) attrs; Buffer.add_string ldif_buffer "\n"; Buffer.output_buffer stdout ldif_buffer; Buffer.clear ldif_buffer | `Referral _f -> () let main () = let usg = "test -H -D -w -b " in let host = ref "" in let binddn = ref "" in let cred = ref "" in let base = ref "" in let filter = ref "" in let set_host x = host := x in let set_binddn x = binddn := x in let set_cred x = cred := x in let set_base x = base := x in let set_filter x = filter := x in let spec = [("-H", String(set_host), "host"); ("-D", String(set_binddn), "dn to bind with"); ("-w", String(set_cred), "password to use when binding"); ("-b", String(set_base), "search base")] in if (Array.length Sys.argv) > 9 then (parse spec set_filter usg; let con = init [!host] in bind_s con ~who:!binddn ~cred:!cred; let msgid = search con ~base:!base !filter in try while true do print_entry (get_search_entry con msgid); done with LDAP_Failure (`SUCCESS, _, _) -> print_endline "") else usage spec usg ;; main ();; ldap-2.5.1/tests/ldif/0000755000175000017500000000000014652453725016134 5ustar kit_ty_katekit_ty_kateldap-2.5.1/tests/ldif/dune0000644000175000017500000000017314652453725017013 0ustar kit_ty_katekit_ty_kate(executables (names testldif testoo) (libraries ldap ldif)) (alias (name runtest) (deps testldif.exe testoo.exe)) ldap-2.5.1/tests/ldif/testldif.ml0000644000175000017500000000172114652453725020305 0ustar kit_ty_katekit_ty_kate(* a test program for the ldif libraries 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 *) (* $Id$ *) let _ = let ldif = new Ldif_oo.ldif () in ldif#write_entry ldif#read_entry, flush_all ldap-2.5.1/tests/ldif/testoo.ml0000644000175000017500000000352214652453725020005 0ustar kit_ty_katekit_ty_kate(* a test program for ldap_ooclient 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_ooclient open Ldif_oo open Arg let () = (* stuff to handle command line args *) let usg = "testoo -H -D -w -b " in let host = ref "" in let binddn = ref "" in let cred = ref "" in let base = ref "" in let filter = ref "" in let set_host x = host := x in let set_binddn x = binddn := x in let set_cred x = cred := x in let set_base x = base := x in let set_filter x = filter := x in let spec = [("-H", String(set_host), "host"); ("-D", String(set_binddn), "dn to bind with"); ("-w", String(set_cred), "password to use when binding"); ("-b", String(set_base), "search base")] in (* do the ldap part *) if (Array.length Sys.argv) > 9 then (parse spec set_filter usg; let ldap = new ldapcon [!host] in let ldif = new ldif () in ldap#bind !binddn ~cred: !cred; Ldap_ooclient.iter (fun e -> ldif#write_entry e) (ldap#search_a ~base: !base !filter)) else usage spec usg