DATARAMA

Adapt to current Datarama needs

May 02, 2016
Project: goon

Because Datarama now has project pages that are integrated with the wiki, Goon now spits out a "manifest file" that Plutonium can use to render project information from. Since this has made a lot of goon's old features unnecessary, I have removed a large tangled mass of such features. The joy of custom software.

1 files changed, 48 insertions / 347 deletions

diff --git a/goon.scm b/goon.scm
index 50cb157..9ba2f48 100755
--- a/goon.scm
+++ b/goon.scm
@@ -21,7 +21,8 @@
 
 ; == CONFIGURATION ============================================================
 (define page-template '())
-(define date-format-long "~b ~d, ~Y")
+(define date-format-long "~B ~d, ~Y")
+(define date-format-short "~b ~d ~Y")
 (define date-format "~Y-~m-~d")
 (define max-commits 8)
 (define max-releases 4)
@@ -88,93 +89,26 @@
 (define (display-time-long timestamp)
   (date->string (seconds->date timestamp) date-format-long))
 
-(define (dropcapize sxml)
-  (if (string? (car sxml))
-    (cons `(span (@ (class "firstword"))
-                 (span (@ (class "dropcap")) ,(string-take (car sxml) 1))
-                 ,(string-drop (car sxml) 1))
-          (cdr sxml))
-    (cons (cons (caar sxml) (dropcapize (cdar sxml)))
-          (cdr sxml))))
-
-(define (mkdropcap sxml)
-  (if (and (pair? sxml) (pair? (car sxml)) (eq? (caar sxml) 'p))
-    (cons (cons 'p (dropcapize (cdar sxml)))
-          (cdr sxml))
-    sxml))
-
-(define (render-sidebar-mod mod)
-  `(div (@ (class "sidebar-module"))
-        ,(car mod)
-        ,(cadr mod)))
-
-(define (render-sidebar mods)
-  `(div (@ (class "sidebar-module-outer"))
-        ,(map render-sidebar-mod mods)))
-
-; == CATEGORIZED LIST =========================================================
-(define (category-name dirpath)
-  (if (file-exists? (filepath:combine dirpath ".category"))
-    (string-trim-both (read-all (filepath:combine dirpath ".category")))
-    dirpath))
-
-(define (repository-desc repo)
-  (read-all (filepath:combine (repository-path repo) "description")))
-
-(define (read-category dir)
-  (map (lambda (x) (repository-open (filepath:combine dir x)))
-       (filter (lambda (x) 
-                 (and (file-exists? (filepath:combine 
-                                      dir (filepath:combine x ".git")))))
-               (directory dir))))
-
-(define (read-categories)
-  (map (lambda (x) (cons (category-name x) (read-category x)))
-       (filter directory? (directory))))
-
-(define (total-commits categories)
-  (fold + 0 (map length (map commits (flatten (map cdr categories))))))
-
-(define (total-projects categories)
-  (length (flatten (map cdr categories))))
+(define (display-time-short timestamp)
+  (date->string (seconds->date timestamp) date-format-short))
+
+; == REPOSITORY LIST ==========================================================
+(define (read-dir path)
+  (if (and (file-exists? (filepath:combine path ".git")))
+    (begin 
+      (repository-open path))
+    (begin 
+      (map
+        (lambda (x) (read-dir (filepath:combine path x)))
+        (filter (lambda (y) (directory? (filepath:combine path y)))
+                (directory path))))))
+
+(define (read-repositories)
+  (flatten (read-dir ".")))
 
 (define (repository-name repo)
   (cadr (reverse (filepath:split-directories (repository-path repo)))))
 
-(define (projects-sidebar categories)
-  `(div (@ (class "sidebar-module-outer"))
-        (div (@ (class "sidebar-module"))
-             (h2 "Projects")
-             ,(total-projects categories)
-             (h2 "Commits")
-             ,(total-commits categories))))
-
-(define (render-repo-entry repo)
-  `(tr (@ (class "goon_project"))
-     (td (@ (class "repo_name")) 
-         (a (@ (href ,(string-append (repository-name repo)
-                                     "/" (repository-outfile repo "master"))))
-            ,(repository-name repo)))
-     (td (@ (class "repo_desc")) ,(repository-desc repo))
-     (td (@ (class "repo_latest")) ,(display-time-long (latest-commit-time repo)))))
-
-(define (render-category cat)
-  `(div (h1 ,(car cat))
-        (table (@ (class "goon_projects"))
-               ,(map render-repo-entry (cdr cat)))))
-
-(define (render-projects-blurb)
-  (mkdropcap (markdown->sxml (read-all "blurb.markdown"))))
-
-(define (render-repository-list categories)
-  (output-frontpage
-    (prep-output `((header-title . "Projects")
-                   (sidebar      . ,(projects-sidebar categories))
-                   (title        . "")
-                   (content      .  (div 
-                                     ,(render-projects-blurb)
-                                     ,(map render-category categories)))))))
-
 ; == COMMITS ==================================================================
 (define (latest-commit repo branch)
   (car (reverse (commits repo sort: 'time initial: (reference-target branch)))))
@@ -186,20 +120,20 @@
   (string-append (oid->string (commit-id comm)) ".html"))
 
 (define (render-commits repo commits)
-  `(table (@ (class "goon_commits")) 
+  `(ul (@ (class "goon_commits")) 
           ,(map (lambda (x) (render-commit (tags repo) x)) commits)))
 
 (define (render-commit repotags comm)
-  `(tr (td (@ (class "goon_commit_msg")) 
-           (a (@ (href ,(commit-path comm))) ,(commitmsg-first-line comm)))
-       (td (@ (class "goon_commit_tag"))
+  `(li (span (@ (class "goon_commit_tag"))
            ,(let ((tagged 
                    (find (lambda (x) (oid=? (commit-id (tag-peel x))
                                             (commit-id comm)))
                          repotags)))
              (if tagged (string-append "[ " (tag-name tagged) " ]") "")))
-       (td (@ (class "goon_commit_time")) 
-           ,(display-time-long (commit-time comm)))))
+       (span (@ (class "goon_commit_time")) 
+           ,(display-time-short (commit-time comm)))
+       (span (@ (class "goon_commit_msg")) 
+           (a (@ (href ,(commit-path comm))) ,(commitmsg-first-line comm)))))
 
 ; == FILE TREE DISPLAY ========================================================
 (define (sort-filetree tree)
@@ -236,24 +170,6 @@
 (define (tree-entry-path entry)
   (string-append (oid->string (tree-entry-id entry)) ".html"))
 
-(define (filetree-lists tree)
-  `(ul ,(map
-          (lambda (x) 
-            (if (list? x)
-              `(li ,(car x) ,(filetree-lists (cdr x)))
-              `(li (a (@ (href ,(tree-entry-path x))) ,(tree-entry-name x))
-                   (span (@ (class "filesize")) ,(filesize x)))))
-          tree)))
-
-(define (render-filetree repo branch)
-  (let ((head (latest-commit repo branch)))
-    (for-each 
-      (lambda (x) (render-tree-entry repo (cdr x)))
-      (tree-entries (commit-tree head)))
-    `(div (@ (class "goon_filetree"))
-          ,(filetree-lists 
-             (sort-filetree (filetree (tree-entries (commit-tree head))))))))
-
 (define (manifest-file entry)
   (if (list? entry)
     (cons (car entry) (map manifest-file (cdr entry)))
@@ -266,7 +182,6 @@
   (map manifest-file
     (sort-filetree tree)))
 
-
 ; == TARBALLS ================================================================
 (define (prep-tarball prefix repo commit tree)
   (tree-fold
@@ -300,10 +215,7 @@
          (tarball (prep-tarball prefix repo 
                                 (tag-peel tag) (commit-tree (tag-peel tag)))))
     (let* ((filehandle (file-open 
-                          (filepath:combine output-dir 
-                                           (filepath:combine 
-                                             (repository-name repo)
-                                             gzfilename))
+                          (filepath:combine output-dir gzfilename)
                           (+ open/wronly open/creat)))
            (zfile-out (z3:encode-file filehandle)))
         (z3:write-encoded zfile-out 
@@ -317,11 +229,9 @@
   (for-each
     (lambda (tag) 
       (if (not (file-exists? (filepath:combine output-dir
-                                               (filepath:combine
-                                                 (repository-name repo)
                                                  (string-append
                                                    (repository-name repo) "-"
-                                                   (tag-name tag) ".tar.gz")))))
+                                                   (tag-name tag) ".tar.gz"))))
         (release-tarball repo tag)))
     (tags repo)))
 
@@ -329,149 +239,13 @@
   (string-append (repository-name repo) "-" (tag-name tag) ".tar.gz"))
 
 ; == REPOSITORIES =============================================================
-(define (readme-file repo branch)
-  (let ((found 
-          (find (lambda (x) 
-                  (and (string=? (car x) "")
-                       (string=? (tree-entry-name (cdr x)) "README.md")))
-                 (tree-entries (commit-tree (latest-commit repo branch))))))
-    (if found 
-      (blob->string (blob-content (tree-entry->object repo (cdr found))))
-      #f)))
-
 (define (repo-commits repo branch)
   (reverse (commits repo sort: 'time initial: (reference-target branch))))
 
-(define (render-branches-sidebar repo)
-  `(ul ,(map 
-          (lambda (branch) 
-            `(li (a (@ (href ,(repository-outfile repo (branch-name branch))))
-                    ,(branch-name branch))))
-          (branches repo 'local))))
-
-(define (repo-sidebar repo branch)
-  `(div (@ (class "sidebar-module-outer"))
-        (div (@ (class "sidebar-module"))
-             (h2 "Clone URL")
-             (div (@ (class "clone-url"))
-               ,(string-append url-prefix (repository-name repo)))
-             ,(if (not (null? (tags repo)))
-                `(div (h2 "Releases")
-                      ,(render-tags repo (tags repo)))
-                #f)
-             ,(if (> (length (branches repo 'local)) 1)
-                `(div (h2 "Branches")
-                      ,(render-branches-sidebar repo))
-                #f)
-             #f)
-             (h2 "Files")
-             ,(render-filetree repo branch)))
-
-(define (release-file tag)
-  (let* ((files (tree-entries (commit-tree (tag-peel tag))))
-         (found (find (lambda (x)
-                        (and (string=? (car x) "")
-                             (string=? (tree-entry-name (cdr x)) "RELEASE.md")))
-                      files)))
-    (if found (cdr found) #f)))
-
-(define (relfile-sidebar repo tag)
-  `(div (@ (class "sidebar-module-outer"))
-        (div (@ (class "sidebar-module"))
-             (h2 "date")
-             ,(display-time-long (commit-time (tag-peel tag)))
-             (h2 "download")
-             (a (@ (href ,(string-append (repository-name repo) "-" (tag-name tag) ".tar.gz")))
-                ,(string-append (repository-name repo) "-" (tag-name tag) ".tar.gz")))))
-
-(define (relfile-content repo tag)
-  (let* ((rfile (release-file tag))
-         (msg (blob->string (blob-content (tree-entry->object repo rfile)))))
-  (mkdropcap (markdown->sxml msg))))
-
-(define (render-releasefile repo tag)
-  (let ((filename (string-append (repository-name repo) "-" (tag-name tag) ".html")))
-    (if (not (already-rendered? repo filename))
-      (output-page repo
-      (prep-output `((header-title . ,(string-append (repository-name repo) " " (tag-name tag)))
-                     (sidebar      . ,(relfile-sidebar repo tag))
-                   (title        . (h1 (@ (id "pagetitle")) ,(string-append (repository-name repo) " " (tag-name tag))))
-                     (content      . ,(relfile-content repo tag))))
-      filename))))
-
 (define (prepare-repo-dir repo)
   (if (not (file-exists? (filepath:combine output-dir (repository-name repo))))
     (create-directory (filepath:combine output-dir (repository-name repo)))))
 
-(define (render-tag repo tag)
-  (let ((rfile (release-file tag))
-        (rfilename (string-append (repository-name repo) "-" (tag-name tag) ".html")))
-    (if rfile (render-releasefile repo tag))
-    `(tr (td (@ (class "name"))
-           ,(if rfile 
-              `(a (@ (href ,rfilename)) ,(tag-name tag))
-              (tag-name tag)))
-         (td (@ (class "download"))
-           " [" (a (@ (href ,(tarball-path repo tag))) "tar.gz") "]")
-         (td (@ (class "rel_date"))
-           ,(display-time (commit-time (tag-peel tag)))))))
-
-(define (releases-sidebar repo)
-  `(div (@ (class "sidebar-module-outer"))
-        (div (@ (class "sidebar-module"))
-             (h2 "Total Releases")
-             ,(length (tags repo)))))
-
-(define (render-releasesmain repo)
-  (render-taglist repo (tags repo)))
-
-(define (render-tag-long repo tag)
-  (let ((rfile (release-file tag))
-        (rfilename (string-append (repository-name repo) "-" (tag-name tag) ".html")))
-    (if rfile (render-releasefile repo tag))
-    `(tr (td 
-           (a (@ (href ,(commit-path (tag-peel tag))))
-           ,(tag-name tag)))
-         (td
-           ,(if rfile 
-              `(a (@ (href ,rfilename)) "Release Notes")
-              #f))
-         (td
-           (a (@ (href ,(tarball-path repo tag))) "tar.gz"))
-         (td 
-           ,(display-time (commit-time (tag-peel tag)))))))
-
-(define (render-taglist repo tags)
-  `(table
-    ,(map (lambda (x) (render-tag-long repo x)) tags)))
-
- 
-(define (render-releasepage repo comm)
-  (output-page repo
-    (prep-output `((header-title  . ,(repository-name repo))
-                   (sidebar       . ,(releases-sidebar repo))
-                   (title        . (h1 (@ (id "pagetitle")) ,(string-append "Project: " (repository-name repo))))
-                   (content       . ,(render-releasesmain repo))))
-    "releases.html"))
-
-(define (render-tags repo tags)
-  `(div 
-     (table (@ (class "goon_releases"))
-       ,(map (lambda (x) (render-tag repo x)) (clamp-list tags max-releases)))
-     ,(if (> (length tags) max-releases)
-        `(a (@ (href "releases.html"))
-               "Older releases")
-        #f)))
-
-(define (repo-content repo branch)
-  (let ((readme (readme-file repo branch)))
-  `(div
-     ,(if readme (mkdropcap (markdown->sxml readme)) #f)
-     (h1 "Latest Commits")
-     ,(render-commits repo (clamp-list (repo-commits repo branch) max-commits))
-     (a (@ (class "commithist-link") (href ,(string-append (branch-name branch) "-commits.html")))
-        "History →"))))
-
 (define (commit-mentry comm)
   (list (commit-path comm)
         (commit-time comm)
@@ -497,17 +271,10 @@
 (define (render-branch repo branch)
   (branch-manifest repo branch)
   (render-commitlist repo branch)
-  (render-releasepage repo tags)
   (mktarballs repo)
   (for-each
     (lambda (x) (render-commitpage repo x))
-    (repo-commits repo branch))
-  (output-page repo
-    (prep-output `((header-title . ,(repository-name repo))
-                   (sidebar      . ,(repo-sidebar repo branch))
-                   (title        . (h1 (@ (id "pagetitle")) ,(string-append "Project: " (repository-name repo))))
-                   (content      . ,(repo-content repo branch))))
-    (repository-outfile repo (branch-name branch))))
+    (repo-commits repo branch)))
 
 (define (get-master repo)
   (let ((all-branches (branches repo 'local)))
@@ -541,43 +308,28 @@
          (stats (diff-stats diffs))
          (insertions (cadr stats))
          (deletions (caddr stats)))
-    `(div
-       (h2 "Modifications")
-       (ul
-         (li (span (@ (class "sbtext")) 
-                   ,(string-append (number->string (length deltas)) " files changed")))
-         (li (span (@ (class "sbtext"))
+    `(div (@ (class "change_summary"))
+         (span (@ (class "sbtext")) 
+                   ,(string-append (number->string (length deltas)) " files changed"))
+         ", "
+         (span (@ (class "sbtext"))
              ,(string-append (number->string insertions) " insertions / "
-                             (number->string deletions) " deletions")))))))
-
-(define (commits-sidebar repo comm)
-  `(div (@ (class "sidebar-module-outer"))
-        (div (@ (class "sidebar-module"))
-             (h2 "date")
-             ,(display-time-long (commit-time comm))
-             (h2 "project")
-             (a (@ (href ,(repository-outfile repo "master")))
-                ,(repository-name repo))
-             ,(if (commit-parent comm)
-                `(div (h2 "parent")
-                      (a (@ (href ,(commit-path (commit-parent comm))))
-                   ,(string-append (substring 
-                      (oid->string (commit-id (commit-parent comm)))
-                      0 8)))
-                      ,(render-changes repo (commit-parent comm) comm))
-                #f))))
+                             (number->string deletions) " deletions")))))
 
 (define (commitmsg-first-line comm)
   (car (string-split (commit-message comm) "\n")))
 
 (define (render-commitmain repo body comm)
   `(div 
-     ,(if body `(div ,body (hr)) #f)
+     ,(if body `(div ,body) #f)
      ,(if (commit-parent comm)
-        (let ((diffs (diff repo 
+        `(div
+          ,(render-changes repo (commit-parent comm) comm)
+          (hr)
+          ,(let ((diffs (diff repo 
                            (commit-tree (commit-parent comm)) 
                            (commit-tree comm))))
-          `(pre (code (@ (class "diff")) ,(diff->string diffs))))
+             `(pre (code (@ (class "diff")) ,(diff->string diffs)))))
         #f)))
 
 (define (render-commitpage repo comm)
@@ -590,74 +342,24 @@
     (output-page repo
       (prep-output `((header-title  . ,(string-append (repository-name repo) 
                                                       ": " subject))
-                     (sidebar       . ,(commits-sidebar repo comm))
+                     (project . (div (@ (class "project")) "Project: " ,(repository-name repo)))
+                     (date . (div (@ (class "date")) ,(display-time-long (commit-time comm))))
                      (title         . (h1 (@ (id "pagetitle")) ,subject))
                      (content       . ,(render-commitmain repo body comm))))
       (commit-path comm)))))
 
-(define (commitlist-sidebar repo)
-  `(div (@ (class "sidebar-module-outer"))
-        (div (@ (class "sidebar-module"))
-             (h2 "Total commits")
-             ,(length (commits repo)))))
-
 (define (commitlist-main repo branch)
-  `(div 
-     (h1 "Commit History")
-     ,(render-commits repo (repo-commits repo branch))))
+  `(div ,(render-commits repo (repo-commits repo branch))))
 
 (define (render-commitlist repo branch)
   (output-page repo
     (prep-output `((header-title . ,(repository-name repo))
-                   (sidebar . ,(commitlist-sidebar repo))
-                   (title        . (h1 (@ (id "pagetitle")) ,(string-append "Project: " (repository-name repo))))
+                   (date . '())
+                   (project . (div "Project: " ,(repository-name repo)))
+                   (title        . (h1 (@ (id "pagetitle")) "Commit History"))
                    (content . ,(commitlist-main repo branch))))
     (string-append (branch-name branch) "-commits.html")))
 
-(define (count-lines str)
-  (length (string-split str "\n")))
-
-; == TREE ENTRIES =============================================================
-(define (tree-entry-sidebar repo entry)
-  (let* ((blob (tree-entry->object repo entry))
-         (bytes (blob-length blob))
-         (lines (if (blob-binary? blob) #f 
-                  (count-lines (blob->string (blob-content blob))))))
-    `(div (@ (class "sidebar-module-outer"))
-          (div (@ (class "sidebar-module"))
-               (h2 "project")
-               (a (@ (href ,(repository-outfile repo "master")))
-                ,(repository-name repo))
-               (h2 "Bytes")
-               ,bytes
-               ,(if lines
-                  `(div 
-                     (h2 "Lines")
-                     ,lines)
-                  #f)))))
-
-(define (tree-entry-content repo entry)
-  (let ((blob (tree-entry->object repo entry))
-        (lang (file-language (tree-entry-name entry))))
-    `(div 
-       (pre (code (@ (class ,lang))
-               ,(if (blob-binary? blob)
-                  "<binary file>"
-                  (blob->string (blob-content blob))))))))
-
-(define (render-tree-entry repo entry)
-  (if (and (eq? (tree-entry-type entry) 'blob)
-           (not (already-rendered? repo (tree-entry-path entry))))
-    (let* ((blob (tree-entry->object repo entry))
-           (content (blob-content blob))
-           (filename (tree-entry-name entry)))
-      (output-page repo
-        (prep-output `((header-title . ,(string-append (repository-name repo) ":" (tree-entry-name entry)))
-                       (title        . (h1 (@ (id "pagetitle")) ,(tree-entry-name entry)))
-                       (sidebar      . ,(tree-entry-sidebar repo entry))
-                       (content      . ,(tree-entry-content repo entry))))
-        (tree-entry-path entry)))))
-
 ; == FRONT END ================================================================
 (define (repository-dir? path)
   (condition-case (repository-open path)
@@ -665,7 +367,6 @@
     (var () #t)))
 
 (define (run args)
-; TODO: Output commitlist & releases for each project
   (begin
     (set! repositories-dir (car args))
     (set! output-dir (cadr args))
@@ -674,8 +375,8 @@
     (change-directory repositories-dir)
     (set! page-template 
       (make-sxml-template 
-        (read (open-input-file "goon-template.scm"))))
-    (render-repository-list (read-categories))
-    (map render-repo (flatten (map cdr (read-categories))))))
+        (read (open-input-file ".goon-template.scm"))))
+    (map render-repo 
+         (read-repositories))))
 
 (run (command-line-arguments))
 
Powered by Plutonium