#!/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 DELETE-WORK-DIR #t)

(define DEFAULT-CODE
  (string-append
   "`timescale 10ps/10ps\n\n"
   "module test;\n"
   "  initial begin\n"
   "    $display(\"Hello world!\");\n"
   "    $finish();\n"
   "  end\n"
   "endmodule\n"))

(define SIM-SV-FILE  "testbench.sv")
(define SIM-VC-FILE  "testbench.vc")
(define SIM-EXE-FILE "testbench.out")
(define SNIPPET-FILE "code.sv")

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

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

(define LOG-LEVEL LOG-VERBOSE)

(define (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)
  (when (not (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)))
                (when (not (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))

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

;;;
;;; 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)
  (string-append
   (format "$ ~a\n" cmdline)
   (format "Return code: ~a\n" status)
   (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))

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

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

;;;
;;; Create dump module
;;;
(define (create-dump-module path modname top)
  (define (-> . fmt) (display (apply format fmt)) (newline))
  (let ((filename (path+ path (format "~a.v" 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))

;;;
;;; Make workdir with sources and command file
;;; Returns work directory path string
;;;
(define (make-sim-workdir simulator code top base)
  (let* ((work-dir (mkdtemp (path+ base (format "work-~a-XXXXXX" (current-time)))))
         (verilog-file (path+ work-dir SIM-SV-FILE))
         (command-file (path+ work-dir SIM-VC-FILE))
         (dump-file (create-dump-module work-dir "dump" top)))
    (with-output-to-file verilog-file (cut display code))
    (with-output-to-file command-file
      (lambda ()
        (cond
         ((eq? simulator 'iverilog)
          (println "~a" verilog-file)
          (println "~a" dump-file)
          (println "+define+TESTBENCH")
          (println "+timescale+1ps/1ps")))))
    work-dir))

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

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

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

;;;
;;; Execute simulation
;;;
(define* (exec-sim simulator code base
                   #:key
                   (vvp-exe "vvp")
                   (iverilog-exe "iverilog"))
  (let ((top (module-name code)))
    (if (not top)
        "Error: No module declaration\n"
        (let ((work-dir (make-sim-workdir simulator code top base)))
          (let-values
              (((status log)
                (cond
                 ((eq? simulator 'iverilog)
                  (exec-sim-iverilog work-dir vvp-exe iverilog-exe))

                 (else
                  (values -1 "No simulator found!\n")))))

            ;; Delete work dir
            (when DELETE-WORK-DIR
              (delete-recursive work-dir))

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

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

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

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

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

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

;;;
;;; Web page handler
;;;
(define (make-page-handler host root index-file
                           work-base stor-base
                           max-code-size
                           vvp-exe iverilog-exe
                           verilator-exe)

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

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

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

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

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

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

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

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

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

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

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

            (make-response
             (exec-sim 'iverilog
                       (sanitize-verilog code)
                       work-base
                       #:vvp-exe vvp-exe
                       #:iverilog-exe iverilog-exe)
             #:content-type 'text/plain))

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

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

         ;;
         ;; ---- Unknown requests type
         ;;
         (else
          (logger LOG-DBG "Wrong request method")
          (not-found request)))))))

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

(define (print-help app-name)
  (define (-> . args)
    (display (apply format args) (current-error-port))
    (newline (current-error-port)))
  (let ((app-name (basename app-name)))
    (with-output-to-port (current-error-port)
      (lambda ()
        (-> "Usage: ~a [OPTION]..." app-name)
        (-> "Start Verilog playground WEB server")
        (-> "")
        (-> "Options:")
        (-> "  -a, --addr ADDR          Listen on ADDR address. Default: 127.0.0.1")
        (-> "  -p, --port PORT          Listen on PORT port. Default: 8080")
        (-> "  -s, --host URL           Run on URL hostname. Default: http://127.0.0.1:8080")
        (-> "  -r, --root URN           Service location root. Default: ''")
        (-> "  --ivverilog-exe PATH     Set Icarus Verilog compiler executable. Default: iverilog")
        (-> "  --vvp-exe PATH           Set Icarus Verilog interpreter executable. Default: vvp")
        (-> "  --verilator-exe PATH     Set Icarus Verilog interpreter executable. Default: verilator")
        (-> "  --max-len LEN            Set maximum code size in symbols. Default: 0 (infinite)")
        (-> "  --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 (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-exe") required)
                    '(("iverilog-exe") required)
                    '(("verilator-exe") required)
                    '(("max-len") required)
                    '(("work-base") required)
                    '(("stor-base") required)
                    '(("log-level") required)
                    '(("help" #\h) 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") "")))
          (vvp (string-trim (or (option-get opts "vvp-exe") "vvp")))
          (iverilog (string-trim (or (option-get opts "iverilog-exe") "iverilog")))
          (verilator (string-trim (or (option-get opts "verilator-exe") "verilator")))
          (max-code-size (string->number (string-trim (or (option-get opts "max-len") "0"))))
          (work-base (string-trim (or (option-get opts "work-base") "./")))
          (stor-base (string-trim (or (option-get opts "stor-base") "./")))
          (log-level (string->number (string-trim (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: '~a'" iverilog)
        (logger LOG-INFO "vvp: '~a'" vvp)
        (logger LOG-INFO "verilator: '~a'" verilator)
        (logger LOG-INFO "Max code size: ~a" max-code-size)
        (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
                            vvp iverilog
                            verilator)
         'http `(#:host ,addr #:port ,port)))))))