(defmodule nemoptera_site
(export all))
(defun all ()
(maps:from_list
(list (tuple 'site_name (setting "site_name" "Nemoptera"))
(tuple 'site_url (setting "site_url" (default-url)))
(tuple 'site_tagline (setting "site_tagline" "Repositories hosted with Fossil."))
(tuple 'site_description (setting "site_description" ""))
(tuple 'loose_title (setting "loose_title" "Repositories"))
(tuple 'custom_shortcuts (setting "custom_shortcuts" "")))))
(defun setting (key default)
(if (nemoptera_setup:installed?)
(case (catch (nemoptera_db:q "SELECT value FROM site_settings WHERE key=?;" (list key)))
(`((,value)) (let ((text (nemoptera_text:to-str value)))
(if (=:= "" text) default text)))
(_ default))
default))
(defun put-settings (pairs)
(lists:foreach
(lambda (pair)
(let (((tuple key value) pair))
(nemoptera_db:q "INSERT OR REPLACE INTO site_settings(key,value) VALUES(?,?);"
(list key (nemoptera_text:to-str value)))))
pairs))
(defun root ()
(nemoptera_setup:trim-slash (maps:get 'site_url (all) (default-url))))
(defun default-url ()
(lists:flatten (io_lib:format "http://127.0.0.1:~p" (list (nemoptera_config:listen-port)))))
(defun repo-path (org-name slug)
(if (or (=:= org-name 'none) (=:= org-name "") (=:= org-name 'undefined))
(lists:flatten (list "/" (nemoptera_text:to-str slug)))
(lists:flatten (list "/" (nemoptera_text:to-str org-name) "/" (nemoptera_text:to-str slug)))))
(defun repo-base-url (org-name slug)
(lists:flatten (list (root) (repo-path org-name slug))))
(defun https? ()
(lists:prefix "https://" (string:lowercase (root))))
(defun public-groups ()
(let ((loose (loose-repos))
(orgs (org-groups)))
(lists:append
(if (=:= '() loose) '() (list (group (setting "loose_title" "Repositories")
"repositories"
(setting "site_description" "")
loose)))
orgs)))
(defun group (title anchor description repos)
(maps:from_list
(list (tuple 'title title)
(tuple 'anchor anchor)
(tuple 'description description)
(tuple 'repos repos))))
(defun loose-repos ()
(rows-to-repos
(nemoptera_db:q
"SELECT name, description, last_timeline_at FROM repositories WHERE organization_id IS NULL ORDER BY name COLLATE NOCASE;"
'())))
(defun org-groups ()
(case (nemoptera_db:q "SELECT id, name, description FROM organizations ORDER BY name COLLATE NOCASE;" '())
(rows (when (is_list rows))
(lists:map
(lambda (row)
(let (((tuple id name description) (nemoptera_db:as-tuple row)))
(group (nemoptera_text:to-str name)
(lists:flatten (list "org-" (nemoptera_text:to-str name)))
(nemoptera_text:to-str description)
(org-repos id name))))
rows))
(_ '())))
(defun org-repos (org-id org-name)
(rows-to-repos
(nemoptera_db:q
"SELECT name, description, last_timeline_at FROM repositories WHERE organization_id=? ORDER BY name COLLATE NOCASE;"
(list org-id))
org-name))
(defun rows-to-repos (rows)
(rows-to-repos rows 'none))
(defun rows-to-repos (rows org-name)
(case rows
(items (when (is_list items))
(lists:map
(lambda (row)
(let* (((tuple name description timeline) (nemoptera_db:as-tuple row))
(slug (nemoptera_text:to-str name)))
(maps:from_list
(list (tuple 'name slug)
(tuple 'description (nemoptera_text:to-str description))
(tuple 'timeline (nemoptera_text:to-str timeline))
(tuple 'url (repo-path org-name slug))))))
items))
(_ '())))
(defun recent-stamp ()
(case (catch (nemoptera_db:q "SELECT MAX(last_timeline_at) FROM repositories WHERE last_timeline_at IS NOT NULL AND last_timeline_at<>'';" '()))
(`((,value))
(let ((text (nemoptera_text:to-str value)))
(if (=:= "" text) "no changes yet" (human-date text))))
(_ "no changes yet")))
(defun human-date (stamp)
(case (re:run stamp "([0-9]{4})-([0-9]{2})-([0-9]{2})"
(list (tuple 'capture 'all 'list)))
(`#(match (,_all ,year ,month ,day))
(lists:flatten (list (month-name (nemoptera_text:to-int month 1)) " "
(integer_to_list (nemoptera_text:to-int day 1)) ", " year)))
(_ stamp)))
(defun month-name (n)
(lists:nth n '("January" "February" "March" "April" "May" "June"
"July" "August" "September" "October" "November" "December")))
(defun timeline-rows ()
(case (nemoptera_db:q
"SELECT r.name, COALESCE(o.name,''), r.description, COALESCE(r.last_timeline_at,'')
FROM repositories r LEFT JOIN organizations o ON o.id=r.organization_id
ORDER BY COALESCE(r.last_timeline_at,'') DESC, r.name COLLATE NOCASE;" '())
(rows (when (is_list rows))
(lists:map
(lambda (row)
(let* (((tuple name org description timeline) (nemoptera_db:as-tuple row))
(org-name (let ((text (nemoptera_text:to-str org)))
(if (=:= "" text) 'none text))))
(maps:from_list
(list (tuple 'name (nemoptera_text:to-str name))
(tuple 'description (nemoptera_text:to-str description))
(tuple 'timeline (nemoptera_text:to-str timeline))
(tuple 'url (repo-path org-name name))))))
rows))
(_ '())))
(defun custom-shortcuts ()
(parse-shortcuts (setting "custom_shortcuts" "")))
(defun parse-shortcuts (raw)
(let ((lines (string:split (nemoptera_text:to-str raw) "\n" 'all)))
(lists:filtermap #'parse-shortcut-line/1 lines)))
(defun parse-shortcut-line (line)
(let ((trimmed (string:trim line)))
(cond
((=:= "" trimmed) 'false)
((=:= 35 (hd trimmed)) 'false)
('true
(case (string:split trimmed "|" 'all)
(`(,label ,url ,target)
(make-shortcut label url (target-mode target url)))
(`(,label ,url)
(make-shortcut label url (default-target url)))
(`(,single)
(case (string:split single " " 'leading)
(`(,label ,url)
(make-shortcut label url (default-target url)))
(_ 'false)))
(_ 'false))))))
(defun make-shortcut (label url target)
(let ((l (string:trim label))
(u (string:trim url)))
(if (or (=:= "" l) (=:= "" u))
'false
`#(true ,(tuple 'custom u l target)))))
(defun default-target (url)
(let ((u (string:trim url)))
(if (or (lists:prefix "http://" u) (lists:prefix "https://" u))
'blank
'self)))
(defun target-mode (target url)
(let ((t (string:lowercase (string:trim target))))
(cond
((or (=:= t "_blank") (=:= t "blank") (=:= t "new")) 'blank)
((or (=:= t "_self") (=:= t "self")) 'self)
('true (default-target url)))))