288 lines
9.2 KiB
Racket
288 lines
9.2 KiB
Racket
#lang racket/base
|
|
(require
|
|
racket/string
|
|
net/url
|
|
web-server/web-server
|
|
web-server/dispatchers/filesystem-map
|
|
web-server/dispatchers/dispatch
|
|
(prefix-in servlet: web-server/dispatchers/dispatch-servlets)
|
|
(prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
|
|
(prefix-in files: web-server/dispatchers/dispatch-files)
|
|
web-server/servlet/setup
|
|
web-server/stuffers
|
|
web-server/managers/none
|
|
web-server/http/redirect
|
|
web-server/http/request-structs
|
|
web-server/private/mime-types
|
|
"../collection/tree.rkt"
|
|
"weblet-parameter.rkt"
|
|
"website.rkt"
|
|
)
|
|
|
|
(provide
|
|
make-webcontainer
|
|
webcontainer-start
|
|
webcontainer-add-weblet! webcontainer-set-404-weblet!
|
|
webcontainer-add-symlink! webcontainer-add-redirection!
|
|
webcontainer-add-matching-weblet!
|
|
webcontainer-add-website!)
|
|
|
|
; webcontainer - a webserver to run weblets
|
|
; A weblet is a procedure taking a weblet-parameter and returning a response
|
|
(struct webcontainer
|
|
(server-port ; Port to listen
|
|
server-address ; Address to listen
|
|
static ; Path to non-dynamic assets
|
|
weblets ; weblets - dynamic pages
|
|
symlinks ; symlinks for path linking to another weblet
|
|
redirections ; redirections for path going to another website
|
|
matching-weblets ; like weblets, but extract parameters from the url
|
|
dispatcher ; servlet dispatcher
|
|
not-found-dispatcher ; Dispatcher for not found elements
|
|
))
|
|
|
|
; Helper: Make a servlet
|
|
(define (make-servlet function)
|
|
(make-stateless.servlet
|
|
"."
|
|
default-stuffer
|
|
(create-none-manager #f)
|
|
function))
|
|
|
|
; Helper: convert to a string list path, remove the empty elements in the path
|
|
(define (url->path url)
|
|
(filter
|
|
non-empty-string?
|
|
(map
|
|
path/param-path
|
|
(url-path url))))
|
|
|
|
; Helper: check if the path match an element in the tree
|
|
(define (has-matching? tr path)
|
|
(not (not (get-matching tr path))))
|
|
|
|
; Helper: produce a pair of weblet and hash table of params
|
|
(define (make-weblet-params weblet params)
|
|
(let ((hparams (make-hash)))
|
|
(if weblet
|
|
(begin
|
|
(for-each
|
|
(lambda (x)
|
|
(hash-set! hparams (car x) (cdr x)))
|
|
params)
|
|
(cons weblet hparams))
|
|
#f)))
|
|
|
|
; Helper: get the weblet and extracted parameters if the path match an element in the tree
|
|
(define (get-matching tr path [params (list)])
|
|
(cond
|
|
((and (eq? #f (tree-key tr)) (null? path))
|
|
; ROOT of the tree, and itself asked for
|
|
(if (tree-value tr)
|
|
(cons (tree-value tr) (make-hash))
|
|
#f))
|
|
((null? path)
|
|
; Should not happen outside the ROOT => not found...
|
|
#f)
|
|
((eq? #f (tree-key tr))
|
|
; ROOT of the tree, but not itself asked => pass to children with the same path
|
|
(let ((ret
|
|
(filter
|
|
(lambda (x) x)
|
|
(map
|
|
(lambda (x)
|
|
(get-matching x path params))
|
|
(tree-children tr)))))
|
|
(if (null? ret)
|
|
#f
|
|
(car ret))))
|
|
((and (symbol? (tree-key tr)) (null? (cdr path)))
|
|
; match pattern, node found
|
|
(make-weblet-params
|
|
(tree-value tr)
|
|
(cons (cons (tree-key tr) (car path))
|
|
params)))
|
|
((symbol? (tree-key tr))
|
|
; match pattern + check children
|
|
(let* ((p (cons (cons (tree-key tr) (car path)) params))
|
|
(ret
|
|
(filter
|
|
(lambda (x) x)
|
|
(map
|
|
(lambda (x)
|
|
(get-matching x (cdr path) p))
|
|
(tree-children tr)))))
|
|
(if (null? ret)
|
|
#f
|
|
(car ret))))
|
|
((and (equal? (tree-key tr) (car path)) (null? (cdr path)))
|
|
; Node found
|
|
(make-weblet-params (tree-value tr) params))
|
|
((equal? (tree-key tr) (car path))
|
|
; Check children
|
|
(let ((ret
|
|
(filter
|
|
(lambda (x) x)
|
|
(map
|
|
(lambda (x)
|
|
(get-matching x (cdr path) params))
|
|
(tree-children tr)))))
|
|
(if (null? ret)
|
|
#f
|
|
(car ret))))
|
|
(#t #f)
|
|
))
|
|
|
|
; Webcontainer constructor
|
|
(define (make-webcontainer #:port [port 8080] #:address [address #f] #:static [static "./static"])
|
|
(let* ((weblets (make-hash))
|
|
(symlinks (make-hash))
|
|
(redirections (make-hash))
|
|
(matching-weblets (make-tree))
|
|
; Servlet for weblets
|
|
(weblet-servlet
|
|
(make-servlet
|
|
(lambda (req)
|
|
(let* ((path (url->path (request-uri req)))
|
|
(weblet (hash-ref weblets path)))
|
|
(weblet (make-weblet-parameter #:request req #:path path))))))
|
|
; Servlet for symlinks
|
|
(symlink-servlet
|
|
(make-servlet
|
|
(lambda (req)
|
|
(let* ((path (url->path (request-uri req)))
|
|
(real-path (hash-ref symlinks path))
|
|
(weblet (hash-ref weblets real-path)))
|
|
(weblet (make-weblet-parameter #:request req #:path real-path))))))
|
|
; Servlet for redirections
|
|
(redirection-servlet
|
|
(make-servlet
|
|
(lambda (req)
|
|
(let* ((path (url->path (request-uri req)))
|
|
(to (hash-ref redirections path)))
|
|
(redirect-to to permanently)))))
|
|
; Servlet for using matching servlets
|
|
(matching-servlet
|
|
(make-servlet
|
|
(lambda (req)
|
|
(let* ((path (url->path (request-uri req)))
|
|
(weblet-params (get-matching matching-weblets path)))
|
|
((car weblet-params) (make-weblet-parameter #:request req #:path path #:match (cdr weblet-params)))))))
|
|
; Not found servlet
|
|
(not-found-servlet
|
|
(make-servlet
|
|
(lambda (req)
|
|
(let* ((path (url->path (request-uri req)))
|
|
(weblet (hash-ref weblets 404)))
|
|
(weblet (make-weblet-parameter #:request req #:path path))))))
|
|
)
|
|
(webcontainer
|
|
port
|
|
address
|
|
static
|
|
weblets
|
|
symlinks
|
|
redirections
|
|
matching-weblets
|
|
; dispatcher
|
|
(lambda (url)
|
|
(let ((path (url->path url)))
|
|
(cond
|
|
((hash-has-key? redirections path) redirection-servlet)
|
|
((hash-has-key? symlinks path) symlink-servlet)
|
|
((hash-has-key? weblets path) weblet-servlet)
|
|
((has-matching? matching-weblets path) matching-servlet)
|
|
(#t (next-dispatcher)))))
|
|
; not-found-dispatcher
|
|
(lambda (url)
|
|
not-found-servlet)
|
|
)))
|
|
|
|
; Start the server - do not return
|
|
(define (webcontainer-start wcontainer)
|
|
(serve
|
|
#:dispatch
|
|
(sequencer:make
|
|
; File dispatcher, search in the static directory for files
|
|
(files:make
|
|
#:url->path (make-url->path (string->path (webcontainer-static wcontainer)))
|
|
#:path->mime-type (make-path->mime-type "./mime.types"))
|
|
; Servlet dispatcher
|
|
(servlet:make (webcontainer-dispatcher wcontainer))
|
|
; 404 error servlet
|
|
(servlet:make (webcontainer-not-found-dispatcher wcontainer))
|
|
)
|
|
#:port (webcontainer-server-port wcontainer)
|
|
#:listen-ip (webcontainer-server-address wcontainer))
|
|
(do-not-return))
|
|
|
|
; Helper when defining a path to remove the unnecessary "/"
|
|
(define (clean-path str)
|
|
(filter
|
|
non-empty-string?
|
|
(string-split str "/")))
|
|
|
|
; Add a weblet to the container
|
|
(define (webcontainer-add-weblet! wcontainer path weblet)
|
|
(hash-set!
|
|
(webcontainer-weblets wcontainer)
|
|
(clean-path path)
|
|
weblet))
|
|
|
|
; Set the 404 error page weblet
|
|
(define (webcontainer-set-404-weblet! wcontainer weblet)
|
|
(hash-set!
|
|
(webcontainer-weblets wcontainer)
|
|
404
|
|
weblet))
|
|
|
|
; Add an internal redirection: the link given refer to another weblet
|
|
(define (webcontainer-add-symlink! wcontainer from to)
|
|
(hash-set!
|
|
(webcontainer-symlinks wcontainer)
|
|
(clean-path from)
|
|
(clean-path to)))
|
|
|
|
; Add an external redirection: the link given goes to another website
|
|
(define (webcontainer-add-redirection! wcontainer from to)
|
|
(hash-set!
|
|
(webcontainer-redirections wcontainer)
|
|
(clean-path from)
|
|
to))
|
|
|
|
; Matching weblet: the path contain parameters to extract when matching
|
|
(define (webcontainer-add-matching-weblet! wcontainer path weblet)
|
|
(tree-set!
|
|
(webcontainer-matching-weblets wcontainer)
|
|
(map
|
|
(lambda (x)
|
|
(if (and (string-prefix? x "{")
|
|
(string-suffix? x "}"))
|
|
(string->symbol
|
|
(substring x 1 (- (string-length x) 1)))
|
|
x))
|
|
(clean-path path))
|
|
weblet))
|
|
|
|
; Add a full website to the webcontainer
|
|
(define (webcontainer-add-website! wcontainer wsite [parent-path ""])
|
|
(define node (tree-value wsite))
|
|
(define path (string-append parent-path "/" (website-node-url node)))
|
|
(define type (website-node-type node))
|
|
(define weblet (website-node-weblet node))
|
|
(case type
|
|
((weblet)
|
|
(webcontainer-add-weblet! wcontainer path weblet))
|
|
((symlink)
|
|
(webcontainer-add-symlink! wcontainer path weblet))
|
|
((redirection)
|
|
(webcontainer-add-redirection! wcontainer path weblet))
|
|
((matching-weblet)
|
|
(webcontainer-add-matching-weblet! wcontainer path weblet))
|
|
(else
|
|
(error "Unexpected type: " type)))
|
|
(for-each
|
|
(lambda (child)
|
|
(webcontainer-add-website! wcontainer child path))
|
|
(tree-children wsite)))
|