#!/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))

(define INDEX-FILE "index.html")
(define LOGGING #t)

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

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

(define* (make-response str #:key (type 'text/html))
  (values (build-response
           #:headers `((content-type . (,type (charset . "utf-8"))))
           #:code 200)
          str))

(define* (file-reader file-name #:key (max-read-length 512))
  (lambda (port)
    (with-input-from-file file-name
      (lambda ()
        (let loop ()
          (let ((data (get-bytevector-n (current-input-port)
                                        max-read-length)))
            (when (not (eof-object? data))
              (put-bytevector port data)
              (loop))))))))

(define* (file-response file #:key (type 'text/html))
  (make-response (file-reader file) #:type type))

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

(define (printlog . rest)
  (when LOGGING
    (display (apply format rest))
    (newline)))

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

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

;;;
;;; Unused
;;;
;; (define* (system-to-string-list cmd #:key (pwd #f))
;;   (let-values (((status out)
;;                 (system-to-string cmd #:pwd pwd)))
;;     (values
;;      status
;;      (list-trim (string-split out #\newline) string-null?))))

;; (define (iverilog-cmd base)
;;   (format "iverilog -DTESTBENCH -g2012 -o ~a/testbench.vvp ~a/testbench.sv" base base))

;; (define (vvp-cmd base)
;;   (format "vvp ~a/testbench.vvp" base))

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

;;;
;;; Get module name
;;;
(define (module-name code)
  (let ((rx (make-regexp
             "(^|\\s)module\\s*(\\s|(#\\(.*\\)\\s*))[a-zA-Z0-9_]+")))
    (let loop ((pos 0)
               (modname #f))
      (let ((m (regexp-exec rx code pos)))
        (if m
            (loop (match:end m) (match:substring m))
            (if modname
                (match:substring (string-match "[a-zA-Z0-9_]+$" modname))
                #f))))))

;;;
;;; Create file with simulation timeout watchdog
;;;
(define (create-timeout-module path modname timeout)
  (define (* . fmt) (display (apply format fmt)) (newline))
  (let ((filename (format "~a/~a.v" path modname)))
    (with-output-to-file filename
      (lambda ()
        (* "`timescale 1ps/1ps")
        (* "module ~a();" modname)
        (* "  initial begin")
        (if (list? timeout)
            (* "    #(~a~a);"
               (car timeout)
               (if (null? (cdr timeout))
                   ""
                   (symbol->string (cadr timeout))))
            (* "    #~a;" timeout))
        (* "    $display(\"Timeout at %0t\", $time);")
        (* "    $finish;")
        (* "  end")
        (* "endmodule")))
    filename))

;;;
;;; Create dump module
;;;
(define (create-dump-module path modname top)
  (define (* . fmt) (display (apply format fmt)) (newline))
  (let ((filename (format "~a/~a.v" path modname)))
    (with-output-to-file filename
      (lambda ()
        (* "`timescale 1ps/1ps")
        (* "module ~a();" modname)
        (* "  initial begin")
        (* "    $dumpfile(\"~a/~a.vcd\");" path modname)
        (* "    $dumpvars(0, ~a);" top)
        (* "  end")
        (* "endmodule")))
    filename))

;;;
;;; Execute testbench
;;;
(define (execute-icarus code)
  (let ((top-module (module-name code)))
    (if (not top-module)
        "No modules declared\n"
        (let* ((work-dir (mkdtemp (format "work-~a-XXXXXX" (current-time))))
               (verilog-file (format "~a/testbench.sv" work-dir))
               (timeout-file (create-timeout-module work-dir "timeout" '(1 us)))
               (dump-file (create-dump-module work-dir "dump" top-module)))
          (with-output-to-file verilog-file
            (lambda () (display code)))

          ;; Compile
          (let ((log
                 (let ((cmdline
                        (format "iverilog -DTESTBENCH -g2012 -o ~a/testbench.vvp ~a ~a ~a"
                                work-dir verilog-file timeout-file dump-file)))
                   (let-values (((status out)
                                 (system-to-string cmdline)))
                     (let ((compile-log
                            (string-append
                             (format "$ ~a\n" cmdline)
                             (format "Return code: ~a\n" status)
                             (if (string-null? out)
                                 "\n"
                                 (format "--\n~a\n" out)))))
                       (if (not (zero? status))
                           compile-log

                           ;; Execute
                           (let ((cmdline (format "vvp ~a/testbench.vvp" work-dir)))
                             (let-values (((status out)
                                           (system-to-string cmdline)))
                               (let ((execution-log
                                      (string-append
                                       (format "$ ~a\n" cmdline)
                                       (format "Return code: ~a\n" status)
                                       (if (string-null? out)
                                           "\n"
                                           (format "--\n~a\n" out)))))
                                 (string-append compile-log execution-log))))))))))

            (delete-recursive work-dir)
            log)))))

;;;
;;; Web page handler
;;;
(define (make-page-handler host root index-file)
  (let* ((root-path (split-and-decode-uri-path root))
         (sim-path (append root-path '("simulate")))
         (post-uri (string-append host "/" (encode-and-join-uri-path sim-path)))
         (index-html (read-template-text index-file `(("POSTURI" ,post-uri)))))

    (lambda (request request-body)
      (let ((path (split-and-decode-uri-path
                   (uri-path
                    (request-uri request)))))
        (printlog "-- PATH: ~a" path)

        (cond
         ;; Editor javascript files
         ;; ((and (> (length path) 2)
         ;;       (equal? (take path 2) '("ace-builds" "src-min-noconflict"))
         ;;       (string-match "^[a-z_-]+\\.js$" (third path)))
         ;;  (guard (not-found request)
         ;;    (let* ((file-path (canonicalize-path
         ;;                       (apply
         ;;                        string-append
         ;;                        (insert-between (cons "." path)
         ;;                                        file-name-separator-string))))
         ;;           (file-stat (stat file-path)))
         ;;      (if (and (eq? (stat:type file-stat) 'regular)
         ;;               (not (zero? (logand (stat:mode file-stat) #o444))))
         ;;          (begin
         ;;            (printlog "-- Request file '~a'" file-path)
         ;;            (file-response file-path #:type 'text/javascript))
         ;;          (not-found request)))))

         ;; Icarus
         ((equal? path sim-path)
          (printlog "-- Request simulate")
          (let ((log (execute-icarus
                      (sanitize-verilog
                       (utf8->string request-body)))))
            (make-response log #:type 'text/plain)))

         ;; Index page
         ((equal? path root-path)
          (printlog "-- Request index page")
          (make-response index-html))

         ;; Unknown
         (else
          (printlog "-- Request wrong path")
          (not-found request)))))))


;;;
;;; ----------------------------------------------------------------------
;;; ------------------------------- MAIN ---------------------------------
;;; ----------------------------------------------------------------------
;;;

(define (print-help app-name)
  (define (-> . args)
    (display (apply format args) (current-error-port))
    (newline (current-error-port)))
  (let ((app-name (basename app-name)))
    (with-output-to-port (current-error-port)
      (lambda ()
        (-> "Usage: ~a [OPTION]..." app-name)
        (-> "Start Verilog playground WEB server")
        (-> "")
        (-> "Options:")
        (-> "  -a, --addr ADDR      Listen on ADDR address. Default: 127.0.0.1")
        (-> "  -p, --port PORT      Listen on PORT port. Default: 8080")
        (-> "  -s, --host URL       Run on URL hostname. Default: http://127.0.0.1:8080")
        (-> "  -r, --root URN       Service location root. Default: ''")
        (-> "  -h, --help           Print this message and exit")
        (-> "")
        (-> "Source code and issue tracker: <https://github.com/punzik/>")))))

(define (main args)
  (debug-disable 'backtrace)
  (let-values
      (((opts rest err)
        (parse-opts (cdr args)
                    '(#\a addr required)
                    '(#\p port required)
                    '(#\s host required)
                    '(#\r root required)
                    '(#\h help none))))
    (let ((addr (string-trim (or (option-get opts 'addr) "127.0.0.1")))
          (port (string->number (string-trim (or (option-get opts 'port) "8080"))))
          (host (string-trim (or (option-get opts 'host) "http://127.0.0.1:8080")))
          (root (string-trim (or (option-get opts 'root) ""))))

      (if (option-get opts 'help)
          (begin
            (print-help (car args))
            (exit -1))
          (begin
            (printlog "Listen on '~a' port '~a'" addr port)
            (printlog "Server URL: '~a/~a'" host root)

            (run-server
             (make-page-handler host root INDEX-FILE)
             'http `(#:host ,addr #:port ,port)))))))