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

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

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

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

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

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

           ;; 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)
             #: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)))
                 #: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")
        (-> "  --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)
                    '(("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")))
          (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 "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)
         'http `(#:host ,addr #:port ,port)))))))