121 lines
4.0 KiB
Common Lisp
121 lines
4.0 KiB
Common Lisp
;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
|
|
;;;; This is copyrighted software. See documentation for terms.
|
|
;;;;
|
|
;;;; entity.cl --- Entity Handling
|
|
;;;;
|
|
;;;; Checkout Tag: $Name$
|
|
;;;; $Id$
|
|
|
|
(in-package :CLASH)
|
|
|
|
;;;; %File Description:
|
|
;;;;
|
|
;;;;
|
|
;;;;
|
|
|
|
(defclass entity ()
|
|
())
|
|
|
|
(defgeneric render-entity-headers (entity stream))
|
|
|
|
(defgeneric render-entity-body (entity stream))
|
|
|
|
(defclass entity-header-mixin/1.1 ()
|
|
((allow :initarg :allow :reader entity-allow)
|
|
(content-encoding :initarg :content-encoding
|
|
:reader entity-content-encoding)
|
|
(content-language :initarg :content-language
|
|
:reader entity-content-language)
|
|
(content-length :initarg :content-length :reader entity-content-length)
|
|
(content-location :initarg :content-location
|
|
:reader entity-content-location)
|
|
(content-md5 :initarg :content-md5 :reader entity-content-md5)
|
|
(content-range :initarg :content-range :reader entity-content-range)
|
|
(content-type :initarg :content-type :reader entity-content-type)
|
|
(expires :initarg :expires :reader entity-expires)
|
|
(last-modified :initarg :last-modified :reader entity-last-modified)))
|
|
|
|
(defmethod render-entity-headers ((e entity-header-mixin/1.1) stream)
|
|
(render-slots (e stream)
|
|
(allow "Allow"
|
|
(write-http-element-list-1 allow stream))
|
|
(content-encoding "Content-Encoding"
|
|
(write-http-element-list-1 content-encoding stream))
|
|
(content-language "Content-Language"
|
|
(write-http-element-list-1 content-language stream))
|
|
(content-length "Content-Length"
|
|
(format stream "~D" content-length))
|
|
(content-location "Content-Location"
|
|
(princ content-location stream))
|
|
#+NIL
|
|
(content-md5 "Content-MD5"
|
|
(write-string (base64-encode-string content-md5) stream))
|
|
#+NIL
|
|
(content-range "Content-Range"
|
|
(princ content-range stream))
|
|
(content-type "Content-Type"
|
|
(princ content-type stream))
|
|
(expires "Expires"
|
|
(write-string (rfc1123-format-time expires) stream))
|
|
(last-modified "Last-Modified"
|
|
(write-string (rfc1123-format-time last-modified) stream))))
|
|
|
|
(defclass stream-entity-mixin ()
|
|
())
|
|
|
|
(defgeneric stream-entity-stream (entity))
|
|
|
|
(defgeneric stream-entity-length (entity))
|
|
|
|
(defmethod render-entity-headers :before ((e stream-entity-mixin) stream)
|
|
(declare (ignore stream))
|
|
(setf (slot-value e 'content-length) (stream-entity-length e)))
|
|
|
|
(defmethod render-entity-body ((entity stream-entity-mixin) stream)
|
|
(with-open-stream (in-stream (stream-entity-stream entity))
|
|
(with-io-buffer (buffer)
|
|
(loop for length = (read-sequence buffer in-stream)
|
|
until (zerop length)
|
|
do
|
|
(write-sequence buffer stream :end length)))))
|
|
|
|
(defclass string-entity (entity stream-entity-mixin entity-header-mixin/1.1)
|
|
((body :initarg :body :reader entity-body)))
|
|
|
|
(defmethod stream-entity-length ((entity string-entity))
|
|
(length (entity-body entity)))
|
|
|
|
(defmethod stream-entity-stream ((entity string-entity))
|
|
(make-string-input-stream (entity-body entity)))
|
|
|
|
(defclass file-entity (entity stream-entity-mixin entity-header-mixin/1.1)
|
|
((pathname :initarg :pathname :reader entity-pathname)
|
|
(file-stream :initform nil)))
|
|
|
|
(defmethod stream-entity-length ((entity file-entity))
|
|
(file-length (stream-entity-stream entity)))
|
|
|
|
(defmethod stream-entity-stream ((entity file-entity))
|
|
(let ((file-stream (slot-value entity 'file-stream)))
|
|
(if (and (streamp file-stream) (open-stream-p file-stream))
|
|
file-stream
|
|
(setf (slot-value entity 'file-stream)
|
|
(open (entity-pathname entity) :direction :input)))))
|
|
|
|
(defclass cached-entity-mixin ()
|
|
((body-cache)))
|
|
|
|
(defmethod render-entity-body :around ((entity cached-entity-mixin) stream)
|
|
(prog1 nil
|
|
(if (slot-boundp entity 'body-cache)
|
|
(write-sequence (slot-value entity 'body-cache) stream)
|
|
(setf (slot-value entity 'body-cache)
|
|
(with-output-to-string (cache-stream)
|
|
(with-open-stream (combined-stream
|
|
(make-broadcast-stream stream cache-stream))
|
|
(call-next-method entity combined-stream)))))))
|
|
|
|
(defclass cached-file-entity (cached-entity-mixin file-entity)
|
|
())
|
|
|