guile-ssh-file-transfer-example

client.scm

#!/usr/bin/guile \
--debug -e main
# aside from this initial boilerplate, this is actually -*- scheme -*- code
!#

;;; client.scm -- Echo client example.

;; Copyright (C) 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:

;; Echo client example.
;;
;; Usage: client.scm [ options ] <host> <string>
;;
;; Options:
;;   --user=<user>, -u <user>                User name
;;   --port=<port-number>, -p <port-number>  Port number
;;   --identity-file=<file>, -i <file>       Path to private key
;;
;; Examples:
;;   $ ./client.scm -i ~/.ssh/id_rsa -p 12345 127.0.0.1 "`date`"


;;; Code:

(use-modules (ice-9 getopt-long)
             (ice-9 rdelim)
             (ssh channel)
             (ssh session)
             (ssh auth)
             (ssh key))

(define *program-name* "client.scm")
(define *default-identity-file* (format #f "~a/.ssh/id_rsa" (getenv "HOME")))
(define *default-user* (getenv "USER"))
(define *default-port* "22")


(define (print-help-and-exit)
  "Print information about program usage."
  (display (string-append "\
" *program-name* " -- Echo client example.

Copyright (C) Artyom V. Poptsov <poptsov.artyom@gmail.com>
Licensed under GNU GPLv3+

Usage: " *program-name* " [ options ] <host> <string>

Options:
  --user=<user>, -u <user>                User name
  --port=<port-number>, -p <port-number>  Port number
  --identity-file=<file>, -i <file>       Path to private key
"))
  (exit 0))

(define (handle-error session)
  "Handle a SSH error."
  (display (get-error session))
  (newline)
  (exit 1))

(define (get-prvkey session identity-file)
  "Get a private SSH key.  Handle possible errors."
  (let ((prvkey (private-key-from-file session identity-file)))
    (if (not prvkey)
        (handle-error session))
    prvkey))

(define (get-pubkey session prvkey)
  "Get a public SSH key from private key PRVKEY.  Handle possible
errors."
  (let ((pubkey (private-key->public-key prvkey)))
    (if (not pubkey)
        (handle-error session))
    pubkey))

(define (read-all port)
  "Read all lines from the PORT."
  (let r ((res (read-line port 'concat))
          (str ""))
    (if (not (eof-object? str))
        (r (string-append res str) (read-line port 'concat))
        res)))

(define (copy-file file channel)
  "Send FILE over the CHANNEL to the server."
  (let ((fp (open-input-file file)))
    (write-line file channel)
    (let copy ((line (read-line fp)))
      (or (eof-object? line)
          (begin
            (write-line line channel)
            (copy (read-line fp)))))))


(define (main args)
  "Entry point of the program."
  (and (null? (cdr args))
       (print-help-and-exit))

  (let* ((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))))
         (options       (getopt-long args option-spec))
         (user          (option-ref options 'user *default-user*))
         (port          (option-ref options 'port *default-port*))
         (identity-file (option-ref options 'identity-file
                                    *default-identity-file*))
         (help-needed?  (option-ref options 'help #f))
         (args          (option-ref options '() #f)))

    (and help-needed?
         (print-help-and-exit))

    (and (or (null? args) (null? (cdr args)))
         (print-help-and-exit))

    (let* ((host (car args))
           (str  (cadr args))
           (session (make-session #:user user
                                  #:host host
                                  #:port (string->number port)
                                  #:log-verbosity 'nolog))) ;Be quiet

      (connect! session)

      (case (authenticate-server session)
        ((not-known)
         (display "The server is unknown.  Please check MD5 sum:\n")
         (format #t "  ~a~%" (get-public-key-hash session))))

      (let* ((private-key (get-prvkey session identity-file))
             (public-key  (get-pubkey session private-key)))

        (and (eqv? (userauth-pubkey! session public-key private-key) 'error)
             (handle-error session))

        (let ((channel (make-channel session)))

          (or channel
              (handle-error session))

          (channel-open-session channel)

          (copy-file str channel)

          ;; (let poll ((ready? #f))
          ;;   (if ready?
          ;;       (format #t "Response from server: ~a~%" (read-all channel))
          ;;       (poll (char-ready? channel))))

          (close channel))))))

;;; client.scm ends here.

server.scm

#!/usr/bin/guile \
--debug -e main -s
# aside from this initial boilerplate, this is actually -*- scheme -*- code
!#

;;; client.scm -- Echo server example.

;; Copyright (C) 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:

;; Echo server example.
;;
;; Usage: server.scm


;;; Code:

(use-modules (ice-9 rdelim)
             (ice-9 popen)
             (ice-9 getopt-long)
             (ssh server)
             (ssh message)
             (ssh session)
             (ssh channel)
             (ssh key)
             (ssh auth))                ; userauth-*

(define *default-bindport*      "12345")
(define *default-log-verbosity* 'nolog)
(define *default-rsakey*        (format #f "~a/.ssh/id_rsa" (getenv "HOME")))
(define *default-dsakey*        (format #f "~a/.ssh/id_dsa" (getenv "HOME")))

(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 (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 (print-help-and-exit)
  "Print help message and exit."
  (display "\
Usage: server.scm [ options ]

Options:
  --rsakey=<key>, -r <key>      Set host RSA key.
  --dsakey=<key>, -d <key>      Set host DSA key.
  --port=<port>, -p <port>      Set bind port of the server.
  --help, -h                    Print this message and exit.
")
  (exit 0))

(define (main args)
  "Entry point of the program."
  (let* ((option-spec '((dsakey (single-char #\d) (value #t))
                        (rsakey (single-char #\r) (value #t))
                        (port   (single-char #\p) (value #t))
                        (help   (single-char #\h) (value #f))))
         (options     (getopt-long args option-spec))
         (dsakey      (option-ref options 'dsakey *default-dsakey*))
         (rsakey      (option-ref options 'rsakey *default-rsakey*))
         (port        (option-ref options 'port   *default-bindport*))
         (help-wanted (option-ref options 'help   #f)))

    (and help-wanted
         (print-help-and-exit))

    (let ((server  (make-server #:bindport      (string->number port)
                                #:rsakey        rsakey
                                #:dsakey        dsakey
                                #:log-verbosity *default-log-verbosity*
                                #:banner        "Scheme Secure Shell Daemon"))
          (channel #f))

      (format #t (string-append
                  "Using RSA key ~a~%"
                  "Using DSA key ~a~%"
                  "Listening on port ~a~%")
              rsakey
              dsakey
              port)

      ;; Start listen to incoming connections.
      (server-listen server)

      (while #t
        ;; Accept new connections from clients.  Every connection is
        ;; handled in its own SSH session.
        (let ((session (catch 'guile-ssh-error
                         (lambda ()
                           (server-accept server))
                         (lambda (key . args)
                           (format #t "~a: ~a~%" key args)
                           #f))))

          (or session
              (begin
                (sleep 1)
                (continue)))

          (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 ((ready? #f))
                       (if ready?
                           (catch 'guile-ssh-error
                             (lambda ()
                               (let* ((file-name     (read-line channel))
                                      (file-contents (read-all channel))
                                      (fp            (open-output-file file-name)))
                                 (format #t "file-name: ~a~%" file-name)
                                 ;; Write contents of the file
                                 (display file-contents fp)
                                 (close fp)))
                             (lambda (key . args)
                               (display "error\n")
                               (display (get-error session))))
                           (poll (char-ready? channel))))
                     (close channel))

                    ((request-channel)
                     (handle-req-channel msg msg-type channel))

                    (else
                     (display "Reply default\n")
                     (message-reply-default msg)))))
            (if (connected? session)
                (session-loop (server-message-get session))))
          (disconnect! session))))))

;;; server.scm ends here.