├── .gitignore ├── COPYING ├── Changelog ├── README ├── dune-project ├── ldap.opam ├── src ├── ldap │ ├── dune │ ├── lber.ml │ ├── lber.mli │ ├── ldap_dn.ml │ ├── ldap_dn.mli │ ├── ldap_dnlexer.mll │ ├── ldap_dnparser.mly │ ├── ldap_error.ml │ ├── ldap_error.mli │ ├── ldap_filter.ml │ ├── ldap_filter.mli │ ├── ldap_filterlexer.mll │ ├── ldap_filterparser.mly │ ├── ldap_funclient.ml │ ├── ldap_funclient.mli │ ├── ldap_funserver.ml │ ├── ldap_funserver.mli │ ├── ldap_mutex.ml │ ├── ldap_mutex.mli │ ├── ldap_ooclient.ml │ ├── ldap_ooclient.mli │ ├── ldap_protocol.ml │ ├── ldap_protocol.mli │ ├── ldap_schemalexer.mll │ ├── ldap_schemaparser.ml │ ├── ldap_schemaparser.mli │ ├── ldap_txooclient.ml │ ├── ldap_txooclient.mli │ ├── ldap_types.ml │ ├── ldap_types.mli │ ├── ldap_url.ml │ ├── ldap_url.mli │ ├── ldap_urllexer.mll │ ├── ldap_urlparser.mli │ └── ulist.ml ├── ldif │ ├── dune │ ├── ldif_changerec_lexer.mll │ ├── ldif_changerec_oo.ml │ ├── ldif_changerec_oo.mli │ ├── ldif_changerec_parser.mly │ ├── ldif_oo.ml │ ├── ldif_oo.mli │ ├── ldif_parser.ml │ └── ldif_types.mli └── toplevel │ ├── dune │ ├── ldap_toplevel.ml │ └── ldap_toplevel.mli └── tests ├── ldap ├── dune ├── lber_tests.ml ├── page_result_control_test.ml └── test.ml └── ldif ├── dune ├── testldif.ml └── testoo.ml /.gitignore: -------------------------------------------------------------------------------- 1 | /_build 2 | .merlin 3 | /ldap.install 4 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | Copyright (C) 2004 Eric Stokes, Matthew Backes, and The California 2 | State University at Northridge 3 | 4 | This library is free software; you can redistribute it and/or 5 | modify it under the terms of the GNU Lesser General Public 6 | License as published by the Free Software Foundation; either 7 | version 2.1 of the License, or (at your option) any later version. 8 | 9 | This library is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public 15 | License along with this library; if not, write to the Free Software 16 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 17 | USA 18 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | ocamldap - Ocamldap is an implementation of the Light Weight Directory Access Protocol 2 | ====================================================================================== 3 | 4 | --------------------------------------------------------------------------- 5 | Synopsis 6 | --------------------------------------------------------------------------- 7 | 8 | Ocamldap is an ldap toolkit. It can be used by ocaml programs to 9 | communicate with ldap servers, and to build your own ldap servers. 10 | 11 | --------------------------------------------------------------------------- 12 | Features 13 | --------------------------------------------------------------------------- 14 | * Ocamldap supports the core ldap-client functions, including search, add, 15 | modify, and delete. 16 | * object oriented interface with additional features. 17 | Such as, nice data structures for local ldap entries which 18 | record local modifications and can sync them with the server, fewer 19 | arguments needed to perform simple tasks, and transparent reconnection 20 | of dropped connections. 21 | * Ocamldap includes an ldif parser, which allows you to read ldif files into 22 | entry objects. It also supports ldif change records. 23 | * Ocamldap has a method call to grab the schema of an ldapv3 server 24 | * Basic ldap server functionality (ldap_funserver) allows you to easily 25 | construct your own ldap servers. Perfect for meta directories, 26 | and other cool projects. Someday maybe your main database :-) 27 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | (name ldap) 3 | (version 2.5.1) 4 | 5 | (formatting disabled) 6 | (implicit_transitive_deps false) 7 | -------------------------------------------------------------------------------- /ldap.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | version: "2.5.1" 3 | synopsis: "Implementation of the Light Weight Directory Access Protocol" 4 | maintainer: ["Kate "] 5 | authors: ["Eric Stokes "] 6 | license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" 7 | tags: ["ldap"] 8 | homepage: "https://github.com/kit-ty-kate/ocamldap" 9 | doc: "https://kit-ty-kate.github.io/ocamldap" 10 | bug-reports: "https://github.com/kit-ty-kate/ocamldap/issues" 11 | depends: [ 12 | "dune" {>= "2.7"} 13 | "ocaml" {>= "4.03.0"} 14 | "ocamlnet" {>= "3.6.0"} 15 | "re" {>= "1.3.0"} 16 | "camlp-streams" {>= "5.0.1"} 17 | "ssl" {>= "0.5.3"} 18 | ] 19 | conflicts: [ 20 | "ocamldap" {!= "transition"} 21 | ] 22 | build: [ 23 | [ 24 | "dune" 25 | "build" 26 | "-p" 27 | name 28 | "-j" 29 | jobs 30 | "@install" 31 | "@runtest" {with-test} 32 | ] 33 | ] 34 | dev-repo: "git+https://github.com/kit-ty-kate/ocamldap.git" 35 | -------------------------------------------------------------------------------- /src/ldap/dune: -------------------------------------------------------------------------------- 1 | (ocamlyacc ldap_dnparser ldap_filterparser) 2 | (ocamllex ldap_schemalexer ldap_urllexer ldap_filterlexer ldap_dnlexer) 3 | 4 | (library 5 | (name ldap) 6 | (public_name ldap) 7 | (wrapped false) 8 | (modules_without_implementation ldap_urlparser) 9 | (libraries str camlp-streams re ssl)) 10 | -------------------------------------------------------------------------------- /src/ldap/lber.mli: -------------------------------------------------------------------------------- 1 | (* This library implements the subset of the basic encoding rules 2 | necessary to implement the ldap protocol. See ITU-T X.680 and X.690 3 | for a description of ASN.1, and the basic encoding rules. 4 | 5 | Copyright (C) 2004 Eric Stokes, Matthew Backes, and The California 6 | State University at Northridge 7 | 8 | This library is free software; you can redistribute it and/or 9 | modify it under the terms of the GNU Lesser General Public 10 | License as published by the Free Software Foundation; either 11 | version 2.1 of the License, or (at your option) any later version. 12 | 13 | This library is distributed in the hope that it will be useful, 14 | but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 16 | Lesser General Public License for more details. 17 | 18 | You should have received a copy of the GNU Lesser General Public 19 | License along with this library; if not, write to the Free Software 20 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 21 | USA 22 | *) 23 | 24 | (** This library implements the subset of ber *) 25 | 26 | exception Decoding_error of string 27 | exception Encoding_error of string 28 | 29 | type readbyte_error = End_of_stream 30 | | Transport_error 31 | | Peek_error 32 | | Request_too_large 33 | | Not_implemented 34 | exception Readbyte_error of readbyte_error 35 | 36 | type readbyte = ?peek:bool -> int -> string 37 | type writebyte = char -> unit 38 | type ber_class = Universal | Application | Context_specific | Private 39 | type ber_length = Definite of int | Indefinite 40 | 41 | type ber_val_header = { 42 | ber_class : ber_class; 43 | ber_primitive : bool; 44 | ber_tag : int; 45 | ber_length : ber_length; 46 | } 47 | 48 | (** return a readbyte function for a string, currently not implemented *) 49 | val readbyte_of_string : string -> readbyte 50 | 51 | (** return a readbyte implementation which uses another readbyte, but 52 | allows setting a read boundry. Useful for constructing views of the 53 | octet stream which end at the end of a ber structure. This is 54 | essential for reading certian structures because length is only 55 | encoded in the toplevel in order to save space. Currently only 56 | implemented for definite lengths. 57 | 58 | @raise Readbyte_error in the event of a an io error, or the end of file *) 59 | val readbyte_of_ber_element : ber_length -> readbyte -> readbyte 60 | 61 | (** a readbyte implementation which reads from an FD. It implements a 62 | peek buffer, so it can garentee that it will work with 63 | rb_of_ber_element, even with blocking fds. 64 | 65 | @raise Readbyte_error in the event of a an io error, or the end of file *) 66 | val readbyte_of_fd: Unix.file_descr -> readbyte 67 | 68 | (** a readbyte implementation which reads from an SSL socket. It is 69 | otherwise the same as readbyte_of_fd. 70 | 71 | @raise Readbyte_error in the event of a an io error, or the end of file *) 72 | val readbyte_of_ssl: Ssl.socket -> readbyte 73 | 74 | (** decoding and encoding of the ber header *) 75 | val decode_ber_header : ?peek:bool -> readbyte -> ber_val_header 76 | val encode_ber_header : ber_val_header -> string 77 | 78 | (** reads the contents octets *) 79 | val read_contents : ?peek:bool -> readbyte -> ber_length -> string 80 | 81 | (** 82 | ENCODING and DECODING Functions 83 | 84 | Explanation of optional arguments: 85 | The optional arguments are there to deal with a number of 86 | situations, cls, and tag are for context specific or application 87 | situations where it is expected that the value will not be marked 88 | with the class and tag defined in X.680. Contents is there for 89 | akward situations which arise because of the choice 90 | structure. Normally the decode functions will always read the header 91 | for you, however with the choice structure this is impossible. In 92 | this case you should read the header manually, determine which 93 | decode function to call, unpack the contents with read_contents, and 94 | send them in the contents optional. If contents is not None, then 95 | readbyte will never be called, and no attempt will be made to read 96 | the header or length. *) 97 | 98 | (** Encoding/Decoding of the boolean primative ASN.1 type. Encode 99 | function encodes a valid ber type, including the header and length 100 | octets. *) 101 | val decode_ber_bool : ?peek:bool -> ?cls:ber_class -> ?tag:int -> 102 | ?contents:string option -> readbyte -> bool 103 | val encode_ber_bool : ?cls:ber_class -> ?tag:int -> bool -> string 104 | 105 | (** Encoding/Decoding of the integer primative ASN.1 type. Note, in 106 | this library, integers are represented as 32 bit values. In ASN.1 107 | there is no practical limit to the size of an integer, later on, 108 | this library may provide an encoder/decoder to Int64, and Bigints, 109 | however for now, this will have to do. Encode function encodes a 110 | valid ber type, including the header and length octets *) 111 | val decode_ber_int32 : ?peek:bool -> ?cls:ber_class -> ?tag:int -> 112 | ?contents:string option -> readbyte -> int32 113 | val encode_ber_int32 : ?cls:ber_class -> ?tag:int -> int32 -> string 114 | 115 | (** Encoding/Decoding of enum primative ASN.1 type. Enums are simply 116 | integers, the same drawbacks apply as for decode_ber_int32. Encode 117 | function encodes a valid ber type, including the header and length 118 | octets *) 119 | val decode_ber_enum : ?peek:bool -> ?cls:ber_class -> ?tag:int -> 120 | ?contents:string option -> readbyte -> int32 121 | val encode_ber_enum : ?cls:ber_class -> ?tag:int -> int32 -> string 122 | 123 | (** Encoding/Decoding of octetstring ASN.1 types. The Nested or 124 | "segmented" version of the octetstring encoding described in X.690 125 | is not yet supported. Encode function encodes a valid ber type, 126 | including the header and length octets *) 127 | val decode_ber_octetstring : ?peek:bool -> ?cls:ber_class -> ?tag:int -> 128 | ?contents:string option -> readbyte -> string 129 | val encode_ber_octetstring : ?cls:ber_class -> ?tag:int -> string -> string 130 | 131 | (** Encoding/Decoding of Null ASN.1 type. Almost useful as an 132 | assertion-type operation *) 133 | val decode_ber_null : ?peek: bool -> ?cls:ber_class -> ?tag:int -> 134 | ?contents:string option -> readbyte -> unit 135 | val encode_ber_null : ?cls:ber_class -> ?tag:int -> unit -> string 136 | 137 | (** this function is for encoding lists of bervals, a common case. 138 | you pass it a list of things to encode, and an encoding function, and it 139 | will apply the encoding function to each element in the list, storing the 140 | resulting encoding in a buffer (which you may either pass in or not) *) 141 | val encode_berval_list : ?buf:Buffer.t -> ('a -> string) -> 'a list -> string 142 | 143 | (** this is the reverse of the above, it takes a readbyte structure, and 144 | returns a list of decoded elements, processed according to the decoder 145 | function you pass in. Note, that you MUST pass a readbyte structure built 146 | with readbyte_of_string, OR, your reabyte function must raise Stream.Failure 147 | when you reach the end of input. Otherwise this function will explode. That said, 148 | it is usually not practical to pass anything but a readbyte created by 149 | readbyte_of_string so this should not be a huge problem. *) 150 | val decode_berval_list : ?lst:'a list -> (readbyte -> 'a) -> readbyte -> 'a list 151 | -------------------------------------------------------------------------------- /src/ldap/ldap_dn.ml: -------------------------------------------------------------------------------- 1 | (* Utility functions for operating on dns 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University 4 | at Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | open Ldap_types 23 | open Ldap_dnlexer 24 | open Printf 25 | 26 | exception Invalid_dn of int * string 27 | 28 | let of_string dn_string = 29 | let lexbuf = Lexing.from_string dn_string in 30 | try Ldap_dnparser.dn lexdn lexbuf 31 | with 32 | Parsing.Parse_error -> raise (Invalid_dn (lexbuf.Lexing.lex_curr_pos, "parse error")) 33 | | Failure msg -> raise (Invalid_dn (lexbuf.Lexing.lex_curr_pos, msg)) 34 | 35 | let hexpair_of_char c = 36 | let hexify i = 37 | match i with 38 | 0 -> '0' 39 | | 1 -> '1' 40 | | 2 -> '2' 41 | | 3 -> '3' 42 | | 4 -> '4' 43 | | 5 -> '5' 44 | | 6 -> '6' 45 | | 7 -> '7' 46 | | 8 -> '8' 47 | | 9 -> '9' 48 | | 10 -> 'a' 49 | | 11 -> 'b' 50 | | 12 -> 'c' 51 | | 13 -> 'd' 52 | | 14 -> 'e' 53 | | 15 -> 'f' 54 | | n -> raise (Invalid_argument ("invalid hex digit: " ^ (string_of_int n))) 55 | in 56 | let i = int_of_char c in 57 | let buf = Bytes.create 2 in 58 | Bytes.set buf 0 (hexify (i lsr 4)); 59 | Bytes.set buf 1 (hexify (i land 0b0000_1111)); 60 | Bytes.to_string buf 61 | 62 | let escape_value valu = 63 | let strm = Stream.of_string valu in 64 | let buf = Buffer.create ((String.length valu) + 10) in 65 | let rec escape strm buf = 66 | try 67 | match Stream.next strm with 68 | (',' | '=' | '+' | '<' | '>' | '#' | ';' | '\\' | '"') as c -> 69 | Buffer.add_char buf '\\'; 70 | Buffer.add_char buf c; 71 | escape strm buf 72 | | ' ' -> 73 | if Stream.peek strm = None then begin 74 | Buffer.add_string buf "\\ "; 75 | escape strm buf 76 | end 77 | else begin 78 | Buffer.add_char buf ' '; 79 | escape strm buf 80 | end 81 | | c -> 82 | if (int_of_char c) < (int_of_char ' ') || 83 | (int_of_char c) > (int_of_char '~') 84 | then begin 85 | Buffer.add_string buf ("\\" ^ (hexpair_of_char c)); 86 | escape strm buf 87 | end 88 | else begin 89 | Buffer.add_char buf c;escape strm buf 90 | end 91 | with Stream.Failure -> Buffer.contents buf 92 | in 93 | match Stream.peek strm with 94 | Some ' ' -> 95 | Buffer.add_string buf "\\ "; 96 | Stream.junk strm; 97 | escape strm buf 98 | | Some _c -> escape strm buf 99 | | None -> "" 100 | 101 | let to_string dn = 102 | let dn_to_strcomponents dn = 103 | List.map 104 | (fun {attr_type=attr;attr_vals=vals} -> 105 | let rec string_values s attr vals = 106 | match vals with 107 | valu :: [] -> sprintf "%s%s=%s" s attr (escape_value valu) 108 | | valu :: tl -> 109 | string_values 110 | (sprintf "%s%s=%s+" 111 | s attr (escape_value valu)) 112 | attr tl 113 | | [] -> s 114 | in 115 | if List.length vals = 0 then 116 | raise 117 | (Invalid_dn 118 | (0, "invalid dn structure. no attribute " ^ 119 | "value specified for attribute: " ^ attr)) 120 | else 121 | string_values "" attr vals) 122 | dn 123 | in 124 | let rec components_to_dn s comps = 125 | match comps with 126 | comp :: [] -> sprintf "%s%s" s comp 127 | | comp :: tl -> components_to_dn (sprintf "%s%s," s comp) tl 128 | | [] -> s 129 | in 130 | components_to_dn "" (dn_to_strcomponents dn) 131 | 132 | let canonical_dn dn = String.lowercase_ascii (to_string (of_string dn)) 133 | -------------------------------------------------------------------------------- /src/ldap/ldap_dn.mli: -------------------------------------------------------------------------------- 1 | (* Utility functions for operating on dns 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University 4 | at Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | (** operations on ldap dns *) 23 | 24 | (** raised when something goes wrong with conversion to or from a 25 | string. The integer argument is the charachter which the lexer was 26 | looking at then the failure ocurred. In the case of to_string the 27 | integer argument will always be zero. *) 28 | exception Invalid_dn of int * string 29 | 30 | (** Given a string representation of a dn, return a structured 31 | representation. unescapes any escape sequences present. *) 32 | val of_string : string -> Ldap_types.dn 33 | 34 | (** Given a structural representation of a dn, return a string 35 | representation. Performs all the necessary escaping to correctly 36 | represent any structured representation. *) 37 | val to_string : Ldap_types.dn -> string 38 | 39 | (** Escape a string which you intend to be part of a VALUE in the 40 | dn. Do not use on the whole dn, just an attribute value. It is NOT 41 | necessary to use this if you intend to call to_string on your 42 | dn. It will be done for you as part of the conversion 43 | process. This function is exposed for the case where you find it 44 | easier to manipulate the dn via a regular expression, or other 45 | string based means, and you find it necessary to escape values. *) 46 | val escape_value : string -> string 47 | 48 | (** returns the canonical dn. A simple string compare can tell you 49 | accurately whether two canonical dns are equal or not. *) 50 | val canonical_dn : string -> string 51 | -------------------------------------------------------------------------------- /src/ldap/ldap_dnlexer.mll: -------------------------------------------------------------------------------- 1 | (* lexer for rfc2252 format schemas 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University 4 | at Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | { 22 | open Ldap_dnparser 23 | 24 | [@@@ocaml.warning "-26"] 25 | } 26 | 27 | let whsp = [ '\t' ' ' ]* 28 | let alpha = [ 'a' - 'z' 'A' - 'Z' ] 29 | let digit = [ '0' - '9' ] 30 | let hexchar = [ '0' - '9' 'A' - 'F' 'a' - 'f' ] 31 | let keychar = [ 'a' - 'z' 'A' - 'Z' '0' - '9' '-' ] 32 | let attributetype = (alpha keychar*) as attribute 33 | let oid = [ '0' - '9' '.' ]+ 34 | let special = [ ',' '=' '+' '<' '>' '#' ';' ] 35 | let quotechar = [^ '\\' '"' ] 36 | let hexpair = hexchar hexchar 37 | let hexstring = hexpair + 38 | let stringchar = [^ '\\' '"' ] # special 39 | let pair = '\\' (special | ' ' | '\\' | '"' | hexpair) 40 | (* 41 | According to the rfc this is the set of possible values for an attribute value 42 | We don't implement it directly, instead we split each one into a seperate token 43 | to make unescaping easier 44 | 45 | string = (stringchar | pair)* | '#' hexstring | '"' (quotechar | pair)* '"' 46 | *) 47 | 48 | rule lexdn = parse 49 | whsp '=' whsp {Equals} 50 | | whsp '+' whsp {Plus} 51 | | whsp (',' | ';') whsp {Comma} 52 | | oid {Oid (Lexing.lexeme lexbuf)} 53 | | attributetype {AttributeType (Lexing.lexeme lexbuf)} 54 | | stringchar* ([^ ' '] # special) {String (Lexing.lexeme lexbuf)} 55 | | (stringchar | pair)* (pair | ([^ ' '] # special)) {StringWithPair (Lexing.lexeme lexbuf)} 56 | | '#' hexstring {HexString (Lexing.lexeme lexbuf)} 57 | | '"' (quotechar | pair)* '"' {QuoteString (Lexing.lexeme lexbuf)} 58 | | eof {End_of_input} 59 | -------------------------------------------------------------------------------- /src/ldap/ldap_dnparser.mly: -------------------------------------------------------------------------------- 1 | /* a parser for rfc2254 ldap filters 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University 4 | at Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | */ 20 | 21 | %{ 22 | open Ldap_types 23 | 24 | let unhex hex = 25 | match hex with 26 | '0' -> 0 27 | | '1' -> 1 28 | | '2' -> 2 29 | | '3' -> 3 30 | | '4' -> 4 31 | | '5' -> 5 32 | | '6' -> 6 33 | | '7' -> 7 34 | | '8' -> 8 35 | | '9' -> 9 36 | | 'a' -> 10 37 | | 'b' -> 11 38 | | 'c' -> 12 39 | | 'd' -> 13 40 | | 'e' -> 14 41 | | 'f' -> 15 42 | | _ -> failwith "invalid hex digit" 43 | 44 | let unescape_hexpair hex1 hex2 = 45 | (char_of_int 46 | ((lor) 47 | ((lsl) (unhex hex1) 4) 48 | (unhex hex2))) 49 | 50 | let unescape_stringwithpair s = 51 | let strm = Stream.of_string s in 52 | let buf = Buffer.create (String.length s) in 53 | let rec unescape strm buf = 54 | try 55 | match Stream.next strm with 56 | '\\' -> 57 | (match Stream.next strm with 58 | (',' | '=' | '+' | '<' | '>' | '#' | ';' | '\\' | '"' | ' ') as c -> 59 | Buffer.add_char buf c; 60 | unescape strm buf 61 | | ('0' .. '9' | 'A' .. 'F' | 'a' .. 'f') as hex1 -> 62 | let hex2 = Stream.next strm in 63 | Buffer.add_char buf (unescape_hexpair hex1 hex2); 64 | unescape strm buf 65 | | _ -> failwith "invalid escape sequence") 66 | | c -> Buffer.add_char buf c;unescape strm buf 67 | with Stream.Failure -> Buffer.contents buf 68 | in 69 | unescape strm buf 70 | 71 | let unescape_quotestring s = 72 | unescape_stringwithpair (String.sub s 1 ((String.length s) - 2)) 73 | 74 | let unescape_hexstring s = 75 | let strm = Stream.of_string s in 76 | let buf = Buffer.create (String.length s) in 77 | let rec unescape strm buf = 78 | try 79 | let hex1 = Stream.next strm in 80 | let hex2 = Stream.next strm in 81 | Buffer.add_char buf (unescape_hexpair hex1 hex2); 82 | unescape strm buf 83 | with Stream.Failure -> Buffer.contents buf 84 | in 85 | match Stream.next strm with 86 | '#' -> unescape strm buf 87 | | _ -> failwith "invalid hexstring" 88 | %} 89 | 90 | %token Equals Plus Comma End_of_input 91 | %token AttributeType 92 | %token Oid 93 | %token String 94 | %token StringWithPair 95 | %token HexString 96 | %token QuoteString 97 | %type dn 98 | %start dn 99 | %% 100 | 101 | attrval: 102 | AttributeType {$1} 103 | | Oid {$1} 104 | | String {$1} 105 | | StringWithPair {unescape_stringwithpair $1} 106 | | HexString {unescape_hexstring $1} 107 | | QuoteString {unescape_quotestring $1} 108 | ; 109 | 110 | attrname: 111 | AttributeType {$1} 112 | | Oid {$1} 113 | ; 114 | 115 | dn: 116 | attrname Equals attrval Plus dn 117 | {match $5 with 118 | {attr_type=attr_name;attr_vals=vals} :: tl -> 119 | if $1 = attr_name then 120 | {attr_type=attr_name;attr_vals=($3 :: vals)} :: tl 121 | else failwith ("invalid multivalued rdn, expected: " ^ $1) 122 | | [] -> [{attr_type=$1;attr_vals=[$3]}]} 123 | | attrname Equals attrval Comma dn {{attr_type=$1;attr_vals=[$3]} :: $5} 124 | | attrname Equals attrval End_of_input {[{attr_type=$1;attr_vals=[$3]}]} 125 | | End_of_input {[]} 126 | ; 127 | -------------------------------------------------------------------------------- /src/ldap/ldap_error.ml: -------------------------------------------------------------------------------- 1 | open Ldap_types 2 | 3 | let err2string code = 4 | match code with 5 | `SUCCESS -> "`SUCCESS" 6 | | `OPERATIONS_ERROR -> "`OPERATIONS_ERROR" 7 | | `PROTOCOL_ERROR -> "`PROTOCOL_ERROR" 8 | | `TIMELIMIT_EXCEEDED -> "`TIMELIMIT_EXCEEDED" 9 | | `SIZELIMIT_EXCEEDED -> "`SIZELIMIT_EXCEEDED" 10 | | `COMPARE_FALSE -> "`COMPARE_FALSE" 11 | | `COMPARE_TRUE -> "`COMPARE_TRUE" 12 | | `AUTH_METHOD_NOT_SUPPORTED -> "`AUTH_METHOD_NOT_SUPPORTED" 13 | | `STRONG_AUTH_REQUIRED -> "`STRONG_AUTH_REQUIRED" 14 | | `REFERRAL -> "`REFERRAL" 15 | | `ADMINLIMIT_EXCEEDED -> "`ADMINLIMIT_EXCEEDED" 16 | | `UNAVAILABLE_CRITICAL_EXTENSION -> "`UNAVAILABLE_CRITICAL_EXTENSION" 17 | | `CONFIDENTIALITY_REQUIRED -> "`CONFIDENTIALITY_REQUIRED" 18 | | `SASL_BIND_IN_PROGRESS -> "`SASL_BIND_IN_PROGRESS" 19 | | `NO_SUCH_ATTRIBUTE -> "`NO_SUCH_ATTRIBUTE" 20 | | `UNDEFINED_TYPE -> "`UNDEFINED_TYPE" 21 | | `INAPPROPRIATE_MATCHING -> "`INAPPROPRIATE_MATCHING" 22 | | `CONSTRAINT_VIOLATION -> "`CONSTRAINT_VIOLATION" 23 | | `TYPE_OR_VALUE_EXISTS -> "`TYPE_OR_VALUE_EXISTS" 24 | | `INVALID_SYNTAX -> "`INVALID_SYNTAX" 25 | | `NO_SUCH_OBJECT -> "`NO_SUCH_OBJECT" 26 | | `ALIAS_PROBLEM -> "`ALIAS_PROBLEM" 27 | | `INVALID_DN_SYNTAX -> "`INVALID_DN_SYNTAX" 28 | | `ALIAS_DEREF_PROBLEM -> "`ALIAS_DEREF_PROBLEM" 29 | | `INAPPROPRIATE_AUTH -> "`INAPPROPRIATE_AUTH" 30 | | `INVALID_CREDENTIALS -> "`INVALID_CREDENTIALS" 31 | | `INSUFFICIENT_ACCESS -> "`INSUFFICIENT_ACCESS" 32 | | `BUSY -> "`BUSY" 33 | | `UNAVAILABLE -> "`UNAVAILABLE" 34 | | `UNWILLING_TO_PERFORM -> "`UNWILLING_TO_PERFORM" 35 | | `LOOP_DETECT -> "`LOOP_DETECT" 36 | | `NAMING_VIOLATION -> "`NAMING_VIOLATION" 37 | | `OBJECT_CLASS_VIOLATION -> "`OBJECT_CLASS_VIOLATION" 38 | | `NOT_ALLOWED_ON_NONLEAF -> "`NOT_ALLOWED_ON_NONLEAF" 39 | | `NOT_ALLOWED_ON_RDN -> "`NOT_ALLOWED_ON_RDN" 40 | | `ALREADY_EXISTS -> "`ALREADY_EXISTS" 41 | | `NO_OBJECT_CLASS_MODS -> "`NO_OBJECT_CLASS_MODS" 42 | | `LOCAL_ERROR -> "`LOCAL_ERROR" 43 | | `SERVER_DOWN -> "`SERVER_DOWN" 44 | | `OTHER -> "`OTHER" 45 | | _ -> raise (LDAP_Decoder "invalid error code") 46 | 47 | let ldap_strerror msg ldaperror = 48 | match ldaperror with 49 | LDAP_Failure (code, error, {ext_matched_dn=mdn;ext_referral=refs}) -> 50 | "LDAP_Failure (" ^ 51 | (String.concat ", " 52 | [(err2string code); 53 | "\"" ^ (String.concat ": " 54 | (List.filter 55 | (function "" -> false | _ -> true) 56 | [error; msg])) ^ "\""; 57 | "{ext_matched_dn = " ^ "\"" ^ mdn ^ "\"; ext_referral = " ^ 58 | (match refs with 59 | Some lst -> "[" ^ (String.concat "; " lst) ^ "]" 60 | | None -> "None") ^ "})"]) 61 | | _ -> failwith "not an ldap error" 62 | 63 | let ldap_perror error ldaperror = 64 | prerr_endline (ldap_strerror error ldaperror) 65 | -------------------------------------------------------------------------------- /src/ldap/ldap_error.mli: -------------------------------------------------------------------------------- 1 | (** given an ldap error code return a string describing it *) 2 | val err2string : 3 | [> `ADMINLIMIT_EXCEEDED 4 | | `ALIAS_DEREF_PROBLEM 5 | | `ALIAS_PROBLEM 6 | | `ALREADY_EXISTS 7 | | `AUTH_METHOD_NOT_SUPPORTED 8 | | `BUSY 9 | | `COMPARE_FALSE 10 | | `COMPARE_TRUE 11 | | `CONFIDENTIALITY_REQUIRED 12 | | `CONSTRAINT_VIOLATION 13 | | `INAPPROPRIATE_AUTH 14 | | `INAPPROPRIATE_MATCHING 15 | | `INSUFFICIENT_ACCESS 16 | | `INVALID_CREDENTIALS 17 | | `INVALID_DN_SYNTAX 18 | | `INVALID_SYNTAX 19 | | `LOCAL_ERROR 20 | | `LOOP_DETECT 21 | | `NAMING_VIOLATION 22 | | `NOT_ALLOWED_ON_NONLEAF 23 | | `NOT_ALLOWED_ON_RDN 24 | | `NO_OBJECT_CLASS_MODS 25 | | `NO_SUCH_ATTRIBUTE 26 | | `NO_SUCH_OBJECT 27 | | `OBJECT_CLASS_VIOLATION 28 | | `OPERATIONS_ERROR 29 | | `OTHER 30 | | `PROTOCOL_ERROR 31 | | `REFERRAL 32 | | `SASL_BIND_IN_PROGRESS 33 | | `SERVER_DOWN 34 | | `SIZELIMIT_EXCEEDED 35 | | `STRONG_AUTH_REQUIRED 36 | | `SUCCESS 37 | | `TIMELIMIT_EXCEEDED 38 | | `TYPE_OR_VALUE_EXISTS 39 | | `UNAVAILABLE 40 | | `UNAVAILABLE_CRITICAL_EXTENSION 41 | | `UNDEFINED_TYPE 42 | | `UNWILLING_TO_PERFORM ] -> 43 | string 44 | 45 | (** return a string with a human readable description of an LDAP_Failure exception *) 46 | val ldap_strerror : string -> exn -> string 47 | 48 | (** print to stderr a string with a human readable description of an LDAP_Failure exception *) 49 | val ldap_perror : string -> exn -> unit 50 | -------------------------------------------------------------------------------- /src/ldap/ldap_filter.ml: -------------------------------------------------------------------------------- 1 | (* Ldap filter parser driver. 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University at 4 | Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | open Ldap_types 22 | open Ldap_filterparser 23 | open Ldap_filterlexer 24 | open Str 25 | 26 | exception Invalid_filter of int * string 27 | 28 | (* escape a string to be put in a string representation of a search 29 | filter *) 30 | let star_rex = Re.compile (Re.char '*') 31 | let lparen_rex = Re.compile (Re.char '(') 32 | let rparen_rex = Re.compile (Re.char ')') 33 | let backslash_rex = Re.compile (Re.char '\\') 34 | let null_rex = Re.compile (Re.char '\000') 35 | let escape_filterstring s = 36 | (Re.replace_string star_rex ~by:"\\2a" 37 | (Re.replace_string lparen_rex ~by:"\\28" 38 | (Re.replace_string rparen_rex ~by:"\\29" 39 | (Re.replace_string null_rex ~by:"\\00" 40 | (Re.replace_string backslash_rex ~by:"\\5c" s))))) 41 | 42 | let of_string f = 43 | let lxbuf = Lexing.from_string f in 44 | try filter_and_eof lexfilter lxbuf 45 | with 46 | Parsing.Parse_error -> 47 | raise (Invalid_filter (lxbuf.Lexing.lex_curr_pos, "parse error")) 48 | | Failure msg -> 49 | raise (Invalid_filter (lxbuf.Lexing.lex_curr_pos, msg)) 50 | 51 | let double_star_rex = regexp "\\*\\*" 52 | let to_string (f:filter) = 53 | let rec to_string' buf f = 54 | match f with 55 | `And lst -> 56 | Buffer.add_string buf "(&"; 57 | List.iter 58 | (fun f_component -> to_string' buf f_component) 59 | lst; 60 | Buffer.add_char buf ')' 61 | | `Or lst -> 62 | Buffer.add_string buf "(|"; 63 | List.iter 64 | (fun f_component -> to_string' buf f_component) 65 | lst; 66 | Buffer.add_char buf ')' 67 | | `Not f_component -> 68 | Buffer.add_string buf "(!"; 69 | to_string' buf f_component; 70 | Buffer.add_char buf ')' 71 | | `EqualityMatch {attributeDesc=attrname;assertionValue=valu} -> 72 | Buffer.add_char buf '('; 73 | Buffer.add_string buf attrname; 74 | Buffer.add_char buf '='; 75 | Buffer.add_string buf (escape_filterstring valu); 76 | Buffer.add_char buf ')' 77 | | `Substrings {attrtype=attrname; 78 | substrings={substr_initial=initial; 79 | substr_any=any; 80 | substr_final=final}} -> 81 | Buffer.add_char buf '('; 82 | Buffer.add_string buf attrname; 83 | Buffer.add_char buf '='; 84 | Buffer.add_string buf 85 | (global_replace double_star_rex "*" 86 | ((match initial with 87 | [s] -> (escape_filterstring s) ^ "*" 88 | | [] -> "" 89 | | _ -> 90 | raise 91 | (Invalid_filter 92 | (0, "multiple substring components cannot be represented"))) ^ 93 | (match any with 94 | [] -> "" 95 | | lst -> 96 | List.fold_left 97 | (fun f s -> f ^ "*" ^ (escape_filterstring s) ^ "*") 98 | "" lst) ^ 99 | (match final with 100 | [s] -> "*" ^ (escape_filterstring s) 101 | | [] -> "" 102 | | _ -> 103 | raise 104 | (Invalid_filter 105 | (0, "multiple substring components cannot be represented"))))); 106 | Buffer.add_char buf ')'; 107 | | `GreaterOrEqual {attributeDesc=attrname;assertionValue=valu} -> 108 | Buffer.add_char buf '('; 109 | Buffer.add_string buf attrname; 110 | Buffer.add_string buf ">="; 111 | Buffer.add_string buf (escape_filterstring valu); 112 | Buffer.add_char buf ')' 113 | | `LessOrEqual {attributeDesc=attrname;assertionValue=valu} -> 114 | Buffer.add_char buf '('; 115 | Buffer.add_string buf attrname; 116 | Buffer.add_string buf "<="; 117 | Buffer.add_string buf (escape_filterstring valu); 118 | Buffer.add_char buf ')' 119 | | `ApproxMatch {attributeDesc=attrname;assertionValue=valu} -> 120 | Buffer.add_char buf '('; 121 | Buffer.add_string buf attrname; 122 | Buffer.add_string buf "~="; 123 | Buffer.add_string buf (escape_filterstring valu); 124 | Buffer.add_char buf ')' 125 | | `Present attr -> 126 | Buffer.add_char buf '('; 127 | Buffer.add_string buf attr; 128 | Buffer.add_string buf "=*"; 129 | Buffer.add_char buf ')' 130 | | `ExtensibleMatch {matchingRule=rul;ruletype=rtype; 131 | matchValue=matchval;dnAttributes=dnattrs} -> 132 | Buffer.add_char buf '('; 133 | (match rtype with 134 | Some attrname -> 135 | Buffer.add_string buf attrname; 136 | (if dnattrs then 137 | Buffer.add_string buf ":dn"); 138 | (match rul with 139 | Some r -> 140 | Buffer.add_char buf ':'; 141 | Buffer.add_string buf r 142 | | None -> ()); 143 | Buffer.add_string buf ":="; 144 | Buffer.add_string buf (escape_filterstring matchval) 145 | | None -> 146 | ((if dnattrs then 147 | Buffer.add_string buf ":dn"); 148 | (match rul with 149 | Some r -> 150 | Buffer.add_char buf ':'; 151 | Buffer.add_string buf r; 152 | Buffer.add_string buf ":="; 153 | Buffer.add_string buf (escape_filterstring matchval) 154 | | None -> 155 | raise 156 | (Invalid_filter 157 | (0, "matchingRule is required if type is unspecified"))))); 158 | Buffer.add_char buf ')' 159 | in 160 | let buf = Buffer.create 100 in 161 | to_string' buf f; 162 | Buffer.contents buf 163 | -------------------------------------------------------------------------------- /src/ldap/ldap_filter.mli: -------------------------------------------------------------------------------- 1 | (** operations on ldap search filters 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University 4 | at Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | (** raised when something goes wrong in to_string or of_string. The 23 | integer argument is, in the case of of_string, the position in the 24 | string at which the error occurred. It has no meaning in to_string, 25 | and may take any value. *) 26 | exception Invalid_filter of int * string 27 | 28 | (** turn the string representation into the internal representation 29 | defined in ldap_types.ml. This representation is suitable for 30 | sending on the wire, and can also have all sorts of operations 31 | performed on it. play around with it in the toplevel to get a feel 32 | for it *) 33 | val of_string : string -> Ldap_types.filter 34 | 35 | (** turn an internal representaion of a filter into a string 36 | representaion compliant with rfc2254*) 37 | val to_string : Ldap_types.filter -> string 38 | 39 | (** escape a string which is intended to be the VALUE of an attribute 40 | assertion in a filter. Do not use this on a whole filter, it will 41 | destroy all the meta chars. Use it only on the VALUE part of the 42 | assertion. It is NOT necessary to use this function if you intend 43 | to call to_string, escaping will be done for you in that 44 | case. This function is exposed because you may want to manipulate 45 | a filter with a regular expression, or other string means, and you 46 | may find it necessary to escape values manually in that case. *) 47 | val escape_filterstring : string -> string 48 | -------------------------------------------------------------------------------- /src/ldap/ldap_filterlexer.mll: -------------------------------------------------------------------------------- 1 | (* a lexer for rfc2254 human readable search filters 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University 4 | at Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | { 22 | open Ldap_filterparser 23 | open Ldap_types 24 | 25 | let star = Re.compile (Re.char '*') 26 | let substr_proto = {substr_initial=[];substr_any=[];substr_final=[]} 27 | 28 | let to_substr v = 29 | let substrs = Re.split star v in 30 | (if v.[0] = '*' then 31 | (* pcre puts the empty string on the front of the list if the 32 | delimeter is the first char in the string *) 33 | let substrs = List.tl substrs in 34 | if v.[(String.length v) - 1] = '*' then 35 | {substr_proto with substr_any=substrs} 36 | else 37 | {substr_initial=[]; 38 | substr_final=[(List.hd (List.rev substrs))]; 39 | substr_any=(try List.rev (List.tl (List.rev substrs)) with _ -> [])} 40 | else 41 | if v.[(String.length v) - 1] = '*' then 42 | {substr_initial=(try [List.hd substrs] with _ -> []); 43 | substr_any=(try List.tl substrs with _ -> []); 44 | substr_final=[]} 45 | else 46 | {substr_initial=(try [List.hd substrs] with _ -> []); 47 | substr_final=(try [List.hd (List.rev substrs)] with _ -> []); 48 | substr_any=(try (List.rev 49 | (List.tl 50 | (List.rev (List.tl substrs)))) 51 | with _ -> [])}) 52 | } 53 | 54 | let lparen = '(' 55 | let rparen = ')' 56 | let andop = '&' 57 | let orop = '|' 58 | let notop = '!' 59 | let equalop = '=' 60 | let colonequalop = ":=" 61 | let approxop = '~' equalop 62 | let gteop = '>' equalop 63 | let lteop = '<' equalop 64 | let star = '*' 65 | let attr = [ '0' - '9' 'a' - 'z' 'A' - 'Z' ] + 66 | let hexdigit = [ '0' - '9' 'a' - 'f' 'A' - 'F' ] 67 | let escape = '\\' hexdigit hexdigit 68 | let value = escape | ( [ '\t' ' ' '!' - '~' ] # [ '(' ')' '&' '|' '*' ] ) 69 | let values = value + 70 | let colon = ':' 71 | let oid = ( [ '0' - '9' '.' ] + as oid) 72 | let dn = colon "dn" 73 | let matchingrule = colon oid 74 | let extendedmatchattr = (attr as a) matchingrule 75 | let extendeddnattr = (attr as a) dn (matchingrule)? 76 | let substrany = star (values star) + 77 | let substr = 78 | substrany 79 | | values substrany 80 | | substrany values 81 | | values substrany values 82 | | values star 83 | | star values 84 | | values star values 85 | 86 | rule lexfilter = parse 87 | lparen {LPAREN} 88 | | rparen {RPAREN} 89 | | andop {AND} 90 | | orop {OR} 91 | | notop {NOT} 92 | | (attr as a) equalop (substr as v) {ATTREQUALSUB (a, to_substr v)} 93 | | (attr as a) equalop star {ATTRPRESENT a} 94 | | (attr as a) equalop (values as v) {ATTREQUAL (a, v)} 95 | | (attr as a) gteop (values as v) {ATTRGTE (a, v)} 96 | | (attr as a) lteop (values as v) {ATTRLTE (a, v)} 97 | | (attr as a) approxop (values as v) {ATTRAPPROX (a, v)} 98 | | extendedmatchattr colonequalop (values as v) {ATTREXTENDEDMATCH (a, oid, v)} 99 | | extendeddnattr colonequalop (values as v) {ATTREXTENDEDDN (a, oid, v)} 100 | | eof {EOF} 101 | -------------------------------------------------------------------------------- /src/ldap/ldap_filterparser.mly: -------------------------------------------------------------------------------- 1 | /* a parser for rfc2254 ldap filters 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University 4 | at Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | */ 20 | 21 | 22 | %{ 23 | open Ldap_types 24 | 25 | let star_escape_rex = Re.compile (Re.str "\\2a") 26 | let lparen_escape_rex = Re.compile (Re.str "\\28") 27 | let rparen_escape_rex = Re.compile (Re.str "\\29") 28 | let backslash_escape_rex = Re.compile (Re.str "\\5c") 29 | let null_escape_rex = Re.compile (Re.str "\\00") 30 | let unescape s = 31 | (Re.replace_string star_escape_rex ~by:"*" 32 | (Re.replace_string lparen_escape_rex ~by:"(" 33 | (Re.replace_string rparen_escape_rex ~by:")" 34 | (Re.replace_string null_escape_rex ~by:"\000" 35 | (Re.replace_string backslash_escape_rex ~by:"\\" s))))) 36 | %} 37 | 38 | %token WHSP LPAREN RPAREN AND OR NOT EOF 39 | %token ATTREQUAL 40 | %token ATTREQUALSUB 41 | %token ATTRGTE 42 | %token ATTRLTE 43 | %token ATTRAPPROX 44 | %token ATTRPRESENT 45 | %token ATTREXTENDEDMATCH 46 | %token ATTREXTENDEDDN 47 | %start filter_and_eof 48 | %type filter_and_eof 49 | %% 50 | 51 | filterlist: 52 | filterlist filter {$2 :: $1} 53 | | filter {[$1]} 54 | ; 55 | 56 | filter: 57 | LPAREN AND filterlist RPAREN {`And $3} 58 | | LPAREN OR filterlist RPAREN {`Or $3} 59 | | LPAREN NOT filter RPAREN {`Not $3} 60 | | LPAREN filter RPAREN {$2} 61 | | ATTREQUALSUB {`Substrings {attrtype=(fst $1);substrings=(snd $1)}} 62 | | ATTREQUAL {`EqualityMatch {attributeDesc=(fst $1);assertionValue=(unescape (snd $1))}} 63 | | ATTRGTE {`GreaterOrEqual {attributeDesc=(fst $1);assertionValue=(unescape (snd $1))}} 64 | | ATTRLTE {`LessOrEqual {attributeDesc=(fst $1);assertionValue=(unescape (snd $1))}} 65 | | ATTRPRESENT {`Present $1} 66 | | ATTRAPPROX {`ApproxMatch {attributeDesc=(fst $1);assertionValue=(unescape (snd $1))}} 67 | | ATTREXTENDEDMATCH {let (a, oid, v) = $1 in 68 | `ExtensibleMatch 69 | {matchingRule=(Some (unescape oid)); 70 | ruletype=(Some (unescape a)); 71 | matchValue=(unescape v); 72 | dnAttributes=false}} 73 | | ATTREXTENDEDDN {let (a, oid, v) = $1 in 74 | `ExtensibleMatch 75 | {matchingRule=(match oid with 76 | Some s -> Some (unescape s) 77 | | None -> None); 78 | ruletype=(Some (unescape a)); 79 | matchValue=(unescape v); 80 | dnAttributes=true}} 81 | ; 82 | 83 | /* used to enforce EOF at the end of the filter */ 84 | filter_and_eof: 85 | filter EOF {$1} 86 | ; 87 | -------------------------------------------------------------------------------- /src/ldap/ldap_funclient.ml: -------------------------------------------------------------------------------- 1 | (* A functional client interface to ldap 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University 4 | at Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | open Ldap_types 22 | open Ldap_protocol 23 | open Lber 24 | open Unix 25 | open Sys 26 | 27 | type msgid = Int32.t 28 | 29 | type ld_socket = Ssl of Ssl.socket 30 | | Plain of file_descr 31 | 32 | type conn = { 33 | mutable rb: readbyte; 34 | mutable socket: ld_socket; (* communications channel to the ldap server *) 35 | mutable current_msgid: Int32.t; (* the largest message id allocated so far *) 36 | pending_messages: (int32, ldap_message Queue.t) Hashtbl.t; 37 | protocol_version: int; 38 | } 39 | 40 | type modattr = modify_optype * string * string list 41 | type result = search_result_entry list 42 | type entry = search_result_entry 43 | type authmethod = [ `SIMPLE | `SASL ] 44 | type search_result = [ `Entry of entry 45 | | `Referral of (string list) 46 | | `Success of (Ldap_types.ldap_controls option) ] 47 | type page_control = 48 | [ `Noctrl 49 | | `Initctrl of int 50 | | `Subctrl of (int * string) ] 51 | 52 | let ext_res = {ext_matched_dn=""; 53 | ext_referral=None} 54 | 55 | let _ = Ssl.init () 56 | 57 | (* limits us to Int32.max_int active async operations 58 | at any one time *) 59 | let find_free_msgid con = 60 | let msgid = con.current_msgid in 61 | (if msgid = Int32.max_int then 62 | con.current_msgid <- 0l 63 | else 64 | con.current_msgid <- Int32.succ con.current_msgid); 65 | msgid 66 | 67 | (* allocate a message id from the free message id pool *) 68 | let allocate_messageid con = 69 | let msgid = find_free_msgid con in 70 | Hashtbl.replace con.pending_messages msgid (Queue.create ()); 71 | msgid 72 | 73 | let free_messageid con msgid = 74 | try Hashtbl.remove con.pending_messages msgid 75 | with Not_found -> 76 | raise (LDAP_Failure (`LOCAL_ERROR, "free_messageid: invalid msgid", ext_res)) 77 | 78 | (* send an ldapmessage *) 79 | let send_message con msg = 80 | let write ld_socket buf off len = 81 | match ld_socket with 82 | Ssl s -> 83 | (try Ssl.write s buf off len 84 | with Ssl.Write_error _ -> raise (Unix_error (EPIPE, "Ssl.write", ""))) 85 | | Plain s -> Unix.write s buf off len 86 | in 87 | let e_msg = Ldap_protocol.encode_ldapmessage msg in 88 | let e_msg = Bytes.of_string e_msg in 89 | let len = Bytes.length e_msg in 90 | let written = ref 0 in 91 | try 92 | while !written < len 93 | do 94 | written := ((write con.socket e_msg 95 | !written (len - !written)) + 96 | !written) 97 | done 98 | with 99 | Unix_error (EBADF, _, _) 100 | | Unix_error (EPIPE, _, _) 101 | | Unix_error (ECONNRESET, _, _) 102 | | Unix_error (ECONNABORTED, _, _) 103 | | Sys_error _ -> 104 | (raise 105 | (LDAP_Failure 106 | (`SERVER_DOWN, 107 | "the connection object is invalid, data cannot be written", 108 | ext_res))) 109 | 110 | (* recieve an ldapmessage for a particular message id (messages for 111 | all other ids will be read and queued. They can be retreived later) *) 112 | let receive_message con msgid = 113 | let q_for_msgid con msgid = 114 | try Hashtbl.find con.pending_messages msgid 115 | with Not_found -> raise (LDAP_Failure (`LOCAL_ERROR, "invalid message id", ext_res)) 116 | in 117 | let rec read_message con msgid = 118 | let msg = decode_ldapmessage con.rb in 119 | if msg.messageID = msgid then msg 120 | else 121 | (let q = q_for_msgid con msg.messageID in 122 | Queue.add msg q; 123 | read_message con msgid) 124 | in 125 | let q = q_for_msgid con msgid in 126 | try 127 | if Queue.is_empty q then 128 | read_message con msgid 129 | else Queue.take q 130 | with 131 | Readbyte_error Transport_error -> 132 | raise (LDAP_Failure (`SERVER_DOWN, "read error", ext_res)) 133 | | Readbyte_error End_of_stream -> 134 | raise (LDAP_Failure (`LOCAL_ERROR, "bug in ldap decoder detected", ext_res)) 135 | 136 | exception Timeout 137 | 138 | let init ?(connect_timeout = 1) ?(version = 3) hosts = 139 | if ((version < 2) || (version > 3)) then 140 | raise (LDAP_Failure (`LOCAL_ERROR, "invalid protocol version", ext_res)) 141 | else 142 | let fd = 143 | let addrs = 144 | (List.flatten 145 | (List.map 146 | (fun (mech, host, port) -> 147 | try 148 | (List.rev_map 149 | (fun addr -> (mech, addr, port)) 150 | (Array.to_list ((gethostbyname host).h_addr_list))) 151 | with Not_found -> []) 152 | (List.map 153 | (fun host -> 154 | (match Ldap_url.of_string host with 155 | {url_mech=mech;url_host=(Some host);url_port=(Some port);_} -> 156 | (mech, host, int_of_string port) 157 | | {url_mech=mech;url_host=(Some host);url_port=None;_} -> 158 | (mech, host, 389) 159 | | _ -> raise 160 | (LDAP_Failure (`LOCAL_ERROR, "invalid ldap url", ext_res)))) 161 | hosts))) 162 | in 163 | let rec open_con addrs = 164 | let previous_signal = ref Signal_default in 165 | match addrs with 166 | (mech, addr, port) :: tl -> 167 | (try 168 | if mech = `PLAIN then 169 | let s = socket PF_INET SOCK_STREAM 0 in 170 | try 171 | previous_signal := 172 | signal sigalrm 173 | (Signal_handle (fun _ -> raise Timeout)); 174 | ignore (alarm connect_timeout); 175 | connect s (ADDR_INET (addr, port)); 176 | ignore (alarm 0); 177 | set_signal sigalrm !previous_signal; 178 | Plain s 179 | with exn -> close s;raise exn 180 | else 181 | (previous_signal := 182 | signal sigalrm 183 | (Signal_handle (fun _ -> raise Timeout)); 184 | ignore (alarm connect_timeout); 185 | let ssl = Ssl (Ssl.open_connection 186 | (Ssl.SSLv23 [@ocaml.alert "-deprecated"]) 187 | (ADDR_INET (addr, port))) 188 | in 189 | ignore (alarm 0); 190 | set_signal sigalrm !previous_signal; 191 | ssl) 192 | with 193 | Unix_error (ECONNREFUSED, _, _) 194 | | Unix_error (EHOSTDOWN, _, _) 195 | | Unix_error (EHOSTUNREACH, _, _) 196 | | Unix_error (ECONNRESET, _, _) 197 | | Unix_error (ECONNABORTED, _, _) 198 | | Ssl.Connection_error _ 199 | | Timeout -> 200 | ignore (alarm 0); 201 | set_signal sigalrm !previous_signal; 202 | open_con tl) 203 | | [] -> raise (LDAP_Failure (`SERVER_DOWN, "", ext_res)) 204 | in 205 | open_con addrs 206 | in 207 | {rb=(match fd with 208 | Ssl s -> Lber.readbyte_of_ssl s 209 | | Plain s -> Lber.readbyte_of_fd s); 210 | socket=fd; 211 | current_msgid=1l; 212 | pending_messages=(Hashtbl.create 3); 213 | protocol_version=version} 214 | 215 | (* sync auth_method types between the two files *) 216 | let bind_s ?(who = "") ?(cred = "") ?(auth_method = `SIMPLE) con = 217 | let _ = auth_method in (* TODO: usused?? *) 218 | let msgid = allocate_messageid con in 219 | (try 220 | send_message con 221 | {messageID=msgid; 222 | protocolOp=Bind_request 223 | {bind_version=con.protocol_version; 224 | bind_name=who; 225 | bind_authentication=(Simple cred)}; 226 | controls=None}; 227 | match receive_message con msgid with 228 | {protocolOp=Bind_response {bind_result={result_code=`SUCCESS;_};_};_} -> () 229 | | {protocolOp=Bind_response {bind_result=res;_};_} -> 230 | raise (LDAP_Failure 231 | (res.result_code, res.error_message, 232 | {ext_matched_dn=res.matched_dn; 233 | ext_referral=res.ldap_referral})) 234 | | _ -> raise (LDAP_Failure (`LOCAL_ERROR, "invalid server response", ext_res)) 235 | with exn -> free_messageid con msgid;raise exn); 236 | free_messageid con msgid 237 | 238 | let search ?(base = "") ?(scope = `SUBTREE) ?(aliasderef=`NEVERDEREFALIASES) 239 | ?(sizelimit=0l) ?(timelimit=0l) ?(attrs = []) ?(attrsonly = false) 240 | ?(page_control = `Noctrl) con filter = 241 | let msgid = allocate_messageid con in 242 | let build_res_ctrl size cookie = 243 | {Ldap_types.criticality = false; 244 | Ldap_types.control_details=(`Paged_results_control {Ldap_types.size; Ldap_types.cookie})} 245 | in 246 | let controls = match (page_control) with 247 | | `Noctrl -> None 248 | | `Initctrl size | `Subctrl (size,_) when size < 1 -> 249 | raise (Ldap_types.LDAP_Failure(`LOCAL_ERROR, "invalid page size", ext_res)) 250 | | `Initctrl size -> Some [(build_res_ctrl size "")] 251 | | `Subctrl (size,cookie) -> Some [(build_res_ctrl size cookie)] 252 | in 253 | try 254 | let e_filter = (try Ldap_filter.of_string filter 255 | with _ -> 256 | (raise 257 | (LDAP_Failure 258 | (`LOCAL_ERROR, "bad search filter", ext_res)))) 259 | in 260 | send_message con 261 | {messageID=msgid; 262 | protocolOp=Search_request 263 | {baseObject=base; 264 | scope=scope; 265 | derefAliases=aliasderef; 266 | sizeLimit=sizelimit; 267 | timeLimit=timelimit; 268 | typesOnly=attrsonly; 269 | filter=e_filter; 270 | s_attributes=attrs}; 271 | controls}; 272 | msgid 273 | with exn -> free_messageid con msgid;raise exn 274 | 275 | let get_search_entry con msgid = 276 | try 277 | match receive_message con msgid with 278 | {protocolOp=Search_result_entry e;_} -> `Entry e 279 | | {protocolOp=Search_result_reference r;_} -> `Referral r 280 | | {protocolOp=Search_result_done {result_code=`SUCCESS;_};_} -> 281 | raise (LDAP_Failure (`SUCCESS, "success", ext_res)) 282 | | {protocolOp=Search_result_done res;_} -> 283 | raise (LDAP_Failure (res.result_code, res.error_message, 284 | {ext_matched_dn=res.matched_dn; 285 | ext_referral=res.ldap_referral})) 286 | | _ -> raise (LDAP_Failure (`LOCAL_ERROR, "unexpected search response", ext_res)) 287 | with exn -> free_messageid con msgid;raise exn 288 | 289 | let get_search_entry_with_controls con msgid = 290 | try 291 | match receive_message con msgid with 292 | {Ldap_types.protocolOp=Ldap_types.Search_result_entry e;_} -> `Entry e 293 | | {Ldap_types.protocolOp=Ldap_types.Search_result_reference r;_} -> `Referral r 294 | | {Ldap_types.protocolOp=Ldap_types.Search_result_done {Ldap_types.result_code=`SUCCESS;_};Ldap_types.controls=cntrls;_} -> 295 | `Success cntrls 296 | | {Ldap_types.protocolOp=Ldap_types.Search_result_done res;_} -> 297 | raise (Ldap_types.LDAP_Failure (res.Ldap_types.result_code, res.Ldap_types.error_message, 298 | {Ldap_types.ext_matched_dn=res.Ldap_types.matched_dn; 299 | ext_referral=res.Ldap_types.ldap_referral})) 300 | | _ -> raise (Ldap_types.LDAP_Failure (`LOCAL_ERROR, "unexpected search response", ext_res)) 301 | with exn -> free_messageid con msgid;raise exn 302 | 303 | let abandon con msgid = 304 | let my_msgid = allocate_messageid con in 305 | try 306 | free_messageid con msgid; 307 | send_message con 308 | {messageID=my_msgid; 309 | protocolOp=(Abandon_request msgid); 310 | controls=None} 311 | with exn -> free_messageid con my_msgid;raise exn 312 | 313 | let search_s ?(base = "") ?(scope = `SUBTREE) ?(aliasderef=`NEVERDEREFALIASES) 314 | ?(sizelimit=0l) ?(timelimit=0l) ?(attrs = []) ?(attrsonly = false) con filter = 315 | let msgid = search ~base:base ~scope:scope ~aliasderef:aliasderef ~sizelimit:sizelimit 316 | ~timelimit:timelimit ~attrs:attrs ~attrsonly:attrsonly con filter 317 | in 318 | let result = ref [] in 319 | (try 320 | while true 321 | do 322 | result := (get_search_entry con msgid) :: !result 323 | done 324 | with 325 | LDAP_Failure (`SUCCESS, _, _) -> () 326 | | LDAP_Failure (code, msg, ext) -> raise (LDAP_Failure (code, msg, ext)) 327 | | exn -> (try abandon con msgid with _ -> ());raise exn); 328 | free_messageid con msgid; 329 | !result 330 | 331 | let add_s con (entry: entry) = 332 | let msgid = allocate_messageid con in 333 | (try 334 | send_message con 335 | {messageID=msgid; 336 | protocolOp=Add_request entry; 337 | controls=None}; 338 | match receive_message con msgid with 339 | {protocolOp=Add_response {result_code=`SUCCESS;_};_} -> () 340 | | {protocolOp=Add_response res;_} -> 341 | raise (LDAP_Failure (res.result_code, res.error_message, 342 | {ext_matched_dn=res.matched_dn; 343 | ext_referral=res.ldap_referral})) 344 | | _ -> raise (LDAP_Failure (`LOCAL_ERROR, "invalid add response", ext_res)) 345 | with exn -> free_messageid con msgid;raise exn); 346 | free_messageid con msgid 347 | 348 | let delete_s con ~dn = 349 | let msgid = allocate_messageid con in 350 | (try 351 | send_message con 352 | {messageID=msgid; 353 | protocolOp=Delete_request dn; 354 | controls=None}; 355 | match receive_message con msgid with 356 | {protocolOp=Delete_response {result_code=`SUCCESS;_};_} -> () 357 | | {protocolOp=Delete_response res;_} -> 358 | raise (LDAP_Failure (res.result_code, res.error_message, 359 | {ext_matched_dn=res.matched_dn; 360 | ext_referral=res.ldap_referral})) 361 | | _ -> raise (LDAP_Failure (`LOCAL_ERROR, "invalid delete response", ext_res)) 362 | with exn -> free_messageid con msgid;raise exn); 363 | free_messageid con msgid 364 | 365 | let unbind con = 366 | try 367 | (match con.socket with 368 | Ssl s -> Ssl.shutdown s 369 | | Plain s -> close s) 370 | with _ -> () 371 | 372 | let modify_s con ~dn ~mods = 373 | let rec convertmods ?(converted=[]) mods = 374 | match mods with 375 | (op, attr, values) :: tl -> 376 | (convertmods 377 | ~converted:({mod_op=op; 378 | mod_value={attr_type=attr; 379 | attr_vals=values}} :: converted) 380 | tl) 381 | | [] -> converted 382 | in 383 | let msgid = allocate_messageid con in 384 | (try 385 | send_message con 386 | {messageID=msgid; 387 | protocolOp=Modify_request 388 | {mod_dn=dn; 389 | modification=convertmods mods}; 390 | controls=None}; 391 | match receive_message con msgid with 392 | {protocolOp=Modify_response {result_code=`SUCCESS;_};_} -> () 393 | | {protocolOp=Modify_response res;_} -> 394 | raise (LDAP_Failure (res.result_code, res.error_message, 395 | {ext_matched_dn=res.matched_dn; 396 | ext_referral=res.ldap_referral})) 397 | | _ -> raise (LDAP_Failure (`LOCAL_ERROR, "invalid modify response", ext_res)) 398 | with exn -> free_messageid con msgid;raise exn); 399 | free_messageid con msgid 400 | 401 | let modrdn_s ?(deleteoldrdn=true) ?(newsup=None) con ~dn ~newdn = 402 | let _ = newsup in (* TODO: not used?? *) 403 | let msgid = allocate_messageid con in 404 | (try 405 | send_message con 406 | {messageID=msgid; 407 | protocolOp=Modify_dn_request 408 | {modn_dn=dn; 409 | modn_newrdn=newdn; 410 | modn_deleteoldrdn=deleteoldrdn; 411 | modn_newSuperior=None}; 412 | controls=None}; 413 | match receive_message con msgid with 414 | {protocolOp=Modify_dn_response {result_code=`SUCCESS;_};_} -> () 415 | | {protocolOp=Modify_dn_response res;_} -> 416 | raise (LDAP_Failure (res.result_code, res.error_message, 417 | {ext_matched_dn=res.matched_dn; 418 | ext_referral=res.ldap_referral})) 419 | | _ -> raise (LDAP_Failure (`LOCAL_ERROR, "invalid modify dn response", ext_res)) 420 | with exn -> free_messageid con msgid;raise exn); 421 | free_messageid con msgid 422 | -------------------------------------------------------------------------------- /src/ldap/ldap_funclient.mli: -------------------------------------------------------------------------------- 1 | (* a functional interface to ldap 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University 4 | at Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | (** a functional ldap client interface *) 23 | 24 | open Ldap_types 25 | 26 | type msgid 27 | type conn 28 | type modattr = modify_optype * string * string list 29 | type result = Ldap_types.search_result_entry list 30 | type entry = Ldap_types.search_result_entry 31 | type authmethod = [ `SIMPLE | `SASL ] 32 | type search_result = 33 | [ `Entry of entry 34 | | `Referral of string list 35 | | `Success of (ldap_controls option) ] 36 | type page_control = 37 | [ `Noctrl 38 | | `Initctrl of int 39 | | `Subctrl of (int * string) ] 40 | 41 | (** Initializes the conn data structure, and opens a connection to the 42 | server. init 43 | [["ldap://rrhost.example.com/";"ldap://backup.example.com:1389"]]. 44 | init is round robin dns aware, if dns returns multiple mappings it 45 | will try each one before finially failing. It also takes a list of 46 | hostnames, so you can specify backup servers to try. SSL and TLS are 47 | supported if selected at compile time. 48 | 49 | @param version the protocol version to use to 50 | connect, default is version 3. And actually, version 2 will probably 51 | not work correctly without some tweaking. 52 | 53 | @raise LDAP_Failure any 54 | failure to connect to the server will result in LDAP_Failure with 55 | the result_code set to `LOCAL_ERROR. 56 | 57 | @raise Failure May raise 58 | Failure "int_of_string" if you pass it a malformed url. May also 59 | raise various lexer errors under the same conditions. *) 60 | val init : ?connect_timeout:int -> ?version:int -> string list -> conn 61 | 62 | (** close the connection to the server. You may not use the conn 63 | after you have unbound, if you do you will get an exception. *) 64 | val unbind : conn -> unit 65 | 66 | (** authenticatite to the server. In this version only simple binds 67 | are supported, however the ldap_protocol.ml module DOES implement 68 | sasl binds. It would be fairly easy to support them here. We 69 | eventually will. 70 | 71 | @param who the dn to bind as 72 | @param cred the credentials to authenticate with. For `SIMPLE binds 73 | this is a password, but for `SASL binds it can be nearly 74 | anything. Perhaps a hash of the thumb print of your first born is 75 | sufficent. 76 | @param auth_method either `SIMPLE (the default) or `SASL 77 | 78 | @raise LDAP_Failure for bind errors such as `INVALID_CREDENTIALS 79 | @raise Decoding_error for decoder errors (unlikely, probably a bug) 80 | @raise Encoding_error for encoder errors (unlikely, probably a bug) 81 | *) 82 | val bind_s : 83 | ?who:string -> ?cred:string -> ?auth_method:[> `SIMPLE ] -> conn -> unit 84 | 85 | (** Search for the given entry with the specified base node and search 86 | scope, optionally limiting the returned attributes to those listed in 87 | 'attrs'. aliasderef sets the server's alias dereferencing policy, 88 | sizelimit is the number of entries to return, timelimit is the number 89 | of seconds to allow the search to run for, attrsonly tells the server 90 | not to return the values. This is the asyncronus version of search 91 | (it does not block) you will need to call the get_search_entry 92 | function below to actually get any data back. This function will 93 | return a msgid which you must use when you call get_search_entry. 94 | 95 | @param base The dn of the object in the tree to use as the base 96 | object, the search will only cover children of this object, and will 97 | be further governed by scope. 98 | @param scope The depth in the tree to look for the requested 99 | object. There are three possible values, `BASE, `ONELEVEL, and 100 | `SUBTREE. `BASE means to only search the base object, the search 101 | will return exactly 1 or 0 objects. `ONELEVEL means to search one 102 | level under the base, only immediate children of the base object 103 | will be considered. `SUBTREE means to search the entire tree under 104 | the base object. 105 | @param aliasderef Controls when aliases are dereferenced. 106 | @param sizelimit The maximum number of objects to return 107 | @param timelimit The maximum time, in seconds, that the search will 108 | be allowed to run before terminateing. 109 | @param attrs The list of attribute types (names) to include [[]] 110 | (the default) means all. 111 | @param attrsonly return only attribute types (names), not any of the 112 | values 113 | 114 | @raise LDAP_Failure for immediate errors (bad filter, etc) 115 | @raise Decoding_error for decoder errors (unlikely, probably a bug) 116 | @raise Encoding_error for encoder errors (unlikely, probably a bug) 117 | *) 118 | val search : 119 | ?base:string -> 120 | ?scope:Ldap_types.search_scope -> 121 | ?aliasderef:Ldap_types.alias_deref -> 122 | ?sizelimit:int32 -> 123 | ?timelimit:int32 -> 124 | ?attrs:string list -> 125 | ?attrsonly:bool -> 126 | ?page_control:page_control -> conn -> string -> msgid 127 | 128 | (** fetch a search entry from the wire using the given msgid. The 129 | entry could be a search entry, OR it could be a referral structure. 130 | 131 | @raise LDAP_Failure for all results other than `SUCCESS (except referrals) 132 | @raise Decoding_error for decoder errors (unlikely, probably a bug) 133 | @raise Encoding_error for encoder errors (unlikely, probably a bug) 134 | *) 135 | val get_search_entry : 136 | conn -> 137 | msgid -> 138 | [> `Entry of Ldap_types.search_result_entry | `Referral of string list ] 139 | 140 | (** fetch a search entry from the wire using the given msgid. The 141 | entry could be a search entry, OR it could be a referral structure. 142 | 143 | The version supports passing ldap_controls (like page control) through on 144 | success. Returning an entry of type `SUCCESS was thus needed. 145 | 146 | @raise LDAP_Failure for all results other than `SUCCESS (except referrals) 147 | @raise Decoding_error for decoder errors (unlikely, probably a bug) 148 | @raise Encoding_error for encoder errors (unlikely, probably a bug) 149 | *) 150 | val get_search_entry_with_controls : 151 | conn -> 152 | msgid -> 153 | [> `Entry of Ldap_types.search_result_entry | 154 | `Referral of string list | 155 | `Success of (ldap_controls option) ] 156 | 157 | (** abandon the async request attached to msgid. 158 | 159 | @raise Encoding_error for encoder errors (unlikely, probably a bug) *) 160 | val abandon : conn -> msgid -> unit 161 | 162 | (** This is the syncronus version of search. It blocks until the 163 | search is complete, and returns a list of objects. It is exactly the 164 | same in all other ways. *) 165 | val search_s : 166 | ?base:string -> 167 | ?scope:Ldap_types.search_scope -> 168 | ?aliasderef:Ldap_types.alias_deref -> 169 | ?sizelimit:int32 -> 170 | ?timelimit:int32 -> 171 | ?attrs:string list -> 172 | ?attrsonly:bool -> 173 | conn -> 174 | string -> 175 | [> `Entry of Ldap_types.search_result_entry | `Referral of string list ] 176 | list 177 | 178 | (** add entry to the directory 179 | 180 | @raise LDAP_Failure for all results other than `SUCCESS 181 | @raise Decoding_error for decoder errors (unlikely, probably a bug) 182 | @raise Encoding_error for encoder errors (unlikely, probably a bug) 183 | *) 184 | val add_s : conn -> entry -> unit 185 | 186 | (** delete the entry named by dn from the directory 187 | 188 | @raise LDAP_Failure for all results other than `SUCCESS 189 | @raise Decoding_error for decoder errors (unlikely, probably a bug) 190 | @raise Encoding_error for encoder errors (unlikely, probably a bug) 191 | *) 192 | val delete_s : conn -> dn:string -> unit 193 | 194 | (** apply the list of modifications to the named entry 195 | 196 | @param dn The dn of the object to modify 197 | @param mods The list of modifications to apply 198 | 199 | @raise LDAP_Failure for all results other than `SUCCESS 200 | @raise Decoding_error for decoder errors (unlikely, probably a bug) 201 | @raise Encoding_error for encoder errors (unlikely, probably a bug) 202 | *) 203 | val modify_s : 204 | conn -> 205 | dn:string -> 206 | mods:(Ldap_types.modify_optype * string * string list) list -> unit 207 | 208 | (** change the rdn, and optionally the superior entry of dn 209 | 210 | @param deleteoldrdn Delete the old rdn value, (default true) 211 | @param newsup The new superior dn of the object (default None) 212 | @param dn The dn of the object to modify 213 | @param newrdn The new rdn value (eg. cn=bob) 214 | 215 | @raise LDAP_Failure for all results other than `SUCCESS 216 | @raise Decoding_error for decoder errors (unlikely, probably a bug) 217 | @raise Encoding_error for encoder errors (unlikely, probably a bug) 218 | *) 219 | val modrdn_s : 220 | ?deleteoldrdn:bool -> 221 | ?newsup:'a option -> conn -> dn:string -> newdn:string -> unit 222 | -------------------------------------------------------------------------------- /src/ldap/ldap_funserver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (C) 2004 Eric Stokes, and The California State University 3 | at Northridge 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 18 | USA 19 | *) 20 | 21 | 22 | open Lber 23 | open Ldap_types 24 | open Ldap_protocol 25 | open Unix 26 | open Printf 27 | 28 | exception Server_error of string 29 | exception Finished 30 | 31 | type connection_id = int 32 | 33 | type backendInfo = { 34 | bi_op_bind : (connection_id -> ldap_message -> ldap_message) option; 35 | bi_op_unbind : (connection_id -> ldap_message -> unit) option; 36 | bi_op_search : (connection_id -> ldap_message -> (unit -> ldap_message)) option; 37 | bi_op_compare : (connection_id -> ldap_message -> ldap_message) option; 38 | bi_op_modify : (connection_id -> ldap_message -> ldap_message) option; 39 | bi_op_modrdn : (connection_id -> ldap_message -> ldap_message) option; 40 | bi_op_add : (connection_id -> ldap_message -> ldap_message) option; 41 | bi_op_delete : (connection_id -> ldap_message -> ldap_message) option; 42 | bi_op_abandon : (connection_id -> ldap_message -> unit) option; 43 | bi_op_extended : (connection_id -> ldap_message -> ldap_message) option; 44 | bi_init : (unit -> unit) option; 45 | bi_close : (unit -> unit) option; 46 | } 47 | 48 | type log_level = 49 | [ `GENERAL 50 | | `CONNECTION 51 | | `OPERATIONS 52 | | `ERROR 53 | | `TRACE ] 54 | 55 | type opcnt = int 56 | type pending_operations = (unit -> unit) list 57 | 58 | type server_info = { 59 | si_listening_socket: file_descr; 60 | si_client_sockets: (file_descr, connection_id * opcnt * pending_operations * readbyte) Hashtbl.t; 61 | si_backend: backendInfo; 62 | si_log: (log_level -> string -> unit); 63 | mutable si_current_connection_id: int; 64 | } 65 | 66 | let allocate_connection_id si = 67 | if si.si_current_connection_id < max_int then 68 | (si.si_current_connection_id <- si.si_current_connection_id + 1; 69 | si.si_current_connection_id) 70 | else 71 | (si.si_current_connection_id <- 1;1) 72 | 73 | let log_result conn_id op_nr si msg = 74 | let log_search_result {result_code=err;error_message=text;_} = 75 | si.si_log `OPERATIONS 76 | (sprintf "conn=%d op=%d SEARCH RESULT tag=0 err=%d nentries=0 text=%s" 77 | conn_id op_nr (Ldap_protocol.encode_resultcode err) text) 78 | in 79 | let log_normal_result {result_code=err;error_message=text;_} = 80 | si.si_log `OPERATIONS 81 | (sprintf "conn=%d op=%d RESULT tag=0 err=%d text=%s" 82 | conn_id op_nr (Ldap_protocol.encode_resultcode err) text) 83 | in 84 | match msg.protocolOp with 85 | Bind_response {bind_result=result;_} 86 | | Modify_response result 87 | | Add_response result 88 | | Delete_response result 89 | | Modify_dn_response result 90 | | Compare_response result -> log_normal_result result 91 | | Search_result_done result -> log_search_result result 92 | | _ -> () 93 | 94 | let send_message si conn_id op_nr fd msg = 95 | let e_msg = encode_ldapmessage msg in 96 | let e_msg = Bytes.of_string e_msg in 97 | let len = Bytes.length e_msg in 98 | let written = ref 0 in 99 | try 100 | while !written < len 101 | do 102 | written := ((write fd e_msg 103 | !written (len - !written)) + 104 | !written) 105 | done; 106 | log_result conn_id op_nr si msg 107 | with Unix_error (_, _, _) -> 108 | (try close fd with _ -> ()); 109 | raise (Server_error "data cannot be written") 110 | 111 | let keys h = Hashtbl.fold (fun k _v l -> k :: l) h [] 112 | 113 | let init ?(log=(fun _ _ -> ())) ?(port=389) bi = 114 | let s = 115 | let s = socket PF_INET SOCK_STREAM 0 in 116 | setsockopt s SO_REUSEADDR true; 117 | bind s (ADDR_INET (inet_addr_any, port)); 118 | listen s 500; 119 | s 120 | in 121 | (match bi.bi_init with 122 | Some f -> f () 123 | | None -> ()); 124 | {si_listening_socket=s; 125 | si_client_sockets=Hashtbl.create 10; 126 | si_current_connection_id=0; 127 | si_log=log; 128 | si_backend=bi} 129 | 130 | let shutdown si = 131 | (match si.si_backend.bi_close with 132 | Some f -> f () 133 | | None -> ()); 134 | close si.si_listening_socket; 135 | List.iter (fun fd -> close fd) (keys si.si_client_sockets); 136 | Hashtbl.clear si.si_client_sockets; 137 | si.si_log `GENERAL "stopped." 138 | 139 | let dispatch_request si conn_id op_nr rb fd = 140 | let bi = si.si_backend in 141 | let not_imp msg op = 142 | {messageID=msg.messageID; 143 | protocolOp=op; 144 | controls=None} 145 | in 146 | let not_implemented = {result_code=`OTHER; 147 | matched_dn=""; 148 | error_message="Not Implemented"; 149 | ldap_referral=None} 150 | in 151 | let message = decode_ldapmessage rb in 152 | match message with 153 | {protocolOp=Bind_request {bind_name=dn;bind_authentication=auth;_};_} -> 154 | si.si_log `OPERATIONS 155 | (sprintf "conn=%d op=%d BIND dn=\"%s\" method=128" conn_id op_nr dn); 156 | si.si_log `OPERATIONS 157 | (sprintf "conn=%d op=%d BIND dn=\"%s\" mech=%s ssf=0" conn_id op_nr dn 158 | (match auth with 159 | Simple _ -> "SIMPLE" 160 | | Sasl _ -> "SASL")); 161 | (match bi.bi_op_bind with 162 | Some f -> 163 | (fun () -> 164 | send_message si conn_id op_nr fd (f conn_id message); 165 | raise Finished) 166 | | None -> (fun () -> send_message si conn_id op_nr fd 167 | (not_imp message (Bind_response 168 | {bind_result=not_implemented; 169 | bind_serverSaslCredentials=None})); 170 | raise Finished)) 171 | | {protocolOp=Unbind_request;_} -> 172 | si.si_log `OPERATIONS 173 | (sprintf "conn=%d op=%d UNBIND" conn_id op_nr); 174 | (match bi.bi_op_unbind with 175 | Some f -> (fun () -> f conn_id message;raise Finished) 176 | | None -> (fun () -> raise Finished)) 177 | | {protocolOp=(Search_request 178 | {baseObject=base; 179 | scope=scope; 180 | derefAliases=deref; 181 | sizeLimit=_sizelimit; 182 | timeLimit=_timelimit; 183 | typesOnly=_attrsonly; 184 | filter=filter; 185 | s_attributes=attrs});_} -> 186 | si.si_log `OPERATIONS 187 | (sprintf "conn=%d op=%d SRCH base=\"%s\" scope=%d deref=%d filter=\"%s\"" 188 | conn_id op_nr base 189 | (match scope with 190 | `BASE -> 0 191 | | `ONELEVEL -> 1 192 | | `SUBTREE -> 2) 193 | (match deref with 194 | `NEVERDEREFALIASES -> 0 195 | | `DEREFINSEARCHING -> 1 196 | | `DEREFFINDINGBASE -> 2 197 | | `DEREFALWAYS -> 3) 198 | (Ldap_filter.to_string filter)); 199 | (match attrs with 200 | [] -> () 201 | | lst -> si.si_log `OPERATIONS 202 | (sprintf "conn=%d op=%d SRCH attr=%s" conn_id op_nr 203 | (List.fold_left 204 | (fun s attr -> if s = "" then attr else (attr ^ " " ^ s)) 205 | "" lst))); 206 | (match bi.bi_op_search with 207 | Some f -> 208 | let get_srch_result = f conn_id message in 209 | (fun () -> 210 | let msg = get_srch_result () in 211 | send_message si conn_id op_nr fd msg; 212 | match msg.protocolOp with 213 | Search_result_done _ -> raise Finished 214 | | _ -> ()) 215 | | None -> (fun () -> send_message si conn_id op_nr fd 216 | (not_imp message (Search_result_done not_implemented)); 217 | raise Finished)) 218 | | {protocolOp=Modify_request {mod_dn=modify;modification=modlst};_} -> 219 | si.si_log `OPERATIONS 220 | (sprintf "conn=%d op=%d MOD dn=\"%s\"" conn_id op_nr modify); 221 | si.si_log `OPERATIONS 222 | (sprintf "conn=%d op=%d MOD attr=\"%s\"" conn_id op_nr 223 | (List.fold_left 224 | (fun s attr -> 225 | if s = "" then 226 | attr.mod_value.attr_type 227 | else 228 | (attr.mod_value.attr_type ^ " " ^ s)) 229 | "" modlst)); 230 | (match bi.bi_op_modify with 231 | Some f -> (fun () -> 232 | send_message si conn_id op_nr fd (f conn_id message); 233 | raise Finished) 234 | | None -> (fun () -> send_message si conn_id op_nr fd 235 | (not_imp message (Modify_response not_implemented)); 236 | raise Finished)) 237 | | {protocolOp=Add_request {sr_dn=dn;_};_} -> 238 | si.si_log `OPERATIONS (sprintf "conn=%d op=%d ADD dn=\"%s\"" conn_id op_nr dn); 239 | (match bi.bi_op_add with 240 | Some f -> (fun () -> 241 | send_message si conn_id op_nr fd (f conn_id message); 242 | raise Finished) 243 | | None -> (fun () -> send_message si conn_id op_nr fd 244 | (not_imp message (Add_response not_implemented)); 245 | raise Finished)) 246 | | {protocolOp=Delete_request dn;_} -> 247 | si.si_log `OPERATIONS (sprintf "conn=%d op=%d DEL dn=\"%s\"" conn_id op_nr dn); 248 | (match bi.bi_op_delete with 249 | Some f -> (fun () -> 250 | send_message si conn_id op_nr fd (f conn_id message); 251 | raise Finished) 252 | | None -> (fun () -> send_message si conn_id op_nr fd 253 | (not_imp message (Delete_response not_implemented)); 254 | raise Finished)) 255 | | {protocolOp=Modify_dn_request {modn_dn=dn;_};_} -> 256 | si.si_log `OPERATIONS (sprintf "conn=%d op=%d MODRDN dn=\"%s\"" conn_id op_nr dn); 257 | (match bi.bi_op_modrdn with 258 | Some f -> (fun () -> 259 | send_message si conn_id op_nr fd (f conn_id message); 260 | raise Finished) 261 | | None -> (fun () -> send_message si conn_id op_nr fd 262 | (not_imp message (Modify_dn_response not_implemented)); 263 | raise Finished)) 264 | | {protocolOp=Compare_request {cmp_dn=dn;cmp_ava=ava};_} -> 265 | si.si_log `OPERATIONS 266 | (sprintf "conn=%d op=%d CMP dn=\"%s\" attr=\"%s\"" 267 | conn_id op_nr dn ava.attributeDesc); 268 | (match bi.bi_op_compare with 269 | Some f -> (fun () -> 270 | send_message si conn_id op_nr fd (f conn_id message); 271 | raise Finished) 272 | | None -> (fun () -> send_message si conn_id op_nr fd 273 | (not_imp message (Compare_response not_implemented)); 274 | raise Finished)) 275 | | {protocolOp=Abandon_request msgid;_} -> 276 | si.si_log `OPERATIONS (sprintf "conn=%d op=%d ABANDON msgid=%ld" conn_id op_nr msgid); 277 | (match bi.bi_op_abandon with 278 | Some f -> (fun () -> f conn_id message;raise Finished) 279 | | None -> (fun () -> raise Finished)) 280 | | {protocolOp=Extended_request _;_} -> 281 | (match bi.bi_op_extended with 282 | Some f -> (fun () -> 283 | send_message si conn_id op_nr fd (f conn_id message); 284 | raise Finished) 285 | | None -> (fun () -> send_message si conn_id op_nr fd 286 | (not_imp message 287 | (Extended_response 288 | {ext_result=not_implemented; 289 | ext_responseName=None; 290 | ext_response=None})); 291 | raise Finished)) 292 | | _ -> raise (Server_error "invalid operation") 293 | 294 | let string_of_sockaddr sockaddr = 295 | match sockaddr with 296 | ADDR_UNIX addr -> addr 297 | | ADDR_INET (ip, port) -> 298 | (sprintf "%s:%d" (string_of_inet_addr ip) port) 299 | 300 | let run si = 301 | let pending_writes si = (* do we have data to write? *) 302 | Hashtbl.fold 303 | (fun k (_, _, ops_pending, _) pending -> 304 | match ops_pending with 305 | [] -> pending 306 | | _ -> k :: pending) 307 | si.si_client_sockets [] 308 | in 309 | let process_read reading writing excond (fd:file_descr) = 310 | if Hashtbl.mem si.si_client_sockets fd then 311 | (* an existing client has requested a new operation *) 312 | let (conn_id, op_nr, pending_ops, rb) = Hashtbl.find si.si_client_sockets fd in 313 | try 314 | try 315 | Hashtbl.replace 316 | si.si_client_sockets 317 | fd 318 | (conn_id, 319 | (op_nr + 1), 320 | (dispatch_request si conn_id op_nr rb fd) :: pending_ops, 321 | rb) 322 | with LDAP_Decoder e | Decoding_error e -> (* handle protocol errors *) 323 | send_message si conn_id 0 fd (* send a notice of disconnection *) 324 | {messageID=0l; 325 | protocolOp=Extended_response 326 | {ext_result={result_code=`PROTOCOL_ERROR; 327 | matched_dn=""; 328 | error_message=e; 329 | ldap_referral=None}; 330 | ext_responseName=(Some "1.3.6.1.4.1.1466.20036"); 331 | ext_response=None}; 332 | controls=None}; 333 | raise (Readbyte_error Transport_error) (* close the connection *) 334 | with Readbyte_error Transport_error -> 335 | (match si.si_backend.bi_op_unbind with 336 | Some f -> f conn_id {messageID=0l;protocolOp=Unbind_request;controls=None} 337 | | None -> ()); 338 | (* remove the client from our table of clients, and 339 | from the list of readable/writable fds, that way we 340 | don't try to do a write to them, even though we may 341 | have pending writes *) 342 | Hashtbl.remove si.si_client_sockets fd; 343 | reading := List.filter ((<>) fd) !reading; 344 | writing := List.filter ((<>) fd) !writing; 345 | excond := List.filter ((<>) fd) !excond; 346 | (try close fd with _ -> ()); 347 | si.si_log `CONNECTION (sprintf "conn=%d fd=0 closed" conn_id) 348 | else (* a new connection has come in, accept it *) 349 | let (newfd, sockaddr) = accept fd in 350 | let rb = readbyte_of_fd newfd in 351 | let connid = allocate_connection_id si in 352 | Hashtbl.add si.si_client_sockets newfd (connid, 0, [], rb); 353 | si.si_log `CONNECTION 354 | (sprintf "conn=%d fd=0 ACCEPT from IP=%s (IP=%s)" 355 | connid 356 | (string_of_sockaddr sockaddr) 357 | (string_of_sockaddr (getsockname fd))) 358 | in 359 | let process_write reading writing excond (fd: file_descr) = 360 | if Hashtbl.mem si.si_client_sockets fd then 361 | let (conn_id, op_nr, pending_ops, rb) = Hashtbl.find si.si_client_sockets fd in 362 | try 363 | match pending_ops with 364 | [] -> () 365 | | hd :: tl -> 366 | try hd () with Finished -> 367 | Hashtbl.replace si.si_client_sockets fd (conn_id, op_nr, tl, rb) 368 | with Server_error "data cannot be written" -> 369 | (match si.si_backend.bi_op_unbind with 370 | Some f -> f conn_id {messageID=0l;protocolOp=Unbind_request;controls=None} 371 | | None -> ()); 372 | Hashtbl.remove si.si_client_sockets fd; 373 | reading := List.filter ((<>) fd) !reading; 374 | writing := List.filter ((<>) fd) !writing; 375 | excond := List.filter ((<>) fd) !excond; 376 | si.si_log `CONNECTION (sprintf "conn=%d fd=0 closed" conn_id) 377 | else raise (Server_error "socket to write to not found") 378 | in 379 | si.si_log `GENERAL "starting"; 380 | while true 381 | do 382 | let fds = keys si.si_client_sockets in 383 | let reading = ref [] 384 | and writing = ref [] 385 | and excond = ref [] in 386 | let (rd, wr, ex) = 387 | select (si.si_listening_socket :: fds) 388 | (pending_writes si) (* nothing to write? don't bother *) 389 | fds (-1.0) 390 | in 391 | reading := rd;writing := wr;excond := ex; 392 | 393 | (* service connections which are ready to be read *) 394 | List.iter (process_read reading writing excond) !reading; 395 | 396 | (* service connections which are ready to be written to *) 397 | List.iter (process_write reading writing excond) !writing; 398 | 399 | (* Process out of band data *) 400 | List.iter (process_read reading writing excond) !excond 401 | done 402 | -------------------------------------------------------------------------------- /src/ldap/ldap_funserver.mli: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (C) 2004 Eric Stokes, and The California State University 3 | at Northridge 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 18 | USA 19 | *) 20 | 21 | (** A functional ldap server construction kit *) 22 | 23 | open Ldap_types 24 | 25 | (** raised whenever an error occurrs in the server *) 26 | exception Server_error of string 27 | 28 | type connection_id = int 29 | 30 | (** This structure is the guts of the ldap server. For each operation that you 31 | implement put the function (or closure) of the correct type in this 32 | structure. Any functions you set as None will return 33 | `UNWILLING_TO_PERFORM, with the error string set to "not implemented". 34 | bi_init will be called (if it is provided) before the server is brought 35 | up, and bi_close (if it is provided) will be called before the server is 36 | brought down. This interface is based loosely on the back-end api in 37 | OpenLDAP.*) 38 | type backendInfo = { 39 | bi_op_bind : (connection_id -> ldap_message -> ldap_message) option; 40 | bi_op_unbind : (connection_id -> ldap_message -> unit) option; 41 | bi_op_search : (connection_id -> ldap_message -> (unit -> ldap_message)) option; 42 | bi_op_compare : (connection_id -> ldap_message -> ldap_message) option; 43 | bi_op_modify : (connection_id -> ldap_message -> ldap_message) option; 44 | bi_op_modrdn : (connection_id -> ldap_message -> ldap_message) option; 45 | bi_op_add : (connection_id -> ldap_message -> ldap_message) option; 46 | bi_op_delete : (connection_id -> ldap_message -> ldap_message) option; 47 | bi_op_abandon : (connection_id -> ldap_message -> unit) option; 48 | bi_op_extended : (connection_id -> ldap_message -> ldap_message) option; 49 | bi_init : (unit -> unit) option; 50 | bi_close : (unit -> unit) option; 51 | } 52 | 53 | type log_level = 54 | [ `GENERAL 55 | | `CONNECTION 56 | | `OPERATIONS 57 | | `ERROR 58 | | `TRACE ] 59 | 60 | (** This abstract type contains the server context. It has the listening, 61 | socket, all the connected client sockets, and some internal data 62 | structures. *) 63 | 64 | type server_info 65 | 66 | (** Initialize the server, create the listening socket and return the 67 | server context, which you will pass to serv to process 68 | connections. log is a string -> log_level -> unit function to which log 69 | messages will be sent. *) 70 | val init : ?log:(log_level -> string -> unit) -> ?port:int -> backendInfo -> server_info 71 | 72 | (** Shutdown the server *) 73 | val shutdown : server_info -> unit 74 | 75 | (** Using the supplied server context, begin processing ldap operations. This 76 | function should never terminate unless there is an exceptional condition, in 77 | which case the exception will be raised. In many cases it is safe to restart 78 | the server process when an exception happens. *) 79 | val run : server_info -> unit 80 | -------------------------------------------------------------------------------- /src/ldap/ldap_mutex.ml: -------------------------------------------------------------------------------- 1 | open Ldap_ooclient 2 | open Ldap_types 3 | 4 | (* ldap mutexes *) 5 | exception Ldap_mutex of string * exn 6 | 7 | class type mutex_t = 8 | object 9 | method lock: unit 10 | method unlock: unit 11 | end 12 | 13 | class type object_lock_table_t = 14 | object 15 | method lock: dn -> unit 16 | method unlock: dn -> unit 17 | end 18 | 19 | let addmutex ldap mutexdn = 20 | let mt = new ldapentry in 21 | let mtrdn = List.hd (Ldap_dn.of_string mutexdn) in 22 | mt#set_dn mutexdn; 23 | 24 | 25 | 26 | mt#add [("objectclass", ["top";"mutex"]); 27 | (mtrdn.attr_type, mtrdn.attr_vals)]; 28 | try ldap#add mt 29 | with exn -> raise (Ldap_mutex ("addmutex", exn)) 30 | 31 | exception Locked 32 | 33 | let rec lock (ldap:ldapcon) mutexdn lockval = 34 | try 35 | let obj = 36 | try 37 | ldap#search 38 | ~base:mutexdn 39 | ~scope:`BASE 40 | "objectclass=*" 41 | with LDAP_Failure (`NO_SUCH_OBJECT, _, _) -> [] 42 | in 43 | if List.length obj = 0 then begin 44 | addmutex ldap mutexdn; 45 | lock ldap mutexdn lockval 46 | end 47 | else if List.length obj = 1 then 48 | while true 49 | do 50 | try 51 | ldap#modify (List.hd obj)#dn lockval; 52 | raise Locked 53 | with (* the mutex is locked already *) 54 | LDAP_Failure (`TYPE_OR_VALUE_EXISTS, _, _) 55 | | LDAP_Failure (`OBJECT_CLASS_VIOLATION, _, _) -> 56 | (* this is so evil *) 57 | ignore (Unix.select [] [] [] 0.25) (* wait 1/4 of a second *) 58 | done 59 | else failwith "huge error, multiple objects with the same dn" 60 | with 61 | Locked -> () 62 | | (Ldap_mutex _) as exn -> raise exn 63 | | exn -> raise (Ldap_mutex ("lock", exn)) 64 | 65 | let rec unlock (ldap:ldapcon) mutexdn unlockval = 66 | try 67 | let obj = 68 | try 69 | ldap#search 70 | ~base:mutexdn 71 | ~scope:`BASE 72 | "objectclass=*" 73 | with LDAP_Failure (`NO_SUCH_OBJECT, _, _) -> [] 74 | in 75 | if List.length obj = 0 then begin 76 | addmutex ldap mutexdn; 77 | unlock ldap mutexdn unlockval 78 | end 79 | else if List.length obj = 1 then 80 | try 81 | ldap#modify 82 | (List.hd obj)#dn unlockval 83 | with LDAP_Failure (`NO_SUCH_ATTRIBUTE, _, _) -> () 84 | with 85 | (Ldap_mutex _) as exn -> raise exn 86 | | exn -> raise (Ldap_mutex ("unlock", exn)) 87 | 88 | 89 | class mutex ldapurls binddn bindpw mutexdn = 90 | object (_self) 91 | val ldap = 92 | let ldap = new ldapcon ldapurls in 93 | ldap#bind binddn ~cred:bindpw; 94 | ldap 95 | 96 | method private addmutex = addmutex ldap mutexdn 97 | method lock = lock ldap mutexdn [(`ADD, "mutexlocked", ["locked"])] 98 | method unlock = unlock ldap mutexdn [(`DELETE, "mutexlocked", [])] 99 | end 100 | 101 | let apply_with_mutex mutex f = 102 | mutex#lock; 103 | try 104 | let result = f () in 105 | mutex#unlock; 106 | result 107 | with exn -> (try mutex#unlock with _ -> ());raise exn 108 | 109 | class object_lock_table ldapurls binddn bindpw mutextbldn = 110 | object (_self) 111 | val ldap = 112 | let ldap = new ldapcon ldapurls in 113 | ldap#bind binddn ~cred:bindpw; 114 | ldap 115 | method private addmutex = addmutex ldap mutextbldn 116 | method lock dn = lock ldap mutextbldn [(`ADD, "lockedObject", [Ldap_dn.to_string dn])] 117 | method unlock dn = unlock ldap mutextbldn [(`DELETE, "lockedObject", [Ldap_dn.to_string dn])] 118 | end 119 | -------------------------------------------------------------------------------- /src/ldap/ldap_mutex.mli: -------------------------------------------------------------------------------- 1 | (** functions for implementing mutexes on top of LDAP's built in test 2 | and set mechanism. In order to use this module you must load 3 | mutex.schema, which is an rfc2252 format schema file. raised when 4 | a mutex operation fails. The string argument contains the name of 5 | the method which failed, and the exception contains details about 6 | what failed. *) 7 | exception Ldap_mutex of string * exn 8 | 9 | (** the class type of a single mutex, used for performing 10 | advisory locking of some action *) 11 | class type mutex_t = 12 | object 13 | method lock: unit 14 | method unlock: unit 15 | end 16 | 17 | (** the class type of an object lock table which allows for advisory 18 | locking of objects by dn *) 19 | class type object_lock_table_t = 20 | object 21 | method lock: Ldap_types.dn -> unit 22 | method unlock: Ldap_types.dn -> unit 23 | end 24 | 25 | (** new mutex ldapurls binddn bindpw mutexdn *) 26 | class mutex: string list -> string -> string -> string -> 27 | object 28 | (** lock the mutex. This WILL block if the mutex is already locked *) 29 | method lock: unit 30 | 31 | (** unlock the mutex *) 32 | method unlock: unit 33 | end 34 | 35 | (** used to apply some function, first locking the mutex, unlocking it 36 | only after the function has been applied. If the function 37 | generates any exception, this wrapper catches that exception, and 38 | unlocks the mutex before reraising the exception. Generally 39 | garentees that the mutex will always be used consistantly when 40 | performing an action. *) 41 | val apply_with_mutex: mutex -> (unit -> 'a) -> 'a 42 | 43 | (** new object_lock_table ldapurls binddn bindpw mutexdn *) 44 | class object_lock_table: string list -> string -> string -> string -> 45 | object 46 | (** lock the specified dn, if it is already locked, then block until the lock can be aquired *) 47 | method lock: Ldap_types.dn -> unit 48 | 49 | (** unlock the specified dn, if it is not locked do nothing *) 50 | method unlock: Ldap_types.dn -> unit 51 | end 52 | -------------------------------------------------------------------------------- /src/ldap/ldap_protocol.mli: -------------------------------------------------------------------------------- 1 | (* an implementation of the ldap wire protocol 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University 4 | at Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | (** an implementation of the ldap wire protocol *) 23 | 24 | open Ldap_types 25 | open Lber 26 | 27 | (** return the int asociated with the specified result code *) 28 | val encode_resultcode : ldap_resultcode -> int 29 | 30 | (** return the result code for the specified int, error codes which do 31 | not map to a code defined within the standard (or any of our own 32 | internal ones) will be represented as (`UNKNOWN_ERROR of int), where 33 | int is the unknown error code. *) 34 | val decode_resultcode : int -> ldap_resultcode 35 | 36 | (** encode a value of type ldap_message using lber and return 37 | a string which is ready to be put on the wire *) 38 | val encode_ldapmessage : ldap_message -> string 39 | 40 | (** decode an ldap_message from the wire, and build/return a 41 | structure of type ldap_message *) 42 | val decode_ldapmessage : readbyte -> ldap_message 43 | -------------------------------------------------------------------------------- /src/ldap/ldap_schemalexer.mll: -------------------------------------------------------------------------------- 1 | (* lexer for rfc2252 format schemas 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University 4 | at Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | 22 | { 23 | type token = 24 | Lparen 25 | | Rparen 26 | | Numericoid of string 27 | | Name of string list 28 | | Desc of string 29 | | Obsolete 30 | | Equality of string 31 | | Ordering of string 32 | | Substr of string 33 | | Syntax of string * Int64.t 34 | | Single_value 35 | | Collective 36 | | No_user_modification 37 | | Usage of string 38 | | Sup of string list 39 | | Abstract 40 | | Structural 41 | | Auxiliary 42 | | Must of string list 43 | | May of string list 44 | | Xstring of string 45 | 46 | let quote = Str.regexp "'" 47 | let spacerex = Str.regexp " *" 48 | let stripspace buf = Str.global_replace spacerex "" buf 49 | let extract buf i chop = String.sub buf i ((String.length buf) - i - chop);; 50 | let splitoidlst buf regex = Str.split regex buf;; 51 | let stripquote buf = Str.global_replace quote "" buf 52 | let stripquotes lst = List.map (fun item -> stripquote item) lst 53 | 54 | [@@@ocaml.warning "-26"] 55 | } 56 | 57 | (* conversion definitions, from rfc 2252. I've tried to keep the names 58 | the same, or close. I've changed some names to make them more 59 | descriptive *) 60 | let alpha = [ 'a' - 'z' 'A' - 'Z' ] 61 | let digit = [ '0' - '9' ] 62 | let hdigit = [ 'a' - 'f' 'A' - 'F' '0' - '9' ] 63 | let k = [ 'a' - 'z' 'A' - 'Z' '0' - '9' '-' ';' ] 64 | let p = [ 'a' - 'z' 'A' - 'Z' '0' - '9' '"' '(' ')' '+' ',' '-' '.' '/' ':' '?' ' ' ] 65 | let utf8 = [ '\t' ' ' '!' - '&' '(' - '~' ] (* for now, this works, need to read about this *) 66 | let xstring = [ 'A' - 'Z' '-' ';' '_' ] + 67 | let whsp = ' ' + 68 | let dstring = utf8 * 69 | let qdstring = (whsp)? '\'' (dstring as qdstringval) '\'' (whsp)? 70 | let qdstringlist = qdstring + 71 | let qdstrings = qdstring | ( (whsp)? '(' qdstringlist ')' (whsp)? ) 72 | let letterstring = alpha + 73 | let numericstring = digit + 74 | let anhstring = k + 75 | let keystring = alpha anhstring * 76 | let printablestring = p + 77 | let space = ' ' + 78 | let descr = keystring 79 | let qdescr = whsp ''' (descr as qdescrval) ''' whsp 80 | let qdescrlist = qdescr ( ''' descr ''' whsp ) * 81 | let numericoid = numericstring ( '.' numericstring ) * 82 | let oid = descr | numericoid 83 | let woid = ( whsp )? oid ( whsp )? 84 | let oidlist = ( woid ( '$' woid ) * ) as oidlst 85 | let oids = woid as oidlst | whsp '(' ( oidlist as oidlst ) ')' whsp 86 | 87 | (* violates rfc2252 to support Microsoft Active Directory, but at least is not ambigous *) 88 | let noidlen = whsp ( ( numericoid ( '{' numericstring '}' ) ? ) as oid ) 89 | | whsp ''' ( ( numericoid ( '{' numericstring '}' ) ? ) as oid ) ''' 90 | | whsp ''' ( keystring as oid ) ''' 91 | 92 | let attributeUsage = "userApplication" | "directoryOperation" | "distributedOperation" | "dSAOperation" 93 | 94 | rule lexattr = parse 95 | '(' whsp {Lparen} 96 | | "NAME" qdescr {Name [qdescrval]} 97 | | "NAME" whsp '(' (qdescrlist as namelst) ')' whsp {Name (stripquotes 98 | (splitoidlst 99 | namelst 100 | (Str.regexp " *")))} 101 | | "DESC" qdstring {Desc qdstringval} 102 | | "OBSOLETE" whsp {Obsolete} 103 | | "SUP" whsp (woid as sup) {Sup [(stripspace sup)]} 104 | | "EQUALITY" whsp (woid as equality) {Equality (stripspace equality)} 105 | | "ORDERING" whsp (woid as ord) {Ordering (stripspace ord)} 106 | | "SUBSTR" whsp (woid as substr) {Substr (stripspace substr)} 107 | | "SYNTAX" noidlen whsp {match (splitoidlst oid (Str.regexp "{")) with 108 | [syntax] -> Syntax (syntax, Int64.zero) 109 | | [syntax;length] -> Syntax (syntax, 110 | Int64.of_string 111 | (extract length 0 1)) 112 | | _ -> failwith "syntax error"} 113 | | "SINGLE-VALUE" whsp {Single_value} 114 | | "COLLECTIVE" whsp {Collective} 115 | | "NO-USER-MODIFICATION" whsp {No_user_modification} 116 | | "USAGE" whsp attributeUsage whsp {Usage (extract (Lexing.lexeme lexbuf) 6 1)} 117 | | "X-" xstring qdstrings {Xstring (Lexing.lexeme lexbuf)} 118 | | oid whsp {Numericoid (extract (Lexing.lexeme lexbuf) 0 1)} 119 | | ')' {Rparen} 120 | 121 | and lexoc = parse 122 | '(' whsp {Lparen} 123 | | "NAME" qdescr {Name [qdescrval]} 124 | | "NAME" whsp '(' (qdescrlist as namelst) ')' whsp {Name (stripquotes 125 | (splitoidlst 126 | namelst 127 | (Str.regexp " *")))} 128 | | "DESC" qdstring {Desc qdstringval} 129 | | "OBSOLETE" whsp {Obsolete} 130 | | "SUP" whsp (woid as sup) {Sup [(stripspace sup)]} 131 | | "SUP" whsp '(' oidlist ')' whsp {Sup (List.rev_map stripspace 132 | (splitoidlst oidlst 133 | (Str.regexp " *\\$ *")))} 134 | | "ABSTRACT" whsp {Abstract} 135 | | "STRUCTURAL" whsp {Structural} 136 | | "AUXILIARY" whsp {Auxiliary} 137 | | "MUST" whsp (woid as must) {Must [(stripspace must)]} 138 | | "MUST" whsp '(' oidlist ')' whsp {Must (List.rev_map stripspace 139 | (splitoidlst oidlst 140 | (Str.regexp " *\\$ *")))} 141 | | "MAY" whsp (woid as may) {May [(stripspace may)]} 142 | | "MAY" whsp '(' oidlist ')' whsp {May (List.rev_map stripspace 143 | (splitoidlst oidlst 144 | (Str.regexp " *\\$ *")))} 145 | | "X-" xstring qdstrings {Xstring (Lexing.lexeme lexbuf)} 146 | | oid whsp {Numericoid (extract (Lexing.lexeme lexbuf) 0 1)} 147 | | ')' {Rparen} 148 | -------------------------------------------------------------------------------- /src/ldap/ldap_schemaparser.ml: -------------------------------------------------------------------------------- 1 | (* A parser for rfc2252 format schema definitionsa 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University 4 | at Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | 23 | open Ldap_schemalexer;; 24 | 25 | module Oid = 26 | (struct 27 | type t = string 28 | let of_string s = s 29 | let to_string oid = oid 30 | let compare x y = String.compare (to_string x) (to_string y) 31 | end 32 | : 33 | sig 34 | type t 35 | val of_string: string -> t 36 | val to_string: t -> string 37 | val compare: t -> t -> int 38 | end);; 39 | 40 | let format_oid id = 41 | Format.open_box 0; 42 | Format.print_string (""); 43 | Format.close_box () 44 | 45 | module Lcstring = 46 | (struct 47 | type t = string 48 | let of_string s = String.lowercase_ascii s 49 | let to_string x = x 50 | let compare x y = String.compare x y 51 | end 52 | : 53 | sig 54 | type t 55 | val of_string: string -> t 56 | val to_string: t -> string 57 | val compare: t -> t -> int 58 | end);; 59 | 60 | let format_lcstring id = 61 | Format.open_box 0; 62 | Format.print_string (""); 63 | Format.close_box () 64 | 65 | type octype = Abstract | Structural | Auxiliary;; 66 | type objectclass = {oc_name: string list; 67 | oc_oid:Oid.t; 68 | oc_desc:string; 69 | oc_obsolete:bool; 70 | oc_sup:Lcstring.t list; 71 | oc_must:Lcstring.t list; 72 | oc_may:Lcstring.t list; 73 | oc_type:octype; 74 | oc_xattr:string list} 75 | 76 | type attribute = {at_name:string list; 77 | at_desc:string; 78 | at_oid:Oid.t; 79 | at_equality:string; 80 | at_ordering:string; 81 | at_substr:Oid.t; 82 | at_syntax:Oid.t; 83 | at_length: Int64.t; 84 | at_obsolete:bool; 85 | at_single_value:bool; 86 | at_collective:bool; 87 | at_no_user_modification:bool; 88 | at_usage:string; 89 | at_sup:Lcstring.t list; 90 | at_xattr:string list};; 91 | 92 | type schema = {objectclasses: (Lcstring.t, objectclass) Hashtbl.t; 93 | objectclasses_byoid: (Oid.t, objectclass) Hashtbl.t; 94 | attributes: (Lcstring.t, attribute) Hashtbl.t; 95 | attributes_byoid: (Oid.t, attribute) Hashtbl.t};; 96 | 97 | exception Depth 98 | 99 | let schema_print_depth = ref 10 100 | let format_schema s = 101 | let indent = 3 in 102 | let printtbl tbl = 103 | let i = ref 0 in 104 | try 105 | Hashtbl.iter 106 | (fun aname _aval -> 107 | if !i < !schema_print_depth then begin 108 | Format.print_string (""); 109 | Format.print_break 1 indent; 110 | i := !i + 1 111 | end 112 | else raise Depth) 113 | tbl 114 | with Depth -> Format.print_string "..." 115 | in 116 | Format.open_box 0; 117 | Format.print_string "{objectclasses = ;"; 121 | Format.print_break 0 1; 122 | Format.print_string "objectclasses_byoid = ;"; 123 | Format.print_break 0 1; 124 | Format.print_string "attributes = ;"; 128 | Format.print_break 0 1; 129 | Format.print_string "attributes_byoid = }"; 130 | Format.close_box () 131 | 132 | exception Parse_error_oc of Lexing.lexbuf * objectclass * string;; 133 | exception Parse_error_at of Lexing.lexbuf * attribute * string;; 134 | exception Syntax_error_oc of Lexing.lexbuf * objectclass * string;; 135 | exception Syntax_error_at of Lexing.lexbuf * attribute * string;; 136 | 137 | let readSchema oclst attrlst = 138 | let empty_oc = {oc_name=[];oc_oid=Oid.of_string "";oc_desc="";oc_obsolete=false;oc_sup=[]; 139 | oc_must=[];oc_may=[];oc_type=Abstract;oc_xattr=[]} 140 | in 141 | let empty_attr = {at_name=[];at_oid=Oid.of_string "";at_desc="";at_equality="";at_ordering=""; 142 | at_usage=""; at_substr=Oid.of_string "";at_syntax=Oid.of_string ""; 143 | at_length=0L;at_obsolete=false;at_single_value=false; 144 | at_collective=false;at_no_user_modification=false;at_sup=[];at_xattr=[]} 145 | in 146 | let readOc lxbuf oc = 147 | let rec readOptionalFields lxbuf oc = 148 | try match (lexoc lxbuf) with 149 | Name s -> readOptionalFields lxbuf {oc with oc_name=s} 150 | | Desc s -> readOptionalFields lxbuf {oc with oc_desc=s} 151 | | Obsolete -> readOptionalFields lxbuf {oc with oc_obsolete=true} 152 | | Sup s -> (readOptionalFields 153 | lxbuf 154 | {oc with oc_sup=(List.rev_map (Lcstring.of_string) s)}) 155 | | Ldap_schemalexer.Abstract -> readOptionalFields lxbuf {oc with oc_type=Abstract} 156 | | Ldap_schemalexer.Structural -> readOptionalFields lxbuf {oc with oc_type=Structural} 157 | | Ldap_schemalexer.Auxiliary -> readOptionalFields lxbuf {oc with oc_type=Auxiliary} 158 | | Must s -> (readOptionalFields 159 | lxbuf 160 | {oc with oc_must=(List.rev_map (Lcstring.of_string) s)}) 161 | | May s -> (readOptionalFields 162 | lxbuf 163 | {oc with oc_may=(List.rev_map (Lcstring.of_string) s)}) 164 | | Xstring t -> (readOptionalFields 165 | lxbuf 166 | {oc with oc_xattr=(t :: oc.oc_xattr)}) 167 | | Rparen -> oc 168 | | _ -> raise (Parse_error_oc (lxbuf, oc, "unexpected token")) 169 | with Failure(_) -> raise (Parse_error_oc (lxbuf, oc, "Expected right parenthesis")) 170 | in 171 | let readOid lxbuf oc = 172 | try match (lexoc lxbuf) with 173 | Numericoid(s) -> readOptionalFields lxbuf {oc with oc_oid=Oid.of_string s} 174 | | _ -> raise (Parse_error_oc (lxbuf, oc, "missing required field, numericoid")) 175 | with Failure(_) -> raise (Syntax_error_oc (lxbuf, oc, "Syntax error")) 176 | in 177 | let readLparen lxbuf oc = 178 | try match (lexoc lxbuf) with 179 | Lparen -> readOid lxbuf oc 180 | | _ -> raise (Parse_error_oc (lxbuf, oc, "Expected left paren")) 181 | with Failure(_) -> raise (Syntax_error_oc (lxbuf, oc, "Syntax error")) 182 | in 183 | readLparen lxbuf oc 184 | in 185 | let rec readOcs oclst schema = 186 | match oclst with 187 | a :: l -> let oc = readOc (Lexing.from_string a) empty_oc in 188 | List.iter (fun n -> Hashtbl.add schema.objectclasses (Lcstring.of_string n) oc) oc.oc_name; 189 | Hashtbl.add schema.objectclasses_byoid oc.oc_oid oc;readOcs l schema 190 | | [] -> () 191 | in 192 | let readAttr lxbuf attr = 193 | let rec readOptionalFields lxbuf attr = 194 | try match (lexattr lxbuf) with 195 | Name s -> readOptionalFields lxbuf {attr with at_name=s} 196 | | Desc s -> readOptionalFields lxbuf {attr with at_desc=s} 197 | | Obsolete -> readOptionalFields lxbuf {attr with at_obsolete=true} 198 | | Sup s -> 199 | readOptionalFields lxbuf {attr with at_sup=(List.rev_map (Lcstring.of_string) s)} 200 | | Equality s -> readOptionalFields lxbuf {attr with at_equality=s} 201 | | Substr s -> readOptionalFields lxbuf {attr with at_substr=Oid.of_string s} 202 | | Ordering s -> readOptionalFields lxbuf {attr with at_ordering=s} 203 | | Syntax (s, l) -> 204 | readOptionalFields lxbuf {attr with at_syntax=Oid.of_string s;at_length=l} 205 | | Single_value -> readOptionalFields lxbuf {attr with at_single_value=true} 206 | | Collective -> readOptionalFields lxbuf {attr with at_collective=true} 207 | | No_user_modification -> readOptionalFields lxbuf {attr with at_no_user_modification=true} 208 | | Usage s -> readOptionalFields lxbuf {attr with at_usage=s} 209 | | Rparen -> attr 210 | | Xstring t -> (readOptionalFields 211 | lxbuf 212 | {attr with at_xattr=(t :: attr.at_xattr)}) 213 | | _ -> raise (Parse_error_at (lxbuf, attr, "unexpected token")) 214 | with Failure(f) -> raise (Parse_error_at (lxbuf, attr, f)) 215 | in 216 | let readOid lxbuf attr = 217 | try match (lexoc lxbuf) with 218 | Numericoid(s) -> readOptionalFields lxbuf {attr with at_oid=Oid.of_string s} 219 | | _ -> raise (Parse_error_at (lxbuf, attr, "missing required field, numericoid")) 220 | with Failure(_) -> raise (Syntax_error_at (lxbuf, attr, "Syntax error")) 221 | in 222 | let readLparen lxbuf attr = 223 | try match (lexoc lxbuf) with 224 | Lparen -> readOid lxbuf attr 225 | | _ -> raise (Parse_error_at (lxbuf, attr, "Expected left paren")) 226 | with Failure(_) -> raise (Syntax_error_at (lxbuf, attr, "Syntax error")) 227 | in 228 | readLparen lxbuf attr 229 | in 230 | let rec readAttrs attrlst schema = 231 | match attrlst with 232 | a :: l -> let attr = readAttr (Lexing.from_string a) empty_attr in 233 | List.iter (fun n -> Hashtbl.add schema.attributes (Lcstring.of_string n) attr) attr.at_name; 234 | Hashtbl.add schema.attributes_byoid attr.at_oid attr;readAttrs l schema 235 | | [] -> () 236 | in 237 | let schema = {objectclasses=Hashtbl.create 500; 238 | objectclasses_byoid=Hashtbl.create 500; 239 | attributes=Hashtbl.create 5000; 240 | attributes_byoid=Hashtbl.create 5000} in 241 | readAttrs attrlst schema; 242 | readOcs oclst schema; 243 | schema;; 244 | -------------------------------------------------------------------------------- /src/ldap/ldap_schemaparser.mli: -------------------------------------------------------------------------------- 1 | (** A library for parsing rfc2252 schemas as returned by directory 2 | servers *) 3 | 4 | module Oid : 5 | sig 6 | type t 7 | val of_string : string -> t 8 | val to_string : t -> string 9 | val compare : t -> t -> int 10 | end 11 | 12 | val format_oid : Oid.t -> unit 13 | 14 | module Lcstring : 15 | sig 16 | type t 17 | val of_string : string -> t 18 | val to_string : t -> string 19 | val compare : t -> t -> int 20 | end 21 | 22 | val format_lcstring : Lcstring.t -> unit 23 | 24 | type octype = Abstract | Structural | Auxiliary 25 | 26 | (** The type representing an objectclass definition *) 27 | type objectclass = { 28 | oc_name : string list; 29 | oc_oid : Oid.t; 30 | oc_desc : string; 31 | oc_obsolete : bool; 32 | oc_sup : Lcstring.t list; 33 | oc_must : Lcstring.t list; 34 | oc_may : Lcstring.t list; 35 | oc_type : octype; 36 | oc_xattr : string list; 37 | } 38 | 39 | (** The type representing an attribute definition *) 40 | type attribute = { 41 | at_name : string list; 42 | at_desc : string; 43 | at_oid : Oid.t; 44 | at_equality : string; 45 | at_ordering : string; 46 | at_substr : Oid.t; 47 | at_syntax : Oid.t; 48 | at_length : Int64.t; 49 | at_obsolete : bool; 50 | at_single_value : bool; 51 | at_collective : bool; 52 | at_no_user_modification : bool; 53 | at_usage : string; 54 | at_sup : Lcstring.t list; 55 | at_xattr : string list; 56 | } 57 | 58 | (** The type representing the whole schema. Consists of hashtbls 59 | indexed by two useful keys. For both attributes and objectclasses 60 | there exists a hashtbl indexed by OID, and one indexed by lower case 61 | canonical name. There exist functions in Ldap_ooclient to look up 62 | attributes and objectclasses by non canonical names if that is 63 | necessary for you to do. see attrToOid, and ocToOid. They will find 64 | the oid of an attribute or objectclass given any name, not just the 65 | canonical one. Not that this is somewhat (like several orders of 66 | magnitude) slower than lookups by canonical name.*) 67 | type schema = { 68 | objectclasses : (Lcstring.t, objectclass) Hashtbl.t; 69 | objectclasses_byoid : (Oid.t, objectclass) Hashtbl.t; 70 | attributes : (Lcstring.t, attribute) Hashtbl.t; 71 | attributes_byoid : (Oid.t, attribute) Hashtbl.t; 72 | } 73 | 74 | (** This reference controls the dept of printing for the schema in the 75 | toplevel. The default is 10 keys from each table will be printed. OID 76 | tables are not currently printed. *) 77 | val schema_print_depth : int ref 78 | 79 | (** A formatter for the schema, prints the structure, and expands the 80 | hashtbls to show the keys. The number of keys printed is controled by 81 | schema_print_depth. *) 82 | val format_schema : schema -> unit 83 | 84 | exception Parse_error_oc of Lexing.lexbuf * objectclass * string 85 | exception Parse_error_at of Lexing.lexbuf * attribute * string 86 | exception Syntax_error_oc of Lexing.lexbuf * objectclass * string 87 | exception Syntax_error_at of Lexing.lexbuf * attribute * string 88 | 89 | (** readSchema attribute_list objectclass_list, parse the schema into 90 | a schema type given a list of attribute definition lines, and 91 | objectclass definition lines. *) 92 | val readSchema : string list -> string list -> schema 93 | -------------------------------------------------------------------------------- /src/ldap/ldap_txooclient.ml: -------------------------------------------------------------------------------- 1 | open Ldap_mutex 2 | open Ldap_ooclient 3 | open Ldap_types 4 | 5 | type txn = { 6 | mutable dead: bool; 7 | entries: (string, (ldapentry_t * ldapentry_t)) Hashtbl.t 8 | } 9 | 10 | exception Rollback of exn * ((ldapentry_t * ldapentry_t) list) 11 | exception Txn_commit_failure of string * exn * ldapentry_t list option 12 | exception Txn_rollback_failure of string * exn 13 | 14 | class ldapadvisorytxcon 15 | ?(connect_timeout=1) 16 | ?(referral_policy=`RETURN) 17 | ?(version = 3) 18 | hosts binddn bindpw mutextbldn = 19 | let copy_entry entry = 20 | let new_entry = new ldapentry in 21 | new_entry#set_dn (entry#dn); 22 | List.iter 23 | (fun attr -> new_entry#add [(attr, entry#get_value attr)]) 24 | entry#attributes; 25 | new_entry 26 | in 27 | object (self) 28 | inherit ldapcon ~connect_timeout ~referral_policy ~version hosts as super 29 | initializer 30 | super#bind binddn ~cred:bindpw 31 | 32 | val lock_table = new object_lock_table hosts binddn bindpw mutextbldn 33 | 34 | method private check_dead txn = 35 | if txn.dead then 36 | raise 37 | (LDAP_Failure 38 | (`LOCAL_ERROR, 39 | "this transaction is dead, create a new one", 40 | {ext_matched_dn="";ext_referral=None})) 41 | 42 | method begin_txn = {dead=false;entries=Hashtbl.create 1} 43 | 44 | method associate_entry txn (entry: ldapentry_t) = 45 | self#check_dead txn; 46 | let dn = Ldap_dn.canonical_dn entry#dn in 47 | if Hashtbl.mem txn.entries dn then 48 | raise 49 | (LDAP_Failure 50 | (`LOCAL_ERROR, 51 | "dn: " ^ dn ^ " is already part of this transaction", 52 | {ext_matched_dn="";ext_referral=None})) 53 | else 54 | if entry#changes = [] then begin 55 | lock_table#lock (Ldap_dn.of_string dn); 56 | Hashtbl.add txn.entries dn ((copy_entry entry), (entry :> ldapentry_t)) 57 | end else 58 | raise 59 | (LDAP_Failure 60 | (`LOCAL_ERROR, 61 | "this entry has been changed since it was downloaded " ^ 62 | "commit your current changes, and then add the entry to " ^ 63 | "this transaction", 64 | {ext_matched_dn="";ext_referral=None})) 65 | 66 | method associate_entries txn entries = 67 | List.iter (self#associate_entry txn) entries 68 | 69 | method disassociate_entry txn (entry: ldapentry_t) = 70 | self#check_dead txn; 71 | let dn = Ldap_dn.canonical_dn entry#dn in 72 | if Hashtbl.mem txn.entries dn then begin 73 | Hashtbl.remove txn.entries dn; 74 | lock_table#unlock (Ldap_dn.of_string dn); 75 | end else 76 | raise 77 | (LDAP_Failure 78 | (`LOCAL_ERROR, 79 | "dn: " ^ dn ^ " is not part of this transaction", 80 | {ext_matched_dn="";ext_referral=None})) 81 | 82 | method disassociate_entries txn entries = 83 | List.iter (self#disassociate_entry txn) entries 84 | 85 | method commit_txn txn = 86 | self#check_dead txn; 87 | txn.dead <- true; 88 | try 89 | List.iter 90 | (fun (_, e) -> lock_table#unlock (Ldap_dn.of_string e#dn)) 91 | (Hashtbl.fold 92 | (fun _k (original_entry, modified_entry) successful_so_far -> 93 | try 94 | (match modified_entry#changetype with 95 | `MODIFY -> super#update_entry modified_entry 96 | | `ADD -> super#add modified_entry 97 | | `DELETE -> super#delete modified_entry#dn 98 | | `MODRDN -> 99 | super#modrdn 100 | original_entry#dn 101 | (Ldap_dn.to_string 102 | [(List.hd 103 | (Ldap_dn.of_string modified_entry#dn))]) 104 | | `MODDN -> 105 | let dn = Ldap_dn.of_string modified_entry#dn in 106 | super#modrdn 107 | original_entry#dn 108 | (Ldap_dn.to_string [List.hd dn]) 109 | ~newsup:(Some (Ldap_dn.to_string (List.tl dn)))); 110 | (original_entry, modified_entry) :: successful_so_far 111 | with exn -> 112 | raise (Rollback (exn, successful_so_far))) 113 | txn.entries 114 | []) 115 | with Rollback (exn, successful_so_far) -> 116 | (Hashtbl.iter (fun _k (_, e) -> e#flush_changes) txn.entries); 117 | (match 118 | ((Hashtbl.iter (* rollback everything in memory *) 119 | (fun _k (original_entry, modified_entry) -> 120 | match modified_entry#changetype with 121 | `MODIFY -> modified_entry#modify (original_entry#diff modified_entry) 122 | | `ADD -> () 123 | | `DELETE -> () 124 | | `MODRDN -> 125 | if not (List.mem (original_entry, modified_entry) successful_so_far) then 126 | modified_entry#set_dn original_entry#dn 127 | | `MODDN -> 128 | if not (List.mem (original_entry, modified_entry) successful_so_far) then 129 | modified_entry#set_dn original_entry#dn) 130 | txn.entries); 131 | (List.fold_left (* rollback in the directory only what we commited *) 132 | (fun not_rolled_back (original_entry, modified_entry) -> 133 | try 134 | (match modified_entry#changetype with 135 | `MODIFY -> super#update_entry modified_entry 136 | | `ADD -> super#delete modified_entry#dn 137 | | `DELETE -> super#add modified_entry 138 | | `MODRDN -> 139 | super#modrdn 140 | (modified_entry#dn) 141 | (Ldap_dn.to_string 142 | [List.hd (Ldap_dn.of_string original_entry#dn)]) 143 | | `MODDN -> 144 | super#modrdn 145 | (modified_entry#dn) 146 | (Ldap_dn.to_string 147 | [List.hd (Ldap_dn.of_string original_entry#dn)]) 148 | ~newsup:(Some 149 | (Ldap_dn.to_string 150 | (List.tl 151 | (Ldap_dn.of_string 152 | original_entry#dn))))); 153 | not_rolled_back 154 | with _ -> modified_entry :: not_rolled_back) 155 | [] 156 | successful_so_far)) 157 | with 158 | [] -> 159 | Hashtbl.iter 160 | (fun _k (e, _) -> lock_table#unlock (Ldap_dn.of_string e#dn)) 161 | txn.entries; 162 | (Hashtbl.iter (fun _k (_, e) -> e#flush_changes) txn.entries); 163 | raise (Txn_commit_failure ("rollback successful", exn, None)) 164 | | not_rolled_back -> 165 | Hashtbl.iter 166 | (fun _k (e, _) -> lock_table#unlock (Ldap_dn.of_string e#dn)) 167 | txn.entries; 168 | (Hashtbl.iter (fun _k (_, e) -> e#flush_changes) txn.entries); 169 | raise 170 | (Txn_commit_failure 171 | ("rollback failed", exn, 172 | Some not_rolled_back))) 173 | 174 | method rollback_txn txn = 175 | txn.dead <- true; 176 | Hashtbl.iter 177 | (fun _k (original_entry, modified_entry) -> 178 | try 179 | lock_table#unlock (Ldap_dn.of_string original_entry#dn); 180 | modified_entry#modify (original_entry#diff modified_entry); 181 | modified_entry#flush_changes 182 | with exn -> raise (Txn_rollback_failure ("rollback failed", exn))) 183 | txn.entries 184 | end 185 | -------------------------------------------------------------------------------- /src/ldap/ldap_txooclient.mli: -------------------------------------------------------------------------------- 1 | open Ldap_ooclient 2 | 3 | (** the abstract type of a transaction *) 4 | type txn 5 | 6 | (** raised when a commit fails, contains a list of entries which were 7 | not rolled back successfully only if rollback failed as well, 8 | otherwise None *) 9 | exception Txn_commit_failure of string * exn * ldapentry_t list option 10 | 11 | (** raised when an explicit rollback fails *) 12 | exception Txn_rollback_failure of string * exn 13 | 14 | (** A subclass of ldapcon which implements an experimental interface 15 | to draft_zeilenga_ldap_txn. A draft standard for multi object 16 | transactions over the ldap protocol. This class can only implement 17 | advisory transactions because it must depend on the advisory 18 | locking mechanisms for the transactions to be consistant. You use 19 | this class by calling begin_txn to get a transaction id, and then 20 | associating a set of ldapentry objects with the transaction by 21 | calling associate_entry_with_txn. You are then free to modify 22 | those entries in any way you like, and when you are done, you can 23 | either call commit_txn, or rollback_txn. Commit will commit the 24 | changes of all the entries associated with the transaction to the 25 | database. For other writers which obey advisory locking the commit 26 | operation is atomic. For readers which are willing to obey 27 | advisory locking is atomic. If the commit fails, a full rollback 28 | occurrs, including all changes made to the directory. For example 29 | in a set of N entries in a transaction, if the modificiation of 30 | the nth entry fails to commit, then the modifications to all the 31 | previous entries, which have already been made in the directory, 32 | are undone. It is important to note that if advisory locking is 33 | not obeyed, rollback may not be successful. Rollback undoes all 34 | the changes you've made in memory, and unlocks all the objects in 35 | the transaction. After a transaction object has been commited or 36 | rolled back it is considered "dead", and cannot be used again. *) 37 | class ldapadvisorytxcon : 38 | ?connect_timeout:int -> 39 | ?referral_policy:[> `RETURN ] -> 40 | ?version:int -> 41 | string list -> string -> string -> string -> (* hosts binddn bindpw mutextbldn *) 42 | object 43 | method add : ldapentry -> unit 44 | method bind : 45 | ?cred:string -> ?meth:Ldap_funclient.authmethod -> string -> unit 46 | method delete : string -> unit 47 | method modify : 48 | string -> 49 | (Ldap_types.modify_optype * string * string list) list -> unit 50 | method modrdn : string -> ?deleteoldrdn:bool -> ?newsup:string option -> string -> unit 51 | method rawschema : ldapentry 52 | method schema : Ldap_schemaparser.schema 53 | method search : 54 | ?scope:Ldap_types.search_scope -> 55 | ?attrs:string list -> 56 | ?attrsonly:bool -> ?base:string -> 57 | ?sizelimit:Int32.t -> ?timelimit:Int32.t -> 58 | string -> ldapentry list 59 | method search_a : 60 | ?scope:Ldap_types.search_scope -> 61 | ?attrs:string list -> 62 | ?attrsonly:bool -> ?base:string -> 63 | ?sizelimit:Int32.t -> ?timelimit:Int32.t -> 64 | string -> (?abandon:bool -> unit -> ldapentry) 65 | method unbind : unit 66 | method update_entry : ldapentry -> unit 67 | method begin_txn : txn 68 | method associate_entry : txn -> ldapentry_t -> unit 69 | method associate_entries : txn -> ldapentry_t list -> unit 70 | method disassociate_entry : txn -> ldapentry_t -> unit 71 | method disassociate_entries : txn -> ldapentry_t list -> unit 72 | method commit_txn : txn -> unit 73 | method rollback_txn : txn -> unit 74 | end 75 | -------------------------------------------------------------------------------- /src/ldap/ldap_types.ml: -------------------------------------------------------------------------------- 1 | (* Common data types from rfc 2251 used throughout the library 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University 4 | at Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | (** Common data types used by ocamldap. Most of these types are taken 23 | from the ASN.1 specification for LDAP as defined in rfc2251 @see 24 | rfc2251*) 25 | 26 | (** An encoding error has occurred, the argument contains a 27 | description of the error This is likely a bug, so it should be 28 | reported *) 29 | exception LDAP_Encoder of string 30 | 31 | (** A decoding error has occurred, the argument contains a description 32 | of the error. This MAY be a bug, but it may also be that the server 33 | you are talking to is non standard. Please report these right away in 34 | any case.*) 35 | exception LDAP_Decoder of string 36 | 37 | type ldap_resultcode = [ 38 | `SUCCESS 39 | | `OPERATIONS_ERROR 40 | | `PROTOCOL_ERROR 41 | | `TIMELIMIT_EXCEEDED 42 | | `SIZELIMIT_EXCEEDED 43 | | `COMPARE_FALSE 44 | | `COMPARE_TRUE 45 | | `AUTH_METHOD_NOT_SUPPORTED 46 | | `STRONG_AUTH_REQUIRED 47 | | `REFERRAL 48 | | `ADMINLIMIT_EXCEEDED 49 | | `UNAVAILABLE_CRITICAL_EXTENSION 50 | | `CONFIDENTIALITY_REQUIRED 51 | | `SASL_BIND_IN_PROGRESS 52 | | `NO_SUCH_ATTRIBUTE 53 | | `UNDEFINED_TYPE 54 | | `INAPPROPRIATE_MATCHING 55 | | `CONSTRAINT_VIOLATION 56 | | `TYPE_OR_VALUE_EXISTS 57 | | `INVALID_SYNTAX 58 | | `NO_SUCH_OBJECT 59 | | `ALIAS_PROBLEM 60 | | `INVALID_DN_SYNTAX 61 | | `IS_LEAF 62 | | `ALIAS_DEREF_PROBLEM 63 | | `INAPPROPRIATE_AUTH 64 | | `INVALID_CREDENTIALS 65 | | `INSUFFICIENT_ACCESS 66 | | `BUSY 67 | | `UNAVAILABLE 68 | | `UNWILLING_TO_PERFORM 69 | | `LOOP_DETECT 70 | | `NAMING_VIOLATION 71 | | `OBJECT_CLASS_VIOLATION 72 | | `NOT_ALLOWED_ON_NONLEAF 73 | | `NOT_ALLOWED_ON_RDN 74 | | `ALREADY_EXISTS 75 | | `NO_OBJECT_CLASS_MODS 76 | | `AFFECTS_MULTIPLE_DSAS 77 | | `OTHER 78 | | `SERVER_DOWN 79 | | `LOCAL_ERROR 80 | | `ENCODING_ERROR 81 | | `DECODING_ERROR 82 | | `TIMEOUT 83 | | `AUTH_UNKNOWN 84 | | `FILTER_ERROR 85 | | `USER_CANCELLED 86 | | `PARAM_ERROR 87 | | `NO_MEMORY 88 | | `CONNECT_ERROR 89 | | `NOT_SUPPORTED 90 | | `CONTROL_NOT_FOUND 91 | | `NO_RESULTS_RETURNED 92 | | `MORE_RESULTS_TO_RETURN 93 | | `CLIENT_LOOP 94 | | `REFERRAL_LIMIT_EXCEEDED 95 | | `UNKNOWN_ERROR of int ] 96 | 97 | type ldap_result = { 98 | result_code: ldap_resultcode; 99 | matched_dn: string; 100 | error_message: string; 101 | ldap_referral: (string list) option; 102 | } 103 | 104 | (** extended information to return with the LDAP_Failure 105 | exception. Contains the remaining values which are defined by the 106 | protocol ext_matched_dn: the matched dn. Commonly set by 107 | `NO_SUCH_OBJECT. ext_referral: a list of ldapurls returned by the 108 | server when you attempted to do a write operation. If you use 109 | Ldap_ooclient with referrals set to follow you will never see this*) 110 | type ldap_ext_return = { 111 | ext_matched_dn: string; 112 | ext_referral: string list option; 113 | } 114 | 115 | (** The exception raised to indicate all types of failure in the 116 | higher level libraries Ldap_funclient, and Ldap_ooclient. example 117 | [LDAP_Failure (`NO_SUCH_OBJECT, "no such object", 118 | {ext_matched_dn=Some "o=csun";ext_referral=None})] *) 119 | exception LDAP_Failure of ldap_resultcode * string * ldap_ext_return 120 | 121 | type saslCredentials = { 122 | sasl_mechanism: string; 123 | sasl_credentials: string option; 124 | } 125 | 126 | type authentication = Simple of string 127 | | Sasl of saslCredentials 128 | 129 | type bind_request = { 130 | bind_version: int; 131 | bind_name: string; 132 | bind_authentication: authentication; 133 | } 134 | 135 | type bind_response = { 136 | bind_result: ldap_result; 137 | bind_serverSaslCredentials: string option; 138 | } 139 | 140 | type attribute = { 141 | attr_type: string; 142 | attr_vals: string list; 143 | } 144 | 145 | type dn = attribute list 146 | 147 | (** the type used to encode and decode a search entry. Also the type 148 | returned by search_s and search_a in Ldap_funclient *) 149 | type search_result_entry = { 150 | sr_dn: string; 151 | sr_attributes: attribute list; 152 | } 153 | 154 | (** a type defining the scope of a search filter *) 155 | type search_scope = [ `BASE (** search only at the base *) 156 | | `ONELEVEL (** search one level below the base *) 157 | | `SUBTREE (** search the entire tree under the base *)] 158 | 159 | type alias_deref = [ `NEVERDEREFALIASES 160 | | `DEREFINSEARCHING 161 | | `DEREFFINDINGBASE 162 | | `DEREFALWAYS ] 163 | 164 | type attribute_value_assertion = { 165 | attributeDesc: string; 166 | assertionValue: string; 167 | } 168 | 169 | type matching_rule_assertion = { 170 | matchingRule: string option; 171 | ruletype: string option; 172 | matchValue: string; 173 | dnAttributes: bool; (* default false *) 174 | } 175 | 176 | type substring_component = { (* at least one must be specified *) 177 | substr_initial: string list; 178 | substr_any: string list; 179 | substr_final: string list; 180 | } 181 | 182 | type substring_filter = { 183 | attrtype: string; 184 | substrings: substring_component; 185 | } 186 | 187 | type filter = [ `And of filter list 188 | | `Or of filter list 189 | | `Not of filter 190 | | `EqualityMatch of attribute_value_assertion 191 | | `Substrings of substring_filter 192 | | `GreaterOrEqual of attribute_value_assertion 193 | | `LessOrEqual of attribute_value_assertion 194 | | `Present of string 195 | | `ApproxMatch of attribute_value_assertion 196 | | `ExtensibleMatch of matching_rule_assertion ] 197 | 198 | type search_request = { 199 | baseObject: string; 200 | scope: search_scope; 201 | derefAliases: alias_deref; 202 | sizeLimit: int32; 203 | timeLimit: int32; 204 | typesOnly: bool; 205 | filter: filter; 206 | s_attributes: string list; 207 | } 208 | 209 | type modify_optype = [ `ADD 210 | | `DELETE 211 | | `REPLACE ] 212 | 213 | type modify_op = { 214 | mod_op: modify_optype; 215 | mod_value: attribute; 216 | } 217 | 218 | type modify_request = { 219 | mod_dn: string; 220 | modification: modify_op list 221 | } 222 | 223 | type modify_dn_request = { 224 | modn_dn: string; 225 | modn_newrdn: string; 226 | modn_deleteoldrdn: bool; 227 | modn_newSuperior: string option 228 | } 229 | 230 | type compare_request = { 231 | cmp_dn: string; 232 | cmp_ava: attribute_value_assertion; 233 | } 234 | 235 | type extended_request = { 236 | ext_requestName: string; 237 | ext_requestValue: string option; 238 | } 239 | 240 | type extended_response = { 241 | ext_result: ldap_result; 242 | ext_responseName: string option; 243 | ext_response: string option; 244 | } 245 | 246 | type protocol_op = Bind_request of bind_request 247 | | Bind_response of bind_response 248 | | Unbind_request 249 | | Search_request of search_request 250 | | Search_result_entry of search_result_entry 251 | | Search_result_reference of string list 252 | | Search_result_done of ldap_result 253 | | Modify_request of modify_request 254 | | Modify_response of ldap_result 255 | | Add_request of search_result_entry 256 | | Add_response of ldap_result 257 | | Delete_request of string 258 | | Delete_response of ldap_result 259 | | Modify_dn_request of modify_dn_request 260 | | Modify_dn_response of ldap_result 261 | | Compare_request of compare_request 262 | | Compare_response of ldap_result 263 | | Abandon_request of Int32.t 264 | | Extended_request of extended_request 265 | | Extended_response of extended_response 266 | 267 | type paged_results_control_value = { 268 | size: int; 269 | cookie: string; 270 | } 271 | 272 | type control_details = 273 | [`Paged_results_control of paged_results_control_value 274 | |`Unknown_value of string ] 275 | 276 | type ldap_control = { 277 | criticality: bool; 278 | control_details: control_details; 279 | } 280 | 281 | type ldap_controls = ldap_control list 282 | 283 | type ldap_message = { 284 | messageID: Int32.t; 285 | protocolOp: protocol_op; 286 | controls: ldap_controls option; 287 | } 288 | 289 | type con_mech = [ `SSL 290 | | `PLAIN ] 291 | 292 | type ldap_url = { 293 | url_mech: con_mech; 294 | url_host: string option; 295 | url_port: string option; 296 | url_dn: string option; 297 | url_attributes: (string list) option; 298 | url_scope: search_scope option; 299 | url_filter: filter option; 300 | url_ext: ((bool * string * string) list) option; 301 | } 302 | 303 | (** see draft-zeilenga-ldap-grouping-xx Ldap grouping is a way of 304 | telling the server that a set of ldap operations is related, its most 305 | interesting application is transactions across multiple objects. 306 | This draft is not yet implemented by any present day ldap server *) 307 | type ldap_grouping_type = [ `LDAP_GROUP_TXN ] 308 | 309 | (** a cookie that is sent with every ldap operation which is part of a 310 | group *) 311 | type ldap_grouping_cookie 312 | -------------------------------------------------------------------------------- /src/ldap/ldap_types.mli: -------------------------------------------------------------------------------- 1 | (* Common data types from rfc 2251 used throughout the library 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University 4 | at Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | (** Common data types used by ocamldap. Most of these types are taken 23 | from the ASN.1 specification for LDAP as defined in rfc2251 24 | @see rfc2251 *) 25 | 26 | (** An encoding error has occurred, the argument contains a 27 | description of the error This is likely a bug, so it should be 28 | reported *) 29 | exception LDAP_Encoder of string 30 | 31 | (** A decoding error has occurred, the argument contains a description 32 | of the error. This MAY be a bug, but it may also be that the server 33 | you are talking to is non standard. Please report these right away in 34 | any case.*) 35 | exception LDAP_Decoder of string 36 | 37 | type ldap_resultcode = [ 38 | `SUCCESS 39 | | `OPERATIONS_ERROR 40 | | `PROTOCOL_ERROR 41 | | `TIMELIMIT_EXCEEDED 42 | | `SIZELIMIT_EXCEEDED 43 | | `COMPARE_FALSE 44 | | `COMPARE_TRUE 45 | | `AUTH_METHOD_NOT_SUPPORTED 46 | | `STRONG_AUTH_REQUIRED 47 | | `REFERRAL 48 | | `ADMINLIMIT_EXCEEDED 49 | | `UNAVAILABLE_CRITICAL_EXTENSION 50 | | `CONFIDENTIALITY_REQUIRED 51 | | `SASL_BIND_IN_PROGRESS 52 | | `NO_SUCH_ATTRIBUTE 53 | | `UNDEFINED_TYPE 54 | | `INAPPROPRIATE_MATCHING 55 | | `CONSTRAINT_VIOLATION 56 | | `TYPE_OR_VALUE_EXISTS 57 | | `INVALID_SYNTAX 58 | | `NO_SUCH_OBJECT 59 | | `ALIAS_PROBLEM 60 | | `INVALID_DN_SYNTAX 61 | | `IS_LEAF 62 | | `ALIAS_DEREF_PROBLEM 63 | | `INAPPROPRIATE_AUTH 64 | | `INVALID_CREDENTIALS 65 | | `INSUFFICIENT_ACCESS 66 | | `BUSY 67 | | `UNAVAILABLE 68 | | `UNWILLING_TO_PERFORM 69 | | `LOOP_DETECT 70 | | `NAMING_VIOLATION 71 | | `OBJECT_CLASS_VIOLATION 72 | | `NOT_ALLOWED_ON_NONLEAF 73 | | `NOT_ALLOWED_ON_RDN 74 | | `ALREADY_EXISTS 75 | | `NO_OBJECT_CLASS_MODS 76 | | `AFFECTS_MULTIPLE_DSAS 77 | | `OTHER 78 | | `SERVER_DOWN 79 | | `LOCAL_ERROR 80 | | `ENCODING_ERROR 81 | | `DECODING_ERROR 82 | | `TIMEOUT 83 | | `AUTH_UNKNOWN 84 | | `FILTER_ERROR 85 | | `USER_CANCELLED 86 | | `PARAM_ERROR 87 | | `NO_MEMORY 88 | | `CONNECT_ERROR 89 | | `NOT_SUPPORTED 90 | | `CONTROL_NOT_FOUND 91 | | `NO_RESULTS_RETURNED 92 | | `MORE_RESULTS_TO_RETURN 93 | | `CLIENT_LOOP 94 | | `REFERRAL_LIMIT_EXCEEDED 95 | | `UNKNOWN_ERROR of int ] 96 | 97 | type ldap_result = { 98 | result_code: ldap_resultcode; 99 | matched_dn: string; 100 | error_message: string; 101 | ldap_referral: (string list) option; 102 | } 103 | 104 | (** extended information to return with the LDAP_Failure 105 | exception. Contains the remaining values which are defined by the 106 | protocol ext_matched_dn: the matched dn. Commonly set by 107 | `NO_SUCH_OBJECT. ext_referral: a list of ldapurls returned by the 108 | server when you attempted to do a write operation. If you use 109 | Ldap_ooclient with referrals set to follow you will never see this*) 110 | type ldap_ext_return = { 111 | ext_matched_dn: string; 112 | ext_referral: string list option; 113 | } 114 | 115 | (** The exception raised to indicate all types of failure in the 116 | higher level libraries Ldap_funclient, and Ldap_ooclient. example 117 | [LDAP_Failure (`NO_SUCH_OBJECT, "no such object", 118 | {ext_matched_dn=Some "o=csun";ext_referral=None})] *) 119 | exception LDAP_Failure of ldap_resultcode * string * ldap_ext_return 120 | 121 | type saslCredentials = { 122 | sasl_mechanism: string; 123 | sasl_credentials: string option; 124 | } 125 | 126 | type authentication = Simple of string 127 | | Sasl of saslCredentials 128 | 129 | type bind_request = { 130 | bind_version: int; 131 | bind_name: string; 132 | bind_authentication: authentication; 133 | } 134 | 135 | type bind_response = { 136 | bind_result: ldap_result; 137 | bind_serverSaslCredentials: string option; 138 | } 139 | 140 | type attribute = { 141 | attr_type: string; 142 | attr_vals: string list; 143 | } 144 | 145 | type dn = attribute list 146 | 147 | (** the type used to encode and decode a search entry. Also the type 148 | returned by search_s and search_a in Ldap_funclient *) 149 | type search_result_entry = { 150 | sr_dn: string; 151 | sr_attributes: attribute list; 152 | } 153 | 154 | (** a type defining the scope of a search filter *) 155 | type search_scope = [ `BASE (** search only at the base *) 156 | | `ONELEVEL (** search one level below the base *) 157 | | `SUBTREE (** search the entire tree under the base *)] 158 | 159 | type alias_deref = [ `NEVERDEREFALIASES 160 | | `DEREFINSEARCHING 161 | | `DEREFFINDINGBASE 162 | | `DEREFALWAYS ] 163 | 164 | type attribute_value_assertion = { 165 | attributeDesc: string; 166 | assertionValue: string; 167 | } 168 | 169 | type matching_rule_assertion = { 170 | matchingRule: string option; 171 | ruletype: string option; 172 | matchValue: string; 173 | dnAttributes: bool; (* default false *) 174 | } 175 | 176 | type substring_component = { (* at least one must be specified *) 177 | substr_initial: string list; 178 | substr_any: string list; 179 | substr_final: string list; 180 | } 181 | 182 | type substring_filter = { 183 | attrtype: string; 184 | substrings: substring_component; 185 | } 186 | 187 | type filter = [ `And of filter list 188 | | `Or of filter list 189 | | `Not of filter 190 | | `EqualityMatch of attribute_value_assertion 191 | | `Substrings of substring_filter 192 | | `GreaterOrEqual of attribute_value_assertion 193 | | `LessOrEqual of attribute_value_assertion 194 | | `Present of string 195 | | `ApproxMatch of attribute_value_assertion 196 | | `ExtensibleMatch of matching_rule_assertion ] 197 | 198 | type search_request = { 199 | baseObject: string; 200 | scope: search_scope; 201 | derefAliases: alias_deref; 202 | sizeLimit: int32; 203 | timeLimit: int32; 204 | typesOnly: bool; 205 | filter: filter; 206 | s_attributes: string list; 207 | } 208 | 209 | type modify_optype = [ `ADD 210 | | `DELETE 211 | | `REPLACE ] 212 | 213 | type modify_op = { 214 | mod_op: modify_optype; 215 | mod_value: attribute; 216 | } 217 | 218 | type modify_request = { 219 | mod_dn: string; 220 | modification: modify_op list 221 | } 222 | 223 | type modify_dn_request = { 224 | modn_dn: string; 225 | modn_newrdn: string; 226 | modn_deleteoldrdn: bool; 227 | modn_newSuperior: string option 228 | } 229 | 230 | type compare_request = { 231 | cmp_dn: string; 232 | cmp_ava: attribute_value_assertion; 233 | } 234 | 235 | type extended_request = { 236 | ext_requestName: string; 237 | ext_requestValue: string option; 238 | } 239 | 240 | type extended_response = { 241 | ext_result: ldap_result; 242 | ext_responseName: string option; 243 | ext_response: string option; 244 | } 245 | 246 | type protocol_op = Bind_request of bind_request 247 | | Bind_response of bind_response 248 | | Unbind_request 249 | | Search_request of search_request 250 | | Search_result_entry of search_result_entry 251 | | Search_result_reference of string list 252 | | Search_result_done of ldap_result 253 | | Modify_request of modify_request 254 | | Modify_response of ldap_result 255 | | Add_request of search_result_entry 256 | | Add_response of ldap_result 257 | | Delete_request of string 258 | | Delete_response of ldap_result 259 | | Modify_dn_request of modify_dn_request 260 | | Modify_dn_response of ldap_result 261 | | Compare_request of compare_request 262 | | Compare_response of ldap_result 263 | | Abandon_request of Int32.t 264 | | Extended_request of extended_request 265 | | Extended_response of extended_response 266 | 267 | type paged_results_control_value = { 268 | size: int; 269 | cookie: string; 270 | } 271 | 272 | type control_details = 273 | [`Paged_results_control of paged_results_control_value 274 | |`Unknown_value of string ] 275 | 276 | type ldap_control = { 277 | criticality: bool; 278 | control_details: control_details; 279 | } 280 | 281 | type ldap_controls = ldap_control list 282 | 283 | type ldap_message = { 284 | messageID: Int32.t; 285 | protocolOp: protocol_op; 286 | controls: ldap_controls option; 287 | } 288 | 289 | type con_mech = [ `SSL 290 | | `PLAIN ] 291 | 292 | type ldap_url = { 293 | url_mech: con_mech; 294 | url_host: string option; 295 | url_port: string option; 296 | url_dn: string option; 297 | url_attributes: (string list) option; 298 | url_scope: search_scope option; 299 | url_filter: filter option; 300 | url_ext: ((bool * string * string) list) option; 301 | } 302 | 303 | (** see draft-zeilenga-ldap-grouping-xx Ldap grouping is a way of 304 | telling the server that a set of ldap operations is related, its most 305 | interesting application is transactions across multiple objects. 306 | This draft is not yet implemented by any present day ldap server *) 307 | type ldap_grouping_type = [ `LDAP_GROUP_TXN ] 308 | 309 | (** a cookie that is sent with every ldap operation which is part of a 310 | group *) 311 | type ldap_grouping_cookie 312 | -------------------------------------------------------------------------------- /src/ldap/ldap_url.ml: -------------------------------------------------------------------------------- 1 | (* a quick and dirty rfc 2255 ldap url lexer for referral processing Will 2 | only parse a subset of the ldapurl 3 | 4 | Copyright (C) 2004 Eric Stokes, and The California State University 5 | at Northridge 6 | 7 | This library is free software; you can redistribute it and/or 8 | modify it under the terms of the GNU Lesser General Public 9 | License as published by the Free Software Foundation; either 10 | version 2.1 of the License, or (at your option) any later version. 11 | 12 | This library is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | Lesser General Public License for more details. 16 | 17 | You should have received a copy of the GNU Lesser General Public 18 | License along with this library; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | open Ldap_urllexer 23 | 24 | exception Invalid_ldap_url of int * string 25 | 26 | let of_string s = 27 | let lx = Lexing.from_string s in 28 | try lexurl lx 29 | with 30 | | SyntaxError -> 31 | raise (Invalid_ldap_url (lx.Lexing.lex_last_pos, "syntax error")) 32 | | exn -> 33 | raise (Invalid_ldap_url (lx.Lexing.lex_last_pos, Printexc.to_string exn)) 34 | -------------------------------------------------------------------------------- /src/ldap/ldap_url.mli: -------------------------------------------------------------------------------- 1 | (* a quick and dirty rfc 2255 ldap url lexer for referral processing Will 2 | only parse a subset of the ldapurl 3 | 4 | Copyright (C) 2004 Eric Stokes, and The California State University 5 | at Northridge 6 | 7 | This library is free software; you can redistribute it and/or 8 | modify it under the terms of the GNU Lesser General Public 9 | License as published by the Free Software Foundation; either 10 | version 2.1 of the License, or (at your option) any later version. 11 | 12 | This library is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | Lesser General Public License for more details. 16 | 17 | You should have received a copy of the GNU Lesser General Public 18 | License along with this library; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | (** a library for parsing a subset of the ldapurl syntax *) 23 | 24 | (** will be raised in the event of a parse or type error. The integer 25 | is the location of the error, measured in charachters from the 26 | left, and the string is a description of the error. The current 27 | lexer does not correctly set the charachter location, however 28 | future lexers will. *) 29 | exception Invalid_ldap_url of int * string 30 | 31 | (** internalize the url contained in the string argument *) 32 | val of_string : string -> Ldap_types.ldap_url 33 | -------------------------------------------------------------------------------- /src/ldap/ldap_urllexer.mll: -------------------------------------------------------------------------------- 1 | (* a quick and dirty rfc 2255 ldap url lexer for referral processing Will 2 | only parse a subset of the ldapurl 3 | 4 | Copyright (C) 2004 Eric Stokes, and The California State University 5 | at Northridge 6 | 7 | This library is free software; you can redistribute it and/or 8 | modify it under the terms of the GNU Lesser General Public 9 | License as published by the Free Software Foundation; either 10 | version 2.1 of the License, or (at your option) any later version. 11 | 12 | This library is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | Lesser General Public License for more details. 16 | 17 | You should have received a copy of the GNU Lesser General Public 18 | License along with this library; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | { 23 | open Ldap_types 24 | 25 | type lexeme = SCHEME 26 | | COLONSLASHSLASH 27 | | PORT of string 28 | | HOST of string 29 | | DN of string 30 | | IDENT of string 31 | | SCOPE of string 32 | | FILTER of string 33 | | QUESTION 34 | | EQUAL 35 | | CRITICAL 36 | | SLASH 37 | | WHSP 38 | | COMMA 39 | 40 | exception SyntaxError 41 | } 42 | 43 | let port = ['0' - '9']+ 44 | let host = ['-' '.' '0' - '9' 'a' - 'z' 'A' - 'Z']+ 45 | let dn = [',' '=' '0' - '9' 'a' - 'z' 'A' - 'Z']+ 46 | let attribute = ['a' - 'z' 'A' - 'Z' '0' - '9']+ 47 | let filter = [' ' '(' ')' '&' '|' '!' '~' '=' '>' '<' '.' '\\' '0' - '9' 'a' - 'z' 'A' - 'Z'] + 48 | let scope = "base" | "one" | "sub" 49 | 50 | rule lexurl = parse 51 | | (("ldap" 's'?) as mech) "://" (host as host)? (':' (port as port))? '/'? eof 52 | {{url_mech=(match mech with "ldap" -> `PLAIN | "ldaps" -> `SSL 53 | | _ -> failwith "invalid mechanism") ; 54 | url_host=host; 55 | url_port=port; 56 | url_dn=None; 57 | url_attributes=None; 58 | url_scope=None; 59 | url_filter=None; 60 | url_ext=None}} 61 | | _ | eof { raise SyntaxError } 62 | 63 | (* 64 | rule lexurl = parse 65 | "ldap" {SCHEME} 66 | | "://" {COLONSLASHSLASH} 67 | | port {PORT (Lexing.lexeme lexbuf)} 68 | | host {HOST (Lexing.lexeme lexbuf)} 69 | | dn {DN (Lexing.lexeme lexbuf)} 70 | | attribute {IDENT (Lexing.lexeme lexbuf)} 71 | | scope {SCOPE (Lexing.lexeme lexbuf)} 72 | | filter {FILTER (Lexing.lexeme lexbuf)} 73 | | ',' {COMMA} 74 | | '?' {QUESTION} 75 | | '=' {EQUAL} 76 | | ':' {COLON} 77 | | '!' {CRITICAL} 78 | | '/' {SLASH} 79 | | ' '* {WHSP} 80 | *) 81 | -------------------------------------------------------------------------------- /src/ldap/ldap_urlparser.mli: -------------------------------------------------------------------------------- 1 | type token = 2 | | SCHEME 3 | | COLONSLASHSLASH 4 | | SLASH 5 | | QUESTION 6 | | EQUAL 7 | | COLON 8 | | COMMA 9 | | WHSP 10 | | CRITICAL 11 | | HOST of (string) 12 | | PORT of (string) 13 | | DN of (string) 14 | | IDENT of (string) 15 | | SCOPE of (string) 16 | | FILTER of (string) 17 | 18 | val ldapurl : 19 | (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Ldap_types.ldap_url 20 | -------------------------------------------------------------------------------- /src/ldap/ulist.ml: -------------------------------------------------------------------------------- 1 | (* case insensitive, case perserving, unique lists based on hash 2 | tables 3 | 4 | Copyright (C) 2004 Eric Stokes, and The California State University 5 | at Northridge 6 | 7 | This library is free software; you can redistribute it and/or 8 | modify it under the terms of the GNU Lesser General Public 9 | License as published by the Free Software Foundation; either 10 | version 2.1 of the License, or (at your option) any later version. 11 | 12 | This library is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | Lesser General Public License for more details. 16 | 17 | You should have received a copy of the GNU Lesser General Public 18 | License along with this library; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 20 | USA 21 | *) 22 | 23 | 24 | type t = (string, string) Hashtbl.t;; 25 | 26 | let create n = Hashtbl.create n;; 27 | let mem lst item = Hashtbl.mem lst (String.lowercase_ascii item);; 28 | let add lst item = 29 | let lcitem = String.lowercase_ascii item in 30 | if (Hashtbl.mem lst lcitem) = false then 31 | Hashtbl.add lst lcitem item; ();; 32 | let addlst lst lst1 = List.iter (fun i -> add lst i) lst1;; 33 | let remove lst item = Hashtbl.remove lst (String.lowercase_ascii item);; 34 | let iter func lst = Hashtbl.iter (fun key _v -> func key) lst;; 35 | let tolst lst = Hashtbl.fold (fun _k v l -> v :: l) lst [];; 36 | -------------------------------------------------------------------------------- /src/ldif/dune: -------------------------------------------------------------------------------- 1 | (ocamlyacc ldif_changerec_parser) 2 | (ocamllex ldif_changerec_lexer) 3 | 4 | (library 5 | (name ldif) 6 | (public_name ldap.ldif) 7 | (wrapped false) 8 | (modules_without_implementation ldif_types) 9 | (libraries camlp-streams ldap threads netstring)) 10 | 11 | ; TODO: remove threads. See https://gitlab.camlcity.org/gerd/lib-ocamlnet3/issues/14 12 | -------------------------------------------------------------------------------- /src/ldif/ldif_changerec_lexer.mll: -------------------------------------------------------------------------------- 1 | (* lexer for extended ldif 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University 4 | at Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | { 22 | open Ldif_changerec_parser 23 | open Netencoding 24 | } 25 | 26 | let nl = '\n' 27 | let whsp = ' ' * 28 | let mustsp = ' ' + 29 | let alphanum = ['0' - '9' 'a' - 'z' 'A' - 'Z'] 30 | let anyprintablechar = ['\t' ' ' - '~'] 31 | let attrname = alphanum + 32 | let attrval = (anyprintablechar | '\n' ' ') + 33 | 34 | rule lexcr = parse 35 | | "dn:" mustsp ([' ' - '~']+ as dn) nl {Dn dn} 36 | | "changetype:" mustsp "modify" nl {Change_type_modify} 37 | | "changetype:" mustsp "delete" nl {Change_type_delete} 38 | | "changetype:" mustsp "modrdn" nl {Change_type_modrdn} 39 | | "changetype:" mustsp "add" nl {Change_type_add} 40 | | "add:" mustsp (attrname as name) nl {Add name} 41 | | "delete:" mustsp (attrname as name) nl {Delete name} 42 | | "replace:" mustsp (attrname as name) nl {Replace name} 43 | | (attrname as attr) ':' mustsp (attrval as valu) nl {Attr (attr, valu)} 44 | | (attrname as attr) "::" mustsp (attrval as valu) nl {Attr (attr, Base64.decode valu)} 45 | | '-' nl {Dash} 46 | | nl + {Newline} 47 | | eof {End_of_input} 48 | -------------------------------------------------------------------------------- /src/ldif/ldif_changerec_oo.ml: -------------------------------------------------------------------------------- 1 | (* create an ldap changerec factory from a channel attached to an ldif 2 | changerec source default is stdin and stdout. 3 | 4 | Copyright (C) 2004 Eric Stokes, Matthew Backes, and The California 5 | State University at Northridge 6 | 7 | This library is free software; you can redistribute it and/or 8 | modify it under the terms of the GNU Lesser General Public 9 | License as published by the Free Software Foundation; either 10 | version 2.1 of the License, or (at your option) any later version. 11 | 12 | This library is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | Lesser General Public License for more details. 16 | 17 | You should have received a copy of the GNU Lesser General Public 18 | License along with this library; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 20 | USA 21 | *) 22 | 23 | open Ldap_ooclient 24 | open Ldif_changerec_parser 25 | open Ldif_changerec_lexer 26 | 27 | exception Invalid_changerec of string 28 | exception End_of_changerecs 29 | 30 | let iter f cr = 31 | try 32 | while true 33 | do 34 | f cr#read_changerec 35 | done 36 | with End_of_changerecs -> () 37 | 38 | let rec fold f cr a = 39 | try fold f cr (f a cr#read_changerec) 40 | with End_of_changerecs -> a 41 | 42 | let insert_change buf cr = 43 | match cr with 44 | `Modification (dn, mod_op) -> 45 | Buffer.add_string buf ("dn: " ^ dn ^ "\n"); 46 | Buffer.add_string buf "changetype: modify\n"; 47 | List.iter 48 | (fun (op, attr, vals) -> 49 | (match op with 50 | `ADD -> Buffer.add_string buf ("add: " ^ attr ^ "\n") 51 | | `DELETE -> Buffer.add_string buf ("delete: " ^ attr ^ "\n") 52 | | `REPLACE -> Buffer.add_string buf ("replace: " ^ attr ^ "\n")); 53 | List.iter 54 | (fun valu -> Buffer.add_string buf (attr ^ ": " ^ valu ^ "\n")) 55 | vals; 56 | Buffer.add_string buf "-\n") 57 | mod_op; 58 | Buffer.add_string buf "\n"; 59 | buf 60 | | `Addition e -> Ldif_oo.entry2ldif ~ext:true buf e; 61 | | `Delete dn -> 62 | Buffer.add_string buf ("dn: " ^ dn ^ "\n"); 63 | Buffer.add_string buf "changetype: delete\n"; 64 | buf 65 | | `Modrdn (dn, deleteoldrdn, newrdn) -> 66 | Buffer.add_string buf ("dn: " ^ dn ^ "\n"); 67 | Buffer.add_string buf "changetype: modrdn\n"; 68 | Buffer.add_string buf ("deleteoldrdn: " ^ (string_of_int deleteoldrdn) ^ "\n"); 69 | Buffer.add_string buf ("newrdn: " ^ newrdn ^ "\n"); 70 | buf 71 | 72 | class change ?(in_ch=stdin) ?(out_ch=stdout) () = 73 | object (_self) 74 | val lxbuf = Lexing.from_channel in_ch 75 | val buf = Buffer.create 1 76 | method read_changerec = 77 | try changerec lexcr lxbuf 78 | with 79 | Ldif_types.Changerec_parser_end -> raise End_of_changerecs 80 | | Failure s -> raise (Invalid_changerec s) 81 | method of_string (s:string) = 82 | let lx = Lexing.from_string s in 83 | try changerec lexcr lx 84 | with 85 | Ldif_types.Changerec_parser_end -> raise End_of_changerecs 86 | | Failure s -> raise (Invalid_changerec s) 87 | method to_string (e:changerec) = 88 | let res = Buffer.contents (insert_change buf e) in 89 | Buffer.clear buf;res 90 | method write_changerec (e:changerec) = 91 | ignore (insert_change buf e); 92 | Buffer.output_buffer out_ch buf; 93 | Buffer.clear buf 94 | end 95 | -------------------------------------------------------------------------------- /src/ldif/ldif_changerec_oo.mli: -------------------------------------------------------------------------------- 1 | (* create an ldap entry factory from a channel attached to an ldif 2 | source default is stdin and stdout. 3 | 4 | Copyright (C) 2004 Eric Stokes, Matthew Backes, and The California 5 | State University at Northridge 6 | 7 | This library is free software; you can redistribute it and/or 8 | modify it under the terms of the GNU Lesser General Public 9 | License as published by the Free Software Foundation; either 10 | version 2.1 of the License, or (at your option) any later version. 11 | 12 | This library is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | Lesser General Public License for more details. 16 | 17 | You should have received a copy of the GNU Lesser General Public 18 | License along with this library; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 20 | USA 21 | *) 22 | 23 | (** an object oriented interface to the ldif parser *) 24 | 25 | (** an exception raised when there is a parse error *) 26 | exception Invalid_changerec of string 27 | 28 | (** raised at the end of the change records *) 29 | exception End_of_changerecs 30 | 31 | (** Ldif_changerec.iter f change, iterate accross all change entries 32 | in the specified change object, applying f to each one *) 33 | val iter : ('a -> unit) -> < read_changerec : 'a; .. > -> unit 34 | 35 | (** Ldif_changerec.fold f change value, for each change entry en in 36 | the change object fold computes f (... (f (f value e1) e2) ...) en *) 37 | val fold : ('a -> 'b -> 'a) -> < read_changerec : 'b; .. > -> 'a -> 'a 38 | 39 | class change: 40 | ?in_ch:in_channel -> 41 | ?out_ch:out_channel -> 42 | unit -> 43 | object 44 | method read_changerec: Ldap_ooclient.changerec 45 | method of_string: string -> Ldap_ooclient.changerec 46 | method to_string: Ldap_ooclient.changerec -> string 47 | method write_changerec: Ldap_ooclient.changerec -> unit 48 | end 49 | -------------------------------------------------------------------------------- /src/ldif/ldif_changerec_parser.mly: -------------------------------------------------------------------------------- 1 | /* a parser for extended ldif 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University 4 | at Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | */ 20 | 21 | %{ 22 | open Ldap_ooclient 23 | 24 | let check_attrs attr attrs = 25 | List.rev_map 26 | (fun (declared_attr, valu) -> 27 | if declared_attr = attr then 28 | valu 29 | else 30 | failwith 31 | ("declared attribute " ^ 32 | "modifies the wrong" ^ 33 | "attribute, " ^ 34 | "attribute: " ^ attr ^ 35 | "declared: " ^ 36 | declared_attr)) 37 | attrs 38 | 39 | let check_empty op attr = 40 | match op with 41 | `DELETE -> (op, attr, []) 42 | | `ADD -> failwith "non sensical empty add" 43 | | `REPLACE -> failwith "non sensical empty replace" 44 | %} 45 | 46 | %token End_of_input Change_type_add Change_type_modrdn 47 | %token Change_type_modify Change_type_delete Dash Newline 48 | %token AttributeType Dn Add Delete Replace 49 | %token Attr 50 | %type changerec 51 | %start changerec 52 | %% 53 | 54 | operation: 55 | Add {(`ADD, $1)} 56 | | Delete {(`DELETE, $1)} 57 | | Replace {(`REPLACE, $1)} 58 | ; 59 | 60 | attrlst: 61 | Attr attrlst {$1 :: $2} 62 | | Attr {[$1]} 63 | 64 | newline: 65 | Newline {} 66 | | End_of_input {} 67 | 68 | modificationterminator: 69 | Dash newline {} 70 | | newline {} 71 | ; 72 | 73 | modifications: 74 | operation attrlst Dash modifications {let (op, attr) = $1 in 75 | (op, 76 | attr, 77 | check_attrs attr $2) :: $4} 78 | | operation Dash modifications {let (op, attr) = $1 in 79 | (check_empty op attr) :: $3} 80 | | operation attrlst modificationterminator {let (op, attr) = $1 in 81 | [(op, attr, 82 | check_attrs attr $2)]} 83 | | operation modificationterminator {let (op, attr) = $1 in 84 | [(check_empty op attr)]} 85 | ; 86 | 87 | entry: 88 | Attr entry {let (a, v) = $1 in (a, [v]) :: $2} 89 | | Attr newline {let (a, v) = $1 in [(a, [v])]} 90 | 91 | changerec: 92 | Dn Change_type_modify modifications {`Modification ($1, List.rev $3)} 93 | | Dn Change_type_add entry {let e = new ldapentry in 94 | e#set_dn $1;e#add $3;`Addition e} 95 | | Dn Change_type_delete newline {`Delete $1} 96 | | Dn Change_type_modrdn Attr Attr newline {`Modrdn 97 | ($1, 98 | int_of_string (snd $3), 99 | snd $4)} 100 | | End_of_input {raise Ldif_types.Changerec_parser_end} 101 | ; 102 | -------------------------------------------------------------------------------- /src/ldif/ldif_oo.ml: -------------------------------------------------------------------------------- 1 | (* An object oriented interface for parsing Lightweight Directory 2 | Interchange Format file 3 | 4 | Copyright (C) 2004 Eric Stokes, Matthew Backes, and The California 5 | State University at Northridge 6 | 7 | This library is free software; you can redistribute it and/or 8 | modify it under the terms of the GNU Lesser General Public 9 | License as published by the Free Software Foundation; either 10 | version 2.1 of the License, or (at your option) any later version. 11 | 12 | This library is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | Lesser General Public License for more details. 16 | 17 | You should have received a copy of the GNU Lesser General Public 18 | License along with this library; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 20 | USA 21 | *) 22 | 23 | 24 | open Netencoding 25 | open Ldap_ooclient 26 | open Ldif_parser 27 | 28 | let safe_string_regex = 29 | Str.regexp "^[\x01-\x09\x0b-\x0c\x0e-\x7f]+$" 30 | 31 | let password_regex = 32 | Str.regexp_case_fold ".*p\\(ass\\)?w\\(or\\)?d$" 33 | 34 | let empty_regex = 35 | Str.regexp "^ *$\\|^ *.*$" 36 | 37 | let safe_val buf s = 38 | if 39 | (Str.string_match safe_string_regex s 0) && 40 | (not (Str.string_match empty_regex s 0)) 41 | then begin 42 | Buffer.add_string buf ": "; 43 | Buffer.add_string buf s 44 | end 45 | else begin 46 | Buffer.add_string buf ":: "; 47 | Buffer.add_string buf (Base64.encode s) 48 | end 49 | 50 | let safe_attr_val buf a v = 51 | if Str.string_match password_regex a 0 then begin 52 | Buffer.add_string buf a; 53 | Buffer.add_string buf ":: "; 54 | Buffer.add_string buf (Base64.encode v) 55 | end 56 | else begin 57 | Buffer.add_string buf a; 58 | safe_val buf v 59 | end 60 | 61 | let entry2ldif ?(ext=false) outbuf e = 62 | Buffer.add_string outbuf "dn"; 63 | safe_val outbuf e#dn; 64 | if ext then Buffer.add_string outbuf "\nchangetype: add"; 65 | Buffer.add_char outbuf '\n'; 66 | (List.iter 67 | (fun attr -> 68 | (List.iter 69 | (fun value -> 70 | safe_attr_val outbuf attr value; 71 | Buffer.add_char outbuf '\n') 72 | (e#get_value attr))) 73 | e#attributes); 74 | Buffer.add_char outbuf '\n'; 75 | outbuf 76 | 77 | let iter (f: ('a -> unit)) ldif = 78 | try 79 | while true 80 | do 81 | f ldif#read_entry 82 | done 83 | with End -> () 84 | 85 | let fold f ldif v = 86 | let objects = 87 | let objects = ref [] in 88 | try 89 | while true 90 | do 91 | objects := (ldif#read_entry) :: !objects 92 | done; 93 | !objects 94 | with End -> !objects 95 | in 96 | List.fold_left f v objects 97 | 98 | class ldif ?(in_ch=stdin) ?(out_ch=stdout) () = 99 | object (_self) 100 | val in_ch = {stream=(Stream.of_channel in_ch);buf=Buffer.create 256;line=1} 101 | val out_ch = out_ch 102 | val outbuf = Buffer.create 50 103 | 104 | method read_entry = Ldap_ooclient.to_entry (`Entry (ldif_attrval_record in_ch)) 105 | 106 | method of_string s = 107 | let strm = {stream=(Stream.of_string s);buf=Buffer.create 256;line=1} in 108 | Ldap_ooclient.to_entry (`Entry (ldif_attrval_record strm)) 109 | 110 | method to_string (e:ldapentry_t) = 111 | try 112 | let contents = Buffer.contents (entry2ldif outbuf e) in 113 | Buffer.clear outbuf; 114 | contents 115 | with exn -> 116 | Buffer.clear outbuf; 117 | raise exn 118 | 119 | method write_entry (e:ldapentry_t) = 120 | try 121 | Buffer.output_buffer out_ch (entry2ldif outbuf e); 122 | Buffer.clear outbuf 123 | with exn -> 124 | Buffer.clear outbuf; 125 | raise exn 126 | end 127 | 128 | let read_ldif_file file = 129 | let fd = open_in file in 130 | try 131 | let ldif = new ldif ~in_ch:fd () in 132 | let entries = fold (fun l e -> e :: l) ldif [] in 133 | close_in fd; 134 | entries 135 | with exn -> close_in fd;raise exn 136 | 137 | let write_ldif_file file entries = 138 | let fd = open_out file in 139 | try 140 | let ldif = new ldif ~out_ch:fd () in 141 | List.iter ldif#write_entry entries; 142 | close_out fd 143 | with exn -> close_out fd;raise exn 144 | -------------------------------------------------------------------------------- /src/ldif/ldif_oo.mli: -------------------------------------------------------------------------------- 1 | (* create an ldap entry factory from a channel attached to an ldif 2 | source default is stdin and stdout. 3 | 4 | Copyright (C) 2004 Eric Stokes, Matthew Backes, and The California 5 | State University at Northridge 6 | 7 | This library is free software; you can redistribute it and/or 8 | modify it under the terms of the GNU Lesser General Public 9 | License as published by the Free Software Foundation; either 10 | version 2.1 of the License, or (at your option) any later version. 11 | 12 | This library is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | Lesser General Public License for more details. 16 | 17 | You should have received a copy of the GNU Lesser General Public 18 | License along with this library; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 20 | USA 21 | *) 22 | 23 | (** an object oriented interface to the ldif parser *) 24 | 25 | (** Ldif_oo.iter f ldif, iterate accross all ldif entries in the 26 | specified ldif object, applying f to each one *) 27 | val iter : ('a -> unit) -> < read_entry : 'a; .. > -> unit 28 | 29 | (** Ldif_oo.fold f ldif value, for each ldif entry en in the ldif 30 | object fold computes f (... (f (f value e1) e2) ...) en *) 31 | val fold : ('a -> 'b -> 'a) -> < read_entry : 'b; .. > -> 'a -> 'a 32 | 33 | (** if you need a fast, low level interface to to_string, this 34 | function will write ldif directly into a buffer. Setting ext to 35 | true (defaul false) will write extended ldif. Extended ldif should 36 | be parsed using the Ldif_changerec_oo module. *) 37 | val entry2ldif : ?ext:bool -> Buffer.t -> 38 | < attributes : string list; dn : string; get_value : string -> 39 | string list; .. > -> Buffer.t 40 | 41 | (** read all the entries in the named ldif file and return them in a list *) 42 | val read_ldif_file : string -> Ldap_ooclient.ldapentry list 43 | 44 | (** write all the entries in the given list to the named file in ldif format *) 45 | val write_ldif_file : string -> Ldap_ooclient.ldapentry list -> unit 46 | 47 | class ldif: 48 | ?in_ch:in_channel -> 49 | ?out_ch:out_channel -> 50 | unit -> 51 | object 52 | method read_entry: Ldap_ooclient.ldapentry 53 | method of_string: string -> Ldap_ooclient.ldapentry 54 | method to_string: Ldap_ooclient.ldapentry -> string 55 | method write_entry: Ldap_ooclient.ldapentry -> unit 56 | end 57 | -------------------------------------------------------------------------------- /src/ldif/ldif_parser.ml: -------------------------------------------------------------------------------- 1 | (* A lexer and parser for ldif format files 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University at 4 | Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | 23 | open Ldap_types 24 | open Netencoding 25 | 26 | exception Illegal_char of char * int 27 | exception End 28 | 29 | type stream_rec = {stream: char Stream.t;buf:Buffer.t;mutable line: int} 30 | 31 | let optval o = 32 | match o with 33 | Some(c) -> c 34 | | None -> raise End 35 | 36 | let rec read_comment s = 37 | let check_next s = 38 | match (optval (Stream.peek s.stream)) with 39 | ' ' | '#' -> (Stream.junk s.stream);read_comment s (* line folded, or another comment *) 40 | | _ -> () 41 | in 42 | match (optval (Stream.peek s.stream)) with 43 | '\n' -> (Stream.junk s.stream);s.line <- s.line + 1;check_next s 44 | | '\r' -> 45 | (Stream.junk s.stream);(Stream.junk s.stream); 46 | s.line <- s.line + 1;check_next s 47 | | _ -> (Stream.junk s.stream);read_comment s 48 | 49 | let comment s = 50 | match (optval (Stream.peek s.stream)) with 51 | '#' -> (Stream.junk s.stream);read_comment s 52 | | _ -> () 53 | 54 | let sep s = 55 | match (optval (Stream.peek s.stream)) with 56 | '\n' -> (Stream.junk s.stream);s.line <- s.line + 1;"\n" 57 | | '\r' -> (Stream.junk s.stream);(Stream.junk s.stream);s.line <- s.line + 1;"\n" 58 | | c -> raise (Illegal_char (c,s.line));; 59 | 60 | let seps s = 61 | try 62 | (while true 63 | do 64 | ignore (sep s) 65 | done) 66 | with Illegal_char(_,_) -> ();; 67 | 68 | let digit s = 69 | match (optval (Stream.peek s.stream)) with 70 | '0'..'9' -> (Stream.next s.stream) 71 | | c -> raise (Illegal_char (c,s.line));; 72 | 73 | let safe_char s = 74 | match (optval (Stream.peek s.stream)) with 75 | ' '..'~' -> (Stream.next s.stream) 76 | | c -> raise (Illegal_char (c,s.line));; 77 | 78 | let safe_init_char s = 79 | match (optval (Stream.peek s.stream)) with 80 | '!'..'9'|';'..'~' -> (Stream.next s.stream) 81 | | c -> raise (Illegal_char (c,s.line));; 82 | 83 | let alpha s = 84 | match (optval (Stream.peek s.stream)) with 85 | 'a'..'z'|'A'..'Z' -> (Stream.next s.stream) 86 | | c -> raise (Illegal_char (c,s.line));; 87 | 88 | let safe_chars s = 89 | let rec do_safe_chars s = 90 | try 91 | while true 92 | do 93 | Buffer.add_char s.buf (safe_char s) 94 | done 95 | with 96 | Illegal_char('\n',_) -> 97 | (match (Stream.npeek 2 s.stream) with 98 | ['\n';' '] -> 99 | (Stream.junk s.stream);(Stream.junk s.stream); 100 | s.line <- s.line + 1; 101 | (do_safe_chars s) 102 | | _ -> ()) 103 | | Illegal_char('\r',_) -> 104 | (match (Stream.npeek 3 s.stream) with 105 | ['\r';'\n';' '] -> 106 | (Stream.junk s.stream);(Stream.junk s.stream);(Stream.junk s.stream); 107 | s.line <- s.line + 1; 108 | (do_safe_chars s) 109 | | _ -> ()) 110 | | Illegal_char(_,_) -> () 111 | | End -> () 112 | in 113 | do_safe_chars s;; 114 | 115 | let safe_string s = 116 | Buffer.clear s.buf; 117 | Buffer.add_char s.buf (safe_init_char s); 118 | safe_chars s; 119 | Buffer.contents s.buf;; 120 | 121 | let attr_type_char s = 122 | match (optval (Stream.peek s.stream)) with 123 | 'A'..'Z'|'a'..'z'|'0'..'9'|'-' -> (Stream.next s.stream) 124 | | c -> raise (Illegal_char (c, s.line));; 125 | 126 | let attr_type_chars s = 127 | try 128 | while true 129 | do 130 | Buffer.add_char s.buf (attr_type_char s) 131 | done; 132 | with Illegal_char(_,_) -> () 133 | 134 | let option s = 135 | Buffer.clear s.buf; 136 | Buffer.add_char s.buf (attr_type_char s); 137 | attr_type_chars s; 138 | Buffer.contents s.buf;; 139 | 140 | let rec options s = 141 | match (optval (Stream.peek s.stream)) with 142 | ';' -> let thisone = (Stream.junk s.stream);(option s) in thisone ^ (options s) 143 | | ':' -> "" 144 | | c -> raise (Illegal_char (c, s.line));; (* syntax error *) 145 | 146 | let attributeType s = 147 | Buffer.clear s.buf; 148 | Buffer.add_char s.buf (alpha s); 149 | attr_type_chars s; 150 | Buffer.contents s.buf;; 151 | 152 | let attributeDescription s = 153 | let name = (attributeType s) in 154 | let _options = (match (optval (Stream.peek s.stream)) with 155 | ';' -> options s (* there are options *) 156 | | _ -> "") in 157 | let _colon = (match (optval (Stream.peek s.stream)) with 158 | ':' -> (Stream.junk s.stream);"" 159 | | _ -> failwith "Parse, error. Missing colon in attribute spec") 160 | in 161 | name 162 | 163 | let value_spec s = 164 | match (optval (Stream.peek s.stream)) with 165 | ':' -> (Stream.junk s.stream); 166 | (match (optval (Stream.peek s.stream)) with 167 | ' ' -> (Stream.junk s.stream); 168 | (Base64.decode (safe_string s)) 169 | | c -> raise (Illegal_char (c, s.line))) 170 | | '<' -> (Stream.junk s.stream);(match (optval (Stream.peek s.stream)) with 171 | ' ' -> (Stream.junk s.stream);(safe_string s) (* a url *) 172 | | c -> raise (Illegal_char (c, s.line))) 173 | | ' ' -> (Stream.junk s.stream);(safe_string s) 174 | | c -> raise (Illegal_char (c, s.line)) 175 | 176 | let rec attrval_spec ?(attrs=[]) s = 177 | let lc = String.lowercase_ascii in 178 | try 179 | ignore (sep s);attrs 180 | with 181 | Illegal_char(_,_) -> 182 | let attr = (attributeDescription s) in 183 | let valu = (value_spec s) in 184 | let _sep = (sep s) in 185 | (match attrs with 186 | | {attr_type=name;attr_vals=vals} :: tl -> 187 | if (lc attr) = (lc name) then 188 | attrval_spec 189 | ~attrs:({attr_type=name; 190 | attr_vals=(valu :: vals)} :: tl) s 191 | else 192 | attrval_spec 193 | ~attrs:({attr_type=attr;attr_vals=[valu]} :: attrs) s 194 | | [] -> 195 | attrval_spec ~attrs:[{attr_type=attr;attr_vals=[valu]}] s) 196 | | End -> attrs 197 | 198 | let distinguishedName s = 199 | match (optval (Stream.peek s.stream)) with 200 | ':' -> (Stream.junk s.stream); 201 | (match (optval (Stream.peek s.stream)) with 202 | ' ' -> (Stream.junk s.stream); 203 | (Base64.decode (safe_string s)) 204 | | c -> raise (Illegal_char (c, s.line))) 205 | | ' ' -> (Stream.junk s.stream);safe_string s 206 | | c -> raise (Illegal_char (c, s.line)) 207 | 208 | let dn_spec s = 209 | match (Stream.npeek 3 s.stream) with 210 | ['d';'n';':'] -> 211 | (Stream.junk s.stream); 212 | (Stream.junk s.stream); 213 | (Stream.junk s.stream); 214 | (distinguishedName s) 215 | | _ -> failwith ("invalid dn on line: " ^ (string_of_int s.line)) 216 | 217 | let ldif_attrval_record s = 218 | let _ = comment s in 219 | let _ = seps s in 220 | let dn = dn_spec s in 221 | let _ = try seps s with End -> () in (* just a dn is a valid ldif file *) 222 | let attrs = attrval_spec s in 223 | {sr_dn=dn;sr_attributes=attrs} 224 | -------------------------------------------------------------------------------- /src/ldif/ldif_types.mli: -------------------------------------------------------------------------------- 1 | exception Changerec_parser_end 2 | -------------------------------------------------------------------------------- /src/toplevel/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name toplevel) 3 | (public_name ldap.toplevel) 4 | (modes byte) 5 | (wrapped false) 6 | (libraries ldap ldif compiler-libs)) 7 | -------------------------------------------------------------------------------- /src/toplevel/ldap_toplevel.ml: -------------------------------------------------------------------------------- 1 | (* Functions which resemble the command line tools, useful in the 2 | interactive environment 3 | 4 | Copyright (C) 2004 Eric Stokes, and The California State University 5 | at Northridge 6 | 7 | This library is free software; you can redistribute it and/or 8 | modify it under the terms of the GNU Lesser General Public 9 | License as published by the Free Software Foundation; either 10 | version 2.1 of the License, or (at your option) any later version. 11 | 12 | This library is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | Lesser General Public License for more details. 16 | 17 | You should have received a copy of the GNU Lesser General Public 18 | License along with this library; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 20 | USA 21 | *) 22 | 23 | open Ldap_ooclient 24 | 25 | let eval s = 26 | let l = Lexing.from_string s in 27 | let ph = !Toploop.parse_toplevel_phrase l in 28 | assert(Toploop.execute_phrase false Format.err_formatter ph) 29 | ;; 30 | 31 | eval "#install_printer Ldap_ooclient.format_entries;;";; 32 | eval "#install_printer Ldap_ooclient.format_entry;;";; 33 | eval "#install_printer Ldap_schemaparser.format_oid;;";; 34 | eval "#install_printer Ldap_schemaparser.format_lcstring;;";; 35 | eval "#install_printer Ldap_schemaparser.format_schema;;";; 36 | 37 | let ldap_cmd_harness ~h ~d ~w f = 38 | let ldap = new ldapcon [h] in 39 | try 40 | ldap#bind d ~cred:w; 41 | let res = f ldap in 42 | ldap#unbind; 43 | res 44 | with exn -> ldap#unbind;raise exn 45 | ;; 46 | 47 | let ldapsearch ?(s=`SUBTREE) ?(a=[]) ?(b="") ?(d="") ?(w="") ~h filter = 48 | ldap_cmd_harness ~h ~d ~w 49 | (fun ldap -> 50 | ldap#search 51 | ~base:b ~scope:s 52 | ~attrs:a filter) 53 | ;; 54 | 55 | let ldapmodify ~h ~d ~w mods = 56 | ldap_cmd_harness ~h ~d ~w 57 | (fun ldap -> 58 | List.iter 59 | (fun (dn, ldmod) -> ldap#modify dn ldmod) 60 | mods) 61 | ;; 62 | 63 | let ldapadd ~h ~d ~w entries = 64 | ldap_cmd_harness ~h ~d ~w 65 | (fun ldap -> 66 | List.iter 67 | (fun entry -> ldap#add entry) 68 | entries) 69 | ;; 70 | -------------------------------------------------------------------------------- /src/toplevel/ldap_toplevel.mli: -------------------------------------------------------------------------------- 1 | (* Functions which resemble the command line tools which many users 2 | are familar with, useful in the interactive environment 3 | 4 | Copyright (C) 2004 Eric Stokes, and The California State University 5 | at Northridge 6 | 7 | This library is free software; you can redistribute it and/or 8 | modify it under the terms of the GNU Lesser General Public 9 | License as published by the Free Software Foundation; either 10 | version 2.1 of the License, or (at your option) any later version. 11 | 12 | This library is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | Lesser General Public License for more details. 16 | 17 | You should have received a copy of the GNU Lesser General Public 18 | License along with this library; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 20 | USA 21 | *) 22 | 23 | (** Functions which resemble the command line tools which many users 24 | are familar with, useful in the interactive environment *) 25 | 26 | (** connect to the specified host and perform a search. 27 | @param h The ldapurl which names the host and port to connect to 28 | @param d The dn of the object you with to bind as, default anonymous 29 | @param w The credentials of the object you wish to bind as, default anonymous 30 | @param s The scope of the search, default `SUBTREE 31 | @param b The base of the search 32 | The final argument is the search filter *) 33 | val ldapsearch : 34 | ?s:Ldap_types.search_scope -> 35 | ?a:string list -> 36 | ?b:string -> 37 | ?d:string -> 38 | ?w:string -> h:string -> string -> Ldap_ooclient.ldapentry list 39 | 40 | (** connect to the specified host and perform one or more modifications. 41 | @param h The ldapurl which names the host and port to connect to 42 | @param d The dn of the object you with to bind as, default anonymous 43 | @param w The credentials of the object you wish to bind as, default anonymous 44 | The final argument is a list of (dn, modification) pairs which you want to apply *) 45 | val ldapmodify : 46 | h:string -> 47 | d:string -> 48 | w:string -> 49 | (string * (Ldap_types.modify_optype * string * string list) list) list -> 50 | unit 51 | 52 | (** connect to the specified host and add the specified objects. 53 | @param h The ldapurl which names the host and port to connect to 54 | @param d The dn of the object you with to bind as, default anonymous 55 | @param w The credentials of the object you wish to bind as, default anonymous 56 | The final argument is a list of objects you wish to add *) 57 | val ldapadd : 58 | h:string -> d:string -> w:string -> Ldap_ooclient.ldapentry list -> unit 59 | -------------------------------------------------------------------------------- /tests/ldap/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names test page_result_control_test lber_tests) 3 | (libraries ldap)) 4 | 5 | (rule 6 | (alias runtest) 7 | (deps test.exe) 8 | (action 9 | (progn 10 | (run %{exe:page_result_control_test.exe}) 11 | (run %{exe:lber_tests.exe})))) 12 | -------------------------------------------------------------------------------- /tests/ldap/lber_tests.ml: -------------------------------------------------------------------------------- 1 | open Lber 2 | 3 | let encode_decode_int32 i = 4 | let e_i32 = encode_ber_int32 i in 5 | let rb = readbyte_of_string e_i32 in 6 | decode_ber_int32 rb 7 | 8 | let rec test_positive_encode_decode_int32 i = 9 | if i < Int32.max_int then 10 | let result = 11 | try encode_decode_int32 i 12 | with exn -> 13 | print_endline ("unhandled exception: " ^ (Printexc.to_string exn) ^ 14 | " with int: " ^ (Int32.to_string i)); 15 | exit 0 16 | in 17 | if result <> i then 18 | failwith ("I encode: " ^ (Int32.to_string i) ^ 19 | " and I get: " ^ (Int32.to_string result)) 20 | else 21 | ((if Int32.rem i 1000000l = 0l then 22 | print_endline ("i:" ^ (Int32.to_string i))); 23 | test_positive_encode_decode_int32 (Int32.succ i)) 24 | 25 | let rec test_negative_encode_decode_int32 i = 26 | if i > Int32.min_int then 27 | let result = 28 | try encode_decode_int32 i 29 | with exn -> 30 | print_endline ("unhandled exception: " ^ (Printexc.to_string exn) ^ 31 | " with int: " ^ (Int32.to_string i)); 32 | exit 0 33 | in 34 | if result <> i then 35 | failwith ("I encode: " ^ (Int32.to_string i) ^ 36 | " and I get: " ^ (Int32.to_string result)) 37 | else 38 | ((if Int32.rem i (-1000000l) = 0l then 39 | print_endline ("i:" ^ (Int32.to_string i))); 40 | test_negative_encode_decode_int32 (Int32.pred i)) 41 | 42 | let main () = 43 | (* print_endline "testing integer encoder/decoder with positive numbers"; 44 | test_positive_encode_decode_int32 0l; *) 45 | print_endline "testing integer encoder/decoder with negative numbers"; 46 | test_negative_encode_decode_int32 0l 47 | ;; 48 | 49 | main () 50 | -------------------------------------------------------------------------------- /tests/ldap/page_result_control_test.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | (* 4 | Build this test with the following command: 5 | ocamlc -g -o page_result_control_test -package str -package ldap -thread -linkpkg page_result_control_test.ml 6 | *) 7 | 8 | let default_server = "ldap://x500.bund.de" 9 | let default_base = "o=Bund,c=DE" 10 | let default_who = "" 11 | let default_cred = "" 12 | let default_page_size = 200 13 | 14 | let get_page_control controls = 15 | List.fold_left 16 | (fun cur_res control -> 17 | match cur_res with 18 | | None -> 19 | begin match control.Ldap_types.control_details with 20 | | `Paged_results_control _ -> Some control 21 | | _ -> None 22 | end 23 | | Some x -> Some x) 24 | None 25 | controls 26 | 27 | let rec entry_list_builder_helper accum search_function page_size msgid conn = 28 | let cur_entry = 29 | try 30 | Ldap_funclient.get_search_entry_with_controls conn msgid 31 | with _ -> failwith "error" 32 | in 33 | begin match cur_entry with 34 | | `Success None -> accum 35 | (* This means we are done, if we are not using page 36 | control...but we are so we never reach here in this case *) 37 | | `Success (Some controls) -> 38 | (* do recursive call with cookie *) 39 | let pg_control = get_page_control controls in 40 | begin match pg_control with 41 | | None -> 42 | (*printf "Error: couldn't get page control\n";*) 43 | [] 44 | | Some c -> 45 | begin match c.Ldap_types.control_details with 46 | | `Paged_results_control value -> 47 | let mycookie=value.Ldap_types.cookie in 48 | if mycookie = "" then 49 | accum (* This means we are done. *) 50 | else 51 | let new_msgid = search_function (`Subctrl (page_size,mycookie)) in 52 | entry_list_builder_helper accum search_function page_size new_msgid conn 53 | | `Unknown_value _ -> 54 | (*printf "Error: unknown ldap control value: %s\n" s;*) 55 | [] 56 | end 57 | end 58 | | `Entry e -> 59 | entry_list_builder_helper (e::accum) search_function page_size msgid conn 60 | | `Referral _ -> 61 | entry_list_builder_helper accum search_function page_size msgid conn 62 | (*ignore referrals and continue *) 63 | end 64 | 65 | let entry_list_builder search_function page_size msgid conn = 66 | entry_list_builder_helper [] search_function page_size msgid conn 67 | 68 | let search_function conn page_control = 69 | Ldap_funclient.search 70 | ~base:default_base 71 | ~scope:`SUBTREE 72 | ~attrs:["dc"] 73 | ~page_control 74 | conn 75 | "(objectclass=*)" 76 | 77 | let () = 78 | match 79 | try Some (Ldap_funclient.init [default_server]) 80 | with Ldap_types.LDAP_Failure _ | Unix.Unix_error _ -> None 81 | with 82 | | Some conn -> 83 | Ldap_funclient.bind_s 84 | conn 85 | ~who:default_who 86 | ~cred:default_cred 87 | ~auth_method:`SIMPLE; 88 | let msgid = search_function conn (`Initctrl default_page_size) in 89 | let elist = 90 | entry_list_builder (search_function conn) default_page_size msgid conn 91 | in 92 | printf "got %d entries\n" (List.length elist) 93 | | None -> 94 | prerr_endline "Couldn't connect to the server, abort." 95 | -------------------------------------------------------------------------------- /tests/ldap/test.ml: -------------------------------------------------------------------------------- 1 | (* a test program for ldap_funclient 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University 4 | at Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | (* $Id$ *) 23 | 24 | open Ldap_types 25 | open Ldap_funclient 26 | open Arg 27 | 28 | let ldif_buffer = Buffer.create 3124 29 | let print_entry e = 30 | match e with 31 | `Entry {sr_dn=dn;sr_attributes=attrs} -> 32 | Buffer.add_string ldif_buffer "dn: "; 33 | Buffer.add_string ldif_buffer dn; 34 | Buffer.add_string ldif_buffer "\n"; 35 | List.iter 36 | (fun {attr_type=name;attr_vals=vals} -> 37 | List.iter 38 | (fun aval -> 39 | Buffer.add_string ldif_buffer name; 40 | Buffer.add_string ldif_buffer ": "; 41 | Buffer.add_string ldif_buffer aval; 42 | Buffer.add_string ldif_buffer "\n") 43 | vals) 44 | attrs; 45 | Buffer.add_string ldif_buffer "\n"; 46 | Buffer.output_buffer stdout ldif_buffer; 47 | Buffer.clear ldif_buffer 48 | | `Referral _f -> () 49 | 50 | let main () = 51 | let usg = "test -H -D -w -b " in 52 | let host = ref "" in 53 | let binddn = ref "" in 54 | let cred = ref "" in 55 | let base = ref "" in 56 | let filter = ref "" in 57 | let set_host x = host := x in 58 | let set_binddn x = binddn := x in 59 | let set_cred x = cred := x in 60 | let set_base x = base := x in 61 | let set_filter x = filter := x in 62 | let spec = [("-H", String(set_host), "host"); 63 | ("-D", String(set_binddn), "dn to bind with"); 64 | ("-w", String(set_cred), "password to use when binding"); 65 | ("-b", String(set_base), "search base")] in 66 | if (Array.length Sys.argv) > 9 then 67 | (parse spec set_filter usg; 68 | let con = init [!host] in 69 | bind_s con ~who:!binddn ~cred:!cred; 70 | let msgid = search con ~base:!base !filter in 71 | try 72 | while true 73 | do 74 | print_entry (get_search_entry con msgid); 75 | done 76 | with LDAP_Failure (`SUCCESS, _, _) -> print_endline "") 77 | else 78 | usage spec usg 79 | ;; 80 | 81 | main ();; 82 | 83 | -------------------------------------------------------------------------------- /tests/ldif/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names testldif testoo) 3 | (libraries ldap ldif)) 4 | 5 | (alias 6 | (name runtest) 7 | (deps testldif.exe testoo.exe)) 8 | -------------------------------------------------------------------------------- /tests/ldif/testldif.ml: -------------------------------------------------------------------------------- 1 | (* a test program for the ldif libraries 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University 4 | at Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | 23 | (* $Id$ *) 24 | 25 | let _ = 26 | let ldif = new Ldif_oo.ldif () in 27 | ldif#write_entry ldif#read_entry, 28 | flush_all 29 | -------------------------------------------------------------------------------- /tests/ldif/testoo.ml: -------------------------------------------------------------------------------- 1 | (* a test program for ldap_ooclient 2 | 3 | Copyright (C) 2004 Eric Stokes, and The California State University 4 | at Northridge 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 2.1 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | Lesser General Public License for more details. 15 | 16 | You should have received a copy of the GNU Lesser General Public 17 | License along with this library; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | open Ldap_ooclient 23 | open Ldif_oo 24 | open Arg 25 | 26 | let () = 27 | (* stuff to handle command line args *) 28 | let usg = "testoo -H -D -w -b " in 29 | let host = ref "" in 30 | let binddn = ref "" in 31 | let cred = ref "" in 32 | let base = ref "" in 33 | let filter = ref "" in 34 | let set_host x = host := x in 35 | let set_binddn x = binddn := x in 36 | let set_cred x = cred := x in 37 | let set_base x = base := x in 38 | let set_filter x = filter := x in 39 | let spec = [("-H", String(set_host), "host"); 40 | ("-D", String(set_binddn), "dn to bind with"); 41 | ("-w", String(set_cred), "password to use when binding"); 42 | ("-b", String(set_base), "search base")] in 43 | 44 | 45 | (* do the ldap part *) 46 | if (Array.length Sys.argv) > 9 then 47 | (parse spec set_filter usg; 48 | let ldap = new ldapcon [!host] in 49 | let ldif = new ldif () in 50 | ldap#bind !binddn ~cred: !cred; 51 | Ldap_ooclient.iter 52 | (fun e -> ldif#write_entry e) 53 | (ldap#search_a ~base: !base !filter)) 54 | else 55 | usage spec usg 56 | --------------------------------------------------------------------------------