#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)))