;;; soup.sls --- Glossing for the Soup namespace

;; Copyright (C) 2009, 2010 Andreas Rottmann <a.rottmann@gmx.at>

;; Author: Andreas Rottmann <a.rottmann@gmx.at>

;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.

;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.

;; You should have received a copy of the GNU Lesser General Public
;; License along with this library. If not, see
;; <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:
#!r6rs

(library (sbank soup)
  (export send
          soup-setup!
          soup-status
          make-soup-output-port+flusher
          make-soup-input-port
          #!@(typelib-exports (prefix ("Soup" #f) soup-)
                              (name soup)
                              (exclude "ByteArray")))
  (import (rnrs base)
          (rnrs control)
          (rnrs lists)
          (rnrs bytevectors)
          (rnrs io ports)
          (spells foreign)
          (spells cells)
          (spells tracing)
          (sbank support utils)
          (sbank support shlibs)
          (sbank ctypes basic)
          (sbank gobject)
          (sbank gobject decorate)
          (sbank typelib base)
          (sbank typelib decorators)
          (sbank typelib))

  ;;@ Returns two values: a binary output port, and a flusher
  ;; procedure, which is a thunk that appends all data written to the
  ;; output port since the creation of the port, or the last
  ;; invokation of the flusher procedure, to message-body. Note that
  ;; closing the port does @emph{not} imply a call to the flusher
  ;; procedure, so that the port may be used and closed by code that
  ;; isn't aware of the underlying message-body object, which might
  ;; become invalid while the code using the port is running.
  (define (make-soup-output-port+flusher message-body)
    (let* ((chunks (make-cell '())))
      (values
       (make-custom-binary-output-port "soup"
                                       (soup-output-port-write! message-body chunks)
                                       #f ; get-position
                                       #f ; set-position!
                                       #f ; close
                                       )
       (lambda () (sync-chunks! chunks message-body)))))

  (define (sync-chunks! chunks message-body)
    (let ((size (fold-left (lambda (size chunk)
                             (+ size (bytevector-length chunk)))
                           0
                           (cell-ref chunks))))
      (when (> size 0)
        (let ((buffer (make-bytevector size)))
          (let loop ((i 0) (chunks (reverse (cell-ref chunks))))
            (when (not (null? chunks))
              (let ((size (bytevector-length (car chunks))))
                (bytevector-copy! (car chunks) 0 buffer i size)
                (loop (+ i size) (cdr chunks)))))
          (send message-body (append buffer))))
      (cell-set! chunks '())))

  (define (soup-output-port-write! message-body chunks)
    (lambda (bytevector start count)
      (when (not (= count 0))
        (cell-set! chunks (cons (let ((part (make-bytevector count)))
                                  (bytevector-copy! bytevector start part 0 count)
                                  part)
                                (cell-ref chunks))))
      count))

  (define (make-soup-input-port message-body)
    (make-custom-binary-input-port "soup"
                                   (soup-input-port-read! message-body)
                                   #f ; get-position
                                   #f ; set-position!
                                   (soup-input-port-close message-body)
                                   ))

  (define (soup-input-port-read! message-body)
    (let ((offset 0)
          (current-chunk #f)
          (chunk-offset 0))
      (lambda (bytevector start count)
        (unless current-chunk
          (set! current-chunk (send message-body (get-chunk offset))))
        (if (not current-chunk)
            0
            (let ((len (send current-chunk (get-length)))
                  (data (send current-chunk (get-data))))
              (if (= len 0)
                  0
                  (let ((n (min count (- len chunk-offset))))
                    (bytevector-copy! data chunk-offset bytevector start n)
                    (set! chunk-offset (+ chunk-offset n))
                    (when (>= chunk-offset len)
                      (set! current-chunk #f)
                      (set! offset (+ offset len))
                      (set! chunk-offset 0))
                    n)))))))
  
  (define (soup-input-port-close message-body)
    (lambda ()
      (send message-body (complete))))
  
  ;;@ Resolve @1 to an HTTP status code. If @1 is a symbol, it is
  ;; looked up among the Soup known status codes enumeration (that
  ;; lookup returns @code{#f} if it is not in the enumeration). If @1
  ;; is not a symbol, it is simply returned.
  (define (soup-status code)
    (if (symbol? code)
        (genumerated-lookup <soup-known-status-code> code)
        code))

  (define (message-decorator typelib class)
    (gobject-class-decorate
     class
     values
     (gobject-method-overrider typelib `((set-response . ,message-set-response)))
     values))

  (define (message-set-response typelib next-method)
    (lambda (message content-type data)
      (let ((resp-body (send message (get-response-body)))
            (hdrs (send message (get-response-headers))))
        (cond (content-type
               (send hdrs (replace "Content-Type" content-type))
               (send resp-body (append data)))
              (else
               (send hdrs (remove "Content-Type"))
               (send resp-body (truncate)))))))

  ;;@ Do the setup necessary for using Soup. You should call this
  ;; before doing a @code{typelib-import} of the "Soup"
  ;; namespace.
  (define-setup-procedure (soup-setup!)
    (gobject-setup!)
    (register-typelib-decorator "Soup" "Message" message-decorator))

  (typelib-import (only (prefix ("Soup" #f) soup-)
                        #!@(typelib-exports soup))
                  (setup soup-setup!))

  )
