#!/usr/physics/gauche/bin/gosh

(use srfi-1)
(use srfi-13)
(use srfi-14)

(use gauche.net)
(use gauche.uvector)
(use gauche.syslog)
(use gauche.process)

(define SASLAUTHD-SOCK "/var/saslauthd/mux")
(define AUTHREALM "PHYSICS.UNLV.EDU")
(define AUTHSERVICE "host")
(define TEST-MODE #f)

(define no-colon (char-set-delete char-set:full #\:))

(define (pe . args)
  (if TEST-MODE
    (begin
      (display "Extauth: " (standard-error-port))
      (for-each (lambda (a) (display a (standard-error-port))) args)
      (newline (standard-error-port))
      (flush (standard-error-port))
    )
    (sys-syslog LOG_INFO (string-join
      (map (lambda (a) (format #f "~a" a)) args)))
  )
)

(define (sasl-auth sockname username password service realm)
  (let ((sock (make-client-socket 'unix sockname))
        (bout (make-u16vector 1))
        (resp (make-u8vector 256)))
    (call-with-client-socket sock
      (lambda (in out)
        (for-each      
          (lambda (t)      
            (u16vector-set! bout 0 (sys-htons (string-length t)))
            (write-block bout out) 
            (display t out)
            (flush out)
          )
          (list username password service realm)
        )
        (flush out)
        (read-block! bout in)       
        (let ((len (sys-ntohs (u16vector-ref bout 0))))
          (read-block! resp in 0 len)
          (string=? (u8vector->string resp 0 len) "OK")
        )
      )
    )
  )
)

(define (username->uid username)
  (let ((sl #f)
        (lp (run-process
              (list "/usr/physics/bin/ldapuser"
                    "cn" username "uidNumber" )
              :input "/dev/null"
              :output :pipe
              :error "/dev/null")))
    (set! sl (port->string-list (process-output lp)))
    (process-wait lp)
    (cond
      ((= (length sl) 1) (string->number (first sl)))
      (else #f)
    )
  )
)

(define (is-user? username)
  (let ((uid (username->uid username)))
    (pe "Username " username " is uid " uid)
    (if uid
      (> uid 1999)
      #f
    )
  )
)

(define (write-extauth-result result)
  (if (= result 1)
    (pe "Operation succeeded with " result)
    (pe "Operation failed with " result)
  )
  (pe "Sending result: " result)
  (let ((nr (make-u16vector 1)))
    (u16vector-set! nr 0 (sys-htons 2))
    (write-block nr (standard-output-port))
    (flush (standard-output-port))

    (u16vector-set! nr 0 (sys-htons result))
    (write-block nr (standard-output-port))
    (flush (standard-output-port))
  )
)

(define (exit-program . args)
  (apply pe args)
  (exit 0)
)

(define (read-extauth-data buf start end)
  (let ((rv (read-block! buf (standard-input-port) start end)))
    (cond
      ((eof-object? rv) (exit-program "EOF reached"))
      ((number? rv)
        (if (not (= rv (- end start)))
          (exit-program
            "Weird return value from read-block! "
            rv " expected " (- end start))))
      (else (exit-program "Unknown result value from read-block! " rv))
    )
  )
)

(define (read-extauth-request)
  (pe "Waiting for request")
  (let ((lenbuf (make-u16vector 1))
        (buf    (make-u8vector 65536)))
    (read-extauth-data lenbuf 0 1)
    (let ((len (sys-ntohs (u16vector-ref lenbuf 0))))
      (pe "Read length: " len)
      (read-extauth-data buf 0 len)
      (pe "Request read!")
      (string-tokenize (u8vector->string buf 0 len) no-colon)
    )
  )
)

(define (extauth-loop)
  (let ((field-list (read-extauth-request)))
    (cond
      ((and (string=? (first field-list) "auth") (= (length field-list) 4))
        (pe "auth request " (second field-list) " " (third field-list))
        (if (and
              (is-user? (second field-list))
              (sasl-auth SASLAUTHD-SOCK
                (second field-list) (fourth field-list) AUTHSERVICE AUTHREALM))
          (write-extauth-result 1)
          (write-extauth-result 0)
        )
      )
      ((string=? (first field-list) "isuser")
        (pe "isuser request " field-list)
        (if (is-user? (second field-list))
          (write-extauth-result 1)
          (write-extauth-result 0)
        )
      )
      (else
        (pe "Unknown request" field-list)
        (write-extauth-result 0)
      )
    )
  )
  (extauth-loop)
)

(define (guard-loop)
  (guard
    (e (else (pe e)))
    (extauth-loop)
  )
  (guard-loop)
)

(define (main args)
  (sys-openlog "extauth_saslauthd" LOG_PID LOG_AUTH)
  (guard-loop)
)