Initial commit

backplane-auth.scm

@@ -0,0 +1,66 @@
+(use-modules (srfi srfi-1)
+             (srfi srfi-13)
+             (ice-9 binary-ports)
+             (ice-9 textual-ports)
+             (ice-9 format)
+             (ice-9 regex)
+             (rnrs bytevectors))
+
+(define *host-passwd-file* (getenv "FUDO_HOST_PASSWD_FILE"))
+(when (not *host-passwd-file*)
+  (format (current-error-port "FUDO_HOST_PASSWD_FILE not set~%"))
+  (exit 1))
+
+(define *service-passwd-file* (getenv "FUDO_SERVICE_PASSWD_FILE"))
+(when (not *service-passwd-file*)
+  (format (current-error-port "FUDO_SERVICE_PASSWD_FILE not set~%"))
+  (exit 1))
+
+(define host-regex "^host-([a-zA-Z][a-zA-Z0-9_-]+)$")
+(define service-regex "^service-([a-zA-Z][a-zA-Z0-9_-]+)$")
+
+(define (make-verifier passwd-file)
+  (let ((passwds (load passwd-file)))
+    (lambda (username passwd)
+      (and (> (string-length passwd) 6)
+           (equal? (assoc-ref passwds username) passwd)))))
+
+(define (make-authenticator host-verifier service-verifier)
+  (lambda (username hostname password)
+    (cond ((string-match host-regex username)
+           (host-verifier (match:substring (string-match host-regex username) 1)
+                          password))
+
+          ((string-match service-regex username)
+           (service-verifier (match:substring (string-match service-regex username) 1)
+                             password))
+
+          (else #f))))
+
+(define (make-handler handlers)
+  (lambda (request)
+    (let ((op (assoc-ref handlers (first request))))
+      (if op
+          (apply op (cdr request))
+          #f))))
+
+(define (auth-listener handler)
+  (let ((in (current-input-port))
+        (out (current-output-port)))
+    (while #t
+           (let ((size (bytevector-u16-ref (get-bytevector-n in 2) 0 (endianness big)))
+                 (response (make-bytevector 4 0)))
+             (bytevector-u8-set! response 1 #x02)
+             (if (handler (string-split (get-string-n in size) #\:))
+                 (begin (bytevector-u8-set! response 3 #x01)
+                        (put-bytevector out response 0 4)
+                        (force-output out))
+                 (begin (bytevector-u8-set! response 3 #x00)
+                        (put-bytevector out response 0 4)
+                        (force-output out)))))))
+
+(auth-listener
+ (make-handler
+  (list (cons "auth"
+              (make-authenticator (make-verifier *host-passwd-file*)
+                                  (make-verifier *service-passwd-file*))))))