(module emacsclient ()

(import scheme)
(import (chicken base))
(import (chicken blob))
(import (chicken condition))
(import (chicken file))
(import (chicken file posix))
(import (chicken foreign))
(import (chicken format))
(import (chicken io))
(import (chicken irregex))
(import (chicken port))
(import (chicken process-context))
(import (chicken process-context posix))
(import (chicken string))
(import (srfi 1))
(import (except socket socket?))

#> #include <sys/socket.h> <#

(define _linger_size (foreign-value "sizeof(struct linger)" int))

(define (encode-linger-option state time)
  (let ((blob (make-blob _linger_size)))
    ((foreign-lambda* void ((scheme-pointer ptr) (bool onoff) (int linger))
       "struct linger *p = ptr;"
       "p->l_onoff = onoff; p->l_linger = linger;")
     blob state time)
    blob))

(define stderr (current-error-port))
(define getenv get-environment-variable)

(define (die message #!rest args)
  (apply fprintf stderr (string-append message "\n") args)
  (exit 1))

(define xdg-runtime-dir (getenv "XDG_RUNTIME_DIR"))
(define xdg-config-home (getenv "XDG_CONFIG_HOME"))
(define home (getenv "HOME"))
(define tmpdir (getenv "TMPDIR"))
(define appdata (getenv "APPDATA"))
(define uid (current-user-id))

(define (dynamic-wind+ before thunk after)
  (handle-exceptions exn
    (signal exn)
    (dynamic-wind
        before
        thunk
        after)))

(define (default-paths)
  (list
   ;; unix socket
   (getenv "EMACS_SOCKET_NAME")
   (and xdg-runtime-dir (format "~a/emacs/server" xdg-runtime-dir))
   (and tmpdir (format "~a/emacs~a/server" tmpdir uid))
   (format "/tmp/emacs~a/server" uid)

   ;; tcp config
   (getenv "EMACS_SERVER_FILE")
   (and home xdg-config-home (format "~a/~a/emacs/server/server"
                                     home xdg-config-home))
   (and home (format "~a/.config/emacs/server/server" home))
   (and home (format "~a/.emacs.d/server/server" home))
   (and appdata xdg-config-home (format "~a/~a/emacs/server/server"
                                        appdata xdg-config-home))
   (and appdata (format "~a/.config/emacs/server/server" appdata))
   (and appdata (format "~a/.emacs.d/server/server" appdata))))

(define (default-path)
  (find (lambda (path) (and path (file-exists? path))) (default-paths)))

(define quote-control-characters '("&" "-" "\n" " "))
(define quoted-control-characters '("&&" "&-" "&n" "&_"))
(define quote-string-map
  (map cons quote-control-characters quoted-control-characters))
(define unquote-string-map
  (map cons quoted-control-characters quote-control-characters))

(define (encode string) (string-translate* string quote-string-map))
(define (decode string) (string-translate* string unquote-string-map))

(define (parse-tcp-config path)
  (call-with-input-file path
    (lambda (in)
      (and-let* ((meta (irregex-match "([^: ]+):([0-9]+) .+" (read-line in)))
                 (host (irregex-match-substring meta 1))
                 (port (string->number (irregex-match-substring meta 2)))
                 (secret (read-line in))
                 ((irregex-match "[!-~]{64}" secret)))
        `((host . ,host)
          (port . ,port)
          (secret . ,secret))))))

(define (call-with-socket so proc)
  (dynamic-wind+
   (lambda () #f)
   (lambda () (proc so))
   (lambda () (socket-close so))))

(define (open-unix-socket path)
  (let ((so (socket af/unix sock/stream)))
    (socket-connect so (unix-address path))
    so))

(define (open-tcp-socket host port)
  (let* ((addrs (address-information host port type: sock/stream))
         (so (socket-connect/ai addrs)))
    (set-socket-option so sol/socket so/linger (encode-linger-option #t 1))
    so))

(define (read-from-socket so)
  (define buf-size 8192)
  (with-output-to-string
    (lambda ()
      (let ((buffer "")
            (index 0))
        (let loop ()
          (let ((chunk (socket-receive so buf-size)))
            (set! buffer (string-append buffer chunk))
            (when (not (equal? chunk ""))
              (if (irregex-search "^-error " buffer index)
                  (let* ((beg (substring-index " " buffer index))
                         (arg (decode (substring buffer beg))))
                    (error arg))
                  (let loop ()
                    (let ((end (substring-index "\n" buffer index)))
                      (when end
                        (let* ((line (substring buffer index end))
                               (args (string-split (string-chomp line) " "))
                               (command (car args))
                               (arg (decode (cadr args))))
                          (set! index (add1 end))
                          (cond
                           ((equal? command "-emacs-pid"))
                           ((member command '("-print" "-print-nonl"))
                            (display arg))
                           (else
                            (error "unknown command" command arg))))
                        (loop)))))
              (loop))))))))

(define (unix-eval path code)
  (call-with-socket (open-unix-socket path)
    (lambda (so)
      (socket-send so (format "-eval ~a\n" (encode code)))
      (read-from-socket so))))

(define (tcp-eval path code)
  (let ((config (parse-tcp-config path)))
    (when (not config)
      (error "failed parsing TCP config" path))
    (let ((host (alist-ref 'host config))
          (port (alist-ref 'port config))
          (secret (alist-ref 'secret config)))
      (call-with-socket (open-tcp-socket host port)
        (lambda (so)
          (socket-send so (format "-auth ~a -eval ~a\n" secret (encode code)))
          (read-from-socket so))))))

(define (eval-elisp path code)
  (case (file-type path)
    ((socket) (unix-eval path code))
    ((regular-file) (tcp-eval path code))
    (else (error "unsupported file type" (file-type path) path))))

(define main
  (case-lambda
   ((code)
    (let ((path (or (default-path) (getenv "EMACSCLIENT_FILE")
                    (die "couldn't detect path"))))
      (print (eval-elisp path code))))
   (_
    (die "usage: ~a <code>" (program-name)))))

(apply main (command-line-arguments))

)