;; 站点信息与公开首页数据聚合。
(defmodule lamina_site_mgr
(export all))
;;---- 站点设置 ----
(defun defaults ()
#M(site_name "lamina"
site_url "http://localhost:8827"
site_tagline "Small teams. Open source. Built on Fossil."
site_description "Open source projects and tools powered by Fossil."
footer_text "lamina — a small, focused Fossil management shell."
footer_terms_url ""
footer_privacy_url ""
footer_contact_url ""
nav_menu ""))
(defun get (key default)
(case (catch (lamina_db:q "SELECT value FROM site_settings WHERE key=?;"
(list key)))
(`((,value)) (to-str value))
(_
(default-value key default))))
;; Setup 向导首先把站点名称与 URL 写入运行时配置；数据库设置表尚未有值时，
;; 公开首页和新建仓库皮肤也应该沿用这两个值。
(defun default-value (key fallback)
(case key
('site_name (lamina_config:get 'site_name fallback))
('site_url (lamina_config:get 'site_url fallback))
(_
(case (maps:find key (defaults))
(`#(ok ,value) value)
(_ fallback)))))
(defun all ()
(lists:foldl
(lambda (entry acc)
(let (((tuple key default) entry))
(maps:put key (get key default) acc)))
#M()
(list (tuple 'site_name "lamina")
(tuple 'site_url "http://localhost:8827")
(tuple 'site_tagline "Small teams. Open source. Built on Fossil.")
(tuple 'site_description "Open source projects and tools powered by Fossil.")
(tuple 'footer_text "lamina — a small, focused Fossil management shell.")
(tuple 'footer_terms_url "")
(tuple 'footer_privacy_url "")
(tuple 'footer_contact_url "")
(tuple 'nav_menu ""))))
(defun set (key value)
(let ((value1 (to-str value)))
(case (catch (lamina_db:q
"INSERT OR REPLACE INTO site_settings(key,value) VALUES(?,?);"
(list key value1)))
('ok 'ok)
('() 'ok)
(`#(error ,reason) `#(error ,(format-db-error reason)))
(_ `#(error "保存站点设置失败")))))
(defun update (values)
(let ((entries (maps:to_list values)))
(save-settings entries)))
(defun save-settings (entries)
(case entries
('() 'ok)
(`(#(,key ,value) . ,rest)
(case (set key value)
('ok (save-settings rest))
(error error)
(_ `#(error "保存站点设置失败"))))))
(defun site-name () (get 'site_name "lamina"))
(defun site-url () (get 'site_url "http://localhost:8827"))
(defun site-tagline () (get 'site_tagline "Small teams. Open source. Built on Fossil."))
;; 自定义顶栏菜单。每行 "名称 | URL"，Explore 始终在最前。
(defun nav-items ()
(parse-nav-menu (get 'nav_menu "")))
(defun parse-nav-menu (text)
(lists:filtermap
(lambda (line)
(parse-nav-line (string:trim (to-str line))))
(string:split (to-str text) "\n" 'all)))
(defun parse-nav-line (line)
(if (=:= "" line)
'false
(case (string:split line "|" 'leading)
(`(,label ,url)
(let ((name (string:trim label))
(href (string:trim url)))
(if (and (/= "" name) (/= "" href) (valid-nav-url? href))
`#(true ,(maps:from_list (list (tuple 'label name) (tuple 'url href))))
'false)))
(_ 'false))))
(defun valid-nav-url? (url)
(or (lists:prefix "https://" url)
(lists:prefix "http://" url)
(lists:prefix "mailto:" url)
(and (lists:prefix "/" url) (not (lists:prefix "//" url)))))
;; 管理员从 Settings 页面修改平台密码。平台目前使用 OTP 内置的
;; PBKDF2-HMAC-SHA512（见 lamina_crypto），避免引入原生 argon2 依赖。
(defun change-admin-password (username current-password new-password confirmation)
(let* ((username1 (to-str username))
(current1 (to-bin current-password))
(new1 (to-bin new-password))
(confirm1 (to-bin confirmation)))
(cond
((=:= #"" current1) `#(error "当前密码不能为空"))
((< (byte_size new1) 8) `#(error "新密码至少需要 8 个字符"))
((/= new1 confirm1) `#(error "两次输入的新密码不一致"))
('true
(case (catch (lamina_db:q
"SELECT password_hash FROM admin_user WHERE username=?;"
(list username1)))
(`((,stored))
(if (lamina_crypto:verify_password current1 (to-bin stored))
(let ((result (lamina_db:q
"UPDATE admin_user SET password_hash=?,updated_at=? WHERE username=?;"
(list (lamina_crypto:hash_password new1)
(lamina_setup:iso8601 (os:system_time 'second))
username1))))
(case result
('ok (lamina_auth:reset-fails) 'ok)
('() (lamina_auth:reset-fails) 'ok)
(`#(error ,reason) `#(error ,(format-db-error reason)))
(_ `#(error "保存管理员密码失败"))))
`#(error "当前密码不正确")))
(_ `#(error "管理员账户不存在")))))))
;; 重新渲染并导入所有仓库的统一皮肤。失败项全部收集后返回，方便设置页
;; 给出可读反馈，同时不会因为单个损坏仓库而中断剩余仓库。
(defun reapply-skin-all ()
(case (catch (lamina_db:q
"SELECT id,organization_id,name,fossil_path,description FROM repositories ORDER BY id;"))
(rows (let (((tuple count errors)
(lists:foldl #'reapply-one/2 (tuple 0 '()) rows)))
(if (=:= '() errors)
`#(ok ,count)
`#(error ,(lists:reverse errors)))))
(`#(error ,reason) `#(error ,(format-db-error reason)))
(_ `#(error "读取仓库列表失败"))))
(defun reapply-one (row acc)
(let (((tuple count errors) acc))
(case row
(`(,_id ,org-id ,slug ,path ,desc)
(let ((result (catch (lamina_repo_ctl:maybe-apply-skin
(to-str path) (normalize-org-id org-id) (to-str slug)
(to-str desc)))))
(case result
('ok (tuple (+ count 1) errors))
(`#(error ,reason) (tuple count (cons (list (to-str slug) ": " (to-str reason)) errors)))
(`#(EXIT ,reason) (tuple count (cons (list (to-str slug) ": " (to-str reason)) errors)))
(_ (tuple count (cons (list (to-str slug) ": 皮肤导入失败") errors))))))
(_ acc))))
(defun normalize-org-id (value)
(case value
('undefined 'none)
('null 'none)
(_ value)))
;; repo_server 使用该 URL，让 Fossil 生成的内部链接和反向代理前缀一致。
(defun repo-base-url (org-name slug)
(let ((root (trim-right-slash (site-url)))
(path (case org-name
('none (lists:flatten (list "/" (to-str slug))))
(#"" (lists:flatten (list "/" (to-str slug))))
("" (lists:flatten (list "/" (to-str slug))))
(org (lists:flatten (list "/" (to-str org) "/" (to-str slug)))))))
(lists:flatten (list root path))))
;;---- 公开首页 ----
(defun public-index ()
(let* ((result (catch
(lamina_db:q
"SELECT r.name,r.display_name,r.description,COALESCE(r.last_timeline_at,''),r.updated_at,r.fossil_path,COALESCE(o.name,''),COALESCE(o.created_at,'') FROM repositories r LEFT JOIN organizations o ON o.id=r.organization_id;")))
(rows (if (is_list result) result '()))
(hidden (lamina_library:hidden-paths))
(summaries (lists:filter
(lambda (summary) (not (hide-summary? summary hidden)))
(lists:map #'row->summary/1 rows))))
(maps:from_list
(list (tuple 'site (all))
(tuple 'groups (build-groups summaries))))))
(defun hide-summary? (summary hidden-paths)
(lists:member (element 8 summary) hidden-paths))
;; summary: {org-name, org-created, slug, display-name, description,
;; last-timeline, updated-at, fossil-path}
(defun row->summary (row)
(tuple (to-str (lists:nth 7 row))
(to-str (lists:nth 8 row))
(to-str (lists:nth 1 row))
(to-str (lists:nth 2 row))
(to-str (lists:nth 3 row))
(to-str (lists:nth 4 row))
(to-str (lists:nth 5 row))
(to-str (lists:nth 6 row))))
(defun build-groups (summaries)
(let ((ordered (lists:sort #'summary-less?/2 summaries)))
(lists:map #'group->map/1 (group-rows ordered '()))))
(defun summary-less? (a b)
(let ((a-org (element 1 a))
(b-org (element 1 b)))
(cond
((and (=:= "" a-org) (/= "" b-org)) 'true)
((and (/= "" a-org) (=:= "" b-org)) 'false)
((=:= a-org b-org)
(let ((a-updated (element 7 a))
(b-updated (element 7 b)))
(if (=:= a-updated b-updated)
(=< (element 3 a) (element 3 b))
(>= a-updated b-updated))))
('true
(let ((a-created (element 2 a))
(b-created (element 2 b)))
(if (=:= a-created b-created)
(=< a-org b-org)
(=< a-created b-created)))))))
(defun group-rows (summaries groups)
(case summaries
('() groups)
(`(,summary . ,rest)
(group-rows rest (add-to-group summary groups)))))
(defun add-to-group (summary groups)
(let ((org (element 1 summary)))
(case groups
('() (list (tuple org (element 2 summary) (list summary))))
(`(#(,group-org ,created ,repos) . ,rest)
(if (=:= org group-org)
(cons (tuple group-org created (add-repo summary repos)) rest)
(cons (tuple group-org created repos)
(add-to-group summary rest)))))))
(defun add-repo (summary repos)
(case repos
('() (list summary))
(`(,first . ,rest)
(if (summary-less? summary first)
(cons summary repos)
(cons first (add-repo summary rest))))))
(defun group->map (group)
(let (((tuple org _created summaries) group))
(maps:from_list
(list (tuple 'title (if (=:= "" org) "project" org))
(tuple 'repos (lists:map #'summary->map/1 summaries))))))
(defun summary->map (summary)
(let (((tuple org _created slug display description last updated path) summary))
(let ((display1 (if (=:= "" display) slug display)))
(maps:from_list
(list (tuple 'name slug)
(tuple 'display_name display1)
(tuple 'description description)
(tuple 'organization org)
(tuple 'url (repo-url org slug))
(tuple 'last_timeline (timeline-value last path updated))
(tuple 'updated_at updated))))))
(defun timeline-value (last path updated)
(cond
((/= "" (to-str last)) (to-str last))
('true
(case (lamina_fossil_repo:last-timeline path)
('unknown (format-updated updated))
(value (to-str value))))))
(defun format-updated (updated)
(let ((s (to-str updated)))
(case (re:run s "^([0-9]{4}-[0-9]{2}-[0-9]{2})[T ]([0-9]{2}:[0-9]{2})"
(list (tuple 'capture 'all 'list)))
(`#(match (,_ ,date ,time)) (lists:flatten (list date " " time)))
(_ (if (=:= "" s) "No activity yet" s)))))
(defun repo-url (org slug)
(if (=:= "" org)
(lists:flatten (list "/" slug))
(lists:flatten (list "/" org "/" slug))))
(defun trim-right-slash (value)
(let ((s (to-str value)))
(if (and (> (length s) 0) (=:= (lists:last s) 47))
(trim-right-slash (lists:sublist s 1 (- (length s) 1)))
s)))
(defun format-db-error (reason)
(lists:flatten (io_lib:format "数据库错误: ~p" (list reason))))
(defun to-bin (value)
(if (is_binary value) value (list_to_binary (to-str value))))
(defun to-str (value)
(cond
((is_binary value) (binary_to_list value))
((is_list value) value)
((or (=:= 'undefined value) (=:= 'null value)) "")
('true (lists:flatten (io_lib:format "~p" (list value))))))