Tildeverse Report

#!/usr/bin/env gsi-script

;; STYLE INFORMATION
(define css-files (list "../css/base.css" "../css/report.css"))
(define logo-link "https://tilde.green")
(define logo-icon "../images/tildeverse.png")
(define logo-name "~GREEN")

;; TILDE INFORMATION
(define hosts (list
          (cons "~CLUB" "tilde.club")
          (cons "~FUN" "tilde.fun")
          (cons "~GREEN" "tilde.green")
          (cons "~GURU" "tilde.guru")
          (cons "~INSTITUTE" "tilde.institute")
          (cons "~PINK" "tilde.pink")
          (cons "~PT" "tilde.pt")
          (cons "~TEAM" "tilde.team")
          (cons "~TOWN" "tilde.town")
          (cons "AUSSIES SPACE" "aussies.space")
          (cons "COSMIC VOYAGE" "cosmic.voyage")
          (cons "CRTL-C CLUB" "ctrl-c.club")
          (cons "DIMENSIONS" "dimension.sh")
          (cons "ENVS NET" "envs.net")
          (cons "HACKERS.COOL" "hackers.cool")
          (cons "REMOTES CLUB" "remotes.club")
          (cons "RW.RS" "rw.rs")
          (cons "SKYLAB" "skylab.org")
          (cons "SQUIGGLE CITY" "squiggle.city")
          ;;(cons "TEXTO PLANO" "texto-plano.xyz")
          (cons "THUNIX" "thunix.net")
          (cons "XINU" "xinu.me")
          ))
(define domains (map (lambda (h) (cons (cdr h) (car h))) hosts))
(define ports (list (cons "ssh" "22") (cons "gopher" "70") (cons "http" "80") (cons "https" "443") (cons "gemini" "1965")))

(define (open? port host)
  (= 0 (shell-command (string-append "nc -zv" " " host " " port " " "-w 1"))))
(define hosts-and-ports 
  (map
   (lambda (h) (cons h (map (lambda (p) (cons (car p) (open? (cdr p) (cdr h)))) ports)))
   hosts))

