uim-skkserv.scm

;; skkserv
(require-extension (srfi 1 48))

(require "util.scm")
(require "socket.scm")
(require "i18n.scm")
(require "input-parse.scm")
(require-dynlib "look")

(define socks (tcp-listen "localhost" 1178))
(define dict (string-append (home-directory (user-name)) "/.uim.d/dict/SKK-JISYO"))
(define cand-max 1000)

;; XXX: srfi-13
(define (string-concatenate-reverse strs final end)
  (define (string-xcopy! target tstart s sfrom sto)
    (do ((i sfrom (inc i)) (j tstart (inc j)))
        ((>= i sto))
      (string-set! target j (string-ref s i))))
  (if (null? strs) (substring final 0 end)
    (let*
      ((total-len
	 (let loop ((len end) (lst strs))
	   (if (null? lst) len
	     (loop (+ len (string-length (car lst))) (cdr lst)))))
	(result (make-string total-len)))
      (let loop ((len end) (j total-len) (str final) (lst strs))
	(string-xcopy! result (- j len) str 0 len)
	(if (null? lst) result
	  (loop (string-length (car lst)) (- j len)
	    (car lst) (cdr lst)))))))

(define (skk-parse-line line)
  (define (skk-key-state port)
    (next-token '(#\space #\tab) '(#\space *eof*) (N_ "Invalid skk entry") port))
  (define (skk-entry-state port)
    (and (eq? #\/ (skip-while '(#\space #\tab) port))
         (let loop ((val (next-token '(#\/) '(#\/ *eof*) (N_ "Invalid skk value") port))
                    (rest '()))
           (if (or (eof-object? val)
                   (string=? val ""))
                 (reverse rest)
                 (loop (next-token '(#\/) '(#\/ *eof*) (N_ "Invalid skk value") port)
                       (cons val rest))))))
  (call-with-input-string line
                          (lambda (port)
                            (and-let* ((key (skk-key-state port))
                                       (value (skk-entry-state port)))
                                      (values key value)))))

(define (skkserv:receive-search s exact-match?)
  (define (read-word c rest)
    (cond ((eof-object? c)
           (values #f (list->string (reverse rest))))
          ((eq? (car c) #\space)
           (values #t (list->string (reverse rest))))
          (else
           (read-word (file-read s 1) (cons (car c) rest)))))
  (define (normalize sl) ;; drop noise
    (let ((ent (find-tail (lambda (c) (eq? c #\/))
                          (reverse (string->list sl)))))
      (if ent
          (list->string (reverse ent))
          "")))
  (receive (cont? ret)
      (read-word (file-read s 1) '())
    (let ((look (look-lib-look #f #f cand-max dict ret))) ;; return raw text (text1 text2 ...)
      (if (null? look)
          (begin
            ;; not found
            (file-write s '(#\4 #\space))
            #t)
          (let* ((recv-cand (filter-map (lambda (ent)
                                          (receive (key value)
                                              (skk-parse-line (string-append ret (normalize ent)))
                                            (if exact-match?
                                                (if (string=? key ret)
                                                    value
                                                    #f)
                                                value)))
                                        look))
                 (recv-string (string-join (apply append recv-cand) "/")))
            ;;(print recv-string)
            (if (string=? recv-string "")
                (file-write s '(#\4 #\space))
                (begin
                  (file-write s '(#\1 #\/))
                  (file-write s (string->list recv-string))
                  (file-write s '(#\/ #\newline))))
            #t)))))


(define (skkserv:receive-version s)
  ;;(file-write s (string->list (uim-version))))
  (file-write s '(#\1 #\. #\0 #\space)))

(define (skkserv:receive-hostname s)
  ;; XXX
  (file-write s (string->list (format "~a:~a: " "localhost" "0.0.0.0"))))

(define (read-req s)
  (define (reqno? c)
    (find (lambda (x) (eq? c x)) '(#\0 #\1 #\2 #\3 #\4)))
  (let loop ((c (file-read s 1)))
    (if (or (eof-object? c)
            (reqno? (car c)))
        c
        (loop (file-read s 1)))))

(define server (make-tcp-server
                (lambda (s)
                  ;;(display "connected.\n")
                  (let loop ((req (read-req s)))
                    (if (eof-object? req)
                        (file-close s)
                        (let ((reqno (car req)))
                          ;;(write `(reqno ,reqno))(newline)
                          (cond ((eq? reqno #\0)
                                 (file-close s))
                                ((eq? reqno #\1)
                                 (if (skkserv:receive-search s #t)
                                     (loop (read-req s))
                                     (file-close s)))
                                ((eq? reqno #\2)
                                 (skkserv:receive-version s)
                                 (loop (read-req s)))
                                ((eq? reqno #\3)
                                 (skkserv:receive-hostname s)
                                 (loop (read-req s)))
                                ((eq? reqno #\4)
                                 (if (skkserv:receive-search s #f)
                                     (loop (read-req s))
                                     (file-close s)))
                                (else
                                 (loop (read-req s))))))))))

;;(display "skkserver starting.\n")
(server socks)