#lang racket/base

(require racket/match
         racket/contract
         crypto
         crypto/libcrypto
         base58
         syrup
         goblins
         goblins/actor-lib/common)

(provide cadify
         split-cad-symbol
         symbol->cad)

(crypto-factories (list libcrypto-factory))

;; Avoid length extension attacks
(define (sha256d input)
  (digest 'sha256 (digest 'sha256 input)))

(define/contract (cadify shortname description #:short? [short? #f])
  (->* ((or/c string? symbol?) any/c) (#:short? boolean?) symbol?)
  (define base58-hash
    (base58-encode (sha256d (syrup-encode description)) #:check? #f))
  (string->symbol
   (format "~a-~a"
           shortname
           (if short?
               (substring base58-hash 0 8)
               base58-hash))))

(module+ test
  (require rackunit)

  (crypto-factories (list libcrypto-factory))

  (define look-desc "\
Look at a fantasary game object, returning a string \
designating current description.  Takes no arguments.")

  (define look-cad (cadify 'look look-desc))

  (define look-scad (cadify 'look look-desc #:short? #t))
  
  (define fantasary-gameobj-desc
    "A game object in the Fantasary game system."))

(define (spawn-cad-registry-pair [cad-registry #hasheq()])
  (define registry (spawn ^hash cad-registry))
  (define (^register-cad bcom)
    (lambda (name description)
      (define cad (cadify name description))
      ($ registry 'set cad (record* 'cad name description))
      cad))
  (define (^fetch-cad bcom)
    (lambda (name)
      ($ registry 'ref name)))
  (values (spawn ^register-cad)
          (spawn ^fetch-cad)))


(module+ test
  (require goblins/actor-lib/bootstrap)
  (define-vat-run vat-run (make-vat))
  (define-values (register-cad fetch-cad)
    (vat-run (spawn-cad-registry-pair)))
  (test-equal?
   "Register cad claims to register the cad"
   (vat-run ($ register-cad 'foo-bar "A foo and a bar, by far, by far"))
   'foo-bar-2aNSpqx96JFBzdSWUQXJZu6haew1tF9hLRicqHyCmyiX)
  (test-equal?
   "fetch-cad gives us the cad's definition"
   (vat-run ($ fetch-cad 'foo-bar-2aNSpqx96JFBzdSWUQXJZu6haew1tF9hLRicqHyCmyiX))
   (record* 'cad 'foo-bar "A foo and a bar, by far, by far")))


;;;; Not really used yet.  Maybe later.

(define (cad hash description)
  (record* 'cad hash description))

(define (cad? obj)
  (match obj
    [(record 'cad (list string? bytes?))
     #t]
    [_ #f]))

(define (cad-hash cad)
  (match cad
    [(record 'cad (list (? string? _shortname) (? bytes? hash)))
     hash]))

(define (cad-shortname cad)
  (match cad
    [(record 'cad (list (? string? shortname) (? bytes? _hash)))
     shortname]))

(define (cad->symbol cad)
  (match cad
    [(record 'cad (list (? string? shortname) (? bytes? hash)))
     (define base58-hash (base58-encode hash #:check? #f))
     (string->symbol
      (format "~a-~a"
              shortname
              (substring base58-hash 0 8)))]))

(define (split-cad-symbol cadify-symbol)
  (define str (symbol->string cadify-symbol))
  (define last-dash #f)
  (define str-len (string-length str))
  (for ([i str-len])
    (when (eq? (string-ref str i) #\-)
      (set! last-dash i)))
  (if last-dash
      (values (substring str 0 last-dash)
              (substring str (add1 last-dash) str-len))
      (error "No dash in string")))

(define (symbol->cad cad-sym)
  (define-values (shortname encoded-hash)
    (split-cad-symbol cad-sym))
  (define hash (base58-decode encoded-hash #:check? #f))
  (cad shortname hash))