syndicate-rkt/syndicate/sturdy.rkt

#lang racket/base
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2021-2024 Tony Garnock-Jones <tonyg@leastfixedpoint.com>

;; Basically Macaroons [1] in a Dataspace context
;;
;; [1]: Birgisson, Arnar, Joe Gibbs Politz, Úlfar Erlingsson, Ankur
;; Taly, Michael Vrable, and Mark Lentczner. “Macaroons: Cookies with
;; Contextual Caveats for Decentralized Authorization in the Cloud.”
;; In Network and Distributed System Security Symposium. San Diego,
;; California: Internet Society, 2014.

(provide KEY_LENGTH
         new-key
         sturdy-encode
         sturdy-decode
         mint
         attenuate-sturdy
         SturdyRef-valid?
         SturdyRef-caveatChain
         CaveatsField-caveats
         validate
         (all-from-out "schemas/sturdy.rkt"))

(require racket/match)
(require (only-in libb2 blake2s BLAKE2S_BLOCKLEN))
(require (only-in noise-protocol/hmac make-hmac))
(require (only-in racket/random crypto-random-bytes))
(require preserves)
(require preserves-schema)
(require "schemas/sturdy.rkt")

(define KEY_LENGTH 16) ;; 128 bits

(define (new-key) (crypto-random-bytes KEY_LENGTH))

(define (embedded-not-allowed _)
  (error 'embedded-not-allowed "Embedded Ref not permitted in SturdyRef"))

(define (sturdy-encode v)
  (preserve->bytes v
                   #:canonicalizing? #t
                   #:encode-embedded embedded-not-allowed
                   #:write-annotations? #f))

(define (sturdy-decode bs)
  (bytes->preserve bs
                   #:read-syntax? #f
                   #:decode-embedded embedded-not-allowed))

(define hmac-BLAKE2s (make-hmac blake2s BLAKE2S_BLOCKLEN))

(define (signature key data)
  (subbytes (hmac-BLAKE2s key data) 0 KEY_LENGTH))

(define (mint oid key)
  (SturdyRef (Parameters oid (signature key (sturdy-encode oid)) (CaveatsField-absent))))

(define (update-signature sig caveats)
  (for/fold [(sig sig)] [(caveat (in-list caveats))]
    (signature sig (sturdy-encode (->preserve caveat)))))

(define (attenuate-sturdy r . caveats)
  (if (null? caveats)
      r
      (match r
        [(SturdyRef (Parameters oid sig cs))
         (SturdyRef (Parameters oid
                                (update-signature sig caveats)
                                (CaveatsField-present
                                 (append (CaveatsField-caveats cs) caveats))))])))

(define (SturdyRef-valid? r key)
  (match-define (SturdyRef (Parameters oid actual-sig cs)) r)
  (define expected-sig (update-signature (signature key (sturdy-encode oid)) (CaveatsField-caveats cs)))
  (equal? expected-sig actual-sig))

(define (SturdyRef-caveatChain r)
  (CaveatsField-caveats (Parameters-caveats (SturdyRef-parameters r))))

(define (CaveatsField-caveats c)
  (match c
    [(CaveatsField-absent) '()]
    [(CaveatsField-present cs) cs]
    [(CaveatsField-invalid _) (error 'CaveatsField-caveats "Invalid caveats field")]))

(define (validate r key)
  (when (not (SturdyRef-valid? r key))
    (error 'validate "Invalid SturdyRef"))
  r)