;; 仓库业务：创建（本地）、编辑、删除、查询。
(defmodule lamina_repo_ctl
(export all))
(defun repo-dir ()
(lamina_config:get 'repo_dir "data/repos"))
(defun fossil-path (slug)
(fossil-path 'none slug))
(defun fossil-path (org-id slug)
(let ((base (case org-id
('none (repo-dir))
(_ (filename:join (repo-dir) (org-name org-id))))))
(filename:join base (concat-slug slug))))
(defun concat-slug (slug)
(lists:flatten (io_lib:format "~s.fossil" (list (to-str slug)))))
;;---- 创建（本地）----
(defun create-local (org-id slug display-name description setup-user setup-password)
(let ((slug1 (to-str slug))
(display-name1 (default-display display-name slug))
(description1 (to-str description))
(setup-user1 (to-str setup-user))
(setup-password1 (to-bin setup-password)))
(cond
((not (=:= 'ok (lamina_validate:check-slug slug1)))
(lamina_validate:check-slug slug1))
((=:= "" setup-user1) `#(error "Setup 用户名不能为空"))
((=:= #"" setup-password1) `#(error "Setup 密码不能为空"))
((not (=:= 'ok (valid-org? org-id)))
(valid-org? org-id))
('true
(let ((availability
(lamina_validate:check-availability
(case org-id ('none 'none) (_ (org-name org-id))) slug1)))
(case availability
('ok (create-local-files org-id slug1 display-name1 description1
setup-user1 setup-password1))
(`#(error ,message) `#(error ,message))
(_ `#(error "无法检查仓库路径"))))))))
;;---- 创建（远程导入）----
(defun create-remote (org-id slug display-name description remote-url sync-interval
setup-user setup-password)
(let ((slug1 (to-str slug))
(display-name1 (default-display display-name slug))
(description1 (to-str description))
(remote-url1 (to-str remote-url))
(setup-user1 (to-str setup-user))
(setup-password1 (to-bin setup-password))
(interval (normalize-sync-interval sync-interval)))
(cond
((not (=:= 'ok (lamina_validate:check-slug slug1)))
(lamina_validate:check-slug slug1))
((=:= "" remote-url1) `#(error "远程 Fossil 地址不能为空"))
((=:= "" setup-user1) `#(error "Setup 用户名不能为空"))
((=:= #"" setup-password1) `#(error "Setup 密码不能为空"))
((=:= 'error interval) `#(error "同步周期必须是正整数分钟"))
((not (=:= 'ok (valid-org? org-id))) (valid-org? org-id))
('true
(let ((availability
(lamina_validate:check-availability
(case org-id ('none 'none) (_ (org-name org-id))) slug1)))
(case availability
('ok (create-remote-files org-id slug1 display-name1 description1
remote-url1 interval setup-user1 setup-password1))
(`#(error ,message) `#(error ,message))
(_ `#(error "无法检查仓库路径"))))))))
(defun create-remote-files (org-id slug display-name description remote-url interval
setup-user setup-password)
(let ((result (create-remote-files-unsafe org-id slug display-name description
remote-url interval setup-user setup-password)))
(case result
('ok 'ok)
(`#(error ,message)
(delete-row-by-path (fossil-path org-id slug))
`#(error ,message))
(_
(delete-row-by-path (fossil-path org-id slug))
`#(error "远程仓库导入失败")))))
(defun create-remote-files-unsafe (org-id slug display-name description remote-url interval
setup-user setup-password)
(let ((path (fossil-path org-id slug))
(clone-url (remote-credential-url remote-url setup-user setup-password)))
(filelib:ensure_dir path)
(case (lamina_fossil_repo:clone clone-url path setup-user)
(`#(ok ,_)
(case (configure-repo org-id path slug description setup-user setup-password)
('ok (insert-remote-and-start org-id slug display-name description setup-user
setup-password path remote-url interval))
(`#(error ,reason) (cleanup-files path) `#(error ,(format-error "远程仓库配置失败" reason)))
(_ (cleanup-files path) `#(error "远程仓库配置失败"))))
(`#(error ,reason)
(cleanup-files path)
`#(error ,(format-error "fossil clone 失败" reason)))
(_
(cleanup-files path)
`#(error "fossil clone 失败")))))
(defun insert-remote-and-start (org-id slug display-name description setup-user setup-password
path remote-url interval)
(case (insert-remote-repo org-id slug display-name description setup-user setup-password
path remote-url interval)
('ok (start-created org-id slug path))
(`#(error ,reason)
(cleanup-files path)
`#(error ,(format-error "写远程仓库记录失败" reason)))
(_
(cleanup-files path)
`#(error "写远程仓库记录失败"))))
(defun insert-remote-repo (org-id slug display-name description setup-user setup-password
path remote-url interval)
(let ((now (lamina_setup:iso8601 (os:system_time 'second)))
(encrypted (encrypt-pw setup-password)))
(case org-id
('none
(case (catch
(lamina_db:q
"INSERT INTO repositories(name,organization_id,display_name,description,source,remote_url,sync_interval_minutes,setup_username,setup_password_enc,fossil_path,created_at,updated_at) VALUES(?,NULL,?,?, 'remote',?,?,?, ?,?,?,?);"
(list slug display-name description remote-url interval setup-user
encrypted path now now)))
('ok 'ok)
('() 'ok)
(`#(error ,reason) `#(error ,reason))
(_ `#(error "写库操作失败"))))
(_
(case (catch
(lamina_db:q
"INSERT INTO repositories(name,organization_id,display_name,description,source,remote_url,sync_interval_minutes,setup_username,setup_password_enc,fossil_path,created_at,updated_at) VALUES(?,?,?,?,'remote',?,?,?, ?,?,?,?);"
(list slug org-id display-name description remote-url interval setup-user
encrypted path now now)))
('ok 'ok)
('() 'ok)
(`#(error ,reason) `#(error ,reason))
(_ `#(error "写库操作失败")))))))
(defun create-local-files (org-id slug display-name description setup-user setup-password)
(let ((result (create-local-files-unsafe org-id slug display-name description
setup-user setup-password)))
;; 任何失败路径都再次清理 DB 记录，保证 init/配置/启动失败不留半成品。
(case result
('ok 'ok)
(`#(error ,message)
(delete-row-by-path (fossil-path org-id slug))
`#(error ,message))
(_
(delete-row-by-path (fossil-path org-id slug))
`#(error "创建仓库失败")))))
(defun create-local-files-unsafe (org-id slug display-name description setup-user setup-password)
(let ((path (fossil-path org-id slug)))
(filelib:ensure_dir path)
(case (lamina_fossil_repo:init path setup-user)
(`#(ok ,_) (configure-and-insert org-id slug display-name description
setup-user setup-password path))
(`#(error ,reason)
(cleanup-files path)
`#(error ,(format-error "fossil init 失败" reason)))
(_
(cleanup-files path)
`#(error "fossil init 失败")))))
(defun configure-and-insert (org-id slug display-name description setup-user setup-password path)
(case (configure-repo org-id path slug description setup-user setup-password)
('ok (insert-and-start org-id slug display-name description setup-user setup-password path))
(`#(error ,reason)
(cleanup-files path)
`#(error ,(format-error "仓库配置失败" reason)))
(_
(cleanup-files path)
`#(error "仓库配置失败"))))
(defun insert-and-start (org-id slug display-name description setup-user setup-password path)
(case (insert-repo org-id slug display-name description setup-user setup-password path)
('ok (start-created org-id slug path))
(`#(error ,reason)
(cleanup-files path)
`#(error ,(format-error "写库失败" reason)))
(_
(cleanup-files path)
`#(error "写库失败"))))
(defun start-created (org-id slug path)
(let ((org-name (case org-id
('none 'none)
(_ (org-name org-id)))))
(lamina_sup:ensure-runtime)
(case (catch (lamina_repo_mgr:start-repo org-name slug path))
('ok 'ok)
(`#(error ,reason) (fail-start path reason))
(`#(EXIT ,reason) (fail-start path reason))
(other (fail-start path other)))))
(defun fail-start (path reason)
(delete-row-by-path path)
(cleanup-files path)
`#(error ,(start-error-text reason)))
(defun start-error-text (reason)
(let ((text (lists:flatten (io_lib:format "~p" (list reason)))))
(cond
((/= 'nomatch (string:find text "noproc"))
"仓库服务未就绪。若刚完成安装，请重启服务后再创建仓库。")
((/= 'nomatch (string:find text "timeout"))
"仓库进程启动超时")
('true (lamina_fossil:error-message reason)))))
(defun configure-repo (org-id path slug description setup-user setup-password)
(case (lamina_fossil_repo:set-user-pw path setup-user setup-password)
(`#(ok ,_)
(case (maybe-apply-skin path org-id slug description)
('ok
(case (lamina_fossil_repo:set-description path slug description)
(`#(ok ,_) 'ok)
(`#(error ,reason) `#(error ,reason))
(_ `#(error "仓库描述操作失败"))))
(`#(error ,reason) `#(error ,reason))))
(`#(error ,reason) `#(error ,reason))
(_ `#(error "仓库配置操作失败"))))
;; 每次创建时按当前站点设置生成并导入皮肤；配置文件只在导入期间存在。
(defun maybe-apply-skin (path org-id slug)
(maybe-apply-skin path org-id slug ""))
(defun maybe-apply-skin (path org-id slug description)
(let ((org-name (case org-id
('none "")
(_ (org-name org-id)))))
(case (catch (lamina_fossil_skin:render org-name slug description))
(`#(ok ,skin-path)
(let ((result (catch (lamina_fossil_repo:apply-skin path skin-path))))
(catch (file:delete skin-path))
(case result
(`#(ok ,_) (after-skin path))
(`#(error ,reason) `#(error ,reason))
(`#(EXIT ,reason) `#(error ,reason))
(_ `#(error "皮肤导入失败")))))
(`#(error ,reason) `#(error ,reason))
(`#(EXIT ,reason) `#(error ,reason))
(_ `#(error "皮肤生成失败")))))
(defun after-skin (path)
(case (lamina_fossil_repo:configure-web path)
(`#(ok ,_) 'ok)
(`#(error ,reason) `#(error ,reason))
(_ `#(error "仓库首页配置失败"))))
(defun insert-repo (org-id slug display-name description setup-user setup-password path)
(let ((now (lamina_setup:iso8601 (os:system_time 'second)))
(encrypted (encrypt-pw setup-password)))
(case org-id
('none
(case (catch
(lamina_db:q
"INSERT INTO repositories(name,organization_id,display_name,description,source,setup_username,setup_password_enc,fossil_path,created_at,updated_at) VALUES(?,NULL,?,?, 'local',?,?,?, ?,?);"
(list slug display-name description setup-user encrypted path now now)))
('ok 'ok)
('() 'ok)
(`#(error ,reason) `#(error ,reason))
(_ `#(error "写库操作失败"))))
(_
(case (catch
(lamina_db:q
"INSERT INTO repositories(name,organization_id,display_name,description,source,setup_username,setup_password_enc,fossil_path,created_at,updated_at) VALUES(?,?,?,?, 'local',?,?,?, ?,?);"
(list slug org-id display-name description setup-user encrypted path now now)))
('ok 'ok)
('() 'ok)
(`#(error ,reason) `#(error ,reason))
(_ `#(error "写库操作失败")))))))
;;---- 编辑 ----
;; slug 从数据库读取，调用者不能提交或修改 URL 段。
(defun update-repo (repo-id display-name description setup-user setup-password)
(case (catch (lamina_db:q
"SELECT name,fossil_path,setup_username FROM repositories WHERE id=?;"
(list repo-id)))
(`((,name ,path-bin ,old-user))
(update-existing repo-id (to-str name) (to-str path-bin) (to-str old-user)
display-name description setup-user setup-password))
(_ `#(error "仓库不存在"))))
;; M6 编辑页使用的扩展更新入口：保留 M4 的兼容 API，同时更新远程同步与 Git 设置。
(defun update-repo-settings (repo-id display-name description setup-user setup-password
remote-url sync-interval git-enabled git-url git-username
git-token git-auto-push)
(case (get-repo-detail repo-id)
('undefined `#(error "仓库不存在"))
(detail
(let* ((source (maps:get 'source detail "local"))
(remote-url1 (to-str remote-url))
(interval (normalize-sync-interval sync-interval)))
(cond
((and (=:= "remote" source) (=:= "" remote-url1))
`#(error "远程 Fossil 地址不能为空"))
((=:= 'error interval) `#(error "同步周期必须是正整数分钟"))
('true
(case (update-repo repo-id display-name description setup-user setup-password)
('ok (persist-remote-git repo-id source remote-url1 interval git-enabled
git-url git-username git-token git-auto-push))
(error error)
(_ `#(error "更新仓库失败")))))))))
(defun persist-remote-git (repo-id source remote-url interval git-enabled git-url
git-username git-token git-auto-push)
(let ((token (to-bin git-token))
(enabled (flag-value git-enabled))
(auto (flag-value git-auto-push)))
(let ((sql-result
(if (=:= #"" token)
(lamina_db:q
"UPDATE repositories SET remote_url=?,sync_interval_minutes=?,git_enabled=?,git_url=?,git_username=?,git_auto_push=?,updated_at=? WHERE id=?;"
(list (if (=:= "remote" source) remote-url 'null)
(if (=:= "remote" source) interval 'null)
enabled (to-str git-url) (to-str git-username) auto
(lamina_setup:iso8601 (os:system_time 'second)) repo-id))
(lamina_db:q
"UPDATE repositories SET remote_url=?,sync_interval_minutes=?,git_enabled=?,git_url=?,git_username=?,git_token_enc=?,git_auto_push=?,updated_at=? WHERE id=?;"
(list (if (=:= "remote" source) remote-url 'null)
(if (=:= "remote" source) interval 'null)
enabled (to-str git-url) (to-str git-username)
(encrypt-token token) auto
(lamina_setup:iso8601 (os:system_time 'second)) repo-id)))))
(case sql-result
('ok 'ok)
('() 'ok)
(`#(error ,reason) `#(error ,(format-error "保存同步/Git 设置失败" reason)))
(_ `#(error "保存同步/Git 设置失败"))))))
(defun get-repo-detail (repo-id)
(case (catch
(lamina_db:q
"SELECT r.id,r.name,r.display_name,r.description,r.source,COALESCE(r.remote_url,''),COALESCE(r.sync_interval_minutes,0),r.setup_username,r.git_enabled,COALESCE(r.git_url,''),COALESCE(r.git_username,''),r.git_auto_push,COALESCE(r.last_timeline_at,''),COALESCE(r.last_synced_at,''),COALESCE(r.last_sync_status,''),COALESCE(r.last_pushed_at,''),COALESCE(r.last_push_status,''),r.fossil_path,COALESCE(r.repo_status,'up'),COALESCE(o.name,'') FROM repositories r LEFT JOIN organizations o ON o.id=r.organization_id WHERE r.id=?;"
(list repo-id)))
(`((,id ,name ,display ,description ,source ,remote-url ,interval ,username
,git-enabled ,git-url ,git-username ,git-auto ,last-timeline ,last-synced ,sync-status
,last-pushed ,push-status ,path ,repo-status ,org-name))
(maps:from_list
(list (tuple 'id id) (tuple 'name (to-str name))
(tuple 'display_name (to-str display))
(tuple 'description (to-str description))
(tuple 'source (to-str source)) (tuple 'remote_url (to-str remote-url))
(tuple 'sync_interval (to-int interval)) (tuple 'setup_username (to-str username))
(tuple 'git_enabled (to-int git-enabled)) (tuple 'git_url (to-str git-url))
(tuple 'git_username (to-str git-username)) (tuple 'git_auto_push (to-int git-auto))
(tuple 'last_timeline_at (to-str last-timeline))
(tuple 'last_synced_at (to-str last-synced))
(tuple 'last_sync_status (to-str sync-status))
(tuple 'last_pushed_at (to-str last-pushed))
(tuple 'last_push_status (to-str push-status))
(tuple 'fossil_path (to-str path))
(tuple 'repo_status (to-str repo-status))
(tuple 'org_name (to-str org-name)))))
(_ 'undefined)))
(defun flag-value (value)
(case value
('true 1)
('false 0)
(#"on" 1)
("on" 1)
(1 1)
(#"1" 1)
("1" 1)
(_ 0)))
(defun to-int (value)
(cond
((is_integer value) value)
((is_binary value) (case (catch (binary_to_integer value)) (`#(EXIT ,_) 0) (i i)))
((is_list value) (case (catch (list_to_integer value)) (`#(EXIT ,_) 0) (i i)))
('true 0)))
(defun encrypt-token (token)
(term_to_binary (lamina_crypto:encrypt token (lamina_auth:secret-key))))
(defun update-existing (repo-id slug path old-user display-name description setup-user setup-password)
(let ((password (to-bin setup-password))
(username (if (=:= "" (to-str setup-user)) old-user (to-str setup-user))))
(cond
((=:= "" username) `#(error "Setup 用户名不能为空"))
((and (=:= #"" password) (not (=:= username old-user)))
`#(error "修改 Setup 用户名时必须填写新密码"))
('true
(case (if (=:= #"" password)
'ok
(lamina_fossil_repo:set-user-pw path username password))
('ok (update-fossil-description repo-id slug path old-user username
display-name description password))
(`#(ok ,_) (update-fossil-description repo-id slug path old-user username
display-name description password))
(`#(error ,reason) `#(error ,(format-error "更新 Setup 凭据失败" reason)))
(_ `#(error "更新仓库操作失败")))))))
(defun update-fossil-description (repo-id slug path _old-user username
display-name description password)
(case (lamina_fossil_repo:set-description path slug description)
(`#(ok ,_)
(case (maybe-apply-skin path (org-id-of repo-id) slug description)
('ok (persist-update repo-id username display-name description password))
(`#(error ,reason) `#(error ,(format-error "更新仓库皮肤失败" reason)))
(_ (persist-update repo-id username display-name description password))))
(`#(error ,reason) `#(error ,(format-error "更新仓库描述失败" reason)))
(_ `#(error "更新仓库描述失败"))))
(defun persist-update (repo-id username display-name description password)
(let ((now (lamina_setup:iso8601 (os:system_time 'second))))
(case (if (=:= #"" password)
(lamina_db:q
"UPDATE repositories SET display_name=?,description=?,setup_username=?,updated_at=? WHERE id=?;"
(list display-name description username now repo-id))
(lamina_db:q
"UPDATE repositories SET display_name=?,description=?,setup_username=?,setup_password_enc=?,updated_at=? WHERE id=?;"
(list display-name description username (encrypt-pw password) now repo-id)))
('ok 'ok)
('() 'ok)
(`#(error ,reason) `#(error ,(format-error "更新失败" reason)))
(_ `#(error "更新数据库失败")))))
;;---- 删除 ----
(defun delete (repo-id)
(case (catch (lamina_db:q "SELECT r.name,r.fossil_path,COALESCE(o.name,'') FROM repositories r LEFT JOIN organizations o ON o.id=r.organization_id WHERE r.id=?;" (list repo-id)))
(`((,name ,path-bin ,org-bin))
(let ((slug (to-str name))
(path (to-str path-bin))
(org-name (to-str org-bin)))
(case (catch (if (=:= "" org-name)
(lamina_repo_mgr:stop-repo slug)
(lamina_repo_mgr:stop-repo org-name slug)))
(`#(EXIT ,_) 'ok)
(_ 'ok))
(case (catch (lamina_db:q "DELETE FROM repositories WHERE id=?;" (list repo-id)))
('ok
(cleanup-files path)
'ok)
('()
(cleanup-files path)
'ok)
(`#(error ,reason) `#(error ,(format-error "删除失败" reason)))
(_ `#(error "删除数据库记录失败")))))
(_ `#(error "仓库不存在"))))
;;---- 查询 ----
(defun list-repos ()
(let ((result (catch (lamina_db:q
"SELECT r.id,r.name,r.display_name,r.description,r.source,COALESCE(o.name,''),r.last_timeline_at,r.fossil_path,COALESCE(r.last_sync_status,''),COALESCE(r.last_push_status,''),COALESCE(r.git_enabled,0),COALESCE(r.repo_status,'up') FROM repositories r LEFT JOIN organizations o ON o.id=r.organization_id ORDER BY r.updated_at DESC;"))))
(if (is_list result) result '())))
(defun get-repo (repo-id)
(case (catch (lamina_db:q
"SELECT r.id,r.name,r.display_name,r.description,r.source,COALESCE(o.name,''),r.last_timeline_at,r.fossil_path FROM repositories r LEFT JOIN organizations o ON o.id=r.organization_id WHERE r.id=?;"
(list repo-id)))
(`(,row) row)
(_ 'undefined)))
;;---- helpers ----
(defun org-id-of (repo-id)
(case (catch (lamina_db:q "SELECT organization_id FROM repositories WHERE id=?;"
(list repo-id)))
(`((,id))
(if (or (=:= id 'undefined) (=:= id 'null) (=:= id 'nil))
'none
id))
(_ 'none)))
(defun org-name (org-id)
(case (catch (lamina_db:q "SELECT name FROM organizations WHERE id=?;" (list org-id)))
(`((,name)) (to-str name))
(_ 'none)))
(defun valid-org? (org-id)
(case org-id
('none 'ok)
(id (if (=:= 'true (lamina_org_mgr:exists? id))
'ok
`#(error "组织不存在")))
(_ `#(error "组织选择无效"))))
(defun normalize-sync-interval (value)
(let ((s (to-str value)))
(if (=:= "" s)
60
(case (catch (list_to_integer s))
(`#(EXIT ,_) 'error)
(minutes (if (and (> minutes 0) (=< minutes 525600)) minutes 'error))))))
;; HTTP(S) 远程源用表单中的 Setup 凭据访问；file:// 等本地测试源保持原样。
(defun remote-credential-url (url username password)
(let ((s (to-str url)))
(if (or (lists:prefix "http://" s) (lists:prefix "https://" s))
(let* ((scheme-len (if (lists:prefix "https://" s) 8 7))
(scheme (lists:sublist s scheme-len))
(rest (lists:nthtail scheme-len s)))
(case (string:split rest "/" 'leading)
(`(,authority ,path)
(if (lists:member 64 authority)
s
(lists:flatten
(list scheme (url-encode username) ":" (url-encode password) "@"
authority "/" path))))
(_ s)))
s)))
(defun url-encode (value)
(url-encode (to-str value) '()))
(defun url-encode (chars acc)
(case chars
('() (lists:flatten (lists:reverse acc)))
(`(,char . ,rest)
(if (url-safe? char)
(url-encode rest (cons (list char) acc))
(url-encode rest (cons (percent-char char) acc))))))
(defun url-safe? (char)
(or (and (>= char 48) (=< char 57))
(and (>= char 65) (=< char 90))
(and (>= char 97) (=< char 122))
(lists:member char (list 45 46 95 126))))
(defun percent-char (char)
(let ((hex "0123456789ABCDEF"))
(list 37 (lists:nth (+ 1 (div char 16)) hex)
(lists:nth (+ 1 (rem char 16)) hex))))
(defun encrypt-pw (password)
;; SQLite BLOB 存 term_to_binary，避免直接把 {IV,CT,TAG} 当成参数。
(term_to_binary (lamina_crypto:encrypt (to-bin password) (lamina_auth:secret-key))))
(defun cleanup-files (path)
(lists:foreach
(lambda (suffix) (catch (file:delete (lists:append (list path suffix)))))
(list "" "-wal" "-shm" "-journal")))
(defun delete-row-by-path (path)
(catch (lamina_db:q "DELETE FROM repositories WHERE fossil_path=?;" (list path))))
(defun default-display (display slug)
(let ((s (to-str display)))
(if (=:= "" s) (to-str slug) s)))
(defun format-error (prefix reason)
(lists:flatten (io_lib:format "~s: ~s" (list prefix (reason-text reason)))))
(defun reason-text (reason)
(case reason
(`#(exit_status ,_code ,_out) (lamina_fossil:error-message reason))
(`#(enoent ,_) (lamina_fossil:error-message reason))
(`#(eacces ,_) (lamina_fossil:error-message reason))
('timeout (lamina_fossil:error-message reason))
(_ (lists:flatten (io_lib:format "~p" (list reason))))))
(defun to-bin (value)
(cond
((is_binary value) value)
((is_list value) (list_to_binary value))
('true (list_to_binary (to-str 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))))))