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, 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