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 310bf5f62783679ea5d20cc190f3e120c899ca006b62f74e54d1b9a67400d844:


;; 组织业务:组织是仓库的分类,同时也是公开 URL 的前缀。
(defmodule lamina_org_mgr
  (export all))

;;---- 查询 ----

(defun list-orgs ()
  (let ((result (catch
                  (lamina_db:q
                   "SELECT o.id,o.name,o.description,o.created_at,COUNT(r.id) FROM organizations o LEFT JOIN repositories r ON r.organization_id=o.id GROUP BY o.id,o.name,o.description,o.created_at ORDER BY o.created_at ASC;"))))
    (if (is_list result) result '())))

(defun get (org-id)
  (case (catch (lamina_db:q
                "SELECT id,name,description,created_at FROM organizations WHERE id=?;"
                (list org-id)))
    (`(,row) row)
    (_ 'undefined)))

(defun exists? (org-id)
  (case (get org-id)
    ('undefined 'false)
    (_ 'true)))

;;---- 创建 ----

(defun create (name description)
  (let ((name1 (to-str name))
        (description1 (to-str description)))
    (case (lamina_validate:check-slug name1)
      ('ok
       (case (available? name1 0)
         ('ok
          (case (catch
                 (lamina_db:q
                  "INSERT INTO organizations(name,description,created_at) VALUES(?,?,?);"
                  (list name1 description1 (lamina_setup:iso8601 (os:system_time 'second)))))
            ('ok 'ok)
            ('() 'ok)
            (`#(error ,reason) `#(error ,(format-db-error reason)))
            (_ `#(error "创建组织失败"))))
         (`#(error ,message) `#(error ,message))))
      (`#(error ,message) `#(error ,message))
      (_ `#(error "组织名称无效")))))

;; 修改组织名会改变公开 URL;仓库文件路径保持不变,repo_mgr 会在下次
;; 启动时按新的组织名重新注册路由。
(defun update-org (org-id name description)
  (let ((name1 (to-str name))
        (description1 (to-str description)))
    (case (lamina_validate:check-slug name1)
      ('ok (update-existing-org org-id name1 description1))
      (`#(error ,message) `#(error ,message))
      (_ `#(error "组织名称无效")))))

(defun update-existing-org (org-id name description)
  (case (get org-id)
    ('undefined `#(error "组织不存在"))
    (row
     (let ((old-name (to-str (lists:nth 2 row))))
       (case (available? name org-id)
         ('ok
          (case (catch (lamina_db:q
                        "UPDATE organizations SET name=?,description=? WHERE id=?;"
                        (list name description org-id)))
            ('ok (finish-org-rename old-name name description org-id))
            ('() (finish-org-rename old-name name description org-id))
            (`#(error ,reason) `#(error ,(format-db-error reason)))
            (_ `#(error "更新组织失败"))))
         (`#(error ,message) `#(error ,message)))))))

(defun finish-org-rename (old-name new-name description org-id)
  (case (restart-org-repos old-name new-name org-id)
    ('ok 'ok)
    (`#(error ,message)
     ;; 数据库名称和运行时路由必须保持一致;重启失败时恢复原名并尝试恢复旧路由。
     (lamina_db:q "UPDATE organizations SET name=? WHERE id=?;" (list old-name org-id))
     (catch (restart-org-repos new-name old-name org-id))
     `#(error ,message))))

(defun restart-org-repos (old-name new-name org-id)
  (let ((result (catch (lamina_db:q
                        "SELECT name,fossil_path FROM repositories WHERE organization_id=?;"
                        (list org-id)))))
    (if (is_list result)
        (let ((failures
               (lists:foldl
                (lambda (row acc)
                  (let ((slug (to-str (lists:nth 1 row)))
                        (path (to-str (lists:nth 2 row))))
                    ;; 先清掉旧的 registry key,再用新组织名前缀注册。
                    (catch (lamina_repo_mgr:stop-repo old-name slug))
                    (case (catch (lamina_repo_mgr:start-repo new-name slug path))
                      ('ok acc)
                      (other
                       (logger:error "organization rename could not restart ~s/~s: ~p"
                                     (list new-name slug other))
                       (cons slug acc)))))
                '() result)))
          (if (=:= '() failures)
              'ok
              `#(error ,(lists:flatten
                         (io_lib:format "组织改名后以下仓库服务启动失败: ~p"
                                        (list (lists:reverse failures)))))))
        `#(error "组织改名后仓库服务刷新失败"))))

;; 只有空组织允许删除,避免仓库 URL 突然失效。
(defun delete (org-id)
  (case (catch (lamina_db:q
                "SELECT COUNT(*) FROM repositories WHERE organization_id=?;"
                (list org-id)))
    (`((,count))
     (if (=:= 0 (to-int count))
         (case (catch (lamina_db:q "DELETE FROM organizations WHERE id=?;" (list org-id)))
           ('ok 'ok)
           ('() 'ok)
           (`#(error ,reason) `#(error ,(format-db-error reason)))
           (_ `#(error "删除组织失败")))
         `#(error "组织中仍有仓库,不能删除")))
    (_ `#(error "组织不存在"))))

;; 组织名不能与 project 分组中的仓库名相同,否则 /name/path 的路由
;; 语义会产生歧义;组织自身则由数据库 UNIQUE 约束保证唯一。
(defun available? (name exclude-id)
  (case (catch (lamina_db:q
                "SELECT COUNT(*) FROM organizations WHERE name=? AND id<>?;"
                (list name exclude-id)))
    (`((,org-count))
     (if (> (to-int org-count) 0)
         `#(error "该组织名称已存在")
         (case (catch (lamina_db:q
                       "SELECT COUNT(*) FROM repositories WHERE name=? AND organization_id IS NULL;"
                       (list name)))
           (`((,repo-count))
            (if (> (to-int repo-count) 0)
                `#(error "该名称已被 project 仓库占用")
                'ok))
           (_ `#(error "无法检查组织名称")))))
    (_ `#(error "无法检查组织名称"))))

(defun format-db-error (reason)
  (lists:flatten (io_lib:format "数据库错误: ~p" (list reason))))

(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)
    ((or (=:= 'undefined value) (=:= 'null value)) "")
    ('true (lists:flatten (io_lib:format "~p" (list 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.