Bettern cmap handling. Lots of changes.

server.rkt

@@ -15,10 +15,12 @@
          web-server/http
          web-server/servlet-env
          "private/auth.rkt"
+         "private/cmap-storage.rkt"
          "private/config.rkt"
          "private/http-util.rkt"
          "private/setup.rkt"
          "private/storage.rkt"
+         "private/version.rkt"
          "translate.rkt")
 
 (provide start-wiki-server)
@@ -181,18 +183,140 @@ CSS
   (require-role
    config req 'reader
    (λ (_session)
-     (json-response (hash 'pages (list-pages config))))))
+     (json-response (hash 'pages (list-pages config)
+                          'aliases (list-page-aliases config))))))
+
+(define (concept-map-list-handler config req)
+  (require-role
+   config req 'reader
+   (λ (_session)
+     (json-response (hash 'conceptMaps (list-concept-maps config))))))
+
+(define (request-concept-map-document body)
+  (define document (hash-ref body 'document #f))
+  (unless (hash? document)
+    (raise-argument-error 'request-concept-map-document "hash?" document))
+  document)
+
+(define (concept-map-create-handler config req)
+  (require-write-role
+   config req 'editor
+   (λ (session)
+     (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
+       (define body (request-json req))
+       (define title (string-trim (hash-ref body 'title "")))
+       (define requested-slug (string-trim (hash-ref body 'slug "")))
+       (define slug
+         (if (string=? requested-slug "")
+             (title->slug title)
+             requested-slug))
+       (define document (request-concept-map-document body))
+       (cond
+         ((string=? title "") (json-error 400 "Title is required"))
+         ((string=? slug "") (json-error 400 "The title cannot be converted to a concept map address"))
+         ((read-concept-map config slug)
+          (json-error 409 "A concept map with this address already exists"))
+         (else
+          (json-response
+           (create-concept-map! config
+                                slug
+                                title
+                                document
+                                (wiki-user-username (wiki-session-user session)))
+           #:code 201)))))))
+
+(define (concept-map-get-handler config req slug)
+  (require-role
+   config req 'reader
+   (λ (_session)
+     (define concept-map (read-concept-map config slug))
+     (if concept-map
+         (json-response concept-map)
+         (json-error 404 "Concept map not found")))))
+
+(define (concept-map-update-handler config req slug)
+  (require-write-role
+   config req 'editor
+   (λ (session)
+     (with-handlers ((exn:fail?
+                      (λ (e)
+                        (if (string=? (exn-message e) "update-concept-map!: version-conflict")
+                            (json-error 409 "Concept map changed since it was opened")
+                            (json-error 400 (exn-message e))))))
+       (define body (request-json req))
+       (define title (string-trim (hash-ref body 'title "")))
+       (define document (request-concept-map-document body))
+       (define base-version (hash-ref body 'baseVersion ""))
+       (json-response
+        (update-concept-map! config
+                             slug
+                             title
+                             document
+                             (wiki-user-username (wiki-session-user session))
+                             base-version))))))
+
+(define (concept-map-rename-handler config req slug)
+  (require-write-role
+   config req 'editor
+   (λ (session)
+     (with-handlers ((exn:fail?
+                      (λ (e)
+                        (if (string=? (exn-message e) "rename-concept-map!: version-conflict")
+                            (json-error 409 "Concept map changed since it was opened")
+                            (json-error 400 (exn-message e))))))
+       (define body (request-json req))
+       (define title (string-trim (hash-ref body 'title "")))
+       (define base-version (hash-ref body 'baseVersion ""))
+       (json-response
+        (rename-concept-map! config
+                             slug
+                             title
+                             (wiki-user-username (wiki-session-user session))
+                             base-version))))))
+
+(define (concept-map-delete-handler config req slug)
+  (require-write-role
+   config req 'editor
+   (λ (session)
+     (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
+       (archive-concept-map! config
+                             slug
+                             (wiki-user-username (wiki-session-user session)))
+       (json-response (hash 'ok #t))))))
 
 (define (request-query-value req key [default ""])
   (define found (assoc key (url-query (request-uri req))))
   (if found (cdr found) default))
 
+(define (search-result-before? first-result second-result)
+  (define first-rank (hash-ref first-result 'rank 0))
+  (define second-rank (hash-ref second-result 'rank 0))
+  (if (= first-rank second-rank)
+      (string-ci<? (hash-ref first-result 'title "")
+                   (hash-ref second-result 'title ""))
+      (> first-rank second-rank)))
+
+(define (recent-result-before? first-result second-result)
+  (define first-updated-at (hash-ref first-result 'updatedAt 0))
+  (define second-updated-at (hash-ref second-result 'updatedAt 0))
+  (if (= first-updated-at second-updated-at)
+      (string-ci<? (hash-ref first-result 'title "")
+                   (hash-ref second-result 'title ""))
+      (> first-updated-at second-updated-at)))
+
 (define (search-handler config req)
   (require-role
    config req 'reader
    (λ (_session)
      (define query-text (request-query-value req 'q))
-     (json-response (hash 'results (search-pages config query-text))))))
+     (define page-results (search-pages config query-text))
+     (define concept-map-results (search-concept-maps config query-text))
+     (define sorted-results
+       (sort (append page-results concept-map-results)
+             search-result-before?))
+     (define result-count (min 50 (length sorted-results)))
+     (json-response
+      (hash 'results (take sorted-results result-count))))))
 
 (define (todo-list-handler config req)
   (require-role
@@ -205,7 +329,17 @@ CSS
   (require-role
    config req 'reader
    (λ (_session)
-     (json-response (hash 'pages (list-recent-pages config))))))
+     (define page-results
+       (map (λ (page) (hash-set page 'type "page"))
+            (list-recent-pages config)))
+     (define concept-map-results
+       (map (λ (concept-map) (hash-set concept-map 'type "cmap"))
+            (list-recent-concept-maps config)))
+     (define sorted-results
+       (sort (append page-results concept-map-results)
+             recent-result-before?))
+     (define result-count (min 50 (length sorted-results)))
+     (json-response (hash 'items (take sorted-results result-count))))))
 
 (define (bookmark-list-handler config req)
   (require-role
@@ -313,7 +447,6 @@ CSS
                             (json-error 400 (exn-message e))))))
        (define body (request-json req))
        (define title (hash-ref body 'title ""))
-       (define namespace (hash-ref body 'namespace #f))
        (define markdown (hash-ref body 'markdown ""))
        (define tags (request-tags body))
        (define base-version (hash-ref body 'baseVersion ""))
@@ -327,7 +460,28 @@ CSS
                       base-version
                       summary
                       tags
-                      namespace))))))
+                      #f))))))
+
+(define (page-rename-handler config req reference)
+  (require-write-role
+   config req 'editor
+   (λ (session)
+     (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
+       (when (string=? reference (translation-page-slug))
+         (error 'page-rename-handler "the translations system page cannot be renamed"))
+       (define body (request-json req))
+       (define title (string-trim (hash-ref body 'title "")))
+       (define namespace (string-trim (hash-ref body 'namespace "")))
+       (define slug (string-trim (hash-ref body 'slug "")))
+       (define summary (hash-ref body 'summary "Renamed page"))
+       (json-response
+        (rename-page! config
+                      reference
+                      title
+                      namespace
+                      slug
+                      (wiki-user-username (wiki-session-user session))
+                      summary))))))
 
 (define (page-delete-handler config req slug)
   (require-write-role
@@ -420,6 +574,35 @@ CSS
        (delete-orphaned-upload! config id)
        (json-response (hash 'ok #t))))))
 
+(define (admin-info-handler config req)
+  (require-role
+   config req 'admin
+   (λ (_session)
+     (json-response (hash 'softwareVersion racket-wiki-version)))))
+
+(define (admin-page-aliases-handler config req)
+  (require-role
+   config req 'admin
+   (λ (_session)
+     (json-response (hash 'aliases (list-page-alias-details config))))))
+
+
+(define (admin-cleanup-page-alias-handler config req id)
+  (require-write-role
+   config req 'admin
+   (λ (session)
+     (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
+       (define author (wiki-user-username (wiki-session-user session)))
+       (json-response (cleanup-page-alias! config id author))))))
+
+(define (admin-delete-page-alias-handler config req id)
+  (require-write-role
+   config req 'admin
+   (λ (_session)
+     (with-handlers ((exn:fail? (λ (e) (json-error 400 (exn-message e)))))
+       (delete-page-alias! config id)
+       (json-response (hash 'ok #t))))))
+
 (define (admin-users-handler config req)
   (require-role
    config req 'admin
@@ -476,13 +659,18 @@ CSS
   (string-append "/" (string-join segments "/")))
 
 (define (index-response)
+  (define cmap-cache-id (number->string (random 1000000000)))
+  (define index-html
+    (file->string (build-path static-directory "index.html")))
+  (define cache-busted-index-html
+    (string-replace index-html "__CMAP_CACHE_ID__" cmap-cache-id))
   (bytes-response
-   (file->bytes (build-path static-directory "index.html"))
+   (string->bytes/utf-8 cache-busted-index-html)
    #"text/html; charset=utf-8"
    #:headers (list (make-header #"Cache-Control" #"no-cache"))))
 
 (define (static-request-path? path)
-  (or (regexp-match? #px"^/(vendor|css|js)/" path)
+  (or (regexp-match? #px"^/(vendor|cmap|css|js)/" path)
       (string=? path "/favicon.ico")))
 
 (define (application-api-path? path)
@@ -547,12 +735,26 @@ CSS
       (λ (req) (search-handler config req))]
      [("api" "pages") #:method "get"
       (λ (req) (page-list-handler config req))]
+     [("api" "cmaps") #:method "get"
+      (λ (req) (concept-map-list-handler config req))]
+     [("api" "cmaps") #:method "post"
+      (λ (req) (concept-map-create-handler config req))]
+     [("api" "cmaps" (string-arg)) #:method "get"
+      (λ (req slug) (concept-map-get-handler config req slug))]
+     [("api" "cmaps" (string-arg)) #:method "put"
+      (λ (req slug) (concept-map-update-handler config req slug))]
+     [("api" "cmaps" (string-arg) "rename") #:method "post"
+      (λ (req slug) (concept-map-rename-handler config req slug))]
+     [("api" "cmaps" (string-arg)) #:method "delete"
+      (λ (req slug) (concept-map-delete-handler config req slug))]
      [("api" "pages") #:method "post"
       (λ (req) (page-create-handler config req))]
      [("api" "pages" (string-arg)) #:method "get"
       (λ (req slug) (page-get-handler config req slug))]
      [("api" "pages" (string-arg)) #:method "put"
       (λ (req slug) (page-update-handler config req slug))]
+     [("api" "pages" (string-arg) "rename") #:method "post"
+      (λ (req slug) (page-rename-handler config req slug))]
      [("api" "pages" (string-arg)) #:method "delete"
       (λ (req slug) (page-delete-handler config req slug))]
      [("api" "pages" (string-arg) "history") #:method "get"
@@ -563,6 +765,14 @@ CSS
       (λ (req slug) (upload-handler config req slug))]
      [("uploads" (string-arg) (string-arg)) #:method "get"
       (λ (req slug stored-name) (upload-get-handler config req slug stored-name))]
+     [("api" "admin" "info") #:method "get"
+      (λ (req) (admin-info-handler config req))]
+     [("api" "admin" "aliases") #:method "get"
+      (λ (req) (admin-page-aliases-handler config req))]
+     [("api" "admin" "aliases" (integer-arg) "cleanup") #:method "post"
+      (λ (req id) (admin-cleanup-page-alias-handler config req id))]
+     [("api" "admin" "aliases" (integer-arg)) #:method "delete"
+      (λ (req id) (admin-delete-page-alias-handler config req id))]
      [("api" "admin" "uploads" "orphaned") #:method "get"
       (λ (req) (admin-orphaned-uploads-handler config req))]
      [("api" "admin" "uploads" "orphaned" (integer-arg)) #:method "delete"