539 lines
21 KiB
Plaintext
539 lines
21 KiB
Plaintext
#lang racket/base
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Repeatable import of the bundled racket-wiki architecture pages and CMaps.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(require file/sha1
|
|
json
|
|
racket/cmdline
|
|
racket/file
|
|
racket/list
|
|
racket/path
|
|
racket/runtime-path
|
|
racket/set
|
|
racket/string
|
|
"../private/cmap-storage.rkt"
|
|
"../private/config.rkt"
|
|
"../private/database.rkt"
|
|
"../private/storage.rkt")
|
|
|
|
(provide (struct-out architecture-import-result)
|
|
validate-racket-wiki-architecture!
|
|
import-racket-wiki-architecture-from-data-directory!
|
|
import-racket-wiki-architecture!)
|
|
|
|
(struct architecture-import-result (kind reference status message)
|
|
#:transparent)
|
|
|
|
(struct architecture-page (reference title markdown tags)
|
|
#:transparent)
|
|
|
|
(struct architecture-concept-map (slug title document)
|
|
#:transparent)
|
|
|
|
(define-runtime-path architecture-directory ".")
|
|
|
|
(define page-source-marker-pattern
|
|
#px"^<!-- racket-wiki-architecture-source: ([0-9a-f]+) -->\\r?\\n")
|
|
|
|
(define concept-map-source-marker-id
|
|
"racket-wiki-architecture-source")
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Content loading and validation
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (manifest-path)
|
|
(build-path architecture-directory "manifest.rktd"))
|
|
|
|
(define (read-manifest)
|
|
(call-with-input-file (manifest-path) read))
|
|
|
|
(define (content-path relative-path)
|
|
(build-path architecture-directory relative-path))
|
|
|
|
(define (canonical-datum value)
|
|
(cond
|
|
[(hash? value)
|
|
(define keys
|
|
(sort (hash-keys value)
|
|
string<?
|
|
#:key (λ (key) (format "~a" key))))
|
|
(for/list ([key (in-list keys)])
|
|
(list key (canonical-datum (hash-ref value key))))]
|
|
[(list? value)
|
|
(for/list ([item (in-list value)])
|
|
(canonical-datum item))]
|
|
[else value]))
|
|
|
|
(define (source-hash value)
|
|
(define source-bytes
|
|
(string->bytes/utf-8
|
|
(format "~s" (canonical-datum value))))
|
|
(bytes->hex-string (sha256-bytes source-bytes)))
|
|
|
|
(define (read-page-source namespace specification)
|
|
(define slug (hash-ref specification 'slug))
|
|
(architecture-page
|
|
(page-reference namespace slug)
|
|
(hash-ref specification 'title)
|
|
(file->string (content-path (hash-ref specification 'file)))
|
|
(hash-ref specification 'tags '())))
|
|
|
|
(define (read-concept-map-source specification)
|
|
(architecture-concept-map
|
|
(hash-ref specification 'slug)
|
|
(hash-ref specification 'title)
|
|
(call-with-input-file
|
|
(content-path (hash-ref specification 'file))
|
|
read-json)))
|
|
|
|
(define (load-architecture-content)
|
|
(define manifest (read-manifest))
|
|
(unless (hash? manifest)
|
|
(error 'load-architecture-content "manifest.rktd must contain a hash"))
|
|
(define namespace (hash-ref manifest 'namespace))
|
|
(define pages
|
|
(for/list ([specification (in-list (hash-ref manifest 'pages))])
|
|
(read-page-source namespace specification)))
|
|
(define concept-maps
|
|
(for/list ([specification (in-list (hash-ref manifest 'concept-maps))])
|
|
(read-concept-map-source specification)))
|
|
(values namespace pages concept-maps))
|
|
|
|
(define (duplicate-values values)
|
|
(define seen (mutable-set))
|
|
(define duplicates (mutable-set))
|
|
(for ([value (in-list values)])
|
|
(if (set-member? seen value)
|
|
(set-add! duplicates value)
|
|
(set-add! seen value)))
|
|
(sort (set->list duplicates) string<?))
|
|
|
|
(define (validate-page-links! page page-references concept-map-slugs)
|
|
(define markdown (architecture-page-markdown page))
|
|
(define linked-pages
|
|
(regexp-match*
|
|
#px"\\]\\((racket-wiki:[^)#]+)(?:#[^)]*)?\\)"
|
|
markdown
|
|
#:match-select (λ (match) (list-ref match 1))))
|
|
(define embedded-concept-maps
|
|
(for/list ([line (in-list (string-split markdown "\n" #:trim? #f))]
|
|
#:do [(define match
|
|
(regexp-match
|
|
#px"^\\s*\\{\\{cmap:([^{}\\n]+)\\}\\}\\s*$"
|
|
line))]
|
|
#:when match)
|
|
(string-trim (list-ref match 1))))
|
|
(for ([reference (in-list linked-pages)])
|
|
(unless (set-member? page-references reference)
|
|
(error 'validate-racket-wiki-architecture!
|
|
"page ~a links to unknown architecture page ~a"
|
|
(architecture-page-reference page)
|
|
reference)))
|
|
(for ([slug (in-list embedded-concept-maps)])
|
|
(unless (set-member? concept-map-slugs slug)
|
|
(error 'validate-racket-wiki-architecture!
|
|
"page ~a embeds unknown architecture CMap ~a"
|
|
(architecture-page-reference page)
|
|
slug))))
|
|
|
|
(define (validate-concept-map! concept-map page-references)
|
|
(define document (architecture-concept-map-document concept-map))
|
|
(unless (hash? document)
|
|
(error 'validate-racket-wiki-architecture!
|
|
"CMap ~a is not a JSON object"
|
|
(architecture-concept-map-slug concept-map)))
|
|
(unless (equal? (hash-ref document 'schemaVersion #f) 1)
|
|
(error 'validate-racket-wiki-architecture!
|
|
"CMap ~a does not use schema version 1"
|
|
(architecture-concept-map-slug concept-map)))
|
|
(define items (hash-ref document 'items '()))
|
|
(define connectors (hash-ref document 'connectors '()))
|
|
(unless (and (list? items) (list? connectors))
|
|
(error 'validate-racket-wiki-architecture!
|
|
"CMap ~a must contain item and connector arrays"
|
|
(architecture-concept-map-slug concept-map)))
|
|
(define item-ids
|
|
(for/list ([item (in-list items)])
|
|
(unless (hash? item)
|
|
(error 'validate-racket-wiki-architecture!
|
|
"CMap ~a contains a non-object item"
|
|
(architecture-concept-map-slug concept-map)))
|
|
(define item-id (hash-ref item 'id #f))
|
|
(unless (exact-positive-integer? item-id)
|
|
(error 'validate-racket-wiki-architecture!
|
|
"CMap ~a contains an invalid item id"
|
|
(architecture-concept-map-slug concept-map)))
|
|
(define linked-page (hash-ref item 'pageSlug #f))
|
|
(when (and linked-page (not (set-member? page-references linked-page)))
|
|
(error 'validate-racket-wiki-architecture!
|
|
"CMap ~a links to unknown architecture page ~a"
|
|
(architecture-concept-map-slug concept-map)
|
|
linked-page))
|
|
item-id))
|
|
(define duplicate-item-ids
|
|
(duplicate-values (map number->string item-ids)))
|
|
(unless (null? duplicate-item-ids)
|
|
(error 'validate-racket-wiki-architecture!
|
|
"CMap ~a has duplicate item ids: ~a"
|
|
(architecture-concept-map-slug concept-map)
|
|
(string-join duplicate-item-ids ", ")))
|
|
(define item-id-set (list->set item-ids))
|
|
(for ([connector (in-list connectors)])
|
|
(unless (hash? connector)
|
|
(error 'validate-racket-wiki-architecture!
|
|
"CMap ~a contains a non-object connector"
|
|
(architecture-concept-map-slug concept-map)))
|
|
(define source-id (hash-ref connector 'sourceId #f))
|
|
(define target-id (hash-ref connector 'targetId #f))
|
|
(unless (and (set-member? item-id-set source-id)
|
|
(set-member? item-id-set target-id))
|
|
(error 'validate-racket-wiki-architecture!
|
|
"CMap ~a contains a connector with an unknown endpoint"
|
|
(architecture-concept-map-slug concept-map)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Validate every bundled page, link and CMap before importing.
|
|
; pre : The architecture files are present beside this module.
|
|
; post : No wiki or file state has been changed.
|
|
; result : Two values containing the validated pages and CMaps.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (validate-racket-wiki-architecture!)
|
|
(define-values (namespace pages concept-maps)
|
|
(load-architecture-content))
|
|
(unless (string=? namespace "racket-wiki")
|
|
(error 'validate-racket-wiki-architecture!
|
|
"the architecture namespace must be racket-wiki"))
|
|
(define page-reference-list
|
|
(map architecture-page-reference pages))
|
|
(define concept-map-slug-list
|
|
(map architecture-concept-map-slug concept-maps))
|
|
(define duplicate-pages (duplicate-values page-reference-list))
|
|
(define duplicate-concept-maps (duplicate-values concept-map-slug-list))
|
|
(unless (null? duplicate-pages)
|
|
(error 'validate-racket-wiki-architecture!
|
|
"duplicate page references: ~a"
|
|
(string-join duplicate-pages ", ")))
|
|
(unless (null? duplicate-concept-maps)
|
|
(error 'validate-racket-wiki-architecture!
|
|
"duplicate CMap slugs: ~a"
|
|
(string-join duplicate-concept-maps ", ")))
|
|
(for ([reference (in-list page-reference-list)])
|
|
(unless (valid-page-reference? reference)
|
|
(error 'validate-racket-wiki-architecture!
|
|
"invalid page reference: ~a"
|
|
reference)))
|
|
(for ([slug (in-list concept-map-slug-list)])
|
|
(unless (valid-slug? slug)
|
|
(error 'validate-racket-wiki-architecture!
|
|
"invalid CMap slug: ~a"
|
|
slug)))
|
|
(define page-references (list->set page-reference-list))
|
|
(define concept-map-slugs (list->set concept-map-slug-list))
|
|
(for ([page (in-list pages)])
|
|
(validate-page-links! page page-references concept-map-slugs))
|
|
(for ([concept-map (in-list concept-maps)])
|
|
(validate-concept-map! concept-map page-references))
|
|
(values pages concept-maps))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Source ownership markers
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (page-with-source-marker title markdown tags)
|
|
(string-append
|
|
"<!-- racket-wiki-architecture-source: "
|
|
(source-hash (list title markdown tags))
|
|
" -->\n"
|
|
markdown))
|
|
|
|
(define (page-source-unmodified? title markdown tags)
|
|
(define match (regexp-match page-source-marker-pattern markdown))
|
|
(and match
|
|
(let ([body (regexp-replace page-source-marker-pattern markdown "")]
|
|
[stored-hash (list-ref match 1)])
|
|
(string=? stored-hash (source-hash (list title body tags))))))
|
|
|
|
(define (concept-map-source-marker? reference)
|
|
(and (hash? reference)
|
|
(string=? (hash-ref reference 'id "")
|
|
concept-map-source-marker-id)))
|
|
|
|
(define (concept-map-without-source-marker document)
|
|
(define references (hash-ref document 'conceptMaps '()))
|
|
(hash-set document
|
|
'conceptMaps
|
|
(filter (λ (reference)
|
|
(not (concept-map-source-marker? reference)))
|
|
references)))
|
|
|
|
(define (concept-map-with-source-marker title document)
|
|
(define clean-document (concept-map-without-source-marker document))
|
|
(define marker
|
|
(hash 'id concept-map-source-marker-id
|
|
'kind "architecture-source"
|
|
'sourceHash (source-hash (list title clean-document))))
|
|
(hash-set clean-document
|
|
'conceptMaps
|
|
(append (hash-ref clean-document 'conceptMaps '())
|
|
(list marker))))
|
|
|
|
(define (concept-map-source-unmodified? title document)
|
|
(define marker
|
|
(findf concept-map-source-marker?
|
|
(hash-ref document 'conceptMaps '())))
|
|
(and marker
|
|
(string=? (hash-ref marker 'sourceHash "")
|
|
(source-hash
|
|
(list title
|
|
(concept-map-without-source-marker document))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Import operations
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (result kind reference status message)
|
|
(architecture-import-result kind reference status message))
|
|
|
|
(define (page-content-equal? current page marked-markdown)
|
|
(and (string=? (hash-ref current 'title)
|
|
(architecture-page-title page))
|
|
(string=? (hash-ref current 'markdown)
|
|
marked-markdown)
|
|
(equal? (hash-ref current 'tags '())
|
|
(architecture-page-tags page))))
|
|
|
|
(define (import-page! config page author dry-run? overwrite-modified?)
|
|
(define reference (architecture-page-reference page))
|
|
(define marked-markdown
|
|
(page-with-source-marker (architecture-page-title page)
|
|
(architecture-page-markdown page)
|
|
(architecture-page-tags page)))
|
|
(define current (read-page config reference))
|
|
(cond
|
|
[(not current)
|
|
(if dry-run?
|
|
(result 'page reference 'would-create "Page would be created")
|
|
(begin
|
|
(create-page! config
|
|
reference
|
|
(architecture-page-title page)
|
|
marked-markdown
|
|
author
|
|
"Imported racket-wiki architecture documentation"
|
|
(architecture-page-tags page))
|
|
(result 'page reference 'created "Page created")))]
|
|
[(page-content-equal? current page marked-markdown)
|
|
(result 'page reference 'unchanged "Page already matches the bundled source")]
|
|
[(and (not overwrite-modified?)
|
|
(not (page-source-unmodified? (hash-ref current 'title)
|
|
(hash-ref current 'markdown)
|
|
(hash-ref current 'tags '()))))
|
|
(result 'page
|
|
reference
|
|
'skipped-modified
|
|
"Page was modified after import and was not overwritten")]
|
|
[dry-run?
|
|
(result 'page
|
|
reference
|
|
(if overwrite-modified? 'would-overwrite 'would-update)
|
|
"Page would be updated")]
|
|
[else
|
|
(update-page! config
|
|
reference
|
|
(architecture-page-title page)
|
|
marked-markdown
|
|
author
|
|
(hash-ref current 'currentVersion)
|
|
"Updated racket-wiki architecture documentation"
|
|
(architecture-page-tags page))
|
|
(result 'page reference 'updated "Page updated")]))
|
|
|
|
(define (concept-map-content-equal? current concept-map marked-document)
|
|
(and (string=? (hash-ref current 'title)
|
|
(architecture-concept-map-title concept-map))
|
|
(equal? (hash-ref current 'document)
|
|
marked-document)))
|
|
|
|
(define (import-concept-map! config concept-map author dry-run? overwrite-modified?)
|
|
(define slug (architecture-concept-map-slug concept-map))
|
|
(define marked-document
|
|
(concept-map-with-source-marker
|
|
(architecture-concept-map-title concept-map)
|
|
(architecture-concept-map-document concept-map)))
|
|
(define current (read-concept-map config slug))
|
|
(cond
|
|
[(not current)
|
|
(if dry-run?
|
|
(result 'concept-map slug 'would-create "CMap would be created")
|
|
(begin
|
|
(create-concept-map! config
|
|
slug
|
|
(architecture-concept-map-title concept-map)
|
|
marked-document
|
|
author)
|
|
(result 'concept-map slug 'created "CMap created")))]
|
|
[(concept-map-content-equal? current concept-map marked-document)
|
|
(result 'concept-map slug 'unchanged "CMap already matches the bundled source")]
|
|
[(and (not overwrite-modified?)
|
|
(not (concept-map-source-unmodified?
|
|
(hash-ref current 'title)
|
|
(hash-ref current 'document))))
|
|
(result 'concept-map
|
|
slug
|
|
'skipped-modified
|
|
"CMap was modified after import and was not overwritten")]
|
|
[dry-run?
|
|
(result 'concept-map
|
|
slug
|
|
(if overwrite-modified? 'would-overwrite 'would-update)
|
|
"CMap would be updated")]
|
|
[else
|
|
(update-concept-map! config
|
|
slug
|
|
(architecture-concept-map-title concept-map)
|
|
marked-document
|
|
author
|
|
(hash-ref current 'currentVersion)
|
|
"Updated racket-wiki architecture CMap"
|
|
"import")
|
|
(result 'concept-map slug 'updated "CMap updated")]))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Import the bundled architecture set below namespace racket-wiki.
|
|
; pre : config points at an initialized or initializable PostgreSQL wiki.
|
|
; post : Missing managed pages/CMaps are created and unchanged managed
|
|
; sources can receive new versions; locally modified sources are
|
|
; skipped unless overwrite-modified? is true.
|
|
; result : A list of architecture-import-result values.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (import-racket-wiki-architecture!
|
|
config
|
|
#:author [author "racket-wiki architecture import"]
|
|
#:dry-run? [dry-run? #f]
|
|
#:overwrite-modified? [overwrite-modified? #f])
|
|
(define-values (pages concept-maps)
|
|
(validate-racket-wiki-architecture!))
|
|
(ensure-wiki-data! config)
|
|
(unless (database-settings-exist? config)
|
|
(error 'import-racket-wiki-architecture!
|
|
"PostgreSQL is not configured for data directory ~a"
|
|
(wiki-config-data-dir config)))
|
|
(initialize-database! config)
|
|
(append
|
|
(for/list ([page (in-list pages)])
|
|
(import-page! config page author dry-run? overwrite-modified?))
|
|
(for/list ([concept-map (in-list concept-maps)])
|
|
(import-concept-map! config
|
|
concept-map
|
|
author
|
|
dry-run?
|
|
overwrite-modified?))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Import the architecture set using only a wiki data directory.
|
|
; pre : data-directory contains the wiki's database.rktd configuration.
|
|
; post : The same changes as import-racket-wiki-architecture! have occurred.
|
|
; result : A list of architecture-import-result values.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (import-racket-wiki-architecture-from-data-directory!
|
|
data-directory
|
|
#:author [author "racket-wiki architecture import"]
|
|
#:dry-run? [dry-run? #f]
|
|
#:overwrite-modified? [overwrite-modified? #f])
|
|
(define config
|
|
(make-wiki-config #:data-dir data-directory))
|
|
(import-racket-wiki-architecture!
|
|
config
|
|
#:author author
|
|
#:dry-run? dry-run?
|
|
#:overwrite-modified? overwrite-modified?))
|
|
|
|
(define (display-import-results results)
|
|
(for ([import-result (in-list results)])
|
|
(displayln
|
|
(format "~a ~a ~a"
|
|
(architecture-import-result-status import-result)
|
|
(architecture-import-result-kind import-result)
|
|
(architecture-import-result-reference import-result))))
|
|
(define skipped
|
|
(count (λ (import-result)
|
|
(eq? (architecture-import-result-status import-result)
|
|
'skipped-modified))
|
|
results))
|
|
(displayln (format "Processed ~a architecture items." (length results)))
|
|
(when (> skipped 0)
|
|
(displayln
|
|
(format
|
|
"~a locally modified item(s) were preserved. Review them before using --overwrite-modified."
|
|
skipped))))
|
|
|
|
(module+ main
|
|
(define config (default-wiki-config))
|
|
(define author "racket-wiki architecture import")
|
|
(define dry-run? #f)
|
|
(define overwrite-modified? #f)
|
|
|
|
(command-line
|
|
#:program "racket-wiki architecture import"
|
|
#:once-each
|
|
[("--data") directory
|
|
"Wiki data directory"
|
|
(set! config
|
|
(struct-copy wiki-config config
|
|
[data-dir (path->complete-path directory)]))]
|
|
[("--author") name
|
|
"Author recorded in imported page and CMap versions"
|
|
(set! author name)]
|
|
[("--dry-run")
|
|
"Validate and report changes without changing wiki content"
|
|
(set! dry-run? #t)]
|
|
[("--overwrite-modified")
|
|
"Replace architecture items that were edited after import"
|
|
(set! overwrite-modified? #t)])
|
|
|
|
(display-import-results
|
|
(import-racket-wiki-architecture!
|
|
config
|
|
#:author author
|
|
#:dry-run? dry-run?
|
|
#:overwrite-modified? overwrite-modified?)))
|
|
|
|
(module+ test
|
|
(require rackunit)
|
|
|
|
(define-values (test-pages test-concept-maps)
|
|
(validate-racket-wiki-architecture!))
|
|
|
|
(check-equal? (length test-pages) 12)
|
|
(check-equal? (length test-concept-maps) 2)
|
|
|
|
(define test-markdown "# Test\n\nBody.\n")
|
|
(define marked-test-markdown
|
|
(page-with-source-marker "Test" test-markdown '("test")))
|
|
(check-true
|
|
(page-source-unmodified? "Test" marked-test-markdown '("test")))
|
|
(check-false
|
|
(page-source-unmodified? "Test"
|
|
(string-append marked-test-markdown "Local edit\n")
|
|
'("test")))
|
|
(check-false
|
|
(page-source-unmodified? "Changed title"
|
|
marked-test-markdown
|
|
'("test")))
|
|
|
|
(define test-document
|
|
(architecture-concept-map-document (car test-concept-maps)))
|
|
(define marked-test-document
|
|
(concept-map-with-source-marker "Test CMap" test-document))
|
|
(check-true
|
|
(concept-map-source-unmodified? "Test CMap" marked-test-document))
|
|
(check-false
|
|
(concept-map-source-unmodified?
|
|
"Test CMap"
|
|
(hash-set marked-test-document 'schemaVersion 2)))
|
|
(check-false
|
|
(concept-map-source-unmodified? "Changed title" marked-test-document)))
|