200行くらいで書いた小さなサーバ lang:SBCL

super-tiny-server.lisp

(require 'sb-bsd-sockets)

(defmacro while (condition &body body)
  `(do () ((not ,condition)) ,@body))

(defmacro for (enumerator begin to end &body body)
  (let ((end-num (gensym)))
    `(let ((,enumerator ,begin)
           (,end-num ,end))
       (while (<= ,enumerator ,end-num)
              ,@body
              (incf ,enumerator)))))

(defmacro foreach (iterator in list &body body)
  (let ((rest (gensym)))
    `(let ((,iterator nil)
           (,rest ,list))
       (while ,rest
              (setf ,iterator (car ,rest))
              (setf ,rest (cdr ,rest))
              ,@body))))

(defun exclusive (n)
  (- n 1))

(defun concatenate-array (list)
  (let* ((length (reduce #'+ (mapcar #'length list)))
         (buffer (make-array length :element-type '(unsigned-byte 8)))
         (base 0))
    (foreach array in list
             (for i 0 to (exclusive (length array))
                  (setf (aref buffer (+ base i)) (aref array i)))
             (setf base (+ base (length array))))
    buffer))

(defstruct array-builder
  (buffer (make-array 1024 :element-type '(unsigned-byte 8)))
  (temp nil)
  (current-index -1))

(defun array-builder-append! (array-builder x)
  (let ((buffer (array-builder-buffer array-builder))
        (current-index (array-builder-current-index array-builder)))
    (incf current-index)
    (when (= current-index (length buffer))
      (setf (array-builder-temp array-builder)
            (cons buffer (array-builder-temp array-builder)))
      (setf buffer (make-array (length buffer)))
      (setf current-index 0)
      (setf (array-builder-buffer array-builder) buffer))
    (setf (aref buffer current-index) x)
    (setf (array-builder-current-index array-builder) current-index)))

(defun array-from-array-builder! (array-builder)
  (let ((buffer (array-builder-buffer array-builder))
        (current-index (array-builder-current-index array-builder))
        (temp (array-builder-temp array-builder)))
    (setf buffer (adjust-array buffer (+ current-index 1)))
    (concatenate-array (nreverse (cons buffer temp)))))

(defun read-socket-to-space (socket)
  (let ((buffer (make-array 1 :element-type '(unsigned-byte 8)))
        (array-builder (make-array-builder))
        (found-octet? nil)
        (errored? nil))
    (while (and (not found-octet?) (not errored?))
           (multiple-value-bind
             (buffer-ret length peer) (sb-bsd-sockets:socket-receive socket buffer 1)
             (if (= length 0)
               (setf errored? t)
               (let ((gotten-octet (aref buffer-ret 0)))
                 (if (= gotten-octet #x20)
                   (setf found-octet? t)
                   (array-builder-append! array-builder gotten-octet))))))
    (array-from-array-builder! array-builder)))

(defun read-socket-to-crlf (socket)
  (let ((buffer (make-array 1 :element-type '(unsigned-byte 8)))
        (array-builder (make-array-builder))
        (found-octets? nil)
        (errored? nil)
        (last-octet -1))
    (while (and (not found-octets?) (not errored?))
           (multiple-value-bind
             (buffer-ret length peer) (sb-bsd-sockets:socket-receive socket buffer 1)
             (if (= length 0)
               (setf errored? t)
               (let ((gotten-octet (aref buffer-ret 0)))
                 (if (and (= last-octet #x0d) (= gotten-octet #x0a))
                   (setf found-octets? t)
                   (progn
                     (when (= last-octet #x0d)
                       (array-builder-append! array-builder last-octet))
                     (unless (= gotten-octet #x0d)
                       (array-builder-append! array-builder gotten-octet))))
                 (setf last-octet gotten-octet)))))
    (array-from-array-builder! array-builder)))

(defun receive-request-line (client)
  (let* ((method (read-socket-to-space client))
         (request-target (read-socket-to-space client))
         (HTTP-version (read-socket-to-crlf client)))
    (values method request-target HTTP-version)))

(defun read-header-fields (socket)
  (let ((temp nil)
        (eoh? nil))
    (while (not eoh?)
           (let ((header-field (read-socket-to-crlf socket)))
             (if (= (length header-field) 0)
               (setf eoh? t)
               (setf temp (cons header-field temp)))))
    (nreverse temp)))

(defun send-response (client list)
  (foreach sequence in list
    (handler-case
      (sb-bsd-sockets:socket-send client sequence nil)
      (sb-bsd-sockets:socket-error ()))))

(defmacro define-method (method args &body body)
  (let ((method-name (intern (concatenate 'string
                                          (symbol-name method) "-METHOD")))
        (method-name? (intern (concatenate 'string
                                           (symbol-name method) "-METHOD?"))))
    `(progn
       (defun ,method-name? (method)
         (equalp method ,(sb-ext:string-to-octets (symbol-name method))))
       (defun ,method-name ,args
         ,@body))))

(defun parse-target (path)
  (let* ((external-pathname (pathname (sb-ext:octets-to-string path)))
         (external-path (pathname-directory external-pathname))
         (internal-path `(:relative "www" ,@(cdr external-path))))
    (make-pathname :directory internal-path
                   :name (pathname-name external-pathname)
                   :type (pathname-type external-pathname))))

(defun load-file (target)
  (let ((stream (open (parse-target target)
                      :direction :input
                      :element-type '(unsigned-byte 8)
                      :if-does-not-exist nil)))
    (if stream
      (let* ((length (file-length stream))
             (array (make-array length :element-type '(unsigned-byte 8))))
        (for index 0 to (exclusive length)
             (setf (aref array index) (read-byte stream)))
        (values "200 OK" array))
      (values "404 Not Found" (sb-ext:string-to-octets "404 Not Found.")))))

(defun make-header (status body)
  (let ((crlf #.(format nil "~C~C" #\return #\linefeed)))
    (sb-ext:string-to-octets
      (concatenate 'string
                   "HTTP/1.1 " status crlf
                   "Content-Length: " (write-to-string (length body)) crlf
                   crlf))))

(defun solve-get/head-request (request-target client)
  (let ((header-fields (read-header-fields client)))
    (multiple-value-bind
      (status content) 
      (load-file request-target)
      (values (make-header status content) content))))

(define-method GET (request-target client)
  (multiple-value-bind
    (header body) (solve-get/head-request request-target client)
    `(,header ,body)))

(define-method HEAD (request-target client)
  (multiple-value-bind
    (header body) (solve-get/head-request request-target client)
    `(,header)))

(defun start-server (&key port accepts-client)
  (let ((server (make-instance 'sb-bsd-sockets:inet-socket :protocol :tcp :type :stream)))
    (sb-bsd-sockets:socket-bind server #(0 0 0 0) port)
    (sb-bsd-sockets:socket-listen server 100)
    (unwind-protect
      (loop
        (multiple-value-bind (client address)
          (sb-bsd-sockets:socket-accept server)
          (funcall accepts-client client address)))
      (sb-bsd-sockets:socket-close server))))

(defun return-response (client address)
  (multiple-value-bind
    (method request-target HTTP-version) (receive-request-line client)
    (send-response
      client
      (cond ((get-method? method)
             (get-method request-target client))
            ((head-method? method)
             (head-method request-target client)))))
  (sb-bsd-sockets:socket-close client))

(defun main ()
  (handler-case
    (start-server
      :port 8080
      :accepts-client #'return-response)
    (sb-sys:interactive-interrupt
      ()
      (format t "~%"))))