Feufochmar
/
feuforeve.v4
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Change weblets parameters and add a website description syntax for building and loading the website inside the webcontainer

This commit is contained in:
Feufochmar 2019-11-07 15:09:19 +01:00
parent 9d3d4a38b3
commit 6fc48835fc
5 changed files with 182 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
main.rkt
View File

@ -9,23 +9,38 @@
(require
"src/webcontainer/webcontainer.rkt")
(require
"src/webcontainer/weblets.rkt")
"src/webcontainer/weblets.rkt"
"src/webcontainer/weblet-parameter.rkt"
"src/webcontainer/website.rkt")
;; Main entry point, executed when run with the `racket` executable or DrRacket.
(define *webcontainer* (make-webcontainer))
(webcontainer-add-weblet!
*webcontainer*
"/"
(define *home-page*
(html-page-weblet
#:body '(html (body (h1 "Hello World")))))
(webcontainer-add-matching-weblet!
*webcontainer*
"/{name}"
(define *hello-page*
(html-page-weblet
#:body (lambda (req params)
`(html (body (h1 "Hello " ,(hash-ref params 'name)))))))
#:body (lambda (param)
`(html (body (h1 "Hello " ,(hash-ref (weblet-parameter-match param) 'name)))))))
; Website
(define *website*
(website
"" weblet *home-page* "Home" #t
("hello/{name}" matching-weblet *hello-page* "Hello" #f)))
; Webcontainer
(define *webcontainer* (make-webcontainer))
(webcontainer-add-website! *webcontainer* *website*)
(webcontainer-set-404-weblet!
*webcontainer*
(html-page-weblet
#:body '(html (body (h1 "Sorry") (p "Nothing found here")))))
(display "Starting server...")(newline)
(webcontainer-start *webcontainer*))
;(website
; "" weblet home-page "Home" #t
; ("ToyCatCreator" redirection "http://beleth.pink" "Toy Cat Creator" #f)
; ("About" weblet about-me-page "About me" #t)
; ("Fonts" weblet fonts-page "Fonts" #t)
; ("FlagGenerator" weblet flag-generator-page "Flag Generator" #t
; ("RawFlag" weblet flag-generator-raw-page "Flag Generator (Raw SVG)" #t)
; ("About" weblet about-flag-generator-page "About the Flag Generator" #t))
; )

88
src/webcontainer/webcontainer.rkt
View File

@ -14,6 +14,8 @@
web-server/http/redirect
web-server/http/request-structs
"../collection/tree.rkt"
"weblet-parameter.rkt"
"website.rkt"
)
(provide
@ -21,10 +23,11 @@
webcontainer-start
webcontainer-add-weblet! webcontainer-set-404-weblet!
webcontainer-add-symlink! webcontainer-add-redirection!
webcontainer-add-matching-weblet!)
webcontainer-add-matching-weblet!
webcontainer-add-website!)
; webcontainer - a webserver to run weblets
; A weblet is a procedure taking a request parameter and returning a response
; 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
@ -37,8 +40,8 @@
not-found-dispatcher ; Dispatcher for not found elements
))
; Helper: Make a servlet running a weblet
(define (weblet->servlet function)
; Helper: Make a servlet
(define (make-servlet function)
(make-stateless.servlet
"."
default-stuffer
@ -135,20 +138,42 @@
(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
(weblet->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
(weblet->servlet
(make-servlet
(lambda (req)
(let* ((path (url->path (request-uri req)))
(weblet-params (get-matching matching-weblets path)))
((car weblet-params) req (cdr weblet-params))))))
((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
@ -163,13 +188,13 @@
(let ((path (url->path url)))
(cond
((hash-has-key? redirections path) redirection-servlet)
((hash-has-key? symlinks path) (hash-ref weblets (hash-ref symlinks path)))
((hash-has-key? weblets path) (hash-ref weblets path))
((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)
(hash-ref weblets 404))
not-found-servlet)
)))
; Start the server - do not return
@ -177,40 +202,46 @@
(serve
#:dispatch
(sequencer:make
(servlet:make (webcontainer-dispatcher wcontainer)) ; Servlet dispatcher
(files:make #:url->path (make-url->path (string->path (webcontainer-static wcontainer)))) ; File dispatcher, search in the static directory for files
(servlet:make (webcontainer-dispatcher wcontainer)) ; Servlet dispatcher
(servlet:make (webcontainer-not-found-dispatcher wcontainer)) ; 404 error servlet
)
#: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)
(string-split path "/")
(weblet->servlet weblet)))
(clean-path path)
weblet))
; Set the 404 error page weblet
(define (webcontainer-set-404-weblet! wcontainer weblet)
(hash-set!
(webcontainer-weblets wcontainer)
404
(weblet->servlet weblet)))
weblet))
; Add an internal redirection: the link given refer to another weblet
(define (webcontainer-add-symlink! wcontainer from to)
(hash-set!
(webcontainer-symlinks wcontainer)
(string-split from "/")
(string-split to "/")))
(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)
(string-split from "/")
(clean-path from)
to))
; Matching weblet: the path contain parameters to extract when matching
@ -224,5 +255,26 @@
(string->symbol
(substring x 1 (- (string-length x) 1)))
x))
(string-split path "/"))
(clean-path path))
weblet))
; Add a full website to the webcontainer
(define (webcontainer-add-website! wcontainer wsite [parent-path ""])
(define path (string-append parent-path "/" (website-node-url wsite)))
(define type (website-node-type wsite))
(define weblet (website-node-weblet wsite))
(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 (node)
(webcontainer-add-website! wcontainer node path))
(website-node-children wsite)))

22
src/webcontainer/weblet-parameter.rkt Normal file
View File

@ -0,0 +1,22 @@
#lang racket/base
(provide
make-weblet-parameter
weblet-parameter-request
weblet-parameter-path
weblet-parameter-match)
; weblet-parameter
; Contains: the request, the path of the request and a hash of matching parameters in the path
(struct weblet-parameter
(request ; HTTP request
path ; path called for the request, as a list of strings
match ; hash used in paramters
))
; Constructor
(define (make-weblet-parameter #:request request #:path path #:match [match (make-hash)])
(weblet-parameter
request
path
match))

77
src/webcontainer/weblets.rkt
View File

@ -13,17 +13,10 @@
html-page-weblet)
; Apply or return - If value is a procedure, apply it to the request, or else return value
(define apply-or-return
(case-lambda
((value request)
(if (procedure? value)
(value request)
value))
((value request params)
(if (procedure? value)
(value request params)
value))
))
(define (apply-or-return value param)
(if (procedure? value)
(value param)
value))
; Weblet to return raw data
(define (raw-data-weblet
@ -32,26 +25,14 @@
#:error-code [error-code 200] ; page error code
#:headers [headers (list)] ; headers of the response, or a procedure taking the request and returning the list of headers
)
(case-lambda
; Standard weblets
((req)
(response/full
error-code (http-message error-code)
(current-seconds)
content-type
(apply-or-return headers req)
(list
(apply-or-return body req))))
; Matching weblets
((req param)
(response/full
error-code (http-message error-code)
(current-seconds)
content-type
(apply-or-return headers req param)
(list
(apply-or-return body req param))))
))
(lambda (param)
(response/full
error-code (http-message error-code)
(current-seconds)
content-type
(apply-or-return headers param)
(list
(apply-or-return body param)))))
; Weblet to return html data
(define (html-page-weblet
@ -59,27 +40,13 @@
#:error-code [error-code 200] ; page error code
#:headers [headers (list)] ; headers of the response, or a procedure taking the request and returning the list of headers
)
(case-lambda
; Standard weblets
((req)
(response/full
error-code (http-message error-code)
(current-seconds)
TEXT/HTML-MIME-TYPE
(apply-or-return headers req)
(list
(string->bytes/utf-8
(xexpr->string
(apply-or-return body req))))))
; Matching weblets
((req param)
(response/full
error-code (http-message error-code)
(current-seconds)
TEXT/HTML-MIME-TYPE
(apply-or-return headers req param)
(list
(string->bytes/utf-8
(xexpr->string
(apply-or-return body req param))))))
))
(lambda (param)
(response/full
error-code (http-message error-code)
(current-seconds)
TEXT/HTML-MIME-TYPE
(apply-or-return headers param)
(list
(string->bytes/utf-8
(xexpr->string
(apply-or-return body param)))))))

43
src/webcontainer/website.rkt Normal file
View File

@ -0,0 +1,43 @@
#lang racket/base
; An helper to fill a webcontainer with weblets
; Also provides a way to store the website map for use in weblets
(provide
website
website-node-name
website-node-url
website-node-type
website-node-weblet
website-node-displayed?
website-node-children
website-root set-website-root!)
(define *website-root* #f)
(define (set-website-root! map)
(set! *website-root* map))
(define (website-root)
*website-root*)
; Values in the site map tree
(struct website-node
(name ; name of the link
url ; the partial url of the link, relative to parent
type ; the type of weblet
weblet ; the weblet associated (or a link for symlinks and redirections)
displayed? ; indicate if a link to the page should be displayed
children ; children of the node
))
; website syntax to build a site map
(define-syntax website
(syntax-rules ()
((website path type weblet name displayed? (childparam ...) ...)
(website-node
name
path
(quote type)
weblet
displayed?
(list
(website childparam ...)
...)))))