added mermaid and a lot of cmap changes

2026-08-27 13:13:39 +02:00
parent 20c1584016
commit 2215d1d04a
35 changed files with 6442 additions and 350 deletions
@@ -0,0 +1,119 @@
+#lang racket/base
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Wiki-wide registry for person tags used by CMap concepts.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(require db
+         racket/list
+         racket/string
+         "database.rkt")
+
+(provide list-people
+         create-person!
+         update-person!
+         sync-person-tags!)
+
+(define (row->person row)
+  (hash 'id (vector-ref row 0)
+        'name (vector-ref row 1)
+        'active (vector-ref row 2)))
+
+(define (list-people config [include-inactive? #t])
+  (call-with-wiki-database
+   config
+   (lambda (db)
+     (for/list ((row (in-list
+                      (query-rows
+                       db
+                       (string-append
+                        "SELECT id, name, active FROM people"
+                        (if include-inactive? "" " WHERE active = TRUE")
+                        " ORDER BY lower(name), name")))))
+       (row->person row)))))
+
+(define (clean-person-name who name)
+  (unless (string? name)
+    (raise-argument-error who "string?" name))
+  (define clean (string-trim name))
+  (when (or (string=? clean "") (> (string-length clean) 200))
+    (error who "person name must contain between 1 and 200 characters"))
+  clean)
+
+(define (create-person! config name)
+  (define clean-name (clean-person-name 'create-person! name))
+  (call-with-wiki-database
+   config
+   (lambda (db)
+     (define now (current-seconds))
+     (row->person
+      (query-row
+       db
+       #<<SQL
+INSERT INTO people(name, active, created_at, updated_at)
+VALUES ($1, TRUE, $2, $2)
+ON CONFLICT (lower(name)) DO UPDATE
+SET name = excluded.name, active = TRUE, updated_at = excluded.updated_at
+RETURNING id, name, active
+SQL
+       clean-name now)))))
+
+(define (update-person! config id name active?)
+  (define clean-name (clean-person-name 'update-person! name))
+  (call-with-wiki-database
+   config
+   (lambda (db)
+     (define row
+       (query-maybe-row
+        db
+        #<<SQL
+UPDATE people
+SET name = $1, active = $2, updated_at = $3
+WHERE id = $4
+RETURNING id, name, active
+SQL
+        clean-name (if active? #t #f) (current-seconds) id))
+     (and row (row->person row)))))
+
+(define (person-tag-names document)
+  (remove-duplicates
+   (for*/list ((concept (in-list
+                         (append (hash-ref document 'concepts '())
+                                 (hash-ref document 'items '()))))
+               #:when (hash? concept)
+               (tag (in-list (hash-ref concept 'tags '())))
+               #:when (and (hash? tag)
+                           (string=? (hash-ref tag 'type "") "person")
+                           (string? (hash-ref tag 'value #f))
+                           (not (string=? (string-trim (hash-ref tag 'value)) ""))))
+     (string-trim (hash-ref tag 'value)))
+   string-ci=?))
+
+;; Called inside the concept-map write transaction. New names become active;
+;; an explicitly deactivated existing name remains deactivated.
+(define (sync-person-tags! db document)
+  (define now (current-seconds))
+  (for ((name (in-list (person-tag-names document))))
+    (query-exec
+     db
+     #<<SQL
+INSERT INTO people(name, active, created_at, updated_at)
+VALUES ($1, TRUE, $2, $2)
+ON CONFLICT (lower(name)) DO NOTHING
+SQL
+     name now))
+  (void))
+
+(module+ test
+  (require rackunit)
+  (check-equal?
+   (person-tag-names
+    (hash 'concepts
+          (list (hash 'tags
+                      (list (hash 'type "person" 'value " Alex Morgan ")
+                            (hash 'type "label" 'value "architecture")))
+                (hash 'tags
+                      (list (hash 'type "person" 'value "alex morgan")
+                            (hash 'type "person" 'value "Sam de Vries"))))
+          'items '()))
+   '("Alex Morgan" "Sam de Vries")))