(library (sph storage dg permission)
  (export
    dg-p-delete
    dg-p-delete*
    dg-p-get
    dg-p-has?
    dg-p-set
    dg-p3-get
    dg-p3-get*
    dg-p3-get-opposite-permissions
    dg-p3-has?
    dg-p3-has?*
    dg-p3-permissions
    dg-p3-set
    dg-p3-set*
    ide-alias-permission-element
    sph-storage-dg-permission-description
    (rename (ide-alias-default-entity dg-p3-default-entity)))
  (import
    (rnrs base)
    (sph)
    (sph hashtable)
    (sph storage dg)
    (sph storage dg one)
    (sph storage dg relation path-find)
    (only (sph list) length-one? complement))

  (define sph-storage-dg-permission-description
    "set and check permissions for individual nodes. experimental")

  (define dg-p3-permissions (ht-create))
  (define ids-default-entity)
  (define ids-permission-element)

  (define (dg-p-set txn entity perm target)
    "(integer ...) (integer ...) (integer ...) -> unspecified"
    (dg-pair-ensure txn entity (if target (dg-pair-ensure txn perm target) perm)))

  (define (dg-p-get txn entity perm target) "list list list -> target-ide"
    (dg-pair-select-read txn perm
      target null (dg-pair-select-read txn null entity null (q right)) (q right)))

  (define (dg-p-has? txn entity perm target)
    "list list list -> boolean
     any perm on all targets"
    (not
      (null?
        (dg-pair-select-read txn null
          entity
          (if target
            (if (length-one? target) (dg-pair-select-read txn null perm target (q id))
              (dg-read-pairs-by-relation (list perm (list (q all) target)) (q id)))
            perm)
          (q right)))))

  (define (dg-p-delete txn entity perm target) "list list list ->"
    (if target
      (let*
        ( (target-pairs
            (dg-pair-select-read txn (dg-pair-select-read txn null entity null (q right))
              perm target (q id)))
          (entity-pairs (dg-pair-select-read txn null entity target-pairs (q id))))
        (dg-delete txn entity-pairs) (dg-delete-disconnected txn target-pairs))
      (let (entity-pairs (dg-pair-select-read txn null entity perm (q id)))
        (dg-delete txn entity-pairs))))

  (dg-init-define-interns ids-default-entity "permission-default-entity"
    ids-permission-element "permission-element")

  (define (dg-p3-get-opposite-permissions . perm)
    (map (l (perm) (ht-ref dg-p3-permissions perm)) perm))

  (define (dg-p3-has? txn entity perm target) "false/list list false/list -> boolean"
    (if entity
      (if target
        (and (dg-p-has? txn (append ids-default-entity entity) perm target)
          (not (dg-p-has? txn entity (apply dg-p3-get-opposite-permissions perm) target)))
        (dg-p-has? txn (append ids-default-entity entity) perm target))
      (dg-p-has? txn ids-default-entity perm target)))

  (define (dg-p3-get txn entity perm target) "false/list list false/list -> list"
    (if entity
      (complement (dg-p-get txn (append ids-default-entity entity) perm target)
        (dg-p-get txn entity (apply dg-p3-get-opposite-permissions perm) target))
      (dg-p-get txn ids-default-entity perm target)))

  (define (dg-p3-set txn entity perm target) "false/list list false/list -> unspecified"
    (let (entity (if entity entity ids-default-entity))
      (if target (dg-p-delete txn entity (apply dg-p3-get-opposite-permissions perm) target))
      (dg-p-set txn entity perm target)))

  (define-syntax-rule (any->list-or-false-s arg) (if (list? arg) arg (if arg (list arg) arg)))

  (define-syntax-rule (define-w-list-conversion (name other-name) ...)
    (begin
      (define (name txn entity perm target)
        (other-name txn (any->list-or-false-s entity)
          (any->list-or-false-s perm) (any->list-or-false-s target)))
      ...))

  (define-w-list-conversion (dg-p3-get* dg-p3-get) (dg-p3-has?* dg-p3-has?)
    (dg-p3-set* dg-p3-set) (dg-p-delete* dg-p-delete)))