;;; phricken chicken extension

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

(require-library gopher) ;; doesn't work inside module when not compiled

(module phricken
  (make-entry make-info-entry make-error-entry make-url-entry
   sgm->entry send-entry send-entries
   match-selector
   ;; request object
   request? request-selector request-matches request-extra
   ;; utilities
   sanitize-filename selector->filename utc-seconds->string
   match-resource match-url bind-fs any-handler
   start-server! filenames->entries extension-type
   ;; handlers
   handle-request handle-url handle-file handle-sgm handle-open-dir
   handlers
   ;; parameters
   host listen-address port sgm-rules url-redirect-time
   logger logger-port client-ip extension-type-map
   path->entry
   ;; reexports from gopher
   send-lastline send-line
   )

(import scheme chicken)
(require-library srfi-1 ports srfi-13 files)
(import (prefix (only gopher make-entry send-entry entry? accept)
                gopher:))
(import (except gopher make-entry send-entry entry? accept))
(import (only srfi-1 cons* any filter-map)
        (only srfi-13 string-downcase)
        (only files pathname-extension)
        (only ports with-output-to-string))

;; All this for URI encoding.  And uri-generic SVN head required!
(require-library srfi-14 uri-generic)
(import (only srfi-14 char-set-difference char-set-complement))
(import (only uri-generic
              uri-encode-string char-set:uri-unreserved char-set:gen-delims))

(use srfi-18 extras data-structures)
(use tcp-server tcp6 regex matchable posix)
(import irregex)  ; weird

;;; Parameters

(define host (make-parameter (get-host-name)))
(define listen-address (make-parameter #f))
(define port (make-parameter 70))
(define client-ip (make-parameter #f))   ; Read-only for users.

;;; Records

(define-record request selector matches extra)

;;; Logging

;; Default is (current-error-port); it is set to this value
;; at module init time, so won't be looked up dynamically.
(define logger-port
  (make-parameter (current-error-port))) ; set at init time!
;; Convert seconds since UNIX epoch into string in format "yy-mm-dd HH:MM:SS".
;; Seconds are interpreted as UTC time.
(define (utc-seconds->string seconds)
  (define (w2 x)
    (if (< x 10) (sprintf "0~a" x) (sprintf "~a" x)))
  (let ((v (seconds->utc-time seconds)))
    (define (g x)
      (vector-ref v x))
    (conc
     (+ (g 5) 1900) "-" (w2 (+ (g 4) 1)) "-" (w2 (g 3)) " " ; yyyy-mm-dd
     (w2 (g 2)) ":" (w2 (g 1)) ":" (w2 (g 0)))))            ; HH:MM:SS
;; Default logger implementation logs a formatted message to (logger-port),
;; or skips logging if the port is #f.  No locking is performed.
;; Seeking to end is performed prior to writing, but it is recommended
;; the port be opened in #:append mode.
;; It is legal for REQ to be #f if a request has not yet been created.
;; TYPE can be any symbol; current types are 'connect, 'access,
;; 'error, 'redirect.
(define logger
  (make-parameter
   (lambda (type req . msg)
     (when (logger-port)
       (let ((sel (or (and req (request-selector req))
                      '-))
             (ip (or (client-ip) '-))
             (p (logger-port)))
         (set! (file-position p 0) seek/end)
         (fprintf p         ; thread ID might be nice.
                  "~A ~A:~A ~A ~A ~S ~A\n"
                  (utc-seconds->string (current-seconds))
                  (host) (port) ip
                  type sel
                  (apply conc msg))
         (flush-output p))))))

;;; Creating entries

(define (make-entry type name sel #!optional (host (host)) (port (port)))
  (gopher:make-entry type name sel host port))
(define (make-info-entry . msg)
  (make-entry "i" (apply conc msg) "fake" "(NULL)" 0))
(define (make-error-entry . msg)
  (make-entry "3" (apply conc msg) "fake" "(NULL)" 0))
(define (make-url-entry name url)
  (make-entry "h" name (string-append "URL:" url) (host) (port)))

;;; Converting Scheme (S-expr) Gophermaps to entries

;; sgm-rules: alist mapping entry type to a procedure which creates
;; that entry.  Procedure is passed the current sgm entry via APPLY.
(define sgm-rules
  (make-parameter
   `((*default* . ,make-entry)
     (i . ,(lambda (type . msg)    (apply make-info-entry msg)))
     (3 . ,(lambda (type . msg)    (apply make-error-entry msg)))
     (h . ,(lambda (type name url) (make-url-entry name url)))
)))

;; Convert expr to entry using sgm-rules.  If entry type is not found,
;; the rule *default* is consulted; an error is signaled if no rules match.
(define (sgm->entry expr)
  (let* ((rules (sgm-rules))
         (default (alist-ref '*default* rules)))
    (cond ((alist-ref (car expr) rules)
           => (lambda (make)
                (apply make expr)))
          (default (apply default expr))
          (else
           (error 'sgm->entry
                  "No rule corresponding to type" (car expr))))))

;;; Sending entries to client

;; Sends one entry to the client.  e may be an entry object or
;; an sgm item.
(define (send-entry e)
  (cond ((gopher:entry? e)
         (gopher:send-entry e))
        ((pair? e)
         (gopher:send-entry (sgm->entry e)))
        (else
         (error 'send-entry
                "Invalid entry" e))))

;; Sends all entries in L to the client.
(define (send-entries L)
  (for-each send-entry L)
  #t)


;;; Handlers

;;;; Filename utilities

;; Sanitize filename FN; currently just removes any references
;; to a parent directory "..".
(define sanitize-filename
  (let ((parent-dir (irregex '(: (or "/" bos)
                                 ".."
                                 (or "/" eos)))))
    (lambda (fn)
      (and (not (string-search parent-dir fn))
           fn))))

;; Converts a selector string into a filename string by prepending the
;; ROOT path.  Also confirms the file exists and the user has read
;; permission.  Returns #f on failure.
(define (selector->filename s root)
  (unless root
    (error "Filesystem 'root' parameter not set"))
  (and-let* ((fn (sanitize-filename (string-append root "/" s))))
    (and (file-read-access? fn)
         fn)))

;;;; URL handler

(define url-redirect-time (make-parameter 0)) ;; Redirect time, in seconds
;; Meta redirect user to URL in first submatch of request, as provided
;; by match-url.
(define handle-url
  (let ((url-escape-charset
         (char-set-difference (char-set-complement char-set:uri-unreserved)
                              char-set:gen-delims)))  ;; blechhh!!
    (lambda (req)
      (let ((url (uri-encode-string (car (request-matches req))
                                    url-escape-charset)))
        ;; Should we print to a port?
        (printf "
<html><head><title>phricken gopher server redirect page</title>
            <meta http-equiv=\"refresh\" content=\"~A;url=~A\" />
</head>
<body>You will be redirected to <a href=\"~A\">~A</a> in ~A seconds.
</body></html>" (url-redirect-time) url url url (url-redirect-time))
        ((logger) 'redirect req "to " url)
        #t))))

;;;; File handler

;; Expects to be attached to a resource (path is second submatch).
(define (handle-file root)
  (lambda (req)
    (cond ((selector->filename (cadr (request-matches req)) root)
           => (lambda (fn)
                (if (regular-file? fn)
                    (send-binary-file fn)
                    #f)))
          (else #f))))

;;;; SGM handler

;; If (sgm-filename) exists in the directory indicated by the selector,
;; read the file contents as a Scheme Gopher Map and send the results.
(define sgm-filename (make-parameter "index.sgm"))
;; Expects to be attached to a resource (path is second submatch).
(define (handle-sgm root)
  (lambda (req)
    (and-let* ((fn (selector->filename
                    (string-append (cadr (request-matches req))
                                   "/" (sgm-filename))
                    root)))
      (and (regular-file? fn)
           (send-entries (read-file fn))))))

;;;; Open directory handler

;; Case-insensitive map of file extension (as symbol) to
;; 1-character Gopher entry type (as symbol).
(define extension-type-map
  (make-parameter
   `((txt . 0) (log . 0) (scm . 0) (sgm . 0) (c . 0) (h . 0)
     (png . I) (gif . g) (jpg . I) (svg . I))))
;; (Internal.) Look up extension EXT in (extension-type-map).
(define (extension-type ext)
  (alist-ref
   (string->symbol
    (string-downcase (or ext "")))  ; treat #f ext as empty
   (extension-type-map)))
;; Convert pathname (DIR is directory on disk; FN is basename of file
;; on disk; DIR-SEL is the selector corresponding to DIR) into an
;; entry (either an entry object or an SGM entry is permissible).
;; Used by filenames->entres.
;;
;; The default procedure maps directories to type 1, other files based
;; on (extension-type-map), and defaults to binary type 9.  Symbolic
;; links are currently ignored.
(define path->entry
  (make-parameter
   (lambda (dir fn dir-sel)
     (define (path->entry-type dir fn)
       (let ((path (string-append dir "/" fn)))
         (cond ((directory? path) 1)
               ((symbolic-link? path) #f)
               ((regular-file? path)
                (or (extension-type (pathname-extension fn))
                    9))
               (else #f))))
     (let ((child-sel (string-append dir-sel "/" fn)))
       (and-let* ((type (path->entry-type dir fn)))
         `(,type ,fn ,child-sel))))))

;; DIR is the containing directory on disk; BASENAMES are the
;; basenames of the files, such as provided via the (directory dir)
;; call; DIR-SEL is the absolute selector corresponding to this
;; directory (not relative to any resource).
(define (filenames->entries dir basenames dir-sel)
  (filter-map
   (lambda (fn)
     ((path->entry) dir fn dir-sel))
   basenames))

;; Generate a directory listing for any directory under ROOT,
;; using filenames->entries to determine how to generate an
;; entry for each filename.  (Generated entries need not be
;; file entries!)
;; Expects to be attached to a resource (path is second submatch).
(define (handle-open-dir root)
  (lambda (req)
    ;; if paranoid, run selector->filename on generated name
    (and-let* ((sel (request-selector req))
               (relative-dir-sel (cadr (request-matches req)))
               (dir (selector->filename relative-dir-sel root)))
      (and (directory? dir)
           (let ((contents (sort (directory dir) string<?))) ; ignore dotfiles
             (send-entries
              `((i "Contents of " ,sel)
                (i)
                ,@(filenames->entries dir contents sel))))))))

;;; Selector matching for handlers

;; Match incoming selector against regex RX using string-match, and calls
;; HANDLER with the request object.  Any submatches will be added to
;; the MATCHES field of the request (i.e., the CDR of the result of
;; string-match).
(define (match-selector rx handler)
  (lambda (req)
    (and-let* ((matches (string-match rx (request-selector req))))
      (handler (make-request (request-selector req)
                             (cdr matches) ; first match is always selector
                             (request-extra req))))))

;; Match resource.  Just a shortcut for match-selector, which matches
;; the directory (posix-string or SRE) you provide as 'resource', plus
;; optional subdirectory path.  E.g., "/wiki" will match
;; "(/wiki)($|/*)" and provide those two submatches in the request.
(define (match-resource resource handler)
  (define (maybe-string->sre rx)
    (if (string? rx) (string->sre rx) rx))
  (let* ((sre (maybe-string->sre resource))
         (rx (irregex `(: (submatch ,sre)
                          (submatch (or eos (: "/" (* any))))))))
    (match-selector rx handler)))

;; Matcher for URL selectors; first submatch will be the URL.
(define (match-url handler)
  (match-selector '(: "URL:" (submatch (+ any)))
                  handler))

;; Utility function which 'mounts' fs ROOT on resource selector SEL.
;; Handlers used are handle-sgm, handle-open-dir, handle-file.
(define (bind-fs sel root)
  (match-resource
   sel
   (any-handler (handle-sgm root)
                (handle-open-dir root)
                (handle-file root))))

;; Execute HANDLERS in order and return first true value, or #f.
(define (any-handler . handlers)
  (lambda (req)
    (any (lambda (h) (h req))
         handlers)))

;;; Handle requests

;; Handlers are executed in order until one returns a true value.
;; If a handler throws an exception, processing terminates immediately.
;; Each handler is passed a request object.

(define handlers (make-parameter #f))

(define (handle-request selector extra)
  (let ((req (make-request selector '() extra)))
      (handle-exceptions exn
          (begin (send-entry '(3 "Internal server error."))
                 ((logger) 'error req
                         (string-intersperse
                          (cons ((condition-property-accessor
                                  'exn 'message) exn)
                                (map ->string
                                     ((condition-property-accessor
                                       'exn 'arguments) exn)))
                          ": "))
                 (signal exn))
        ;; Log immediately upon request receipt, instead of after handler.
        ;; Noisier, but handler logging appears in correct order.
        (if (null? extra)
            ((logger) 'access req)
            ((logger) 'access req
                    (with-output-to-string (lambda ()
                                             (write extra)))))
        (or (any (lambda (h) (h req))
                 (handlers))
            (begin (send-entry `(3 "Invalid selector " ,selector))
                   ((logger) 'error req "Invalid selector"))))))

;;; Start/stop server

(define-constant *listen-backlog* 10)
(define (start-server! #!optional (bg #f))
  (parameterize ((tcp-server-accept-connection-procedure tcp-accept)
                 (tcp-server-get-addresses-procedure tcp-addresses))  ;; tcp6
    (let ((server
           (make-tcp-server
            (tcp-listen (port) *listen-backlog* (listen-address))
            (lambda ()
              (let-values (((local remote)
                            (tcp-addresses (current-output-port))))
                (parameterize ((client-ip remote))
                  ((logger) 'connect #f)
                  (gopher:accept handle-request)))))))
      (parameterize ((tcp-buffer-size 16384))
        (if bg
            (thread-start! server)
            (server))))))

;; (define (stop-server!)
;;   (when (server-thread)
;;    (thread-terminate! (server-thread))  ; Unsafe and won't close port
;;    (server-thread #f)))
)

;; Copyright (c) 2009-2011 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.