(defmodule nemoptera_admin
(export all))
(defun auth-check (req)
(cond
((not (nemoptera_setup:installed?))
`#(false 302 #M(#"location" #"/setup")))
((case (nemoptera_auth:verify-request req)
(`#(ok ,_) 'true)
(_ 'false))
'true)
('true `#(false 302 #M(#"location" #"/login")))))
(defun home (req)
(let ((repos (nemoptera_repo:list-all))
(orgs (nemoptera_org:list-all)))
(page req "Home" 'home
(list "<h1 class=\"page\">Home</h1>"
"<p>" (count-phrase (length repos) "repository" "repositories") ", "
(count-phrase (length orgs) "organization" "organizations") ".</p>"
"<p><a href=\"/admin/repos/new\">New repository</a> | "
"<a href=\"/admin/orgs/new\">New organization</a> | "
"<a href=\"/admin/settings\">Site settings</a></p>"
(repo-table repos 'false)))))
(defun count-phrase (n one many)
(list (integer_to_list n) " " (if (=:= n 1) one many)))
(defun repos (req)
(page req "Repositories" 'repos
(list "<h1 class=\"page\">Repositories</h1>"
"<p><a href=\"/admin/repos/new\">New repository</a></p>"
(repo-table (nemoptera_repo:list-all) 'true))))
(defun repo-new (req)
(page req "New repository" 'repos
(repo-form req "New repository" "/admin/repos/new" (blank-repo (nemoptera_http:param req "org")) "")))
(defun repo-create (req)
(if (nemoptera_http:csrf-ok? req)
(case (nemoptera_repo:create (repo-fields req))
(`#(ok ,id) (nemoptera_http:redirect (lists:flatten (list "/admin/repos/" (integer_to_list id)))))
(`#(error ,message)
(page-status req 400 "New repository" 'repos
(repo-form req "New repository" "/admin/repos/new" (repo-fields req) message))))
(forbidden req)))
(defun repo-edit (req)
(case (nemoptera_repo:fetch (nemoptera_http:binding-id req))
(`#(ok ,repo)
(page req "Edit repository" 'repos
(repo-form req "Edit repository"
(lists:flatten (list "/admin/repos/" (integer_to_list (maps:get 'id repo))))
repo "")))
(_ (missing req "Repository"))))
(defun repo-update (req)
(let ((id (nemoptera_http:binding-id req)))
(if (nemoptera_http:csrf-ok? req)
(case (nemoptera_repo:update id (repo-fields req))
('ok (nemoptera_http:redirect (lists:flatten (list "/admin/repos/" (integer_to_list id)))))
(`#(error ,message)
(case (nemoptera_repo:fetch id)
(`#(ok ,repo)
(page-status req 400 "Edit repository" 'repos
(repo-form req "Edit repository"
(lists:flatten (list "/admin/repos/" (integer_to_list id)))
(maps:merge repo (repo-fields req)) message)))
(_ (missing req "Repository")))))
(forbidden req))))
(defun repo-delete (req)
(case (nemoptera_repo:fetch (nemoptera_http:binding-id req))
(`#(ok ,repo)
(page req "Delete repository" 'repos
(list "<h1 class=\"page\">Delete repository</h1>"
"<p>Delete <strong>" (nemoptera_ui:escape (maps:get 'name repo))
"</strong> and its local Fossil file?</p>"
(post-button req (lists:flatten (list "/admin/repos/" (integer_to_list (maps:get 'id repo)) "/delete"))
"Delete repository"))))
(_ (missing req "Repository"))))
(defun repo-delete-do (req)
(if (nemoptera_http:csrf-ok? req)
(case (nemoptera_repo:delete (nemoptera_http:binding-id req))
('ok (nemoptera_http:redirect "/admin/repos"))
(`#(error ,message) (page-status req 400 "Delete repository" 'repos (list "<p class=\"error\">" (nemoptera_ui:escape message) "</p>"))))
(forbidden req)))
(defun repo-sync (req)
(action req #'nemoptera_sync:run-sync/1 "Sync"))
(defun repo-push (req)
(action req #'nemoptera_sync:run-push/1 "Git push"))
(defun action (req fun label)
(if (nemoptera_http:csrf-ok? req)
(let ((id (nemoptera_http:binding-id req)))
(case (funcall fun id)
('ok (nemoptera_http:redirect (lists:flatten (list "/admin/repos/" (integer_to_list id)))))
(`#(error ,message)
(page-status req 400 label 'repos
(list "<h1 class=\"page\">" label "</h1><p class=\"error\">"
(nemoptera_ui:escape message) "</p><p><a href=\"/admin/repos/"
(integer_to_list id) "\">Back</a></p>")))))
(forbidden req)))
(defun orgs (req)
(page req "Organizations" 'orgs
(list "<h1 class=\"page\">Organizations</h1><p><a href=\"/admin/orgs/new\">New organization</a></p>"
(org-table (nemoptera_org:list-all)))))
(defun org-new (req)
(page req "New organization" 'orgs
(org-form req "New organization" "/admin/orgs/new" "" "" "")))
(defun org-create (req)
(if (nemoptera_http:csrf-ok? req)
(case (nemoptera_org:create (nemoptera_http:param req "name") (nemoptera_http:param req "description"))
(`#(ok ,id) (nemoptera_http:redirect (lists:flatten (list "/admin/orgs/" (integer_to_list id)))))
(`#(error ,message)
(page-status req 400 "New organization" 'orgs
(org-form req "New organization" "/admin/orgs/new"
(nemoptera_http:param req "name")
(nemoptera_http:param req "description") message))))
(forbidden req)))
(defun org-edit (req)
(case (nemoptera_org:fetch (nemoptera_http:binding-id req))
(`#(ok ,org)
(page req "Edit organization" 'orgs
(org-form req "Edit organization"
(lists:flatten (list "/admin/orgs/" (integer_to_list (maps:get 'id org))))
(maps:get 'name org) (maps:get 'description org) "")))
(_ (missing req "Organization"))))
(defun org-update (req)
(let ((id (nemoptera_http:binding-id req)))
(if (nemoptera_http:csrf-ok? req)
(case (nemoptera_org:update id (nemoptera_http:param req "name") (nemoptera_http:param req "description"))
('ok (nemoptera_http:redirect (lists:flatten (list "/admin/orgs/" (integer_to_list id)))))
(`#(error ,message)
(page-status req 400 "Edit organization" 'orgs
(org-form req "Edit organization"
(lists:flatten (list "/admin/orgs/" (integer_to_list id)))
(nemoptera_http:param req "name")
(nemoptera_http:param req "description") message))))
(forbidden req))))
(defun org-delete (req)
(case (nemoptera_org:fetch (nemoptera_http:binding-id req))
(`#(ok ,org)
(page req "Delete organization" 'orgs
(list "<h1 class=\"page\">Delete organization</h1><p>Delete <strong>"
(nemoptera_ui:escape (maps:get 'name org)) "</strong>? Repositories must be removed first.</p>"
(post-button req (lists:flatten (list "/admin/orgs/" (integer_to_list (maps:get 'id org)) "/delete"))
"Delete organization"))))
(_ (missing req "Organization"))))
(defun org-delete-do (req)
(if (nemoptera_http:csrf-ok? req)
(case (nemoptera_org:delete (nemoptera_http:binding-id req))
('ok (nemoptera_http:redirect "/admin/orgs"))
(`#(error ,message) (page-status req 400 "Delete organization" 'orgs (list "<p class=\"error\">" (nemoptera_ui:escape message) "</p>"))))
(forbidden req)))
(defun settings (req)
(page req "Settings" 'settings (settings-form req (nemoptera_site:all) "")))
(defun settings-save (req)
(if (nemoptera_http:csrf-ok? req)
(case (save-settings req)
('ok
(catch (restart-all))
(nemoptera_http:redirect "/admin/settings"))
(`#(error ,message)
(page-status req 400 "Settings" 'settings (settings-form req (nemoptera_site:all) message))))
(forbidden req)))
(defun save-settings (req)
(let ((name (nemoptera_http:param req "site_name"))
(url (nemoptera_http:param req "site_url"))
(password (nemoptera_http:param req "password"))
(password2 (nemoptera_http:param req "password2")))
(cond
((nemoptera_text:blank? name) `#(error "Site name is required."))
((nemoptera_text:blank? url) `#(error "Site URL is required."))
((and (not (nemoptera_text:blank? password)) (< (length password) 8))
`#(error "Password must be at least 8 characters."))
((not (=:= password password2)) `#(error "The two passwords do not match."))
('true
(nemoptera_site:put-settings
(list (tuple "site_name" name)
(tuple "site_url" (nemoptera_setup:trim-slash url))
(tuple "site_tagline" (nemoptera_http:param req "site_tagline"))
(tuple "site_description" (nemoptera_http:param req "site_description"))
(tuple "loose_title" (defaulting (nemoptera_http:param req "loose_title") "Repositories"))
(tuple "custom_shortcuts" (nemoptera_http:param req "custom_shortcuts"))))
(if (nemoptera_text:blank? password)
'ok
(let ((user (nemoptera_auth:current-user req))
(now (nemoptera_text:now-iso)))
(nemoptera_db:q "UPDATE admin_user SET password_hash=?, updated_at=? WHERE username=?;"
(list (nemoptera_crypto:hash-password password) now user))
'ok))))))
(defun restart-all ()
(lists:foreach
(lambda (repo)
(nemoptera_mgr:stop-repo (maps:get 'org repo) (maps:get 'name repo))
(case (nemoptera_repo:fetch (maps:get 'id repo))
(`#(ok ,full) (nemoptera_mgr:start-repo (maps:get 'org full) (maps:get 'name full) (maps:get 'fossil_path full)))
(_ 'ok)))
(nemoptera_repo:list-all)))
(defun page (req title current body)
(page-status req 200 title current body))
(defun page-status (req code title current body)
(nemoptera_http:html code
(nemoptera_ui:render title current 'admin (nemoptera_public:logged-in? req) body)))
(defun missing (req noun)
(page-status req 404 noun 'home
(list "<h1 class=\"page\">" noun "</h1><p>Not found.</p>")))
(defun forbidden (req)
(page-status req 403 "Forbidden" 'home "<h1 class=\"page\">Forbidden</h1><p>The form token was rejected. Reload the page and try again.</p>"))
(defun repo-table (repos show-admin?)
(if (=:= '() repos)
"<p>No repositories yet.</p>"
(list "<table><tr><th>Name</th><th>Organization</th><th>Source</th><th>Last change</th>"
(if show-admin? "<th></th>" "")
"</tr>"
(lists:map (lambda (repo) (repo-row repo show-admin?)) repos)
"</table>")))
(defun repo-row (repo show-admin?)
(let ((org (maps:get 'org repo)))
(list "<tr><td><a href=\"" (nemoptera_ui:escape (maps:get 'url repo)) "\" target=\"_blank\" rel=\"noopener\">"
(nemoptera_ui:escape (maps:get 'name repo)) "</a><br><span class=\"note\">"
(nemoptera_ui:escape (maps:get 'description repo)) "</span></td><td>"
(nemoptera_ui:escape (if (=:= org 'none) "—" org)) "</td><td>"
(nemoptera_ui:escape (maps:get 'source repo)) "</td><td>"
(nemoptera_ui:escape (blank (maps:get 'timeline repo) "—")) "</td>"
(if show-admin?
(list "<td><a href=\"/admin/repos/" (integer_to_list (maps:get 'id repo)) "\">Edit</a></td>")
"")
"</tr>")))
(defun org-table (orgs)
(if (=:= '() orgs)
"<p>No organizations yet. Repositories without an organization appear under the public heading.</p>"
(list "<table><tr><th>Name</th><th>URL prefix</th><th>Description</th><th>Repositories</th><th></th></tr>"
(lists:map
(lambda (org)
(list "<tr><td>" (nemoptera_ui:escape (maps:get 'name org)) "</td><td>/"
(nemoptera_ui:escape (maps:get 'name org)) "/</td><td>"
(nemoptera_ui:escape (maps:get 'description org)) "</td><td>"
(integer_to_list (maps:get 'count org)) "</td><td><a href=\"/admin/orgs/"
(integer_to_list (maps:get 'id org)) "\">Edit</a> | <a href=\"/admin/repos/new?org="
(integer_to_list (maps:get 'id org)) "\">New repository</a></td></tr>"))
orgs)
"</table>")))
(defun repo-form (req title action repo message)
(let ((id (maps:get 'id repo 0))
(source (maps:get 'source repo "local"))
(org-id (maps:get 'organization_id repo 'none)))
(list "<h1 class=\"page\">" (nemoptera_ui:escape title) "</h1>"
(if (=:= "" message) "" (list "<p class=\"error\">" (nemoptera_ui:escape message) "</p>"))
(if (> id 0)
(list "<p>Public path: <a href=\"" (nemoptera_ui:escape (maps:get 'url repo "")) "\" target=\"_blank\" rel=\"noopener\">"
(nemoptera_ui:escape (maps:get 'url repo "")) "</a></p>"
"<p class=\"note\">Last sync: " (nemoptera_ui:escape (blank (maps:get 'sync_status repo "") "—"))
"<br>Last Git push: " (nemoptera_ui:escape (blank (maps:get 'push_status repo "") "—")) "</p>")
"")
"<form method=\"post\" action=\"" (nemoptera_ui:escape action) "\">"
(nemoptera_http:csrf-field req)
(org-select org-id)
(text "name" "Repository name" (maps:get 'name repo ""))
(area "description" "Description" (maps:get 'description repo ""))
(text "setup_username" "Setup username" (maps:get 'setup_username repo ""))
(password "setup_password" (if (> id 0) "Setup password (leave blank to keep)" "Setup password"))
"<p class=\"check\"><label><input type=\"radio\" name=\"source\" value=\"local\""
(if (=:= source "remote") "" " checked") "> New local repository</label></p>"
"<p class=\"check\"><label><input type=\"radio\" name=\"source\" value=\"remote\""
(if (=:= source "remote") " checked" "") "> Clone a remote Fossil repository</label></p>"
(text "remote_url" "Remote Fossil URL" (maps:get 'remote_url repo ""))
(select-interval (maps:get 'sync_interval repo 0))
"<h2>Git push</h2><p class=\"note\">One-way export with Fossil. The password or token is stored encrypted.</p>"
(check "git_enabled" "Enable Git push" (=:= (maps:get 'git_enabled repo 0) 1))
(text "git_url" "Git URL" (maps:get 'git_url repo ""))
(text "git_username" "Git username" (maps:get 'git_username repo ""))
(password "git_token" "Git password or token")
(check "git_auto_push" "Push after the repository changes" (=:= (maps:get 'git_auto_push repo 0) 1))
"<p class=\"actions\"><button type=\"submit\">Save</button></p></form>"
(if (> id 0)
(list (if (=:= source "remote")
(post-button req (lists:flatten (list "/admin/repos/" (integer_to_list id) "/sync")) "Sync now")
"")
(if (=:= (maps:get 'git_enabled repo 0) 1)
(post-button req (lists:flatten (list "/admin/repos/" (integer_to_list id) "/push")) "Push to Git")
"")
"<p><a href=\"/admin/repos/" (integer_to_list id) "/delete\">Delete repository</a></p>")
""))))
(defun org-form (req title action name description message)
(list "<h1 class=\"page\">" (nemoptera_ui:escape title) "</h1>"
(if (=:= "" message) "" (list "<p class=\"error\">" (nemoptera_ui:escape message) "</p>"))
"<p class=\"note\">The name is the URL prefix. Repositories in this organization are published at /"
(if (=:= "" name) "prefix" (nemoptera_ui:escape name))
"/repository-name.</p>"
"<form method=\"post\" action=\"" (nemoptera_ui:escape action) "\">"
(nemoptera_http:csrf-field req)
(text "name" "Name (URL prefix)" name)
(area "description" "Description" description)
(if (=:= "" name)
""
"<p class=\"note\">Changing the prefix changes the public path of every repository in this organization.</p>")
"<p class=\"actions\"><button type=\"submit\">Save</button></p></form>"))
(defun org-select (selected)
(let ((current (org-id-text selected)))
(list "<label for=\"organization_id\">Organization</label>"
"<select id=\"organization_id\" name=\"organization_id\">"
"<option value=\"\"" (if (=:= "" current) " selected" "") ">None</option>"
(lists:map (lambda (org) (org-option org current)) (nemoptera_org:list-all))
"</select>"
"<p class=\"note\">The organization supplies the URL prefix. None publishes the repository at /name.</p>")))
(defun org-option (org current)
(let ((id (integer_to_list (maps:get 'id org)))
(name (maps:get 'name org)))
(list "<option value=\"" id "\""
(if (=:= id current) " selected" "")
">" (nemoptera_ui:escape name) " — /" (nemoptera_ui:escape name) "/</option>")))
(defun org-id-text (selected)
(cond
((or (=:= selected 'none) (=:= selected 'undefined) (=:= selected 0)) "")
('true
(let ((text (nemoptera_text:to-str selected)))
(if (or (=:= text "") (=:= text "0") (=:= text "none")) "" text)))))
(defun settings-form (req site message)
(list "<h1 class=\"page\">Settings</h1>"
(if (=:= "" message) "" (list "<p class=\"error\">" (nemoptera_ui:escape message) "</p>"))
"<form method=\"post\" action=\"/admin/settings\">"
(nemoptera_http:csrf-field req)
(text "site_name" "Site name" (maps:get 'site_name site))
(text "site_url" "Site URL" (maps:get 'site_url site))
(text "site_tagline" "Tagline" (maps:get 'site_tagline site))
(area "site_description" "Description for uncategorized repositories" (maps:get 'site_description site))
(text "loose_title" "Heading for uncategorized repositories" (maps:get 'loose_title site))
(area "custom_shortcuts" "Custom shortcuts (one per line: Name | URL)" (maps:get 'custom_shortcuts site ""))
"<p class=\"note\">Format: <code>Name | URL</code> (e.g. <code>Blog | https://blog.example.com</code> or <code>Docs | /docs</code>). External links open in a new tab.</p>"
(password "password" "New administrator password")
(password "password2" "Repeat new password")
"<p class=\"actions\"><button type=\"submit\">Save</button></p></form>"))
(defun text (name label current)
(list "<label for=\"" name "\">" label "</label><input id=\"" name "\" name=\"" name
"\" type=\"text\" value=\"" (nemoptera_ui:escape current) "\">"))
(defun password (name label)
(list "<label for=\"" name "\">" label "</label><input id=\"" name "\" name=\"" name "\" type=\"password\" value=\"\">"))
(defun area (name label current)
(list "<label for=\"" name "\">" label "</label><textarea id=\"" name "\" name=\"" name "\">"
(nemoptera_ui:escape current) "</textarea>"))
(defun check (name label on?)
(list "<p class=\"check\"><label><input type=\"checkbox\" name=\"" name "\" value=\"1\""
(if on? " checked" "") "> " label "</label></p>"))
(defun select-interval (current)
(list "<label for=\"sync_interval\">Remote sync interval</label><select id=\"sync_interval\" name=\"sync_interval\">"
(lists:map
(lambda (choice)
(let (((tuple minutes label) choice))
(list "<option value=\"" (integer_to_list minutes) "\""
(if (=:= minutes (nemoptera_text:to-int current 0)) " selected" "")
">" label "</option>")))
(list (tuple 0 "Manual only")
(tuple 30 "Every 30 minutes")
(tuple 60 "Every hour")
(tuple 360 "Every 6 hours")
(tuple 1440 "Every day")))
"</select>"))
(defun post-button (req action label)
(list "<form class=\"inline\" method=\"post\" action=\"" (nemoptera_ui:escape action) "\">"
(nemoptera_http:csrf-field req)
"<button type=\"submit\">" (nemoptera_ui:escape label) "</button></form> "))
(defun repo-fields (req)
(maps:from_list
(list (tuple 'name (nemoptera_http:param req "name"))
(tuple 'description (nemoptera_http:param req "description"))
(tuple 'setup_username (nemoptera_http:param req "setup_username"))
(tuple 'setup_password (nemoptera_http:param req "setup_password"))
(tuple 'source (if (=:= (nemoptera_http:param req "source") "remote") "remote" "local"))
(tuple 'remote_url (nemoptera_http:param req "remote_url"))
(tuple 'sync_interval (nemoptera_text:to-int (nemoptera_http:param req "sync_interval") 0))
(tuple 'organization_id (org-value (nemoptera_http:param req "organization_id")))
(tuple 'git_enabled (if (nemoptera_http:checked? req "git_enabled") 1 0))
(tuple 'git_url (nemoptera_http:param req "git_url"))
(tuple 'git_username (nemoptera_http:param req "git_username"))
(tuple 'git_token (nemoptera_http:param req "git_token"))
(tuple 'git_auto_push (if (nemoptera_http:checked? req "git_auto_push") 1 0)))))
(defun blank-repo (org-param)
(maps:from_list
(list (tuple 'id 0) (tuple 'name "") (tuple 'description "") (tuple 'source "local")
(tuple 'remote_url "") (tuple 'sync_interval 0) (tuple 'setup_username "")
(tuple 'organization_id (org-value org-param)) (tuple 'org 'none)
(tuple 'git_enabled 0) (tuple 'git_url "") (tuple 'git_username "")
(tuple 'git_auto_push 0) (tuple 'url "") (tuple 'sync_status "") (tuple 'push_status ""))))
(defun org-value (text)
(let ((id (nemoptera_text:to-int text 0)))
(if (=:= id 0) 'none id)))
(defun blank (value fallback)
(if (nemoptera_text:blank? value) fallback (nemoptera_text:to-str value)))
(defun defaulting (value fallback)
(if (nemoptera_text:blank? value) fallback value))