#!/usr/bin/env scheme-script
;; -*- mode: scheme; coding: utf-8 -*- !#
;; Semi-interactive demonstration SSH client
;; Copyright © 2010, 2011 Göran Weinholt <goran@weinholt.se>
;;
;; 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/>.
#!r6rs

(import (rnrs)
        (only (srfi :13 strings) string-index)
        (srfi :39 parameters)
        (weinholt crypto dsa)
        (weinholt crypto ec dsa)
        (weinholt crypto rsa)
        (weinholt crypto sha-1)
        (weinholt crypto ssh-public-key (1))
        ;; (weinholt net dns numbers)
        ;; (weinholt net dns types)
        (weinholt net ssh)
        (weinholt net ssh connection)
        (weinholt net ssh transport)
        (weinholt net ssh userauth)
        (weinholt net tcp)
        (weinholt text base64)
        (xitomatl AS-match))

(define (print . x) (for-each display x) (newline))

(define (open-connection hostname portname)
  (let-values (((in out) (tcp-connect hostname portname)))
    (print "Connecting to " hostname " port " portname "...")
    (let ((conn (make-ssh-client in out)))
      (print "Running key exchange...")
      (ssh-key-exchange conn)
      conn)))

(define (reexchange conn algorithm)
  ;; Key re-exchange.
  (let ((local
         (parameterize ((preferred-server-host-key-algorithms (list algorithm)))
           (build-kexinit-packet conn))))
    (put-ssh conn local)
    (let lp ()
      (let ((pkt (get-ssh conn)))
        (cond ((kexinit? pkt)
               (ssh-key-re-exchange conn pkt local)
               (lp))
              ((key-exchange-packet? pkt)
               (unless (eq? (process-key-exchange-packet conn pkt) 'finished)
                 (lp)))
              (else
               ;; XXX: pkt was probably something important, and now it's lost
               (lp)))))))

(define (print-key hostname key)
  (print (ssh-public-key-fingerprint key))
  (print (ssh-public-key-random-art key))
  ;; (print key)
  (let ((key-bv (ssh-public-key->bytevector key)))
    (print hostname " "
           (ssh-public-key-algorithm key) " "
           (base64-encode key-bv))
    ;; RFC4255
    #;
    (let ((algo (cond ((rsa-public-key? key) (dns-sshfp-algorithm RSA))
                      ((dsa-public-key? key) (dns-sshfp-algorithm DSA))
                      (else #f))))
      (when algo
        (display "\tSSHFP\t")
        (dns-resource-print (current-output-port) 80
                            (make-dns-resource/SSHFP
                             '() 0 (dns-class IN)
                             algo
                             (dns-sshfp-type SHA-1)
                             (sha-1->bytevector (sha-1 key-bv))))
        (newline)))))

;; Prints all of the server's host keys. It uses one new connection
;; per host key.
(define (scan-keys hostname portname)
  (let ((conn (open-connection hostname portname)))
    (let lp ((conn conn)
             (algos (remove
                     (ssh-public-key-algorithm (ssh-conn-host-key conn))
                     (kexinit-server-host-key-algorithms
                      (ssh-conn-peer-kexinit conn)))))
      (print-key hostname (ssh-conn-host-key conn))
      (close-ssh conn)
      (unless (null? algos)
        (lp (parameterize ((preferred-server-host-key-algorithms (list (car algos))))
              (open-connection hostname portname))
            (cdr algos))))))

;; Prints all of the server's host keys. It uses one connection, but
;; requires userauth.
(define (getkeys hostname conn)
  (for-each (lambda (algo)
              (print "Switching to host key algorithm " algo)
              (reexchange conn algo)
              (print-key hostname (ssh-conn-host-key conn)))
            (kexinit-server-host-key-algorithms
             (ssh-conn-peer-kexinit conn))))



(define (main hostname portname)
  (define username #f)
  (define sessions '())
  (define authenticated #f)
  (define (get-send-id rec-id)
    (let ((s (assv rec-id sessions)))
      (and s (vector-ref (cdr s) 0))))
  (define (get-auth-result conn)
    (let ((x (get-ssh conn)))
      (cond ((userauth-failure? x)
             (print "You may try these authentication methods: "
                    (userauth-failure-can-continue x)))
            ((userauth-success? x)
             (print "You've succesfully authenticated.")
             (let ((r (ssh-conn-registrar conn)))
               (deregister-userauth r)
               (print "You now have access to the SSH connection protocol.")
               (set! authenticated #t)
               (register-connection r)))
            (else
             (error 'print-auth-result "Unexpected message" x)))))
  (print "Industria SSH demo client.\n")
  (let ((conn (open-connection hostname portname)))
    (print-key hostname (ssh-conn-host-key conn))
    (print "Please verify the above key.")
    (print "SSH session established.\nType help for a list of commands.\n")
    (let loop ()
      (display hostname)
      (display "=> ")
      (flush-output-port (current-output-port))
      (guard (exn
              (else
               (print "There was an error: " exn)))
        (case (read)
          ((help)
           (print "Command reference:")
           (print "d                  Toggle protocol debug messages")
           (print "help               This helpful help text")
           (print "q                  Exit the program")
           (print "g                  Get all host keys")
           (print "u \"username\"       Start user authentication")
           (print "p \"password\"       User authentication with a password")
           (print "s                  Open a new session channel")
           (print "t <channel id>     Request a pseudo-terminal and shell")
           (print "w <channel id>     Send a line to a channel")
           (print "r                  Read a packet (might block)"))

          ((d)
           (ssh-debugging (fxxor (ssh-debugging) #b111))
           (print "ssh-debugging set to #b" (number->string #b111 2)))

          ((g)
           (if authenticated
               (getkeys hostname conn)
               (scan-keys hostname portname)))

          ((u)
           (when username
             (error 'main "Once a username has been sent it can't be changed."))
           (set! username (read))
           ;; Ask nicely that we may use the userauth protocol
           (put-ssh conn (make-service-request "ssh-userauth"))
           (let ((x (get-ssh conn)))
             (if (and (service-accept? x)
                      (string=? (service-accept-name x)
                                "ssh-userauth"))
                 (print "Your request to use ssh-userauth was accepted.")
                 (error 'main "Couldn't request ssh-userauth" x)))
           (register-userauth (ssh-conn-registrar conn))
           ;; Ask what authentication methods are available. Also
           ;; indicates that we want to use the ssh-connection
           ;; protocol later.
           (put-ssh conn (make-userauth-request username "ssh-connection" "none"))
           (get-auth-result conn))

          ((p)
           ;; Try password authentication. Passwords are of course
           ;; visible on the terminal.
           (let ((password (read)))
             (put-ssh conn (make-userauth-request/password username "ssh-connection"
                                                           password))
             (get-auth-result conn)))

          ;; Open a new session
          ((s)
           (let ((rec-id (length sessions))
                 (rec-w 4096)
                 (rec-max 32768))
             (put-ssh conn (make-channel-open/session rec-id rec-w rec-max))
             (let ((x (get-ssh conn)))
               (let ((send-id (channel-open-confirmation-sender x))
                     (send-w (channel-open-confirmation-initial-window-size x))
                     (send-max (channel-open-confirmation-maximum-packet-size x)))
                 (set! sessions (cons (cons rec-id
                                            (vector send-id rec-w send-w
                                                    rec-max send-max))
                                      sessions))
                 (print "New session opened.")
                 (print "Receive side parameters:")
                 (print "ID: " rec-id " window size: " rec-w
                        " maximum packet size: " rec-max)
                 (print "Send side parameters:")
                 (print "ID: " send-id " window size: " send-w
                        " maximum packet size: " send-max)))))

          ;; Request a pseudo-terminal and a shell
          ((t)
           ;; These parameters here are mostly useless, because this
           ;; program doesn't put the user's terminal into raw mode.
           (let ((modes
                  (terminal-modes->bytevector
                   '((TTY_OP_OSPEED . 38400) (TTY_OP_ISPEED . 38400) (VINTR . 3)
                     (VQUIT . 28) (VERASE . 127) (VKILL . 21) (VEOF . 4)
                     (VEOL . 0) (VEOL2 . 0) (VSTART . 17) (VSTOP . 19)
                     (VSUSP . 26) (VREPRINT . 18) (VWERASE . 23) (VLNEXT . 22)
                     (VDISCARD . 15) (IGNPAR . 1) (PARMRK . 0) (INPCK . 0)
                     (ISTRIP . 0) (INLCR . 0) (IGNCR . 0) (ICRNL . 1)
                     (IUCLC . 0) (IXON . 1) (IXANY . 0) (IXOFF . 0)
                     (IMAXBEL . 1) (ISIG . 1) (ICANON . 1) (XCASE . 0)
                     (ECHO . 1) (ECHOE . 1) (ECHOK . 1) (ECHONL . 0)
                     (NOFLSH . 0) (TOSTOP . 0) (IEXTEN . 1) (ECHOCTL . 1)
                     (ECHOKE . 1) (PENDIN . 0) (OPOST . 1) (OLCUC . 0)
                     (ONLCR . 1) (OCRNL . 0) (ONOCR . 0) (ONLRET . 0) (CS7 . 1)
                     (CS8 . 1) (PARENB . 0) (PARODD . 0)))))
             (cond ((assv (read) sessions) =>
                    (lambda (s)
                      (let ((send-id (vector-ref (cdr s) 0)))
                        (put-ssh conn (make-channel-request/pty-req
                                       send-id #f "vt100" 24 80 1032 325 modes))
                        (put-ssh conn (make-channel-request/shell send-id #f))
                        (flush-ssh-output conn))))
                   (else
                    (print "No such session. Use the receive ID.")))))

          ((w)
           (cond ((get-send-id (read)) =>
                  (lambda (send-id)
                    (print "Type a line:")
                    (get-line (current-input-port))
                    (let lp ((line (string->utf8
                                    (string-append (get-line (current-input-port))
                                                   "\n"))))
                      (put-ssh conn (make-channel-data send-id line))
                      (flush-ssh-output conn))))
                 (else
                  (print "No such session. Use the receive ID."))))

          ((r)
           (let ((x (get-ssh conn)))
             (cond ((channel-data? x)
                    (display (utf8->string (channel-data-value x)))
                    (newline)
                    ;; This is super-naive. These adjustments should
                    ;; be based on some real buffer size and should
                    ;; not be sent this often.
                    (let ((send-id (get-send-id (channel-packet-recipient x))))
                      (put-ssh conn (make-channel-window-adjust send-id
                                                                (bytevector-length
                                                                 (channel-data-value x))))))
                   (else
                    (print x)))))

          ((q) (exit 0))

          (else
           (print "Unknown command."))))

      (loop))))

(apply
 (case-lambda
   ((who hostname portname)
    (main hostname portname))
   ((who hostname)
    (main hostname "22"))
   ((who . _)
    (print "Usage: " who " hostname [port]")
    (exit 1)))
 (command-line))
