From 7851b6408e4954e7b2ebce500de8734b246ee439 Mon Sep 17 00:00:00 2001
From: Pjotr Prins
Date: Thu, 10 Aug 2023 13:43:46 +0200
Subject: Render HTML on species

---
 web/view/doc.scm  | 20 +++++++++++++++-----
 web/webserver.scm | 23 ++++++++++++++++-------
 2 files changed, 31 insertions(+), 12 deletions(-)

(limited to 'web')

diff --git a/web/view/doc.scm b/web/view/doc.scm
index 1125147..71112eb 100644
--- a/web/view/doc.scm
+++ b/web/view/doc.scm
@@ -15,7 +15,12 @@
 (define* (layout #:key
                  (head '())
                  (body '())
-                 (title "GeneNetwork.org API"))
+                 (title "GeneNetwork.org API")
+                 (info "")
+                 (meta "")
+                 (data "")
+                 (back "")
+                 )
   `((doctype "html")
     (html (@ (lang "en"))
      (head
@@ -30,8 +35,13 @@
           (type "text/css")
           (href "./css/gn-doc.css")))
       ,@head)
-     (body (h1 ,body)
-           ; ,body
+     (body (h1 ,title)
+           (p ,info)
+           (p "JSON API: " (a (@ (href ,meta)) "meta") " | "
+              (a (@ (href ,data)) "data") " | "
+              (a (@ (href ,back)) "back"))
+           (pre
+           ,(scm->json-string body #:pretty #t))
            ; (p ,(parse-html "<b>some raw really <i>text</i> here</b>"))
            (footer
             (p "Copyright © 2005—2023 by the GeneNetwork community with a touch of " (span (@ (class "lambda")) "λ") "!")
@@ -40,5 +50,5 @@
                   "source code") "."))
            ))))
 
-(define (view-doc path page)
-  (layout #:body page))
+(define* (view-doc path page #:optional rec)
+  (layout #:title page #:info (assoc-ref rec "info") #:meta (assoc-ref rec "meta") #:data (assoc-ref rec "data") #:back (assoc-ref rec "up") #:body rec))
diff --git a/web/webserver.scm b/web/webserver.scm
index a5671dc..537fad5 100755
--- a/web/webserver.scm
+++ b/web/webserver.scm
@@ -36,11 +36,17 @@
 (define (base-url)
   "https://luna.genenetwork.org")
 
-
 (define (prefix)
   "Build the API URL including version"
   (string-append (base-url) "/api/v" get-version))
 
+(define (base-url)
+  "http://localhost:8091")
+
+(define (prefix)
+  "Build the API URL including version"
+  (base-url))
+
 (define* (mk-url postfix #:optional (ext ""))
   "Add the path to the API URL"
   (string-append (prefix) "/" postfix ext))
@@ -189,11 +195,12 @@
 
 (define (get-species-meta)
   (let ([recs (get-expanded-species)])
-    `(("comment" . "Get information on species")
+    `(("info" . "Get information on species by visiting the data link or one of the individual links")
       ("doc" . ,(mk-doc "species"))
       ("meta" . ,(mk-meta "species"))
-      ("rec" . ,(mk-rec "species"))
-      ("meta" . ,(get-species-meta2 recs))
+      ("data" . ,(mk-rec "species"))
+      ("up" . ,(string-append (prefix) "/"))
+      ("meta-links" . ,(get-species-meta2 recs))
       ("links" . ,(get-species-links recs)))))
 
 ;; ---- REST API web server handler
@@ -207,11 +214,11 @@
   (list (build-response #:code 404)
         (string-append "Resource not found: " (uri->string uri))))
 
-(define* (render-doc path page #:key (extra-headers '()))
+(define* (render-doc path page #:optional rec #:key (extra-headers '()))
   (list (append extra-headers
                 '((content-type . (text/html))))
         (lambda (port)
-          (sxml->html (view-doc (pk path) (pk page)) port))))
+          (sxml->html (view-doc (pk path) (pk page) rec) port))))
 
 (define (render-json json)
   (list '((content-type . (application/json)))
@@ -231,6 +238,8 @@
      (render-json info))
     (('GET "version")
      (render-json get-version))
+    (('GET "doc" "species.html")
+     (render-doc "doc" "species.html" (get-species-meta)))
     (('GET "doc" path ... page) ; serve documents from /doc/
      (render-doc path page))
     (('GET "species.json")
@@ -255,7 +264,7 @@
           (request-method request)
           (uri-path (request-uri request)))
   (apply values
-         ((controller request body)
+         ((controller (pk request) body)
           (cons (request-method request)
                 (request-path-components request)))))
 
-- 
cgit v1.2.3