From d1456cd16e0e73bee94110430cbb5f7ee97ed461 Mon Sep 17 00:00:00 2001 From: Nikolay Puzanov Date: Wed, 30 Nov 2022 13:10:58 +0300 Subject: [PATCH] Parameterize playground server --- _web_server/index.html | 4 +- _web_server/playground-server.scm | 174 +++++++++++++++++++++--------- 2 files changed, 122 insertions(+), 56 deletions(-) diff --git a/_web_server/index.html b/_web_server/index.html index 70a66ef..02f27cb 100644 --- a/_web_server/index.html +++ b/_web_server/index.html @@ -72,11 +72,9 @@ endmodule enableBasicAutocompletion : true, enableLiveAutocompletion : true }); - const log_area = document.getElementById('log'); - function send_to_icarus() { - fetch('http://localhost:8080/icarus', + fetch('%POSTURI%', { method: 'POST', headers: { diff --git a/_web_server/playground-server.scm b/_web_server/playground-server.scm index 15626bc..2514e4f 100755 --- a/_web_server/playground-server.scm +++ b/_web_server/playground-server.scm @@ -5,6 +5,7 @@ (import (srfi srfi-1) (srfi srfi-11) + (srfi srfi-26) (srfi srfi-28) (rnrs bytevectors) (web server) @@ -20,8 +21,8 @@ (import (embddr common) (embddr optargs)) -(define MAIN-PAGE "index.html") -(define LOGGING #f) +(define INDEX-FILE "index.html") +(define LOGGING #t) (define (multistring . strings) (apply string-append @@ -61,7 +62,8 @@ (define (printlog . rest) (when LOGGING - (display (apply format rest)))) + (display (apply format rest)) + (newline))) ;;; ;;; Return directory list @@ -105,6 +107,14 @@ (reverse (list-trim (cdr lr) pred)) l))))) +;;; +;;; Read template to string +;;; +(define (read-template-text file subst) + (let ((lines (read-template file "%~a%" subst))) + (apply string-append + (append-map (cut list <> "\n") lines)))) + ;;; ;;; Execute system command and capture stdout and stderr to string list ;;; @@ -115,18 +125,21 @@ (out (get-string-all p))) (values (close-pipe p) out))) -(define* (system-to-string-list cmd #:key (pwd #f)) - (let-values (((status out) - (system-to-string cmd #:pwd pwd))) - (values - status - (list-trim (string-split out #\newline) string-null?)))) +;;; +;;; Unused +;;; +;; (define* (system-to-string-list cmd #:key (pwd #f)) +;; (let-values (((status out) +;; (system-to-string cmd #:pwd pwd))) +;; (values +;; status +;; (list-trim (string-split out #\newline) string-null?)))) -(define (iverilog-cmd base) - (format "iverilog -DTESTBENCH -g2012 -o ~a/testbench.vvp ~a/testbench.sv" base base)) +;; (define (iverilog-cmd base) +;; (format "iverilog -DTESTBENCH -g2012 -o ~a/testbench.vvp ~a/testbench.sv" base base)) -(define (vvp-cmd base) - (format "vvp ~a/testbench.vvp" base)) +;; (define (vvp-cmd base) +;; (format "vvp ~a/testbench.vvp" base)) ;;; ;;; Trivial sanitize verilog code @@ -248,49 +261,104 @@ ;;; ;;; Web page handler ;;; -(define (page-handler request request-body) - (let ((path (split-and-decode-uri-path - (uri-path - (request-uri request))))) - (printlog "-- PATH: ~a\n" path) +(define (make-page-handler host root index-file) + (let* ((root-path (split-and-decode-uri-path root)) + (sim-path (append root-path '("simulate"))) + (post-uri (string-append host "/" (encode-and-join-uri-path sim-path))) + (index-html (read-template-text index-file `(("POSTURI" ,post-uri))))) - (cond - ;; Editor javascript files - ;; ((and (> (length path) 2) - ;; (equal? (take path 2) '("ace-builds" "src-min-noconflict")) - ;; (string-match "^[a-z_-]+\\.js$" (third path))) - ;; (guard (not-found request) - ;; (let* ((file-path (canonicalize-path - ;; (apply - ;; string-append - ;; (insert-between (cons "." path) - ;; file-name-separator-string)))) - ;; (file-stat (stat file-path))) - ;; (if (and (eq? (stat:type file-stat) 'regular) - ;; (not (zero? (logand (stat:mode file-stat) #o444)))) - ;; (begin - ;; (printlog "-- Request file '~a'\n" file-path) - ;; (file-response file-path #:type 'text/javascript)) - ;; (not-found request))))) + (lambda (request request-body) + (let ((path (split-and-decode-uri-path + (uri-path + (request-uri request))))) + (printlog "-- PATH: ~a" path) - ;; Icarus - ((equal? path '("icarus")) - (printlog "-- Request icarus\n") - (let ((log (execute-icarus - (sanitize-verilog - (utf8->string request-body))))) - (make-response log #:type 'text/plain))) + (cond + ;; Editor javascript files + ;; ((and (> (length path) 2) + ;; (equal? (take path 2) '("ace-builds" "src-min-noconflict")) + ;; (string-match "^[a-z_-]+\\.js$" (third path))) + ;; (guard (not-found request) + ;; (let* ((file-path (canonicalize-path + ;; (apply + ;; string-append + ;; (insert-between (cons "." path) + ;; file-name-separator-string)))) + ;; (file-stat (stat file-path))) + ;; (if (and (eq? (stat:type file-stat) 'regular) + ;; (not (zero? (logand (stat:mode file-stat) #o444)))) + ;; (begin + ;; (printlog "-- Request file '~a'" file-path) + ;; (file-response file-path #:type 'text/javascript)) + ;; (not-found request))))) - ;; Index page - ((null? path) - (printlog "-- Request index page\n") - (make-response MAIN-PAGE)) + ;; Icarus + ((equal? path sim-path) + (printlog "-- Request simulate") + (let ((log (execute-icarus + (sanitize-verilog + (utf8->string request-body))))) + (make-response log #:type 'text/plain))) - ;; Unknown - (else - (printlog "-- Request wrong path\n") - (not-found request))))) + ;; Index page + ((equal? path root-path) + (printlog "-- Request index page") + (make-response index-html)) + + ;; Unknown + (else + (printlog "-- Request wrong path") + (not-found request))))))) + + +;;; +;;; ---------------------------------------------------------------------- +;;; ------------------------------- MAIN --------------------------------- +;;; ---------------------------------------------------------------------- +;;; + +(define (print-help app-name) + (define (-> . args) + (display (apply format args) (current-error-port)) + (newline (current-error-port))) + (let ((app-name (basename app-name))) + (with-output-to-port (current-error-port) + (lambda () + (-> "Usage: ~a [OPTION]..." app-name) + (-> "Start Verilog playground WEB server") + (-> "") + (-> "Options:") + (-> " -a, --addr ADDR Listen on ADDR address. Default: 127.0.0.1") + (-> " -p, --port PORT Listen on PORT port. Default: 8080") + (-> " -s, --host URL Run on URL hostname. Default: http://127.0.0.1:8080") + (-> " -r, --root URN Service location root. Default: ''") + (-> " -h, --help Print this message and exit") + (-> "") + (-> "Source code and issue tracker: "))))) (define (main args) - (set! MAIN-PAGE (call-with-input-file MAIN-PAGE get-string-all)) - (run-server page-handler)) + (debug-disable 'backtrace) + (let-values + (((opts rest err) + (parse-opts (cdr args) + '(#\a addr required) + '(#\p port required) + '(#\s host required) + '(#\r root required) + '(#\h help none)))) + (let ((addr (string-trim (or (option-get opts 'addr) "127.0.0.1"))) + (port (string->number (string-trim (or (option-get opts 'port) "8080")))) + (host (string-trim (or (option-get opts 'host) "http://127.0.0.1:8080"))) + (root (string-trim (or (option-get opts 'root) "")))) + + (if (option-get opts 'help) + (begin + (print-help (car args)) + (exit -1)) + (begin + (printlog "Listen on '~a' port '~a'" addr port) + (printlog "Server URL: '~a/~a'" host root) + + (run-server + (make-page-handler host root INDEX-FILE) + 'http `(#:host ,addr #:port ,port)))))))