;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;;;; Main loop for the Philip-Jose Farmer

;;;;; Incremental parser protocol

(in-package :philip-jose)

;;;; The Incremental parser protocol
;;
;; This protocol allows for a single-threaded server to monitor many connections at once,
;; possibly on many ports, with each connection having partial request message that will
;; either be trivially handled, or lead to spawning after the request is complete.
;;
;; An incremental parser function is given a buffer (byte or char array),
;; the size up to which the buffer is filled, and
;; the previous (incomplete) state of the incremental parser, or nil on the first attempt.
;; It returns two values. The first is a boolean that tells if the parse was successful.
;; If the first value is T, then the second value is the result of the parse.
;; If the first value is NIL, then the second value is the state of the incremental parser,
;; from which to resume when the buffer is made more full.
;;
;; In a world with any kind of first-class (partial) continuations, either linear or multi-entry,
;; any direct parser could be made incremental, by having the READ-CHAR primitive return the
;; partial continuation of the parser to the caller.
;; Maybe we can hook Screamer or arnesi's call/cc into here.

;; TODO:
;; * add a buffer management protocol to make the thing work for bigger requests and
;;  on-going conversations

;;;; Trivial implementations of simple cases


;;; Line parser -- the request in complete at the end of the first line
(defun line-end-code-p (cc)
  (member cc '(10 13)))
(defun line-end-char-p (ch)
  (line-end-code-p (char-code ch)))

(defun trivial-incremental-line-parser (buffer size state)
  ;; Implements the incremental parser protocol for character input, detecting a full line.
  (let* ((line-end-pos (position-if #'line-end-char-p buffer :start (or state 0))))
    (if line-end-pos
      (values t line-end-pos)
      (values nil size))))


;;; Wrapper that prevents too many retries
;; Drop (presumably buggy or malevolent) connections with too many packets for the initial request.
;; As in attempts to flood with small packets, connection with a lot of fragmentation,
;; malformed request, overlarge request, buffer overflow tentative.

(define-condition too-many-attempts ()
  ()
  (:report (lambda (condition stream)
             (declare (ignore condition))
	     (format stream "Too many attempts in incremental request parsing"))))

(defun incremental-parser-attempt-limiter (max-attempts incremental-parser)
  (labels ((check (x)
               (when (>= x max-attempts)
                 (error 'too-many-attempts)))
           (try (buffer size state)
             (multiple-value-bind (count inner-state)
                 (if state (values (car state) (cdr state)) (values 0 nil))
               (check count)
               (multiple-value-bind (successp x)
                   (funcall incremental-parser buffer size inner-state)
                 (if successp
                   (values t x)
                   (let ((c (1+ count)))
                     (check c)
                     (values nil (cons c x))))))))
    (if (typep max-attempts '(unsigned-byte 16))
      #'try
      incremental-parser)))


;;; Trivial transformation of a parser into a pseudo incremental parser.
;; Restarting from the beginning everytime.
;; It's inefficient and a big DoS target unless combined with the limiter above.

(defun pseudo-incremental-parser-from-reader (reader)
  ;; Implements the incremental parser protocol for character input, given a reader.
  ;; Not really incremental, always restart from scratch, so called pseudo.
  ;; Could do better with call/cc and an open stream protocol.
  #'(lambda (buffer size state &aux index)
      (declare (ignore state))
      (handler-case
          (values t (cons (with-input-from-string (s buffer :index index :start 0 :end size)
	       		    (funcall reader s t))
	                  index))
	(end-of-file () (values nil nil)))))


;;; Use of the Lisp reader as a parser.
;; NOT FOR USE IN THE WILD! See warning in trivial-sexp-server.lisp

(let ((f (pseudo-incremental-parser-from-reader #'safe-read)))
  (defun make-incremental-reader (&optional (max-attempts 4))
    (incremental-parser-attempt-limiter max-attempts f)))


(defun incrementally-parsed-request-handler (connection buffer size state &optional (handler #'handle-sexp-request))
  (with-trivial-logging ()
    (destructuring-bind (request . index) state
      (with-open-stream (bufin (make-string-input-stream buffer index size))
        (with-open-stream (in (make-concatenated-stream bufin connection))
          (let ((*standard-input* in)
                (*standard-output* connection))
            (funcall handler request)))))))

(defun make-incrementally-parsed-request-handler (h)
  #'(lambda (connection buffer size state)
      (incrementally-parsed-request-handler connection buffer size state h)))