Fosi Fossil Service
Small teams. Open source. Built on Fossil.

CaaS / Lamina

Unified Management for Fossil Repositories

Public | Owner: CaaS | Default branch: trunk | Last update: 2026-10-25 00:41

Artifact d8a16ad20c08dd0bd325010f79d3cb0a1b2c178fbcbdfe0d7d768fd26a1e306b:


;; 后台管理 Library:每个仓库一条文档,并填写导航名称。
(defmodule lamina_library_admin
  (export all))

(defun show (req)
  (page req (param req "repo_id") ""))

(defun save (req)
  (if (not (lamina_admin_pages:csrf-valid? req))
      (lamina_admin_pages:html 403 "CSRF token 无效")
      (let ((action (param req "action")))
        (case (run action req)
          ('ok (page req "" (done-message action)))
          (`#(error ,message) (page req (param req "repo_id") message))
          (_ (page req (param req "repo_id") "Could not update the Library."))))))

(defun run (action req)
  (case action
    ("add" (lamina_library:add (param req "repo_id") (param req "branch") (param req "name")))
    ("save" (lamina_library:update (param req "old_name") (param req "name") (param req "branch")))
    ("remove" (lamina_library:remove (param req "name")))
    ("up" (lamina_library:move (param req "name") "up"))
    ("down" (lamina_library:move (param req "name") "down"))
    (_ `#(error "Unknown action."))))

(defun done-message (action)
  (case action
    ("remove" "Library entry removed.")
    ("up" "Library order saved.")
    ("down" "Library order saved.")
    (_ "Library saved.")))

(defun page (req picked message)
  (let ((repos (lamina_docs:list-repos))
        (entries (lamina_library:entries)))
    (lamina_admin_pages:html
     200
     (lamina_admin_pages:layout
      (lamina_admin_pages:current-username req)
      "Library"
      (lamina_docs:encode-html (body req repos entries picked message))))))

(defun body (req repos entries picked message)
  (let ((available (available-repos repos))
        (public (lists:flatten (list (lamina_site_mgr:site-url) "/library"))))
    (list
     "<div class=\"settings-page library-page\"><div class=\"topline\"><div><h1>Library</h1>"
     "<p class=\"lede\">Add a repository on the left. Entries already in the Library stay in the list on the right.</p>"
     "<p class=\"hint\">Public page: <a href=\"/library\">" (lamina_ui:escape public) "</a></p></div></div>"
     (if (=:= "" message) "" (list "<div class=\"notice\">" (lamina_ui:escape message) "</div>"))
     "<div class=\"library-split\">"
     (add-html req available picked)
     (entries-html req repos entries)
     "</div></div>")))

(defun entries-html (req repos entries)
  (list "<section class=\"library-list\"><div class=\"library-head\"><h2>Entries</h2>"
        "<span class=\"hint\">" (count-label entries) "</span></div>"
        (if (=:= '() entries)
            "<div class=\"tablebox\"><p class=\"hint library-empty\">No repositories yet.</p></div>"
            (list "<div class=\"tablebox\"><table class=\"library-table\"><thead><tr>"
                  "<th>Navigation name</th><th>Repository</th><th>Address</th><th>Branch</th><th>Order</th><th></th>"
                  "</tr></thead><tbody>"
                  (entry-rows repos entries entries 0)
                  "</tbody></table></div>"
                  (entry-forms req entries 0)))
        "</section>"))

(defun count-label (entries)
  (let ((n (length entries)))
    (if (=:= 1 n)
        "1 entry"
        (lists:flatten (list (integer_to_list n) " entries")))))

(defun entry-rows (repos items entries index)
  (case items
    ('() '())
    (`(,item . ,rest)
     (cons (entry-row repos item entries index)
           (entry-rows repos rest entries (+ index 1))))))

(defun entry-row (repos item entries index)
  (let ((name (maps:get 'name item))
        (repo (find-listed repos (maps:get 'repo_id item)))
        (save-id (form-id "save" index)))
    (list "<tr>"
          (if (=:= 'none repo)
              (list "<td class=\"library-name library-miss\">Missing repository</td>"
                    "<td class=\"library-repo\">" (lamina_ui:escape (maps:get 'repo_id item)) "</td>"
                    "<td class=\"library-address\"></td><td class=\"library-branch\"></td><td class=\"library-order\"></td>")
              (list "<td class=\"library-name\"><input form=\"" save-id "\" name=\"name\" value=\"" (lamina_ui:escape name) "\"></td>"
                    "<td class=\"library-repo\"><a class=\"library-repo\" href=\"" (lamina_ui:escape (repo-href repo)) "\">"
                    (lamina_ui:escape (lamina_docs:repo-label repo)) "</a></td>"
                    "<td class=\"library-address\">" (repo-facts repo (maps:get 'branch item)) "</td>"
                    "<td class=\"library-branch\">" (branch-control repo (maps:get 'branch item) save-id) "</td>"
                    "<td class=\"library-order\"><span class=\"library-ops\">"
                    (order-button "up" index "Up" (not (first? item entries)))
                    (order-button "down" index "Down" (not (last? item entries)))
                    "</span></td>"))
          "<td class=\"library-actions\"><span class=\"library-ops\">"
          (if (=:= 'none repo)
              ""
              (list "<button class=\"btn\" type=\"submit\" form=\"" save-id "\">Save</button>"))
          "<button class=\"btn secondary\" type=\"submit\" form=\"" (form-id "remove" index) "\">Remove</button>"
          "</span></td></tr>")))

(defun entry-forms (req entries index)
  (case entries
    ('() '())
    (`(,item . ,rest)
     (cons (entry-form-set req item index)
           (entry-forms req rest (+ index 1))))))

(defun entry-form-set (req item index)
  (let ((name (maps:get 'name item)))
    (list (hidden-form req (form-id "save" index) "save" name)
          (hidden-form req (form-id "up" index) "up" name)
          (hidden-form req (form-id "down" index) "down" name)
          (hidden-form req (form-id "remove" index) "remove" name))))

(defun hidden-form (req id action name)
  (list "<form id=\"" id "\" method=\"POST\" action=\"/admin/library\">"
        (lamina_admin_pages:csrf-field req)
        "<input type=\"hidden\" name=\"action\" value=\"" action "\">"
        (if (=:= "save" action)
            (list "<input type=\"hidden\" name=\"old_name\" value=\"" (lamina_ui:escape name) "\">")
            (list "<input type=\"hidden\" name=\"name\" value=\"" (lamina_ui:escape name) "\">"))
        "</form>"))

(defun form-id (action index)
  (lists:flatten (list "lib-" action "-" (integer_to_list index))))

(defun order-button (action index label show)
  (if show
      (list "<button class=\"btn secondary\" type=\"submit\" form=\"" (form-id action index) "\">" label "</button>")
      ""))

(defun repo-href (repo)
  (lamina_site_mgr:repo-base-url (maps:get 'org repo "") (maps:get 'name repo)))

(defun repo-facts (repo branch)
  (let ((href (repo-href repo))
        (path (maps:get 'path repo)))
    (list "<div class=\"library-meta\"><a class=\"library-addr\" title=\"" (lamina_ui:escape href) "\" href=\"" (lamina_ui:escape href) "\">"
          (lamina_ui:escape href) "</a><span class=\"library-facts\">"
          (fact "Size" (lamina_docs:format-bytes (lamina_docs:file-size path)))
          (fact "Articles" (article-count path branch))
          (fact "Timeline" (integer_to_list (lamina_docs:timeline-count path)))
          "</span></div>")))

(defun fact (label value)
  (list "<span><b>" label "</b>" (lamina_ui:escape value) "</span>"))

(defun article-count (path branch)
  (case (lamina_docs:list-files path branch)
    (`#(ok ,files) (integer_to_list (maps:get 'articles (lamina_docs:doc-counts files) 0)))
    (_ "-")))

(defun add-html (req available picked)
  (let ((repo (find-listed available picked)))
    (list "<section class=\"settings-card library-add\"><h2>Add an entry</h2>"
          (if (=:= '() available)
              "<p class=\"hint\">Every repository is already used by Docs or Library.</p>"
              (list "<form method=\"GET\" action=\"/admin/library\">"
                    "<label>Repository<select name=\"repo_id\" onchange=\"this.form.submit()\">"
                    "<option value=\"\">Select a repository</option>"
                    (lists:map (lambda (item) (repo-option item picked)) available)
                    "</select></label></form>"
                    (if (=:= 'none repo)
                        "<p class=\"hint\">Choose a repository to load its branches.</p>"
                        (list "<form method=\"POST\" action=\"/admin/library\">"
                              (lamina_admin_pages:csrf-field req)
                              "<input type=\"hidden\" name=\"action\" value=\"add\">"
                              "<input type=\"hidden\" name=\"repo_id\" value=\""
                              (lamina_ui:escape (integer_to_list (maps:get 'id repo))) "\">"
                              "<label>Navigation name<input name=\"name\" value=\"\"></label>"
                              "<label>Branch" (branch-control repo "trunk" "") "</label>"
                              "<div class=\"settings-actions\"><button class=\"btn\" type=\"submit\">Add</button></div>"
                              "</form>"))))
          "</section>")))

(defun branch-control (repo selected form-id)
  (let ((names (branch-names repo selected))
        (form (if (=:= "" form-id) "" (list " form=\"" form-id "\""))))
    (if (=:= '() names)
        (list "<input name=\"branch\"" form " value=\"" (lamina_ui:escape selected) "\">")
        (list "<select name=\"branch\"" form ">"
              (lists:map (lambda (name) (branch-option name selected)) names)
              "</select>"))))

(defun branch-names (repo selected)
  (let ((names (lamina_docs:branches (maps:get 'path repo))))
    (if (lists:member selected names)
        names
        (if (=:= "" selected) names (lists:append names (list selected))))))

(defun branch-option (name selected)
  (list "<option" (if (=:= name selected) " selected" "") ">" (lamina_ui:escape name) "</option>"))

(defun repo-option (repo picked)
  (let ((id (integer_to_list (maps:get 'id repo))))
    (list "<option value=\"" id "\""
          (if (=:= id picked) " selected" "")
          ">" (lamina_ui:escape (lamina_docs:repo-label repo)) "</option>")))

(defun available-repos (repos)
  (lists:filter
   (lambda (repo) (not (lamina_library:claims-repo? (maps:get 'id repo))))
   repos))

(defun find-listed (repos id)
  (let ((wanted (lamina_library:normalize-id id)))
    (case (lists:search
           (lambda (repo) (=:= wanted (lamina_library:normalize-id (maps:get 'id repo))))
           repos)
      (`#(value ,repo) repo)
      (_ 'none))))

(defun first? (item entries)
  (=:= (maps:get 'name item) (maps:get 'name (hd entries))))

(defun last? (item entries)
  (=:= (maps:get 'name item) (maps:get 'name (lists:last entries))))

(defun param (req name)
  (let ((params (maps:get 'params req #M()))
        (key (list_to_binary name)))
    (case (maps:find key params)
      (`#(ok ,value) (lamina_ui:to-str value))
      (_
       (case (lists:keyfind key 1 (cowboy_req:parse_qs req))
         (`#(,_ ,value) (lamina_ui:to-str value))
         (_ ""))))))

Clone

You can clone this repository with the following command:

fossil clone https://fosi.dev/CaaS/Lamina

Contribute

The best way to contribute is through e-mail. See the project documentation for more details.