;; 单仓库同步/推送任务。任务本身是短生命周期进程，锁放在 ETS 中，
;; 因而手动按钮和调度器同时触发时不会对同一仓库并发执行。
(defmodule lamina_sync_task
(export all))
(defun sync (repo-id)
(run-sync repo-id))
(defun run-sync (repo-id)
(if (not (lock 'sync repo-id))
'skipped
(let ((result (catch (do-sync repo-id))))
(unlock 'sync repo-id)
(case result
('ok 'ok)
(`#(error ,reason) `#(error ,reason))
(`#(EXIT ,reason) (mark-sync-crashed repo-id reason))
(_ `#(error ,result))))))
(defun do-sync (repo-id)
(case (repo-row repo-id)
('undefined `#(error "仓库不存在"))
(repo (do-sync-repo repo))))
(defun do-sync-repo (repo)
(let ((repo-id (maps:get 'id repo))
(source (maps:get 'source repo ""))
(remote-url (maps:get 'remote_url repo "")))
(case (begin-sync-log repo-id)
('busy 'skipped)
('error `#(error "无法创建同步日志"))
(log-id
(cond
((not (=:= "remote" source))
(finish-sync-failed log-id repo-id "只有远程仓库可以同步"))
((=:= "" remote-url)
(finish-sync-failed log-id repo-id "远程 Fossil 地址未配置"))
('true (sync-with-log repo log-id)))))))
(defun sync-with-log (repo log-id)
(let* ((repo-id (maps:get 'id repo))
(path (maps:get 'fossil_path repo))
(username (maps:get 'setup_username repo ""))
(password (decrypt-credential (maps:get 'setup_password_enc repo 'undefined)))
(before (info-fingerprint path)))
(case password
(`#(error ,reason) (finish-sync-failed log-id repo-id reason))
(password1
(let ((url (lamina_fossil_git:credential-url (maps:get 'remote_url repo)
username password1)))
(case (lamina_fossil:run (list "user" "default" username "-R" path))
(`#(ok ,_)
(case (lamina_fossil_repo:sync url path)
(`#(ok ,_output)
(let ((last (lamina_fossil_repo:last-timeline path))
(changed (not (=:= before (info-fingerprint path)))))
(finish-sync-ok log-id repo-id last)
(if (and (=:= 1 (maps:get 'git_auto_push repo 0)) changed)
(case (run-push repo-id)
('ok 'ok)
(`#(error ,_) 'ok)
(_ 'ok))
'ok)))
(`#(error ,reason) (finish-sync-failed log-id repo-id reason))
(`#(EXIT ,reason) (finish-sync-failed log-id repo-id reason))
(_ (finish-sync-failed log-id repo-id "fossil sync 失败"))))
(`#(error ,reason) (finish-sync-failed log-id repo-id reason))
(_ (finish-sync-failed log-id repo-id "无法设置同步用户"))))))))
(defun run-push (repo-id)
(if (not (lock 'push repo-id))
'skipped
(let ((result (catch (do-push repo-id))))
(unlock 'push repo-id)
(case result
('ok 'ok)
(`#(error ,reason) `#(error ,reason))
(`#(EXIT ,reason) (mark-push-crashed repo-id reason))
(_ `#(error ,result))))))
(defun push (repo-id)
(run-push repo-id))
(defun do-push (repo-id)
(case (repo-row repo-id)
('undefined `#(error "仓库不存在"))
(repo (do-push-repo repo))))
(defun do-push-repo (repo)
(let ((repo-id (maps:get 'id repo))
(url (maps:get 'git_url repo ""))
(enabled (maps:get 'git_enabled repo 0)))
(cond
((/= 1 enabled) `#(error "Git 推送未启用"))
((=:= "" url) `#(error "Git 仓库地址未配置"))
('true (start-push repo repo-id)))))
(defun start-push (repo repo-id)
(case (begin-push-log repo-id)
('busy 'skipped)
('error `#(error "无法创建推送日志"))
(log-id (push-with-log repo log-id))))
(defun push-with-log (repo log-id)
(let* ((repo-id (maps:get 'id repo))
(path (maps:get 'fossil_path repo))
(url (maps:get 'git_url repo))
(username (maps:get 'git_username repo ""))
(token (decrypt-credential (maps:get 'git_token_enc repo 'undefined))))
(case token
(`#(error ,reason) (finish-push-failed log-id repo-id reason))
(token1
(case (lamina_fossil_git:push path url username token1)
(`#(ok ,_) (finish-push-ok log-id repo-id))
(`#(error ,reason) (finish-push-failed log-id repo-id reason))
(`#(EXIT ,reason) (finish-push-failed log-id repo-id reason))
(_ (finish-push-failed log-id repo-id "Git 推送失败")))))))
(defun repo-row (repo-id)
(case (catch
(lamina_db:q
"SELECT id,name,source,COALESCE(remote_url,''),setup_username,setup_password_enc,COALESCE(git_enabled,0),COALESCE(git_url,''),COALESCE(git_username,''),git_token_enc,COALESCE(git_auto_push,0),fossil_path FROM repositories WHERE id=?;"
(list repo-id)))
(`((,id ,name ,source ,remote-url ,setup-user ,setup-password ,git-enabled ,git-url
,git-user ,git-token ,git-auto ,path))
(maps:from_list
(list (tuple 'id id) (tuple 'name (to-str name)) (tuple 'source (to-str source))
(tuple 'remote_url (to-str remote-url)) (tuple 'setup_username (to-str setup-user))
(tuple 'setup_password_enc setup-password)
(tuple 'git_enabled (to-int git-enabled)) (tuple 'git_url (to-str git-url))
(tuple 'git_username (to-str git-user)) (tuple 'git_token_enc git-token)
(tuple 'git_auto_push (to-int git-auto)) (tuple 'fossil_path (to-str path)))))
(_ 'undefined)))
(defun begin-sync-log (repo-id)
(case (catch (lamina_db:q
"SELECT id FROM sync_log WHERE repository_id=? AND finished_at IS NULL LIMIT 1;"
(list repo-id)))
(`((,_)) 'busy)
(_
(case (catch (lamina_db:q
"INSERT INTO sync_log(repository_id,started_at,status,message) VALUES(?,?, 'running','');"
(list repo-id (now))))
(`#(error ,_) 'error)
(_ (lamina_db:last-rowid))))))
(defun begin-push-log (repo-id)
(case (catch (lamina_db:q
"SELECT id FROM push_log WHERE repository_id=? AND finished_at IS NULL LIMIT 1;"
(list repo-id)))
(`((,_)) 'busy)
(_
(case (catch (lamina_db:q
"INSERT INTO push_log(repository_id,started_at,status,message) VALUES(?,?, 'running','');"
(list repo-id (now))))
(`#(error ,_) 'error)
(_ (lamina_db:last-rowid))))))
(defun finish-sync-ok (log-id repo-id last)
(let ((last-value (if (=:= 'unknown last) "" (to-str last))))
(lamina_db:q "UPDATE sync_log SET finished_at=?,status='success',message='' WHERE id=?;"
(list (now) log-id))
(lamina_db:q "UPDATE repositories SET last_synced_at=?,last_sync_status='success',last_timeline_at=?,updated_at=? WHERE id=?;"
(list (now) last-value (now) repo-id))
(write-sync-log repo-id "sync" "success" "")
'ok))
(defun finish-sync-failed (log-id repo-id reason)
(let ((message (reason-text reason)))
(lamina_db:q "UPDATE sync_log SET finished_at=?,status='failed',message=? WHERE id=?;"
(list (now) (db-text message) log-id))
(lamina_db:q "UPDATE repositories SET last_synced_at=?,last_sync_status='failed' WHERE id=?;"
(list (now) repo-id))
(write-sync-log repo-id "sync" "failed" message)
`#(error ,message)))
(defun finish-push-ok (log-id repo-id)
(lamina_db:q "UPDATE push_log SET finished_at=?,status='success',message='' WHERE id=?;"
(list (now) log-id))
(lamina_db:q "UPDATE repositories SET last_pushed_at=?,last_push_status='success',updated_at=? WHERE id=?;"
(list (now) (now) repo-id))
(write-sync-log repo-id "push" "success" "")
'ok)
(defun finish-push-failed (log-id repo-id reason)
(let ((message (reason-text reason)))
(lamina_db:q "UPDATE push_log SET finished_at=?,status='failed',message=? WHERE id=?;"
(list (now) (db-text message) log-id))
(lamina_db:q "UPDATE repositories SET last_push_status='failed' WHERE id=?;"
(list repo-id))
(write-sync-log repo-id "push" "failed" message)
`#(error ,message)))
(defun mark-sync-crashed (repo-id reason)
(let ((message (reason-text reason)))
(lamina_db:q "UPDATE sync_log SET finished_at=?,status='failed',message=? WHERE repository_id=? AND finished_at IS NULL;"
(list (now) (db-text message) repo-id))
(lamina_db:q "UPDATE repositories SET last_synced_at=?,last_sync_status='failed' WHERE id=?;"
(list (now) repo-id))
(write-sync-log repo-id "sync" "failed" message)
`#(error ,message)))
(defun mark-push-crashed (repo-id reason)
(let ((message (reason-text reason)))
(lamina_db:q "UPDATE push_log SET finished_at=?,status='failed',message=? WHERE repository_id=? AND finished_at IS NULL;"
(list (now) (db-text message) repo-id))
(lamina_db:q "UPDATE repositories SET last_push_status='failed' WHERE id=?;"
(list repo-id))
(write-sync-log repo-id "push" "failed" message)
`#(error ,message)))
(defun write-sync-log (repo-id kind status message)
(let ((line (lists:flatten
(io_lib:format "~s repo=~p kind=~s status=~s message=~s~n"
(list (now) repo-id kind status (one-line message))))))
(case (catch (progn
(filelib:ensure_dir "data/logs/sync.log")
(file:write_file "data/logs/sync.log" line '(append))))
('ok 'ok)
(_ (logger:warning "could not write data/logs/sync.log for repo ~p" (list repo-id))))))
(defun one-line (value)
(let ((text (to-str value)))
(lists:flatten (string:replace (string:replace text "\n" " " 'all) "\r" " " 'all))))
(defun db-text (value)
(unicode:characters_to_binary (to-str value)))
(defun info-fingerprint (path)
(case (lamina_fossil_repo:info path)
(`#(ok ,output) output)
(_ "")))
(defun decrypt-credential (value)
(case value
('undefined "")
('null "")
(#"" "")
(binary
(case (catch (binary_to_term binary))
(`#(,iv ,ciphertext ,tag)
(case (lamina_crypto:decrypt iv ciphertext tag (lamina_auth:secret-key))
(`#(ok ,plaintext) (binary_to_list plaintext))
(_ `#(error "凭据解密失败"))))
(`#(EXIT ,_) `#(error "凭据解密失败"))
(_ `#(error "凭据格式无效"))))
(_ `#(error "凭据格式无效"))))
(defun lock (kind repo-id)
(let ((key (tuple kind repo-id)))
(case (catch (ets:insert_new 'lamina_task_locks (tuple key 'true)))
('true 'true)
('false 'false)
(`#(EXIT ,_)
(case (catch (ets:new 'lamina_task_locks (list 'named_table 'public 'set)))
(`#(EXIT ,_) 'ok)
(_ 'ok))
(=:= 'true (catch (ets:insert_new 'lamina_task_locks (tuple key 'true))))))))
(defun unlock (kind repo-id)
(catch (ets:delete 'lamina_task_locks (tuple kind repo-id))))
(defun recent-sync-logs (repo-id)
(case (catch (lamina_db:q
"SELECT started_at,finished_at,status,message FROM sync_log WHERE repository_id=? ORDER BY started_at DESC LIMIT 10;"
(list repo-id)))
(rows rows)
(_ '())))
(defun recent-push-logs (repo-id)
(case (catch (lamina_db:q
"SELECT started_at,finished_at,status,message FROM push_log WHERE repository_id=? ORDER BY started_at DESC LIMIT 10;"
(list repo-id)))
(rows rows)
(_ '())))
(defun refresh-local-timeline (repo-id path)
(if (not (lock 'timeline repo-id))
'skipped
(let ((last (catch (lamina_fossil_repo:last-timeline path))))
(unlock 'timeline repo-id)
(case last
('unknown `#(error "无法读取本地仓库时间线"))
(value
(lamina_db:q "UPDATE repositories SET last_timeline_at=? WHERE id=?;"
(list (to-str value) repo-id))
'ok)))))
;; 定时刷新本地仓库时，若时间线确实发生变化且开启了自动 Git 推送，
;; 在释放时间线锁后复用标准推送任务，避免与手动推送并发。
(defun refresh-local-timeline-and-push (repo-id path)
(if (not (lock 'timeline repo-id))
'skipped
(let* ((previous (stored-timeline repo-id))
(current (catch (lamina_fossil_repo:last-timeline path))))
(unlock 'timeline repo-id)
(case current
('unknown
(write-sync-log repo-id "timeline" "failed" "无法读取本地仓库时间线")
`#(error "无法读取本地仓库时间线"))
(value
(lamina_db:q "UPDATE repositories SET last_timeline_at=?,updated_at=? WHERE id=?;"
(list (to-str value) (now) repo-id))
(if (and (=:= 1 (maps:get 'git_auto_push previous 0))
(=:= 1 (maps:get 'git_enabled previous 0))
(not (=:= (to-str value) (maps:get 'last_timeline previous ""))))
(case (run-push repo-id)
('ok 'ok)
('skipped 'skipped)
(`#(error ,reason) `#(error ,reason))
(other `#(error ,other)))
'ok))))))
(defun stored-timeline (repo-id)
(case (catch (lamina_db:q
"SELECT COALESCE(last_timeline_at,''),COALESCE(git_auto_push,0),COALESCE(git_enabled,0) FROM repositories WHERE id=?;"
(list repo-id)))
(`((,last ,auto-push ,git-enabled))
(maps:from_list
(list (tuple 'last_timeline (to-str last))
(tuple 'git_auto_push (to-int auto-push))
(tuple 'git_enabled (to-int git-enabled)))))
(_ #M(last_timeline "" git_auto_push 0 git_enabled 0))))
(defun now ()
(lamina_setup:iso8601 (os:system_time 'second)))
(defun reason-text (reason)
(let ((text (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))
(`#(error ,message) (to-str message))
(_ (lists:flatten (io_lib:format "~p" (list reason)))))))
(if (> (length text) 2000) (lists:sublist text 2000) text)))
(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 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))))))