;;; gopher chicken extension

;; Copyright(c) 2009 Jim Ursetto.  All rights reserved.
;; See EOF for license.

;; API notes: send-* are specified to return a true value.

(module gopher
  (accept send-line send-lastline send-text-file send-binary-file 
   make-entry send-entry entry? eol entry->string max-line-length)
  
  (import scheme chicken)
  (require-library sendfile extras data-structures)
  (import (only sendfile sendfile)
          (only extras sprintf fprintf read-line)
          (only data-structures string-translate string-split ->string))
  (require-extension posix)

  (define-record entry type name selector host port)
  (define-record-printer (entry e p) ; Interacts badly with modules w/o my patch
    (fprintf p "#<gopher-entry: ~A ~S ~S ~S ~A>"
             (entry-type e) (entry-name e)
             (entry-selector e) (entry-host e)
             (entry-port e)))
  (define (sanitize-selector str)
    ;; Replace CR, LF, TAB and NUL.  Perhaps more?
    (string-translate str "\r\n\t\x00" #\space))
  
  ;; Read a line from the client, split it into tabs and
  ;; pass it into handle-request.  Meaning of fields after
  ;; the selector is context-sensitive (ugh), so we pass
  ;; those as a list.
  ;; NB Official selector limit is 255 characters; we just
  ;; limit the total input line length.
  (define max-line-length (make-parameter 2048))
  (define (accept handle-request)
    (let ((line (read-line (current-input-port) (max-line-length))))
      (and (not (eof-object? line))
           (let ((fields (map sanitize-selector (string-split line "\t" #t))))
             (handle-request (car fields) (cdr fields))))))

  (define eol "\r\n")
  (define (send-line line)
    (display line)
    (display eol)
    #t)
  (define (send-lastline)
    (send-line ".")
    (flush-output))

  (define (send-text-file filename)
    (let ((in (open-input-file filename)))
      (handle-exceptions exn (begin (close-input-port in) (signal exn))
        (let loop ()
          (let ((line (read-line in)))
            (cond ((eof-object? line)
                   (send-lastline))
                  (else
                   (and (> (string-length line) 0)
                        (char=? (string-ref line 0) #\.)
                        (display #\.))
                   (send-line line)
                   (loop))))))
      (close-input-port in)
      #t))

  (define (send-binary-file filename)
    (let ((out (current-output-port)))
      (let ((in (file-open filename (+ open/binary open/rdonly))))
        (handle-exceptions exn (begin (file-close in) (signal exn))
          ;; Contrary to doc, sendfile doesn't accept a port, due to FILE-SIZE.
          (sendfile in out))
        (file-close in)
        #t)))

  (define (entry->string e)
    (define (s x)
      (sanitize-selector (->string x)))
    (sprintf "~a~a\t~a\t~a\t~a"
                        (string-ref (s (entry-type e)) 0)
                        (s (entry-name e))
                        (s (entry-selector e))
                        (s (entry-host e)) (s (entry-port e))))

  (define (send-entry e)
    (send-line (entry->string e)))
  )

;; Copyright (c) 2009 Jim Ursetto.  All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;; 
;;  Redistributions of source code must retain the above copyright notice,
;;   this list of conditions and the following disclaimer.
;;  Redistributions in binary form must reproduce the above copyright notice,
;;   this list of conditions and the following disclaimer in the documentation
;;   and/or other materials provided with the distribution.
;;  Neither the name of the author nor the names of its contributors 
;;   may be used to endorse or promote products derived from this software 
;;   without specific prior written permission.
;; 
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.