Permalink
Switch branches/tags
Find file
Fetching contributors…
Cannot retrieve contributors at this time
276 lines (249 sloc) 6.05 KB
#lang scheme/base
(require scheme/match
(planet untyped/dispatch:2:=1/dispatch)
(planet jaymccarthy/with-bindings:1:=2/with-bindings)
web-server/servlet-env
web-server/dispatchers/dispatch
web-server/configuration/responders
"util.scm"
"settings.scm"
"web-export.ss"
"web-support.scm"
"record.scm"
"repository.scm"
"form.scm"
"validate.scm"
"closures.scm"
"session.scm"
"js.scm"
"user.scm"
"time.scm"
"page.scm"
"compute.scm"
"profiler.scm"
"log.scm"
"task-queue.scm"
"feed.ss"
"facebook.ss"
)
(provide
;; the work of others:
(all-from-out (planet untyped/dispatch:2:=1/dispatch))
(all-from-out (planet jaymccarthy/with-bindings:1:=2/with-bindings))
;; built-in PLT tools:
request-bindings
;; web server
serve
define-app
load-server-settings
server-log
;; core web help
web-link
wrap-each-in-list
raw-str
img
xexpr-if
url+query
url->string
get-url
;; web forms
form
validate
field-validate
form-id
form-markup
grab-user-input
;; feeds
atom-feed
atom-item
rss-feed
rss-item
;; records and the data repository
rec-prop
rec-has-prop?
rec-child-prop
rec-id
rec-data
rec-set-prop!
rec-set-each-prop!
rec-remove-prop!
rec-set-data!
rec-set-rec-prop!
rec-rec-prop
load-rec
record-id-stored?
load-where
load-children
load-descendants
contains-child?
rec-add-child!
add-child-and-save!
remove-child-and-save!
rec-add-list-prop-elt!
store-rec!
delete-rec!
fresh-rec-from-data
same-rec?
only-rec-of-type
if-rec-of-type
rec-type-is?
is-descendant?
find-parent
find-ancestor
find-highest-ancestor
find-incoming-record
find-incoming-records
rec?
sort-recs-by
define-cache
define-type-cache
;; closures
handle-closure-in-req
body-as-url
body-as-closure-key
num-closures-in-memory
make-closure-key
add-closure!
closure-key->url
;; sessions
session-put-val!
session-get-val
session-id
session-get-hash
session-replace-hash!
get-session-object
session-remove-entry!
sessioned-response
make-fresh-session
remove-session
flash-create!
flash-get!
;; response
cookied-response
list-response
;; js
js-script-invoke
js-array
js-hash
js-quote
js-call
js-call-on-load
;; html, pages, includes, etc
define-page
define-session-page
page
design
**
page-url
redirect-to-page
(rename-out (response-promise-to-redirect redirect-to))
js-inc
css-inc
versioned-file-reference
;; settings
declare-setting
setting
setting-set!
;; users
register-form
welcome-message
login-form
register-form
register-user!
make-unloginable-user!
current-user
user-in
created-by?
created-by-xexpr
created-by-user-rec
stamp-user-on-rec!
get-user-rec
authenticated-login!
unauthenticated-login!
if-these-users
if-login
when-login
logout-user!
;; time
created-when
created-when-str
days-since
hours-since
minutes-since
A_DAY
AN_HOUR
THIRTY_DAYS
seconds->time-string
;; computation
sum-recs
;; profiler
profile
define-profile
;; task queues
make-threaded-task-queue
sleep-task-thread-for-at-least
task-inspector-lock
task-inspector-num-tasks-thunk
;; facebook
facebook-fn
define-facebook-required-login-page
facebook-require-login
facebook-session-key
facebook-error
facebook-uid
facebook-form
facebook-complex-val
facebook-create-object
facebook-strict-error
)
(declare-setting *APP_VERSION* 1)
(declare-setting *PAGE_NOT_FOUND_FILE* "page-not-found.html")
(declare-setting *CATCH-EXCEPTION?* (lambda (exn) #t))
(declare-setting *EXCEPTION->XEXPR* (lambda (exn)
(if (exn:dispatcher? exn)
;; then it really just means that dispatch
;; failed to find an appropriate URL match, so we
;; need to look for static files:
(next-dispatcher)
;; otherwise, it is an actual error...
(begin
((error-display-handler)
(exn-message exn) exn)
"Error on page."))))
(define (serve web-app)
(populate-caches)
(server-log "Server is ready at ~A (ctrl-c to stop it)." (setting *WEB_APP_URL*))
(serve/servlet #:command-line? #t
#:launch-browser? #f
#:servlet-path "/"
#:server-root-path (build-path ".")
#:servlet-regexp #rx""
#:file-not-found-responder
(gen-file-not-found-responder (build-path
"htdocs"
(setting *PAGE_NOT_FOUND_FILE*)))
#:listen-ip (setting *LISTEN_IP*)
#:port (setting *PORT*)
(lambda (req)
(let ((catch? (setting *CATCH-EXCEPTION?*))
(err (setting *EXCEPTION->XEXPR*)))
(with-handlers ((catch? err))
(final-prep-of-response
(handle-closure-in-req req
(dispatch req web-app))))))))
(define-syntax define-app
(syntax-rules ()
((_ app-name
(page-name route-syntax)
...)
(begin (provide app-name page-name ...)
(define-site app-name ((route-syntax page-name) ...))))))
;; load appropriate settings file based on command line arg to server script
(define (load-server-settings #:envo (envo #f))
(load (string-append "settings-"
(or envo
(let ((args (current-command-line-arguments)))
(if (= (vector-length args) 0)
"localhost"
(vector-ref args 0))))
".scm")))