Common Lisp网络编程

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :sb-bsd-sockets)
  (use-package :sb-bsd-sockets)
  (use-package :sb-sys))

(defun htons (hostshort)
  (logior (ash (logand hostshort #x00FF) 8)
          (ash (logand hostshort #xFF00) -8)))

(defun ntohs (netshort)
  (htons netshort))

(defun htonl (hostlong)
  (logior (ash (htons hostlong) 16)
          (htons (ash hostlong -16))))

(defun ntohl (netlong)
  (htonl netlong))

(defun htonll (hostlonglong)
  (logior (ash (htonl hostlonglong) 32)
          (htonl (ash hostlonglong -32))))

(defun ntohll (netlonglong)
  (htonll netlonglong))

(defun write-word (value out)
  (write-byte (ash value -8) out)
  (write-byte (logand value #xFF) out))

(defun write-dword (value out)
  (write-word (ash value -16) out)
  (write-word (logand value #xFFFF) out))

(defun write-qword (value out)
  (write-dword (ash value -32) out)
  (write-dword (logand value #xFFFFFFFF) out))

(defun read-word (in)
  (logior (ash (read-byte in nil 0) 8) (read-byte in nil 0)))

(defun read-dword (in)
  (logior (ash (read-word in) 16) (read-word in)))

(defun read-qword (in)
  (logior (ash (read-dword in) 32) (read-dword in)))

(defclass event ()
  ((socket :initarg :socket :initform nil)
   (handler :initarg :handler :initform nil)))

(defgeneric destroy(event))

(defmethod destroy ((ev event))
  (socket-close (slot-value ev 'socket))
  (remove-fd-handler (slot-value ev 'handler)))

(let ((fd-event (make-hash-table)))
  (defun insert-fd-event (fd ev)
    (setf (gethash fd fd-event) ev))
  (defun remove-fd-event (fd)
    (destroy (get-event fd))
    (remhash fd fd-event))
  (defun get-event (fd)
    (gethash fd fd-event)))

(defun socket-stream-close? (s)
  (null (peek-char nil s nil nil)))

(defun process-client (cfd)
  (let* ((cev (get-event cfd))
         (c (slot-value cev 'socket))
         (s (socket-make-stream c :input t :output t :element-type :default)))
    (handler-case
        (let ((str (read-line s)))
          (format t "~a recive: ~a~%" c str)
          (write-line str s)
          (force-output s))
      (end-of-file ()
        (format t "~a closed~%" c)
        (remove-fd-event cfd)))))

(defun accept-handler (serverfd)
  (let* ((ev (get-event serverfd))
         (c (socket-accept (slot-value ev 'socket)))
         (clientfd (socket-file-descriptor c))
         (cev (make-instance 'event
                             :socket c
                             :handler (add-fd-handler clientfd :input #'process-client))))
    (format t "accept ~a~%" c)
    (insert-fd-event clientfd cev)))

(defun tcp-server (addr port)
  (let* ((s (make-instance 'inet-socket :type :stream :protocol :tcp))
         (fd (socket-file-descriptor s))
         (ev (make-instance 'event
                            :socket s
                            :handler (add-fd-handler fd :input #'accept-handler))))
    (socket-bind s (make-inet-address addr) port)
    (socket-listen s 512)
    (insert-fd-event fd ev)
    (loop (serve-event))))

(defun client (c)
  (let ((s (socket-make-stream c :input t :output t :element-type :default)))
    (dolist (str '("11111111" "22222222222" "33333333333" "444444444" "5555555"))
      (sleep 1)
      (write-line str s)
      (force-output s)
      (format t "~a send: ~a~%" c str)
      (format t "~a recevie: ~a~%" c (read-line s)))
    (socket-close c)))

(defun tcp-client (addr port)
  (let ((c (make-instance