diff options
| -rw-r--r-- | ChangeLog | 4 | ||||
| -rw-r--r-- | configure.ac | 1 | ||||
| -rw-r--r-- | ssh/Makefile.am | 2 | ||||
| -rw-r--r-- | ssh/dist/Makefile.am | 9 | ||||
| -rw-r--r-- | ssh/dist/node.scm | 162 |
5 files changed, 178 insertions, 0 deletions
@@ -1,3 +1,7 @@ +2014-10-14 Artyom Poptsov <poptsov.artyom@gmail.com> + + * ssh/dist/Makefile.am: New file. + 2014-10-13 Artyom Poptsov <poptsov.artyom@gmail.com> * ssh/version.c: Don't include `gcrypt.h'. diff --git a/configure.ac b/configure.ac index 1624a42..8ff0c8c 100644 --- a/configure.ac +++ b/configure.ac @@ -72,6 +72,7 @@ GUILE_EFFECTIVE_VERSION=`$GUILE -c '(display (effective-version))'` AC_SUBST(GUILE_EFFECTIVE_VERSION) AC_CONFIG_FILES([Makefile ssh/Makefile examples/Makefile build-aux/Makefile]) +AC_CONFIG_FILES([ssh/dist/Makefile]) AC_CONFIG_FILES([m4/Makefile doc/Makefile tests/Makefile am/Makefile]) # Generate a Makefile, based on the results. diff --git a/ssh/Makefile.am b/ssh/Makefile.am index 50e49e1..26d86ea 100644 --- a/ssh/Makefile.am +++ b/ssh/Makefile.am @@ -18,6 +18,8 @@ include $(top_srcdir)/am/snarf include $(top_srcdir)/am/guilec +SUBDIRS = dist + lib_LTLIBRARIES = libguile-ssh.la libguile_ssh_la_SOURCES = \ diff --git a/ssh/dist/Makefile.am b/ssh/dist/Makefile.am new file mode 100644 index 0000000..b736f61 --- /dev/null +++ b/ssh/dist/Makefile.am @@ -0,0 +1,9 @@ +SCM_SOURCES = \ + node.scm + +EXTRA_DIST = \ + $(SCM_SOURCES) + +distdir = $(guilesitedir)/ssh/dist + +nobase_dist_dist_DATA = $(SCM_SOURCES) diff --git a/ssh/dist/node.scm b/ssh/dist/node.scm new file mode 100644 index 0000000..a7acf70 --- /dev/null +++ b/ssh/dist/node.scm @@ -0,0 +1,162 @@ +;;; node.scm -- Distributed computing node + +(define-module (ssh dist node) + #:use-module (ice-9 rdelim) + #:use-module (ssh session) + #:use-module (ssh server) + #:use-module (ssh message) + #:use-module (ssh session) + #:use-module (ssh channel) + #:use-module (ssh key) + #:export (node? + make-node + run-node + ;; Low-level procedures + %handle-job)) + +(define %delimiter "\0") + +(define <node> + (make-vtable "pw" + (lambda (struct port) + (let* ((server (struct-ref struct 0)) + (bindaddr (server-get server 'bindaddr)) + (bindport (server-get server 'bindport))) + (format port "#<node ~a:~a>" + (if bindaddr + bindaddr + "") + bindport))))) + +(define (node? x) + "Check if X is a <node> instance." + (and (struct? x) + (eq? (struct-vtable x) <node>))) + +(define* (make-node #:key (white-list '()) + (black-list '()) + (bindaddr #f) + (bindport 2223) + (rsa-key #f) + (dsa-key #f) + (log-verbosity 'nolog)) + (let ((server (make-server #:bindaddr bindaddr + #:bindport bindport + #:rsakey rsa-key + #:dsakey dsa-key + #:log-verbosity log-verbosity))) + (make-struct/no-tail <node> server))) + +(define (accept-and-catch server) + "Accept new client connection to a SERVER. Catch errors, return #f on +error." + (catch 'guile-ssh-error + (lambda () + (server-accept server)) + (lambda (key . args) + (format #t "~a: ~a~%" key args) + #f))) + +(define (read-all port) + "Read all lines from the PORT." + (let r ((res (read-line port 'concat)) + (str "")) + (if (and (not (eof-object? str)) (char-ready? port)) + (r (string-append res str) (read-line port 'concat)) + res))) + +(define (handle-req-channel-open msg msg-type) + (let ((subtype (cadr msg-type))) + (format #t " subtype: ~a~%" subtype) + (case subtype + ((channel-session) + (message-channel-request-open-reply-accept msg)) + (else + (message-reply-default msg) + #f)))) + +(define (%send-message message channel) + "Send MESSAGE to CHANNEL." + (write message channel) + (write-char #\nul channel)) + +(define (%recv-message channel) + "Receive server response from the CHANNEL." + (read-delimited %delimiter channel)) + +(define (%handle-job channel) + "Receive and handle distributed job from CHANNEL." + (let* ((data (read (open-input-string (%recv-message channel)))) + (proc (primitive-eval (car data)))) + (format #t "proc: ~a; list: ~a~%" proc (cadr data)) + (%send-message (map proc (cadr data)) channel))) + +(define (handle-req-auth session msg msg-type) + (let ((subtype (cadr msg-type))) + + (format #t " subtype: ~a~%" subtype) + + ;; Allowed authentication methods + (message-auth-set-methods! msg '(public-key)) + + (case subtype + ((auth-method-publickey) + (let* ((req (message-get-req msg)) + (user (auth-req:user req)) + (pubkey (auth-req:pubkey req)) + (pubkey-state (auth-req:pubkey-state req))) + (format #t + (string-append " User ~a wants to authenticate with a public key (~a)~%" + " Public key state: ~a~%") + user (get-key-type pubkey) pubkey-state) + + (case pubkey-state + ((none) + (message-auth-reply-public-key-ok msg)) + + ((valid) + (message-reply-success msg)) + + (else + (format #t " Bad public key state: ~a~%" pubkey-state) + (message-reply-default msg))))) + + (else + (message-reply-default msg))))) + +(define (run-session-loop session) + (display "Session loop\n") + (while #t + (let ((msg (server-message-get session))) + (format #t "Message: ~a~%" msg) + (and msg + (let ((msg-type (message-get-type msg))) + (format #t "Message: ~a~%" msg-type) + (case (car msg-type) + ((request-service) + (message-reply-success msg)) + ((request-auth) + (handle-req-auth session msg msg-type)) + ((request-channel-open) + (let* ((channel (handle-req-channel-open msg msg-type))) + (%handle-job channel) + (close channel) + (break))) + (else + (message-reply-default msg)))))))) + +(define (run-node node) + (let ((server (struct-ref node 0))) + (server-listen server) + (while #t + (let ((session (accept-and-catch server))) + (format #t "Session: ~a~%" session) + (or session + (begin + (sleep 1) + (continue))) + (server-handle-key-exchange session) + (run-session-loop session) + (disconnect! session))))) + +;;; node.scm ends here |