(cond-expand
 (chicken
  ;;; defaults to the medea library
  (define json-string->scheme
    (make-parameter (lambda (j)
                      (call-with-input-string j
                        read-json))))

  (define scheme->json-string
    (make-parameter (lambda (scm)
                      (json->string scm)))))
 (guile
  (define json-string->scheme
    (make-parameter
     (lambda (j)
       (call-with-input-string j
         (lambda (p)
           (json-read p))))))
  (define scheme->json-string
    (make-parameter (lambda (scm)
                      (call-with-output-string
                        (lambda (p) (json-write scm p)))))))
 (else
  (define json-string->scheme
    (make-parameter #f))
  (define scheme->json-string
    (make-parameter #f))))


(define json-rpc-log-level (make-parameter 2))

(define core-error-codes
  '((parse-error . -32700)
    (invalid-request . -32600)
    (method-not-found . -32601)
    (invalid-parameters . -32602)
    (internal-error . -32603)))

(define custom-error-codes
  (make-parameter '()))

(define (error-codes)
  (append core-error-codes (custom-error-codes)))

(define error-code-to-symbol-map
  (map (lambda (p)
         (cons (cdr p) (car p)))
       (error-codes)))

(define json-rpc-handler-table
  (make-parameter '() (lambda (alist)
                        (alist->hash-table alist equal?))))

(define (json-rpc-loop in-port out-port)
  (guard
      (condition
       ((eq? condition 'json-rpc-exit)
        (write-log 'info "Closing JSON-RPC server.")
        'json-rpc-exit)
       (else (raise condition)))
    (let loop ((request (json-rpc-read in-port)))
      (cond ((eof-object? request)
             (write-log 'info "connection closed on other end-point\r\n")
             #f)
            ((not request)
             (write-log 'warning
                        (format "unknown command: ~a~%" request))
             (loop (json-rpc-read in-port)))
            (else
             (begin
               (write-log 'debug
                          (format "received json: ~a~%" request))
               (json-rpc-respond request out-port)
               (loop (json-rpc-read in-port))))))))

(define (json-rpc-read in-port)
  (define line (read-line in-port))
  (if (eof-object? line)
      (eof-object)
      (let* ((request (string-trim line)))
        (write-log 'debug
                   (format "REQUEST ~a~%" request))
        (cond ((eof-object? request)
               (write-log 'info "<eof>\r\n")
               request)
              ((< (string-length request) 17)
               (write-log 'warning
                          (format "unknown command: ~a~%" request))
               #f)
              (else
               (let ((header-prefix (substring request 0 16)))
                 (if (string=? header-prefix "Content-Length: ")
                     (let ((num (string->number
                                 (string-trim-right
                                  (substring request 16)))))
                       (write-log
                        'debug
                        (format "Receiving input of length ~a~%" num))
                       (let* ((contents
                               (string-trim-both (read-string (+ 2 num)
                                                              in-port))))
                         ((json-string->scheme) contents)))
                     (begin (write-log 'error "ill-formed header" request)
                            #f))))))))

(define (json-rpc-write scm . args)
  (define str ((scheme->json-string) scm))
  (define port
    (if (not (null? args))
        (car args)
        (current-output-port)))
  (write-string (format "Content-Length: ~a\r\n\r\n"
                        (+ 2 (string-length str)))
                port)
  (write-string str port)
  (newline port)
  (newline port)
  (flush-output-port port))

(define (json-rpc-respond request out-port)
  (define response (json-rpc-compute-response request))
  (when response
    (write-log 'debug "responding with: ")
    (write-log 'debug
               (with-output-to-string
                 (lambda ()
                   (json-rpc-write response))))
    (json-rpc-write response out-port)))

(define (json-rpc-compute-response request)
  (define id (alist-ref 'id request))
  (guard (condition
          ((json-rpc-error? condition)
           (write-log 'error (format "~a" condition))
           (make-response id
                          #f
                          (cdr condition))))
    (json-rpc-dispatch request)))

(define (json-rpc-dispatch request)
  (define (dispatch j)
    (let* ((method-pair (assoc 'method j))
           (params-pair (assoc 'params j)))
      (unless (and method-pair params-pair)
        (raise (make-json-rpc-invalid-request-error)))
      (let* ((method (hash-table-ref/default
                      (json-rpc-handler-table)
                      (cdr method-pair)
                      #f)))
        (unless method
          (raise (make-json-rpc-method-not-found-error (cdr method-pair))))
        (if params-pair
            (let ((params (extract-params params-pair)))
              (method params))
            (method)))))
  (define id (assoc 'id request))
  (let ((result (or (dispatch request) 'null)))
    (cond (id (make-response (cdr id)
                             result
                             #f))
          (else #f))))

(define (json-rpc-exit)
  (raise 'json-rpc-exit))

(define (make-response id result err)
  (let ((content (if err
                     (cons 'error err)
                     (cons 'result result))))
    (if id
        `((jsonrpc . "2.0")
          (id . ,id)
          ,content)
        `((jsonrpc . "2.0")
          ,content))))

(define (extract-params params-pair)
  (let ((params (cdr params-pair)))
    (if (vector? params)
        (vector->list params)
        params)))

(define-syntax define-json-rpc-error
  (syntax-rules ()
    ((define-json-rpc-error ctor pred error-symbol msg)
     (begin
       (define (ctor . args)
         (let ((full-msg (if (null? args)
                             msg
                             (string-append msg ": " (car args)))))
           (cons error-symbol
                 `((message . ,full-msg)
                   (code . ,(alist-ref error-symbol
                                       (error-codes)))))))
       (define (pred condition)
         (and (pair? condition)
              (eqv? (car condition) error-symbol)))))))

(define-json-rpc-error
  make-json-rpc-internal-error
  json-rpc-internal-error?
  'internal-error
  "Internal error")

(define-json-rpc-error
  make-json-rpc-invalid-request-error
  json-rpc-invalid-request-error?
  'invalid-request
  "Invalid request error")

(define-json-rpc-error
  make-json-rpc-method-not-found-error
  json-rpc-method-not-found-error?
  'method-not-found
  "Method not found")

(define (make-json-rpc-custom-error error-symbol msg)
  (cons error-symbol
        `((message . ,msg)
          (code . ,(alist-ref error-symbol (custom-error-codes))))))

(define (json-rpc-custom-error? condition)
  (and (pair? condition)
       (let ((tag (car condition)))
         (member tag
                 (map car (custom-error-codes))))))

(define (json-rpc-error? condition)
  (and (pair? condition)
       (let ((tag (car condition)))
         (member tag
                 (map car (error-codes))))))

(define (json-rpc-error-contents err)
  (cdr err))

(define (get-log-level symb)
  (cond ((eqv? symb 'error) 0)
        ((eqv? symb 'warning) 1)
        ((eqv? symb 'info) 2)
        ((eqv? symb 'debug) 3)
        (else (error "invalid log level" symb))))

(define (write-log type msg . args)
  (define level (get-log-level type))
  (when (<= level (json-rpc-log-level))
    (display (format "[~a] ~a"
                     (string-upcase (symbol->string type))
                     msg))
    (when (not (null? args))
      (display ": ")
      (map (lambda (s)
             (display (format "~a    " s)))
           args))
    (newline)
    (flush-output-port)))

(cond-expand
 (guile
  (define (alist-ref key alist)
    (define match (assoc key alist))
    (if match
        (cdr match)
        #f)))
 (else))