scsh-ldap/scheme/conditions.scm

;; conditions with sub-conditions

(define-condition-type &ldap-error &condition
  ldap-error?)

(define-condition-type &ldap-data-error &ldap-error
  ldap-data-error?
  (code ldap-error-code)
  (session ldap-error-session))

(define-condition-type &ldap-security-error &ldap-error
  ldap-security-error?
  (code ldap-error-code)
  (session ldap-error-session))

(define-condition-type &ldap-service-error &ldap-error
  ldap-service-error?
  (code ldap-error-code)
  (session ldap-error-session))

(define-condition-type &ldap-bindings-error &ldap-error
  ldap-bindings-error?)

;; conditions without sub-conditions

(define-condition-type &ldap-bindings-internal-error &ldap-bindings-error
  ldap-bindings-internal-error?)

(define-condition-type &ldap-bindings-not-implemented &ldap-bindings-error
  ldap-bindings-not-implemented?
  (what ldap-bindings-not-implemented-what))

(define-condition-type &ldap-session-option-error &ldap-error
  ldap-session-option-error?)
  
(define-condition-type &ldap-implicit-unbind &ldap-error
  ldap-implicit-unbind?)

(define-condition-type &ldap-operations-error &ldap-error
  ldap-operations-error?)

(define-condition-type &ldap-protocol-error &ldap-error
  ldap-protocol-error?)

(define-condition-type &ldap-timelimit-exceeded &ldap-error
  ldap-timelimit-exceeded?)

(define-condition-type &ldap-sizelimit-exceeded &ldap-error
  ldap-sizelimit-exceeded?)

(define-condition-type &ldap-strong-auth-not-supported &ldap-security-error
  ldap-strong-auth-not-supported?)

(define-condition-type &ldap-strong-auth-required &ldap-security-error
  ldap-strong-auth-required?)

(define-condition-type &ldap-adminlimit-exceeded &ldap-error
  ldap-adminlimit-exceeded?)

(define-condition-type &ldap-critical-extension-unavailable &ldap-error
  ldap-critical-extension-unavailable?)

(define-condition-type &ldap-confidentiality-required &ldap-security-error
  ldap-confidentiality-required?)

(define-condition-type &ldap-sasl-bind-in-progress &ldap-security-error
  ldap-sasl-bind-in-progress?)

(define-condition-type &ldap-no-such-attribute &ldap-data-error
  ldap-no-such-attribute?)

(define-condition-type &ldap-undefined-type &ldap-data-error
  ldap-undefined-type?)

(define-condition-type &ldap-inappropriate-type &ldap-data-error
  ldap-inappropriate-type?)

(define-condition-type &ldap-invalid-credentials &ldap-security-error
  ldap-invalid-credentials?)

(define-condition-type &ldap-insufficient-access &ldap-security-error
  ldap-insufficient-access?)

(define-condition-type &ldap-busy &ldap-service-error
  ldap-busy?)

(define-condition-type &ldap-unavailable &ldap-service-error
  ldap-unavailable?)

(define-condition-type &ldap-unwilling-to-perform &ldap-data-error
  ldap-unwilling-to-perform?)

(define-condition-type &ldap-loop-detect &ldap-error
  ldap-loop-detect?)

(define-condition-type &ldap-invalid-syntax &ldap-error
  ldap-invalid-syntax?)

(define-condition-type &ldap-invalid-dn-syntax &ldap-error
  ldap-invalid-dn-syntax?)

(define-condition-type &ldap-naming-violation &ldap-data-error
  ldap-naming-violation?)

(define-condition-type &ldap-constraint-violation &ldap-data-error
  ldap-constraint-violation?)

(define-condition-type &ldap-type-or-value-exists &ldap-data-error
  ldap-type-or-value-exists?)

(define-condition-type &ldap-objectclass-violation &ldap-data-error
  ldap-objectclass-violation?)

(define-condition-type &ldap-not-allowed-on-leaf &ldap-data-error
  ldap-not-allowed-on-leaf?)

(define-condition-type &ldap-not-allowed-on-rdn &ldap-data-error
  ldap-not-allowed-on-rdn?)

(define-condition-type &ldap-already-exists &ldap-data-error
  ldap-already-exists?)

(define-condition-type &ldap-no-such-object &ldap-data-error
  ldap-no-such-object?)

(define-condition-type &ldap-alias-problem &ldap-data-error
  ldap-alias-problem?)

(define-condition-type &ldap-alias-deref-problem &ldap-data-error
  ldap-alias-deref-problem?)

(define-condition-type &ldap-referral-limit-exceeded &ldap-data-error
  ldap-referral-limit-exceeded?)

(define-condition-type &ldap-no-objectclass-mods &ldap-data-error
  ldap-no-objectclass-mods?)

(define-condition-type &ldap-results-too-large &ldap-error
  ldap-results-too-large?)

(define-condition-type &ldap-affects-multiple-dsas &ldap-data-error
  ldap-affects-multiple-dsas?)

(define-condition-type &ldap-server-down &ldap-service-error
  ldap-server-down?)

(define-condition-type &ldap-local-error &ldap-error
  ldap-local-error?)

(define-condition-type &ldap-encoding-error &ldap-service-error
  ldap-encoding-error?)

(define-condition-type &ldap-decoding-error &ldap-service-error
  ldap-decoding-error?)

(define-condition-type &ldap-timeout-error &ldap-service-error
  ldap-timeout-error?)

