;; 
;; %%HEADER%%
;;

(module chickumber-server
(+default-port+
 start-wire-server
 load-step-files!
 find-wire-procedure
 add-wire-procedure!
 wire-procedures
 define-wire-procedure
 find-and-apply-wire-procedure
 handle-wire-request
 wrap-wire-procedure
 current-exit-continuation
 fail succeed pending suggest-step-snippet-for
 current-step-evaluator
 boolean-step-evaluator
 test-step-evaluator
 missbehave-step-evaluator
 current-step-evaluator-dependencies
 )

(import chicken scheme)
(require-library tcp json files srfi-13 chickumber test posix defstruct missbehave)



(import
  chickumber
  test
  defstruct
  (except missbehave pending $)
  (only posix file-modification-time glob current-directory directory? set-signal-handler! signal/int signal/hup signal/term signal/quit)
  (only extras read-line sprintf read-file printf)
  (only data-structures alist-ref conc)
  (only ports with-input-from-string with-output-to-string)
  (only srfi-1 fold filter any)
  (only srfi-13 string=? string-join)
  (only tcp tcp-listen tcp-accept tcp-close)
  (only regex regexp regexp-escape string-substitute string-match-positions string-search)
  (only irregex string-match)
  (only files pathname-strip-directory normalize-pathname absolute-pathname?)
  (only json json-write json-read))

(define wire-procedures (list))
(define +default-port+ 61616)
(define *current-step-files* (list))

(define (handle-wire-request input-port output-port #!key (debug #f))
  (let loop ((line (read-line input-port)))
    (unless (eof-object? line)
     
      (reload-step-files-if-needed)
      
      (let* ((request   (with-input-from-string line json-read))
             (message   (car request))
             (arguments (if (> (length request) 1) (cdr request) '()))
             (response  (find-and-apply-wire-procedure message arguments)))
        (when debug
          (printf "Read: ~S ~%" line)
          (printf "Write: ~S =>  ~S~%" response (with-output-to-string (lambda () (json-write (or response (make-message-not-understood-response message arguments)))))))
        (display ".")
        (flush-output (current-output-port))
        (json-write (or response (make-message-not-understood-response message arguments)) output-port)
        (newline output-port)
        (flush-output output-port)
        (loop (read-line input-port))))))

(define (start-wire-server additional-files #!key (framework 'boolean) (port +default-port+) (debug #f) (on-shutdown values) (on-sig-hup values))
  (with-test-framework
   framework
   (lambda ()
     (load-step-files! (discover-step-files additional-files))
     (set-signal-handler! signal/hup (lambda (sig)
                                       (on-sig-hup)
                                       (load-step-files! (discover-step-files additional-files) reload: #t)))
     
     (let* ((listener (tcp-listen port))
            (shutdown (lambda (sig)
                        (tcp-close listener)
                        (on-shutdown))))
       
       (for-each (cut set-signal-handler! <> shutdown)
                 (list signal/int signal/term signal/quit))
       
       (let loop ()
         (receive (input-port output-port) (tcp-accept listener)           
           (handle-wire-request input-port output-port debug: debug)
           (close-input-port input-port)
           (close-output-port output-port))
         (loop))))))

(define (find-wire-procedure message)
  (alist-ref message wire-procedures string=?))

(define (add-wire-procedure! message procedure)
  (set! wire-procedures (cons (cons message procedure) wire-procedures)))

(define-syntax define-wire-procedure
  (syntax-rules ()
    ((_ message (argument ...) code more-code ...)
     (add-wire-procedure! message (wrap-wire-procedure (list (symbol->string (quote argument)) ...)
                                                       (lambda (argument ...) code more-code ...))))))

(define ((wrap-wire-procedure wanted-argument-names procedure) #!optional (arguments #f))
  (if arguments
      (let ((wanted-arguments (extract-wanted-arguments wanted-argument-names arguments)))
        (apply procedure wanted-arguments))
      (procedure)))

(define (extract-wanted-arguments argument-names arguments)
  (let ((arguments (vector->list arguments)))
    (map (lambda (argument-name)
           (alist-ref argument-name arguments string=?))
         argument-names)))

(define (find-and-apply-wire-procedure message arguments)
  (let ((procedure (find-wire-procedure message)))
    (if (procedure? procedure)
        (apply procedure arguments)
        #f)))

(define (make-message-not-understood-response message args)
  (fail (sprintf "Unknown wire-message: ~A with arguments ~A" message args)))

(define (succeed #!optional (arguments #f))
  (if arguments
      (list "success" arguments)
      (list "success")))

(define (fail message #!optional (backtrace #f) (exn #f))
  (cond
   ((and backtrace exn)
    `("fail" #(("message" . ,message) ("backtrace" . ,backtrace) ("exception" . ,exn))))
   (backtrace
    `("fail" #(("message" . ,message) ("backtrace" . ,backtrace))))
   (exn
    `("fail" #(("message" . ,message) ("exception" . ,exn))))
   (else
    `("fail" #(("message" . ,message))))))

(define-wire-procedure "step_matches" (name_to_match)
  (define (convert-submatches submatch-positions)
    (map (lambda (pair)
           `#(("val" . ,(substring name_to_match (car pair) (cadr pair)))
              ("pos" . ,(car pair))))
         submatch-positions))
  
  (define (step-selector step result)
    (let* ((step-rx (step-regex step))
           (id      (step-id step))
           (matches (string-match-positions step-rx name_to_match)))
      (if matches
          (let ((submatches (convert-submatches (cdr matches))))
            (if (null? submatches)
                (cons `#(("id" . ,(number->string id)) ("args") ("regexp" . ,(step-regex-string step)) ("source" . ,(step-source step))) result)
                (cons `#(("id" . ,(number->string id)) ("args" ,@submatches) ("regexp" . ,(step-regex-string step)) ("source" . ,(step-source step))) result)))
          result)))
  (succeed
   (fold step-selector '() *step-definitions*)))

(define-wire-procedure "snippet_text" (step_keyword step_name multiline_arg_class)
  (succeed (suggest-step-snippet-for step_keyword step_name)))

(define (suggest-step-snippet-for keyword step-name)
  (receive (new-rx capture-arguments) (translate-step-name step-name)
    (with-output-to-string
      (lambda ()
        (print "(" keyword " #/^" new-rx "$/ (" (string-join capture-arguments) ")")
        (print "  ;write the code you wish you had")
        (display "  (pending))")))))

(define (translate-step-name step-name)
  (let* ((rx (regexp "\"([^\"]*)\""))
         (escaped-step-name (regexp-escape step-name))
         (captures (string-search rx escaped-step-name)))
    (values
     (string-substitute rx "\"([^\"]+)\"" escaped-step-name)
     (if captures
         (let ((index 0))
           (map (lambda (_)
                  (set! index (+ index 1))
                  (sprintf "arg~A" index))
                (cdr captures)))
         '()))))

(define-wire-procedure "begin_scenario" ()
  (apply-hooks 'before)
  (succeed))

(define-wire-procedure "end_scenario" ()
  (apply-hooks 'after)
  (succeed))

(define-wire-procedure "invoke" (id args)
  (let ((step (find-step (string->number id))))
    (if step
        (run-step step args)
        (fail (sprintf "There is no step with id ~A" id)))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Stepevaluators
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;; This is the simple default evaluator
;; it signals success if the code evaluates to #t and fails otherwise
(define (boolean-step-evaluator step args)
  (handle-exceptions exn
      (begin
        (fail ((condition-property-accessor 'exn 'message) exn)
              backtrace: ((condition-property-accessor 'exn 'location) exn)))
    (if (apply (step-code step) args)
        (succeed)
        (fail "Step failed"))))

(define (assq-ref ls key . o)
  (cond ((assq key ls) => cdr)
        ((pair? o) (car o))
        (else #f)))

(define (collect-test-error status expect expr info)
  (with-output-to-string
    (lambda ()
      (cond
       ((eq? status 'ERROR)
        (cond ((assq 'exception info)
               => (lambda (e)
                    (print-error-message (cdr e) (current-output-port))))))
       ((and (eq? status 'FAIL) (assq-ref info 'assertion))
        (display "assertion failed\n"))
       ((and (eq? status 'FAIL) (assq-ref info 'expect-error))
        (display "expected an error but got ")
        (write (assq-ref info 'result)) (newline))
       ((eq? status 'FAIL)
        (display "expected ") (write (assq-ref info 'expected))
        (display " but got ") (write (assq-ref info 'result)) (newline))))))

(define (test-step-evaluator step args)
  (let ((errors '()))
    (define (test-handler status expect expr info)
      (when (or (eq? status 'ERROR) (eq? status 'FAIL))
        (set! errors (cons (collect-test-error status expect expr info) errors))))

    (let ((original-test-applier (current-test-applier)))
      (parameterize ((current-test-handler test-handler)
                     (current-test-verbosity #f)
                     (current-test-group-reporter (lambda (_) #t))
                     (current-test-applier (lambda args
                                             (parameterize ((current-output-port (open-output-string)))
                                               (apply original-test-applier args)))))
        (handle-exceptions exn
            (begin
              (fail ((condition-property-accessor 'exn 'message) exn)
                    backtrace: ((condition-property-accessor 'exn 'location) exn)))
        
          (apply (step-code step) args)
          (if (null? errors)
              (succeed)
              (fail (string-join errors "\n"))))))))

(define (missbehave-step-evaluator step args)
  (let ((errors '()))
    (define (reporter data #!key (mode 'adhoc))
      (when (and (eq? mode 'adhoc)
                 (example-result? data)
                 (example-failed? data))
        (set! errors (cons (example-result-messages data) errors))))
    (handle-exceptions exn
        (begin
          (fail ((condition-property-accessor 'exn 'message) exn)
                backtrace: ((condition-property-accessor 'exn 'location) exn)))
      (run-specification
       (call-with-specification
        (make-empty-specification)
        (lambda ()
          (describe "Step"
             (it "runs"
                (apply (step-code step) args)))))
       reporter: reporter))
    (if (null? errors)
        (succeed)
        (fail (string-join errors "\n")))))

;; this parameter is the adapter to plug in
;; custom step-evaluators that are aware of the test-mechanism used.
(define current-step-evaluator    (make-parameter boolean-step-evaluator))
(define current-step-evaluator-dependencies (make-parameter '()))
(define current-step-evaluator-prolog (make-parameter '()))

(define (with-test-framework framework thunk)
  (case framework
    ((boolean)
     (parameterize ((current-step-evaluator boolean-step-evaluator))
       (thunk)))
    ((missbehave)
     (parameterize ((current-step-evaluator missbehave-step-evaluator)
                    (current-step-evaluator-prolog `((require-extension (except missbehave pending $)))))
       (thunk)))
    ((test)
     (parameterize ((current-step-evaluator test-step-evaluator)
                    (current-step-evaluator-dependencies '(test)))
       (thunk)))
    (else (error "Invalid test-framework given"))))

(define (run-step step args)
  (call-with-current-continuation
   (lambda (exit)
     (parameterize ((current-exit-continuation (lambda (message)
                                                 (if message
                                                     (exit (list 'pending message))
                                                     (exit (list 'pending))))))
       ((current-step-evaluator) step args)))))

;; load steps
(defstruct stepfile path last-modified)

(define (create-step-file path)
  (if (stepfile? path)
      path
      (make-stepfile path: path last-modified: (file-modification-time path))))

(define (default-step-files)
  (let loop ((defaults (map absolutize-path (list "features/support" "features/step_definitions")))
             (files '()))
    (cond
     ((null? defaults) (reverse files))
     ((directory? (car defaults))
       (loop (cdr defaults) (add-files-from-directory (car defaults) files)))
     (else (loop (cdr defaults) files)))))

(define (discover-step-files arguments)
  (let loop ((arguments arguments) (step-files (default-step-files)))
    (if (null? arguments) (reverse step-files)
        (let ((full-path (absolutize-path (car arguments))))
          (if (directory? full-path)
              (loop (cdr arguments) (add-files-from-directory full-path step-files))
              (loop (cdr arguments) (cons (create-step-file full-path) step-files)))))))

(define (add-files-from-directory directory step-files)
  (map create-step-file (fold cons step-files (glob (conc directory "/*.scm")))))

(define (absolutize-path path)
  (if (absolute-pathname? path)
      (normalize-pathname path)
      (normalize-pathname (conc (current-directory) "/" path))))

(define (load-step-files! files #!key (reload #f))
  (when reload
    (set! *step-definitions* '())
    (reset-step-id-generator))
  (let ((step-files (filter (lambda (file) (file-exists? (stepfile-path file))) files)))
    (set! *current-step-files*
      (map (lambda (file)
             (update-stepfile file last-modified: (file-modification-time (stepfile-path file))))
           step-files))
    (for-each eval-step-file step-files)))

(define (reload-step-files-if-needed)
  (when (any reload-needed? *current-step-files*)
    (load-step-files! *current-step-files* reload: #t)))

(define (reload-needed? file)
  (let ((path (stepfile-path file))
        (mtime (stepfile-last-modified file)))
    (and (file-exists? path)
         (> (file-modification-time path) mtime))))

(define (eval-step-file file)
  (let ((content (read-file (stepfile-path file))))
    (unless (null? content)
      (eval (decorate-content content (pathname-strip-directory (stepfile-path file)))))))

(define (decorate-content content file)
  (cond-expand
    (development
     `(begin
        (use regex ,@(current-step-evaluator-dependencies))
        ,@(current-step-evaluator-prolog)
        (load "chickumber.scm")
        (import chickumber)
        (parameterize ((current-steps-file ,file))
          ,@content)))
    (else
     `(begin
        (use regex ,@(current-step-evaluator-dependencies))
        ,@(current-step-evaluator-prolog)
        (require-extension chickumber)
        (parameterize ((current-steps-file ,file))
          ,@content))))))