#!/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. Code size should not exceed 10000 characters."
                  "3. 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)))))))