(define green-homepage-updates "~/public_html/data/green-homepage-updates.ss")
(define green-homepage-updates-url "https://tilde.green/~fabius/data/green-homepage-updates.ss")
(define club-homepage-updates "~/public_html/data/club-homepage-updates.ss")
(define club-homepage-updates-url "https://tilde.green/~fabius/data/club-homepage-updates.ss")
(define club-homepage-updates-json "https://tilde.club/tilde.24h.json")
(define team-homepage-updates "~/public_html/data/team-homepage-updates.ss")
(define team-homepage-updates-url "https://tilde.green/~fabius/data/team-homepage-updates.ss")
(define team-homepage-updates-json "https://tilde.team/tilde.24h.json")
(define town-homepage-updates "~/public_html/data/town-homepage-updates.ss")
(define town-homepage-updates-url "https://tilde.green/~fabius/data/town-homepage-updates.ss")
(define town-homepage-updates-json "https://tilde.town/~ags/updated.json")
(define tildeverse-homepage-ignore "~/public_html/data/tildeverse-homepage-updates-ignore.ss")
(define homepage-updates '())
(for-each
 (lambda (u) (with-input-from-file u (lambda () (set! homepage-updates (append homepage-updates (read))))))
 (list green-homepage-updates club-homepage-updates team-homepage-updates town-homepage-updates))
(define homepage-ignore (with-input-from-file tildeverse-homepage-ignore (lambda () (read))))
      
;; STANDARD PROCEDURES
(define (take a-list n)
  (let loop ((head '())
             (tail a-list)
             (k n))
    (if (or (null? tail) (= k 0))
        (reverse head)
        (loop (cons (car tail) head) (cdr tail) (- k 1)))))

(define (last a-list)
  (cond
   ((null? a-list) #f)
   ((null? (cdr a-list)) (car a-list))
   (else (last (cdr a-list)))))

(define (filter a-list a-predicate)
  (let loop ((valid-elements '())
             (elements a-list))
    (if (null? elements)
        (reverse valid-elements)
        (if (a-predicate (car elements))
            (loop (cons (car elements) valid-elements)
                  (cdr elements))
            (loop valid-elements (cdr elements))))))

(define (sort a-list an-order)
  (if (null? a-list)
      a-list
      (let ((first (car a-list))
            (rest (cdr a-list)))
        (append
         (sort (filter rest (lambda (x) (an-order x first))) an-order)
         (list first)
         (sort (filter rest (lambda (x) (not (an-order x first)))) an-order)))))

(define (string-index where what)
  (letrec ((helper (lambda (index)
		     (if (> (+ index (string-length what)) (string-length where))
		         #f
		         (if (string=? (substring where index (+ index (string-length what))) what)
			     index
			     (helper (+ index 1)))))))
    (helper 0)))

(define (string-replace where what with)
  (let ((ind (string-index where what)))
    (if ind
        (string-append
	 (substring where 0 ind)
	 with
	 (string-replace (substring where (+ ind (string-length what)) (string-length where)) what with))
        where)))

(define (string-html a-string)
  (let replace ((s a-string)
                (l (list (cons "&" "&amp;") (cons "\"" "&quot;")  (cons "<" "&lt;") (cons ">" "&gt"))))
    (if (null? l)
        s
        (replace (string-replace s (caar l) (cdar l)) (cdr l)))))

(define (html-link-css path-to-file)
  (display (string-append "<link rel=\"preload\" href=\"" path-to-file "\" as=\"style\">\n"
                          "<link rel=\"stylesheet\" href=\"" path-to-file "\" type=\"text/css\">\n")))

(define (string-split what with)
  (let process ((splits '())
		(str what))
    (let ((ind (string-index str with)))
      (if ind
	  (process (cons (substring str 0 ind) splits) (substring str (+ ind (string-length with)) (string-length str)))
	  (reverse (cons str splits))))))

;; SCRIPT SPECIFIC PROCEDURES
(define (format-date date)
  (cdr (shell-command (string-append "echo -n " date " | cut -c1-19 | sed 's/./ @ /11' | tr -d '\n'") #t)))

(set! homepage-updates
      (take
       (sort
        (filter homepage-updates (lambda (x) (and (not (member (cdr (assoc 'HOMEPAGE x)) homepage-ignore)) (not (member (cdr (assoc 'FILE x)) homepage-ignore)))))
        (lambda (u v) (string>? (format-date (cdr (assoc 'TIMESTAMP u))) (format-date (cdr (assoc 'TIMESTAMP v))))))
       30))

(define (link host-and-ports)
  (let ((host (car host-and-ports))
        (ports (reverse (cdr host-and-ports))))
    (cond
     ((cdr (assoc "https" ports)) (string-append "<a href=\"https://" (cdr host) "\" title=\"" (cdr host) "\">" (car host) "</a>"))
     ((cdr (assoc "http" ports)) (string-append "<a href=\"http://" (cdr host) "\" title=\"" (cdr host) "\">" (car host) "</a>"))
     ((cdr (assoc "gopher" ports)) (string-append "<a href=\"https://gopher.tildeverse.org/" (cdr host) "/1/\" title=\"" (cdr host) "\">" (car host) "</a>"))
     ((cdr (assoc "gemini" ports)) (string-append "<a href=\"https://gemini.tildeverse.org/?gemini://" (cdr host) "/\" title=\"" (cdr host) "\">" (car host) "</a>"))
     ((cdr (assoc "ssh" ports)) (car host))
     (else (string-append "<a href=\"#\" title=\"" (cdr host) "\"><del>" (car host) "</del></a>")))))

;;HTML
(display "<!DOCTYPE html>\n")
(display "<html lang=\"en\">\n")
(display "<head>\n")
(display "<meta charset=\"UTF-8\">\n")
(display (string-append "<title>TILDEVERSE REPORT</title>\n"))
(for-each (lambda (css) (html-link-css css)) css-files)
(display "<style>\n")
(display ".yes{color:#78b159;font-weight:600;text-transform:uppercase;}\n")
(display ".no{color:#dd2e44;font-weight:600;text-transform:uppercase;}\n")
(display "</style>\n")
(display "</head>\n")
(display "<body>\n")
(display (string-append "<h1><a href=\"https://tildeverse.org\">Tildeverse</a> Report</h1>\n"))
;; LATEST HOMEPAGE CHANGES
(display "<h2>Latest Homepage Updates</h2>\n")
(display "<table>\n")
(display "<tr><th>When</th><th>Who</th><th>Where</th><th>What</th></tr>\n")
(for-each
 (lambda (x)
   (let ((t (format-date (cdr (assoc 'TIMESTAMP x))))
         (u (cdr (assoc 'USER x)))
         (h (cdr (assoc 'HOMEPAGE x)))
         (f (cdr (assoc 'FILE x))))
     (display
      (string-append
       "<tr>"
       "<td>" t "</td>"
       "<td>" "<a href=\"" h "\" alt=\"" h "\">" u "</a>" "</td>"
       "<td>"
       (link (assoc (cons (cdr (assoc (caddr (string-split h "/")) domains)) (caddr (string-split h "/"))) hosts-and-ports))
       "</td>"
       "<td>" (if (equal? f "") f (string-append "<a href=\"" f "\">" (last (string-split f "/")) "</a>")) "</td>"
       "</tr>\n"))))
 homepage-updates)
(display "</table>\n")
(display "<p>Certain <a href=\"https://tilde.green/~fabius/data/tildeverse-homepage-updates-ignore.ss\">pages and files</a> have been excluded so as not to crowd the list with what is automatically updated and generated.</p>\n")
;; DATA
(display "<h3>Raw Data</h3>\n")
(display "<table>\n")
(display "<tr><th>Tilde</th><th>S-Expression</th><th>JSON</th></tr>\n")
(display
 (string-append
  "<tr>"
  "<td><a href=\"https://tilde.club\" alt=\"https://tilde.club\" title=\"https://tilde.club\">~CLUB</a></td>"
  "<td><a href=\"" club-homepage-updates-url "\" title=\"" club-homepage-updates-url "\">" (last (string-split club-homepage-updates "/")) "</a></td>"
  "<td><a href=\"" club-homepage-updates-json "\" title=\"" club-homepage-updates-json "\">" (last (string-split club-homepage-updates-json "/"))" </a></td>"
  "</tr>\n"))
(display
 (string-append
  "<tr>"
  "<td><a href=\"https://tilde.green\" title=\"https://tilde.green\">~GREEN</a></td>"
  "<td><a href=\"" green-homepage-updates-url "\" title=\"" green-homepage-updates-url "\">" (last (string-split green-homepage-updates "/")) "</a></td>"
  "<td>N/A</td>"
  "</tr>\n"))
(display
 (string-append
  "<tr>"
  "<td><a href=\"https://tilde.team\" alt=\"https://tilde.team\" alt=\"https://tilde.team\">~TEAM</a></td>"
  "<td><a href=\"" team-homepage-updates-url "\" title=\"" team-homepage-updates-url "\">" (last (string-split team-homepage-updates "/")) "</a></td>"
  "<td><a href=\"" team-homepage-updates-json "\" title=\"" team-homepage-updates-json "\">" (last (string-split team-homepage-updates-json "/")) "</a></td>"
  "</tr>\n"))
(display
 (string-append
  "<tr>"
  "<td><a href=\"https://tilde.team\" alt=\"https://tilde.town\" alt=\"https://tilde.town\">~TOWN</a></td>"
  "<td><a href=\"" town-homepage-updates-url "\" title=\"" town-homepage-updates-url "\">" (last (string-split town-homepage-updates "/")) "</a></td>"
  "<td><a href=\"" town-homepage-updates-json "\" title=\"" town-homepage-updates-json "\">" (last (string-split town-homepage-updates-json "/")) "</a></td>"
  "</tr>\n"))
(display "</table>\n")
(display "<h2>Port Availability Status</h2>")
(display "<table>\n")
(display "<tr><th>Host</th>")
(for-each
 (lambda (p) (display (string-append "<th>" (car p) "(" (cdr p) ")" "</th>")))
 ports)
(display "</tr>\n")
(for-each
 (lambda (hp)
   (let ((l (link hp))
         (ps (map (lambda (p) (cdr p)) (cdr hp))))
     (display "<tr>")
     (display (string-append "<td>" l "</td>"))
     (for-each
      (lambda (s) (display (string-append "<td>" (if s "<span class=\"yes\">yes</span>" "<span class=\"no\">no</span>") "</td>"))) ;(if s "&#x1F7E2;" "&#x1F534;")
      ps)
     (display "</tr>\n")))
 hosts-and-ports)
(display "</table>\n")
;; TIMESTAMP
(display (string-append "<h2>Updated : " (cdr (shell-command "date +\"%Y-%m-%d @ %H:%M\"" #t)) "</h2>\n"))
;; SCRIPT SOURCE CODE
(display "<details>\n")
(display "<summary>Script</summary>")
(display "<pre>\n")
(let ((script (cdr (shell-command (string-append "cat" " " (car (command-line))) #t))))
  (display (string-html script)))
(display "</pre>\n")
(display "</details>\n")
(display "<footer>\n")
(display (string-append "<a href=\"" logo-link "\"><img src=\"" logo-icon "\" alt=\"" logo-name "\" title=\"" logo-name "\"></a>\n"))
(display "</footer>\n")
(display "</body>\n")
(display "</html>\n")