(define-condition-type &ldap-auth-unknown &ldap-security-error
  ldap-auth-unknown?)

(define-condition-type &ldap-filter-error &ldap-data-error
  ldap-filter-error?)

(define-condition-type &ldap-param-error &ldap-error
  ldap-param-error?)

(define-condition-type &ldap-no-memory &ldap-error
  ldap-no-memory?)

(define-condition-type &ldap-connect-error &ldap-service-error
  ldap-connect-error?)

(define-condition-type &ldap-not-supported &ldap-error
  ldap-not-supported?)

(define-condition-type &ldap-control-not-found &ldap-error
  ldap-control-not-found?)

(define-condition-type &ldap-referral-limit-exceeded &ldap-error
  ldap-referral-limit-exceeded?)

(define raise-ldap-condition
  (let ((alist
	 `((,(ldap-return operations-error)		,&ldap-operations-error)
	   (,(ldap-return protocol-error)		,&ldap-protocol-error)
	   (,(ldap-return timelimit-exceeded)		,&ldap-timelimit-exceeded)
	   (,(ldap-return sizelimit-exceeded)		,&ldap-sizelimit-exceeded)
	   (,(ldap-return strong-auth-not-supported)	,&ldap-strong-auth-not-supported)
	   (,(ldap-return strong-auth-required)		,&ldap-strong-auth-required)
	   (,(ldap-return adminlimit-exceeded)		,&ldap-adminlimit-exceeded)
	   (,(ldap-return unavailable-critical-extension) ,&ldap-critical-extension-unavailable)
	   (,(ldap-return confidentiality-required)	,&ldap-confidentiality-required)
	   (,(ldap-return sasl-bind-in-progress)	,&ldap-sasl-bind-in-progress)
	   (,(ldap-return no-such-attribute)		,&ldap-no-such-attribute)
	   (,(ldap-return undefined-type)		,&ldap-undefined-type)
;	   (,(ldap-return inappropriate-type)		,&ldap-inappropriate-type)
	   (,(ldap-return constraint-violation)		,&ldap-constraint-violation)
	   (,(ldap-return type-or-value-exists)		,&ldap-type-or-value-exists)
	   (,(ldap-return invalid-syntax)		,&ldap-invalid-syntax)
	   (,(ldap-return no-such-object)		,&ldap-no-such-object)
	   (,(ldap-return alias-problem)		,&ldap-alias-problem)
	   (,(ldap-return invalid-dn-syntax)		,&ldap-invalid-dn-syntax)
	   (,(ldap-return is-leaf)			,&ldap-not-allowed-on-leaf)
	   (,(ldap-return alias-deref-problem)		,&ldap-alias-deref-problem)
	   (,(ldap-return inappropriate-auth)		,&ldap-auth-unknown)
	   (,(ldap-return invalid-credentials)		,&ldap-invalid-credentials)
	   (,(ldap-return insufficient-access)		,&ldap-insufficient-access)
	   (,(ldap-return busy)				,&ldap-busy)
	   (,(ldap-return unavailable)			,&ldap-unavailable)
	   (,(ldap-return unwilling-to-perform)		,&ldap-unwilling-to-perform)
	   (,(ldap-return loop-detect)			,&ldap-loop-detect)
	   (,(ldap-return naming-violation)		,&ldap-naming-violation)
	   (,(ldap-return object-class-violation)	,&ldap-objectclass-violation)
;	   (,(ldap-return not-allowed-on-leaf)		,&ldap-not-allowed-on-leaf)
	   (,(ldap-return not-allowed-on-rdn)		,&ldap-not-allowed-on-rdn)
	   (,(ldap-return already-exists)		,&ldap-already-exists)
	   (,(ldap-return no-object-class-mods)		,&ldap-no-objectclass-mods)
	   (,(ldap-return results-too-large)		,&ldap-results-too-large)
	   (,(ldap-return affects-multiple-dsas)	,&ldap-affects-multiple-dsas)
	   (,(ldap-return other)			,&ldap-error)
	   (,(ldap-return server-down)			,&ldap-server-down)
	   (,(ldap-return local-error)			,&ldap-local-error)
	   (,(ldap-return encoding-error)		,&ldap-encoding-error)
	   (,(ldap-return decoding-error)		,&ldap-decoding-error)
	   (,(ldap-return timeout)			,&ldap-timeout-error)
	   (,(ldap-return auth-unknown)			,&ldap-auth-unknown)
	   (,(ldap-return filter-error)			,&ldap-filter-error)
	   (,(ldap-return param-error)			,&ldap-param-error)
	   (,(ldap-return no-memory)			,&ldap-no-memory)
	   (,(ldap-return connect-error)		,&ldap-connect-error)
	   (,(ldap-return not-supported)		,&ldap-not-supported)
	   (,(ldap-return control-not-found)		,&ldap-control-not-found)
	   (,(ldap-return referral-limit-exceeded)	,&ldap-referral-limit-exceeded))))
    (lambda (return-object ldap-session)
      (cond 
       ((assoc return-object alist)
	=> (lambda (p)
	     (let ((the-condition (cadr p)))
	       (if (ldap-bindings-error? the-condition)
		   (raise (condition (the-condition)))
		   (raise (condition (the-condition 
				      (code return-object)
				      (session ldap-session))))))))
       (else 
	(raise 
	 (condition (&ldap-bindings-internal-error 
		     (code return-object)))))))))