(use-modules (goblins)
             (goblins actor-lib methods)
             (ice-9 match))

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

(define (^cell bcom val)
  (methods
   ((get)
    ;; return current value, as-is
    val)
   ((set new-val)
    (bcom (^cell bcom new-val)))))


;; 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 title-stars
    (make-string
     (+ 6 (string-length blog-title))
     #\*))
  (display
   (format #f "~a\n** ~a **\n~a\n"
           title-stars blog-title title-stars)))

#;(display-blog-header "Maple Valley News")
#;(display-post-content
 '(*post* "A Day in the Park"
          "Lauren Ipsdale"
          "It was a fine day to take a walk..."))
#;(display-post-content
 '(*post* "Spelling Bee a Real Buzz"
           "Jim Winfantino"
           "Today, Maple Valley Middle School held its inagural spelling bee..."))

(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)))


;; Blogpost main code
;; ==================

(define* (spawn-post-and-editor #:key title author body)
  ;; The public blogpost
  (define (^post _bcom)
    (methods
     ((get-content)
      (cons '*post*
            ($ editor 'get-data)))))

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

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


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

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

  (define (^blog _bcom)
    (methods
     [(get-title)
      title]
     [(get-posts)
      ($ posts 'get)]))

  (define (^admin bcom)
    (methods
     [(add-post post)
      (define current-posts
        ($ posts 'get))
      (define new-posts
        (cons post current-posts))
      ($ posts 'set new-posts)]))

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


;; 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 (spawn-blog-and-admin "Maple Valley News")))

(define-values (day-in-park-post day-in-park-editor)
  (am-run (spawn-post-and-editor
           #:title "A Day in the Park"
           #:author "Lauren Ipsdale"
           #:body "It was a fine day to take a walk...")))

(am-run
 ($ maple-valley-admin 'add-post day-in-park-post))

(define-values (spelling-bee-post spelling-bee-editor)
  (am-run (spawn-post-and-editor
           #:title "Spelling Bee a Success"
           #:author "Robert Busyfellow"
           #:body
           "Maple Valley School held its annual spelling bee...")))

(am-run
 ($ spelling-bee-editor 'update
    #:title "Town Buzzing About Spelling Bee"))

(am-run
 ($ maple-valley-admin 'add-post spelling-bee-post))

(am-run
 (display-blog maple-valley-blog))


;;; 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-post-and-editor #: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))

(define-values (science-fair-post science-fair-editor science-fair-reviewer)
  (am-run
   (spawn-post-guest-editor-and-reviewer "Matilda Sample" maple-valley-admin)))

(am-run
 ($ science-fair-editor 'set-body 
    "My name is Matilda and I am twelve. I won the science fair..."))

(am-run
 ($ science-fair-editor 'set-title
    "Winning the Middle School Science Fair: A Personal Account")
 ($ science-fair-editor 'set-body 
    "At twelve years old, winning the local science fair has been..."))

(am-run
 ($ science-fair-reviewer 'approve))

(am-run
 (display-blog maple-valley-blog))


;; Add group stuff
;; ===============

(use-modules (goblins)
             (srfi srfi-9)
             (srfi srfi-9 gnu))

(define-record-type <pos>
  (make-pos x y)
  pos?
  (x pos-x)
  (y pos-y))

(define* (make-sealer-triplet #:optional name)
  ;; This is where all the sealing/unsealing stuff happens.
  ;; It's actually just a constructor, predicate, and accessor
  ;; on a language-protected record.
  (define-record-type <seal>
    (seal val)     ; constructor (sealer)
    sealed?        ; predicate   (brand-check)
    (val unseal))  ; accessor    (unsealer)

  ;; This is just for nicer display at the REPL.
  (define (print-seal _rec port)
    (if name
        (format port "#<sealed by ~a>" name)
        (display "#<sealed>" port)))
  (set-record-type-printer! <seal> print-seal)

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


(define* (spawn-post-and-editor2 blog-sealer #:key title author body)
  ;; The public blogpost
  (define (^post _bcom)
    (methods
     ((get-content)
      (cons '*post*
            ($ editor 'get-data)))
     ;; *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)
    (let update-beh ((title title) (author author) (body body))
      (methods
       ((update #:key (title title) (author author) (body body))
        (bcom (update-beh title author body)))
       ((get-data)
        (list title author body))
       ((get-post)
        post))))

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

(define (spawn-blog-and-admin2 title)
  (define-values (blog-seal blog-unseal blog-sealed?)
    (make-sealer-triplet 'blog))
  (define posts
    (spawn ^cell '()))

  (define (^blog _bcom)
    (methods
     [(get-title)
      title]
     [(get-posts)
      ($ posts 'get)]))

  (define (^admin bcom)
    (methods
     [(add-post post)
      (define current-posts
        ($ posts 'get))
      (define new-posts
        (cons post current-posts))
      (define sealed-self
        ($ post 'get-sealed-self))
      ;; *New*: Ensure this is a post from this blog
      (match (blog-unseal sealed-self)
        (('*post-self-proof* obj)
         (unless (eq? obj post)
           (error "Self-proof not for this post"))))
      ;; Checks out, let's update the set of posts
      ($ posts 'set new-posts)]
     ;; *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-editor2
         blog-seal
         #:title title
         #:author author
         #:body body))
      (list post editor)]
     ;; *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)
           editor)))
      (apply $ editor 'update args)]))

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

;; Just re-setting-things-up
(define-values (maple-valley-blog2 maple-valley-admin2)
  (am-run (spawn-blog-and-admin2 "Maple Valley News Vol 2")))
(define dip2
  (am-run
   ($ maple-valley-admin2
      'new-post-and-editor
      #:title "A Day in the Park"
      #:author "Lauren Ipsdale"
      #:body "It was a fine day to take a walk...")))
(am-run
 ($ maple-valley-admin2 'add-post (car dip2)))
(define sb2
  (am-run
   ($ maple-valley-admin2
      'new-post-and-editor
      #:title "Town Buzzing About Spelling Bee"
      #:author "Robert Busyfellow"
      #:body
      "Maple Valley School held its annual spelling bee...")))
(am-run
 ($ maple-valley-admin2 'add-post (car sb2)))

(am-run
 ($ maple-valley-admin2
    'edit-post
    (car dip2)
    #:title "A Very Nice Day in the Park"))

(am-run
 (display-blog maple-valley-blog2))