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

ホームページにファイルをアップロードするのに Common Lisp を使ってみようと思いました。
実装は 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))))
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))
(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))
(format nil "~a~@{~^ ~a~}" ,(string-upcase (string cmd)) ,@lambda-list)
(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)
(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)
(user ,user)
(pass ,passwd)

(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)
(load script)

0 件のコメント: