(define last-id (make-parameter 0))

(define (increment-last-id!)
  (last-id (+ 1 (last-id))))

(define-syntax define-request-handler
  (syntax-rules ()
    ((define-request-handler (handler params #:exit? exit?) body ...)
     (define (handler out-port params)
       (when (and (shutting-down?) (not exit?))
         (raise (make-json-rpc-invalid-request-error
                 "Only exit request allowed after shutdown.")))
       (write-log 'debug
                  (format "Handler ~a called with params ~s"
                          'handler
                          (truncate-string (format "~a" params))))
       body ...))
    ((define-request-handler (handler out-port params) body ...)
     (define-request-handler (handler out-port params #:exit? #f) body ...))))

;;; Notification handlers always return #f, what causes json-rpc-loop not
;;; to send an answer to the caller.
(define-syntax define-notification-handler
  (syntax-rules ()
    ((define-notification-handler (handler out-port params #:exit? exit?) body ...)
     (define (handler params)
       (when (and (shutting-down?) (not exit?))
         (raise (make-json-rpc-invalid-request-error
                 "Only exit request allowed after shutdown.")))
       (write-log 'debug
                  (format "Handler ~a called with params ~s"
                          'handler
                          (truncate-string (format "~a" params))))
       body ... #f))
    ((define-notification-handler (handler params) body ...)
     (define-notification-handler (handler params #:exit? #f) body ...))))

(define (json-rpc-call in-port out-port method params)
  (json-rpc-write `((id . ,(last-id))
                    (method . ,method)
                    (params . ,params))
                  out-port)
  (increment-last-id!)
  (let ((response (json-rpc-read in-port)))
    (write-log 'debug
               (format "json-rpc-call response: ~a" response))
    (cond ((list? response)
           (let ((result (assoc 'result response))
                 (err (assoc 'error response)))
             (cond (result => cdr)
                   (err (error (cdr err)))
                   (else (error "invalid response: " err)))))
          (else response))))

(define (json-rpc-send-notification out-port method params)
  (write-log 'debug
             (format "json-rpc-send-notification method: ~s ~s"
                     method
                     params))
  (json-rpc-write `((method . ,method)
                    (params . ,params))
                  out-port))

(define json-rpc-send-request json-rpc-call)

(define (json-rpc-call/tcp tcp-address tcp-port-number method params)
  (let-values (((in-port out-port)
                (tcp-connect tcp-address tcp-port-number)))
    (let ((res (json-rpc-call in-port out-port method params)))
      (close-output-port out-port)
      (close-input-port in-port)
      res)))

(define json-rpc-start-server/tcp
  (case-lambda
   ((tcp-port-number tcp-error-port-number)
    (let-values (((in-err-port out-err-port)
                  (tcp-connect "127.0.0.1" tcp-error-port-number)))
      (parameterize ((current-error-port out-err-port))
        (json-rpc-start-server/tcp tcp-port-number))))
   ((tcp-port-number)
    (parameterize ((tcp-read-timeout #f))
      (let ((listener (tcp-listen tcp-port-number)))
        (write-log 'info
                   (format "listening on port ~a with log level ~a~%"
                           tcp-port-number
                           (json-rpc-log-level)))
        (guard
         (condition (#t (begin
                          (write-log 'error (format "JSON-RPC error: ~a" condition))
                          (cond-expand (chicken (print-error-message condition))
                                       (else (display condition)))
                          #f)))
         (let loop ()
           (let-values (((in-port out-port)
                         (tcp-accept listener)))
             (if (eqv? (json-rpc-loop in-port out-port) 'json-rpc-exit)
                 (begin
                   (close-input-port in-port)
                   (close-output-port out-port)
                   (tcp-close listener))
                 (begin
                   (write-log 'debug (format "Accepted incoming request"))
                   (loop)))))))))))