(define-module (goblins-blog)
  #:use-module (goblins)
  #:use-module (goblins actor-lib methods)
  #:use-module (goblins utils simple-sealers)
  #:use-module (goblins actor-lib cell)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:export (spawn-post-and-editor
	    spawn-blog-and-admin
	    spawn-blog-and-admin spawn-adminable-post-and-editor
            ^logger spawn-logged-revocable-proxy-pair
            spawn-post-guest-editor-and-reviewer
            display-post-content display-blog-header
            display-post display-blog))

(define* (spawn-post-and-editor #:key title author body)
  ;; The public blogpost
  (define (^post bcom)
    (methods
     ;; fetches title, author, and body, tags with '*post* symbol
     ((get-content)
      ; assign data-triple to the current data
      (define data-triple ($ editor 'get-data))
      ; return tagged with '*post*
      (cons '*post* data-triple))))

  ;; The editing interface
  (define (^editor bcom title author body)
    (methods
     ;; update method can take keyword arguments for
     ;; title, author, and body, but defaults to their current
     ;; definitions
     ((update #:key (title title) (author author) (body body))
      (bcom (^editor bcom title author body)))
      ;; get the current values for title, author, body as a list
     ((get-data)
      (list title author body))))

  ;; spawn and return the post and editor
  (define post (spawn ^post))
  (define editor (spawn ^editor title author body))
  (values post editor))  ; multi-value return of post, editor

;; Blog main code
;; ==============

(define (spawn-blog-and-admin title)
  (define posts
    (spawn ^cell '()))

  (define (^blog bcom)
    (methods
     ((get-title) title)           ; return the title, as a value
     (get-posts) ($ posts 'get)))  ; fetch and return the value of posts

  (define (^admin bcom)
    (methods
     ((add-post post)
      (define current-posts
        ($ posts 'get))
      (define new-posts
        (cons post current-posts))  ; prepend post to current-posts
      ($ posts 'set new-posts))))

  (define blog (spawn ^blog))
  (define admin (spawn ^admin))
  (values blog admin))

(define* (spawn-post-and-editor-internal blog-sealer #:key title author body)
  ;; The public blogpost
  (define (^post bcom)
    (methods
     ;; fetches title, author, and body, tags with '*post* symbol
     ((get-content)
      ; assign data-triple to the current data
      (define data-triple ($ editor 'get-data))
      (cons '*post* data-triple))  ; return tagged with '*post*
     ;; *New*: get a sealed version of the editor from anywhere
     ((get-sealed-editor)
      (blog-sealer (list '*editor* editor)))
     ;; *New*: get a sealed version of self for self-attestation
     ((get-sealed-self)
      (blog-sealer (list '*post-self-proof* post)))))

  ;; The editing interface
  (define (^editor bcom title author body)
    (methods
     ((update #:key (title title) (author author) (body body))
      (bcom (^editor bcom title author body)))
     ((get-data)
      (list title author body))))

  ;; spawn and return the post and editor
  (define post (spawn ^post))
  (define editor (spawn ^editor title author body))
  (values post editor))

(define (new-spawn-blog-and-admin title)
  ;; *New:* sealers / unsealers relevant to this blog
  (define-values (blog-seal blog-unseal blog-sealed?)
    (make-sealer-triplet))

  (define posts
    (spawn ^cell '()))

  (define (^blog bcom)
    (methods
     ((get-title) title)
     ((get-posts) ($ posts 'get))))

  (define (^admin bcom)
    (methods
     ;; *New:* A method to create posts specifically for this blog
     ((new-post-and-editor #:key title author body)
      (define-values (post editor)
        (spawn-post-and-editor-internal
         blog-seal
         #:title title
         #:author author
         #:body body))
      (list post editor))

     ;; *Updated:* check that a post was made (and is updateable)
     ;;   by this blog
     ((add-post post)
      ;; (This part is the same as in the last version)
      (define current-posts ($ posts 'get))
      ;; prepend post to current-posts
      (define new-posts (cons post current-posts))
      ;; *New*: Ensure this is a post from this blog
      ;; This is accomplished by asking the post to provide the sealed
      ;; version "of itself".  The `blog-unseal` method will throw an error
      ;; if it is sealed by anything other than `blog-seal
      (define post-self-proof
        ($ post 'get-sealed-self
           (match (blog-unseal post-self-proof)
             (('*post-self-proof* obj)  ; match against tagged proof
              (unless (eq? obj post)    ; equality check: same object?
		(error "Self-proof not for this post"))))))
        ;; Checks out, update the set of posts
      ($ posts 'set new-posts))

     ;; *New:* A method to edit any post associated with this blog
     ((edit-post post #:rest args)
      (define sealed-editor
        ($ post 'get-sealed-editor))
      (define editor
        (match (blog-unseal sealed-editor)
          (('*editor* editor)  ; match against tagged editor
           editor)))
      (apply $ editor 'update args))))

  (values
   (spawn ^blog)
   (spawn ^admin)))

(define (spawn-adminable-post-and-editor admin . args)
  (define post-and-editor
    (apply $ admin 'new-post-and-editor args))
  (match post-and-editor
    ((post editor)            ; match against list of post and editor
     (values post editor))))  ; return as values for consistency in examples

(define (^logger bcom)
  (define log (spawn ^cell '()))  ; log starts out as the empty list

  (methods
    ;; Add an entry to the log of:
    ;;  - the username accessing the log
    ;;  - the object they were accessing
    ;;  - the arguments they passed in
   ((append-to-log username object args)
    (define new-log-entry
      (list '*entry* 'user username 'object object 'args args))
    (define current-log ($ log 'get))
    (define new-log (cons new-log-entry current-log))  ; prepend new-log-entry
    ($ log 'set new-log))

   ((get-log) ($ log 'get))))

(define (spawn-logged-revocable-proxy-pair username object log)
  ;; The cell which keeps track of whether or not the proxy user's
  ;; access is revoked.
  (define revoked? (spawn ^cell #f))

  ;; The proxy which both logs and forwards arguments (if not revoked)
  (define (^proxy bcom)
    (lambda args
      ;; check if access has been revoked
      (when ($ revoked? 'get)
        (error "Access revoked!"))
      ;; If not, first send a message to log the access
      ($ log 'append-to-log username object args)
      ;; Then proxy the invocation to the object asynchronously
      (apply $ object args)))

  (define proxy (spawn ^proxy))
  (values proxy revoked?))

;;; Guest post with review
;;; ======================

;; The restricted-editor user can only change the title and body, but
;; not their name.
;; They cannot conspire with their teacher to be someone else on the
;; newspaper.
;;
;; The teacher cannot do anything but approve the student's post to
;; go live.  They cannot change the student's choice of language,
;; only ask them to change it before approval.

(define (spawn-post-guest-editor-and-reviewer author blog-admin)
  (define-values (post editor)
    (spawn-adminable-post-and-editor
     blog-admin #:author author))

  (define submitted-already? (spawn ^cell #f))

  (define (ensure-not-submitted)
    (when ($ submitted-already? 'get)
      (error "Already submitted!")))

  (define (^reviewer bcom)
    (methods
     ((approve)
      (ensure-not-submitted
       ($ blog-admin 'add-post post)
       ($ submitted-already? 'set #t)))))

  (define (^restricted-editor bcom)
    (methods
     ((set-title new-title)
      (ensure-not-submitted
       ($ editor 'update #:title new-title)))
     ((set-body new-body)
      (ensure-not-submitted
       ($ editor 'update #:body new-body)))))

  (define reviewer (spawn ^reviewer))
  (define restricted-editor (spawn ^restricted-editor))
  (values post restricted-editor reviewer))

;; Blogpost rendering utilities
;; ============================
(define (display-post-content post-content)
  (match post-content
    (('*post* post-title post-author post-body)
     (let* ((title (or post-title "<<No Title>>"))
	      (title-underline (make-string (string-length title) #\=))
	      (author (or post-author "<<Anonymous>>"))
	      (body (or post-body "<<Empty blogpost!>>")))
	 (display
	  (format #f "~a\n~a\n  By: ~a\n\n~a\n"
		  title title-underline author body))))))

(define (display-blog-header blog-title)
  (define header-len (+ 6 (string-length blog-title)))
  (define title-stars (make-string header-len #\*))
  (display
   (format #f "~a\n** ~a **\n~a\n"
	     title-stars blog-title title-stars)))

(define (display-post post)
  (display-post-content ($ post 'get-content)))

(define (display-blog blog)
  (display-blog-header
   ($ blog 'get-title))
  (for-each
   (lambda (post)
     (display "\n")
     (display-post post)
     (display "\n"))
   ($ blog 'get-posts)))