simple-mint.rkt 3.56 KB
Newer Older
Christopher Lemmer Webber's avatar
Christopher Lemmer Webber committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128
#lang racket/base

;; An extremely simple mint, straight from
;;   http://erights.org/elib/capability/ode/index.html

(provide ^mint
         withdraw)

(require "../core.rkt" "../utils/simple-sealers.rkt"
         "methods.rkt" "cell.rkt"
         racket/contract)

(define (^mint _bcom)
  (define-values (decr-seal decr-unseal _decr-sealed?)
    (make-sealer-triplet 'mint))
  (define (^purse _bcom initial-balance)
    (define-cell balance
      initial-balance)
    (define (<=-balance? amount)
      (<= amount ($ balance)))
    (define/contract (decr amount)
      (-> (and/c integer? (>=/c 0) <=-balance?)
          any/c)
      ($ balance (- ($ balance) amount)))
    (define/contract (deposit-method amount src)
      (-> (and/c integer? (>=/c 0)) any/c any/c)
      ((decr-unseal ($ src 'get-decr)) amount)  ; decrement src balance
      ($ balance (+ ($ balance) amount)))       ; increment our balance
    (methods
     [(get-balance) ($ balance)]
     [(sprout) (spawn ^purse 0)]
     [deposit deposit-method]
     [(get-decr) (decr-seal decr)]))
  (define/contract (fiat-make-purse initial-balance)
    (-> (and/c integer? (>=/c 0)) any/c)
    (spawn ^purse initial-balance))
  (methods [new-purse fiat-make-purse]))

(define (withdraw from-purse amt)
  (define new-purse
    ($ from-purse 'sprout))
  ($ new-purse 'deposit amt from-purse)
  new-purse)

(module+ test
  (require rackunit
           "bootstrap.rkt")

  (define am (make-actormap))
  (define-actormap-run am-run am)
  (define carol-mint
    (am-run (spawn ^mint)))
  (define alice-purse
    (am-run ($ carol-mint 'new-purse 1000)))
  (check-equal?
   (am-run ($ alice-purse 'get-balance))
   1000)

  (define bob-purse
    (am-run ($ carol-mint 'new-purse 300)))
  (define payment-for-bob
    (am-run ($ alice-purse 'sprout)))
  ;; transfer money from alice's purse to payment-for-bob
  (am-run ($ payment-for-bob 'deposit 250 alice-purse))
  (check-equal?
   (am-run ($ alice-purse 'get-balance))
   750)
  (check-equal?
   (am-run ($ payment-for-bob 'get-balance))
   250)

  ;; give bob the money
  (am-run ($ bob-purse 'deposit 250 payment-for-bob))
  (check-equal?
   (am-run ($ payment-for-bob 'get-balance))
   0)
  (check-equal?
   (am-run ($ bob-purse 'get-balance))
   550)
  (check-equal?
   (am-run ($ alice-purse 'get-balance))
   750)

  ;; withdraw should work just as easily
  (define joe-purse
    (am-run ($ carol-mint 'new-purse 400)))
  (define payment-for-jane
    (am-run (withdraw joe-purse 150)))
  (check-equal?
   (am-run ($ payment-for-jane 'get-balance))
   150)
  (check-equal?
   (am-run ($ joe-purse 'get-balance))
   250)

  ;; Now let's make sure there are things we can't do...
  ;; Like have mallet make up a new mint and try to insert stuff
  ;; into eir wallet
  (define mallet-mint
    (am-run (spawn ^mint)))
  (define mallet-mallet-purse
    (am-run ($ mallet-mint 'new-purse 1000)))
  (define mallet-carol-purse
    (am-run ($ carol-mint 'new-purse 0)))
  ;; Now mallet tries to deposit money into their carol purse
  (check-exn
   any/c
   (lambda ()
     (am-run ($ mallet-carol-purse 'deposit mallet-mallet-purse))))
  ;; nice try, Mallet
  (check-equal?
   (am-run ($ mallet-carol-purse 'get-balance))
   0)

  ;; Okay now let's try withdrawing more than we can
  (define zed-purse
    (am-run ($ carol-mint 'new-purse 100)))
  (check-exn
   any/c
   (lambda ()
     (am-run (withdraw zed-purse 9000))))
  ;; Likewise we can't deposit more to willow than we have
  (define willow-purse
    (am-run ($ carol-mint 'new-purse 0)))
  (check-exn
   any/c
   (lambda ()
     (am-run ($ willow-purse 'deposit 9000 zed-purse)))))