;;; Copyright © 2019 - 2022 Jakob L. Kreuze <zerodaysfordays@sdf.org>
;;;
;;; 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
;;; <http://www.gnu.org/licenses/>.

(define-module (jakob dynamic capabilities comments)
  #:use-module (ice-9 match)
  #:use-module (jakob dynamic captcha)
  #:use-module (jakob dynamic util)
  #:use-module (json)
  #:use-module (squee)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web uri)
  #:export (get-comments
            get-comments-by-slug
            put-comment
            put-reaction))

(define conn (connect-to-postgres-paramstring "dbname=jakob_comments"))

(define (get-comments-by-slug slug)
  "Internal function for querying the approved comments on a post

This interface exists for dynamically generating the comment view from Haunt."
  (define (format-comment comment)
    (match comment
      ((id name subject email comment url approved reactions)
       `((id . ,id)
         (name . ,name)
         (subject . ,subject)
         (email . ,email)
         (comment . ,comment)
         (url . ,url)
         (publish-time . ,approved)
         (reactions . ,(if reactions
                           (with-input-from-string reactions read)
                           '()))))))
  (let* ((query "SELECT id, name, subject, email, comment, url, approved, reactions
                 FROM comments WHERE slug = $1 and approved IS NOT NULL")
         (result (exec-query conn query (list slug))))
    (map format-comment result)))

(define (get-comments request body)
  "API endpoint handler for querying for the comments on a particular post

This is a wrapper around `get-comments-by-slug'."
  (let* ((query-string (uri-query (request-uri request)))
         (params (if query-string
                     (decode-form query-string)
                     '()))
         (slug (assoc-ref params "p")))
    (if slug
        (values '((content-type . (application/json)))
                (scm->json-string
                 (list->vector
                  (get-comments-by-slug (car slug)))))
        (values (build-response #:code 400)
                (scm->json-string
                 `((success . #f)
                   (error . "missing `slug' query parameter")))))))



(define (put-comment request body)
  "API endpoint handler for submitting a comment"
  (define (valid-comment? form-data)
    (display form-data)
    (and (assoc "slug" form-data)
         (assoc "name" form-data)
         (assoc "comment" form-data)
         (assoc "captcha" form-data)
         (assoc "solution" form-data)
         (assoc "solution-mac" form-data)
         (validate-captcha
          (assoc-value form-data "captcha")
          (assoc-value form-data "solution")
          (assoc-value form-data "solution-mac"))))
  (define (insert-comment form-data)
    (exec-query conn
                "INSERT INTO comments (submitted, slug, name, subject,
                                       email, url, comment)
                 VALUES (now(), $1, $2, $3, $4, $5, $6);"
                (list (assoc-value form-data "slug")
                      (assoc-value form-data "name")
                      (assoc-value form-data "subject")
                      (assoc-value form-data "email")
                      (assoc-value form-data "url")
                      (assoc-value form-data "comment")))
    (values '((content-type . (application/json)))
            (scm->json-string `((success . #t)))))
  (let ((form-data (decode-form body)))
    (if (valid-comment? form-data)
        (insert-comment form-data)
        (values (build-response #:code 400)
                (scm->json-string
                 `((success . #f)
                   (error . "missing `slug', `name', or `comment'")))))))



(define (add-reaction reactions reaction)
  (with-output-to-string
    (lambda ()
      (let ((parsed (call-with-input-string reactions read)))
        (write (acons-normalize reaction
                                (if (assoc reaction parsed) (+ 1 (assoc-value parsed reaction)) 1)
                                parsed))))))

(define (put-reaction request body)
  (define (set-reactions id reactions)
    (exec-query conn "UPDATE comments SET reactions = $1 WHERE id = $2"
                (list reactions id)))
  (define (comment-reactions id)
    (let* ((query "SELECT reactions FROM comments WHERE id = $1")
           (result (exec-query conn query (list id))))
      ;; It could be NULL, in which case we want the empty list instead.
      (if (positive? (length result)) (or (caar result) "()") #f)))
  (define (valid-reaction? form-data)
    (and (assoc "id" form-data)
         (assoc "reaction" form-data)))
  (let* ((query-string (uri-query (request-uri request)))
         (form-data (if query-string
                        (decode-form query-string)
                        '())))
    (if (valid-reaction? form-data) 
        (let ((id (assoc-value form-data "id"))
              (reaction (assoc-value form-data "reaction"))
              (reactions (comment-reactions id)))
          (if reactions
              (begin
                (set-reactions id (add-reaction reactions reaction))
                (values '((content-type . (application/json)))
                        (scm->json-string `((success . #t)))))
              (values (build-response #:code 400)
                      (scm->json-string
                       `((success . #f)
                         (error . "no such comment"))))))
        (values (build-response #:code 400)
                (scm->json-string
                 `((success . #f)
                   (error . "missing `id', or `reaction'")))))))

;; (define (make-challenge request body)
;;   (let-values (((uuid value image) (new-captcha)))
;;     (hash-set! challenges uuid value)
;;     (hash-for-each (lambda (x y) (display x) (newline)) challenges)
;;     (values `((content-type . (application/base64))
;;               (access-control-allow-origin . "*")
;;               (x-captcha-id . ,uuid))
;;             (base64-encode image))))