Commit040aeef4Recorded25 Aug 2026Repositoryfolio

F3b: move, same-file and cross-file, with reference re-addressing

Message

folio-move-node! moves a work item. Same-file: extract + reinsert in one staged document; no reference is touched because D12 references address document + node and neither changes. Cross-file: the moved node LEAVES its document, so every related/transclude pairing the moved id with the source document would silently go stale (t-5e4329's class) -- those document: fields are rewritten to the destination in the SAME manifest transaction, with rename's absolute raw-accounting refusal for anything unrewritable, and the moved subtree's ids must be fresh in the destination.

Two defects the smoke's own fixtures caught before any gate existed: the inserted node abutted @end note without a newline (the staged reparse refused it -- the postcheck defending as designed), and the first document-identity derivation used the FILESYSTEM slug where a reference names the D12 DOCUMENT ADDRESS (the owning root's declared id); the watcher fixture refused the move on the mismatch immediately. Both spellings now derive from the descriptor (owning-root-id), and a root with no declared id refuses rather than guessing.

F3a battery 22/22 green.

Changed
 src/folio/doc/structural.sgl | 400 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 398 insertions(+), 2 deletions(-)
Diff
src/folio/doc/structural.sglmodified
@@ -789,5 +789,401 @@
789
current-revision: rev))
790
(else #f)))
791
−792
(define (folio-move-node! . args)
−793
(error "folio-move-node!: landing in the next F3b slice"))))
+792
;; ------------------------------------------------------------------
+793
;; MOVE
+794
;;
+795
;; Same-file: one staged document, extract + reinsert, no reference is
+796
;; affected (D12 references address document + node, and neither
+797
;; changes). Cross-file: the moved node LEAVES its document, so every
+798
;; `related`/`transclude` whose `document:` names the source AND whose
+799
;; `node:` names the moved id would silently go stale -- exactly
+800
;; t-5e4329's class -- so those `document:` fields are rewritten to the
+801
;; destination's slug in the same manifest transaction, with the same
+802
;; raw-accounting refusal as rename for anything unrewritable.
+803
;; ------------------------------------------------------------------
+804
(define (folio-move-node! coord source-path node-id dest-path dest-container-id
+805
expected-source-revision
+806
(keys: (expected-dest-revision #f)))
+807
(unless (coordinator? coord) (error "folio-move-node!: coord must be a coordinator"))
+808
(let ((source-path (%txn-require-contained-path coord source-path))
+809
(dest-path (%txn-require-contained-path coord dest-path)))
+810
(coordinator-transact coord
+811
(lambda (recovery-actions)
+812
(%txn-stamp-recovery
+813
(if (equal? source-path dest-path)
+814
(move-same-file coord source-path node-id dest-container-id
+815
expected-source-revision)
+816
(move-cross-file coord source-path node-id dest-path dest-container-id
+817
expected-source-revision expected-dest-revision))
+818
recovery-actions)))))
+819
+820
(define (read-doc coord path label)
+821
;; (list bytes text rev descriptor) or a refusal.
+822
(if (not (file-exists? path))
+823
(%txn-refuse 'unknown-node (format "no such file: ~a" path))
+824
(let* ((bytes (read-file-bytes path))
+825
(text (utf8->string bytes))
+826
(rev (revision-of-bytes bytes)))
+827
(if (not (%txn-bytes-equal? (string->utf8 text) bytes))
+828
(%txn-refuse 'encoding-not-roundtrip
+829
(format "~a's bytes do not survive UTF-8 round-trip" path)
+830
current-revision: rev)
+831
(let ((d (%txn-bounded-descriptor coord bytes text path rev label)))
+832
(if (txn-refusal? d)
+833
d
+834
(list bytes text rev d)))))))
+835
+836
(define (movable-node d text node-id rev)
+837
;; The node, checked movable (work item), or a refusal.
+838
(let ((node (find-container d text node-id rev)))
+839
(cond
+840
((txn-refusal? node) node)
+841
((not (memq (inspected-node-name node) work-item-kinds))
+842
(%txn-refuse 'scoped-out
+843
(format "moving a ~a is SCOPED OUT of F3b by ruling (2026-08-25), not unsupported -- F3b moves work items" (inspected-node-name node))
+844
current-revision: rev))
+845
(else node))))
+846
+847
(define (move-same-file coord path node-id dest-container-id expected-revision)
+848
(let ((doc (read-doc coord path (format "document ~a" (path-basename path)))))
+849
(if (txn-refusal? doc)
+850
doc
+851
(let ((bytes (list-ref doc 0)) (text (list-ref doc 1))
+852
(rev (list-ref doc 2)) (d (list-ref doc 3)))
+853
(cond
+854
((not (equal? rev expected-revision))
+855
(%txn-refuse 'structural-revision-mismatch
+856
(format "expected ~a at revision ~a but it is at ~a; structural edits never rebase (amendment 1)"
+857
path expected-revision rev)
+858
current-revision: rev))
+859
(else
+860
(let ((node (movable-node d text node-id rev)))
+861
(if (txn-refusal? node)
+862
node
+863
(let ((dest (find-container d text dest-container-id rev)))
+864
(cond
+865
((txn-refusal? dest) dest)
+866
((not (memq (inspected-node-name dest) container-kinds-for-insert))
+867
(%txn-refuse 'scoped-out
+868
(format "moving into a ~a is SCOPED OUT of F3b by ruling" (inspected-node-name dest))
+869
current-revision: rev))
+870
(else
+871
(let* ((sp (inspected-node-span node))
+872
(del-start (span-scalar-start sp))
+873
(del-end (span-scalar-end sp))
+874
(moved-text (substring text del-start del-end))
+875
(insert-at (%txn-body-insertion-point text dest)))
+876
(cond
+877
((not insert-at)
+878
(%txn-refuse 'update-target-has-no-body
+879
(format "container ~s has no body to move into" dest-container-id)
+880
current-revision: rev))
+881
((and (>= insert-at del-start) (<= insert-at del-end))
+882
(%txn-refuse 'move-into-self
+883
(format "~s cannot be moved into its own extent" node-id)
+884
current-revision: rev))
+885
(else
+886
(let* ((after-delete (%txn-splice text del-start del-end ""))
+887
(adj (if (> insert-at del-end)
+888
(- insert-at (- del-end del-start))
+889
insert-at))
+890
(staged (%txn-splice after-delete adj adj
+891
(string-append "\n" moved-text "\n")))
+892
(lo (if (< adj del-start) adj del-start))
+893
(hi-scalar (if (> del-end insert-at) del-end insert-at))
+894
(byte-lo (%txn-scalar->byte-offset text lo))
+895
(byte-hi (%txn-scalar->byte-offset text hi-scalar))
+896
(bad (%txn-verify-staged coord path bytes text rev
+897
staged (descriptor-ids d)
+898
byte-lo (- byte-hi byte-lo) 0
+899
(lambda (staged-d)
+900
(move-check staged-d node-id dest-container-id rev))
+901
'postcheck-failed
+902
(descriptor-node-count d)
+903
#f '())))
+904
(if bad
+905
bad
+906
(let* ((staged-bytes (string->utf8 staged))
+907
(new-rev (revision-of-bytes staged-bytes)))
+908
(%txn-publish! path staged-bytes)
+909
(sop-result-record
+910
op: 'move-node
+911
files: (list (sop-file path rev new-rev
+912
(%txn-make-line-diff text staged)))
+913
node-id: node-id
+914
detail: (format "moved ~s into ~s (same file)" node-id dest-container-id)
+915
recovery: '()))))))))))))))))))
+916
+917
(define (move-check staged-d node-id dest-container-id rev)
+918
(let ((c2 (let walk ((pending (descriptor-nodes staged-d)))
+919
(cond ((null? pending) #f)
+920
((node-carries-id? (car pending) dest-container-id) (car pending))
+921
(else (walk (append (inspected-node-children (car pending))
+922
(cdr pending))))))))
+923
(cond
+924
((not (eq? (descriptor-id-status staged-d node-id) 'unique))
+925
(%txn-refuse 'postcheck-failed
+926
(format "~s is not uniquely declared after the move" node-id)
+927
current-revision: rev))
+928
((not c2)
+929
(%txn-refuse 'postcheck-failed
+930
(format "destination container ~s vanished" dest-container-id)
+931
current-revision: rev))
+932
((not (let walk ((pending (inspected-node-children c2)))
+933
(cond ((null? pending) #f)
+934
((equal? (inspected-node-id (car pending)) node-id) #t)
+935
(else (walk (append (inspected-node-children (car pending))
+936
(cdr pending)))))))
+937
(%txn-refuse 'postcheck-failed
+938
(format "~s did not land inside ~s" node-id dest-container-id)
+939
current-revision: rev))
+940
(else #f))))
+941
+942
(define (move-cross-file coord source-path node-id dest-path dest-container-id
+943
expected-source-revision expected-dest-revision)
+944
(let ((sdoc (read-doc coord source-path "the source document")))
+945
(if (txn-refusal? sdoc)
+946
sdoc
+947
(let ((ddoc (read-doc coord dest-path "the destination document")))
+948
(if (txn-refusal? ddoc)
+949
ddoc
+950
(let ((s-bytes (list-ref sdoc 0)) (s-text (list-ref sdoc 1))
+951
(s-rev (list-ref sdoc 2)) (s-d (list-ref sdoc 3))
+952
(d-bytes (list-ref ddoc 0)) (d-text (list-ref ddoc 1))
+953
(d-rev (list-ref ddoc 2)) (d-d (list-ref ddoc 3)))
+954
(cond
+955
((not (equal? s-rev expected-source-revision))
+956
(%txn-refuse 'structural-revision-mismatch
+957
(format "source ~a moved past the expected revision; structural edits never rebase" source-path)
+958
current-revision: s-rev))
+959
((and expected-dest-revision (not (equal? d-rev expected-dest-revision)))
+960
(%txn-refuse 'structural-revision-mismatch
+961
(format "destination ~a moved past the expected revision" dest-path)
+962
current-revision: d-rev))
+963
(else
+964
(let ((node (movable-node s-d s-text node-id s-rev)))
+965
(if (txn-refusal? node)
+966
node
+967
(move-cross-with-node coord source-path dest-path
+968
dest-container-id node-id node
+969
s-bytes s-text s-rev s-d
+970
d-bytes d-text d-rev d-d)))))))))))
+971
+972
(define (move-cross-with-node coord source-path dest-path dest-container-id
+973
node-id node s-bytes s-text s-rev s-d
+974
d-bytes d-text d-rev d-d)
+975
(let* ((moved-ids (cons node-id (filter string? (%txn-subtree-declared-ids node))))
+976
(dest (find-container d-d d-text dest-container-id d-rev)))
+977
(cond
+978
((txn-refusal? dest) dest)
+979
((not (memq (inspected-node-name dest) container-kinds-for-insert))
+980
(%txn-refuse 'scoped-out
+981
(format "moving into a ~a is SCOPED OUT of F3b by ruling" (inspected-node-name dest))
+982
current-revision: d-rev))
+983
;; The moved ids must be fresh in the destination document.
+984
((let lp ((ids moved-ids))
+985
(cond ((null? ids) #f)
+986
((not (eq? (descriptor-id-status d-d (car ids)) 'absent)) (car ids))
+987
(else (lp (cdr ids)))))
+988
=> (lambda (id)
+989
(%txn-refuse 'insert-id-taken
+990
(format "id ~s already exists in the destination document" id)
+991
current-revision: d-rev)))
+992
(else
+993
;; Referrer accounting root-wide: every occurrence of the moved
+994
;; ids must be a rewritable document-scoped reference, the
+995
;; declaration itself, or nothing -- the same absolute refusal
+996
;; discipline as rename.
+997
(let* ((root (coordinator-root coord))
+998
(population (root-population coord))
+999
(entries (cdr population))
+1000
(found (find-referrers coord entries moved-ids))
+1001
(semantic (list-ref found 0))
+1002
(raw-only (list-ref found 1))
+1003
(troubles (list-ref found 2)))
+1004
(cond
+1005
((pair? troubles)
+1006
(%txn-refuse 'referrer-uninspectable
+1007
(format "cannot account for every occurrence of ~a: ~a" moved-ids troubles)
+1008
retryable: #t))
+1009
((pair? raw-only)
+1010
(%txn-refuse 'unrewritable-reference
+1011
(format "moving ~s would strand raw occurrence(s): ~a -- refused, no override" node-id raw-only)))
+1012
(else
+1013
(stage-cross-move coord root entries source-path dest-path
+1014
dest-container-id dest node-id node semantic
+1015
s-bytes s-text s-rev s-d
+1016
d-bytes d-text d-rev d-d))))))))
+1017
+1018
(define (stage-cross-move coord root entries source-path dest-path
+1019
dest-container-id dest node-id node semantic
+1020
s-bytes s-text s-rev s-d
+1021
d-bytes d-text d-rev d-d)
+1022
(let* ((source-rel (path-relative root source-path))
+1023
(dest-rel (path-relative root dest-path))
+1024
;; The document identity a reference names is the D12 DOCUMENT
+1025
;; ADDRESS -- the declared id of the ROOT NODE owning the moved
+1026
;; node (`@note["topics/f3a-fixture" ...]`), NOT the file's slug.
+1027
;; The first spelling here used the filesystem slug and the
+1028
;; smoke's own watcher fixture refuted it immediately.
+1029
(source-slug (owning-root-id s-d node))
+1030
(dest-slug (owning-root-id d-d dest))
+1031
(sp (inspected-node-span node))
+1032
(del-start (span-scalar-start sp))
+1033
(del-end (span-scalar-end sp))
+1034
(moved-text (substring s-text del-start del-end))
+1035
(insert-at (%txn-body-insertion-point d-text dest)))
+1036
(cond
+1037
((not insert-at)
+1038
(%txn-refuse 'update-target-has-no-body
+1039
(format "container ~s has no body to move into" dest-container-id)
+1040
current-revision: d-rev))
+1041
((not source-slug)
+1042
(%txn-refuse 'postcheck-failed
+1043
"the moved node's owning root declares no document id; its references cannot be re-addressed"
+1044
current-revision: s-rev))
+1045
((not dest-slug)
+1046
(%txn-refuse 'postcheck-failed
+1047
"the destination's owning root declares no document id; references to the moved node could not name it there"
+1048
current-revision: d-rev))
+1049
(else
+1050
(let* ((staged-source (%txn-splice s-text del-start del-end ""))
+1051
(staged-dest (%txn-splice d-text insert-at insert-at
+1052
(string-append "\n" moved-text "\n")))
+1053
;; Rewrite each referrer's `document:` field where it names
+1054
;; the SOURCE slug for one of the moved ids (a reference in
+1055
;; the source or dest document themselves is handled on the
+1056
;; already-staged text below, so those are excluded here).
+1057
(ref-files (referrer-document-rewrites entries semantic
+1058
source-rel dest-rel
+1059
source-slug dest-slug))
+1060
(staged-list
+1061
(append
+1062
(list (list source-rel source-path s-bytes staged-source)
+1063
(list dest-rel dest-path d-bytes staged-dest))
+1064
(if (txn-refusal? ref-files) '() ref-files))))
+1065
(if (txn-refusal? ref-files)
+1066
ref-files
+1067
;; Verify: source lost the ids, dest gained them uniquely.
+1068
(let ((bad (or (verify-move-side coord source-rel s-bytes s-text s-rev s-d
+1069
staged-source node-id 'gone
+1070
(cons node-id (filter string? (%txn-subtree-declared-ids node))))
+1071
(verify-move-side coord dest-rel d-bytes d-text d-rev d-d
+1072
staged-dest node-id 'present '()))))
+1073
(if bad
+1074
bad
+1075
(let* ((txn-id (content-txn-id "move-node"
+1076
(list node-id source-rel dest-rel s-rev)))
+1077
(published (publish-file-set! coord txn-id "move-node" staged-list)))
+1078
(sop-result-record
+1079
op: 'move-node
+1080
files: (map (lambda (p)
+1081
(sop-file (list-ref p 0) (list-ref p 1) (list-ref p 2) #f))
+1082
published)
+1083
node-id: node-id
+1084
detail: (format "moved ~s from ~a to ~a (container ~s); ~a referrer file(s) redirected"
+1085
node-id source-rel dest-rel dest-container-id
+1086
(- (length staged-list) 2))
+1087
recovery: '()))))))))))
+1088
+1089
;; The id of the top-level root whose subtree holds `node` (by identity).
+1090
;; #f when the root declares no id -- callers refuse on it.
+1091
(define (owning-root-id d node)
+1092
(let roots ((rest (descriptor-nodes d)))
+1093
(cond
+1094
((null? rest) #f)
+1095
((let walk ((pending (list (car rest))))
+1096
(cond ((null? pending) #f)
+1097
((eq? (car pending) node) #t)
+1098
(else (walk (append (inspected-node-children (car pending))
+1099
(cdr pending))))))
+1100
(inspected-node-id (car rest)))
+1101
(else (roots (cdr rest))))))
+1102
+1103
(define (strip-format-extension rel)
+1104
(let ((n (string-length rel)))
+1105
(cond ((and (> n 4) (equal? (substring rel (- n 4) n) ".sgd")) (substring rel 0 (- n 4)))
+1106
((and (> n 3) (equal? (substring rel (- n 3) n) ".md")) (substring rel 0 (- n 3)))
+1107
(else rel))))
+1108
+1109
;; Build staged rewrites of referrer files' `document:` fields. Returns
+1110
;; a list of (rel abs pre-bytes staged-text) or a refusal.
+1111
(define (referrer-document-rewrites entries semantic source-rel dest-rel
+1112
source-slug dest-slug)
+1113
(let loop ((rels (let dedupe ((rest semantic) (out '()))
+1114
(cond ((null? rest) (reverse out))
+1115
((or (equal? (car (car rest)) source-rel)
+1116
(equal? (car (car rest)) dest-rel)
+1117
(member (car (car rest)) out))
+1118
(dedupe (cdr rest) out))
+1119
(else (dedupe (cdr rest) (cons (car (car rest)) out))))))
+1120
(out '()))
+1121
(if (null? rels)
+1122
(reverse out)
+1123
(let* ((rel (car rels))
+1124
(entry (assoc-entry entries rel))
+1125
(bytes (list-ref entry 3))
+1126
(text (utf8->string bytes))
+1127
(sites (let lp ((rest semantic) (acc '()))
+1128
(cond ((null? rest) (reverse acc))
+1129
((equal? (car (car rest)) rel)
+1130
(lp (cdr rest) (cons (cdr (car rest)) acc)))
+1131
(else (lp (cdr rest) acc)))))
+1132
;; Each site: (node field) -- rewrite the sibling
+1133
;; `document` field when it names the source slug.
+1134
(doc-spans
+1135
(let lp ((rest sites) (acc '()))
+1136
(if (null? rest)
+1137
(reverse acc)
+1138
(let* ((n (list-ref (car rest) 0))
+1139
(df (let f ((fs (inspected-node-fields n)))
+1140
(cond ((null? fs) #f)
+1141
((eq? (field-name (car fs)) 'document) (car fs))
+1142
(else (f (cdr fs)))))))
+1143
(cond
+1144
((not df) (lp (cdr rest) acc))
+1145
((not (equal? (field-value df) source-slug))
+1146
;; Points at a different document carrying the
+1147
;; same id -- impossible under the freshness
+1148
;; checks above, refused defensively.
+1149
(%txn-refuse 'postcheck-failed
+1150
(format "a reference in ~a pairs the moved id with document ~s, not the source ~s"
+1151
rel (field-value df) source-slug)))
+1152
((not (field-span df))
+1153
(%txn-refuse 'rebase-span-invalid
+1154
(format "a document: field in ~a has no span" rel)))
+1155
(else (lp (cdr rest) (cons (field-span df) acc)))))))))
+1156
(if (txn-refusal? doc-spans)
+1157
doc-spans
+1158
(let* ((replacement (%txn-escape-string-literal dest-slug))
+1159
(ordered (sort-spans-desc doc-spans))
+1160
(staged (let sp ((rest ordered) (s text))
+1161
(if (null? rest) s
+1162
(sp (cdr rest)
+1163
(%txn-splice s (span-scalar-start (car rest))
+1164
(span-scalar-end (car rest))
+1165
replacement))))))
+1166
(loop (cdr rels)
+1167
(cons (list rel (list-ref entry 1) bytes staged) out))))))))
+1168
+1169
(define (verify-move-side coord rel bytes text rev d staged node-id expect allowed-lost)
+1170
(%txn-verify-staged coord rel bytes text rev staged (descriptor-ids d)
+1171
0 (bytevector-length bytes)
+1172
0
+1173
(lambda (staged-d)
+1174
(cond
+1175
((and (eq? expect 'gone)
+1176
(not (eq? (descriptor-id-status staged-d node-id) 'absent)))
+1177
(%txn-refuse 'postcheck-failed
+1178
(format "~s still in the source after the move" node-id)
+1179
current-revision: rev))
+1180
((and (eq? expect 'present)
+1181
(not (eq? (descriptor-id-status staged-d node-id) 'unique)))
+1182
(%txn-refuse 'postcheck-failed
+1183
(format "~s not uniquely present in the destination" node-id)
+1184
current-revision: rev))
+1185
(else #f)))
+1186
'postcheck-failed
+1187
(descriptor-node-count d)
+1188
#f allowed-lost))))
+1189