#!/usr/bin/env -S guile -e "main" -s
!#

;; -*- geiser-scheme-implementation: guile -*-

(import (srfi srfi-1)
        (srfi srfi-11)
        (srfi srfi-26)
        (srfi srfi-28)
        (rnrs bytevectors)
        (web server)
        (web request)
        (web response)
        (web uri)
        (sxml simple)
        (ice-9 regex)
        (ice-9 binary-ports)
        (ice-9 textual-ports)
        (ice-9 popen))

(import (embddr common)
        (embddr optargs)
        (embddr vcd))

(define INDEX-FILE "index.html")
(define DELETE-WORK-DIR #t)

(define TOP-MODULE "testbench")
(define SNIPPET-FILE "code.sv")
(define IVERILOG-METATOP-FILE "top_iverilog.sv")
(define VERILATOR-CPP-FILE "top_verilator.cpp")
(define USE-TIME-IN-SAVE-URL #f)

(define IVERILOG-EXE "iverilog")
(define VVP-EXE "vvp")
(define VERILATR-EXE "verilator")

(define URI-IVERILOG "iverilog")
(define URI-VERILATOR "verilator")
(define URI-SAVE-CODE "save")
(define URI-SAVEAS-CODE "saveas")

(define LOG-DBG 3)
(define LOG-VERBOSE 2)
(define LOG-INFO 1)
(define LOG-ERROR 0)

(define LOG-LEVEL LOG-VERBOSE)

(define DEFAULT-CODE
  (string-append
   "`timescale 1ps/1ps\n\n"
   (format "module ~a (input clock);\n" TOP-MODULE)
   "  initial begin\n"
   "    $display(\"Hello world!\");\n"
   "    $finish();\n"
   "  end\n"
   "endmodule\n"))

(define (multistring . strings)
  (apply string-append
         (insert-between strings "\n")))

(define-syntax guard
  (syntax-rules ()
    ((_ default code...)
     (with-exception-handler (lambda (e) default)
       (lambda () code...)
       #:unwind? #t))))

(define (print . args)
  (display (apply format args)))

(define (println . args)
  (display (apply format args))
  (newline))

;;;
;;; Logger
;;;
(define (logger . args)
  (unless (null? args)
    (let ((prefix
           (format "~a | "
                   (strftime "%c" (localtime (current-time))))))
      (if (number? (car args))
          (when (<= (car args) LOG-LEVEL)
            (display prefix)
            (display (apply format (cdr args)))
            (newline))
          (begin
            (display prefix)
            (display (apply format args))
            (newline))))
    (force-output (current-output-port))))

;;;
;;; Return directory list
;;;
(define (list-dir path)
  (if (file-exists? path)
      (let ((dir (opendir path)))
        (let loop ((ls '()))
          (let ((item (readdir dir)))
            (if (eof-object? item)
                (begin
                  (closedir dir)
                  ls)
                (if (or (string=? item ".")
                        (string=? item ".."))
                    (loop ls)
                    (loop (cons (string-append path "/" item) ls)))))))
      '()))

;;;
;;; Recursive delete directory
;;;
(define (delete-recursive path)
  (let ((path (canonicalize-path path)))
    (if (eq? 'directory (stat:type (stat path)))
        (begin
          (for-each delete-recursive (list-dir path))
          (rmdir path))
        (delete-file path))))

;;;
;;; Trim list
;;;
(define (list-trim l pred)
  (cond
   ((null? l) '())
   ((pred (car l)) (list-trim (cdr l) pred))
   (else
    (let ((lr (reverse l)))
      (if (pred (car lr))
          (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))))

;;;
;;; 404 response
;;;
(define (not-found request)
  (values (build-response #:code 404)
          (string-append "Resource not found: "
                         (uri->string (request-uri request)))))

;;;
;;; Common text/html response
;;;
(define* (make-response str #:key
                        (content-type 'text/html)
                        (content-type-params '((charset . "utf-8"))))
  (values (build-response
           #:headers `((content-type . (,content-type ,@content-type-params)))
           ;; #:headers `((content-type . (,(if (null? encoding)
           ;;                                   type
           ;;                                   (cons type encoding)))))
           #:code 200)
          str))

;;;
;;; File reader
;;;
(define* (file-reader file-name #:key
                      (max-read-length 512)
                      (max-file-size #f))
  (lambda (port)
    (guard ""
      (call-with-input-file file-name
        (lambda (in)
          (let loop ((readed 0))
            (when (or (not max-file-size)
                      (< readed max-file-size))
              (let ((data (get-bytevector-n in max-read-length)))
                (unless (eof-object? data)
                  (put-bytevector port data)
                  (loop (+ readed (bytevector-length data))))))))
        #:binary #t))))

;;;
;;; File response
;;;
(define* (file-response file #:key
                        (content-type 'application/octet-stream)
                        (content-type-params '((charset . "")))
                        (max-file-size #f))
  (make-response
   (file-reader file #:max-file-size max-file-size)
   #:content-type content-type
   #:content-type-params content-type-params))

;;;
;;; Simple format with convert input number to inexact numbers
;;;
(define (format-inex . args)
  (apply format
         (map (lambda (arg)
                (if (number? arg)
                    (exact->inexact
                     (/ (round (* arg 100)) 100))
                    arg))
              args)))

;;;
;;; Make SVG drawing of VCD signals
;;;
(define* (vcd-signal->svg signal tstart tend x y width height text-position
                          #:key (id #f) (data-hw 3))
  (let* ((time-per-pixel (/ (- tend tstart) width))
         (sig-width (vcd-signal-size signal))
         (sig-type (vcd-signal-type signal))
         (y0 y)
         (y1 (+ y height))
         (yz (+ y (/ height 2)))
         (half-dy (/ (- y1 y0) 2))
         (id (if id (format " id=\"~a\"" id) "")))

    (let next-sample ((samples (append (vcd-signal-get signal) `((,tend . "-"))))
                      (value (if (eq? sig-type 'real)
                                 0
                                 (make-string sig-width #\x)))
                      (time tstart)
                      (svg '()))

      (if (null? samples)
          svg
          (let ((sample-time (car (car samples)))
                (sample-value (cdr (car samples))))
            (if (or (< (- sample-time time) time-per-pixel)
                    (and (equal? value sample-value)
                         (not (eq? sig-type 'event))))
                (next-sample
                 (cdr samples)
                 (if (<= sample-time tstart)
                     sample-value
                     value)
                 time svg)
                (next-sample
                 (cdr samples) sample-value sample-time
                 (cons
                  (cond
                   ((or (eq? sig-type 'bits)
                        (eq? sig-type 'real))

                    (if (and (= sig-width 1)
                             (not (eq? sig-type 'real))
                             (not (char-ci=? (string-ref value 0) #\x)))
                        ;; Scalar
                        (let ((x0 (+ x (/ (- time tstart) time-per-pixel)))
                              (x1 (+ x (/ (- sample-time tstart) time-per-pixel))))
                          (string-append
                           (format-inex "<path~a d=\"M~a ~a v~a\"/>" id x0 y0 (- y1 y0))
                           (format-inex "<path~a d=\"M~a ~a h~a\"/>"
                                        id x0
                                        (cond
                                         ((equal? value "0") y1)
                                         ((equal? value "1") y0)
                                         (else yz))
                                        (- x1 x0))))

                        ;; Vector or Real
                        (let ((x0 (+ x (/ (- time tstart) time-per-pixel)))
                              (x1 (+ x (/ (- sample-time tstart) time-per-pixel))))
                          (string-append
                           ;; Horizontal lines
                           (let ((x0 (+ x0 (if (<= time tstart) 0 data-hw)))
                                 (x1 (- x1 (if (>= sample-time tend) 0 data-hw))))
                             (format-inex
                              "<path~a d=\"M~a ~a L~a ~a M~a ~a L~a ~a\"/>"
                              id x0 y0 x1 y0 x0 y1 x1 y1))

                           ;; Left cross
                           (if (<= time tstart)
                               ""
                               (format-inex "<path~a d=\"M~a ~a l~a ~a\"/><path d=\"M~a ~a l~a ~a\"/>"
                                            id
                                            x0 yz data-hw (- half-dy)
                                            x0 yz data-hw (+ half-dy)))

                           ;; Right cross
                           (if (>= sample-time tend)
                               ""
                               (format-inex "<path~a d=\"M~a ~a l~a ~a\"/><path d=\"M~a ~a l~a ~a\"/>"
                                            id
                                            x1 yz (- data-hw) (- half-dy)
                                            x1 yz (- data-hw) (+ half-dy)))

                           ;; Text
                           (format-inex "<svg~a x=\"~a\" y=\"~a\" width=\"~a\" height=\"~a\">"
                                        id
                                        (+ x0 data-hw)
                                        y0
                                        (- x1 x0 (* data-hw 2))
                                        (- y1 y0))
                           (format-inex "<text id=\"val\" x=\"~a\" y=\"~a\">" 0 text-position)
                           (if (or (eq? sig-type 'real)
                                   (< sig-width 4))
                               value
                               (string-upcase
                                (vcd-binary->hex value #t)))
                           "</text></svg>"))))

                   ;; Real number
                   ((eq? sig-type 'real)
                    "")

                   ;; Event
                   ((eq? sig-type 'event)
                    ""))
                  svg))))))))

;;;
;;; Make legend SVG text for VCD
;;;
(define* (vcd-signals->legend signals text-spacing text-position)
  (map
   (lambda (sig n)
     (string-append
      (format-inex "<text x=\"0\" y=\"~a\">~a</text>"
                   (+ (* n text-spacing) text-position)
                   (vcd-signal-name sig))))
   signals
   (iota (length signals))))

;;;
;;; Create SVG from VCD
;;;
(define* (vcd->svg vcd width #:key
                   (signal-height 15)
                   (signal-text-position 12)
                   (margin 5)
                   (signal-spacing 5)
                   (legend-width 100)
                   (extra-delim-y 3))

  (let ((tstart (apply min (vcd-timestamps vcd)))
        (tend (apply max (vcd-timestamps vcd)))
        (signals (sort
                  (remove
                   (lambda (sig) (< (length (vcd-signal-scope sig)) 2))
                   (vcd-signals vcd))
                  (lambda (a b)
                    (or
                     (and (equal? (vcd-signal-name a) "clock")
                          (not (equal? (vcd-signal-name b) "clock")))

                     (< (length (vcd-signal-scope a))
                        (length (vcd-signal-scope b)))

                     (string-ci<? (vcd-signal-name a)
                                  (vcd-signal-name b)))))))

    (let ((signals-x (+ (* 2 margin) legend-width))
          (signals-w (- width legend-width (* 3 margin)))
          (height
           (+ (* 2 margin)
              (* signal-height (length signals))
              (* signal-spacing (- (length signals) 1)))))

      (append
       ;; Header
       (list
        (format-inex "<svg width=\"~a\" height=\"~a\"" width height)
        (format "preserveAspectRatio=\"xMidYMin slice\" role=\"img\"")
        (format "<g id=\"wave-background\"><rect width=\"100%\" height=\"100%\"/></g>")
        (format "<g id=\"wave-signals\">"))

       ;; Legend
       `(,(format-inex "<svg id=\"legend\" x=\"~a\" y=\"~a\" width=\"~a\" height=\"~a\">"
                       margin margin legend-width (- height (* 2 margin))))
       (signals->legend signals
                        (+ signal-height signal-spacing)
                        signal-text-position)
       '("</svg>")

       ;; Clock
       (signal->svg (car signals) tstart tend
                    signals-x margin
                    signals-w signal-height signal-text-position
                    #:id "clock")

       ;; Rest
       (fold
        (lambda (sig n out)
          (append
           out
           (signal->svg sig tstart tend
                        signals-x
                        (+ margin
                           (* n signal-height)
                           (* n signal-spacing))
                        signals-w signal-height signal-text-position)))
        '()
        (cdr signals)
        (iota (length
               (cdr signals))
              1))

       ;; Delimiter
       `(,(format-inex "<path id=\"delim\" d=\"M~a ~a v~a\"/>"
                       (+ legend-width (* 2 margin)) (- margin extra-delim-y)
                       (- height (* 2 (- margin extra-delim-y)))))

       ;; Close svg tag
       '("</svg>")))))

;;;
;;; Execute system command and capture stdout and stderr to string
;;;
(define* (system-to-string cmd #:key (pwd #f))
  (let* ((cmd (string-append cmd " 2>&1"))
         (cmd (if pwd (format "cd ~a; ~a" pwd cmd) cmd))
         (p (open-input-pipe cmd))
         (out (get-string-all p)))
    (values (close-pipe p) out)))

;;;
;;; Same as system-to-string but returns execution time (in ms) also
;;;
(define* (system-to-string-with-time cmd #:key (pwd #f))
  (let ((start-time (gettimeofday)))
    (let-values
        (((status out)
          (system-to-string cmd #:pwd pwd)))
      (let ((stop-time (gettimeofday)))
        (values status out
                (exact->inexact
                 (- (+ (* (car stop-time) 1000)
                       (/ (cdr stop-time) 1000))
                    (+ (* (car start-time) 1000)
                       (/ (cdr start-time) 1000)))))))))

;;;
;;; Execute system command and capture stdout and stderr to string list
;;;
(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?))))

;;;
;;; Make pretty log from executable output
;;;
(define (exe-log-pretty cmdline status out time)
  (string-append
   (format "$ ~a\n" cmdline)
   (format "Return code: ~a, Exec time: ~a ms\n" status time)
   (if (string-null? out)
       "\n"
       (format "--\n~a\n" out))))

;;;
;;; Trivial sanitize verilog code
;;;
(define (sanitize-verilog code)
  (let* (;; $f* functions but not $finish
         (code (regexp-substitute/global #f "\\$f[a-hj-z][a-z]+" code 'pre "$error" 'post))
         ;; $scanf
         (code (regexp-substitute/global #f "\\$.?scanf" code 'pre "$error" 'post))
         ;; $readmem
         (code (regexp-substitute/global #f "\\$readmem[bh]" code 'pre "$error" 'post))
         ;; $dump*
         (code (regexp-substitute/global #f "\\$dump[a-z]*" code 'pre "$error" 'post)))
    code))

;;;
;;; Concatenate path elements and remove duplicate slashes
;;;
(define (path+ . paths)
  (reverse-list->string
   (string-fold
    (lambda (c s)
      (if (and (not (null? s))
               (char=? c #\/)
               (char=? (car s) #\/))
          s (cons c s)))
    '() (string-concatenate
         (insert-between
          (remove string-null?
                  (map string-trim-both paths))
          "/")))))

(define (wrap-exe exe wrapper)
  (format "~a~a" (if wrapper (format "~a " wrapper) "") exe))

;;;
;;; Make workdir with sources and command file. Common part
;;; Returns work directory path string, verilog file name
;;; and command file name.
;;;
(define* (make-sim-workdir code base top)
  (let* ((work-dir (mkdtemp (path+ base (format "work-~a-XXXXXX" (current-time)))))
         (verilog-file (path+ work-dir (format "~a.sv" top)))
         (command-file (path+ work-dir (format "~a.vc" top))))
    (with-output-to-file verilog-file (cut display code))
    (values work-dir verilog-file command-file)))

;;;
;;; Create workdir for Icarus Verilog
;;; Returns directory path
;;;
(define* (make-iverilog-workdir code metatop base top)
  (let-values (((work-dir verilog-file command-file)
                (make-sim-workdir code base top)))
    (let ((metatop-file (path+ work-dir (format "__~a__.sv" top))))
      (with-output-to-file metatop-file
        (cut display (substitute metatop "@~a@"
                                 `((WORKDIR ,work-dir)
                                   (TOPMODULE ,top)))))

      (with-output-to-file command-file
        (lambda ()
          (println "~a" metatop-file)
          (println "~a" verilog-file)
          (println "+define+TESTBENCH")
          (println "+timescale+1ps/1ps"))))
    work-dir))

;;;
;;; Create workdir for Verilator
;;; Returns directory path
;;;
(define* (make-verilator-workdir code cpp jobs base top)
  (let-values (((work-dir verilog-file command-file)
                (make-sim-workdir code base top)))
    (let ((cpp-file (path+ work-dir (format "~a.cpp" top))))
      (with-output-to-file cpp-file
        (cut display (substitute cpp "@~a@" `((WORKDIR ,work-dir)
                                              (TOPMODULE ,top)))))

      (with-output-to-file command-file
        (lambda ()
          (println "+define+TESTBENCH")
          (println "--timescale 1ps/1ps")
          (println "--top-module ~a" top)
          (println "--Mdir ~a" (path+ work-dir top))
          (println "-cc")
          (println "-O2")
          (when (> jobs 0)
            (println "--build-jobs ~a" jobs))
          (println "-o ~a" top)
          (println "--exe")
          (println "--build")
          (println "-sv")
          (println "-Wno-WIDTH")
          (println "+1800-2017ext+sv")
          (println "--timing")
          (println "--trace")
          (println "--quiet-exit")
          (println "~a" verilog-file)
          (println "~a.cpp" top))))
    work-dir))

;;;
;;; Compile sources and execute simulation with Icarus Verilog
;;; Returns (values status log)
;;;
(define (exec-sim-iverilog top work-dir iverilog-wrap vvp-wrap)
  (let ((command-file (path+ work-dir (format "~a.vc" top)))
        (exe-file (path+ work-dir (format "~a.out" top))))
    ;; Compile
    (let ((cmdline (format "~a -g2012 -s __~a__ -o ~a -c~a"
                           (wrap-exe IVERILOG-EXE iverilog-wrap)
                           top exe-file command-file)))
      (let-values (((status out time)
                    (system-to-string-with-time cmdline)))
        (let ((compile-log
               (exe-log-pretty cmdline status out time)))
          (if (not (zero? status))
              (values status compile-log)

              ;; Execute
              (let ((cmdline (format "~a -N ~a" (wrap-exe VVP-EXE vvp-wrap) exe-file)))
                (let-values (((status out time)
                              (system-to-string-with-time cmdline)))
                  (let ((execution-log
                         (exe-log-pretty cmdline status out time)))
                    (values status (string-append compile-log execution-log)))))))))))

;;;
;;; Compile sources and execute simulation with Verilator
;;; Returns (values status log)
;;;
(define (exec-sim-verilator top work-dir verilator-wrap verilator-sim-wrap)
  ;; Compile
  (let* ((command-file (path+ work-dir (format "~a.vc" top)))
         (cmdline (format "~a -f ~a"
                          (wrap-exe VERILATR-EXE verilator-wrap)
                          command-file)))
    (let-values (((status out time)
                  (system-to-string-with-time cmdline)))
      (let ((compile-log
             (exe-log-pretty cmdline status out time)))
        (if (not (zero? status))
            (values status compile-log)

            ;; Execute
            (let ((cmdline (wrap-exe (path+ work-dir (format "~a/~a" top top))
                                     verilator-sim-wrap)))
              (let-values (((status out time)
                            (system-to-string-with-time cmdline)))
                (let ((execution-log
                       (exe-log-pretty cmdline status out time)))
                  (values status (string-append compile-log execution-log))))))))))

;;;
;;; Execute simulation
;;;
(define* (exec-sim simulator code base top #:key
                   (vvp-wrap "") (iverilog-wrap "") (metatop "")
                   (verilator-wrap "") (verilator-sim-wrap "")
                   (verilator-cpp "") (verilator-build-jobs 0))
  (let-values
      (((work-dir status log)
        (cond
         ;; Run Icarus Verilog
         ((eq? simulator 'iverilog)
          (let ((work-dir (make-iverilog-workdir code metatop base top)))
            (let-values (((status log)
                          (exec-sim-iverilog top work-dir iverilog-wrap vvp-wrap)))
              (values work-dir status log))))

         ;; Run Verilator
         ((eq? simulator 'verilator)
          (let ((work-dir (make-verilator-workdir code verilator-cpp verilator-build-jobs base top)))
            (let-values (((status log)
                          (exec-sim-verilator top work-dir verilator-wrap verilator-sim-wrap)))
              (values work-dir status log))))

         ;; Inknown simulator
         (else
          (values #f #f #f)))))

    (if (not work-dir)
        ("ERROR: Unknown simulator")
        (begin
          ;; Delete work dir
          (when DELETE-WORK-DIR
            (delete-recursive work-dir))

          ;; Return log
          (string-append
           log
           (format "-----------------\nSimulation complete~a\n"
                   (if (zero? status) " succesfully"" with errors")))))))

;;;
;;; Get app version
;;;
(define* (app-version exe #:optional (option "--version"))
  (let-values (((status out)
                (system-to-string-list
                 (format "~a ~a" exe option))))
    (if (and (zero? status)
             (not (null? out)))
        (car out)
        "Unknown")))

;;;
;;; Get storage dir from URI
;;;
(define (get-storage-dir uri root-path)
  (string-trim-both
   (substring (uri-path uri)
              (string-length root-path))
   #\/))

;;;
;;; Check storage path validity
;;;
(define (storage-dir-valid? dir)
  (if (or (< (string-length dir) 1)
          (> (string-length dir) 32))
      #f
      (string-fold
       (lambda (c valid)
         (if (or (char-alphabetic? c)
                 (char-numeric? c)
                 (char=? c #\-))
             valid #f))
       #t dir)))

;;;
;;; Check storage exists
;;;
(define (storage-path-exists? path)
  (let ((dir-stat (stat path #f))
        (file-stat (stat (path+ path SNIPPET-FILE) #f)))
    (and dir-stat file-stat
         (eq? (stat:type dir-stat) 'directory)
         (eq? (stat:type file-stat) 'regular)
         (not (zero? (logand #o444 (stat:perms file-stat))))
         (not (zero? (logand #o222 (stat:perms file-stat)))))))

;;;
;;; Save code to storage
;;;
(define (save-to-storage path code)
  (with-output-to-file (path+ path SNIPPET-FILE)
    (cut display code)))

;;;
;;; Read from storage
;;;
(define (read-from-storage path)
  (call-with-input-file (path+ path SNIPPET-FILE)
    get-string-all))

;;;
;;; Web page handler
;;;
(define (make-page-handler host root index-file
                           work-base stor-base
                           max-code-size sanitize
                           iverilog-wrap vvp-wrap
                           verilator-wrap verilator-sim-wrap verilator-build-jobs)

  (let* ((root-path (split-and-decode-uri-path root))
         (root (encode-and-join-uri-path root-path))
         (iverilog-path (append root-path `(,URI-IVERILOG)))
         (verilator-path (append root-path `(,URI-VERILATOR)))
         (savecode-path (append root-path `(,URI-SAVE-CODE)))
         (saveas-path (append root-path `(,URI-SAVEAS-CODE)))
         (index-html
          (read-template-text
           index-file
           `(("IVERILOGPOSTURI" ,(encode-and-join-uri-path iverilog-path))
             ("VERILATORPOSTURI" ,(encode-and-join-uri-path verilator-path))
             ("SAVECODEURI" ,(encode-and-join-uri-path savecode-path))
             ("SAVEASURI" ,(encode-and-join-uri-path saveas-path))
             ("HELPSTRING",
              (string-concatenate
               (insert-between
                `("Verilog Playground by Punzik (c) 2022"
                  ""
                  ,(format "Icarus: ~a"
                           (app-version (wrap-exe IVERILOG-EXE iverilog-wrap) "-V"))
                  ,(format "Verilator: ~a"
                           (app-version (wrap-exe VERILATR-EXE verilator-wrap)))
                  ""
                  "Rules:"
                  "0. Don't fool around ;)"
                  "1. The top module must be named 'testbench'."
                  "2. The top module for the Verilator must have an input clock signal."
                  "3. Code size should not exceed 10000 characters."
                  "4. Code execution time no longer than 5 seconds.")
                "\\n"))))))
         (iverilog-metatop
          (call-with-input-file IVERILOG-METATOP-FILE get-string-all))
         (verilator-cpp
          (call-with-input-file VERILATOR-CPP-FILE get-string-all)))

    (lambda (request request-body)
      (let (;; Requested resource path
            (path (split-and-decode-uri-path
                   (uri-path
                    (request-uri request))))

            ;; Snippet dir path relative to stor-base
            (ref-stor-dir
             (let ((ref (assoc 'referer (request-headers request))))
               (and ref
                    (let ((p (get-storage-dir (cdr ref) root)))
                      (and (storage-dir-valid? p)
                           (storage-path-exists? (path+ stor-base p))
                           p)))))

            ;; Body of the POST request
            (code
             (if request-body
                 (let ((code (utf8->string request-body)))
                   (if (or (zero? max-code-size)
                           (<= (string-length code) max-code-size))
                       code
                       (substring code 0 max-code-size)))
                 "")))

        (logger LOG-VERBOSE "Request ~a:~a" (request-method request) path)
        (logger LOG-VERBOSE "Request query:~a" (uri-query (request-uri request)))
        (logger LOG-DBG "  stor:'~a' len:~a/~a"
                ref-stor-dir
                (request-content-length request)
                (string-length code))

        (cond
         ;;
         ;; ---- GET requests
         ;;
         ((eq? 'GET (request-method request))
          (cond
           ;; Index page
           ((equal? path root-path)
            (logger LOG-DBG "Request index page")
            (make-response
             (substitute index-html "@~a@" `((CODE ,DEFAULT-CODE)))))

           ;; Site favicon
           ((equal? path (append root-path '("favicon.ico")))
            (logger LOG-DBG "Request favicon.ico")
            (file-response "favicon.png"
                           #:content-type 'image/png
                           #:max-file-size 10000))

           ;; Get saved snippet
           ((and (= (length path)
                    (+ (length root-path) 1))
                 (every equal? path root-path))
            (logger LOG-DBG "Request code from storage")
            (let ((code
                   (if (null? path)
                       DEFAULT-CODE
                       (let* ((stor-dir (last path))
                              (stor-path (path+ stor-base stor-dir)))
                         (if (and (storage-dir-valid? stor-dir)
                                  (storage-path-exists? stor-path))
                             (read-from-storage stor-path)
                             DEFAULT-CODE)))))
              (make-response
               (substitute index-html "@~a@" `((CODE ,code))))))

           ;; Wrong GET request
           (else
            (logger LOG-DBG "Wrong GET request")
            (not-found request))))

         ;;
         ;; ---- POST requests
         ;;
         ((eq? 'POST (request-method request))
          (cond
           ;; Run iverilog simulation
           ((equal? path iverilog-path)
            (logger LOG-DBG "Request iverilog simulation")

            (when ref-stor-dir
              (save-to-storage (path+ stor-base ref-stor-dir) code))

            (make-response
             (exec-sim 'iverilog
                       (if sanitize (sanitize-verilog code) code)
                       work-base
                       TOP-MODULE
                       #:metatop iverilog-metatop
                       #:vvp-wrap vvp-wrap
                       #:iverilog-wrap iverilog-wrap)
             #:content-type 'text/plain))

           ;; Run verilator simulation
           ((equal? path verilator-path)
            (logger LOG-DBG "Request verilator simulation")

            (when ref-stor-dir
              (save-to-storage (path+ stor-base ref-stor-dir) code))

            (make-response
             (exec-sim 'verilator
                       (if sanitize (sanitize-verilog code) code)
                       work-base
                       TOP-MODULE
                       #:verilator-wrap verilator-wrap
                       #:verilator-sim-wrap verilator-sim-wrap
                       #:verilator-cpp verilator-cpp
                       #:verilator-build-jobs verilator-build-jobs)
             #:content-type 'text/plain))

           ;; Save snippet
           ((or (equal? path savecode-path)
                (equal? path saveas-path))
            (let ((saveas (equal? path saveas-path)))
              (logger LOG-DBG "Request code saving~a"
                      (if saveas " as new snippet" ""))
              (let ((stor-dir
                     (if (or saveas
                             (not ref-stor-dir))
                         (basename
                          (mkdtemp
                           (path+
                            stor-base
                            (if USE-TIME-IN-SAVE-URL
                                (format "~a-XXXXXX" (current-time))
                                "XXXXXX"))))
                         ref-stor-dir)))
                (save-to-storage (path+ stor-base stor-dir) code)
                (make-response
                 (encode-and-join-uri-path
                  (append root-path `(,stor-dir)))
                 #:content-type 'text/plain))))

           ;; Wrong POST request
           (else
            (logger LOG-DBG "Wrong POST request")
            (not-found request))))

         ;;
         ;; ---- Unknown requests type
         ;;
         (else
          (logger LOG-DBG "Wrong request method")
          (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: ''")
        (-> "  --iverilog-wrap PATH        Icarus compiler wrapper.")
        (-> "  --vvp-wrap PATH             Icarus Verilog interpreter wrapper.")
        (-> "  --verilator-wrap PATH       Verilator compiler wrapper.")
        (-> "  --verilator-sim-wrap PATH   Verilator simulation executable wrapper.")
        (-> "  --verilator-build-jobs N    Verilator parallel build.")
        (-> "  --max-len LEN               Set maximum code size in symbols. Default: 0 (infinite)")
        (-> "  --dont-sanitize             Do not sanitize verilog code (dangerous)")
        (-> "  --work-base PATH            Set work base path. Default: ./")
        (-> "  --stor-base PATH            Set snippets storage path. Default: ./")
        (-> "  --log-level LEVEL           Set log level from 0 (quiet) to 10 (verbose). Default: 1./")
        (-> "  -h, --help                  Print this message and exit")
        (-> "")
        (-> "Source code and issue tracker: <https://github.com/punzik/>")))))

(define (string-trim-if-string str)
  (if (string? str)
      (string-trim-both str)
      str))

(define (main args)
  (debug-disable 'backtrace)
  (let-values
      (((opts rest err)
        (parse-opts (cdr args)
                    '(("addr" #\a) required)
                    '(("port" #\p) required)
                    '(("host" #\s) required)
                    '(("root" #\r) required)
                    '(("vvp-wrap") required)
                    '(("iverilog-wrap") required)
                    '(("verilator-wrap") required)
                    '(("verilator-sim-wrap") required)
                    '(("verilator-build-jobs") required)
                    '(("max-len") required)
                    '(("dont-sanitize") none)
                    '(("work-base") required)
                    '(("stor-base") required)
                    '(("log-level") required)
                    '(("help" #\h) none))))

    (let ((addr (string-trim-both (or (option-get opts "addr") "127.0.0.1")))
          (port (string->number (string-trim-both (or (option-get opts "port") "8080"))))
          (host (string-trim-both (or (option-get opts "host") "http://127.0.0.1:8080")))
          (root (string-trim-both (or (option-get opts "root") "")))
          (vvp-wrap (string-trim-if-string (option-get opts "vvp-wrap")))
          (iverilog-wrap (string-trim-if-string (option-get opts "iverilog-wrap")))
          (verilator-wrap (string-trim-if-string (option-get opts "verilator-wrap")))
          (verilator-sim-wrap (string-trim-if-string (option-get opts "verilator-sim-wrap")))
          (verilator-build-jobs (string->number (string-trim-both (or (option-get opts "verilator-build-jobs") "0"))))
          (max-code-size (string->number (string-trim-both (or (option-get opts "max-len") "0"))))
          (sanitize (not (option-get opts "dont-sanitize")))
          (work-base (string-trim-both (or (option-get opts "work-base") "./")))
          (stor-base (string-trim-both (or (option-get opts "stor-base") "./")))
          (log-level (string->number (string-trim-both (or (option-get opts "log-level") "1")))))

      (cond
       (err
        (display (format "Unknown option '~a'\n" err))
        (print-help (car args))
        (exit -1))

       ((option-get opts "help")
        (print-help (car args))
        (exit -1))

       (else
        (set! LOG-LEVEL log-level)
        (logger LOG-INFO "Listen on '~a' port '~a'" addr port)
        (logger LOG-INFO "Server URL: '~a/~a'" host root)
        (logger LOG-INFO "iverilog wrapper: '~a'" iverilog-wrap)
        (logger LOG-INFO "vvp wrapper: '~a'" vvp-wrap)
        (logger LOG-INFO "verilator compiler wrapper: '~a'" verilator-wrap)
        (logger LOG-INFO "verilator simulator wrapper: '~a'" verilator-sim-wrap)
        (logger LOG-INFO "verilator build jobs: ~a" verilator-build-jobs)
        (logger LOG-INFO "Max code size: ~a" max-code-size)
        (logger LOG-INFO "Sanitize code: ~a" sanitize)
        (logger LOG-INFO "Work base path: '~a'" work-base)
        (logger LOG-INFO "Storage base path: '~a'" stor-base)
        (logger LOG-INFO "Log level: '~a'" log-level)

        (run-server
         (make-page-handler host root INDEX-FILE
                            work-base stor-base
                            max-code-size sanitize
                            iverilog-wrap vvp-wrap
                            verilator-wrap verilator-sim-wrap verilator-build-jobs)
         'http `(#:host ,addr #:port ,port)))))))