about summary refs log tree commit diff
path: root/web/view
diff options
context:
space:
mode:
Diffstat (limited to 'web/view')
-rw-r--r--web/view/brand/aging.scm2
-rw-r--r--web/view/brand/msk.scm2
-rw-r--r--web/view/doc.scm2
-rw-r--r--web/view/markdown.scm136
-rw-r--r--web/view/view.scm12
5 files changed, 119 insertions, 35 deletions
diff --git a/web/view/brand/aging.scm b/web/view/brand/aging.scm
index 19db4d7..040c711 100644
--- a/web/view/brand/aging.scm
+++ b/web/view/brand/aging.scm
@@ -53,7 +53,7 @@
 ,info)
       (footer
        (hr)
-       (p "Copyright © 2005-2023 "
+       (p "Copyright © 2005-2025 "
           (a (@ (href "https://genenetwork.org/")) "GeneNetwork Webservices") " | GeneNetwork and this website runs fully on free software. See status and download the "
           (a (@ (href "https://ci.genenetwork.org/"))
              "source code") ".")))
diff --git a/web/view/brand/msk.scm b/web/view/brand/msk.scm
index 69c1253..4cbcec4 100644
--- a/web/view/brand/msk.scm
+++ b/web/view/brand/msk.scm
@@ -51,7 +51,7 @@
         (p ,info)
         (footer
        (hr)
-       (p "Copyright © 2005-2023 "
+       (p "Copyright © 2005-2025 "
           (a (@ (href "https://genenetwork.org/")) "GeneNetwork Webservices") " | GeneNetwork and this website runs fully on free software. See status and download the "
           (a (@ (href "https://ci.genenetwork.org/"))
              "source code") ".")))
diff --git a/web/view/doc.scm b/web/view/doc.scm
index 71112eb..cec4400 100644
--- a/web/view/doc.scm
+++ b/web/view/doc.scm
@@ -44,7 +44,7 @@
            ,(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")) "λ") "!")
+            (p "Copyright © 2005—2025 by the GeneNetwork community with a touch of " (span (@ (class "lambda")) "λ") "!")
             (p "This is free software. Download the "
                (a (@ (href "https://ci.genenetwork.org/"))
                   "source code") "."))
diff --git a/web/view/markdown.scm b/web/view/markdown.scm
index 2af2b26..6aa2935 100644
--- a/web/view/markdown.scm
+++ b/web/view/markdown.scm
@@ -6,50 +6,126 @@
   #:use-module (ice-9 receive)
   #:use-module (ice-9 string-fun)
   #:use-module (ice-9 textual-ports)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
   #:use-module (sxml simple)
   #:use-module (web client)
   #:use-module (web uri)
   #:use-module (web request)
   #:use-module (web sxml)
   #:use-module (commonmark)
-
-  #:export (markdown-file->sxml
-	    markdown-github->sxml
-	    fetch-raw-file)
-  )
-
+  #:export (markdown-file->sxml markdown-github->sxml fetch-file
+                                fetch-raw-file commit-file git-invoke))
 
 (define (markdown-file->sxml fn)
   "Parse a local file"
-  (commonmark->sxml
-   (call-with-input-file fn
-       get-string-all)))
-
-;; --- fetch github style URLs
+  (commonmark->sxml (call-with-input-file fn
+                      get-string-all)))
 
 (define (fetch-raw-file url)
   (receive (response-status response-body)
-      (http-request url)
-    response-body))
+      (http-request url) response-body))
 
