giles
bac80f6c0b
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 17s
Migrate the container relations write actions onto lib/relations: POST /internal/actions/attach-child + /detach-child dispatch to relations/relate and relations/unrelate over the same "type:id" node model, behind the auth+ACL pipeline (wrap-errors . require-auth . require-permission), mirroring POST /feed. Closed-loop test: attach -> visible via get-children -> detach -> gone; 401/403/400 guards. Ledger now models the full relations surface (7 endpoints): container reads+writes migrated, typed relate/unrelate/can-relate proxied (registry+cardinality validation not in lib/relations). Off-Quart coverage 45% -> 50%. Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
181 lines
6.7 KiB
Plaintext
181 lines
6.7 KiB
Plaintext
;; lib/host/tests/relations.sx — the migrated relations read endpoints,
|
|
;; GET /internal/data/get-children and /get-parents, dispatching to lib/relations.
|
|
;; Golden tests pin each endpoint to "subsystem call + standard envelope": the
|
|
;; host adds the HTTP/JSON shell over relations/children|parents and nothing else
|
|
;; (golden derived from the same subsystem call, so result order matches).
|
|
|
|
(define host-rl-pass 0)
|
|
(define host-rl-fail 0)
|
|
(define host-rl-fails (list))
|
|
|
|
(define
|
|
host-rl-test
|
|
(fn
|
|
(name actual expected)
|
|
(if
|
|
(= actual expected)
|
|
(set! host-rl-pass (+ host-rl-pass 1))
|
|
(begin
|
|
(set! host-rl-fail (+ host-rl-fail 1))
|
|
(append! host-rl-fails {:name name :actual actual :expected expected})))))
|
|
|
|
(define host-rl-req (fn (target) (dream-request "GET" target {} "")))
|
|
(define host-rl-app (host/make-app (list host/relations-routes)))
|
|
(define host-rl-sym (fn (s) (string->symbol s)))
|
|
|
|
;; ── seed a known graph ──────────────────────────────────────────────
|
|
;; org:1 --member--> list:7, list:8 ; org:1 --owner--> page:9
|
|
(relations/load! (list))
|
|
(relations/relate (host-rl-sym "org:1") (host-rl-sym "list:7") (host-rl-sym "member"))
|
|
(relations/relate (host-rl-sym "org:1") (host-rl-sym "list:8") (host-rl-sym "member"))
|
|
(relations/relate (host-rl-sym "org:1") (host-rl-sym "page:9") (host-rl-sym "owner"))
|
|
|
|
;; ── get-children ────────────────────────────────────────────────────
|
|
(define host-rl-kids
|
|
"/internal/data/get-children?parent-type=org&parent-id=1&relation-type=member")
|
|
(host-rl-test "children 200" (dream-status (host-rl-app (host-rl-req host-rl-kids))) 200)
|
|
(host-rl-test
|
|
"children has list:7"
|
|
(contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-kids))) "list:7")
|
|
true)
|
|
(host-rl-test
|
|
"children has list:8"
|
|
(contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-kids))) "list:8")
|
|
true)
|
|
(host-rl-test
|
|
"children excludes other-kind page:9"
|
|
(contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-kids))) "page:9")
|
|
false)
|
|
(host-rl-test
|
|
"children count via subsystem"
|
|
(len (relations/children (host-rl-sym "org:1") (host-rl-sym "member")))
|
|
2)
|
|
|
|
;; child-type filter narrows by node prefix.
|
|
(host-rl-test
|
|
"children child-type=list keeps both"
|
|
(contains?
|
|
(dream-resp-body (host-rl-app (host-rl-req (str host-rl-kids "&child-type=list"))))
|
|
"list:8")
|
|
true)
|
|
(host-rl-test
|
|
"children child-type=page filters all out"
|
|
(contains?
|
|
(dream-resp-body (host-rl-app (host-rl-req (str host-rl-kids "&child-type=page"))))
|
|
"list:7")
|
|
false)
|
|
|
|
;; ── get-parents ─────────────────────────────────────────────────────
|
|
(define host-rl-par
|
|
"/internal/data/get-parents?child-type=list&child-id=7&relation-type=member")
|
|
(host-rl-test "parents 200" (dream-status (host-rl-app (host-rl-req host-rl-par))) 200)
|
|
(host-rl-test
|
|
"parents has org:1"
|
|
(contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-par))) "org:1")
|
|
true)
|
|
|
|
;; ── missing required params -> 400 ──────────────────────────────────
|
|
(host-rl-test
|
|
"children missing param -> 400"
|
|
(dream-status (host-rl-app (host-rl-req "/internal/data/get-children?parent-type=org")))
|
|
400)
|
|
(host-rl-test
|
|
"parents missing param -> 400"
|
|
(dream-status (host-rl-app (host-rl-req "/internal/data/get-parents?child-type=list")))
|
|
400)
|
|
|
|
;; ── golden: endpoint = subsystem call + envelope ────────────────────
|
|
(host-rl-test
|
|
"golden children"
|
|
(dream-resp-body (host-rl-app (host-rl-req host-rl-kids)))
|
|
(str
|
|
"{\"ok\":true,\"data\":"
|
|
(dream-json-encode
|
|
(host/-rel-strings (relations/children (host-rl-sym "org:1") (host-rl-sym "member"))))
|
|
"}"))
|
|
(host-rl-test
|
|
"golden parents"
|
|
(dream-resp-body (host-rl-app (host-rl-req host-rl-par)))
|
|
(str
|
|
"{\"ok\":true,\"data\":"
|
|
(dream-json-encode
|
|
(host/-rel-strings (relations/parents (host-rl-sym "list:7") (host-rl-sym "member"))))
|
|
"}"))
|
|
|
|
;; ── writes: attach-child / detach-child (auth + ACL + closed loop) ──
|
|
(acl/load!
|
|
(list
|
|
(acl-grant "carol" "relate" "relations")
|
|
(acl-grant "carol" "unrelate" "relations")))
|
|
;; carol is permitted; dave authenticates but has no grant.
|
|
(define host-rl-resolve
|
|
(fn (tok)
|
|
(cond ((= tok "good") "carol") ((= tok "weak") "dave") (true nil))))
|
|
(define host-rl-wapp
|
|
(host/make-app
|
|
(list host/relations-routes (host/relations-write-routes host-rl-resolve))))
|
|
(define host-rl-post
|
|
(fn (action auth body)
|
|
(dream-request "POST" (str "/internal/actions/" action)
|
|
(if auth {:authorization auth} {}) body)))
|
|
(define host-rl-edge
|
|
"{\"parent-type\":\"org\",\"parent-id\":\"2\",\"child-type\":\"list\",\"child-id\":\"5\",\"relation-type\":\"member\"}")
|
|
(define host-rl-org2
|
|
"/internal/data/get-children?parent-type=org&parent-id=2&relation-type=member")
|
|
|
|
(relations/load! (list))
|
|
|
|
;; auth gate
|
|
(host-rl-test
|
|
"attach no auth -> 401"
|
|
(dream-status (host-rl-wapp (host-rl-post "attach-child" nil "{}")))
|
|
401)
|
|
(host-rl-test
|
|
"attach authed-but-unpermitted -> 403"
|
|
(dream-status (host-rl-wapp (host-rl-post "attach-child" "Bearer weak" host-rl-edge)))
|
|
403)
|
|
(host-rl-test
|
|
"graph unchanged after 403"
|
|
(len (relations/children (host-rl-sym "org:2") (host-rl-sym "member")))
|
|
0)
|
|
|
|
;; permitted attach -> 201, and visible through the migrated read
|
|
(host-rl-test
|
|
"attach authed+permitted -> 201"
|
|
(dream-status (host-rl-wapp (host-rl-post "attach-child" "Bearer good" host-rl-edge)))
|
|
201)
|
|
(host-rl-test
|
|
"attached edge visible via get-children"
|
|
(contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-org2))) "list:5")
|
|
true)
|
|
|
|
;; detach -> 200, and gone from the read
|
|
(host-rl-test
|
|
"detach authed+permitted -> 200"
|
|
(dream-status (host-rl-wapp (host-rl-post "detach-child" "Bearer good" host-rl-edge)))
|
|
200)
|
|
(host-rl-test
|
|
"detached edge gone from get-children"
|
|
(contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-org2))) "list:5")
|
|
false)
|
|
|
|
;; bad payloads
|
|
(host-rl-test
|
|
"attach non-object body -> 400"
|
|
(dream-status (host-rl-wapp (host-rl-post "attach-child" "Bearer good" "[1,2]")))
|
|
400)
|
|
(host-rl-test
|
|
"attach missing param -> 400"
|
|
(dream-status
|
|
(host-rl-wapp (host-rl-post "attach-child" "Bearer good" "{\"parent-type\":\"org\"}")))
|
|
400)
|
|
|
|
(define
|
|
host-rl-tests-run!
|
|
(fn
|
|
()
|
|
{:total (+ host-rl-pass host-rl-fail)
|
|
:passed host-rl-pass
|
|
:failed host-rl-fail
|
|
:fails host-rl-fails}))
|