;; Copyright (c) 2010-2015, Mario Domenech Goulart ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. 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. ;; 3. The name of the authors may not be used to endorse or promote products ;; derived from this software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. (module awful (;; Parameters awful-apps debug-file debug-db-query? debug-db-query-prefix db-credentials ajax-library enable-ajax ajax-namespace enable-session page-access-control page-access-denied-message page-doctype page-css page-charset login-page-path main-page-path app-root-path valid-password? page-template ajax-invalid-session-message web-repl-access-control web-repl-access-denied-message session-inspector-access-control session-inspector-access-denied-message page-exception-message http-request-variables db-connection page-javascript sid enable-javascript-compression javascript-compressor debug-resources enable-session-cookie session-cookie-name session-cookie-setter awful-response-headers development-mode? enable-web-repl-fancy-editor web-repl-fancy-editor-base-uri awful-listen awful-accept awful-backlog awful-listener javascript-position awful-resources-table sxml->html enable-sxml literal-script/style? ;; Procedures ++ concat include-javascript add-javascript add-css debug debug-pp $session $session-set! $ $db $db-row-obj define-page undefine-page define-session-page ajax ajax-link periodical-ajax login-form define-login-trampoline enable-web-repl enable-session-inspector awful-version load-apps reload-apps link form redirect-to add-request-handler-hook! remove-request-handler-hook! set-page-title! ;; Macros (define-app path-split path-prefix? match-matcher) ;; spiffy-request-vars wrapper with-request-variables true-boolean-values as-boolean as-list as-number as-alist as-vector as-hash-table as-string as-symbol nonempty ;; Required by the awful server add-resource! register-dispatcher register-root-dir-handler awful-start ;; Required by db-support eggs db-enabled? db-inquirer db-connect db-disconnect sql-quoter db-make-row-obj db-query-transformer ;; Required by awful-static-pages %path-procedure-result ) ; end export list (import scheme chicken data-structures utils extras ports srfi-69 files srfi-1) ;; Units (use posix srfi-13 tcp) ;; Eggs (use intarweb spiffy spiffy-request-vars html-tags html-utils uri-common http-session json spiffy-cookies regex sxml-transforms) ;; For match-matcher (import-for-syntax regex) (include "version.scm") ;;; Parameters ;; User-configurable parameters (define awful-apps (make-parameter '())) (define debug-file (make-parameter #f)) (define debug-db-query? (make-parameter #t)) (define debug-db-query-prefix (make-parameter "")) (define db-credentials (make-parameter #f)) (define ajax-library (make-parameter "//ajax.googleapis.com/ajax/libs/jquery/1.11.0/jquery.min.js")) (define enable-ajax (make-parameter #f)) (define ajax-namespace (make-parameter "ajax")) (define enable-session (make-parameter #f)) (define page-access-control (make-parameter (lambda (path) #t))) (define page-access-denied-message (make-parameter (lambda (path) (
convert-to-entities?: #t (with-output-to-string (lambda () (print-call-chain) (print-error-message exn)))) ("[" ( href: (or (%web-repl-path) "/web-repl") "Web REPL") "]" (if (enable-session) (++* " [" ( href: (or (%session-inspector-path) "/session-inspector") "Session inspector") "]") "")))))) ;; If web-repl has not been activated, activate it allowing access ;; to the localhost at least (`web-repl-access-control' can be ;; used to provide more permissive control) (unless (%web-repl-path) (let ((old-access-control (web-repl-access-control))) (web-repl-access-control (lambda () (or (old-access-control) (equal? (remote-address) "127.0.0.1"))))) (enable-web-repl "/web-repl")) ;; If session-inspector has not been activated, and if ;; `enable-session' is #t, activate it allowing access to the ;; localhost at least (`session-inspector-access-control' can be ;; used to provide more permissive control) (when (and (enable-session) (not (%session-inspector-path))) (let ((old-access-control (session-inspector-access-control))) (session-inspector-access-control (lambda () (or (old-access-control) (equal? (remote-address) "127.0.0.1")))) (enable-session-inspector "/session-inspector"))) ;; The reload page (define-reload-page)) (define (awful-start thunk #!key dev-mode? port ip-address (use-fancy-web-repl? #t) privileged-code) (enable-web-repl-fancy-editor use-fancy-web-repl?) (when dev-mode? (development-mode? #t) (development-mode-actions)) (when port (server-port port)) (when ip-address (server-bind-address ip-address)) ;; if privileged-code is provided, it is loaded before switching ;; user/group (when privileged-code (privileged-code)) (let ((listener ((awful-listener)))) (switch-user/group (spiffy-user) (spiffy-group)) (when (and (not (eq? (software-type) 'windows)) (zero? (current-effective-user-id))) (print "WARNING: awful is running with administrator privileges (not recommended)")) ;; load apps (thunk) ;; Check for invalid JavaScript positioning (unless (memq (javascript-position) '(top bottom)) (error 'awful-start "Invalid value for `javascript-position'. Valid ones are: `top' and `bottom'.")) (register-root-dir-handler) (register-dispatcher) (accept-loop listener (awful-accept)))) (define (get-sid #!optional force-read-sid) (and (or (enable-session) force-read-sid) (if (enable-session-cookie) (or (read-cookie (session-cookie-name)) ($ 'sid)) ($ 'sid)))) (define (redirect-to new-uri) ;; Just set the `%redirect' internal parameter, so `run-resource' is ;; able to know where to redirect. (%redirect new-uri) "") ;;; Application definition (define (path-split path) (cons "/" (string-split path "/"))) (define (path-prefix? prefix path) (let ((len-prefix (length prefix))) (and (<= len-prefix (length path)) (equal? prefix (take path len-prefix))))) (define (match-matcher matcher-obj path thunk) (cond ((procedure? matcher-obj) (when (matcher-obj path) (thunk))) ((list? matcher-obj) (when (path-prefix? matcher-obj (path-split path)) (thunk))) ((regexp? matcher-obj) (when (string-match matcher-obj path) (thunk))) (else (error 'define-app "Unknown matcher object" matcher-obj)))) (define-syntax define-app (syntax-rules (matcher: handler-hook: parameters:) ((_ id matcher: matcher handler-hook: proc body ...) (let ((proc* proc) (matcher* matcher)) (add-request-handler-hook! 'id (lambda (path handler) (match-matcher matcher* path (lambda () (proc* handler))))) (proc* (lambda () body ...)))) ((_ id matcher: matcher parameters: params body ...) (let ((matcher* matcher)) (add-request-handler-hook! 'id (lambda (path handler) (match-matcher matcher* path (lambda () (parameterize params (handler)))))) (parameterize params body ...))) ((_ id matcher: matcher body ...) (let ((matcher* matcher)) (add-request-handler-hook! 'id (lambda (path handler) (match-matcher matcher* path handler))) body ...)))) ;;; JavaScript (define (include-javascript . files) (let ((js (parameterize ((generate-sxml? (enable-sxml))) (map (lambda (file) (