Paste number 23749: FastCGI Library

Paste number 23749: FastCGI Library
Pasted by: kingruedi
2 years, 5 months ago
#lisp
Paste contents:
Raw Source | XML | Display As
; Copyright (C) 2006 by Rüdiger Sonderfeld

;(asdf:oos 'asdf:load-op :fiveam)

; TODO:
;  * move macros and stuff to different file
;  * type declarations
;  * Unit Tests

(defpackage :fcgi
  (:use :common-lisp :sb-bsd-sockets :it.bese.FiveAM)
  (:export "LS-READER" "ACCEPT" "SETUP-ENVIRONMENT" "WRITE-STDOUT"
           "WRITE-STDERR" "END-REQUEST"))
;  (:description "Implementation of the FastCGI 1.0 Protocol specifications."))

(in-package :fcgi)

(defun to-string (n)
  (format nil "~A" n))

;; Binary Mapper
(defun compose-2-to (sym count)
  (values
   `(setf (ldb (byte 8 8) (,sym obj)) (aref byte-data ,count)

          (ldb (byte 8 0) (,sym obj)) (aref byte-data ,(incf count)))
   (1+ count)))

(defun compose-2-from (sym count)
  (values
   `(setf (aref byte-data ,count) (ldb (byte 8 8) (,sym obj))
          (aref byte-data ,(incf count)) (ldb (byte 8 0) (,sym obj)))
   (1+ count)))

(defun compose-4-to (sym count)
  (values
   `(setf (ldb (byte 8 24) (,sym obj)) (aref byte-data ,count)
          (ldb (byte 8 16) (,sym obj)) (aref byte-data ,(incf count))
          (ldb (byte 8  8) (,sym obj)) (aref byte-data ,(incf count))
          (ldb (byte 8  0) (,sym obj)) (aref byte-data ,(incf count)))
   (1+ count)))

(defun compose-4-from (sym count)
  (values
   `(setf (aref byte-data ,count) (ldb (byte 8 24) (,sym obj))
          (aref byte-data ,(incf count)) (ldb (byte 8 16) (,sym obj))
          (aref byte-data ,(incf count)) (ldb (byte 8  8) (,sym obj))
          (aref byte-data ,(incf count)) (ldb (byte 8  0) (,sym obj)))
   (1+ count)))

(defun simple-set-to (sym count)
  (values
   `(setf (,sym obj) (aref byte-data ,count))
   (1+ count)))

(defun simple-set-from (sym count)
  (values
   `(setf (aref byte-data ,count) (,sym obj))
   (1+ count)))

