luvcraft/web-server.lisp
in-package#:luvcraft.web
defclassweb-response
status:initarg:status:readerweb-response-status
content-type:initarg:content-type:readerweb-response-content-type
body:initarg:body:readerweb-response-body
defunmake-web-response
statuscontent-typebody
defunok-response
content-typebody
defunnot-found-response
defunmake-web-application
&restpages
defgenericrespond-to-web-request
receiverpath
:documentation
Return a web-response for path from a web application or mounted page.
defunhtml-escaped
string
with-output-to-string
output
loopforcharacteracrossstringdo
casecharacter
#\&
write-string"&"output
#\<
write-string"<"output
#\>
write-string">"output
#\"
write-string"""output
otherwise
write-charcharacteroutput
defunapplication-index
application
with-output-to-string
output
formatoutput"<!doctype html>~%"
formatoutput"<html lang=\"en\"><head><meta charset=\"utf-8\">~%"
formatoutput"<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">~%"
formatoutput"<title>Luvcraft</title><style>~%"
formatoutput":root { color-scheme: dark; font-family: ui-monospace, SFMono-Regular, monospace; background: #10130f; color: #ecf0df }~%"
formatoutput"body { margin: 0; min-height: 100vh; display: grid; place-items: center; background: radial-gradient(circle at 70% 20%, #29352b, #10130f 55%) }~%"
formatoutput"main { width: min(42rem, calc(100% - 3rem)); padding: 4rem 0 } p { color: #aeb9a8; line-height: 1.6 }~%"
formatoutput"ul { padding: 0; display: grid; gap: 1rem } li { list-style: none } a { display: block; padding: 1.25rem; border: 1px solid #49584a; color: inherit; text-decoration: none; background: #171d17cc }~%"
formatoutput"a:hover { border-color: #d49b68; transform: translateY(-1px) } strong { display: block; color: #f2c28f; margin-bottom: .4rem }~%"
formatoutput"</style></head><body><main><p>LUVCRAFT / WEB</p><h1>Little windows into the world.</h1><ul>~%"
dolist
page
web-application-pagesapplication
formatoutput"<li><a href=\"~A/\"><strong>~A</strong>~A</a></li>~%"
html-escaped
web-page-pathpage
html-escaped
web-page-labelpage
html-escaped
web-page-descriptionpage
formatoutput"</ul></main></body></html>~%"
defmethodrespond-to-web-request
applicationweb-application
pathdefunresponse-octet-length
string
length
sb-ext:string-to-octetsstring:external-format:utf-8
defunwrite-http-response
streamresponse
formatstream"HTTP/1.1 ~A~C~C"
web-response-statusresponse
#\Return#\Linefeedformatstream"Content-Type: ~A~C~C"
web-response-content-typeresponse
#\Return#\Linefeedformatstream"Content-Length: ~D~C~C"
response-octet-length
#\Return#\Linefeedweb-response-bodyresponse
formatstream"Cache-Control: no-store~C~C"#\Return#\Linefeed
formatstream"Connection: close~C~C~C~C"#\Return#\Linefeed#\Return#\Linefeed
write-string
web-response-bodyresponse
streamfinish-outputstream
defunbounded-read-line
streamlimit
defundiscard-http-headers
stream
defunrequest-path
request-line
let
whenfirst-space
setfsecond-space
unless
error"Only a well-formed GET request is supported."
let*
target
subseqrequest-line
1+first-space
second-spacequery
subseqtarget0query
defunserve-web-request
clientapplication
let
stream
sb-bsd-sockets:socket-make-streamclient:inputt:outputt:element-type'character:buffering:full:external-format:utf-8
unwind-protect
handler-case
error
condition
format*error-output*"luvcraft web request failed: ~A~%"condition
ignore-errors
write-http-responsestream
ignore-errors
closestream
ignore-errors
sb-bsd-sockets:socket-closeclient
defunipv4-address
host
sb-bsd-sockets:host-ent-address
sb-bsd-sockets:get-host-by-namehost
defunserve-web-application
application&key
host"127.0.0.1"
port8765
Serve application on a small blocking HTTP/1.1 loop until interrupted.
let
socket
make-instance'sb-bsd-sockets:inet-socket:type:stream:protocol:tcp
unwind-protect
progn
setf
sb-bsd-sockets:sockopt-reuse-addresssocket
tsb-bsd-sockets:socket-listensocket16
formatt"luvcraft web: http://~A:~D/~%"hostport
finish-output
handler-case
sb-sys:interactive-interrupt
formatt"Stopping luvcraft web.~%"
ignore-errors
sb-bsd-sockets:socket-closesocket
defclass web-page
A semantic page mounted at one URL subtree.
defgeneric respond-to-web-request
(receiver path)Return a WEB-RESPONSE for PATH from a web application or mounted page.
defun make-web-response
(status content-type body)defun ok-response
(content-type body)defun make-web-application
(&rest pages)defun page
(&optional (text *page*) (name "test"))defun html-escaped
(string)defun application-index
(application)defun page-relative-path
(page path)define-arithmetic-operator and
Logical conjunction of tests and raw truth values.
define-arithmetic-operator >
Test whether one compatible scalar is greater than another.
define-arithmetic-operator or
Logical disjunction of tests and raw truth values.
define-arithmetic-operator =
Test whether two compatible scalars are equal.
defun response-octet-length
(string)defun write-http-response
(stream response)defun bounded-read-line
(stream limit)defun discard-http-headers
(stream)defun request-path
(request-line)defun serve-web-request
(client application)defun ipv4-address
(host)defun serve-web-application
(application &key (host "127.0.0.1") (port 8765))
The deliberately small HTTP and page protocol for the luvcraft web site.
A
web-pageowns oneurlsubtree. Adding a page means adding an object and arespond-to-web-requestmethod, rather than growing the socket server's knowledge of gallery assets, shader URLs, or future instruments.