use-modules
  goblins
  goblins actor-lib methods
  ice-9 match
  srfi srfi-9
  srfi srfi-9 gnu

;; Just to make some code prettier
;; ===============================

define (return x)
  . x


;; Cells (used later)
;; ==================

define (^cell bcom val)
  methods            ; syntax for first-argument-symbol-based dispatch
    (get)            ; takes no arguments
      return val     ; returns current value
    (set new-val)    ; takes one argument, new-val
      bcom : ^cell bcom new-val  ; become a cell with the new value


;; 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-len : string-length title
          title-underline : make-string title-len #\=
          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 "\n"
  display-post-content
    $ post 'get-content
  display "\n"

define (display-blog blog)
  display-blog-header
    $ blog 'get-title
  for-each display-post
    $ blog 'get-posts


;;; Record demonstration
;;; ====================

define-record-type <pos>   ; <pos>: name of the type
  make-pos x y     ; make-pos: constructor, takes two arguments
  . pos?           ; pos?: brand-check predicate (is it a pos?)
  x pos-x          ; pos-x: accessor for x
  y pos-y          ; pos-y: accessor for y


;;; Sealers and unsealers
;;; =====================


;; Make a sealer, unsealer, and brand-check predicate using
;; dynamic type generation.
define (make-sealer-triplet)
  define-record-type <seal>
    seal val        ; constructor (sealer)
    . sealed?       ; predicate   (brand-check)
    val unseal      ; accessor    (unsealer)

  ;; Prevents snooping on contents at REPL, etc
  define (print-seal _rec port)
    display "#<sealed>" port
  set-record-type-printer! <seal> print-seal

  ;; Return sealer, unsealer, sealed? predicate
  values seal unseal sealed?


define* (spawn-post-and-editor-internal blog-sealer #:key title author body)
  ;; The public blogpost
  define (^post _bcom)
    methods
      (get-content)
        define data-triple : $ editor 'get-data   ; fetch post data
        cons '*post* data-triple                  ; tag 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
             return editor
        apply $ editor 'update args

  values
    spawn ^blog
    spawn ^admin

;; TODO: double check this
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


;;; Logger and revocable logged proxy
;;; =================================

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

  ;; The revoker only has one behavior.  It is called with no
  ;; arguments and revokes access to the proxy.
  define (^revoker _bcom)
    lambda ()
      $ revoked? 'set #t

  define proxy
    spawn ^proxy

  values proxy revoked?


;; Try it out
;; ==========

define am : make-actormap
define-syntax-rule (am-run body ...)
  actormap-churn-run!
    . am
    lambda () body ...
    #:catch-errors? #f

define-values (maple-valley-blog maple-valley-admin)
  am-run
    new-spawn-blog-and-admin "Maple Valley News"

define-values (bumpy-ride-post bumpy-ride-editor)
  am-run
    spawn-adminable-post-and-editor
      . maple-valley-admin
      #:title "Main Street's Bumpy Ride"
      #:author "Lauren Ipsdale"

am-run
  $ maple-valley-admin 'add-post bumpy-ride-post

am-run
  $ maple-valley-admin 'edit-post bumpy-ride-post
    #:body "Anyone who's driven on main street recently..."

define admin-log
  am-run
    spawn ^logger
  
define-values (admin-for-robert roberts-admin-revoked?)
  am-run
    spawn-logged-revocable-proxy-pair
      . "Robert" maple-valley-admin admin-log

am-run
  $ admin-for-robert 'edit-post bumpy-ride-post
    #:title "Main Street Takes Some Bumps"

am-run
  $ admin-log 'get-log

am-run
  display-blog maple-valley-blog

am-run
  $ roberts-admin-revoked? 'set #t