(defmacro binary-mapper (name &rest mapping)
  "Creates functions and a class for mapping a array of binary data to
   an object of that class.

   name is the name of the class. The corresponding functions are
   map-to-<name> and map-from-<name>. map-to-<name> takes an byte array
   as parameter and returns an object with the byte data mapped and
   map-from-<name> takes an object as parameter and returns a byte array.

   mapping are the name of the elements of the class. They can be just a
   symbol (the corresponding name and accessor of the class-element) or a
   list with the name first and as second parameter a composition type
   that allows you to map several bytes to one value.

   At the moment compose-2 and compose-4 are supported:
   compose-2 maps 2 bytes to a value anc compose-4 4 bytes.

    e.g.
   (struct-mapper fcgi request type (content-length 'compose-2))
  "
  (let ((type-in 1) (to-in 2) (from-in 3) (size-in 4)
        (type-mapper '(#(compose-2
                         '(unsigned-byte 16)
                         compose-2-to
                         compose-2-from
                         2)
                       #(compose-4
                         '(unsigned-byte 32)
                         compose-4-to
                         compose-4-from
                         4))))
    `(progn
       (defclass ,name ()
         ,(mapcar #'(lambda (n)
                      (if (listp n)
                          (list (first n) :initform 0 :accessor (first n)
                                :initarg (intern (symbol-name (first n))
                                                 :keyword)
                                :type (aref (find-if #'(lambda (te)
                                                         (eq (aref te 0)
                                                             (second n)))
                                                     type-mapper)
                                            type-in))
                          (list n :initform 0 :accessor n
                                :initarg (intern (symbol-name n) :keyword)
                                :type '(unsigned-byte 8))))
                  mapping))
       (defun ,(intern (format nil "MAP-TO-~A" name)) (byte-data)
         (let ((obj (make-instance ',name)))
           ,@(let ((count 0))
                  (mapcar #'(lambda (n)
                              (if (listp n)
                                  (multiple-value-bind (ret ptr)
                                      (funcall
                                       (aref (find-if #'(lambda (te)
                                                          (eq (aref te 0)
                                                              (second n)))
                                                      type-mapper)
                                             to-in)
                                       (first n) count)
                                    (setf count ptr)
                                    ret)
                                  (multiple-value-bind (ret ptr)
                                      (simple-set-to n count)
                                    (setf count ptr)
                                    ret)))
                          mapping))
           obj))
       (defun ,(intern (format nil "MAP-FROM-~A" name)) (obj)
         (let* ((bytes ,(loop for i in mapping
                              sum (if (listp i)
                                      (aref
                                       (find-if #'(lambda (te)
                                                    (eq (aref te 0)
                                                        (second i)))
                                                type-mapper)
                                       size-in)
                                      1) into size
                              finally (return size)))
                (byte-data (make-array bytes :element-type '(unsigned-byte 8))))
           ,@(let ((count 0))
                  (mapcar #'(lambda (n)
                              (if (listp n)
                                  (multiple-value-bind (ret ptr)
                                      (funcall
                                       (aref (find-if #'(lambda (te)
                                                          (eq (aref te 0)
                                                              (second n)))
                                                      type-mapper)
                                             from-in)
                                       (first n) count)
                                    (setf count ptr)
                                    ret)
                                  (multiple-value-bind (ret ptr)
                                      (simple-set-from n count)
                                    (setf count ptr)
                                    ret)))
                          mapping))
           byte-data))
       (defconstant ,(intern (format nil "+~A-SIZE+" name))
                              ,(loop for i in mapping
                              sum (if (listp i)
                                      (aref
                                       (find-if #'(lambda (te)
                                                    (eq (aref te 0)
                                                        (second i)))
                                                type-mapper)
                                       size-in)
                                      1) into size
                              finally (return size))))))

(define-condition not-enough-byted-read (error)
  ((bytes-read :initarg :bytes-read :reader bytes-read)
   (byted-required :initarg :bytes-required :reader bytes-required)))
; Should rather loop-read until enough bytes read!

(define-condition begin-request-on-active-request (error)
  ((request-id :initarg :request-id :reader request-id)))

(define-condition fastcgi-version-not-supported (error)
  ((version :initarg :version :reader version)))

(define-condition unknown-type (error) ; should rather report error to httpd
  ((conn-type :initarg :conn-type :reader conn-type)))

(defclass fcgi-conn ()
  ((active :initform nil :initarg :active :accessor active)
   (request-id :initform nil :initarg :request-id :accessor request-id)
   (connection-fd :initarg :connection-fd :initform nil :accessor connection-fd)
   (role :initarg :role :accessor role)
   (env :initarg :env :initform nil :accessor environment)
   (stdin :initarg :stdin :accessor stdin)
   (keep-conn :initarg :keep-conn :initform nil :accessor keep-conn)))

(defconstant +fcgi-max-connections+ 16)

(defclass fcgi-main ()
  ((socket :accessor socket)
   (request-ids :initform (make-array #.+fcgi-max-connections+
                                      :initial-element (make-instance
                                                        'fcgi-conn)
                                      :element-type 'fcgi-conn) :type 'array
                                      :accessor request-ids)))

(defmethod local-socket ((fcgi fcgi-main) socket-path)
  "Sets up a LOCAL-SOCKET (UNIX-SOCKET)"
  (with-accessors ((sock socket)) fcgi
    (setf sock (make-instance 'sb-bsd-sockets:local-socket :type :stream))
    (sb-bsd-sockets:socket-bind sock socket-path)
    (sb-bsd-sockets:socket-listen sock 3)))

(binary-mapper fcgi-header
               version
               conn-type
               (request-id compose-2)
               (content-length compose-2)
               padding-length
               reserved)

(defconstant +fcgi-begin-request+ 1)
(defconstant +fcgi-abort-request+ 2)
(defconstant +fcgi-end-request+ 3)
(defconstant +fcgi-params+ 4)
(defconstant +fcgi-stdin+ 5)
(defconstant +fcgi-stdout+ 6)
(defconstant +fcgi-stderr+ 7)
(defconstant +fcgi-data+ 8)
(defconstant +fcgi-get-values+ 9)
(defconstant +fcgi-get-values-result+ 10)
(defconstant +fcgi-unkown-type+ 11)
(defconstant +fcgi-maxtype+ 11)
(defconstant +fcgi-null-request-id+ 0)
(defconstant +fcgi-version+ 1)

(defun read-fcgi-header (conn)
  "reads byte-data from conn and maps it to a fcgi-header"
  (let ((byte-data
         (make-array +fcgi-header-size+ :element-type '(unsigned-byte 8))))
    (multiple-value-bind (buffer length addr)
        (sb-bsd-sockets:socket-receive conn byte-data nil)
      (declare (ignore addr))
      (if (= length +fcgi-header-size+)
          (map-to-fcgi-header buffer)
          (error 'not-enough-bytes-read :byted-read length
                 :bytes-required +fcgi-header-size+)))))

(binary-mapper fcgi-begin-request-body
               (role compose-2)
               flags
               reserved0 reserved1 reserved2 reserved3 reserved4)

(defconstant +fcgi-keep-conn+ 1)
(defconstant +fcgi-responder+ 1)
(defconstant +fcgi-authorizer+ 2)
(defconstant +fcgi-filter+ 3)

(defmethod begin-request ((fcgi fcgi-main) header conn)
  (let ((byte-data (make-array (+ (content-length header)
                                  (padding-length header))
                               :element-type '(unsigned-byte 8))))
    (multiple-value-bind (buffer length addr)
        (sb-bsd-sockets:socket-receive conn byte-data nil)
      (declare (ignore addr)) ; TODO: Check addr for WEB_SERVER_ADDRS (see Spec)
      (if (>= length +fcgi-begin-request-body-size+)
          (let ((begin-req-body (map-to-fcgi-begin-request-body buffer)))
            (when (active (aref (request-ids fcgi) (request-id header)))
              (error 'begin-request-on-active-request
                     :request-id (request-id header)))
              (setf (aref (request-ids fcgi) (request-id header))
                    (make-instance 'fcgi-conn :active t
                                   :request-id (request-id header)
                                   :connection-fd conn
                                   :role (role begin-req-body)
                                   :keep-conn (logand (flags begin-req-body)
                                                      +fcgi-keep-conn+))))
          (error 'not-enough-bytes-read :bytes-read length
                 :bytes-required +fcgi-begin-request-body-size+)))))

(binary-mapper fcgi-end-request-body
               (app-status compose-4)
               protocol-status
               reserved0 reserved1 reserved2)

(defconstant +fcgi-request-complete+ 0)
(defconstant +fcgi-cant-mpx-conn+ 1)
(defconstant +fcgi-overloaded+ 2)
(defconstant +fcgi-unkown-role+ 3)

(binary-mapper fcgi-unkown-type-body
               conn-type
               reserved0 reserved1 reserved2 reserved3 reserved4 reserved5
               reserved6)

; UNTESTED
(defmethod unknown-type ((fcgi fcgi-main) header conn)
  "Sends an UNKNOWN_TYPE-Message to the httpd"
  (let ((ret-header (make-instance 'fcgi-header
                                   :version +fcgi-version+
                                   :conn-type +fcgi-unkown-type+
                                   :request-id +fcgi-null-request-id+
                                   :content-length +fcgi-unkown-type-body-size+
                                   :padding-length 0))
        (body (make-instance 'fcgi-unkown-type-body
                             :conn-type (conn-type header))))
    (sb-bsd-sockets:socket-send conn
                                (concatenate '(vector (unsigned-byte 8))
                                             (map-from-fcgi-header ret-header)
                                             (map-from-fcgi-unkown-type-body
                                              body))
                                nil)))

(defun to-31bit (buffer pos)
  "Converts 4 bytes from buffer beginning at pos into a 31 Bit Fixnum"
  (+ (ash (logand (aref buffer pos) #x7f) 24)
     (ash (aref buffer (1+ pos)) 16)
     (ash (aref buffer (+ 2 pos)) 8)
     (aref buffer (+ 3 pos))))

(defun read-name-value-pairs (buffer &optional (handle-cons #'(lambda (c) c)))
  "Converts Name-Value-Pairs in buffer into a cons and calls handle-cons for
   each (returning a list of the return values of handle-cons) or returns
   a list of cons."
  (loop
     with pos = 0
     with name-length
     with value-length
     until (>= pos (length buffer))
     do (progn
          (setf name-length (aref buffer pos))
          (when (= (ash name-length -7) 1) ; 31 bit name-length?
            (setf name-length (to-31bit buffer pos))
            (incf pos 3))
          (setf value-length (aref buffer (incf pos)))
          (when (= (ash value-length -7) 1) ; 31 bit value-length?
            (setf value-length (to-31bit buffer pos))
            (incf pos 3)))
     collect (funcall handle-cons
                      (cons (map 'string #'code-char
                                 (subseq buffer (incf pos)
                                         (incf pos name-length)))
                            (map 'string #'code-char
                                 (subseq buffer pos
                                         (incf pos value-length)))))))

(defun length-to-binary (value)
  "Converts value into binary data.

   It either returns an array of 4 byte with 31 bit for value and the first bit
   as a flag set to 1 or returns an array of 1 byte with 7 bit for value and
   the first bit set to 0."
  (if (> value #x7f) ; does length fit into 7 Bit or 31 Bit required?
      (let ((buffer (make-array 4 :element-type '(unsigned-byte 8))))
        (setf (aref buffer 0) (logior (ash value -24) #x80)) ; activate bit 32
        (setf (aref buffer 1) (ash value -16))
        (setf (aref buffer 2) (ash value -8))
        (setf (aref buffer 3) value)
        buffer)
      (make-array 1 :element-type '(unsigned-byte 8)
                  :initial-element value)))

(defun write-name-value-pair (pair)
  "Converts a cons into a Name-Value-Pair."
  (let ((name (car pair)) (value (cdr pair)))
    (concatenate '(vector (unsigned-byte 8))
                 (length-to-binary (length name))
                 (length-to-binary (length value))
                 name
                 value)))

; UNTESTED!
(defmethod get-values-result ((fcgi fcgi-main) header conn)
  "Interpretes a GET_VALUES_RESULT-Message and sends an answer to the httpd"
  (let ((byte-data (make-array (+ (content-length header)
                                  (padding-length header))
                               :element-type '(unsigned-byte 8)
                               :fill-pointer (content-length header))))
    (multiple-value-bind (buffer length addr)
        (sb-bsd-sockets:socket-receive conn byte-data nil)
      (declare (ignore addr) (ignore buffer))
      (when (< length (content-length header))
        (error 'not-enough-bytes-read :bytes-read length
               :bytes-required (content-length header)))
      (let* ((body (reduce
                    #'(lambda (&optional a b)
                        (concatenate 'vector a b))
                    (read-name-value-pairs byte-data
                                           #'(lambda (pair)
                                               (write-name-value-pair
                                                (case (car pair)
                                                  ("FCGI_MAX_CONNS"
                                                   '("FCGI_MAX_CONNS" .
                                      (to-string #.+fcgi-max-connections+)))
                                                  ("FCGI_MAX_REQS"
                                                   '("FCGI_MAX_REQS" .
                                                     "1"))
                                                  ("FCGI_MPXS_CONN"
                                                   '("FCGI_MPXS_CONN" .
                                                     "0"))))))))
               (ret-header (make-instance 'fcgi-header
                                        :version +fcgi-version+
                                        :conn-type +fcgi-get-values-result+
                                        :request-id +fcgi-null-request-id+
                                        :content-length (length body)
                                        :padding-length 0)))
        (sb-bsd-sockets:socket-send conn (concatenate 'vector
                                                      (map-from-fcgi-header
                                                       ret-header)
                                                      body)
                                                      nil)))))

(defun read-stream (header conn)
  "Reads stream data from conn."
  (loop
      with hdr = header
      with data = nil
      until (= (content-length hdr) 0)
      do
      (progn
     ; read body
        (with-slots (content-length) hdr
          (let ((byte-data (make-array (+ content-length
                                          (padding-length hdr))
                                       :element-type '(unsigned-byte 8)
                                       :fill-pointer t)))
            (multiple-value-bind (buffer length addr)
                (sb-bsd-sockets:socket-receive conn byte-data nil)
              (declare (ignore addr) (ignore buffer))
              (when (< length content-length)
                (error 'not-enough-bytes-read :bytes-read length
                       :bytes-required content-length)))
            (setf (fill-pointer byte-data) content-length)
            (setf data (concatenate 'vector data byte-data))))
    ; read next package header  
        (setf hdr (read-fcgi-header conn)))
      finally (return data)))

(