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