;;; structlog-mode.el --- Query structured logs      -*- lexical-binding: t; -*-

;; Copyright (C) 2020  Jeremy Dormitzer

;; Author: Jeremy Dormitzer <jdormit@Jeremys-MBP>
;; Version: 0.1.0
;; Package-Requires ((dash "2.17.0") (s "1.12.0") (json-navigator "0.1.1") (tree-mode "1.1.1.1"))
;; Keywords: data

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; structlog-mode provides an interface to query structured logs
;; stored in a database. Right now, it only handles logs stored in the
;; format dictated by the pgjson Fluentd plugin.

;;; Code:
(require 'cl-lib)
(require 's)
(require 'dash)
(require 'json-navigator)
(require 'tree-mode)

(defvar structlog-fields nil
  "Currently selected structlog fields")

(defvar structlog-logs nil
  "Current structlog log lines, formatted as plists")

(defvar structlog-db-username nil
  "PostgreSQL username to use for structlog-mode")

(defvar structlog-db-database nil
  "PostgreSQL database to use for structlog-mode")

(defvar structlog-db-password nil
  "PostgresSQL password to use for structlog-mode")

(defvar structlog-db-table "fluentd"
  "PostgresSQL table to use for structlog-mode")

(defvar structlog-db-record-field "record"
  "PostgreSQL column used to store the log line records")

(defvar structlog-psql-path (executable-find "psql")
  "Path to the psql executable")

(defvar structlog-current-query nil
  "Query for the current structlog display")

(defvar structlog-field-default-width 40
  "Default width for log lines")

(defvar structlog-field-widths '((time . 25)
                                 (event . 100))
  "Widths for specific fields, overrides
`structlog-field-default-width'")

(defvar structlog-default-query
  ":select (time event) :limit 100"
  "Default query for `structlog' command")

(defvar structlog-time-field 'time
  "The structlog field designating the log timestamp")

(defun structlog--query-db (query)
  "Runs `query' against the database, returning a list of lists"
  (dolist (var '(structlog-db-username
                 structlog-db-database))
    (when (or (not (boundp var))
              (not (symbol-value var)))
      (error "%s must be set" var)))
  (let ((raw (shell-command-to-string
              (concat (when structlog-db-password
                        (format "PGPASSWORD=%s " structlog-db-password))
                      structlog-psql-path " "
                      "-U " structlog-db-username " "
                      "-d " structlog-db-database " "
                      "-F '<>STRUCTLOG_SEP<>' "
                      "-t -A -P pager "
                      "-c " (shell-quote-argument query)))))
    (->> raw
         (s-lines)
         (--filter (not (string-empty-p it)))
         (mapcar (apply-partially #'s-split "<>STRUCTLOG_SEP<>")))))

(defun structlog--parse-json (raw)
  "Parses the string `raw' as JSON and returns an alist"
  (if (fboundp 'json-parse-string)
      (json-parse-string raw :object-type 'alist)
    (require 'json)
    (json-read-from-string raw)))

(defun structlog--serialize-json (alist)
  "Serializes the `alist' to a JSON string"
  (if (fboundp 'json-serialize)
      (json-serialize alist)
    (require 'json)
    (json-encode alist)))

(defun structlog--get-query-fields (query)
  "Returns the fields selected by `query'"
  (vconcat (plist-get query :select)))

(defun structlog--parse-where-clause (where)
  "Parses a single WHERE data clause"
  (pcase where
    (`(:and . ,clauses) (format "(%s)"
                                (s-join " AND "
                                        (mapcar #'structlog--parse-where-clause
                                                clauses))))
    (`(:or . ,clauses) (format "(%s)"
                               (s-join " OR "
                                       (mapcar #'structlog--parse-where-clause
                                               clauses))))
    (`(:not ,clause) (format "NOT %s"
                             (structlog--parse-where-clause clause)))
    (`(:like ,sym ,str) (format "%s->>'%s' LIKE '%s'"
                                structlog-db-record-field
                                sym
                                str))
    (sym (format "%s->'%s' IS NOT NULL"
                 structlog-db-record-field
                 where))))

(defun structlog--get-where-sql (where)
  "Returns the SQL WHERE clause for the `where' data"
  (let ((parsed (structlog--parse-where-clause where)))
    (and parsed (format "WHERE %s" parsed))))

(defun structlog--get-query-sql (query)
  "Returns the SQL query to run for `query'"
  (let ((base (format "SELECT %s FROM %s"
                      structlog-db-record-field
                      structlog-db-table))
        (order-by (format "ORDER BY %s->'%s' DESC"
                          structlog-db-record-field
                          structlog-time-field))
        (limit (plist-get query :limit))
        (where (plist-get query :where)))
    (concat base " "
            (when where (structlog--get-where-sql where)) " "
            order-by " "
            (when limit
              (format "LIMIT %s" limit)))))

(defun structlog--make-list-entries ()
  "Makes the tabulated-list-mode entries list for structlog"
  (let* ((fields (structlog--get-query-fields structlog-current-query))
         (sql (structlog--get-query-sql structlog-current-query))
         (raw (structlog--query-db sql))
         (records (->> raw
                       (-map #'car)
                       (-map #'structlog--parse-json))))
    (setq structlog-fields fields)
    (setq structlog-logs records)
    (cl-map 'list
            (lambda (log-alist)
              (list log-alist
                    (cl-map 'vector
                            (lambda (field)
                              (or (format "%s" (alist-get field log-alist)) ""))
                            structlog-fields)))
            structlog-logs)))

(defun structlog--query->str (query)
  "Converts `query' to a string representation by unwrapping it"
  (->> (prin1-to-string query)
       (s-chop-prefix "(")
       (s-chop-suffix ")")))

(defun structlog--str->query (str)
  "Converts `str' into a query list"
  (->> str
       (s-prepend "(")
       (s-append ")")
       (read-from-string)
       (car)))

(defun structlog--fields->format ()
  (cl-map 'vector
          (lambda (field)
            (list (symbol-name field)
                  (or (alist-get field structlog-field-widths)
                      structlog-field-default-width)
                  t))
          structlog-fields))

(defun structlog--revert (&rest _)
  (setq structlog-fields (structlog--get-query-fields
                          structlog-current-query)
        tabulated-list-format (structlog--fields->format))
  (tabulated-list-revert)
  (tabulated-list-init-header))

(defun structlog-query (query)
  "Runs `query' and re-renders the table"
  (interactive "sQuery: ")
  (setq structlog-current-query (structlog--str->query query))
  (structlog--revert))

(defun structlog-edit-query ()
  (interactive)
  (let* ((query-str (structlog--query->str structlog-current-query))
         (new-query (read-string "Query: " query-str)))
    (structlog-query new-query)))

(defun structlog-view-log-at-point ()
  "Opens the log at point in a json-navigator buffer"
  (interactive)
  (let* ((log (tabulated-list-get-id))
         (json (structlog--serialize-json log)))
    (json-navigator-display-tree
     (json-navigator--read-string json))
    (tree-minor-mode)))

(defvar structlog-mode-map
  (let ((map (make-sparse-keymap)))
    (set-keymap-parent map tabulated-list-mode-map)
    (define-key map "m" #'structlog-query)
    (define-key map "M" #'structlog-edit-query)
    (define-key map (kbd "RET") #'structlog-view-log-at-point)
    map)
  "Local keymap for `structlog-mode' buffers")

(when (fboundp 'evil-define-key)
  (evil-define-key 'normal structlog-mode-map
    "m" #'structlog-query
    "M" #'structlog-edit-query
    (kbd "RET") #'structlog-view-log-at-point
    "S" #'tabulated-list-sort
    "{" #'tabulated-list-narrow-current-column
    "}" #'tabulated-list-widen-current-column)
  (evil-define-key 'normal tree-mode-map
    "D" #'tree-mode-delete-tree
    "k" #'tree-mode-previous-node
    "j" #'tree-mode-next-node
    "l" #'tree-mode-next-sib
    "h" #'tree-mode-previous-sib
    "u" #'tree-mode-goto-parent
    "r" #'tree-mode-goto-root
    "gr" #'tree-mode-reflesh
    "E" #'tree-mode-expand-level
    "e" #'tree-mode-toggle-expand
    "s" #'tree-mode-sort-by-tag
    "/" #'tree-mode-keep-match
    "!" #'tree-mode-collapse-other-except))

(define-derived-mode structlog-mode tabulated-list-mode "structlog"
  "Major mode to query structured log lines"
  (setq tabulated-list-format (structlog--fields->format)
        tabulated-list-entries #'structlog--make-list-entries)
  (setq-local revert-buffer-function #'structlog--revert)
  (tabulated-list-init-header))

;;;###autoload
(defun structlog ()
  (interactive)
  (when (get-buffer "*structlog*")
    (kill-buffer "*structlog*"))
  (with-current-buffer (get-buffer-create "*structlog*")
    (setq structlog-current-query (structlog--str->query
                                   (read-string "Query: "
                                                structlog-default-query))
          structlog-fields (structlog--get-query-fields
                            structlog-current-query))
    (structlog-mode)
    (tabulated-list-print))
  (switch-to-buffer "*structlog*"))

(provide 'structlog-mode)
;;; structlog-mode.el ends here