(library (sph storage dg authentication)
  (export
    dg-auth-additive-size-octets
    dg-auth-authenticate
    dg-auth-authenticate-entity
    dg-auth-authenticate-hash
    dg-auth-authorise
    dg-auth-cost-high
    dg-auth-cost-low
    dg-auth-cost-mid
    dg-auth-disallow
    dg-auth-hash-size-octets
    dg-auth-init)
  (import
    (rnrs bytevectors)
    (sph common)
    (sph conditional)
    (sph random-data)
    (sph scrypt)
    (sph storage dg)
    (sph storage dg one)
    (only (guile) current-time))

  ;data:
  ;  d: additive expiry
  ;  r: hash "dg-auth-hash" d
  ;  r: entity "dg-auth-entity" d
  ;  r: context "dg-auth-context" d
  ;todo
  ;  error cases: hash-and-context has multiple additives, entity-and-context has multiple additives
  (define dg-auth-intern-context)
  (define dg-auth-intern-entity)
  (define dg-auth-intern-hash)
  (define dg-auth-intern-account)
  (define dg-auth-intern-data)
  (define dg-auth-intern-name)

  (define (dg-auth-init)
    (dg-txn-call-write
      (l (txn)
        (apply
          (l (name data account hash entity context) (set! dg-auth-intern-name name)
            (set! dg-auth-intern-data data) (set! dg-auth-intern-account account)
            (set! dg-auth-intern-hash hash) (set! dg-auth-intern-entity entity)
            (set! dg-auth-intern-context context))
          (dg-intern-ensure txn
            (list "dg-auth-context" "dg-auth-entity" "dg-auth-hash" "account" "data" "name"))))))

  (define (dg-auth-labels)
    (append dg-auth-intern-context dg-auth-intern-entity dg-auth-intern-hash))

  (define (dg-auth-hash-new? txn . hash)
    "dg-txn bytevector ... -> boolean
     the value only needs to be unique among all auth-hash relations"
    (let (hash (dg-intern-data->id txn hash))
      (or (null? hash) (null? (dg-relation-select-read txn hash #f dg-auth-intern-hash)))))

  (define (dg-auth-data-create txn context entity hash additive expiry)
    "dg-txn integer integer bytevector bytevector integer/false ->"
    (and (dg-auth-hash-new? txn hash)
      (apply
        (l (hash-id additive . expiry)
          (let
            (d
              (first
                (dg-intern-ensure txn
                  (list (dg-ids->bytevector (list additive (if (null? expiry) dg-null expiry)))))))
            (each (l (key label) (dg-relation-ensure txn (list key) (list d) label))
              (list hash-id entity context)
              (list dg-auth-intern-hash dg-auth-intern-entity dg-auth-intern-context))
            #t))
        (dg-intern-ensure txn (if expiry (list expiry additive hash) (list additive hash))))))

  (define* (dg-auth-data-delete txn contexts #:optional entities)
    "dg-txn (integer ...) [(integer ...)/false]
     remove all authorisations in contexts, optionally only for entities"
    (let*
      ( (auth-labels (dg-auth-labels))
        (values (dg-relation-select-read txn contexts #f dg-auth-intern-context (q right)))
        (values
          (if (or (not entities) (null? values)) values
            (dg-relation-select-read txn entities values dg-auth-intern-entity (q right))))
        (keys
          (if (null? values) values (dg-relation-select-read txn #f values auth-labels (q left)))))
      (if (not (and (null? keys) (null? values)))
        (begin (dg-relation-delete txn keys values auth-labels)
          (dg-delete-disconnected txn (append keys values))))))

  (define* (dg-auth-data-delete-by-values txn values)
    "dg-txn (integer ...)
     delete all auth entries related to the given additive+expiry values intern"
    (let*
      ( (auth-labels (dg-auth-labels))
        (keys (dg-relation-select-read txn #f values auth-labels (q left))))
      (dg-relation-delete txn keys values auth-labels)
      (dg-delete-disconnected txn (append keys values))))

  (define (dg-auth-data-get-by-hash& txn context hash c)
    "dg-txn integer string/integer/bytevector procedure:{entity additive expiry} -> false/any
     get entity-id, additive and expiry from a hash.
     if multiple data elements or entities are related to \"hash\" then associated auth data is deleted"
    (and-let*
      ( (hash (false-if-null (dg-intern-data->id txn (list hash))))
        (values (false-if-null (dg-relation-select-read txn hash #f dg-auth-intern-hash (q right))))
        (values
          (false-if-null
            (dg-relation-select-read txn (list context) values dg-auth-intern-context (q right))))
        (entities
          (false-if-null (dg-relation-select-read txn #f values dg-auth-intern-entity (q left))))
        (values-length (length values)) (hash-length (length hash))
        (entities-length (length entities)))
      (if (and (= 1 hash-length) (= 1 values-length) (= 1 entities-length))
        (and-let* ((data (dg-vector-id->data txn (first values)))) (apply c (first entities) data))
        (if (or (< 1 values-length) (< 1 entities-length))
          (dg-auth-data-delete-by-values txn values) #f))))

  (define (dg-auth-data-get-by-entity& txn context entity c)
    "dg-txn integer:node-id integer:node-id procedure:{bytevector:hash bytevector:additive integer:expiry} -> false/any
     get hash, additive and expiry from a entity"
    (let*
      ( (values (dg-relation-select-read txn (list entity) #f dg-auth-intern-entity (q right)))
        (values
          (if (null? values) values
            (dg-relation-select-read txn (list context) values dg-auth-intern-context (q right))))
        (hashes
          (if (null? values) values
            (dg-relation-select-read txn #f values dg-auth-intern-hash (q left)))))
      (if (and (= 1 (length values)) (= 1 (length hashes)))
        (and-let* ((data (dg-vector-id->data txn (first values))))
          (apply c (first (dg-intern-id->data txn hashes (q bytevector))) data))
        (begin (dg-auth-data-delete-by-values txn values) #f))))

  (define (dg-auth-data-hash->entity txn context hash) "dg-txn integer bytevector -> false/integer"
    (dg-auth-data-get-by-entity& txn context hash (l a (first a))))

  (define (dg-auth-data-entity->hash txn context entity)
    "dg-txn integer integer -> false/bytevector"
    (dg-auth-data-get-by-entity& txn context entity (l a (first a))))

  (define dg-auth-cost-mid (list 16 8 1))
  (define dg-auth-cost-low (list 10 8 1))
  (define dg-auth-additive-size-octets 32)
  (define dg-auth-hash-size-octets 64)

  (define (dg-auth-create-additive scrypt-args)
    "(integer integer integer) -> bytevector
     the additive contains the scrypt-args"
    (let (r (random-bytevector dg-auth-additive-size-octets))
      (bytevector-copy! (u8-list->bytevector scrypt-args) 0 r (- dg-auth-additive-size-octets 3) 3) r))

  (define (dg-auth-any->bytevector a)
    (if (bytevector? a) a
      (if (string? a) (string->utf8 a)
        (if (integer? a) (integer->bytevector a) (string->utf8 (any->string a))))))

  (define (dg-auth-create-hash scrypt-args additive . values)
    "(integer integer integer) bytevector any:custom-data -> bytevector"
    (let (values-data (apply bytevector-append (map dg-auth-any->bytevector values)))
      (if (< dg-size-octets-data-max (bytevector-length values-data))
        (raise (q dg-auth-custom-values-exceed-max-data-size))
        (apply scrypt values-data additive dg-auth-hash-size-octets scrypt-args))))

  (define (dg-auth-additive->scrypt-args a) "bytevector -> list"
    (list (bytevector-u8-ref a (- dg-auth-additive-size-octets 3))
      (bytevector-u8-ref a (- dg-auth-additive-size-octets 2))
      (bytevector-u8-ref a (- dg-auth-additive-size-octets 1))))

  (define (dg-auth-create txn scrypt-args expiry context entity . values)
    "dg-txn list integer integer string/integer/bytevector ... -> false/bytevector:hash
     authorise entity, not deleting existing authorisations in context.
     may give false if no new unique hash could be created"
    (let*
      ( (scrypt-args (or scrypt-args dg-auth-cost-high))
        (additive (dg-auth-create-additive scrypt-args))
        (create-hash
          (nullary (apply dg-auth-create-hash scrypt-args additive context entity values))))
      (let loop ((tries-left 4) (hash (create-hash)))
        (or (and (dg-auth-data-create txn context entity hash additive expiry) hash)
          (if (< tries-left 1) #f (loop (- tries-left 1) (create-hash)))))))

  (define (dg-auth-authorise txn dg-auth-cost expiry context entity . values)
    "dg-txn list integer integer string/integer/bytevector ... -> false/bytevector:hash
     delete existing authorisations for entity in context and authorise.
     there can validly only be one active authorisation per entity and context"
    (dg-auth-data-delete txn (list context) (list entity))
    (apply dg-auth-create txn dg-auth-cost expiry context entity values))

  (define (dg-auth-authenticate txn entity context hash additive expiry . values)
    "dg-txn integer integer bytevector bytevector integer any ... -> boolean"
    (and
      (if (and expiry (<= expiry (current-time)))
        (begin (dg-auth-data-delete txn (list context) (list entity)) #f) #t)
      (bytevector=? hash
        (apply dg-auth-create-hash (dg-auth-additive->scrypt-args additive)
          additive context entity values))))

  (define (dg-auth-authenticate-hash txn context hash . values)
    "integer bytevector string/integer/bytevector ... -> integer:entity/false
     authenticate by hash and values and give the entity-id or false"
    (dg-auth-data-get-by-hash& txn context
      hash
      (l (entity additive expiry)
        (and (apply dg-auth-authenticate txn entity context hash additive expiry values) entity))))

  (define (dg-auth-authenticate-entity txn context entity . values)
    "integer integer string/integer/bytevector ... -> bytevector:hash/false
     authenticate an entity"
    (dg-auth-data-get-by-entity& txn context
      entity
      (l (hash additive expiry)
        (and (apply dg-auth-authenticate txn entity context hash additive expiry values) hash))))

  (define dg-auth-disallow dg-auth-data-delete))