From: Christopher Allan Webber Date: Sat, 12 Dec 2015 02:10:30 +0000 (-0600) Subject: Adding absolute basic webdev environment X-Git-Tag: v0.1.0~20 X-Git-Url: https://jxself.org/git/?p=8sync.git;a=commitdiff_plain;h=c4732ac1753554c61613b906166efe6ace38200a Adding absolute basic webdev environment Incomplete, but running * 8sync/system/web.scm: New file * demos/hello-web.scm: New demo file * Makefile.am: Adding files --- diff --git a/8sync/systems/web.scm b/8sync/systems/web.scm new file mode 100644 index 0000000..2dcaf51 --- /dev/null +++ b/8sync/systems/web.scm @@ -0,0 +1,176 @@ +#!/usr/bin/guile \ +-e main -s +!# + +;;; 8sync --- Asynchronous programming for Guile +;;; Copyright (C) 2015 Christopher Allan Webber +;;; +;;; This file is part of 8sync. +;;; +;;; 8sync is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; 8sync is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with 8sync. If not, see . + +;; This is a very preliminary web module. + +(define-module (8sync systems web) + #:use-module (web server) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:use-module (8sync agenda) + #:use-module (8sync repl) + #:use-module (ice-9 receive) + #:use-module (ice-9 match) + #:export (http-server-socket + receive-http-conn + simple-webdemo + make-web-demo-cli)) + +(define (hello-world-handler request request-body) + (values '((content-type . (text/plain))) + "Hello world!")) + +(define* (http-server-socket #:key + (host #f) + (family AF_INET) + (addr (if host + (inet-pton family host) + INADDR_LOOPBACK)) + (port 8080) + (socket + ((@@ (web server http) make-default-socket) + family addr port))) + (listen socket 128) + ;;; This is used in Guile's http server under the commit: + ;;; commit a0ad8ad16c14adbf13e0ead3dafd833fb3c8f0d3 + ;;; Author: Andy Wingo + ;;; Date: Mon Nov 29 13:00:43 2010 +0100 + ;;; + ;;; http web server impl ignores SIGPIPE + ;;; + ;;; * module/web/server/http.scm (http-open): Ignore SIGPIPE. Keeps the + ;;; server from dying in some circumstances. + ;; (sigaction SIGPIPE SIG_IGN) + ;;; Will this break other things that use pipes for us though? + + ;; Throw a system-error rather than block on an (accept) + ;; that has nothing to do + (fcntl socket F_SETFL + (logior O_NONBLOCK + (fcntl socket F_GETFL))) + socket) + + +(define* (accept-connection-gracefully socket #:key complain) + "Try to accept a connection, but if there's nothing there, +don't totally failboat" + (catch 'system-error + (lambda () (accept socket)) + ;; Maybe should catch the more specific error: + ;; (system-error "accept" "~A" ("Resource temporarily unavailable") (11)) + (lambda args + (if complain + (display "Gracefully handled no connection to accept\n" + (current-error-port))) + #f))) + +(define (receive-http-conn handler) + (lambda (server-socket) + (let ((conn-pair (accept-connection-gracefully + server-socket #:complain #t))) + (match conn-pair + ((client-conn . socket-address) + (define (close-and-dequeue) + (close client-conn) + (%8sync-port-remove client-conn)) + + (catch + #t + (lambda () + (let* ((request (read-request client-conn)) + (request-body (read-request-body request))) + (call-with-values + (lambda () + (call-with-values + (lambda () + ;; @@: Is it useful to wrap this in %8sync-run? + ;; It's more indirection but might give breathing + ;; room to other requests... + (handler request request-body)) + (lambda return-values + (match return-values + ((response response-body) + (sanitize-response request response response-body)) + (_ (throw 'invalid-http-response + "Expected values of (response response-body) but didn't get 'em" + return-values)))))) + (lambda (response response-body) + (begin + (write-response-body + (write-response response client-conn) + response-body) + ;; TODO: We might NOT want to close here! + ;; Eg, keep-alive requests. See keep-alive? in guile's + ;; (@@ (web server http) http-write) + (close-and-dequeue)))))) + (lambda (key . args) + (display ":(\n") + (close-and-dequeue) + ;; re-raise exception + (apply throw key args)))) + ;; If we get a #f back, there was nothing to do + (#f #f))))) + +(define (install-http-socket socket handler) + (make-port-request socket #:read (receive-http-conn handler))) + +;; Kinda junky since dynamic-wind and delimited continuations +;; seem to not really get along... + +(define-syntax-rule (with-socket-as make-socket socket-name + body ...) + (let ((socket-name make-socket)) + (dynamic-wind + (const #f) + (lambda () + body ...) + (lambda () + (close socket-name))))) + +(define default-handler (wrap-apply hello-world-handler)) + +(define* (run-simple-webserver #:key + (handler default-handler) + (coop-repl #f)) + (display "Running on http://127.0.0.1:8080/\n") + (with-socket-as + (http-server-socket) server-socket + (let* ((q (make-q* + (wrap (install-http-socket server-socket + handler)))) + (agenda (make-agenda + #:queue q + #:pre-unwind-handler print-error-and-continue))) + ;; (if coop-repl + ;; (spawn-and-queue-repl-server! agenda)) + (start-agenda agenda)))) + +(define* (make-web-demo-cli #:key + (listen #t) + (handler default-handler)) + (define (main args) + (run-simple-webserver #:coop-repl listen + #:handler handler)) + main) + +(define main (make-web-demo-cli)) diff --git a/Makefile.am b/Makefile.am index 5b4705b..e1132ea 100644 --- a/Makefile.am +++ b/Makefile.am @@ -47,7 +47,8 @@ godir=$(libdir)/guile/2.0/ccache SOURCES = \ 8sync/agenda.scm \ 8sync/repl.scm \ - 8sync/systems/irc.scm + 8sync/systems/irc.scm \ + 8sync/systems/web.scm TESTS = \ @@ -71,7 +72,8 @@ EXTRA_DIST = \ pre-inst-env.in \ tests/utils.scm \ demos/run-demo.sh \ - demos/ircbot.scm + demos/ircbot.scm \ + demos/hello-web.scm ## Make changelog on demand diff --git a/demos/hello-web.scm b/demos/hello-web.scm new file mode 100755 index 0000000..af8bd9d --- /dev/null +++ b/demos/hello-web.scm @@ -0,0 +1,73 @@ +#!/usr/bin/guile \ +-e main -s +!# + +;;; 8sync --- Asynchronous programming for Guile +;;; Copyright (C) 2015 Christopher Allan Webber +;;; +;;; This file is part of 8sync. +;;; +;;; 8sync is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; 8sync is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with 8sync. If not, see . + +(use-modules (8sync systems web) + (8sync agenda) + (web request) + (web response) + (web uri) + (ice-9 match)) + + +;;; Utilities +;;; ========= + +(define (simple-404 request request-body) + (values (build-response + #:code 404 + #:headers '((content-type . (text/plain)))) + "Not found. Dag, yo.")) + + + +;;; Views +;;; ===== + +(define (hello-world-view request request-body) + (values '((content-type . (text/plain))) + "Hello world!")) + + + +;;; Dispatch / routing +;;; ================== + +(define (web-dispatch request request-body) + (define (call-view view) + (view request request-body)) + ;; URI routing here + (match (split-and-decode-uri-path (uri-path (request-uri request))) + ;; This is for the `/' root + (() (call-view hello-world-view)) + ;; An example of an inline view at `/pants/' + (("pants") + (values '((content-type . (text/plain))) + "Hello pants!")) + (_ + (call-view simple-404)))) + + + +;;; CLI +;;; === + +(define main (make-web-demo-cli #:handler (wrap-apply web-dispatch)))