1#----------------------------------------------------------------------------- 2# Copyright (C) 1999-2004 Jochen C. Loewer (loewerj@web.de) 3# Copyright (C) 2006 Michael Schlenker (mic42@users.sourceforge.net) 4#----------------------------------------------------------------------------- 5# 6# A (partial) LDAPv3 protocol implementation in plain Tcl. 7# 8# See RFC 4510 and ASN.1 (X.680) and BER (X.690). 9# 10# 11# This software is copyrighted by Jochen C. Loewer (loewerj@web.de). The 12# following terms apply to all files associated with the software unless 13# explicitly disclaimed in individual files. 14# 15# The authors hereby grant permission to use, copy, modify, distribute, 16# and license this software and its documentation for any purpose, provided 17# that existing copyright notices are retained in all copies and that this 18# notice is included verbatim in any distributions. No written agreement, 19# license, or royalty fee is required for any of the authorized uses. 20# Modifications to this software may be copyrighted by their authors 21# and need not follow the licensing terms described here, provided that 22# the new terms are clearly indicated on the first page of each file where 23# they apply. 24# 25# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY 26# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES 27# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY 28# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE 29# POSSIBILITY OF SUCH DAMAGE. 30# 31# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, 32# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, 33# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE 34# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE 35# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR 36# MODIFICATIONS. 37# 38# $Id: ldap.tcl,v 1.26 2008/11/22 12:25:27 mic42 Exp $ 39# 40# written by Jochen Loewer 41# 3 June, 1999 42# 43#----------------------------------------------------------------------------- 44 45package require Tcl 8.4 46package require asn 0.7 47package provide ldap 1.8 48 49namespace eval ldap { 50 51 namespace export connect secure_connect \ 52 disconnect \ 53 bind unbind \ 54 bindSASL \ 55 search \ 56 searchInit \ 57 searchNext \ 58 searchEnd \ 59 modify \ 60 modifyMulti \ 61 add \ 62 addMulti \ 63 delete \ 64 modifyDN \ 65 info 66 67 namespace import ::asn::* 68 69 variable SSLCertifiedAuthoritiesFile 70 variable doDebug 71 72 set doDebug 0 73 74 # LDAP result codes from the RFC 75 variable resultCode2String 76 array set resultCode2String { 77 0 success 78 1 operationsError 79 2 protocolError 80 3 timeLimitExceeded 81 4 sizeLimitExceeded 82 5 compareFalse 83 6 compareTrue 84 7 authMethodNotSupported 85 8 strongAuthRequired 86 10 referral 87 11 adminLimitExceeded 88 12 unavailableCriticalExtension 89 13 confidentialityRequired 90 14 saslBindInProgress 91 16 noSuchAttribute 92 17 undefinedAttributeType 93 18 inappropriateMatching 94 19 constraintViolation 95 20 attributeOrValueExists 96 21 invalidAttributeSyntax 97 32 noSuchObject 98 33 aliasProblem 99 34 invalidDNSyntax 100 35 isLeaf 101 36 aliasDereferencingProblem 102 48 inappropriateAuthentication 103 49 invalidCredentials 104 50 insufficientAccessRights 105 51 busy 106 52 unavailable 107 53 unwillingToPerform 108 54 loopDetect 109 64 namingViolation 110 65 objectClassViolation 111 66 notAllowedOnNonLeaf 112 67 notAllowedOnRDN 113 68 entryAlreadyExists 114 69 objectClassModsProhibited 115 80 other 116 } 117 118} 119 120 121#----------------------------------------------------------------------------- 122# Lookup an numerical ldap result code and return a string version 123# 124#----------------------------------------------------------------------------- 125proc ::ldap::resultCode2String {code} { 126 variable resultCode2String 127 if {[::info exists resultCode2String($code)]} { 128 return $resultCode2String($code) 129 } else { 130 return "unknownError" 131 } 132} 133 134#----------------------------------------------------------------------------- 135# Basic sanity check for connection handles 136# must be an array 137#----------------------------------------------------------------------------- 138proc ::ldap::CheckHandle {handle} { 139 if {![array exists $handle]} { 140 return -code error \ 141 [format "Not a valid LDAP connection handle: %s" $handle] 142 } 143} 144 145#----------------------------------------------------------------------------- 146# info 147# 148#----------------------------------------------------------------------------- 149 150proc ldap::info {args} { 151 set cmd [lindex $args 0] 152 set cmds {connections bound bounduser control extensions features ip saslmechanisms tls whoami} 153 if {[llength $args] == 0} { 154 return -code error \ 155 "Usage: \"info subcommand ?handle?\"" 156 } 157 if {[lsearch -exact $cmds $cmd] == -1} { 158 return -code error \ 159 "Invalid subcommand \"$cmd\", valid commands are\ 160 [join [lrange $cmds 0 end-1] ,] and [lindex $cmds end]" 161 } 162 eval [linsert [lrange $args 1 end] 0 ldap::info_$cmd] 163} 164 165#----------------------------------------------------------------------------- 166# get the ip address of the server we connected to 167# 168#----------------------------------------------------------------------------- 169proc ldap::info_ip {args} { 170 if {[llength $args] != 1} { 171 return -code error \ 172 "Wrong # of arguments. Usage: ldap::info ip handle" 173 } 174 CheckHandle [lindex $args 0] 175 upvar #0 [lindex $args 0] conn 176 if {![::info exists conn(sock)]} { 177 return -code error \ 178 "\"[lindex $args 0]\" is not a ldap connection handle" 179 } 180 return [lindex [fconfigure $conn(sock) -peername] 0] 181} 182 183#----------------------------------------------------------------------------- 184# get the list of open ldap connections 185# 186#----------------------------------------------------------------------------- 187proc ldap::info_connections {args} { 188 if {[llength $args] != 0} { 189 return -code error \ 190 "Wrong # of arguments. Usage: ldap::info connections" 191 } 192 return [::info vars ::ldap::ldap*] 193} 194 195#----------------------------------------------------------------------------- 196# check if the connection is bound 197# 198#----------------------------------------------------------------------------- 199proc ldap::info_bound {args} { 200 if {[llength $args] != 1} { 201 return -code error \ 202 "Wrong # of arguments. Usage: ldap::info bound handle" 203 } 204 CheckHandle [lindex $args 0] 205 upvar #0 [lindex $args 0] conn 206 if {![::info exists conn(bound)]} { 207 return -code error \ 208 "\"[lindex $args 0]\" is not a ldap connection handle" 209 } 210 211 return $conn(bound) 212} 213 214#----------------------------------------------------------------------------- 215# check with which user the connection is bound 216# 217#----------------------------------------------------------------------------- 218proc ldap::info_bounduser {args} { 219 if {[llength $args] != 1} { 220 return -code error \ 221 "Wrong # of arguments. Usage: ldap::info bounduser handle" 222 } 223 CheckHandle [lindex $args 0] 224 upvar #0 [lindex $args 0] conn 225 if {![::info exists conn(bound)]} { 226 return -code error \ 227 "\"[lindex $args 0]\" is not a ldap connection handle" 228 } 229 230 return $conn(bounduser) 231} 232 233#----------------------------------------------------------------------------- 234# check if the connection uses tls 235# 236#----------------------------------------------------------------------------- 237 238proc ldap::info_tls {args} { 239 if {[llength $args] != 1} { 240 return -code error \ 241 "Wrong # of arguments. Usage: ldap::info tls handle" 242 } 243 CheckHandle [lindex $args 0] 244 upvar #0 [lindex $args 0] conn 245 if {![::info exists conn(tls)]} { 246 return -code error \ 247 "\"[lindex $args 0]\" is not a ldap connection handle" 248 } 249 return $conn(tls) 250} 251 252proc ldap::info_saslmechanisms {args} { 253 if {[llength $args] != 1} { 254 return -code error \ 255 "Wrong # of arguments. Usage: ldap::info saslmechanisms handle" 256 } 257 return [Saslmechanisms [lindex $args 0]] 258} 259 260proc ldap::info_extensions {args} { 261 if {[llength $args] != 1} { 262 return -code error \ 263 "Wrong # of arguments. Usage: ldap::info extensions handle" 264 } 265 return [Extensions [lindex $args 0]] 266} 267 268proc ldap::info_control {args} { 269 if {[llength $args] != 1} { 270 return -code error \ 271 "Wrong # of arguments. Usage: ldap::info control handle" 272 } 273 return [Control [lindex $args 0]] 274} 275 276proc ldap::info_features {args} { 277 if {[llength $args] != 1} { 278 return -code error \ 279 "Wrong # of arguments. Usage: ldap::info features handle" 280 } 281 return [Features [lindex $args 0]] 282} 283 284proc ldap::info_whoami {args} { 285 if {[llength $args] != 1} { 286 return -code error \ 287 "Wrong # of arguments. Usage: ldap::info whoami handle" 288 } 289 return [Whoami [lindex $args 0]] 290} 291 292 293#----------------------------------------------------------------------------- 294# Basic server introspection support 295# 296#----------------------------------------------------------------------------- 297proc ldap::Saslmechanisms {conn} { 298 CheckHandle $conn 299 lindex [ldap::search $conn {} {(objectClass=*)} \ 300 {supportedSASLMechanisms} -scope base] 0 1 1 301} 302 303proc ldap::Extensions {conn} { 304 CheckHandle $conn 305 lindex [ldap::search $conn {} {(objectClass=*)} \ 306 {supportedExtension} -scope base] 0 1 1 307} 308 309proc ldap::Control {conn} { 310 CheckHandle $conn 311 lindex [ldap::search $conn {} {(objectClass=*)} \ 312 {supportedControl} -scope base] 0 1 1 313} 314 315proc ldap::Features {conn} { 316 CheckHandle $conn 317 lindex [ldap::search $conn {} {(objectClass=*)} \ 318 {supportedFeatures} -scope base] 0 1 1 319} 320 321#------------------------------------------------------------------------------- 322# Implements the RFC 4532 extension "Who am I?" 323# 324#------------------------------------------------------------------------------- 325proc ldap::Whoami {handle} { 326 CheckHandle $handle 327 if {[lsearch [ldap::Extensions $handle] 1.3.6.1.4.1.4203.1.11.3] == -1} { 328 return -code error \ 329 "Server does not support the \"Who am I?\" extension" 330 } 331 332 set request [asnApplicationConstr 23 [asnOctetString 1.3.6.1.4.1.4203.1.11.3]] 333 set mid [SendMessage $handle $request] 334 set response [WaitForResponse $handle $mid] 335 336 asnGetApplication response appNum 337 if {$appNum != 24} { 338 return -code error \ 339 "unexpected application number ($appNum != 24)" 340 } 341 342 asnGetEnumeration response resultCode 343 asnGetOctetString response matchedDN 344 asnGetOctetString response errorMessage 345 if {$resultCode != 0} { 346 return -code error \ 347 -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \ 348 "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage" 349 } 350 set whoami "" 351 if {[string length $response]} { 352 asnRetag response 0x04 353 asnGetOctetString response whoami 354 } 355 return $whoami 356} 357 358#----------------------------------------------------------------------------- 359# connect 360# 361#----------------------------------------------------------------------------- 362proc ldap::connect { host {port 389} } { 363 364 #-------------------------------------- 365 # connect via TCP/IP 366 #-------------------------------------- 367 set sock [socket $host $port] 368 fconfigure $sock -blocking no -translation binary -buffering full 369 370 #-------------------------------------- 371 # initialize connection array 372 #-------------------------------------- 373 upvar #0 ::ldap::ldap$sock conn 374 catch { unset conn } 375 376 set conn(host) $host 377 set conn(sock) $sock 378 set conn(messageId) 0 379 set conn(tls) 0 380 set conn(bound) 0 381 set conn(bounduser) "" 382 set conn(saslBindInProgress) 0 383 set conn(tlsHandshakeInProgress) 0 384 set conn(lastError) "" 385 set conn(referenceVar) [namespace current]::searchReferences 386 set conn(returnReferences) 0 387 388 fileevent $sock readable [list ::ldap::MessageReceiver ::ldap::ldap$sock] 389 return ::ldap::ldap$sock 390} 391 392#----------------------------------------------------------------------------- 393# secure_connect 394# 395#----------------------------------------------------------------------------- 396proc ldap::secure_connect { host {port 636} } { 397 398 variable SSLCertifiedAuthoritiesFile 399 400 package require tls 401 402 #------------------------------------------------------------------ 403 # connect via TCP/IP 404 #------------------------------------------------------------------ 405 set sock [socket $host $port] 406 fconfigure $sock -blocking no -translation binary -buffering full 407 408 #------------------------------------------------------------------ 409 # make it a SSL connection 410 # 411 #------------------------------------------------------------------ 412 #tls::import $sock -cafile $SSLCertifiedAuthoritiesFile -ssl2 no -ssl3 yes -tls1 yes 413 tls::import $sock -cafile "" -certfile "" -keyfile "" \ 414 -request 1 -server 0 -require 0 -ssl2 no -ssl3 yes -tls1 yes 415 set retry 0 416 while {1} { 417 if {$retry > 20} { 418 close $sock 419 return -code error "too long retry to setup SSL connection" 420 } 421 if {[catch { tls::handshake $sock } err]} { 422 if {[string match "*resource temporarily unavailable*" $err]} { 423 after 50 424 incr retry 425 } else { 426 close $sock 427 return -code error $err 428 } 429 } else { 430 break 431 } 432 } 433 434 #-------------------------------------- 435 # initialize connection array 436 #-------------------------------------- 437 upvar ::ldap::ldap$sock conn 438 catch { unset conn } 439 440 set conn(host) $host 441 set conn(sock) $sock 442 set conn(messageId) 0 443 set conn(tls) 1 444 set conn(bound) 0 445 set conn(bounduser) "" 446 set conn(saslBindInProgress) 0 447 set conn(tlsHandshakeInProgress) 0 448 set conn(lasterror) "" 449 set conn(referenceVar) [namespace current]::searchReferences 450 set conn(returnReferences) 0 451 452 fileevent $sock readable [list ::ldap::MessageReceiver ::ldap::ldap$sock] 453 return ::ldap::ldap$sock 454} 455 456 457#------------------------------------------------------------------------------ 458# starttls - negotiate tls on an open ldap connection 459# 460#------------------------------------------------------------------------------ 461proc ldap::starttls {handle {cafile ""} {certfile ""} {keyfile ""}} { 462 CheckHandle $handle 463 464 upvar #0 $handle conn 465 466 if {$conn(tls)} { 467 return -code error \ 468 "Cannot StartTLS on connection, TLS already running" 469 } 470 471 if {[ldap::waitingForMessages $handle]} { 472 return -code error \ 473 "Cannot StartTLS while waiting for repsonses" 474 } 475 476 if {$conn(saslBindInProgress)} { 477 return -code error \ 478 "Cannot StartTLS while SASL bind in progress" 479 } 480 481 if {[lsearch -exact [ldap::Extensions $handle] 1.3.6.1.4.1.1466.20037] == -1} { 482 return -code error \ 483 "Server does not support the StartTLS extension" 484 } 485 package require tls 486 487 488 set request [asnApplicationConstr 23 [asnOctetString 1.3.6.1.4.1.1466.20037]] 489 set mid [SendMessage $handle $request] 490 set conn(tlsHandshakeInProgress) 1 491 set response [WaitForResponse $handle $mid] 492 493 asnGetApplication response appNum 494 if {$appNum != 24} { 495 set conn(tlsHandshakeInProgress) 0 496 return -code error \ 497 "unexpected application number ($appNum != 24)" 498 } 499 500 asnGetEnumeration response resultCode 501 asnGetOctetString response matchedDN 502 asnGetOctetString response errorMessage 503 if {$resultCode != 0} { 504 set conn(tlsHandshakeInProgress) 0 505 return -code error \ 506 -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \ 507 "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage" 508 } 509 set oid "1.3.6.1.4.1.1466.20037" 510 if {[string length $response]} { 511 asnRetag response 0x04 512 asnGetOctetString response oid 513 } 514 if {$oid ne "1.3.6.1.4.1.1466.20037"} { 515 set conn(tlsHandshakeInProgress) 0 516 return -code error \ 517 "Unexpected LDAP response" 518 } 519 520 tls::import $conn(sock) -cafile $cafile -certfile $certfile -keyfile $keyfile \ 521 -request 1 -server 0 -require 0 -ssl2 no -ssl3 yes -tls1 yes 522 set retry 0 523 while {1} { 524 if {$retry > 20} { 525 close $sock 526 return -code error "too long retry to setup SSL connection" 527 } 528 if {[catch { tls::handshake $conn(sock) } err]} { 529 if {[string match "*resource temporarily unavailable*" $err]} { 530 after 50 531 incr retry 532 } else { 533 close $conn(sock) 534 return -code error $err 535 } 536 } else { 537 break 538 } 539 } 540 set conn(tls) 1 541 set conn(tlsHandshakeInProgress) 0 542 return 1 543} 544 545 546 547#------------------------------------------------------------------------------ 548# Create a new unique message and send it over the socket. 549# 550#------------------------------------------------------------------------------ 551 552proc ldap::CreateAndSendMessage {handle payload} { 553 upvar #0 $handle conn 554 555 if {$conn(tlsHandshakeInProgress)} { 556 return -code error \ 557 "Cannot send other LDAP PDU while TLS handshake in progress" 558 } 559 560 incr conn(messageId) 561 set message [asnSequence [asnInteger $conn(messageId)] $payload] 562 debugData "Message $conn(messageId) Sent" $message 563 puts -nonewline $conn(sock) $message 564 flush $conn(sock) 565 return $conn(messageId) 566} 567 568#------------------------------------------------------------------------------ 569# Send a message to the server which expects a response, 570# returns the messageId which is to be used with FinalizeMessage 571# and WaitForResponse 572# 573#------------------------------------------------------------------------------ 574proc ldap::SendMessage {handle pdu} { 575 upvar #0 $handle conn 576 set mid [CreateAndSendMessage $handle $pdu] 577 578 # safe the state to match responses 579 set conn(message,$mid) [list] 580 return $mid 581} 582 583#------------------------------------------------------------------------------ 584# Send a message to the server without expecting a response 585# 586#------------------------------------------------------------------------------ 587proc ldap::SendMessageNoReply {handle pdu} { 588 upvar #0 $handle conn 589 return [CreateAndSendMessage $handle $pdu] 590} 591 592#------------------------------------------------------------------------------ 593# Cleanup the storage associated with a messageId 594# 595#------------------------------------------------------------------------------ 596proc ldap::FinalizeMessage {handle messageId} { 597 upvar #0 $handle conn 598 trace "Message $messageId finalized" 599 unset -nocomplain conn(message,$messageId) 600} 601 602#------------------------------------------------------------------------------ 603# Wait for a response for the given messageId. 604# 605# This waits in a vwait if no message has yet been received or returns 606# the oldest message at once, if it is queued. 607# 608#------------------------------------------------------------------------------ 609proc ldap::WaitForResponse {handle messageId} { 610 upvar #0 $handle conn 611 612 trace "Waiting for Message $messageId" 613 # check if the message waits for a reply 614 if {![::info exists conn(message,$messageId)]} { 615 return -code error \ 616 [format "Cannot wait for message %d." $messageId] 617 } 618 619 # check if we have a received response in the buffer 620 if {[llength $conn(message,$messageId)] > 0} { 621 set response [lindex $conn(message,$messageId) 0] 622 set conn(message,$messageId) [lrange $conn(message,$messageId) 1 end] 623 return $response 624 } 625 626 # wait for an incoming response 627 vwait [namespace which -variable $handle](message,$messageId) 628 if {[llength $conn(message,$messageId)] == 0} { 629 # We have waited and have been awakended but no message is there 630 if {[string length $conn(lastError)]} { 631 return -code error \ 632 [format "Protocol error: %s" $conn(lastError)] 633 } else { 634 return -code error \ 635 [format "Broken response for message %d" $messageId] 636 } 637 } 638 set response [lindex $conn(message,$messageId) 0] 639 set conn(message,$messageId) [lrange $conn(message,$messageId) 1 end] 640 return $response 641} 642 643proc ldap::waitingForMessages {handle} { 644 upvar #0 $handle conn 645 return [llength [array names conn message,*]] 646} 647 648#------------------------------------------------------------------------------ 649# Process a single response PDU. Decodes the messageId and puts the 650# message into the appropriate queue. 651# 652#------------------------------------------------------------------------------ 653 654proc ldap::ProcessMessage {handle response} { 655 upvar #0 $handle conn 656 657 # decode the messageId 658 asnGetInteger response messageId 659 660 # check if we wait for a response 661 if {[::info exists conn(message,$messageId)]} { 662 # append the new message, which triggers 663 # message handlers using vwait on the entry 664 lappend conn(message,$messageId) $response 665 return 666 } 667 668 # handle unsolicited server responses 669 670 if {0} { 671 asnGetApplication response appNum 672 #if { $appNum != 24 } { 673 # error "unexpected application number ($appNum != 24)" 674 #} 675 asnGetEnumeration response resultCode 676 asnGetOctetString response matchedDN 677 asnGetOctetString response errorMessage 678 if {[string length $response]} { 679 asnGetOctetString response responseName 680 } 681 if {[string length $response]} { 682 asnGetOctetString response responseValue 683 } 684 if {$resultCode != 0} { 685 return -code error \ 686 -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \ 687 "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage" 688 } 689 } 690 #dumpASN1Parse $response 691 #error "Unsolicited message from server" 692 693} 694 695#------------------------------------------------------------------------------- 696# Get the code out of waitForResponse in case of errors 697# 698#------------------------------------------------------------------------------- 699proc ldap::CleanupWaitingMessages {handle} { 700 upvar #0 $handle conn 701 foreach message [array names conn message,*] { 702 set conn($message) [list] 703 } 704} 705 706#------------------------------------------------------------------------------- 707# The basic fileevent based message receiver. 708# It reads PDU's from the network in a non-blocking fashion. 709# 710#------------------------------------------------------------------------------- 711proc ldap::MessageReceiver {handle} { 712 upvar #0 $handle conn 713 714 # We have to account for partial PDUs received, so 715 # we keep some state information. 716 # 717 # conn(pdu,partial) -- we are reading a partial pdu if non zero 718 # conn(pdu,length_bytes) -- the buffer for loading the length 719 # conn(pdu,length) -- we have decoded the length if >= 0, if <0 it contains 720 # the length of the length encoding in bytes 721 # conn(pdu,payload) -- the payload buffer 722 # conn(pdu,received) -- the data received 723 724 # fetch the sequence byte 725 if {[::info exists conn(pdu,partial)] && $conn(pdu,partial) != 0} { 726 # we have decoded at least the type byte 727 } else { 728 foreach {code type} [ReceiveBytes $conn(sock) 1] {break} 729 switch -- $code { 730 ok { 731 binary scan $type c byte 732 set type [expr {($byte + 0x100) % 0x100}] 733 if {$type != 0x30} { 734 CleanupWaitingMessages $handle 735 set conn(lastError) [format "Expected SEQUENCE (0x30) but got %x" $type] 736 return 737 } else { 738 set conn(pdu,partial) 1 739 append conn(pdu,received) $type 740 } 741 } 742 eof { 743 CleanupWaitingMessages $handle 744 set conn(lastError) "Server closed connection" 745 catch {close $conn(sock)} 746 return 747 } 748 default { 749 CleanupWaitingMessages $handle 750 set bytes $type[read $conn(sock)] 751 binary scan $bytes h* values 752 set conn(lastError) [format \ 753 "Error reading SEQUENCE response for handle %s : %s : %s" $handle $code $values] 754 return 755 } 756 } 757 } 758 759 760 # fetch the length 761 if {[::info exists conn(pdu,length)] && $conn(pdu,length) >= 0} { 762 # we already have a decoded length 763 } else { 764 if {[::info exists conn(pdu,length)] && $conn(pdu,length) < 0} { 765 # we already know the length, but have not received enough bytes to decode it 766 set missing [expr {1+abs($conn(pdu,length))-[string length $conn(pdu,length_bytes)]}] 767 if {$missing != 0} { 768 foreach {code bytes} [ReceiveBytes $conn(sock) $missing] {break} 769 switch -- $code { 770 "ok" { 771 append conn(pdu,length_bytes) $bytes 772 append conn(pdu,received) $bytes 773 asnGetLength conn(pdu,length_bytes) conn(pdu,length) 774 } 775 "partial" { 776 append conn(pdu,length_bytes) $bytes 777 append conn(pdu,received) $bytes 778 return 779 } 780 "eof" { 781 CleanupWaitingMessages $handle 782 catch {close $conn(sock)} 783 set conn(lastError) "Server closed connection" 784 return 785 } 786 default { 787 CleanupWaitingMessages $handle 788 set conn(lastError) [format \ 789 "Error reading LENGTH2 response for handle %s : %s" $handle $code] 790 return 791 } 792 } 793 } 794 } else { 795 # we know nothing, need to read the first length byte 796 foreach {code bytes} [ReceiveBytes $conn(sock) 1] {break} 797 switch -- $code { 798 "ok" { 799 set conn(pdu,length_bytes) $bytes 800 binary scan $bytes c byte 801 set size [expr {($byte + 0x100) % 0x100}] 802 if {$size > 0x080} { 803 set conn(pdu,length) [expr {-1* ($size & 0x7f)}] 804 # fetch the rest with the next fileevent 805 return 806 } else { 807 asnGetLength conn(pdu,length_bytes) conn(pdu,length) 808 } 809 } 810 "eof" { 811 CleanupWaitingMessages $handle 812 catch {close $conn(sock)} 813 set conn(lastError) "Server closed connection" 814 } 815 default { 816 CleanupWaitingMessages $handle 817 set conn(lastError) [format \ 818 "Error reading LENGTH1 response for handle %s : %s" $handle $code] 819 return 820 } 821 } 822 } 823 } 824 825 if {[::info exists conn(pdu,payload)]} { 826 # length is decoded, we can read the rest 827 set missing [expr {$conn(pdu,length) - [string length $conn(pdu,payload)]}] 828 } else { 829 set missing $conn(pdu,length) 830 } 831 if {$missing > 0} { 832 foreach {code bytes} [ReceiveBytes $conn(sock) $missing] {break} 833 switch -- $code { 834 "ok" { 835 append conn(pdu,payload) $bytes 836 } 837 "partial" { 838 append conn(pdu,payload) $bytes 839 return 840 } 841 "eof" { 842 CleanupWaitingMessages $handle 843 catch {close $conn(sock)} 844 set conn(lastError) "Server closed connection" 845 } 846 default { 847 CleanupWaitingMessages $handle 848 set conn(lastError) [format \ 849 "Error reading DATA response for handle %s : %s" $handle $code] 850 return 851 } 852 } 853 } 854 855 # we have a complete PDU, push it for processing 856 set pdu $conn(pdu,payload) 857 set conn(pdu,payload) "" 858 set conn(pdu,partial) 0 859 unset -nocomplain set conn(pdu,length) 860 set conn(pdu,length_bytes) "" 861 862 # reschedule message Processing 863 after 0 [list ::ldap::ProcessMessage $handle $pdu] 864} 865 866#------------------------------------------------------------------------------- 867# Receive the number of bytes from the socket and signal error conditions. 868# 869#------------------------------------------------------------------------------- 870proc ldap::ReceiveBytes {sock bytes} { 871 set status [catch {read $sock $bytes} block] 872 if { $status != 0 } { 873 return [list error $block] 874 } elseif { [string length $block] == $bytes } { 875 # we have all bytes we wanted 876 return [list ok $block] 877 } elseif { [eof $sock] } { 878 return [list eof $block] 879 } elseif { [fblocked $sock] || ([string length $block] < $bytes)} { 880 return [list partial $block] 881 } else { 882 error "Socket state for socket $sock undefined!" 883 } 884} 885 886#----------------------------------------------------------------------------- 887# bindSASL - does a bind with SASL authentication 888#----------------------------------------------------------------------------- 889 890proc ldap::bindSASL {handle {name ""} {password ""} } { 891 CheckHandle $handle 892 893 package require SASL 894 895 upvar #0 $handle conn 896 897 set mechs [ldap::Saslmechanisms $handle] 898 899 set conn(saslBindInProgress) 1 900 set auth 0 901 foreach mech [SASL::mechanisms] { 902 if {[lsearch -exact $mechs $mech] == -1} { continue } 903 trace "Using $mech for SASL Auth" 904 if {[catch { 905 SASLAuth $handle $mech $name $password 906 } msg]} { 907 trace [format "AUTH %s failed: %s" $mech $msg] 908 } else { 909 # AUTH was successful 910 if {$msg == 1} { 911 set auth 1 912 break 913 } 914 } 915 } 916 917 set conn(saslBindInProgress) 0 918 return $auth 919} 920 921#----------------------------------------------------------------------------- 922# SASLCallback - Callback to use for SASL authentication 923# 924# More or less cut and copied from the smtp module. 925# May need adjustments for ldap. 926# 927#----------------------------------------------------------------------------- 928proc ::ldap::SASLCallback {handle context command args} { 929 upvar #0 $handle conn 930 upvar #0 $context ctx 931 array set options $conn(options) 932 trace "SASLCallback $command" 933 switch -exact -- $command { 934 login { return $options(-username) } 935 username { return $options(-username) } 936 password { return $options(-password) } 937 hostname { return [::info hostname] } 938 realm { 939 if {[string equal $ctx(mech) "NTLM"] \ 940 && [info exists ::env(USERDOMAIN)]} { 941 return $::env(USERDOMAIN) 942 } else { 943 return "" 944 } 945 } 946 default { 947 return -code error "error: unsupported SASL information requested" 948 } 949 } 950} 951 952#----------------------------------------------------------------------------- 953# SASLAuth - Handles the actual SASL message exchange 954# 955#----------------------------------------------------------------------------- 956 957proc ldap::SASLAuth {handle mech name password} { 958 upvar 1 $handle conn 959 960 set conn(options) [list -password $password -username $name] 961 962 # check for tcllib bug # 1545306 and reset the nonce-count if 963 # found, so a second call to this code does not fail 964 # 965 if {[::info exists ::SASL::digest_md5_noncecount]} { 966 set ::SASL::digest_md5_noncecount 0 967 } 968 969 set ctx [SASL::new -mechanism $mech \ 970 -service ldap \ 971 -callback [list ::ldap::SASLCallback $handle]] 972 973 set msg(serverSASLCreds) "" 974 # Do the SASL Message exchanges 975 while {[SASL::step $ctx $msg(serverSASLCreds)]} { 976 # Create and send the BindRequest 977 set request [buildSASLBindRequest "" $mech [SASL::response $ctx]] 978 set messageId [SendMessage $handle $request] 979 debugData bindRequest $request 980 981 set response [WaitForResponse $handle $messageId] 982 FinalizeMessage $handle $messageId 983 debugData bindResponse $response 984 985 array set msg [decodeSASLBindResponse $handle $response] 986 987 # Check for Bind success 988 if {$msg(resultCode) == 0} { 989 set conn(bound) 1 990 set conn(bounduser) $name 991 SASL::cleanup $ctx 992 break 993 } 994 995 # Check if next SASL step is requested 996 if {$msg(resultCode) == 14} { 997 continue 998 } 999 1000 SASL::cleanup $ctx 1001 # Something went wrong 1002 return -code error \ 1003 -errorcode [list LDAP [resultCode2String $msg(resultCode)] \ 1004 $msg(matchedDN) $msg(errorMessage)] \ 1005 "LDAP error [resultCode2String $msg(resultCode)] '$msg(matchedDN)': $msg(errorMessage)" 1006 } 1007 1008 return 1 1009} 1010 1011#---------------------------------------------------------------------------- 1012# 1013# Create a LDAP BindRequest using SASL 1014# 1015#---------------------------------------------------------------------------- 1016 1017proc ldap::buildSASLBindRequest {name mech {credentials {}}} { 1018 if {$credentials ne {}} { 1019 set request [ asnApplicationConstr 0 \ 1020 [asnInteger 3] \ 1021 [asnOctetString $name] \ 1022 [asnChoiceConstr 3 \ 1023 [asnOctetString $mech] \ 1024 [asnOctetString $credentials] \ 1025 ] \ 1026 ] 1027 } else { 1028 set request [ asnApplicationConstr 0 \ 1029 [asnInteger 3] \ 1030 [asnOctetString $name] \ 1031 [asnChoiceConstr 3 \ 1032 [asnOctetString $mech] \ 1033 ] \ 1034 ] 1035 } 1036 return $request 1037} 1038 1039#------------------------------------------------------------------------------- 1040# 1041# Decode an LDAP BindResponse 1042# 1043#------------------------------------------------------------------------------- 1044proc ldap::decodeSASLBindResponse {handle response} { 1045 upvar #0 $handle conn 1046 1047 asnGetApplication response appNum 1048 if { $appNum != 1 } { 1049 error "unexpected application number ($appNum != 1)" 1050 } 1051 asnGetEnumeration response resultCode 1052 asnGetOctetString response matchedDN 1053 asnGetOctetString response errorMessage 1054 1055 # Check if we have a serverSASLCreds field left, 1056 # or if this is a simple response without it 1057 # probably an error message then. 1058 if {[string length $response]} { 1059 asnRetag response 0x04 1060 asnGetOctetString response serverSASLCreds 1061 } else { 1062 set serverSASLCreds "" 1063 } 1064 return [list appNum $appNum \ 1065 resultCode $resultCode matchedDN $matchedDN \ 1066 errorMessage $errorMessage serverSASLCreds $serverSASLCreds] 1067} 1068 1069 1070#----------------------------------------------------------------------------- 1071# bind - does a bind with simple authentication 1072# 1073#----------------------------------------------------------------------------- 1074proc ldap::bind { handle {name ""} {password ""} } { 1075 CheckHandle $handle 1076 1077 upvar #0 $handle conn 1078 1079 #----------------------------------------------------------------- 1080 # marshal bind request packet and send it 1081 # 1082 #----------------------------------------------------------------- 1083 set request [asnApplicationConstr 0 \ 1084 [asnInteger 3] \ 1085 [asnOctetString $name] \ 1086 [asnChoice 0 $password] \ 1087 ] 1088 set messageId [SendMessage $handle $request] 1089 debugData bindRequest $request 1090 1091 set response [WaitForResponse $handle $messageId] 1092 FinalizeMessage $handle $messageId 1093 debugData bindResponse $response 1094 1095 asnGetApplication response appNum 1096 if { $appNum != 1 } { 1097 error "unexpected application number ($appNum != 1)" 1098 } 1099 asnGetEnumeration response resultCode 1100 asnGetOctetString response matchedDN 1101 asnGetOctetString response errorMessage 1102 if {$resultCode != 0} { 1103 return -code error \ 1104 -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \ 1105 "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage" 1106 } 1107 set conn(bound) 1 1108 set conn(bounduser) $name 1109} 1110 1111 1112#----------------------------------------------------------------------------- 1113# unbind 1114# 1115#----------------------------------------------------------------------------- 1116proc ldap::unbind { handle } { 1117 CheckHandle $handle 1118 1119 upvar #0 $handle conn 1120 1121 #------------------------------------------------ 1122 # marshal unbind request packet and send it 1123 #------------------------------------------------ 1124 set request [asnApplication 2 ""] 1125 SendMessageNoReply $handle $request 1126 1127 set conn(bounduser) "" 1128 set conn(bound) 0 1129 close $conn(sock) 1130 set conn(sock) "" 1131} 1132 1133 1134#----------------------------------------------------------------------------- 1135# search - performs a LDAP search below the baseObject tree using a 1136# complex LDAP search expression (like "|(cn=Linus*)(sn=Torvalds*)" 1137# and returns all matching objects (DNs) with given attributes 1138# (or all attributes if empty list is given) as list: 1139# 1140# {dn1 { attr1 {val11 val12 ...} attr2 {val21 val22 ... } ... }} {dn2 { ... }} ... 1141# 1142#----------------------------------------------------------------------------- 1143proc ldap::search { handle baseObject filterString attributes args} { 1144 CheckHandle $handle 1145 1146 upvar #0 $handle conn 1147 1148 searchInit $handle $baseObject $filterString $attributes $args 1149 1150 set results {} 1151 set lastPacket 0 1152 while { !$lastPacket } { 1153 1154 set r [searchNext $handle] 1155 if {[llength $r] > 0} then { 1156 lappend results $r 1157 } else { 1158 set lastPacket 1 1159 } 1160 } 1161 searchEnd $handle 1162 1163 return $results 1164} 1165#----------------------------------------------------------------------------- 1166# searchInProgress - checks if a search is in progress 1167# 1168#----------------------------------------------------------------------------- 1169 1170proc ldap::searchInProgress {handle} { 1171 CheckHandle $handle 1172 upvar #0 $handle conn 1173 if {[::info exists conn(searchInProgress)]} { 1174 return $conn(searchInProgress) 1175 } else { 1176 return 0 1177 } 1178} 1179 1180#----------------------------------------------------------------------------- 1181# searchInit - initiates an LDAP search 1182# 1183#----------------------------------------------------------------------------- 1184proc ldap::searchInit { handle baseObject filterString attributes opt} { 1185 CheckHandle $handle 1186 1187 upvar #0 $handle conn 1188 1189 if {[searchInProgress $handle]} { 1190 return -code error \ 1191 "Cannot start search. Already a search in progress for this handle." 1192 } 1193 1194 set scope 2 1195 set derefAliases 0 1196 set sizeLimit 0 1197 set timeLimit 0 1198 set attrsOnly 0 1199 1200 foreach {key value} $opt { 1201 switch -- [string tolower $key] { 1202 -scope { 1203 switch -- $value { 1204 base { set scope 0 } 1205 one - onelevel { set scope 1 } 1206 sub - subtree { set scope 2 } 1207 default { } 1208 } 1209 } 1210 -derefaliases { 1211 switch -- $value { 1212 never { set derefAliases 0 } 1213 search { set derefAliases 1 } 1214 find { set derefAliases 2 } 1215 always { set derefAliases 3 } 1216 default { } 1217 } 1218 } 1219 -sizelimit { 1220 set sizeLimit $value 1221 } 1222 -timelimit { 1223 set timeLimit $value 1224 } 1225 -attrsonly { 1226 set attrsOnly $value 1227 } 1228 -referencevar { 1229 set referenceVar $value 1230 } 1231 default { 1232 return -code error \ 1233 "Invalid search option '$key'" 1234 } 1235 } 1236 } 1237 1238 set request [buildSearchRequest $baseObject $scope \ 1239 $derefAliases $sizeLimit $timeLimit $attrsOnly $filterString \ 1240 $attributes] 1241 set messageId [SendMessage $handle $request] 1242 debugData searchRequest $request 1243 1244 # Keep the message Id, so we know about the search 1245 set conn(searchInProgress) $messageId 1246 if {[::info exists referenceVar]} { 1247 set conn(referenceVar) $referenceVar 1248 set $referenceVar [list] 1249 } 1250 1251 return $conn(searchInProgress) 1252} 1253 1254proc ldap::buildSearchRequest {baseObject scope derefAliases 1255 sizeLimit timeLimit attrsOnly filterString 1256 attributes} { 1257 #---------------------------------------------------------- 1258 # marshal filter and attributes parameter 1259 #---------------------------------------------------------- 1260 set berFilter [filter::encode $filterString] 1261 1262 set berAttributes "" 1263 foreach attribute $attributes { 1264 append berAttributes [asnOctetString $attribute] 1265 } 1266 1267 #---------------------------------------------------------- 1268 # marshal search request packet and send it 1269 #---------------------------------------------------------- 1270 set request [asnApplicationConstr 3 \ 1271 [asnOctetString $baseObject] \ 1272 [asnEnumeration $scope] \ 1273 [asnEnumeration $derefAliases] \ 1274 [asnInteger $sizeLimit] \ 1275 [asnInteger $timeLimit] \ 1276 [asnBoolean $attrsOnly] \ 1277 $berFilter \ 1278 [asnSequence $berAttributes] \ 1279 ] 1280 1281} 1282#----------------------------------------------------------------------------- 1283# searchNext - returns the next result of an LDAP search 1284# 1285#----------------------------------------------------------------------------- 1286proc ldap::searchNext { handle } { 1287 CheckHandle $handle 1288 1289 upvar #0 $handle conn 1290 1291 if {! [::info exists conn(searchInProgress)]} then { 1292 return -code error \ 1293 "No search in progress" 1294 } 1295 1296 set result {} 1297 set lastPacket 0 1298 1299 #---------------------------------------------------------- 1300 # Wait for a search response packet 1301 #---------------------------------------------------------- 1302 1303 set response [WaitForResponse $handle $conn(searchInProgress)] 1304 debugData searchResponse $response 1305 1306 asnGetApplication response appNum 1307 1308 if {$appNum == 4} { 1309 trace "Search Response Continue" 1310 #---------------------------------------------------------- 1311 # unmarshal search data packet 1312 #---------------------------------------------------------- 1313 asnGetOctetString response objectName 1314 asnGetSequence response attributes 1315 set result_attributes {} 1316 while { [string length $attributes] != 0 } { 1317 asnGetSequence attributes attribute 1318 asnGetOctetString attribute attrType 1319 asnGetSet attribute attrValues 1320 set result_attrValues {} 1321 while { [string length $attrValues] != 0 } { 1322 asnGetOctetString attrValues attrValue 1323 lappend result_attrValues $attrValue 1324 } 1325 lappend result_attributes $attrType $result_attrValues 1326 } 1327 set result [list $objectName $result_attributes] 1328 } elseif {$appNum == 5} { 1329 trace "Search Response Done" 1330 #---------------------------------------------------------- 1331 # unmarshal search final response packet 1332 #---------------------------------------------------------- 1333 asnGetEnumeration response resultCode 1334 asnGetOctetString response matchedDN 1335 asnGetOctetString response errorMessage 1336 set result {} 1337 FinalizeMessage $handle $conn(searchInProgress) 1338 unset conn(searchInProgress) 1339 1340 if {$resultCode != 0} { 1341 return -code error \ 1342 -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \ 1343 "LDAP error [resultCode2String $resultCode] : $errorMessage" 1344 } 1345 } elseif {$appNum == 19} { 1346 trace "Search Result Reference" 1347 #--------------------------------------------------------- 1348 # unmarshall search result reference packet 1349 #--------------------------------------------------------- 1350 1351 # This should be a sequence but Microsoft AD sends just 1352 # a URI encoded as an OctetString, so have a peek at the tag 1353 # and go on. 1354 1355 asnPeekTag response tag type constr 1356 if {$tag == 0x04} { 1357 set references $response 1358 } elseif {$tag == 0x030} { 1359 asnGetSequence response references 1360 } 1361 1362 set urls {} 1363 while {[string length $references]} { 1364 asnGetOctetString references url 1365 lappend urls $url 1366 } 1367 if {[::info exists conn(referenceVar)]} { 1368 upvar 0 conn(referenceVar) refs 1369 if {[llength $refs]} { 1370 set refs [concat [set $refs $urls]] 1371 } else { 1372 set refs $urls 1373 } 1374 } 1375 1376 # Get the next search result instead 1377 set result [searchNext $handle] 1378 } 1379 1380 # Unknown application type of result set. 1381 # We should just ignore it since the only PDU the server 1382 # MUST return if it understood our request is the "search response 1383 # done" (apptype 5) which we know how to process. 1384 1385 return $result 1386} 1387 1388#----------------------------------------------------------------------------- 1389# searchEnd - end an LDAP search 1390# 1391#----------------------------------------------------------------------------- 1392proc ldap::searchEnd { handle } { 1393 CheckHandle $handle 1394 1395 upvar #0 $handle conn 1396 1397 if {! [::info exists conn(searchInProgress)]} then { 1398 # no harm done, just do nothing 1399 return 1400 } 1401 abandon $handle $conn(searchInProgress) 1402 FinalizeMessage $handle $conn(searchInProgress) 1403 1404 unset conn(searchInProgress) 1405 unset -nocomplain conn(referenceVar) 1406 return 1407} 1408 1409#----------------------------------------------------------------------------- 1410# 1411# Send an LDAP abandon message 1412# 1413#----------------------------------------------------------------------------- 1414proc ldap::abandon {handle messageId} { 1415 CheckHandle $handle 1416 1417 upvar #0 $handle conn 1418 trace "MessagesPending: [string length $conn(messageId)]" 1419 set request [asnApplication 16 \ 1420 [asnInteger $messageId] \ 1421 ] 1422 SendMessageNoReply $handle $request 1423} 1424 1425#----------------------------------------------------------------------------- 1426# modify - provides attribute modifications on one single object (DN): 1427# o replace attributes with new values 1428# o delete attributes (having certain values) 1429# o add attributes with new values 1430# 1431#----------------------------------------------------------------------------- 1432proc ldap::modify { handle dn 1433 attrValToReplace { attrToDelete {} } { attrValToAdd {} } } { 1434 1435 CheckHandle $handle 1436 1437 upvar #0 $handle conn 1438 1439 set lrep {} 1440 foreach {attr value} $attrValToReplace { 1441 lappend lrep $attr [list $value] 1442 } 1443 1444 set ldel {} 1445 foreach {attr value} $attrToDelete { 1446 if {[string equal $value ""]} then { 1447 lappend ldel $attr {} 1448 } else { 1449 lappend ldel $attr [list $value] 1450 } 1451 } 1452 1453 set ladd {} 1454 foreach {attr value} $attrValToAdd { 1455 lappend ladd $attr [list $value] 1456 } 1457 1458 modifyMulti $handle $dn $lrep $ldel $ladd 1459} 1460 1461 1462#----------------------------------------------------------------------------- 1463# modify - provides attribute modifications on one single object (DN): 1464# o replace attributes with new values 1465# o delete attributes (having certain values) 1466# o add attributes with new values 1467# 1468#----------------------------------------------------------------------------- 1469proc ldap::modifyMulti {handle dn 1470 attrValToReplace {attrValToDelete {}} {attrValToAdd {}}} { 1471 1472 CheckHandle $handle 1473 upvar #0 $handle conn 1474 1475 set operationAdd 0 1476 set operationDelete 1 1477 set operationReplace 2 1478 1479 set modifications "" 1480 1481 #------------------------------------------------------------------ 1482 # marshal attribute modify operations 1483 # - always mode 'replace' ! see rfc2251: 1484 # 1485 # replace: replace all existing values of the given attribute 1486 # with the new values listed, creating the attribute if it 1487 # did not already exist. A replace with no value will delete 1488 # the entire attribute if it exists, and is ignored if the 1489 # attribute does not exist. 1490 # 1491 #------------------------------------------------------------------ 1492 append modifications [ldap::packOpAttrVal $operationReplace \ 1493 $attrValToReplace] 1494 1495 #------------------------------------------------------------------ 1496 # marshal attribute add operations 1497 # 1498 #------------------------------------------------------------------ 1499 append modifications [ldap::packOpAttrVal $operationAdd \ 1500 $attrValToAdd] 1501 1502 #------------------------------------------------------------------ 1503 # marshal attribute delete operations 1504 # 1505 # - a non-empty value will trigger to delete only those 1506 # attributes which have the same value as the given one 1507 # 1508 # - an empty value will trigger to delete the attribute 1509 # in all cases 1510 # 1511 #------------------------------------------------------------------ 1512 append modifications [ldap::packOpAttrVal $operationDelete \ 1513 $attrValToDelete] 1514 1515 #---------------------------------------------------------- 1516 # marshal 'modify' request packet and send it 1517 #---------------------------------------------------------- 1518 set request [asnApplicationConstr 6 \ 1519 [asnOctetString $dn ] \ 1520 [asnSequence $modifications ] \ 1521 ] 1522 set messageId [SendMessage $handle $request] 1523 debugData modifyRequest $request 1524 set response [WaitForResponse $handle $messageId] 1525 FinalizeMessage $handle $messageId 1526 debugData bindResponse $response 1527 1528 asnGetApplication response appNum 1529 if { $appNum != 7 } { 1530 error "unexpected application number ($appNum != 7)" 1531 } 1532 asnGetEnumeration response resultCode 1533 asnGetOctetString response matchedDN 1534 asnGetOctetString response errorMessage 1535 if {$resultCode != 0} { 1536 return -code error \ 1537 -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \ 1538 "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage" 1539 } 1540} 1541 1542proc ldap::packOpAttrVal {op attrValueTuples} { 1543 set p "" 1544 foreach {attrName attrValues} $attrValueTuples { 1545 set l {} 1546 foreach v $attrValues { 1547 lappend l [asnOctetString $v] 1548 } 1549 append p [asnSequence \ 1550 [asnEnumeration $op ] \ 1551 [asnSequence \ 1552 [asnOctetString $attrName ] \ 1553 [asnSetFromList $l] \ 1554 ] \ 1555 ] 1556 } 1557 return $p 1558} 1559 1560 1561#----------------------------------------------------------------------------- 1562# add - will create a new object using given DN and sets the given 1563# attributes. Multiple value attributes may be used, provided 1564# that each attr-val pair be listed. 1565# 1566#----------------------------------------------------------------------------- 1567proc ldap::add { handle dn attrValueTuples } { 1568 1569 CheckHandle $handle 1570 1571 # 1572 # In order to handle multi-valuated attributes (see bug 1191326 on 1573 # sourceforge), we walk through tuples to collect all values for 1574 # an attribute. 1575 # http://sourceforge.net/tracker/index.php?func=detail&atid=112883&group_id=12883&aid=1191326 1576 # 1577 1578 foreach { attrName attrValue } $attrValueTuples { 1579 lappend avpairs($attrName) $attrValue 1580 } 1581 1582 return [addMulti $handle $dn [array get avpairs]] 1583} 1584 1585#----------------------------------------------------------------------------- 1586# addMulti - will create a new object using given DN and sets the given 1587# attributes. Argument is a list of attr-listOfVals pair. 1588# 1589#----------------------------------------------------------------------------- 1590proc ldap::addMulti { handle dn attrValueTuples } { 1591 1592 CheckHandle $handle 1593 1594 upvar #0 $handle conn 1595 1596 #------------------------------------------------------------------ 1597 # marshal attribute list 1598 # 1599 #------------------------------------------------------------------ 1600 set attrList "" 1601 1602 foreach { attrName attrValues } $attrValueTuples { 1603 set valList {} 1604 foreach val $attrValues { 1605 lappend valList [asnOctetString $val] 1606 } 1607 append attrList [asnSequence \ 1608 [asnOctetString $attrName ] \ 1609 [asnSetFromList $valList] \ 1610 ] 1611 } 1612 1613 #---------------------------------------------------------- 1614 # marshal search 'add' request packet and send it 1615 #---------------------------------------------------------- 1616 set request [asnApplicationConstr 8 \ 1617 [asnOctetString $dn ] \ 1618 [asnSequence $attrList ] \ 1619 ] 1620 1621 set messageId [SendMessage $handle $request] 1622 debugData addRequest $request 1623 set response [WaitForResponse $handle $messageId] 1624 FinalizeMessage $handle $messageId 1625 debugData bindResponse $response 1626 1627 asnGetApplication response appNum 1628 if { $appNum != 9 } { 1629 error "unexpected application number ($appNum != 9)" 1630 } 1631 asnGetEnumeration response resultCode 1632 asnGetOctetString response matchedDN 1633 asnGetOctetString response errorMessage 1634 if {$resultCode != 0} { 1635 return -code error \ 1636 -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \ 1637 "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage" 1638 } 1639} 1640 1641#----------------------------------------------------------------------------- 1642# delete - removes the whole object (DN) inclusive all attributes 1643# 1644#----------------------------------------------------------------------------- 1645proc ldap::delete { handle dn } { 1646 1647 CheckHandle $handle 1648 1649 upvar #0 $handle conn 1650 1651 #---------------------------------------------------------- 1652 # marshal 'delete' request packet and send it 1653 #---------------------------------------------------------- 1654 set request [asnApplication 10 $dn ] 1655 set messageId [SendMessage $handle $request] 1656 debugData deleteRequest $request 1657 set response [WaitForResponse $handle $messageId] 1658 FinalizeMessage $handle $messageId 1659 1660 debugData deleteResponse $response 1661 1662 asnGetApplication response appNum 1663 if { $appNum != 11 } { 1664 error "unexpected application number ($appNum != 11)" 1665 } 1666 asnGetEnumeration response resultCode 1667 asnGetOctetString response matchedDN 1668 asnGetOctetString response errorMessage 1669 if {$resultCode != 0} { 1670 return -code error \ 1671 -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \ 1672 "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage" 1673 } 1674} 1675 1676 1677#----------------------------------------------------------------------------- 1678# modifyDN - moves an object (DN) to another (relative) place 1679# 1680#----------------------------------------------------------------------------- 1681proc ldap::modifyDN { handle dn newrdn { deleteOld 1 } {newSuperior ! } } { 1682 1683 CheckHandle $handle 1684 1685 upvar #0 $handle conn 1686 1687 #---------------------------------------------------------- 1688 # marshal 'modifyDN' request packet and send it 1689 #---------------------------------------------------------- 1690 1691 if {[string equal $newSuperior "!"]} then { 1692 set request [asnApplicationConstr 12 \ 1693 [asnOctetString $dn ] \ 1694 [asnOctetString $newrdn ] \ 1695 [asnBoolean $deleteOld ] \ 1696 ] 1697 1698 } else { 1699 set request [asnApplicationConstr 12 \ 1700 [asnOctetString $dn ] \ 1701 [asnOctetString $newrdn ] \ 1702 [asnBoolean $deleteOld ] \ 1703 [asnContext 0 $newSuperior] \ 1704 ] 1705 } 1706 set messageId [SendMessage $handle $request] 1707 debugData modifyRequest $request 1708 set response [WaitForResponse $handle $messageId] 1709 1710 asnGetApplication response appNum 1711 if { $appNum != 13 } { 1712 error "unexpected application number ($appNum != 13)" 1713 } 1714 asnGetEnumeration response resultCode 1715 asnGetOctetString response matchedDN 1716 asnGetOctetString response errorMessage 1717 if {$resultCode != 0} { 1718 return -code error \ 1719 -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \ 1720 "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage" 1721 1722 } 1723} 1724 1725#----------------------------------------------------------------------------- 1726# disconnect 1727# 1728#----------------------------------------------------------------------------- 1729proc ldap::disconnect { handle } { 1730 1731 CheckHandle $handle 1732 1733 upvar #0 $handle conn 1734 1735 # should we sent an 'unbind' ? 1736 catch {close $conn(sock)} 1737 unset conn 1738 1739 return 1740} 1741 1742 1743 1744#----------------------------------------------------------------------------- 1745# trace 1746# 1747#----------------------------------------------------------------------------- 1748proc ldap::trace { message } { 1749 1750 variable doDebug 1751 1752 if {!$doDebug} return 1753 1754 puts stderr $message 1755} 1756 1757 1758#----------------------------------------------------------------------------- 1759# debugData 1760# 1761#----------------------------------------------------------------------------- 1762proc ldap::debugData { info data } { 1763 1764 variable doDebug 1765 1766 if {!$doDebug} return 1767 1768 set len [string length $data] 1769 trace "$info ($len bytes):" 1770 set address "" 1771 set hexnums "" 1772 set ascii "" 1773 for {set i 0} {$i < $len} {incr i} { 1774 set v [string index $data $i] 1775 binary scan $v H2 hex 1776 binary scan $v c num 1777 set num [expr {( $num + 0x100 ) % 0x100}] 1778 set text . 1779 if {$num > 31} { 1780 set text $v 1781 } 1782 if { ($i % 16) == 0 } { 1783 if {$address != ""} { 1784 trace [format "%4s %-48s |%s|" $address $hexnums $ascii ] 1785 set address "" 1786 set hexnums "" 1787 set ascii "" 1788 } 1789 append address [format "%04d" $i] 1790 } 1791 append hexnums "$hex " 1792 append ascii $text 1793 #trace [format "%3d %2s %s" $i $hex $text] 1794 } 1795 if {$address != ""} { 1796 trace [format "%4s %-48s |%s|" $address $hexnums $ascii ] 1797 } 1798 trace "" 1799} 1800 1801#----------------------------------------------------------------------------- 1802# ldap::filter -- set of procedures for construction of BER-encoded 1803# data defined by ASN.1 type Filter described in RFC 4511 1804# from string representations of search filters 1805# defined in RFC 4515. 1806#----------------------------------------------------------------------------- 1807namespace eval ldap::filter { 1808 # Regexp which matches strings of type AttribyteType: 1809 variable reatype {[A-Za-z][A-Za-z0-9-]*|\d+(?:\.\d+)+} 1810 1811 # Regexp which matches attribute options in strings 1812 # of type AttributeDescription: 1813 variable reaopts {(?:;[A-Za-z0-9-]+)*} 1814 1815 # Regexp which matches strings of type AttributeDescription. 1816 # Note that this regexp captures attribute options, 1817 # with leading ";", if any. 1818 variable readesc (?:$reatype)($reaopts) 1819 1820 # Two regexps to match strings representing "left hand side" (LHS) 1821 # in extensible match assertion. 1822 # In fact there could be one regexp with two alterations, 1823 # but this would complicate capturing of regexp parts. 1824 # The first regexp captures, in this order: 1825 # 1. Attribute description. 1826 # 2. Attribute options. 1827 # 3. ":dn" string, indicating "Use DN attribute types" flag. 1828 # 4. Matching rule ID. 1829 # The second regexp captures, in this order: 1830 # 1. ":dn" string. 1831 # 2. Matching rule ID. 1832 variable reaextmatch1 ^($readesc)(:dn)?(?::($reatype))?\$ 1833 variable reaextmatch2 ^(:dn)?:($reatype)\$ 1834 1835 # The only validation proc using this regexp requires it to be 1836 # anchored to the boundaries of a string being validated, 1837 # so we change it here to allow this regexp to be compiled: 1838 set readesc ^$readesc\$ 1839 1840 unset reatype reaopts 1841 1842 namespace import ::asn::* 1843} 1844 1845# "Public API" function. 1846# Parses the string represntation of an LDAP search filter expression 1847# and returns its BER-encoded form. 1848# NOTE While RFC 4515 strictly defines that any filter expression must 1849# be surrounded by parentheses it is customary for LDAP client software 1850# to allow specification of simple (i.e. non-compound) filter expressions 1851# without enclosing parentheses, so we also do this (in fact, we allow 1852# omission of outermost parentheses in any filter expression). 1853proc ldap::filter::encode s { 1854 if {[string match (*) $s]} { 1855 ProcessFilter $s 1856 } else { 1857 ProcessFilterComp $s 1858 } 1859} 1860 1861# Parses the string represntation of an LDAP search filter expression 1862# and returns its BER-encoded form. 1863proc ldap::filter::ProcessFilter s { 1864 if {![string match (*) $s]} { 1865 return -code error "Invalid filter: filter expression must be\ 1866 surrounded by parentheses" 1867 } 1868 ProcessFilterComp [string range $s 1 end-1] 1869} 1870 1871# Parses "internals" of a filter expression, i.e. what's contained 1872# between its enclosing parentheses. 1873# It classifies the type of filter expression (compound, negated or 1874# simple) and invokes its corresponding handler. 1875# Returns a BER-encoded form of the filter expression. 1876proc ldap::filter::ProcessFilterComp s { 1877 switch -- [string index $s 0] { 1878 & { 1879 ProcessFilterList 0 [string range $s 1 end] 1880 } 1881 | { 1882 ProcessFilterList 1 [string range $s 1 end] 1883 } 1884 ! { 1885 ProcessNegatedFilter [string range $s 1 end] 1886 } 1887 default { 1888 ProcessMatch $s 1889 } 1890 } 1891} 1892 1893# Parses string $s containing a chain of one or more filter 1894# expressions (as found in compound filter expressions), 1895# processes each filter in such chain and returns 1896# a BER-encoded form of this chain tagged with specified 1897# application type given as $apptype. 1898proc ldap::filter::ProcessFilterList {apptype s} { 1899 set data "" 1900 set rest $s 1901 while 1 { 1902 foreach {filter rest} [ExtractFilter $rest] break 1903 append data [ProcessFilter $filter] 1904 if {$rest == ""} break 1905 } 1906 # TODO looks like it's impossible to hit this condition 1907 if {[string length $data] == 0} { 1908 return -code error "Invalid filter: filter composition must\ 1909 consist of at least one element" 1910 } 1911 asnChoiceConstr $apptype $data 1912} 1913 1914# Parses a string $s representing a filter expression 1915# and returns a BER construction representing negation 1916# of that filter expression. 1917proc ldap::filter::ProcessNegatedFilter s { 1918 asnChoiceConstr 2 [ProcessFilter $s] 1919} 1920 1921# Parses a string $s representing an "attribute matching rule" 1922# (i.e. the contents of a non-compound filter expression) 1923# and returns its BER-encoded form. 1924proc ldap::filter::ProcessMatch s { 1925 if {![regexp -indices {(=|~=|>=|<=|:=)} $s range]} { 1926 return -code error "Invalid filter: no match operator in item" 1927 } 1928 foreach {a z} $range break 1929 set lhs [string range $s 0 [expr {$a - 1}]] 1930 set match [string range $s $a $z] 1931 set val [string range $s [expr {$z + 1}] end] 1932 1933 switch -- $match { 1934 = { 1935 if {$val eq "*"} { 1936 ProcessPresenceMatch $lhs 1937 } else { 1938 if {[regexp {^([^*]*)(\*(?:[^*]*\*)*)([^*]*)$} $val \ 1939 -> initial any final]} { 1940 ProcessSubstringMatch $lhs $initial $any $final 1941 } else { 1942 ProcessSimpleMatch 3 $lhs $val 1943 } 1944 } 1945 } 1946 >= { 1947 ProcessSimpleMatch 5 $lhs $val 1948 } 1949 <= { 1950 ProcessSimpleMatch 6 $lhs $val 1951 } 1952 ~= { 1953 ProcessSimpleMatch 8 $lhs $val 1954 } 1955 := { 1956 ProcessExtensibleMatch $lhs $val 1957 } 1958 } 1959} 1960 1961# From a string $s, containing a chain of filter 1962# expressions (as found in compound filter expressions) 1963# extracts the first filter expression and returns 1964# a two element list composed of the extracted filter 1965# expression and the remainder of the source string. 1966proc ldap::filter::ExtractFilter s { 1967 if {[string index $s 0] ne "("} { 1968 return -code error "Invalid filter: malformed compound filter expression" 1969 } 1970 set pos 1 1971 set nopen 1 1972 while 1 { 1973 if {![regexp -indices -start $pos {\)|\(} $s match]} { 1974 return -code error "Invalid filter: unbalanced parenthesis" 1975 } 1976 set pos [lindex $match 0] 1977 if {[string index $s $pos] eq "("} { 1978 incr nopen 1979 } else { 1980 incr nopen -1 1981 } 1982 if {$nopen == 0} { 1983 return [list [string range $s 0 $pos] \ 1984 [string range $s [incr pos] end]] 1985 } 1986 incr pos 1987 } 1988} 1989 1990# Constructs a BER-encoded form of a "presence" match 1991# involving an attribute description string passed in $attrdesc. 1992proc ldap::filter::ProcessPresenceMatch attrdesc { 1993 ValidateAttributeDescription $attrdesc options 1994 asnChoice 7 [LDAPString $attrdesc] 1995} 1996 1997# Constructs a BER-encoded form of a simple match designated 1998# by application type $apptype and involving an attribute 1999# description $attrdesc and attribute value $val. 2000# "Simple" match is one of: equal, less or equal, greater 2001# or equal, approximate. 2002proc ldap::filter::ProcessSimpleMatch {apptype attrdesc val} { 2003 ValidateAttributeDescription $attrdesc options 2004 append data [asnOctetString [LDAPString $attrdesc]] \ 2005 [asnOctetString [AssertionValue $val]] 2006 asnChoiceConstr $apptype $data 2007} 2008 2009# Constructs a BER-encoded form of a substrings match 2010# involving an attribute description $attrdesc and parts of attribute 2011# value -- $initial, $any and $final. 2012# A string contained in any may be compound -- several strings 2013# concatenated by asterisks ("*"), they are extracted and used as 2014# multiple attribute value parts of type "any". 2015proc ldap::filter::ProcessSubstringMatch {attrdesc initial any final} { 2016 ValidateAttributeDescription $attrdesc options 2017 2018 set data [asnOctetString [LDAPString $attrdesc]] 2019 2020 set seq [list] 2021 set parts 0 2022 if {$initial != ""} { 2023 lappend seq [asnChoice 0 [AssertionValue $initial]] 2024 incr parts 2025 } 2026 2027 foreach v [split [string trim $any *] *] { 2028 if {$v != ""} { 2029 lappend seq [asnChoice 1 [AssertionValue $v]] 2030 incr parts 2031 } 2032 } 2033 2034 if {$final != ""} { 2035 lappend seq [asnChoice 2 [AssertionValue $final]] 2036 incr parts 2037 } 2038 2039 if {$parts == 0} { 2040 return -code error "Invalid filter: substrings match parses to zero parts" 2041 } 2042 2043 append data [asnSequenceFromList $seq] 2044 2045 asnChoiceConstr 4 $data 2046} 2047 2048# Constructs a BER-encoded form of an extensible match 2049# involving an attribute value given in $value and a string 2050# containing the matching rule OID, if present a "Use DN attribute 2051# types" flag, if present, and an atttibute description, if present, 2052# given in $lhs (stands for "Left Hand Side"). 2053proc ldap::filter::ProcessExtensibleMatch {lhs value} { 2054 ParseExtMatchLHS $lhs attrdesc options dn ruleid 2055 set data "" 2056 foreach {apptype val} [list 1 $ruleid 2 $attrdesc] { 2057 if {$val != ""} { 2058 append data [asnChoice $apptype [LDAPString $val]] 2059 } 2060 } 2061 append data [asnChoice 3 [AssertionValue $value]] 2062 if {$dn} { 2063 # [asnRetag] is broken in asn, so we use the trick 2064 # to simulate "boolean true" BER-encoding which 2065 # is octet 1 of length 1: 2066 append data [asnChoice 4 [binary format cc 1 1]] 2067 } 2068 asnChoiceConstr 9 $data 2069} 2070 2071# Parses a string $s, representing a "left hand side" of an extensible match 2072# expression, into several parts: attribute desctiption, options, 2073# "Use DN attribute types" flag and rule OID. These parts are 2074# assigned to corresponding variables in the caller's scope. 2075proc ldap::filter::ParseExtMatchLHS {s attrdescVar optionsVar dnVar ruleidVar} { 2076 upvar 1 $attrdescVar attrdesc $optionsVar options $dnVar dn $ruleidVar ruleid 2077 variable reaextmatch1 2078 variable reaextmatch2 2079 if {[regexp $reaextmatch1 $s -> attrdesc opts dnstr ruleid]} { 2080 set options [ProcessAttrTypeOptions $opts] 2081 set dn [expr {$dnstr != ""}] 2082 } elseif {[regexp $reaextmatch2 $s -> dnstr ruleid]} { 2083 set attrdesc "" 2084 set options [list] 2085 set dn [expr {$dnstr != ""}] 2086 } else { 2087 return -code error "Invalid filter: malformed attribute description" 2088 } 2089} 2090 2091# Validates an attribute description passed as $attrdesc. 2092# Raises an error if it's ill-formed. 2093# Variable in the caller's scope whose name is passed in optionsVar 2094# is set to a list of attribute options (which may be empty if 2095# there's no options in the attribute type). 2096proc ldap::filter::ValidateAttributeDescription {attrdesc optionsVar} { 2097 variable readesc 2098 if {![regexp $readesc $attrdesc -> opts]} { 2099 return -code error "Invalid filter: malformed attribute description" 2100 } 2101 upvar 1 $optionsVar options 2102 set options [ProcessAttrTypeOptions $opts] 2103 return 2104} 2105 2106# Parses a string $s containing one or more attribute 2107# options, delimited by seimcolons, with the leading semicolon, 2108# if non-empty. 2109# Returns a list of distinct options, lowercased for normalization 2110# purposes. 2111proc ldap::filter::ProcessAttrTypeOptions s { 2112 set opts [list] 2113 foreach opt [split [string trimleft $s \;] \;] { 2114 lappend opts [string tolower $opt] 2115 } 2116 set opts 2117} 2118 2119# Checks an assertion value $s for validity and substitutes 2120# any backslash escapes in it with their respective values. 2121# Returns canonical form of the attribute value 2122# ready to be packed into a BER-encoded stream. 2123proc ldap::filter::AssertionValue s { 2124 set v [encoding convertto utf-8 $s] 2125 if {[regexp {\\(?:[[:xdigit:]])?(?![[:xdigit:]])|[()*\0]} $v]} { 2126 return -code error "Invalid filter: malformed assertion value" 2127 } 2128 2129 variable escmap 2130 if {![info exists escmap]} { 2131 for {set i 0} {$i <= 0xff} {incr i} { 2132 lappend escmap [format {\%02x} $i] [format %c $i] 2133 } 2134 } 2135 string map -nocase $escmap $v 2136} 2137 2138# Turns a given Tcl string $s into a binary blob ready to be packed 2139# into a BER-encoded stream. 2140proc ldap::filter::LDAPString s { 2141 encoding convertto utf-8 $s 2142} 2143 2144# vim:ts=8:sw=4:sts=4:noet 2145