Changeset 15507 in project


Ignore:
Timestamp:
08/17/09 22:05:08 (10 years ago)
Author:
sjamaan
Message:

Implement SSL

Location:
release/4/spiffy/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/spiffy/trunk/spiffy.meta

    r13084 r15507  
    77 (license "BSD")
    88 (doc-from-wiki)
    9  (needs intarweb uri-common defstruct sendfile matchable)
     9 (needs openssl intarweb uri-common defstruct sendfile matchable)
    1010 (test-depends test)
    1111 (files "spiffy.scm" "spiffy.setup" "spiffy.html"
  • release/4/spiffy/trunk/spiffy.scm

    r15316 r15507  
    4343   current-request remote-address local-address
    4444   current-response current-file current-pathinfo
    45    server-software root-path server-port server-root-uri index-files
    46    mime-type-map default-mime-type file-extension-handlers
     45   server-software root-path server-port server-ssl-context server-root-uri
     46   index-files mime-type-map default-mime-type file-extension-handlers
    4747   default-host vhost-map access-log error-log debug-log
    4848   spiffy-user spiffy-group access-file max-connections
     
    5252(import chicken scheme extras ports files data-structures)
    5353(require-extension srfi-1 srfi-13 srfi-18 tcp regex posix
    54                    intarweb uri-common sendfile matchable)
     54                   openssl intarweb uri-common sendfile matchable)
    5555
    5656(define version 4)
     
    5858
    5959;;; Request processing information
    60 (define current-request  (make-parameter #f))
    61 (define current-response (make-parameter #f))
    62 (define current-file     (make-parameter #f))
    63 (define current-pathinfo (make-parameter #f))
    64 (define local-address    (make-parameter #f))
    65 (define remote-address   (make-parameter #f))
     60(define current-request    (make-parameter #f))
     61(define current-response   (make-parameter #f))
     62(define current-file       (make-parameter #f))
     63(define current-pathinfo   (make-parameter #f))
     64(define local-address      (make-parameter #f))
     65(define remote-address     (make-parameter #f))
    6666
    6767;;; Configuration
    68 (define server-software  (make-parameter `(("Spiffy"
    69                                             ,(conc version "." release)
    70                                             ,(conc "Running on Chicken "
    71                                                    (chicken-version))))))
    72 (define root-path        (make-parameter "./web"))
    73 (define server-port      (make-parameter 8080))
    74 (define index-files      (make-parameter '("index.html" "index.xhtml")))
     68(define server-software    (make-parameter `(("Spiffy"
     69                                              ,(conc version "." release)
     70                                              ,(conc "Running on Chicken "
     71                                                     (chicken-version))))))
     72(define root-path          (make-parameter "./web"))
     73(define server-port        (make-parameter 8080))
     74(define server-ssl-context (make-parameter #f))
     75(define index-files        (make-parameter '("index.html" "index.xhtml")))
    7576(define mime-type-map
    7677  (make-parameter
     
    9192(define default-mime-type (make-parameter 'application/octet-stream))
    9293(define file-extension-handlers (make-parameter '()))
    93 (define default-host (make-parameter "localhost")) ;; XXX Can we do without?
    94 (define vhost-map (make-parameter `((".*" . ,(lambda (continue) (continue))))))
    95 (define access-log (make-parameter #f))
    96 (define error-log (make-parameter (current-error-port)))
    97 (define debug-log (make-parameter #f))
    98 (define spiffy-user (make-parameter #f))
    99 (define spiffy-group (make-parameter #f))
    100 (define access-file (make-parameter #f))
     94(define default-host    (make-parameter "localhost")) ;; XXX Can we do without?
     95(define vhost-map       (make-parameter `((".*" . ,(lambda (cont) (cont))))))
     96(define access-log      (make-parameter #f))
     97(define error-log       (make-parameter (current-error-port)))
     98(define debug-log       (make-parameter #f))
     99(define spiffy-user     (make-parameter #f))
     100(define spiffy-group    (make-parameter #f))
     101(define access-file     (make-parameter #f))
    101102(define max-connections (make-parameter 1024))
    102103
     
    354355  ((request-restarter) req (request-restarter)))
    355356
    356 (define (handle-incoming-request in out keep-going)
    357   (handle-exceptions       ; This should probably be more fine-grained
    358    exn (begin (close-input-port in)
    359               (close-output-port out))
    360    (receive (req cont)
    361      (call/cc (lambda (c) (values (read-request in) c)))
    362      (parameterize ((current-request req)
    363                     (current-response
    364                      (make-response port: out
    365                                     headers: (headers
    366                                               `((content-type text/html)
    367                                                 (server ,(server-software))))))
    368                     (request-restarter cont))
    369        (handle-exceptions
    370         exn ((handle-exception) exn
     357(define (handle-incoming-request in out)
     358  (handle-exceptions exn   ; This should probably be more fine-grained
     359    (begin (close-input-port in)
     360           (close-output-port out)
     361           #f)                          ; Do not keep going
     362    (receive (req cont)
     363      (call/cc (lambda (c) (values (read-request in) c)))
     364      (parameterize ((current-request req)
     365                     (current-response
     366                      (make-response port: out
     367                                     headers: (headers
     368                                               `((content-type text/html)
     369                                                 (server ,(server-software))))))
     370                     (request-restarter cont))
     371        (handle-exceptions exn
     372          (begin
     373            ((handle-exception) exn
    371374             (with-output-to-string print-call-chain))
    372         (let ((path (uri-path (request-uri req)))
    373               (host (determine-vhost)))
    374           (if (and host
    375                    (pair? path) ;; XXX change this to absolute-path?
    376                    (eq? (car path) '/))
    377               (let ((handler
    378                      (alist-ref host (vhost-map)
    379                                 (lambda (h _)
    380                                   (if (not (regexp? h))
    381                                       (string-match (regexp h #t) host)
    382                                       (string-match h host))))))
    383                 (if handler
    384                     (handler (lambda () (process-entry "" "" (cdr path))))
    385                     ;; Is this ok?
    386                     ((handle-not-found) path)))
    387               ;; No host or non-absolute URI in the request is an error.
    388               (send-status 400 "Bad request"
    389                            "<p>Your client sent a request that the server did not understand</p>"))
    390           (keep-going (handle-another-request?))))))))
     375            #f)                         ; Do not keep going
     376          (let ((path (uri-path (request-uri req)))
     377                (host (determine-vhost)))
     378            (if (and host
     379                     (pair? path) ;; XXX change this to absolute-path?
     380                     (eq? (car path) '/))
     381                (let ((handler
     382                       (alist-ref host (vhost-map)
     383                                  (lambda (h _)
     384                                    (if (not (regexp? h))
     385                                        (string-match (regexp h #t) host)
     386                                        (string-match h host))))))
     387                  (if handler
     388                      (handler (lambda () (process-entry "" "" (cdr path))))
     389                      ;; Is this ok?
     390                      ((handle-not-found) path)))
     391                ;; No host or non-absolute URI in the request is an error.
     392                (send-status 400 "Bad request"
     393                             "<p>Your client sent a request that the server did not understand</p>"))
     394            (handle-another-request?))))))) ; Keep going?
    391395
    392396(define (htmlize str)
     
    410414      (setenv "HOME" (list-ref uinfo 5))
    411415      (initialize-groups user (list-ref uinfo 3))
    412       (unless group ; Already changed to target group?
     416      (unless group                 ; Already changed to target group?
    413417        (set! (current-group-id) (list-ref uinfo 3)))
    414418      (set! (current-user-id) (list-ref uinfo 2)))))
     
    425429    m))
    426430
    427 (define (start-server #!key (port (server-port)))
     431(define (start-server #!key
     432                      (port (server-port))
     433                      (ssl-context (server-ssl-context)))
    428434  (parameterize ((load-verbose #f))
    429435    (letrec ((thread-count (make-mutex/value 'thread-count 0))
    430              (listener (tcp-listen port))
     436             (listener (if ssl-context
     437                           (ssl-listen port ctx: ssl-context)
     438                           (tcp-listen port)))
    431439             (accept-next-connection
    432440              (lambda ()
     
    434442                    (thread-yield!) ; Can't accept right now, wait & try again
    435443                    (receive (in out)
    436                       (tcp-accept listener)
     444                      (if ssl-context
     445                          (ssl-accept listener)
     446                          (tcp-accept listener))
    437447                      (mutex-update! thread-count add1)
    438448                      (thread-start!
     
    451461                                           (handle-another-request? #t))
    452462                              (let handle-next-request ()
    453                                 ;; This is needed to unwind all PARAMETERIZEs
    454                                 (when (call/cc
    455                                        (lambda (k)
    456                                          (handle-incoming-request in out k)
    457                                          #f)) ; in case of errors, we get here
     463                                (when (handle-incoming-request in out)
    458464                                  (log-to (debug-log)
    459465                                          "~A: kept alive"
Note: See TracChangeset for help on using the changeset viewer.