
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; MODULE      : server-chat.scm
;; DESCRIPTION : Sending messages and chatting, server side
;; COPYRIGHT   : (C) 2020  Joris van der Hoeven
;;
;; This software falls under the GNU general public license version 3 or later.
;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(texmacs-module (server server-chat)
  (:use (server server-tmfs)
        (server server-notifications)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Chat rooms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (chat-room-create uid name)
  (with-time-stamp #t
    (db-create-entry `(("type" "chat-room")
                       ("name" ,name)
                       ("owner" ,uid)
                       ("readable" "all")
                       ("writable" "all")))))

(tm-service (remote-chat-room-create name)
  ;; Create chat room and return its identifier
  ;;(display* "remote-chat-room-create " name "\n")
  (with uid (server-get-user envelope)
    (with crid (chat-room-create uid name)
      (server-return envelope crid))))

(define (chat-room-id name)
  (with l (db-search `(("type" "chat-room")
                       ("name" ,name)))
    (and (nnull? l) (car l))))

(tm-define (search-remote-identifier u)
  (:require (string-starts? (url->string u) "tmfs://chat/"))
  (chat-room-id (url->string (url-tail u))))

(tm-service (remote-list-chat-rooms)
  ;; Return list of chat rooms owned by the user as (name date) pairs
  ;;(display* "remote-list-chat-rooms\n")
  (with (client msg-id) envelope
    (let* ((uid (server-get-user envelope))
           (l (db-search `(("type" "chat-room")
                           ("owner" ,uid))))
           (get-entry (lambda (id)
                        (let* ((name (db-get-field-first id "name" #f))
                               (date (db-get-field-first id "date" "")))
                          (list name date))))
           (entries (map get-entry l))
           (r (list-filter entries
                           (lambda (e) (not (string-starts? (car e) "mail-"))))))
      (server-return envelope r))))

(define chat-room-messages (make-ahash-table))
(define chat-room-present  (make-ahash-table))

(define (msg-is-shared? msg)
  (with (action pseudo full-name date doc to) msg
    (== action "share")))

(define (resolve-resource-id rid old-url)
  ;; Given a resource database ID, resolve it to the current URL
  (and-let* ((rtype (db-get-field-first rid "type" #f))
             (name (db-get-field-first rid "name" #f))
             (sname (tmfs-car (tmfs-cdr (url->string (url-unroot old-url))))))
    ;(display* "resolving " rid " of type " rtype " with name " name " and old-url " old-url "\n")
    ;(display* " got name = " name " and sname = " sname "\n")
    (cond ((== rtype "live") (string-append "tmfs://live/" sname "/" name))
          ((== rtype "chat-room")
           (string-append "tmfs://chat/" sname "/" name))
          ((or (== rtype "file") (== rtype "dir"))
           (string-append "tmfs://"
                          (if (== rtype "dir") "remote-dir" "remote-file")
                          "/" sname "/" (resource->file-name rid)))
          (else #f))))

(define (chat-message-retrieve mid)
  (let* ((action (db-get-field-first mid "action" "unknown"))
         (msg (db-get-field-first mid "message" "unknown"))
         (from (db-get-field-first mid "from" "unknown"))
         (to (db-get-field-first mid "to" "unknown"))
         (pseudo (db-get-field-first from "pseudo" "unknown"))
         (pseudo-to (db-get-field-first to "owner" "unknown"))
         (full (db-get-field-first from "name" "unknown"))
         (date (db-get-field-first mid "date" "unknown"))
         (rid (db-get-field-first mid "resource-id" #f)))
    (when (== action "send")
      (with doc (string-load (repository-get msg))
        (set! msg (convert doc "texmacs-snippet" "texmacs-stree"))))
    (when (== action "share")
      ;(display* "got rid for message: " rid "\n")
      (when rid
        (and-with current-url (resolve-resource-id rid msg)
          (set! msg current-url))))
    (list action pseudo full date msg pseudo-to)))

(define (chat-room-retrieve crid)
  (with l (db-search `(("type" "chat-message")
                       ("to" ,crid)
                       (:order "date" #t)))
    (map chat-message-retrieve l)))

(define (chat-messages-sent uid pred?)
  (with l (db-search `(("type" "chat-message")
                       ("from" ,uid)
                       (:order "date" #t)))
        (list-filter (map chat-message-retrieve l) pred?)))

(define (chat-room-initialize crid)
  (when (not (ahash-ref chat-room-messages crid))
    (ahash-set! chat-room-messages crid (chat-room-retrieve crid))
    (ahash-set! chat-room-present  crid (list))))

(define (ensure-chat-room client crid)
  (chat-room-initialize crid)
  (with l (ahash-ref chat-room-present crid)
    (when (nin? client l)
      (ahash-set! chat-room-present crid (cons client l)))))

(tm-define (chat-room-messages-reset)
  (set! chat-room-messages (make-ahash-table)))

(tm-service (remote-chat-room-messages-reset)
  (chat-room-messages-reset)
  (server-return envelope "ok"))

(tm-service (remote-chat-room-open name)
  ;; Connect client to a chat room and return list of past messages
  ;;(display* "remote-chat-room-open " name "\n")
  (with (client msg-id) envelope
    (let* ((uid (server-get-user envelope))
           (crid (chat-room-id name)))
      (cond ((not crid)
             (server-error envelope "Error: unknown chat room"))
            ((string-starts? name "mail-")
             (server-error envelope "Error: invalid name of chat room"))
            ((not (db-allow? crid uid "readable"))
             (server-error envelope "Error: access to chat room denied"))
            (else
             (ensure-chat-room client crid)
             (let* ((ms (ahash-ref chat-room-messages crid))
                    (w? (db-allow? crid uid "writable")))
               (server-return envelope (list w? ms))))))))

(tm-service (remote-mail-open)
  ;; Open mail while creating mail box (a chat room) if necessary
  ;;(display* "remote-chat-room-create " name "\n")
  (with (client msg-id) envelope
    (let* ((uid (server-get-user envelope))
           (pseudo (or (user->pseudo uid) uid))
           (name (string-append "mail-" pseudo))
           (crid (or (chat-room-id name) (chat-room-create uid name))))
      (ensure-chat-room client crid)
      (server-return envelope (ahash-ref chat-room-messages crid)))))

(tm-service (remote-shared)
  (with (client msg-id) envelope
    (let* ((uid (server-get-user envelope))
           (pseudo (or (user->pseudo uid) uid))
           (name (string-append "mail-" pseudo))
           (crid (or (chat-room-id name) (chat-room-create uid name))))
      (ensure-chat-room client crid)
      (server-return
        envelope
        (list-filter (ahash-ref chat-room-messages crid) msg-is-shared?)))))

(define (list-shared? t msg)
  (with (action pseudo full-name date doc to) msg
    (and (== action "share")
         (and (not (ahash-ref t to)) (ahash-set! t to #t)))))

(define (chat-room-notify mid)
  ;; Notify the arrival of a new message to all participants
  (let* ((crid (db-get-field-first mid "to" "unknown"))
         (name (db-get-field-first crid "name" "unknown"))
         (owner (db-get-field-first crid "owner" "unknown"))
         (dummy (chat-room-initialize crid))
         (old-l (ahash-ref chat-room-messages crid))
         (new-m (chat-message-retrieve mid))
         (new-l (rcons old-l new-m))
         (users (make-ahash-table))
         (shared-with (chat-messages-sent owner (cut list-shared? users <>))))
    (display* "got notify room with name " name " owner " owner " shared with " shared-with "\n")
    (ahash-set! chat-room-messages crid new-l)
    (if (string-starts? name "mail-")
      (server-push-message (rcons new-m mid))
      (for (msg shared-with)
           (server-push-message (rcons new-m mid))))
    (for (client (ahash-ref chat-room-present crid))
      (server-remote-eval client `(chat-room-receive ,name ,new-m)
        (lambda (ok?) (noop))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Sending messages
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (remote-create-message uid msg)
  (let* ((rid (with-time-stamp #t
                (db-create-entry `(("type" "message")
                                   ("owner" ,uid)))))
         (name (repository-add rid "tm"))
         (fname (repository-get rid))
         (doc (convert msg "texmacs-stree" "texmacs-snippet")))
    (string-save doc fname)
    rid))

(define (remote-send uid dest action msg)
  (cond ((== action "send-document")
         (and-with msg* (remote-create-message uid msg)
           (remote-send uid dest "send" msg*)))
        ((list? dest)
         (for (did dest)
           (remote-send uid did action msg)))
        ((== (db-get-field-first dest "type" #f) "chat-room")
         (with-time-stamp #t
           ;; Look up resource ID from URL for "share" action
           (with rid (if (== action "share") (search-remote-identifier msg) #f)
             (with mid (db-create-entry `(("type" "chat-message")
                                          ("action" ,action)
                                          ("from" ,uid)
                                          ("to" ,dest)
                                          ("message" ,msg)
                                          ,@(if rid
                                              `(("resource-id" ,rid))
                                              '())))
               (chat-room-notify mid)))))
        ((chat-room-id dest)
         (with crid (chat-room-id dest)
           (when (db-allow? crid uid "writable")
             (remote-send uid (chat-room-id dest) action msg))))
        ((string-starts? dest "mail-")
         (let* ((pseudo (string-drop dest 5))
                (user (or (pseudo->user pseudo) pseudo))
                (crid (chat-room-create user dest)))
           (remote-send uid crid action msg)))))

(tm-service (remote-send-message dest action msg)
  ;;(display* "remote-send-message " dest ", " action ", " msg "\n")
  (with uid (server-get-user envelope)
    (remote-send uid dest action msg)
    (server-return envelope #t)))