-;; https://github.com/genenetwork/gn-docs/master/general/brand/aging/home.md
-;; https://raw.githubusercontent.com/genenetwork/gn-docs/master/general/brand/aging/home.md
-;; https://github.com/genenetwork/gn-docs/edit/master/general/brand/aging/home.md
+(define* (form-github-raw-url project repo page #:optional (branch "master"))
+  (string-append "https://raw.githubusercontent.com/"
+                 project
+                 "/"
+                 repo
+                 "/"
+		 branch
+		 "/"
+                 (string-join page "/")))
 
-(define (form-github-raw-url project repo page)
-    (string-append "https://raw.githubusercontent.com/" project "/" repo "/master/" (string-join page "/")))
-
-(define (form-github-edit-url project repo page)
-    (string-append "https://github.com/" project "/" repo "/edit/master/" (string-join page "/")))
+(define* (form-github-edit-url project repo page #:optional (branch "master"))
+  (string-append "https://github.com/"
+                 project
+                 "/"
+                 repo
+		 "/edit/"
+		 branch
+		 "/"
+                 (string-join page "/")))
 
 (define (markdown-github->sxml path)
   "Parse a github markdown file that is formed like genenetwork/gn-docs/general/brand/aging/home.md"
-  (match-let (((project repo page ...) (string-split path #\/)))
-    `(div (@ (class "markdown"))
-	  ,(commonmark->sxml
-	    (fetch-raw-file (pk (form-github-raw-url project repo (pk page)))))
-	  (p 
-	   (div (@ (class "button-align-right"))
-		(a (@ (href ,(form-github-edit-url project repo page)) (role "button")) "edit")))
-	  (br)
-	  (br))))
+  (match-let (((project repo page ...)
+               (string-split path #\/)))
+             `(div (@ (class "markdown"))
+                   ,(commonmark->sxml (fetch-raw-file (pk (form-github-raw-url
+                                                           project repo
+                                                           (pk page)))))
+                   (p (div (@ (class "button-align-right"))
+                           (a (@ (href ,(form-github-edit-url project repo
+                                                              page))
+                                 (role "button")) "edit")))
+                   (br)
+                   (br))))
+
+(define (fetch-file repo query-path)
+  (let* ((abs-path (format #f "~a/~a" repo query-path)))
+    (if (file-exists? abs-path)
+        (let* ((full-path (canonicalize-path abs-path))
+               (content (call-with-input-file full-path
+                          get-string-all))
+               (commit-sha (get-latest-commit-sha1 repo)))
+          `(("file_path" unquote query-path)
+            ("content" unquote content)
+            ("hash" unquote commit-sha)))
+        (throw 'file-error
+               (format #f "~a does not exists" abs-path)))))
+
+(define (git-invoke repo-path . args)
+  (apply system* "git" "-C" repo-path args))
+
+(define (git-repository? repo-path)
+  (let ((data (git-invoke repo-path "rev-parse")))
+    (zero? data)))
+
+(define (get-latest-commit-sha1 repo-path)
+  (let* ((output-port (open-input-pipe (string-append "git -C " repo-path
+                                        " log -n 1 --pretty=format:%H HEAD")))
+         (commit-sha (read-line output-port)))
+    (close-port output-port) commit-sha))
+
+(define* (commit-file repo
+                      file-path
+                      content
+                      commit-message
+                      username
+                      email
+                      #:optional (prev-commit ""))
+  (unless (string=? prev-commit
+                    (get-latest-commit-sha1 repo))
+    (throw 'system-error
+           (format #f
+            "Commits do no match.Please pull in latest  changes for current * ~a * and prev * ~a * "
+            (get-latest-commit-sha1 repo) prev-commit)))
+  (if (git-repository? repo)
+      (match (file-exists? (format #f "~a/~a" repo file-path))
+        (#t (with-output-to-file (format #f "~a/~a" repo file-path)
+              (lambda ()
+                (display content)))
+         (let* ((git-add-file (git-invoke repo "add" file-path))
+                (git-commit-file (git-invoke repo
+                                  "commit"
+                                  "-m"
+                                  commit-message
+                                  "-m"
+                                  " * Commit made via the GN Markdown Editor"
+                                  "--author"
+                                  (format #f "~a <~a>" username email)))
+                (git-commit-sha (get-latest-commit-sha1 repo)))
+           (if (zero? git-commit-file)
+               `(("status" . "201")
+                 ("message" . "committed file successfully")
+                 ("content" . ,content)
+                 ("commit_sha" . ,git-commit-sha)
+                 ("commit_message" . ,commit-message))
+               `(("status" . "200")
+                 ("message" . "Nothing to commit, working tree clean")
+                 ("commit_sha" . ,git-commit-sha)))))
+        (#f (throw 'system-error
+                   (format #f "~a File does not exist error" file-path))))
+      (throw 'system-error
+             (format #f "~a is no a git repo" repo))))
diff --git a/web/view/view.scm b/web/view/view.scm
index 4584cf8..95ff0a1 100644
--- a/web/view/view.scm
+++ b/web/view/view.scm
@@ -10,11 +10,12 @@
   #:use-module (web view markdown)
   #:use-module (web view brand msk)
   #:use-module (web view brand aging)
+  #:use-module (web templates genenetwork)
 
   #:export (view-brand))
 
 
-(define (view-aging)
+(define (view-aging-home)
   (aging-html #:info
               `(
 		,(markdown-github->sxml "genenetwork/gn-docs/general/brand/aging/home.md")
@@ -44,7 +45,14 @@ data to benefit from the power of integrated datasets, please contact:")
 
 (define* (view-brand path)
   (match path
-    ("aging" (view-aging))
+    ("aging/UMHET-3" (aging-html #:info
+              `(,(markdown-github->sxml "genenetwork/gn-docs/general/brand/aging/home.md"))))
+    ("aging/umhet-3" (aging-html #:info
+              `(,(markdown-github->sxml "genenetwork/gn-docs/general/brand/aging/home.md"))))
+    ("aging" (view-aging-home))
+    ("gnqa" (default-gn-template
+                   "genenetwork/gn-docs/general/brand/gnqa/gnqa.md"
+                   "GeneNetwork Question and Answer System"))
     ( _ (msk-html #:info
             `(
 	      ,(markdown-github->sxml "genenetwork/gn-docs/general/brand/msk/home.md")
generated by cgit-pink 1.4.1 (git 2.36.1) at 2025-11-07 21:34:26 +0000