#!/bin/sh
# -*- scheme -*-
exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
!#
;;; Copyright © 2014       David Thompson <davet@gnu.org>
;;; Copyright © 2015-2017  Amirouche Boubekki <amirouche@hypermove.net>
;;
;; 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 (web))

;; stdlib
(use-modules ((ice-9 binary-ports)))
(use-modules ((ice-9 match)))
(use-modules ((ice-9 threads)))
(use-modules ((rnrs bytevectors)))
(use-modules ((web request)))
(use-modules ((web uri)))

;; third party
(use-modules ((web server)))
(use-modules ((wiredtiger extra)))
(use-modules ((wiredtiger feature-space)))
(use-modules ((wiredtiger wiredtiger)))

;; local
(use-modules ((web decode)))
(use-modules ((web helpers)))
(use-modules ((web html)))
(use-modules ((web mime-types)))
(use-modules ((web static)))
(use-modules ((sha-2)))

;; gnunet
(use-modules ((gnunet sync)))


(setlocale LC_ALL "")


(define %configuration #f)
(define %home #f)

;;; helpers

(define (make-hash bv)
  (let ((hash (make-sha-512)))
    (sha-512-update! hash bv)
    (sha-512-finish! hash)
    (sha-512->string hash)))

;;;

(define (maybe-message-add! body uri)
  (when (null? (fs:find 'uri uri))
    (fs:add! `((kind . message) (body . ,body)))))

(define (discover configuration)
  (let loop ((uris (search configuration '("c3b2://v1/message"))))
    (unless (null? uris)
      (let ((body (download configuration (car uris))))
        (when body
          (pk 'add (car uris))
          (maybe-message-add! (utf8->string body) (car uris)))
        (loop (cdr uris))))))

(define (run-discovery configuration)
  "Run a background thread to look for new messages"
  (call-with-new-thread
   (lambda ()
     (with-context*
      (let loop ()
        (discover configuration)
        (loop)
        (sleep 1))))))

;;;

(define (c3b2/topics)
  (map (lambda (x) (assoc-ref x 'body))
       (map fs:ref*
            (fs:find 'kind 'message))))

(define (c3b2/topic-add! body)
  (let* ((payload (string->utf8 body))
         (hash (make-hash payload))
         (filepath (string-append %home "/" hash)))
    (call-with-output-file filepath
      (lambda (port)
        (put-bytevector port payload))
      #:binary #t)
    (publish %configuration (pk filepath) '("c3b2://v1/message"))))

;;; web

(define (template body-class body)
  `((doctype "html")
    (html
     (head
      (meta (@ (charset "utf-8")))
      (title "c3b2")
      (link (@ (rel "stylesheet") (href "/static/normalize.css")))
      (link (@ (rel "stylesheet") (href "/static/main.css"))))
     (body
      (div (h1 (a (@ (href "/")) "c3b2")))
      ,body))))

(define (template/topic topic)
  `(div (p ,topic)))

(define (template/index topics)
  `(,(map template/topic topics)
    (hr)
    (form (@ (method "POST")
             (action "/"))
          (h2 "Chime in the conversation!")
          (textarea (@ (name "body")))
          (input (@ (type "submit")
                    (value "publish"))))))

(define (route/index/get)
  (render-html (template "index" (template/index (c3b2/topics)))))

(define (route/index/post body)
  (c3b2/topic-add! (car (assoc-ref (decode body) "body")))
  (redirect "/"))

(define (router request body)
  (with-context*
   (match (cons (request-method request) (request-path-components request))
     (('GET) (route/index/get))
     (('POST) (route/index/post body))
     (('GET "static" path ...) (render-static-asset path))
     (_ (not-found (uri->string (request-uri request)))))))


(define-public (main args)
  (set! %configuration (cadr args))
  (set! %home (caddr args))
  (format #t "Server running @ http://localhost:8080\n")
  (with-env (env-open* "wt" (list *feature-space*) "create,log=(enabled=true)")
    (run-discovery %configuration)
    (run-server router)))