(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 ;; Procedures ++ concat include-javascript add-javascript debug debug-pp $session $session-set! $ $db $db-row-obj sql-quote 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! ;; 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 ) ; 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) ;;; Version (define (awful-version) "0.38") ;;; 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.8.2/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) (
"The following awful apps have been reloaded on "
(seconds->string (current-seconds)))
(itemize (map "[" ( 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? privileged-code)
(enable-web-repl-fancy-editor use-fancy-web-repl?)
(when dev-mode? (development-mode? #t))
(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)
"")
;;; Javascript
(define (include-javascript . files)
(let ((js (parameterize ((generate-sxml? (enable-sxml)))
(map (lambda (file)
( (awful-apps)))))
no-ajax: #t
title: "Awful reloaded applications"))
(define (development-mode-actions)
(print "Awful is running in development mode.")
(debug-log (current-error-port))
;; Print the call chain, the error message and links to the
;; web-repl and session-inspector (if enabled)
(page-exception-message
(lambda (exn)
(let* ((sxml? (or (generate-sxml?) (enable-sxml)))
(++* (if sxml? (lambda args (apply append (map list args))) ++))
(null (if sxml? '() "")))
(++* (
convert-to-entities?: #t
(with-output-to-string
(lambda ()
(print-call-chain)
(print-error-message exn))))
(