#lang racket

(require (for-syntax racket/base
                     racket/syntax
                     racket/stxparam
                     syntax/parse)
;;         syntax/parse
         racket/contract
         racket/tcp
         racket/match
         #;asn1
         #;asn1/ber)

(define-syntax (define-ldap stx)
  (syntax-parse stx
    [(_ (name:id ld attr ...)
        [request req-expr ...]
        [response resp-expr])
     (with-syntax
       ([fn-id (format-id stx "ldap-~a" #'name)]
        [req (let ([req (apply hasheq
                               (syntax->datum #'(req-expr ...)))])
               #`(begin
                   (write-asn1/DER #,(hash-ref req 'asn1-type)
                                   (hasheq 'n #,(hash-ref req 'n 2)
                                           'app #,(hash-ref req 'app))
                                   (ldap-to ld))
                   (flush-output (ldap-to ld))))]
        [resp (cond [(symbol? (syntax->datum #'resp-expr))
                     #'(hash-ref (BER-decode resp-expr
                                             (read-asn1 ANY
                                                        (ldap-from ld)
                                                        #:rules 'DER)
                                             #:der? #t)
                                 'app)]
                    [(list? (syntax->datum #'resp-expr))
                     #'resp-expr])])
       #`(define (fn-id ld attr ...) ,req resp))]))

(define-ldap (bind ld [rdn ""] [p ""])
  [request asn1-type BindRequest
           n (match (list rdn p)
               [`("" "") 1]
               [`(,_ ,_) 0])
           app (hasheq 'version 3
                       'name rdn
                       'authentication (list 'simple p))]
  [response BindResponse])

;; expanded
(define (ldap-bind ld (rdn "") (p ""))
  (begin
    (write-asn1/DER
     BindRequest
     (hasheq
      'n
      (match (list rdn p) (`("" "") 1) (`(,_ ,_) 0))
      'app
      (hasheq 'version 3 'name rdn 'authentication (list 'simple p)))
     (ldap-to ld))
    (flush-output (ldap-to ld)))
  (hash-ref
   (BER-decode
    BindResponse
    (read-asn1 ANY (ldap-from ld) #:rules 'DER)
    #:der?
    #t)
   'app))