Common Lisp FTP でファイルをアップロードする

ホームページにファイルをアップロードするのに Common Lisp を使ってみようと思いました。
まず、CL-FTPを試してみたのですが、うまく動かない。それじゃちょっと自分で作るか、と思い次のようなコードを書きました。
実装は SBCL です。upload.lisp

#!/usr/bin/sbcl --noinform

(defpackage :toko.ftp
  (:nicknames :ftp)
  (:use :common-lisp)
  (:shadow quit type))

(in-package :toko.ftp)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :usocket)
  (require :cl-ppcre))

(defvar *stream*)

(defun rcv (&optional (stream *stream*))
  (loop for c = (read-char stream nil nil)
     with out = (make-string-output-stream)
     if (char= #\Return c)
     do (progn
          (read-char stream nil nil)
          (return (print (get-output-stream-string out))))
     else
     do (write-char c out)))

(defun rcv-code (expected-code &optional (stream *stream*))
  (let ((line (rcv stream))
        (code (princ-to-string expected-code)))
    (if (string= code line :end2 (length code))
        line
        (error (format nil "unexpected response: ~a" line)))))

(defun snd (cmd &optional (stream *stream*))
  (print cmd)
  (format stream "~a~c~c" cmd #\Return #\Linefeed)
  (force-output stream))

(defmacro def-simple-cmd (cmd args success-code)
  (let ((lambda-list args)
        (code (prin1-to-string success-code)))
    `(defun ,cmd (,@lambda-list &key (stream *stream*) (response-fn #'identity))
       (snd 
        (format nil "~a~@{~^ ~a~}" ,(string-upcase (string cmd)) ,@lambda-list)
        stream)
       (funcall response-fn (rcv-code ,code stream)))))

(def-simple-cmd user (user) 331)
(def-simple-cmd pass (passwd) 230)
(def-simple-cmd quit () 221)
(def-simple-cmd cwd (remote-dir) 250)
(def-simple-cmd type (binary-or-ascii) 200)
(def-simple-cmd pasv () 227)

(defun put (file)
  (binary)
  (cl-ppcre:do-register-groups 
      (ip1 ip2 ip3 ip4 (#'parse-integer port1) (#'parse-integer port2))
      ("(\\d+),(\\d+),(\\d+),(\\d+),(\\d+),(\\d+)" (pasv))
    (let ((ip (format nil "~@{~a~^.~}" ip1 ip2 ip3 ip4))
          (port (+ (* port1 256) port2)))
      (snd (format nil "STOR ~a" file))
      (with-open-file (in file :element-type '(unsigned-byte 8))
        (usocket:with-client-socket (socket stream ip port
                                            :element-type '(unsigned-byte 8))
          (rcv-code 150)
          (loop for b = (read-byte in nil nil)
             while b
             do (progn
                  (write-byte b stream)))))))
  (rcv-code 226))

(defun ascii ()
  (type "A"))

(defun binary ()
  (type "I"))

(defmacro with-ftp-connection ((host user passwd &key (port 21)) &body body)
  (let ((sock (gensym)))
    `(usocket:with-client-socket (,sock *stream* ,host ,port)
       (rcv)
       (user ,user)
       (pass ,passwd)
       ,@body
       (quit))))
    
(with-ftp-connection ("s6.xrea.com" "user" "passwd")
  (setf *default-pathname-defaults* #p"/home/user/public_html/lisp/")
  (cwd "/public_html/lisp")
  (put "cookbook.html")
  (put "cookbook.css")
  (put "index.html"))

最近は usocket がポータブルなソケットライブラリの定番のようです。
これをシェルから動かすために、SBCL のマニュアルにあるように ~/.sbclrc に次のコードを書いておきます。
これで ./upload.lisp とすればアップロードできます。

;;; If the first user-processable command-line argument is a filename,
;;; disable the debugger, load the file handling shebang-line and quit.
(let ((script (and (second *posix-argv*)
                   (probe-file (second *posix-argv*)))))
  (when script
    ;; Handle shebang-line
    (set-dispatch-macro-character #\# #\!
                                  (lambda (stream char arg)
                                    (declare (ignore char arg))
                                    (read-line stream)))
    ;; Disable debugger
    (setf *invoke-debugger-hook*
          (lambda (condition hook)
            (declare (ignore hook))
            ;; Uncomment to get backtraces on errors
            ;; (sb-debug:backtrace 20)
            (format *error-output* "Error: ~A~%" condition)
            (quit)))
    (load script)
    (quit)))