144 lines
5.2 KiB
Racket
144 lines
5.2 KiB
Racket
#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)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : List people available for CMap person tags.
|
|
; pre : The wiki database schema is initialized.
|
|
; post : Person rows have only been read.
|
|
; result : A name-sorted list of person hashes, optionally excluding inactive rows.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (list-people config [include-inactive? #t])
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (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))
|
|
(let ((clean (string-trim name)))
|
|
(when (or (string=? clean "") (> (string-length clean) 200))
|
|
(error who "person name must contain between 1 and 200 characters"))
|
|
clean))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Create or reactivate a person in the shared registry.
|
|
; pre : name is a string containing between 1 and 200 non-whitespace characters.
|
|
; post : A matching person exists and is active.
|
|
; result : The stored person hash.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (create-person! config name)
|
|
(let ((clean-name (clean-person-name 'create-person! name)))
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(let ((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)))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Change the name and active state of one registered person.
|
|
; pre : id identifies a possible person and name is valid registry text.
|
|
; post : The matching row, when present, contains the supplied values.
|
|
; result : The updated person hash, or #f when id does not exist.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (update-person! config id name active?)
|
|
(let ((clean-name (clean-person-name 'update-person! name)))
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(let ((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.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Add previously unknown person tags from a CMap document.
|
|
; pre : db is inside the CMap write transaction and document is a CMap hash.
|
|
; post : Every distinct person tag has a registry row; existing rows are unchanged.
|
|
; result : void.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (sync-person-tags! db document)
|
|
(let ((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")))
|