(define-module (goblins-blog)
  #:use-module (goblins)
  #:use-module (goblins actor-lib methods)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (simple-sealers)
  #:use-module (method-cell)
  #:export (spawn-post-and-editor spawn-blog-and-admin
            new-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)
        (define data-triple            ; assign data-triple to
          ($ editor 'get-data          ));   the current data
        (cons '*post* data-triple      )))); return tagged with '*post*

  ;; 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)
        (define data-triple            ; assign data-triple to
          ($ editor 'get-data          ));   the current 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))
        (define new-posts
          (cons post current-posts  )); prepend post to 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, let's 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)))