;; 仓库进程管理器：批量启动仓库、处理 fossil server 退出并有限重试。
(defmodule lamina_repo_mgr
(behaviour gen_server)
(export all))
(defun max-restarts () 3)
(defun repo-key (org-name slug) (tuple org-name slug))
(defun start-link ()
(gen_server:start_link #(local lamina_repo_mgr)
'lamina_repo_mgr 'none (list)))
(defun start_link () (start-link))
(defun start-repo (slug fossil-path)
(start-repo 'none slug fossil-path))
(defun start-repo (org-name slug fossil-path)
(gen_server:call 'lamina_repo_mgr
(tuple 'start (normalize-org org-name) slug fossil-path) 30000))
(defun stop-repo (slug)
(stop-repo 'none slug))
(defun stop-repo (org-name slug)
(gen_server:call 'lamina_repo_mgr
(tuple 'stop (normalize-org org-name) slug) 30000))
(defun status (slug)
(status 'none slug))
(defun status (org-name slug)
(gen_server:call 'lamina_repo_mgr
(tuple 'status (normalize-org org-name) slug) 5000))
(defun init (_)
(process_flag 'trap_exit 'true)
(erlang:send_after 0 (self) 'start-all)
`#(ok #M()))
(defun handle_call (msg _from state)
(case msg
(`#(start ,org-name ,slug ,fossil-path)
(let ((key (repo-key org-name slug)))
(case (maps:find key state)
(`#(ok #(,pid ,_path ,_failures))
(if (and (is_pid pid) (is_process_alive pid))
(tuple 'reply 'ok state)
(start-and-reply org-name slug fossil-path state)))
('error (start-and-reply org-name slug fossil-path state)))))
(`#(stop ,org-name ,slug)
(let ((key (repo-key org-name slug)))
(case (maps:find key state)
(`#(ok #(,pid ,_path ,_failures))
(if (is_pid pid) (catch (gen_server:stop pid 'normal 3000)) 'ok)
(lamina_repo_registry:delete org-name slug)
(tuple 'reply 'ok (maps:remove key state)))
('error (tuple 'reply 'ok state)))))
(`#(status ,org-name ,slug)
(let ((key (repo-key org-name slug)))
(case (maps:find key state)
(`#(ok #(,pid ,_path ,failures))
(if (and (is_pid pid) (is_process_alive pid))
`#(reply #(ok up ,pid) ,state)
`#(reply #(ok down ,failures) ,state)))
('error (tuple 'reply 'undefined state)))))
(_ `#(reply 'unknown ,state))))
(defun handle_info (msg state)
(case msg
('start-all
(start-all state))
(`#(EXIT ,pid ,reason)
(case (find-key-by-pid pid state)
('none `#(noreply ,state))
(key
(let (((tuple org-name slug) key))
(let (((tuple _old-pid fossil-path failures) (maps:get key state)))
(logger:warning "repo_server ~s/~s exited: ~p"
(list org-name slug reason))
(let ((state1 (maps:put key (tuple 'undefined fossil-path failures) state)))
(schedule-restart org-name slug fossil-path failures state1)))))))
(`#(restart ,org-name ,slug ,fossil-path ,failures)
(case (start-child org-name slug fossil-path)
(`#(ok ,pid)
(set-repo-status org-name slug "up")
`#(noreply ,(maps:put (repo-key org-name slug)
(tuple pid fossil-path failures) state)))
(`#(error ,reason)
(logger:error "repo_server ~s/~s restart failed: ~p"
(list org-name slug reason))
(schedule-restart org-name slug fossil-path failures state))))
(_ `#(noreply ,state))))
(defun start-all (state)
(case (catch (lamina_db:q
"SELECT COALESCE(o.name,''), r.name, r.fossil_path FROM repositories r LEFT JOIN organizations o ON o.id=r.organization_id;"))
(`((,org-name ,name ,path) . ,rest)
(let ((state1 (start-one (normalize-org org-name) (to-str name) (to-str path) state)))
(start-rows rest state1)))
(_ `#(noreply ,state))))
(defun start-rows (rows state)
(case rows
('() `#(noreply ,state))
(`((,org-name ,name ,path) . ,rest)
(start-rows rest
(start-one (normalize-org org-name) (to-str name) (to-str path) state)))))
(defun start-one (org-name slug path state)
(let ((key (repo-key org-name slug)))
(case (maps:is_key key state)
('true state)
('false
(case (start-child org-name slug (to-str path))
(`#(ok ,pid)
(set-repo-status org-name slug "up")
(maps:put key (tuple pid path 0) state))
(`#(error ,reason)
(logger:error "repo_server ~s/~s initial start failed: ~p"
(list org-name slug reason))
(erlang:send_after 1000 (self)
(tuple 'restart org-name slug path 1))
(set-repo-status org-name slug "starting")
(maps:put key (tuple 'undefined path 1) state)))))))
(defun start-and-reply (org-name slug path state)
(case (start-child org-name slug path)
(`#(ok ,pid)
(set-repo-status org-name slug "up")
(tuple 'reply 'ok
(maps:put (repo-key org-name slug) (tuple pid path 0) state)))
(`#(error ,reason)
(set-repo-status org-name slug "down")
`#(reply #(error ,reason) ,state))))
(defun schedule-restart (org-name slug path failures state)
(let ((next (+ failures 1)))
(if (=< next (max-restarts))
(progn
(set-repo-status org-name slug "starting")
(erlang:send_after (* 1000 next) (self)
(tuple 'restart org-name slug path next))
`#(noreply ,(maps:put (repo-key org-name slug)
(tuple 'undefined path next) state)))
(progn
(logger:error "repo_server ~s/~s repeatedly failed; giving up"
(list org-name slug))
(set-repo-status org-name slug "down")
`#(noreply ,(maps:put (repo-key org-name slug)
(tuple 'undefined path next) state))))))
(defun set-repo-status (org-name slug status)
(case (normalize-org org-name)
('none
(catch (lamina_db:q
"UPDATE repositories SET repo_status=? WHERE name=? AND organization_id IS NULL;"
(list status slug))))
(org
(catch (lamina_db:q
"UPDATE repositories SET repo_status=? WHERE name=? AND organization_id=(SELECT id FROM organizations WHERE name=?);"
(list status slug org))))))
(defun start-child (org-name slug fossil-path)
(case (catch (lamina_repo_server:start-link org-name slug fossil-path))
(`#(ok ,pid) `#(ok ,pid))
(`#(error ,reason) `#(error ,reason))
(`#(EXIT ,reason) `#(error ,reason))
(other `#(error ,other))))
(defun find-key-by-pid (wanted-pid state)
(let ((matches
(lists:filter
(lambda (entry)
(let (((tuple _key value) entry))
(let (((tuple entry-pid _path _failures) value))
(=:= wanted-pid entry-pid))))
(maps:to_list state))))
(case matches
('() 'none)
(`(#(,key ,_) . ,_) key))))
(defun terminate (_reason state)
(lists:foreach
(lambda (entry)
(let (((tuple key value) entry))
(let (((tuple org-name slug) key))
(let (((tuple pid _path _failures) value))
(if (is_pid pid) (catch (gen_server:stop pid 'normal 3000)) 'ok)
(lamina_repo_registry:delete org-name slug)))))
(maps:to_list state))
'ok)
(defun code-change (_old state _extra) `#(ok ,state))
(defun normalize-org (org-name)
(cond
((or (=:= org-name 'none) (=:= org-name 'undefined) (=:= org-name 'null)) 'none)
((is_binary org-name) (normalize-org (binary_to_list org-name)))
((or (=:= org-name "") (=:= org-name #"")) 'none)
('true org-name)))
(defun to-str (v)
(if (is_binary v) (binary_to_list v) v))