#lang racket/base

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Migrate document-internal CMap pages to shared stored views.
;;
;; The parent document remains the canonical graph. A stored child CMap only
;; records which submap root it displays, so concepts, relations and layout
;; contexts are never copied or removed from the parent.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require db
         json
         racket/cmdline
         racket/list
         racket/path
         racket/string
         "private/config.rkt"
         "private/database.rkt"
         "private/storage.rkt")

(define migration-author "system:cmap-shared-submap-migration")
(define replaceable-authors
  '("system:cmap-subpage-migration" "system:cmap-subpage-migration-repair"))

(define (json-list document key)
  (define value (hash-ref document key '()))
  (if (list? value) value '()))

(define (parse-document text)
  (define first (string->jsexpr text))
  (define document (if (string? first) (string->jsexpr first) first))
  (unless (hash? document)
    (error 'parse-document "stored CMap document is not an object"))
  document)

(define (legacy-submap? item)
  (and (equal? (hash-ref item 'kind "") "submap")
       (eq? (hash-ref item 'separateMap #f) #t)
       (let ((slug (hash-ref item 'cmapSlug 'null)))
         (or (eq? slug 'null)
             (and (string? slug) (string=? (string-trim slug) ""))))))

(define (submap-title item)
  (define child-map (hash-ref item 'childMap ""))
  (define label (hash-ref item 'label ""))
  (cond ((and (string? child-map) (not (string=? (string-trim child-map) "")))
         (string-trim child-map))
        ((and (string? label) (not (string=? (string-trim label) "")))
         (string-trim label))
        (else "Sub-CMap")))

(define (derived-document source-slug root-id)
  (hash 'schemaVersion 2
        'derivedView (hash 'sourceCmapSlug source-slug 'rootItemId root-id)
        'concepts '()
        'items '()
        'connectors '()
        'conceptMaps '()))

(define (link-parent-document document roots)
  (define slugs
    (for/hash ((root (in-list roots)))
      (values (hash-ref root 'id) (title->slug (submap-title root)))))
  (hash-set
   document
   'items
   (for/list ((item (in-list (json-list document 'items))))
     (define slug (hash-ref slugs (hash-ref item 'id #f) #f))
     (if slug
         (hash-set (hash-set item 'cmapSlug slug) 'separateMap #t)
         item))))

(define (load-parent-rows connection [lock? #f])
  (query-rows
   connection
   (string-append
    "SELECT id, slug, title, document::text, current_version "
    "FROM concept_maps WHERE archived=FALSE "
    "AND EXISTS (SELECT 1 FROM jsonb_array_elements("
    "CASE WHEN jsonb_typeof(document->'items')='array' "
    "THEN document->'items' ELSE '[]'::jsonb END) item "
    "WHERE coalesce(item->>'kind','')='submap' "
    "AND coalesce((item->>'separateMap')::boolean,FALSE)=TRUE "
    "AND coalesce(item->>'cmapSlug','')='') "
    "ORDER BY id"
    (if lock? " FOR UPDATE" ""))))

(define (existing-child connection slug [lock? #f])
  (query-maybe-row
   connection
   (string-append
    "SELECT id, title, current_version, created_by FROM concept_maps "
    "WHERE slug=$1 AND archived=FALSE"
    (if lock? " FOR UPDATE" ""))
   slug))

(define (replaceable-child? row)
  (and row (member (vector-ref row 3) replaceable-authors)))

(define (check-child! connection parent-slug root [lock? #f])
  (define slug (title->slug (submap-title root)))
  (define row (existing-child connection slug lock?))
  (when (and row (not (replaceable-child? row)))
    (error 'migrate-cmap-subpages
           "target CMap ~a already exists and was not created by the earlier migration"
           slug))
  (hash 'slug slug
        'title (submap-title root)
        'rootId (hash-ref root 'id)
        'sourceSlug parent-slug
        'existing row))

(define (plans-for-row connection row [lock? #f])
  (define document (parse-document (vector-ref row 3)))
  (define roots (filter legacy-submap? (json-list document 'items)))
  (define children
    (for/list ((root (in-list roots)))
      (check-child! connection (vector-ref row 1) root lock?)))
  (values children (link-parent-document document roots)))

(define (report-plan connection)
  (define total 0)
  (for ((row (in-list (load-parent-rows connection))))
    (define-values (children ignored-parent) (plans-for-row connection row))
    (printf "Parent ~a (~a): ~a shared submap view(s)\n"
            (vector-ref row 1) (vector-ref row 2) (length children))
    (for ((child (in-list children)))
      (set! total (add1 total))
      (printf "  ~a -> ~a (~a)\n"
              (hash-ref child 'title)
              (hash-ref child 'slug)
              (if (hash-ref child 'existing) "replace earlier migration result" "create"))))
  (printf "Total: ~a shared view(s). No data changed.\n" total)
  total)

(define (write-child! connection child now)
  (define document-text
    (jsexpr->string
     (derived-document (hash-ref child 'sourceSlug) (hash-ref child 'rootId))))
  (define existing (hash-ref child 'existing))
  (if existing
      (let* ((map-id (vector-ref existing 0))
             (title (vector-ref existing 1))
             (next-version (add1 (vector-ref existing 2))))
        (query-exec
         connection
         #<<SQL
UPDATE concept_maps
SET document=$1::text::jsonb, current_version=$2, updated_at=$3, updated_by=$4
WHERE id=$5
SQL
         document-text next-version now migration-author map-id)
        (query-exec
         connection
         #<<SQL
INSERT INTO concept_map_versions
  (concept_map_id, version, title, document, author, action, summary, created_at)
VALUES ($1,$2,$3,$4::text::jsonb,$5,'shared-view-migration',
        'Converted copied migration result into a canonical shared sub-CMap view',$6)
SQL
         map-id next-version title document-text migration-author now))
      (let ((map-id
             (query-value
              connection
              #<<SQL
INSERT INTO concept_maps
  (slug,title,document,current_version,created_at,updated_at,created_by,updated_by)
VALUES ($1,$2,$3::text::jsonb,1,$4,$4,$5,$5)
RETURNING id
SQL
              (hash-ref child 'slug) (hash-ref child 'title)
              document-text now migration-author)))
        (query-exec
         connection
         #<<SQL
INSERT INTO concept_map_versions
  (concept_map_id,version,title,document,author,action,summary,created_at)
VALUES ($1,1,$2,$3::text::jsonb,$4,'shared-view-migration',
        'Created canonical shared sub-CMap view',$5)
SQL
         map-id (hash-ref child 'title) document-text migration-author now))))

(define (apply-migration! connection)
  (call-with-transaction
   connection
   (lambda ()
     (define now (current-seconds))
     (define total 0)
     (for ((row (in-list (load-parent-rows connection #t))))
       (define-values (children parent-document) (plans-for-row connection row #t))
       (for ((child (in-list children)))
         (write-child! connection child now)
         (set! total (add1 total)))
       (unless (null? children)
         (define map-id (vector-ref row 0))
         (define next-version (add1 (vector-ref row 4)))
         (define parent-text (jsexpr->string parent-document))
         (query-exec
          connection
          #<<SQL
UPDATE concept_maps
SET document=$1::text::jsonb, current_version=$2, updated_at=$3, updated_by=$4
WHERE id=$5
SQL
          parent-text next-version now migration-author map-id)
         (query-exec
          connection
          #<<SQL
INSERT INTO concept_map_versions
  (concept_map_id,version,title,document,author,action,summary,created_at)
VALUES ($1,$2,$3,$4::text::jsonb,$5,'shared-view-migration',
        'Linked internal sub-CMaps to standalone shared views without moving graph data',$6)
SQL
          map-id next-version (vector-ref row 2) parent-text migration-author now)))
     (printf "Migrated ~a submap(s) to shared stored views in one transaction.\n" total)
     total)))

(module+ main
  (define config (default-wiki-config))
  (define apply? #f)
  (command-line
   #:program "migrate-cmap-subpages.rkt"
   #:once-each
   (("--data") directory
    "Wiki data directory"
    (set! config
          (struct-copy wiki-config config
                       (data-dir (path->complete-path directory)))))
   (("--apply")
    "Apply the migration; without this flag only a dry-run is performed"
    (set! apply? #t)))
  (call-with-wiki-database
   config
   (lambda (connection)
     (if apply? (apply-migration! connection) (report-plan connection)))))