;; Fossil 反向代理（设计文档 §6.2）
;; 路由 /:slug/... 与 /:org/:slug/... → 剥前缀转发到对应 repo_server 端口。
(defmodule h_proxy
(export all))
(defun handle (req)
(let ((path (binary_to_list (cowboy_req:path req))))
(case (resolve path)
(`#(ok ,portnum ,rest-path)
(forward req portnum rest-path))
('starting
(lamina_error_pages:service-unavailable "The Fossil repository process is starting. Please retry shortly."))
(_
`#(status 404 #M(#"content-type" #"text/plain; charset=utf-8") #"not found")))))
;; path 形如 /a 或 /a/b/c；返回 ok/Port/ForwardPath 或 not-a-repo
(defun resolve (path)
(let ((segs (lists:filter (lambda (s) (not (=:= "" s)))
(string:split (strip-leading-slash path) "/" 'all))))
(cond
((=:= '() segs) 'not-a-repo)
('true
(let ((s1 (hd segs))
(rest (tl segs)))
(cond
;; /s1 —— 未归类仓库根
((=:= '() rest) (try-repo s1 "/"))
;; /s1/... —— 先试未归类仓库，再试 组织/仓库
('true
(case (lookup-port s1 'none)
(`#(ok ,portnum)
`#(ok ,portnum ,(concat "/" (string:join rest "/"))))
('starting 'starting)
('undefined
(let ((s2 (hd rest)))
(case (lookup-port s2 s1)
(`#(ok ,portnum2)
`#(ok ,portnum2 ,(concat "/" (string:join (tl rest) "/"))))
('starting 'starting)
('undefined 'not-a-repo))))))))))))
(defun try-repo (slug forward-path)
(case (lookup-port slug 'none)
('undefined 'not-a-repo)
('starting 'starting)
(`#(ok ,portnum) `#(ok ,portnum ,forward-path))
(portnum
(if (is_integer portnum)
`#(ok ,portnum ,forward-path)
'starting))))
;; slug 是否存在于 DB（org-name='none' 表示未归类）
(defun lookup-port (slug org-name)
(let ((query-result
(case org-name
('none
(catch (lamina_db:q "SELECT id FROM repositories WHERE name=? AND organization_id IS NULL;" (list slug))))
(_
(catch (lamina_db:q "SELECT r.id FROM repositories r JOIN organizations o ON r.organization_id=o.id WHERE r.name=? AND o.name=?;"
(list slug org-name)))))))
(case query-result
(`((,_))
(case (repo-port slug org-name)
('undefined 'starting)
(portnum
(if (is_integer portnum)
`#(ok ,portnum)
'starting))))
(_ 'undefined))))
(defun repo-port (slug org-name)
(case org-name
('none (lamina_repo_server:get-port slug))
(org (lamina_repo_server:get-port org slug))))
;;---- 转发 ----
(defun forward (req portnum rest-path)
(let* ((method (binary_to_list (cowboy_req:method req)))
(qs (binary_to_list (cowboy_req:qs req)))
(url (lists:flatten
(io_lib:format "http://127.0.0.1:~p~s~s"
(list portnum rest-path
(if (=:= "" qs) "" (concat "?" qs)))))))
(application:ensure_all_started 'inets)
(let ((hdrs (with-forwarded-proto req (req-headers req))))
(let ((result (forward-request method url hdrs req)))
(case result
((tuple 'ok (tuple (tuple _ status _) resp-hdrs resp-body))
(reply req status resp-hdrs resp-body))
(`#(error ,reason)
(lamina_error_pages:bad-gateway
(lists:flatten (io_lib:format "Fossil upstream is unavailable: ~p" (list reason))))))))))
(defun forward-request (method url hdrs req)
;; httpc 会按 body 重算长度；原 Content-Length 一并转出会导致长度不一致。
(let ((fwd-hdrs (drop-header hdrs "content-length")))
(case method
("POST"
(case (read-body req)
(`#(ok ,body)
(httpc:request 'post (tuple url fwd-hdrs (or-ct fwd-hdrs) (safe-body body))
(list (tuple 'autoredirect 'false))
(list (tuple 'body_format 'binary))))
(`#(error ,reason) `#(error ,reason))
(_ `#(error body-read))))
(_
(httpc:request (list_to_atom (lower method))
(tuple url fwd-hdrs)
(list (tuple 'autoredirect 'false))
(list (tuple 'body_format 'binary)))))))
(defun read-body (req)
;; nova_request_plugin 已经把请求体放入 Req.body；仅在没有读取时再从 Cowboy 读取。
(case (maps:find 'body req)
(`#(ok ,body) `#(ok ,body))
(_
(case (catch (cowboy_req:read_body req))
(`#(ok ,body ,_newreq) `#(ok ,body))
(_ `#(ok #""))))))
;; 浏览器→平台 请求头白名单透传
(defun req-headers (req)
(let ((hs (cowboy_req:headers req)))
(lists:filtermap
(lambda (kv)
(let (((tuple k v) kv))
(if (and (is_binary v) (allowed-req-header k))
`#(true ,(tuple (binary_to_list k) (binary_to_list v)))
'false)))
(maps:to_list hs))))
(defun allowed-req-header (k)
(case k
(#"host" 'true)
(#"cookie" 'true)
(#"authorization" 'true)
(#"content-type" 'true)
(#"accept" 'true)
(#"accept-language" 'true)
(#"user-agent" 'true)
(#"if-modified-since" 'true)
(#"if-none-match" 'true)
(#"referer" 'true)
(#"origin" 'true)
(#"content-length" 'true)
(_ 'false)))
(defun or-ct (hdrs)
(let ((ct (proplists:get_value "content-type" hdrs)))
(if (=:= 'undefined ct) "application/x-www-form-urlencoded" ct)))
(defun with-forwarded-proto (req hdrs)
(if (=:= 'undefined (proplists:get_value "x-forwarded-proto" hdrs))
(lists:append hdrs (list (tuple "X-Forwarded-Proto" (scheme req))))
hdrs))
(defun scheme (req)
(let ((value (catch (cowboy_req:scheme req))))
(cond
((is_atom value) (atom_to_list value))
((is_binary value) (binary_to_list value))
('true "http"))))
;; 上游→浏览器 应答。Cowboy 2 禁止在 header map 里放 set-cookie
;;（必须走 cowboy_req:set_resp_cookie），Fossil 登录成功正好会带该头，
;; 直接透传会让 Nova 在 set_resp_headers 里 exit → 平台 500。
(defun reply (req status resp-hdrs body)
(let (((tuple hdr-map cookies) (split-resp-headers resp-hdrs)))
(let ((req2 (apply-cookies req cookies)))
`#(status ,status ,hdr-map ,(safe-body body) ,req2))))
(defun split-resp-headers (hdrs)
(lists:foldl
(lambda (kv acc)
(let (((tuple hdr-map cookies) acc)
((tuple k v) kv))
(let ((key (string:lowercase (to-str k))))
(cond
((=:= key "set-cookie")
(tuple hdr-map (lists:append cookies (list (to-bin v)))))
((or (=:= key "content-length")
(=:= key "transfer-encoding")
(=:= key "connection"))
acc)
('true
(tuple (maps:put (list_to_binary key) (to-bin v) hdr-map)
cookies))))))
(tuple #M() '())
hdrs))
(defun apply-cookies (req cookies)
(lists:foldl #'put-cookie/2 req cookies))
(defun put-cookie (raw req)
(case (cow_cookie:parse_set_cookie (to-bin raw))
(`#(ok ,name ,value ,attrs)
(cowboy_req:set_resp_cookie name value req (cookie-opts attrs)))
(_ req)))
;; parse_set_cookie 的 max_age/expires 是 datetime，Cowboy cookie_opts 只要整数秒。
(defun cookie-opts (attrs)
(lists:foldl
(lambda (key acc)
(case (maps:find key attrs)
(`#(ok ,val)
(if (keep-cookie-opt? key val)
(maps:put key val acc)
acc))
('error acc)))
#M()
(list 'path 'domain 'secure 'http_only 'same_site 'max_age)))
(defun keep-cookie-opt? (key val)
(case key
('max_age (is_integer val))
('secure (is_boolean val))
('http_only (is_boolean val))
('same_site (or (=:= val 'lax) (=:= val 'strict) (=:= val 'none)
(=:= val 'default)))
(_ 'true)))
(defun drop-header (hdrs name)
(lists:filter
(lambda (kv)
(let (((tuple k _v) kv))
(not (=:= (string:lowercase (to-str k)) name))))
hdrs))
(defun resp-headers-map (hdrs)
(let (((tuple hdr-map _cookies) (split-resp-headers hdrs)))
hdr-map))
(defun safe-body (body)
(cond
((is_binary body) body)
((is_list body) (try-bin body))
('true #"")))
(defun try-bin (value)
(case (catch (list_to_binary (to-str value)))
(bin (if (is_binary bin) bin #""))
(_ #"")))
(defun lower (s)
(string:lowercase s))
(defun to-str (value)
(cond
((is_binary value) (binary_to_list value))
((is_list value) value)
((is_atom value) (atom_to_list value))
('true "")))
(defun to-bin (value)
(if (is_binary value) value (list_to_binary (to-str value))))
(defun concat (a b) (lists:append (list a b)))
(defun strip-leading-slash (path)
(if (and (> (length path) 0) (=:= 47 (hd path)))
(tl path)
path))