Parameterize playground server
This commit is contained in:
Nikolay Puzanov
parent
fa81d386f1
commit
d1456cd16e
@ -72,11 +72,9 @@ endmodule
|
|||||||
enableBasicAutocompletion : true,
|
enableBasicAutocompletion : true,
|
||||||
enableLiveAutocompletion : true
|
enableLiveAutocompletion : true
|
||||||
});
|
});
|
||||||
|
|
||||||
const log_area = document.getElementById('log');
|
const log_area = document.getElementById('log');
|
||||||
|
|
||||||
function send_to_icarus() {
|
function send_to_icarus() {
|
||||||
fetch('http://localhost:8080/icarus',
|
fetch('%POSTURI%',
|
||||||
{
|
{
|
||||||
method: 'POST',
|
method: 'POST',
|
||||||
headers: {
|
headers: {
|
||||||
|
|||||||
@ -5,6 +5,7 @@
|
|||||||
|
|
||||||
(import (srfi srfi-1)
|
(import (srfi srfi-1)
|
||||||
(srfi srfi-11)
|
(srfi srfi-11)
|
||||||
|
(srfi srfi-26)
|
||||||
(srfi srfi-28)
|
(srfi srfi-28)
|
||||||
(rnrs bytevectors)
|
(rnrs bytevectors)
|
||||||
(web server)
|
(web server)
|
||||||
@ -20,8 +21,8 @@
|
|||||||
(import (embddr common)
|
(import (embddr common)
|
||||||
(embddr optargs))
|
(embddr optargs))
|
||||||
|
|
||||||
(define MAIN-PAGE "index.html")
|
(define INDEX-FILE "index.html")
|
||||||
(define LOGGING #f)
|
(define LOGGING #t)
|
||||||
|
|
||||||
(define (multistring . strings)
|
(define (multistring . strings)
|
||||||
(apply string-append
|
(apply string-append
|
||||||
@ -61,7 +62,8 @@
|
|||||||
|
|
||||||
(define (printlog . rest)
|
(define (printlog . rest)
|
||||||
(when LOGGING
|
(when LOGGING
|
||||||
(display (apply format rest))))
|
(display (apply format rest))
|
||||||
|
(newline)))
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Return directory list
|
;;; Return directory list
|
||||||
@ -105,6 +107,14 @@
|
|||||||
(reverse (list-trim (cdr lr) pred))
|
(reverse (list-trim (cdr lr) pred))
|
||||||
l)))))
|
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
|
;;; Execute system command and capture stdout and stderr to string list
|
||||||
;;;
|
;;;
|
||||||
@ -115,18 +125,21 @@
|
|||||||
(out (get-string-all p)))
|
(out (get-string-all p)))
|
||||||
(values (close-pipe p) out)))
|
(values (close-pipe p) out)))
|
||||||
|
|
||||||
(define* (system-to-string-list cmd #:key (pwd #f))
|
;;;
|
||||||
(let-values (((status out)
|
;;; Unused
|
||||||
(system-to-string cmd #:pwd pwd)))
|
;;;
|
||||||
(values
|
;; (define* (system-to-string-list cmd #:key (pwd #f))
|
||||||
status
|
;; (let-values (((status out)
|
||||||
(list-trim (string-split out #\newline) string-null?))))
|
;; (system-to-string cmd #:pwd pwd)))
|
||||||
|
;; (values
|
||||||
|
;; status
|
||||||
|
;; (list-trim (string-split out #\newline) string-null?))))
|
||||||
|
|
||||||
(define (iverilog-cmd base)
|
;; (define (iverilog-cmd base)
|
||||||
(format "iverilog -DTESTBENCH -g2012 -o ~a/testbench.vvp ~a/testbench.sv" base base))
|
;; (format "iverilog -DTESTBENCH -g2012 -o ~a/testbench.vvp ~a/testbench.sv" base base))
|
||||||
|
|
||||||
(define (vvp-cmd base)
|
;; (define (vvp-cmd base)
|
||||||
(format "vvp ~a/testbench.vvp" base))
|
;; (format "vvp ~a/testbench.vvp" base))
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Trivial sanitize verilog code
|
;;; Trivial sanitize verilog code
|
||||||
@ -248,49 +261,104 @@
|
|||||||
;;;
|
;;;
|
||||||
;;; Web page handler
|
;;; Web page handler
|
||||||
;;;
|
;;;
|
||||||
(define (page-handler request request-body)
|
(define (make-page-handler host root index-file)
|
||||||
(let ((path (split-and-decode-uri-path
|
(let* ((root-path (split-and-decode-uri-path root))
|
||||||
(uri-path
|
(sim-path (append root-path '("simulate")))
|
||||||
(request-uri request)))))
|
(post-uri (string-append host "/" (encode-and-join-uri-path sim-path)))
|
||||||
(printlog "-- PATH: ~a\n" path)
|
(index-html (read-template-text index-file `(("POSTURI" ,post-uri)))))
|
||||||
|
|
||||||
(cond
|
(lambda (request request-body)
|
||||||
;; Editor javascript files
|
(let ((path (split-and-decode-uri-path
|
||||||
;; ((and (> (length path) 2)
|
(uri-path
|
||||||
;; (equal? (take path 2) '("ace-builds" "src-min-noconflict"))
|
(request-uri request)))))
|
||||||
;; (string-match "^[a-z_-]+\\.js$" (third path)))
|
(printlog "-- PATH: ~a" 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)))))
|
|
||||||
|
|
||||||
;; Icarus
|
(cond
|
||||||
((equal? path '("icarus"))
|
;; Editor javascript files
|
||||||
(printlog "-- Request icarus\n")
|
;; ((and (> (length path) 2)
|
||||||
(let ((log (execute-icarus
|
;; (equal? (take path 2) '("ace-builds" "src-min-noconflict"))
|
||||||
(sanitize-verilog
|
;; (string-match "^[a-z_-]+\\.js$" (third path)))
|
||||||
(utf8->string request-body)))))
|
;; (guard (not-found request)
|
||||||
(make-response log #:type 'text/plain)))
|
;; (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
|
;; Icarus
|
||||||
((null? path)
|
((equal? path sim-path)
|
||||||
(printlog "-- Request index page\n")
|
(printlog "-- Request simulate")
|
||||||
(make-response MAIN-PAGE))
|
(let ((log (execute-icarus
|
||||||
|
(sanitize-verilog
|
||||||
|
(utf8->string request-body)))))
|
||||||
|
(make-response log #:type 'text/plain)))
|
||||||
|
|
||||||
;; Unknown
|
;; Index page
|
||||||
(else
|
((equal? path root-path)
|
||||||
(printlog "-- Request wrong path\n")
|
(printlog "-- Request index page")
|
||||||
(not-found request)))))
|
(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: <https://github.com/punzik/>")))))
|
||||||
|
|
||||||
(define (main args)
|
(define (main args)
|
||||||
(set! MAIN-PAGE (call-with-input-file MAIN-PAGE get-string-all))
|
(debug-disable 'backtrace)
|
||||||
(run-server page-handler))
|
(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)))))))
|
||||||
|
|||||||
Loading…
x
Reference in New Issue
Block a user