#!/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 VERILATOR-EXE "verilator")

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

(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)
   (format "module ~a;\n" TOP-MODULE)
   "  logic clock = 1'b0;\n"
   "  initial forever #(5ns) clock = ~clock;\n"
   "\n"
   "  initial begin\n"
   "    $display(\"Hello world!\");\n"
   "    repeat(10) @(posedge clock);\n"
   "    $finish();\n"
   "  end\n"
   "endmodule\n"))

(define DEFAULT-CANVAS-WIDTH 800)

(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 (vcd-signal-get signal))
                      (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 (and (< sample-time tend)
                     (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 x=\"~a\" y=\"~a\">" 0 text-position)
                           (string-upcase
                            (if (or (eq? sig-type 'real)
                                    (<= sig-width 4))
                                value
                                (vcd-binary->hex value #t)))
                           "</text></svg>"))))

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

;;;
;;; Make legend SVG text for VCD
;;;
(define* (vcd-signals->legend signals text-spacing text-position)
  (if (null? signals)
      ""
      (let ((common-scope-len
             (length
              (fold
               (lambda (scope common)
                 (let loop ((scope scope)
                            (common common)
                            (out '()))
                   (if (or (null? scope)
                           (null? common))
                       (reverse out)
                       (if (string-ci= (car scope)
                                       (car common))
                           (loop (cdr scope)
                                 (cdr common)
                                 (cons (car scope) out))
                           (reverse out)))))
               (vcd-signal-scope (car signals))
               (map vcd-signal-scope (cdr signals))))))
        (map
         (lambda (sig n)
           (string-append
            (format-inex "<text x=\"0\" y=\"~a\">~a</text>"
                         (+ (* n text-spacing) text-position)
                         (string-concatenate
                          (insert-between
                           (append
                            (drop (vcd-signal-scope sig)
                                  common-scope-len)
                            `(,(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 150)
                   (extra-delim-y 3))

  (let ((tstart (apply min (vcd-timestamps vcd)))
        (tend (apply max (vcd-timestamps vcd)))
        (signals (sort
                  (vcd-signals vcd)
                  (lambda (a b)
                    (and (not (equal? (vcd-signal-name b) "clock"))
                         (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))))))))

    (if (<= tend tstart)
        '()
        (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
           `(,(format-inex "<svg id=\"wave\" width=\"~a\" height=\"~a\"" width height)
             ,(format "preserveAspectRatio=\"xMidYMin slice\" role=\"img\">")
             ,(format "<g id=\"wave-background\"><rect width=\"100%\" height=\"100%\"/></g>"))

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

           ;; Clock
           `(,(format "<g id=\"wave-clock\">"))
           (vcd-signal->svg (car signals) tstart tend
                            signals-x margin
                            signals-w signal-height signal-text-position)
           '("</g>")

           ;; Rest
           `(,(format "<g id=\"wave-signals\">"))
           (fold
            (lambda (sig n out)
              (append
               out
               (vcd-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))
           '("</g>")

           ;; Delimiter
           `(,(format-inex "<g id=\"wave-delim\"><path d=\"M~a ~a v~a\"/></g>"
                           (+ 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 "-DTESTBENCH")
          (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-2023ext+sv")
          (println "--timing")
          (println "--trace")
          (println "--trace-structs")
          (println "--trace-depth 1")
          (println "--quiet-exit")
          (println "~a" verilog-file)
          (println "~a.cpp" top))))
    work-dir))

;;;
;;; Execute secuence of commands and return (values status "execution log")
;;; Break execution on error
;;;
(define (exec-sequence cmds)
  (let-values
      (((status logs)
        (let next-cmd ((cmds cmds)
                       (logs '()))
          (if (null? cmds)
              (values 0 logs)
              (let ((cmd (car cmds)))
                (let-values (((status out time)
                              (system-to-string-with-time cmd)))
                  (let ((logs (cons (exe-log-pretty cmd status out time) logs)))
                    (if (zero? status)
                        (next-cmd (cdr cmds) logs)
                        (values status logs)))))))))
    (values status (string-concatenate (reverse logs)))))

;;;
;;; Read and parse VCD file
;;;
(define* (vcd-file-read file #:optional (signal-need? (lambda (s) #t)))
  (if (file-exists? file)
      (guard #f
        (call-with-input-file file
          (cut vcd-parse <> signal-need?)))
      #f))

;;;
;;; Compile sources and execute simulation with Icarus Verilog
;;; Returns (values status log vcd)
;;;
(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)))
         (vcd-file (path+ work-dir (format "~a.vcd" top)))
         (cmds `(,(format "~a -g2012 -s __~a__ -o ~a -c~a"
                          (wrap-exe IVERILOG-EXE iverilog-wrap)
                          top exe-file command-file)
                 ,(format "~a -N ~a" (wrap-exe VVP-EXE vvp-wrap) exe-file))))

    (let-values (((status log)
                  (exec-sequence cmds)))
      (if (zero? status)
          (values status log (vcd-file-read
                              vcd-file
                              (lambda (sig)
                                (>= (length (vcd-signal-scope sig)) 2))))
          (values status log #f)))))

;;;
;;; Compile sources and execute simulation with Verilator
;;; Returns (values status log vcd)
;;;
(define (exec-sim-verilator top work-dir verilator-wrap verilator-sim-wrap)
  (let* ((command-file (path+ work-dir (format "~a.vc" top)))
         (vcd-file (path+ work-dir (format "~a.vcd" top)))
         (cmds `(,(format "~a -f ~a"
                          (wrap-exe VERILATOR-EXE verilator-wrap)
                          command-file)
                 ,(wrap-exe (path+ work-dir (format "~a/~a" top top))
                            verilator-sim-wrap))))

    (let-values (((status log)
                  (exec-sequence cmds)))
      (if (zero? status)
          (values status log (vcd-file-read
                              vcd-file
                              (lambda (sig)
                                (>= (length (vcd-signal-scope sig)) 2))))
          (values status log #f)))))

;;;
;;; 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 vcd)
        (cond
         ;; Run Icarus Verilog
         ((eq? simulator 'iverilog)
          (let ((work-dir (make-iverilog-workdir code metatop base top)))
            (let-values (((status log vcd)
                          (exec-sim-iverilog top work-dir iverilog-wrap vvp-wrap)))
              (values work-dir status log vcd))))

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

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

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

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

;;;
;;; 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))

;;;
;;; Make log HTML
;;;
(define* (make-log-html log vcd canvas-width #:key
                        (minimum-sample-width 10)
                        (maximum-canvas-width 20000))
  (if vcd
      (let ((need-width
             (* minimum-sample-width
                (length (vcd-timestamps vcd)))))
        (format "~a<br/>\n<pre id=\"log\">~a</pre>\n"
                (string-concatenate
                 (vcd->svg vcd
                           (if (< need-width canvas-width)
                               canvas-width
                               (if (> need-width maximum-canvas-width)
                                   maximum-canvas-width
                                   need-width))))
                log))
      (format "<pre>~a</pre>\n" log)))

;;;
;;; 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)))
         (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))
             ("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 VERILATOR-EXE verilator-wrap)))
                  ""
                  "Rules:"
                  "0. Don't fool around ;)"
                  "1. The top module must be named 'testbench'."
                  "2. The top module 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)))
                 ""))

            ;; Request query
            (query (let ((q (uri-query (request-uri request))))
                     (if q
                         (map (lambda (qstr) (string-split q #\=))
                              (string-split q #\;))
                         '()))))

        (logger LOG-VERBOSE "Request ~a:~a" (request-method request) path)
        (logger LOG-VERBOSE "Request query:~a" query)
        (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 simulation
           ((or (equal? path iverilog-path)
                (equal? path verilator-path))
            (let ((simulator
                   (if (equal? path iverilog-path)
                       'iverilog
                       'verilator)))

              (logger LOG-DBG "Request ~a simulation" (symbol->string simulator))
              (let-values
                  (((log vcd)
                    (exec-sim simulator
                              (if sanitize (sanitize-verilog code) code)
                              work-base
                              TOP-MODULE
                              #:metatop iverilog-metatop
                              #:vvp-wrap vvp-wrap
                              #:iverilog-wrap iverilog-wrap
                              #:verilator-wrap verilator-wrap
                              #:verilator-sim-wrap verilator-sim-wrap
                              #:verilator-cpp verilator-cpp
                              #:verilator-build-jobs verilator-build-jobs)))

                (let ((canvas-width
                       (let ((v (assoc "width" query)))
                         (or (and v (string->number (cadr v)))
                             DEFAULT-CANVAS-WIDTH))))
                  (make-response
                   (make-log-html log vcd canvas-width)
                   #:content-type 'text/plain)))))

           ;; Save snippet
           ((or (equal? path savecode-path))
            (logger LOG-DBG "Request code saving")
            (let ((old-code
                   (if ref-stor-dir
                       (read-from-storage (path+ stor-base ref-stor-dir))
                       DEFAULT-CODE)))
              (if (equal? code old-code)
                  ;; If code is not changed do nothing
                  (make-response
                   (encode-and-join-uri-path
                    (append root-path `(,ref-stor-dir)))
                   #:content-type 'text/plain)
                  ;; New code save to new location
                  (let ((stor-dir
                         (basename
                          (mkdtemp
                           (path+
                            stor-base
                            (if USE-TIME-IN-SAVE-URL
                                (format "~a-XXXXXX" (current-time))
                                "XXXXXX"))))))
                    (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)))))))