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

(import chicken scheme)
(require-library tcp json files srfi-13 chickumber)

(import
  chickumber
  (only extras read-line sprintf read-file printf)
  (only data-structures alist-ref)
  (only ports with-input-from-string with-output-to-string)
  (only srfi-1 fold filter)
  (only srfi-13 string=? string-join)
  (only tcp tcp-listen tcp-accept)
  (only regex regexp regexp-escape string-substitute string-match-positions string-search)
  (only irregex string-match)
  (only files pathname-strip-directory)
  (only json json-write json-read))

(define wire-procedures (list))
(define +default-port+ 61616)

;;TODO add exception-handling
(define (handle-wire-request input-port output-port)
  (let loop ((line (read-line input-port)))
    (unless (eof-object? line)
      (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)))
;                                               (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))))))
        (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 stepfiles #!optional (port +default-port+ ))
  (load-step-files stepfiles)
  (let ((listener (tcp-listen port)))
    (let loop ()
      (receive (input-port output-port) (tcp-accept listener)
        (handle-wire-request input-port output-port)
        (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)))))

;; This is the simple default evaluator
;; it signals success if the code evaluates to #t and fails otherwise
(define (boolean-test-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"))))

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

(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
(define (load-step-files paths #!key (reload #f))
  (when reload
    (set! *step-definitions* '())
    (reset-step-id-generator))
  (for-each eval-step-file (filter file-exists? paths)))

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

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