;; 管理后台（/admin*）：登录校验、仓库 CRUD、远程同步与 Git 推送。
(defmodule lamina_admin_pages
(export all))
;;---- Nova security 回调：会话校验 ----
(defun auth-check (req)
(case (lamina_auth:verify-request req)
(`#(ok ,_username) 'true)
(_
`#(false 302 #M(#"location" #"/login")))))
;;---- Dashboard ----
(defun dashboard (req)
(let ((username (current-username req)))
(html 200 (layout username "Dashboard" (dashboard-body username)))))
(defun dashboard-body (username)
(let ((repo-count (count "SELECT COUNT(*) FROM repositories;"))
(org-count (count "SELECT COUNT(*) FROM organizations;"))
(storage (storage-size))
(recent-count (count "SELECT COUNT(*) FROM repositories WHERE datetime(updated_at) >= datetime('now','-7 days') OR datetime(last_timeline_at) >= datetime('now','-7 days') OR datetime(last_synced_at) >= datetime('now','-7 days');"))
(recent (recent-repositories))
(orgs (lamina_org_mgr:list-orgs))
(site (lamina_site_mgr:all))
(root (lamina_ui:trim-right-slash (maps:get 'site_url (lamina_site_mgr:all) "http://localhost:8827"))))
(lists:flatten
(list
"<div class=\"hello\"><div><h1>" (escape (lamina_ui:greeting username)) "</h1>"
"<p class=\"lede\">Manage your repositories and organizations.</p></div>"
"<div class=\"hello-meta\">" (escape (lamina_ui:today-label)) "<br>\""
(escape (maps:get 'site_tagline site "Small teams. Open source. Built on Fossil."))
"\"</div></div>"
"<div class=\"cards\">"
(card "repo" "My Repositories" (integer_to_list repo-count) "hosted on this site")
(card "org" "Organizations" (integer_to_list org-count) "groups for public repositories")
(card "disk" "Storage Used" (format-bytes storage) "Total repository size")
(card "clock" "Recently Updated" (integer_to_list recent-count) "in the last 7 days")
"</div>"
"<div class=\"dash\"><section class=\"panel\"><div class=\"panel-head\"><h2>Recently Updated Repositories</h2>"
"<a href=\"/admin/repos\">View all</a></div>"
(recent-repositories-html recent)
"</section><div><section class=\"panel\"><div class=\"panel-head\"><h2>Your Organizations</h2>"
"<a href=\"/admin/orgs\">View all</a></div>"
(organizations-html orgs)
"<a class=\"new-org\" href=\"/admin/orgs/new\">+ New Organization</a></section>"
"<section class=\"panel\" style=\"margin-top:14px\"><h2>Quick Actions</h2><div class=\"qa\">"
"<a href=\"/admin/repos/new\">" (lamina_ui:icon "plus") " New Repository</a>"
"<a href=\"/admin/settings\">" (lamina_ui:icon "gear") " Account Settings</a>"
"<a href=\"https://fossil-scm.org/home/doc/trunk/www/index.wiki\">" (lamina_ui:icon "help") " Help & Documentation</a>"
"</div></section></div></div>"
"<section id=\"using-fossil\" class=\"panel banner\"><div>" (lamina_ui:icon "disk") "</div><div class=\"grow\">"
"<h2>Using Fossil?</h2>"
"<p class=\"hint\">Clone repositories and manage advanced settings using the Fossil command-line tool.</p>"
"<div class=\"clone\"><span>fossil clone " (escape root) "/username/repo</span>"
"<button type=\"button\" class=\"copy-btn\">Copy</button></div></div>"
"<a href=\"https://fossil-scm.org/home/doc/trunk/www/index.wiki\">View Fossil Documentation -></a>"
"<button type=\"button\" class=\"dismiss-btn\" aria-label=\"Dismiss\">x</button></section>"
"<script>document.querySelectorAll('.copy-btn').forEach(function(b){b.addEventListener('click',function(){navigator.clipboard.writeText(b.previousElementSibling.textContent.trim())})});(function(){if(localStorage.getItem('lamina-using-fossil')==='1'){var n=document.getElementById('using-fossil');if(n)n.remove()}var d=document.querySelector('.dismiss-btn');if(d)d.addEventListener('click',function(){localStorage.setItem('lamina-using-fossil','1');var n=document.getElementById('using-fossil');if(n)n.remove()})})();</script>"))))
(defun recent-repositories ()
(case (catch (lamina_db:q
"SELECT r.id,r.name,COALESCE(r.display_name,''),MAX(COALESCE(r.last_timeline_at,''),COALESCE(r.last_synced_at,''),r.updated_at),COALESCE(o.name,'') FROM repositories r LEFT JOIN organizations o ON o.id=r.organization_id ORDER BY datetime(MAX(COALESCE(r.last_timeline_at,''),COALESCE(r.last_synced_at,''),r.updated_at)) DESC LIMIT 8;"))
(rows rows)
(_ '())))
(defun recent-repositories-html (rows)
(if (=:= '() rows)
"<p class=\"hint\">No repositories yet.</p>"
(lists:map #'recent-repo-row/1 rows)))
(defun recent-repo-row (row)
(let ((id (to-str (lists:nth 1 row)))
(name (to-str (lists:nth 2 row)))
(display (display-name (lists:nth 3 row) (lists:nth 2 row)))
(updated (lamina_ui:relative-time (lists:nth 4 row)))
(org (to-str (lists:nth 5 row))))
(list "<div class=\"repo-row\">" (lamina_ui:icon "repo") "<div class=\"grow\"><a class=\"name\" href=\"/admin/repos/" id "/edit\">"
(escape display) "</a><p>" (if (=:= "" org) "Ungrouped repository" (list (escape org) " / " (escape name))) "</p></div>"
"<span class=\"badge\">Public</span><span class=\"when\">Updated " (escape updated) "</span></div>")))
(defun organizations-html (rows)
(if (=:= '() rows)
"<p class=\"hint\">No organizations yet.</p>"
(lists:map #'organization-summary/1 rows)))
(defun organization-summary (row)
(let ((name (to-str (lists:nth 2 row)))
(count (to-str (lists:nth 5 row))))
(list "<a class=\"org-row\" href=\"/admin/orgs/" (to-str (lists:nth 1 row)) "/edit\">"
"<span class=\"org-mark\">" (escape (lamina_ui:initials name)) "</span>"
"<div class=\"grow\"><span class=\"name\">" (escape name) "</span>"
"<p>" (escape count) " repositories</p></div></a>")))
(defun storage-size ()
(let ((root (lamina_config:get 'repo_dir "data/repos")))
(case (catch (filelib:fold_files root ".*" 'true #'storage-file/2 0))
(size size)
(_ 0))))
(defun storage-file (path total)
(case (file:read_file_info path)
(`#(ok ,info) (+ total (element 2 info)))
(_ total)))
(defun format-bytes (bytes)
(cond
((>= bytes 1073741824) (lists:flatten (io_lib:format "~p GB" (list (/ bytes 1073741824)))))
((>= bytes 1048576) (lists:flatten (io_lib:format "~p MB" (list (/ bytes 1048576)))))
((>= bytes 1024) (lists:flatten (io_lib:format "~p KB" (list (/ bytes 1024)))))
('true (lists:flatten (io_lib:format "~p B" (list bytes))))))
(defun nav-key (title)
(cond
((=:= title "Dashboard") "dashboard")
((=:= title "Settings") "settings")
((=:= title "Docs") "docs")
((=:= title "Library") "library")
((/= 'nomatch (string:find (to-str title) "Organiz")) "orgs")
('true "repos")))
;;---- 站点设置 ----
(defun settings (req)
(settings-page req ""))
(defun settings-update (req)
(if (not (csrf-valid? req))
(html 403 "CSRF token 无效")
(let* ((params (maps:get 'params req #M()))
(action (to-str (param params "action"))))
(cond
((=:= "reapply" action)
(settings-page req (reapply-message (lamina_site_mgr:reapply-skin-all))))
((=:= "password" action)
(case (password-change-if-requested req params)
('ok (settings-page req "管理员密码已更新。"))
(`#(error ,message) (settings-page req message))
(_ (settings-page req "管理员密码保存失败。"))))
('true
(case (lamina_site_mgr:update (settings-values params))
('ok (settings-page req (settings-save-message)))
(`#(error ,message) (settings-page req message))
(_ (settings-page req "保存站点设置失败。"))))))))
(defun settings-page (req message)
(let ((site (lamina_site_mgr:all)))
(html 200 (layout (current-username req) "Settings" (settings-body req site message)))))
(defun settings-values (params)
(maps:from_list
(list (tuple 'site_name (param params "site_name"))
(tuple 'site_url (param params "site_url"))
(tuple 'site_tagline (param params "site_tagline"))
(tuple 'site_description (param params "site_description"))
(tuple 'footer_text (param params "footer_text"))
(tuple 'footer_terms_url (param params "footer_terms_url"))
(tuple 'footer_privacy_url (param params "footer_privacy_url"))
(tuple 'footer_contact_url (param params "footer_contact_url"))
(tuple 'nav_menu (param params "nav_menu")))))
(defun password-change-if-requested (req params)
(let ((current (param params "current_password"))
(new (param params "new_password"))
(confirmation (param params "new_password_confirmation")))
(if (and (=:= "" (to-str current)) (=:= "" (to-str new)) (=:= "" (to-str confirmation)))
'ok
(lamina_site_mgr:change-admin-password (current-username req) current new confirmation))))
(defun reapply-message (result)
(case result
(`#(ok ,count) (lists:flatten (io_lib:format "皮肤已重新应用到 ~p 个仓库。" (list count))))
(`#(error ,errors) (lists:flatten (list "皮肤重新应用完成但有失败项：" (lists:flatten errors))))
(_ "皮肤重新应用失败。")))
(defun settings-save-message ()
(reapply-message (lamina_site_mgr:reapply-skin-all)))
(defun settings-body (req site message)
(list
"<div class=\"settings-page\"><h1>Site Settings</h1>"
"<p class=\"lede\">These values appear on the public site and in newly rendered repository skins.</p>"
(if (=:= "" message) "" (list "<div class=\"notice\">" (escape message) "</div>"))
"<form method=\"POST\" action=\"/admin/settings\"><input type=\"hidden\" name=\"action\" value=\"save\">"
(csrf-field req)
"<section class=\"settings-card\"><h2>Identity</h2>"
"<div class=\"settings-grid\">"
(settings-input "Site name" "site_name" (maps:get 'site_name site ""))
(settings-input "Site URL" "site_url" (maps:get 'site_url site ""))
(settings-input "Tagline" "site_tagline" (maps:get 'site_tagline site "") "span-2")
(settings-textarea "Description" "site_description" (maps:get 'site_description site "") "span-2")
"</div></section>"
"<section class=\"settings-card\"><h2>Navigation</h2>"
"<p class=\"hint\">One extra top-nav link per line, as <code>Label | URL</code>. Explore and Docs stay first. Use <code>https://…</code> or a site path like <code>/docs</code>.</p>"
(settings-textarea "Custom links" "nav_menu" (maps:get 'nav_menu site "") "nav-area")
"</section>"
"<section class=\"settings-card\"><h2>Footer</h2>"
"<div class=\"settings-grid\">"
(settings-textarea "Footer text" "footer_text" (maps:get 'footer_text site "") "span-2")
(settings-input "Terms URL" "footer_terms_url" (maps:get 'footer_terms_url site ""))
(settings-input "Privacy URL" "footer_privacy_url" (maps:get 'footer_privacy_url site ""))
(settings-input "Contact URL" "footer_contact_url" (maps:get 'footer_contact_url site "") "span-2")
"</div></section>"
"<div class=\"settings-actions\"><button class=\"btn\" type=\"submit\">Save settings</button></div></form>"
"<section class=\"settings-card\"><h2>Password</h2>"
"<form method=\"POST\" action=\"/admin/settings\"><input type=\"hidden\" name=\"action\" value=\"password\">"
(csrf-field req)
"<div class=\"settings-grid\">"
(settings-password "Current password" "current_password")
(settings-password "New password" "new_password")
(settings-password "Confirm new password" "new_password_confirmation" "span-2")
"</div>"
"<div class=\"settings-actions\"><button class=\"btn\" type=\"submit\">Change password</button></div></form></section>"
"<section class=\"settings-card\"><h2>Repository skin</h2>"
"<p class=\"hint\">Push the current site name, navigation and footer into every hosted Fossil repository.</p>"
"<form method=\"POST\" action=\"/admin/settings\">" (csrf-field req)
"<input type=\"hidden\" name=\"action\" value=\"reapply\">"
"<button class=\"btn secondary\" type=\"submit\">Re-apply skin to all repositories</button></form></section></div>"))
(defun settings-input (label name value)
(settings-input label name value ""))
(defun settings-input (label name value class)
(list "<label class=\"" class "\">" label
"<input name=\"" name "\" value=\"" (escape value) "\"></label>"))
(defun settings-textarea (label name value)
(settings-textarea label name value ""))
(defun settings-textarea (label name value class)
(list "<label class=\"" class "\">" label
"<textarea name=\"" name "\">" (escape value) "</textarea></label>"))
(defun settings-password (label name)
(settings-password label name ""))
(defun settings-password (label name class)
(list "<label class=\"" class "\">" label
"<input type=\"password\" name=\"" name "\"></label>"))
(defun count (sql)
(case (catch (lamina_db:q sql))
(`((,v)) (to-int v))
(_ 0)))
(defun current-username (req)
(case (lamina_auth:verify-request req)
(`#(ok ,username) username)
(_ "admin")))
;;---- 仓库列表 ----
(defun repos (req)
(let ((username (current-username req)))
(html 200 (layout username "My Repositories" (repos-body)))))
(defun repos-body ()
(let ((rows (lamina_repo_ctl:list-repos)))
(lists:flatten
(list
"<div class=\"topline\"><div><h1>My Repositories</h1><p class=\"lede\">Manage local and synchronized Fossil repositories.</p></div>"
"<a class=\"btn\" href=\"/admin/repos/new\">+ New Repository</a></div>"
(if (=:= '() rows)
"<div class=\"box\"><p>No repositories yet.</p></div>"
(list "<div class=\"tablebox\"><table><thead><tr><th>Repository</th><th>Description</th><th>Source</th><th>Organization</th><th>Sync / Push</th><th>Actions</th></tr></thead><tbody>"
(lists:map #'repo-row/1 rows)
"</tbody></table></div>"))))))
(defun repo-row (row)
(let ((id (to-str (lists:nth 1 row)))
(name (to-str (lists:nth 2 row)))
(display (display-name (lists:nth 3 row) (lists:nth 2 row)))
(description (to-str (lists:nth 4 row)))
(source (to-str (lists:nth 5 row)))
(org (to-str (lists:nth 6 row)))
(sync-status (to-str (lists:nth 9 row)))
(push-status (to-str (lists:nth 10 row))))
(list "<tr><td><a href=\"/" (if (=:= "" org) "" (list (escape org) "/")) (escape name) "\" target=\"_blank\"><b>" (escape display) "</b></a></td>"
"<td>" (escape description) "</td><td>" (escape source) "</td><td>" (if (=:= "" org) "project" (escape org)) "</td>"
"<td>" (status-text sync-status push-status) "</td>"
"<td><a href=\"/admin/repos/" id "/edit\">Edit</a> · <a href=\"/admin/repos/" id "/delete\">Delete</a></td></tr>")))
;;---- 新建本地仓库 ----
(defun repo-new (req)
(html 200 (layout (current-username req) "New Repository"
(repo-form req "" #M() ""))))
(defun repo-create (req)
(if (not (csrf-valid? req))
(html 403 "CSRF token 无效")
(let ((params (maps:get 'params req #M())))
(case (selected-org-id params)
(`#(error ,message)
(html 200 (layout (current-username req) "New Repository"
(repo-form req message params ""))))
(org-id
(case (create-from-params org-id params)
('ok `#(redirect "/admin/repos"))
(`#(error ,message)
(html 200 (layout (current-username req) "New Repository"
(repo-form req message params ""))))
(_ (lamina_error_pages:internal "创建仓库失败"))))))))
(defun create-from-params (org-id params)
(let ((source (param params "source"))
(slug (param params "slug"))
(display (param params "display_name"))
(description (param params "description"))
(remote-url (param params "remote_url"))
(sync-interval (sync-interval-param params))
(setup-user (param params "setup_username"))
(setup-password (param params "setup_password")))
(if (=:= "remote" (to-str source))
(lamina_repo_ctl:create-remote org-id slug display description remote-url
sync-interval setup-user setup-password)
(lamina_repo_ctl:create-local org-id slug display description setup-user
setup-password))))
;;---- 编辑 ----
(defun repo-edit (req)
(let ((id (binding-id req)))
(let ((repo (lamina_repo_ctl:get-repo-detail id)))
(if (is_map repo)
(html 200 (layout (current-username req) "Edit Repository"
(repo-form req "" (detail->form repo) id)))
(html 404 "仓库不存在")))))
(defun repo-update (req)
(if (not (csrf-valid? req))
(html 403 "CSRF token 无效")
(let* ((id (binding-id req))
(params (maps:get 'params req #M()))
(display (param params "display_name"))
(description (param params "description"))
(setup-user (param params "setup_username"))
(setup-password (param params "setup_password"))
(remote-url (param params "remote_url"))
(sync-interval (sync-interval-param params))
(git-enabled (param params "git_enabled"))
(git-url (param params "git_url"))
(git-username (param params "git_username"))
(git-token (param params "git_token"))
(git-auto-push (param params "git_auto_push")))
(case (lamina_repo_ctl:update-repo-settings id display description setup-user setup-password
remote-url sync-interval git-enabled git-url
git-username git-token git-auto-push)
('ok `#(redirect "/admin/repos"))
(`#(error ,message)
(html 200 (layout (current-username req) "Edit Repository"
(repo-form req message (merge-edit-params id params) id))))
(_ (lamina_error_pages:internal "更新仓库失败"))))))
(defun repo-sync (req)
(if (not (csrf-valid? req))
(html 403 "CSRF token 无效")
(progn
(spawn (lambda () (catch (lamina_sync_task:run-sync (binding-id req)))))
`#(redirect "/admin/repos"))))
(defun repo-push (req)
(if (not (csrf-valid? req))
(html 403 "CSRF token 无效")
(progn
(spawn (lambda () (catch (lamina_sync_task:run-push (binding-id req)))))
`#(redirect "/admin/repos"))))
(defun repo-delete-confirm (req)
(let ((id (binding-id req)))
(let ((repo (lamina_repo_ctl:get-repo id)))
(if (is_list repo)
(let ((name (to-str (lists:nth 2 repo))))
(html 200 (layout (current-username req) "Delete Repository"
(list "<h1>Delete repository</h1><div class=\"box\"><p>确定删除 <b>" (escape name) "</b>？此操作会删除本地 Fossil 文件且不可恢复。</p>"
"<form method=\"POST\" action=\"/admin/repos/" (to-str id) "/delete\">"
(csrf-field req) "<button class=\"danger\" type=\"submit\">Delete repository</button>"
" <a href=\"/admin/repos/" (to-str id) "/edit\">Cancel</a></form></div>"))))
(html 404 "仓库不存在")))))
(defun repo-delete (req)
(if (not (csrf-valid? req))
(html 403 "CSRF token 无效")
(case (lamina_repo_ctl:delete (binding-id req))
('ok `#(redirect "/admin/repos"))
(`#(error ,message) (html 400 message))
(_ (html 400 "删除仓库失败")))))
;;---- 组织管理 ----
(defun orgs (req)
(html 200 (layout (current-username req) "Organizations" (orgs-body))))
(defun orgs-body ()
(let ((rows (lamina_org_mgr:list-orgs)))
(lists:flatten
(list
"<div class=\"topline\"><div><h1>Organizations</h1><p class=\"lede\">Group repositories and give them a stable URL prefix.</p></div><a class=\"btn\" href=\"/admin/orgs/new\">+ New Organization</a></div>"
(if (=:= '() rows)
"<div class=\"box\"><p>No organizations yet.</p></div>"
(list "<div class=\"tablebox\"><table><thead><tr><th>Name</th><th>Description</th><th>Repositories</th><th>Created</th><th>Actions</th></tr></thead><tbody>"
(lists:map #'org-row/1 rows)
"</tbody></table></div>"))))))
(defun org-row (row)
(list "<tr><td><b>" (escape (lists:nth 2 row)) "</b></td><td>" (escape (lists:nth 3 row)) "</td><td>"
(escape (lists:nth 5 row)) "</td><td>" (escape (lists:nth 4 row)) "</td><td><a href=\"/admin/orgs/"
(to-str (lists:nth 1 row)) "/edit\">Edit</a> · <a href=\"/admin/orgs/" (to-str (lists:nth 1 row))
"/delete\">Delete</a></td></tr>"))
(defun org-new (req)
(html 200 (layout (current-username req) "New Organization"
(org-form req "" #M() ""))))
(defun org-create (req)
(if (not (csrf-valid? req))
(html 403 "CSRF token 无效")
(let ((params (maps:get 'params req #M())))
(let ((name (param params "name"))
(description (param params "description")))
(case (lamina_org_mgr:create name description)
('ok `#(redirect "/admin/orgs"))
(`#(error ,message)
(html 200 (layout (current-username req) "New Organization"
(org-form req message params ""))))
(_ (lamina_error_pages:internal "创建组织失败")))))))
(defun org-edit (req)
(let ((id (binding-id req)))
(case (lamina_org_mgr:get id)
('undefined (html 404 "组织不存在"))
(row (html 200 (layout (current-username req) "Edit Organization"
(org-form req "" (org-row->form row) id)))))))
(defun org-update (req)
(if (not (csrf-valid? req))
(html 403 "CSRF token 无效")
(let* ((id (binding-id req))
(params (maps:get 'params req #M()))
(name (param params "name"))
(description (param params "description")))
(case (lamina_org_mgr:update-org id name description)
('ok `#(redirect "/admin/orgs"))
(`#(error ,message)
(html 200 (layout (current-username req) "Edit Organization"
(org-form req message params id))))
(_ (lamina_error_pages:internal "更新组织失败"))))))
(defun org-delete-confirm (req)
(let ((id (binding-id req)))
(case (lamina_org_mgr:get id)
('undefined (html 404 "组织不存在"))
(row
(let ((name (lists:nth 2 row)))
(html 200 (layout (current-username req) "Delete Organization"
(list "<h1>Delete organization</h1><div class=\"box\"><p>确定删除组织 <b>"
(escape name) "</b>？只有空组织可以删除。</p><form method=\"POST\" action=\"/admin/orgs/"
(to-str id) "/delete\">" (csrf-field req)
"<button class=\"danger\" type=\"submit\">Delete organization</button> <a href=\"/admin/orgs/"
(to-str id) "/edit\">Cancel</a></form></div>"))))))))
(defun org-delete (req)
(if (not (csrf-valid? req))
(html 403 "CSRF token 无效")
(case (lamina_org_mgr:delete (binding-id req))
('ok `#(redirect "/admin/orgs"))
(`#(error ,message) (html 400 message))
(_ (html 400 "删除组织失败")))))
;;---- 表单与公共 HTML ----
(defun repo-form (req error params id)
(let* ((editing (not (=:= "" (to-str id))))
(slug (if editing (value params "slug" (to-str id)) (value params "slug" "")))
(source (value params "source" "local"))
(display (value params "display_name" ""))
(description (value params "description" ""))
(username (value params "setup_username" ""))
(org-id (value params "organization_id" ""))
(org-name (value params "org_name" ""))
(remote-url (value params "remote_url" ""))
(sync-interval (value params "sync_interval" "60"))
(git-enabled (value params "git_enabled" "0"))
(git-url (value params "git_url" ""))
(git-username (value params "git_username" ""))
(git-auto-push (value params "git_auto_push" "0"))
(repo-status (value params "repo_status" "up"))
(title (if (and editing (not (=:= "" (to-str display)))) display
(if editing "Edit Repository" "New Repository")))
(remote? (=:= "remote" (to-str source))))
(list
"<div class=\"repo-form-page settings-page\"><div class=\"topline\"><div><h1>"
(escape title)
"</h1><p class=\"lede\">"
(if editing
(list "Settings for <code>" (escape slug) "</code>"
(if (=:= "" (to-str org-name)) "" (list " in " (escape org-name)))
".")
"Create a hosted Fossil repository. Git mirroring can be added after it exists.")
"</p></div>"
(if editing
(list "<div class=\"topline-actions\">" (status-pill repo-status)
"<a class=\"btn secondary\" href=\"" (repo-href org-name slug)
"\" target=\"_blank\" rel=\"noopener\">Open repository</a>"
"<a class=\"btn secondary\" href=\"/admin/repos\">Back to list</a></div>")
"<a class=\"btn secondary\" href=\"/admin/repos\">Back to list</a>")
"</div>"
(if (=:= "" error) "" (list "<div class=\"err\">" (escape error) "</div>"))
"<form method=\"POST\" action=\""
(if editing (list "/admin/repos/" (to-str id) "/edit") "/admin/repos/new")
"\" class=\"js-repo-form\">"
(csrf-field req)
"<section class=\"settings-card\"><h2>Identity</h2>"
"<p class=\"hint\">Slug becomes the public URL. Display name is what visitors see.</p>"
"<div class=\"settings-grid\">"
"<label>Slug (URL)<input name=\"slug\" value=\"" (escape slug) "\""
(if editing " readonly" "") " placeholder=\"lotus\"></label>"
(if editing
(list "<label>Organization<input value=\""
(escape (if (=:= "" (to-str org-name)) "Ungrouped (project)" org-name))
"\" readonly></label>")
(list "<label>Organization<select name=\"organization_id\"><option value=\"\">Ungrouped (project)</option>"
(organization-options (lamina_org_mgr:list-orgs) org-id)
"</select></label>"))
"<label class=\"span-2\">Display name<input name=\"display_name\" value=\""
(escape display) "\" placeholder=\"Lotus\"></label>"
"<label class=\"span-2\">Description<textarea name=\"description\" placeholder=\"What this repository is for\">"
(escape description) "</textarea></label>"
"</div></section>"
(source-card editing source remote-url sync-interval params)
"<section class=\"settings-card\"><h2>Fossil login</h2>"
"<p class=\"hint\">This user is created inside the repository (not the platform admin).</p>"
"<div class=\"settings-grid\">"
"<label>Setup username<input name=\"setup_username\" value=\"" (escape username) "\" autocomplete=\"off\"></label>"
"<label>Setup password<input type=\"password\" name=\"setup_password\" placeholder=\""
(if editing "Leave blank to keep" "Required") "\" autocomplete=\"new-password\"></label>"
"</div></section>"
(if editing (git-card git-enabled git-url git-username git-auto-push) "")
"<div class=\"form-actions\"><button class=\"btn\" type=\"submit\">"
(if editing "Save changes" "Create repository")
"</button><a class=\"btn secondary\" href=\"/admin/repos\">Cancel</a></div></form>"
(if editing
(list (edit-actions req id remote? git-enabled)
(logs-html id)
(danger-card id slug)
(git-toggle-script))
(source-toggle-script))
"</div>")))
(defun source-card (editing source remote-url interval params)
(let ((remote? (=:= "remote" (to-str source))))
(list
"<section class=\"settings-card\"><h2>Source</h2>"
(if editing
(list "<p class=\"hint\">Source cannot be changed after creation.</p>"
"<div class=\"meta-row\">"
(meta-item "Type" (if remote? "Remote Fossil clone" "Local repository"))
(meta-item "Last timeline" (stamp-label (value params "last_timeline_at" "")))
(if remote?
(list (meta-item "Last sync" (stamp-label (value params "last_synced_at" "")))
(meta-item "Sync result" (or-dash (value params "last_sync_status" ""))))
"")
"</div>"
(if remote? (remote-fields 'true remote-url interval)
"<p class=\"hint\">This repository is hosted on this server. Remote Fossil sync is not used.</p>"))
(list "<p class=\"hint\">Local creates an empty Fossil file. Remote clones an existing repository.</p>"
"<div class=\"choice-row\">"
"<label class=\"choice\"><input type=\"radio\" name=\"source\" value=\"local\""
(if remote? "" " checked") "> <span>Create local repository<small>Empty repo hosted on this server</small></span></label>"
"<label class=\"choice\"><input type=\"radio\" name=\"source\" value=\"remote\""
(if remote? " checked" "") "> <span>Clone remote Fossil<small>Import from a Fossil URL or file path</small></span></label>"
"</div>"
(remote-fields remote? remote-url interval)))
"</section>")))
(defun git-card (git-enabled git-url git-username git-auto-push)
(let ((on? (not (=:= "" (checked? git-enabled)))))
(list
"<section class=\"settings-card\"><h2>Git mirror</h2>"
"<p class=\"hint\">Optional. Push this Fossil repository to a Git remote.</p>"
"<label class=\"check-row\"><input type=\"checkbox\" name=\"git_enabled\" value=\"1\""
(checked? git-enabled) "> Enable Git push</label>"
"<div class=\"js-git\"" (if on? "" " hidden") ">"
"<div class=\"settings-grid\">"
"<label class=\"span-2\">Git remote URL<input name=\"git_url\" value=\""
(escape git-url) "\" placeholder=\"https://git.example/repo.git\"></label>"
"<label>Git username<input name=\"git_username\" value=\"" (escape git-username) "\"></label>"
"<label>Git token / password<input type=\"password\" name=\"git_token\" placeholder=\"Leave blank to keep\"></label>"
"</div>"
"<label class=\"check-row\"><input type=\"checkbox\" name=\"git_auto_push\" value=\"1\""
(checked? git-auto-push) "> Push to Git after each Fossil sync</label>"
"</div></section>")))
(defun edit-actions (req id remote? git-enabled)
(let ((sync-btn (if remote?
(list "<form method=\"POST\" action=\"/admin/repos/" (to-str id) "/sync\">" (csrf-field req)
"<button class=\"btn secondary\" type=\"submit\">Sync now</button></form>")
""))
(push-btn (if (not (=:= "" (checked? git-enabled)))
(list "<form method=\"POST\" action=\"/admin/repos/" (to-str id) "/push\">" (csrf-field req)
"<button class=\"btn secondary\" type=\"submit\">Push to Git</button></form>")
"")))
(list "<section class=\"settings-card\"><h2>Operations</h2>"
"<p class=\"hint\">These run in the background. Check recent activity below for results.</p>"
(if (and (=:= "" sync-btn) (=:= "" push-btn))
"<p class=\"ops-note\">Enable a remote Fossil source or Git mirror to run operations.</p>"
(list "<div class=\"form-actions\">" sync-btn push-btn "</div>"))
"</section>")))
(defun danger-card (id slug)
(list "<section class=\"settings-card danger-card\"><h2>Danger zone</h2>"
"<p class=\"hint\">Delete <code>" (escape slug)
"</code> and its local Fossil file. This cannot be undone.</p>"
"<a class=\"danger\" href=\"/admin/repos/" (to-str id) "/delete\">Delete repository</a>"
"</section>"))
(defun remote-fields (visible remote-url interval)
(list "<div class=\"js-remote\"" (if visible "" " hidden") ">"
"<div class=\"settings-grid\">"
"<label class=\"span-2\">Remote Fossil URL<input name=\"remote_url\" value=\""
(escape remote-url) "\" placeholder=\"https://example/repo or file:///path/repo.fossil\"></label>"
"<label>Sync interval<select name=\"sync_interval\">"
(interval-option "30" interval "Every 30 minutes")
(interval-option "60" interval "Every hour")
(interval-option "1440" interval "Every day")
(interval-option "10080" interval "Every week")
(interval-option "custom" interval "Custom")
"</select></label>"
"<label>Custom interval (minutes)<input name=\"sync_interval_custom\" value=\""
(if (known-interval? interval) "" (escape interval)) "\"></label>"
"</div></div>"))
(defun source-toggle-script ()
"<script>(function(){function sync(){var box=document.querySelector('.js-remote');var remote=document.querySelector('input[name=source][value=remote]');if(box)box.hidden=!(remote&&remote.checked);}document.querySelectorAll('input[name=source]').forEach(function(el){el.addEventListener('change',sync);});sync();})();</script>")
(defun git-toggle-script ()
"<script>(function(){function sync(){var box=document.querySelector('.js-git');var on=document.querySelector('input[name=git_enabled]');if(box)box.hidden=!(on&&on.checked);}var on=document.querySelector('input[name=git_enabled]');if(on)on.addEventListener('change',sync);sync();})();</script>")
(defun repo-href (org slug)
(if (=:= "" (to-str org))
(list "/" (escape slug))
(list "/" (escape org) "/" (escape slug))))
(defun status-pill (status)
(let ((s (to-str status)))
(list "<span class=\"pill pill-" (escape s) "\">" (escape (service-status s)) "</span>")))
(defun meta-item (label text)
(list "<div class=\"meta-item\"><span>" (escape label) "</span>" (escape text) "</div>"))
(defun stamp-label (stamp)
(let ((s (to-str stamp)))
(if (or (=:= "" s) (=:= "0" s)) "—" (lamina_ui:relative-time s))))
(defun or-dash (value)
(if (=:= "" (to-str value)) "—" (to-str value)))
(defun sync-interval-param (params)
(let ((selected (to-str (param params "sync_interval")))
(custom (to-str (param params "sync_interval_custom"))))
(if (=:= "custom" selected) custom selected)))
(defun known-interval? (value)
(case (to-str value)
("30" 'true) ("60" 'true) ("1440" 'true) ("10080" 'true) ('true 'false)))
(defun interval-option (value selected label)
(let ((selected1 (or (=:= value (to-str selected))
(and (=:= "custom" value) (not (known-interval? selected))))))
(list "<option value=\"" value "\"" (if selected1 " selected" "") ">" label "</option>")))
(defun checked? (value)
(if (or (=:= "1" (to-str value)) (=:= "true" (to-str value)) (=:= "on" (to-str value)))
" checked"
""))
(defun merge-edit-params (id params)
(case (lamina_repo_ctl:get-repo-detail id)
('undefined params)
(detail (maps:merge (detail->form detail) params))))
(defun detail->form (detail)
(maps:from_list
(list (tuple #"slug" (maps:get 'name detail ""))
(tuple #"source" (maps:get 'source detail "local"))
(tuple #"display_name" (maps:get 'display_name detail ""))
(tuple #"description" (maps:get 'description detail ""))
(tuple #"setup_username" (maps:get 'setup_username detail ""))
(tuple #"org_name" (maps:get 'org_name detail ""))
(tuple #"remote_url" (maps:get 'remote_url detail ""))
(tuple #"sync_interval" (maps:get 'sync_interval detail "60"))
(tuple #"git_enabled" (maps:get 'git_enabled detail 0))
(tuple #"git_url" (maps:get 'git_url detail ""))
(tuple #"git_username" (maps:get 'git_username detail ""))
(tuple #"git_auto_push" (maps:get 'git_auto_push detail 0))
(tuple #"repo_status" (maps:get 'repo_status detail "up"))
(tuple #"last_timeline_at" (maps:get 'last_timeline_at detail ""))
(tuple #"last_synced_at" (maps:get 'last_synced_at detail ""))
(tuple #"last_sync_status" (maps:get 'last_sync_status detail ""))
(tuple #"last_pushed_at" (maps:get 'last_pushed_at detail ""))
(tuple #"last_push_status" (maps:get 'last_push_status detail "")))))
(defun logs-html (repo-id)
(list "<section class=\"settings-card\"><h2>Recent activity</h2>"
"<h3>Syncs</h3>" (log-list (lamina_sync_task:recent-sync-logs repo-id))
"<h3>Pushes</h3>" (log-list (lamina_sync_task:recent-push-logs repo-id))
"</section>"))
(defun log-list (rows)
(if (=:= '() rows)
"<p class=\"hint log-empty\">No runs yet.</p>"
(list "<table class=\"compact-table\"><thead><tr><th>Started</th><th>Result</th><th>Detail</th></tr></thead><tbody>"
(lists:map #'log-row/1 rows)
"</tbody></table>")))
(defun log-row (row)
(list "<tr><td>" (escape (lists:nth 1 row)) "</td><td><b>" (escape (lists:nth 3 row))
"</b></td><td>" (if (=:= "" (to-str (lists:nth 4 row))) "—" (escape (lists:nth 4 row)))
"</td></tr>"))
(defun status-text (sync push)
(list "sync: " (if (=:= "" sync) "—" (escape sync)) " / push: "
(if (=:= "" push) "—" (escape push))))
(defun service-status (status)
(case (to-str status)
("up" "up")
("starting" "starting")
("down" "down")
(_ "unknown")))
(defun organization-field (selected)
(list "<label>Organization (optional)<select name=\"organization_id\"><option value=\"\">project (no organization)</option>"
(organization-options (lamina_org_mgr:list-orgs) selected)
"</select></label>"))
(defun organization-options (rows selected)
(case rows
('() "")
(`(,row . ,rest)
(let ((id (to-str (lists:nth 1 row)))
(name (lists:nth 2 row)))
(cons (list "<option value=\"" id "\"" (if (=:= id (to-str selected)) " selected" "") ">"
(escape name) "</option>")
(organization-options rest selected))))))
(defun selected-org-id (params)
(let ((value (param params "organization_id")))
(if (=:= "" (to-str value))
'none
(case (catch (list_to_integer (to-str value)))
(`#(EXIT ,_) `#(error "组织选择无效"))
(id (if (=:= 'true (lamina_org_mgr:exists? id))
id
`#(error "所选组织不存在")))))))
(defun org-form (req error params id)
(let ((editing (not (=:= "" (to-str id))))
(name (value params "name" ""))
(description (value params "description" "")))
(list "<h1>" (if editing "Edit Organization" "New Organization") "</h1>"
(if (=:= "" error) "" (list "<div class=\"err\">" (escape error) "</div>"))
"<form class=\"org-form\" method=\"POST\" action=\"" (if editing (list "/admin/orgs/" (to-str id) "/edit") "/admin/orgs/new") "\">"
(csrf-field req)
"<label>Name (URL prefix)<input name=\"name\" value=\"" (escape name) "\"></label>"
(if editing "<p class=\"hint\">Changing the name changes the public URL of repositories in this organization.</p>" "")
"<label>Description<textarea name=\"description\">" (escape description) "</textarea></label>"
"<div class=\"form-actions\"><button class=\"btn\" type=\"submit\">"
(if editing "Save changes" "Create organization")
"</button></div></form>")))
;; LFE 的 #M 字面量不会执行里面的函数调用，未求值的列表会在 escape 时把页面打成 500。
(defun org-row->form (row)
(maps:from_list
(list (tuple #"name" (to-str (lists:nth 2 row)))
(tuple #"description" (to-str (lists:nth 3 row))))))
(defun csrf-field (req)
(case (lamina_auth:verify-request req)
(`#(ok ,username)
(list "<input type=\"hidden\" name=\"csrf\" value=\"" (escape (lamina_auth:csrf-token username)) "\">"))
(_ "")))
(defun csrf-valid? (req)
(case (lamina_auth:verify-request req)
(`#(ok ,username)
(lamina_auth:verify-csrf username (param (maps:get 'params req #M()) "csrf")))
(_ 'false)))
(defun binding-id (req)
(let ((bindings (maps:get 'bindings req #M())))
(let ((value (case (maps:find 'id bindings)
(`#(ok ,v) v)
(_ (case (maps:find #"id" bindings)
(`#(ok ,v) v)
(_ "0"))))))
(case (catch (list_to_integer (to-str value)))
(`#(EXIT ,_) 0)
(id id)))))
(defun param (params name)
(case (maps:find (list_to_binary name) params)
(`#(ok ,value) value)
(_ "")))
(defun value (params name default)
(let ((v (param params name)))
(if (=:= "" (to-str v)) default (to-str v))))
(defun row->form (row)
(maps:from_list
(list (tuple #"slug" (to-str (lists:nth 2 row)))
(tuple #"display_name" (to-str (lists:nth 3 row)))
(tuple #"description" (to-str (lists:nth 4 row)))
(tuple #"setup_username" ""))))
(defun display-name (display slug)
(let ((d (to-str display)))
(if (=:= "" d) (to-str slug) d)))
(defun layout (_username title body)
(let ((site (lamina_site_mgr:all))
(active (nav-key title)))
(list_to_binary
(lists:flatten
(list
"<!DOCTYPE html><html lang=\"en\"><head><meta charset=\"utf-8\">"
"<meta name=\"color-scheme\" content=\"light only\">"
"<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">"
"<title>" (escape title) " · " (escape (maps:get 'site_name site "lamina")) "</title>"
"<style>" (lamina_ui:admin-css) "</style></head><body><div class=\"app\">"
"<aside class=\"side\"><a class=\"brand\" href=\"/\" title=\"Back to public site\">" (escape (maps:get 'site_name site "lamina"))
"</a><div class=\"brand-sub\">Built on Fossil</div><nav class=\"side-nav\">"
(side-link "/admin" "dashboard" active "home" "Dashboard")
(side-link "/admin/repos" "repos" active "repo" "My Repositories")
(side-link "/admin/orgs" "orgs" active "org" "Organizations")
(side-link "/admin/docs" "docs" active "book" "Docs")
(side-link "/admin/library" "library" active "library" "Library")
(side-link "/admin/settings" "settings" active "gear" "Settings")
"</nav></aside><div class=\"workspace\"><header class=\"topbar\">"
"<a class=\"btn\" href=\"/admin/repos/new\">+ New</a>"
"<a class=\"hint\" href=\"/logout\">Logout</a></header>"
"<main class=\"content\">" body "</main>"
"<footer class=\"admin-foot\"><span>" (escape (lamina_ui:footer-text site)) "</span><nav>"
(lamina_ui:footer-link (maps:get 'footer_terms_url site "") "Terms")
(lamina_ui:footer-link (maps:get 'footer_privacy_url site "") "Privacy")
(lamina_ui:footer-link (maps:get 'footer_contact_url site "") "Contact")
"<span>v1.0.0</span></nav></footer></div></div></body></html>")))))
(defun side-link (href key active icon label)
(list "<a href=\"" href "\" class=\"" (if (=:= key active) "active" "") "\">"
(lamina_ui:icon icon) " " label "</a>"))
(defun card (icon label value subtitle)
(list "<div class=\"stat\"><div class=\"stat-top\">" (lamina_ui:icon icon) " " label
"</div><div class=\"big\">" value "</div><div class=\"sub\">" subtitle "</div></div>"))
(defun html (code body)
(let ((b (if (is_binary body) body (list_to_binary (lists:flatten body)))))
`#(status ,code #M(#"content-type" #"text/html; charset=utf-8") ,b)))
(defun to-int (value)
(cond
((is_integer value) value)
((is_binary value) (binary_to_integer value))
('true (list_to_integer value))))
(defun to-str (value)
(cond
((is_binary value) (binary_to_list value))
((is_list value) value)
((=:= 'undefined value) "")
('true (lists:flatten (io_lib:format "~p" (list value))))))
(defun escape (value)
(let ((s (to-str value)))
(string:replace
(string:replace
(string:replace
(string:replace
(string:replace s "&" "&" 'all)
"<" "<" 'all)
">" ">" 'all)
"\"" """ 'all)
"'" "'" 'all)))