Use Guile port API to implement Guile-SSH channels.

* src/channel-func.c (guile_ssh_channel_read)
  (guile_ssh_channel_write): Remove.
* src/channel-func.h (guile_ssh_channel_read): Remove.
* src/channel-type.c (ptob_fill_input, ptob_write, ptob_flush)
  (ptob_input_waiting, _ssh_channel_to_scm): New procedures.
  (guile_ssh_make_channel): Use `_ssh_channel_to_scm'.
  (_scm_to_ssh_channel): Use `SCM_STREAM' macro.
  (init_channel_type): Register Guile port callbacks.
* src/channel-type.h (_ssh_channel_to_scm): Export.
* src/channel.scm (channel-read, channel-write): Remove.
* src/message-func.c
  (guile_ssh_message_channel_request_open_reply_accept): Use
  `_ssh_channel_to_scm'.
* examples/echo: Add to the repository.
* examples/Makefile.am: Add echo server/client example.
* examples/README: Update.
* examples/sssh.scm: Update.
* README: Update.

2 files changed, 289 insertions, 0 deletions

diff --git a/examples/echo/client.scm b/examples/echo/client.scm
new file mode 100755
index 0000000..478aa67
--- /dev/null
+++ b/examples/echo/client.scm
@@ -0,0 +1,144 @@
+#!/usr/bin/guile \
+--debug -e main
+!#
+
+;;; client.scm -- Echo client example.
+
+;; Copyright (C) 2013-2014 Artyom V. Poptsov <poptsov.artyom@gmail.com>
+;;
+;; This program is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see
+;; <http://www.gnu.org/licenses/>.
+
+
+;;; Commentary:
+
+
+;;; Code:
+
+(use-modules (ice-9 getopt-long)
+             (ice-9 rdelim)
+             (ssh channel)
+             (ssh session)
+             (ssh auth)
+             (ssh key))
+
+(define *program-name* "echo-client")
+(define *default-identity-file*
+  (string-append (getenv "HOME") "/.ssh/id_rsa"))
+
+
+;; Command line options
+(define *option-spec*
+  '((user          (single-char #\u) (value #t))
+    (port          (single-char #\p) (value #t))
+    (identity-file (single-char #\i) (value #t))
+    (help          (single-char #\h) (value #f))))
+
+
+(define (print-help)
+  "Print information about program usage."
+  (display
+   (string-append
+    *program-name* " -- Echo client example.\n"
+    "Copyright (C) Artyom Poptsov <poptsov.artyom@gmail.com>\n"
+    "Licensed under GNU GPLv3+\n"
+    "\n"
+    "Usage: " *program-name* " [ -upidv ] <host> <string>\n"
+    "\n"
+    "Options:\n"
+    "  --user=<user>, -u <user>                User name\n"
+    "  --port=<port-number>, -p <port-number>  Port number\n"
+    "  --identity-file=<file>, -i <file>       Path to private key\n")))
+
+
+(define (handle-error session)
+  "Handle a SSH error."
+  (display (get-error session))
+  (newline)
+  (exit 1))
+
+(define (get-prvkey session identity-file)
+  (let ((prvkey (private-key-from-file session identity-file)))
+    (if (not prvkey)
+        (handle-error session))
+    prvkey))
+
+(define (get-pubkey session prvkey)
+  (let ((pubkey (private-key->public-key prvkey)))
+    (if (not pubkey)
+        (handle-error session))
+    pubkey))
+
+
+(define (main args)
+  "Entry point of the program."
+  (if (null? (cdr args))
+      (begin
+        (print-help)
+        (exit 0)))
+
+  (let* ((options           (getopt-long args *option-spec*))
+         (user              (option-ref options 'user (getenv "USER")))
+         (port              (string->number (option-ref options 'port "22")))
+         (identity-file     (option-ref options 'identity-file
+                                        *default-identity-file*))
+         (help-needed?      (option-ref options 'help #f))
+         (args              (option-ref options '() #f)))
+
+
+
+    (if help-needed?
+        (begin
+          (print-help)
+          (exit 0)))
+
+    (if (or (null? args) (null? (cdr args)))
+        (begin
+          (print-help)
+          (exit 0)))
+
+    (let* ((host (car args))
+           (str  (cadr args))
+           (session (make-session #:user user
+                                  #:host host
+                                  #:port port
+                                  #:log-verbosity 0))) ;Be quiet
+
+      (connect! session)
+      (case (authenticate-server session)
+        ((not-known) (display "   The server is unknown.  Please check MD5.\n")))
+
+      (let* ((private-key (get-prvkey session identity-file))
+             (public-key  (get-pubkey session private-key)))
+
+        (if (eqv? (userauth-pubkey! session #f public-key private-key) 'error)
+            (handle-error session))
+
+        (let ((channel     (make-channel session)))
+
+          (if (not channel)
+              (handle-error session))
+
+          (channel-open-session channel)
+
+          (display str channel)
+
+          (let poll ((count #f))
+            (if (or (not count) (zero? count))
+                (poll (channel-poll channel #f))
+                (begin
+                  (display (read-line channel))
+                  (newline)))))))))
+
+;;; echo.scm ends here.
diff --git a/examples/echo/server.scm b/examples/echo/server.scm
new file mode 100755
index 0000000..29b1376
--- /dev/null
+++ b/examples/echo/server.scm
@@ -0,0 +1,145 @@
+#!/usr/bin/guile \
+--debug -e main -s
+!#
+
+(use-modules (ice-9 rdelim)
+             (ice-9 popen)
+             (ssh server)
+             (ssh message)
+             (ssh session)
+             (ssh channel)
+             (ssh key)
+             (ssh auth))                ; userauth-*
+
+(define *default-bindport*      12345)
+(define *default-log-verbosity* 0)
+(define *default-rsakey*        (string-append (getenv "HOME")
+                                               "/.ssh/id_rsa"))
+
+(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 (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 (handle-req-channel msg msg-type channel)
+  (let ((subtype (cadr msg-type)))
+
+    (format #t "  subtype: ~a~%" subtype)
+
+    (case subtype
+
+      ((channel-request-env)
+       (let* ((env-req (message-get-req msg))
+              (name    (env-req:name env-req))
+              (value   (env-req:value env-req)))
+         (format #t
+                 (string-append "  env requested:~%"
+                                "    name:  ~a~%"
+                                "    value: ~a~%")
+                 name value)
+         (setenv name value)
+         (message-reply-success msg)))
+
+      (else
+       (message-reply-success msg)))))
+
+(define (main args)
+  (let ((server (make-server #:bindport      *default-bindport*
+                             #:rsakey        *default-rsakey*
+                             #:log-verbosity *default-log-verbosity*
+                             #:banner        "Scheme Secure Shell Daemon"))
+        (channel #f))
+
+    (format #t (string-append
+                "Using private key ~a~%"
+                "Listening on port ~a~%")
+            *default-rsakey*
+            *default-bindport*)
+
+    ;; Start listen to incoming connections.
+    (server-listen server)
+
+    ;; Accept new connections from clients.  Every connection is
+    ;; handled in its own SSH session.
+    (let main-loop ((session (server-accept server)))
+      (display "Client accepted.\n")
+      (server-handle-key-exchange session)
+      ;; Handle messages from the connected SSH client.
+      (let session-loop ((msg (server-message-get session)))
+        (if msg
+            (let ((msg-type (message-get-type msg)))
+              (format #t "Message: ~a~%" msg-type)
+              ;; Check the type of the message
+              (case (car msg-type)
+                ((request-service)
+                 (let ((srv-req (message-get-req msg)))
+                   (format #t "  Service requested: ~a~%"
+                           (service-req:service srv-req))
+                   (message-reply-success msg)))
+
+                ((request-auth)
+                 (handle-req-auth session msg msg-type))
+
+                ((request-channel-open)
+                 (set! channel (handle-req-channel-open msg msg-type))
+                 (let poll ((count #f))
+                   (if (or (not count) (zero? count))
+                       (poll (channel-poll channel #f))
+                       (let ((str (read-line channel)))
+                         (format #t "Received message: ~a~%" str)
+                         (display "Echoing back...\n")
+                         (display str channel)))))
+
+                ((request-channel)
+                 (handle-req-channel msg msg-type channel))
+
+                (else
+                 (display "Reply default\n")
+                 (message-reply-default msg)))))
+            ;; (if channel
+            ;;     (let ((str (read-line channel)))
+            ;;       (display str))))
+        (if (connected? session)
+            (session-loop (server-message-get session))))
+      (disconnect! session)
+      (main-loop (server-accept server)))))
+
+;;; server.scm ends here.