CaaS / Lamina

Artifact 693550a89865d204117333a3d2b899d07c1ffbc91fbcc3228c37cd174512d9a4:

• File src/logic/lamina_auth.lfe — part of check-in [432128758e] at 2026-10-23 13:56:37 on branch Dev — feat(app): 初始代码 (user: pluto size: 5464)

;; 平台认证：凭据校验、会话签名 Cookie、防暴力尝试、CSRF（设计文档 §8）
(defmodule lamina_auth
  (export all))

(defun session-cookie-name () #"lamina_session")

(defun session-ttl-seconds () 604800) ; 7 天

(defun fail-limit () 5)

(defun lock-seconds () 900) ; 15 分钟

;;---- 密钥 ----

(defun secret-key ()
  (case (persistent_term:get 'lamina_secret 'error)
    ('error
     (case (lamina_crypto:load_or_create_key "data/secret.key")
       (`#(ok ,key)
        (progn (persistent_term:put 'lamina_secret key) key))
       (`#(error ,reason) (erlang:error reason))))
    (key key)))

;; 测试注入
(defun put-secret-key (key) (persistent_term:put 'lamina_secret key))

;;---- 登录/登出 ----

;; 成功返回 {ok, CookieValue}；失败返回 {error, Reason}
(defun login (username password)
  (case (locked?)
    ('true `#(error "尝试次数过多，请 15 分钟后再试"))
    ('false
     (case (check-credentials username password)
       ('true
        (progn (reset-fails)
               `#(ok ,(make-session-cookie username))))
       ('false
        (progn (register-fail)
               `#(error "用户名或密码错误")))))))

(defun check-credentials (username password)
  (case (catch (lamina_db:q "SELECT password_hash FROM admin_user WHERE username=?;" (list username)))
    (`((,hash))
     (if (is_binary hash)
         (lamina_crypto:verify_password password hash)
         (lamina_crypto:verify_password password (list_to_binary hash))))
    (_ 'false)))

;;---- 会话 Cookie ----

(defun make-session-cookie (username)
  (let ((expires (+ (os:system_time (quote second)) (session-ttl-seconds))))
    (let ((payload (lists:flatten (io_lib:format "~s|~p" (list username expires)))))
      (let ((sig (sign payload)))
        (cookie-string (base64:encode payload) sig (session-ttl-seconds))))))

(defun cookie-string (payload-b64 sig max-age)
  (lists:flatten
   (io_lib:format "~s=~s|~s; Path=/; HttpOnly; SameSite=Lax; Max-Age=~p"
                  (list (session-cookie-name) payload-b64 sig max-age))))

(defun clear-cookie-string ()
  (lists:flatten
   (io_lib:format "~s=; Path=/; HttpOnly; SameSite=Lax; Max-Age=0"
                  (list (session-cookie-name)))))

;; Cookie 值为 "payload-b64|sig"；校验通过返回 {ok, Username}
(defun verify-cookie-value (value)
  ;; Cookie 来自用户请求，任何 Base64/过期时间解析异常都应视为无效会话，
  ;; 不能把异常冒泡成平台 500。
  (case (catch (verify-cookie-value-unsafe value))
    (`#(ok ,username) `#(ok ,username))
    (_ 'error)))

(defun verify-cookie-value-unsafe (value)
  (case value
    ('undefined 'error)
    (_
     (case (string:split value "|" 'leading)
       (`(,payload-b64 ,sig)
        (let ((payload (binary_to_list (base64:decode payload-b64))))
          (if (=:= sig (sign payload))
              (let ((parts (string:split payload "|" 'leading)))
                (case parts
                  (`(,username ,expires-s)
                   (let ((expires (list_to_integer expires-s)))
                     (if (> expires (os:system_time (quote second)))
                         `#(ok ,username)
                         'error)))
                  (_ 'error)))
              'error)))
       (_ 'error)))))

(defun sign (payload)
  (let ((mac (crypto:mac 'hmac 'sha256 (secret-key) payload)))
    (binary_to_list (base64:encode mac))))

;; 从 cowboy Req 中提取并校验会话；有效返回 {ok, Username}
(defun verify-request (req)
  (let ((result (catch (cowboy_req:parse_cookies req))))
    (if (is_list result)
        (let ((value (proplists:get_value (session-cookie-name) result)))
          (if (=:= 'undefined value)
              'error
              (verify-cookie-value (binary_to_list value))))
        'error)))

;;---- CSRF（与会话绑定的派生 token）----
;; 使用 URL-safe Base64，避免表单 urlencode 把 `+` 变成空格导致校验失败。
;; 提交值可能是 binary，签发值是 list，比较前统一成字符串。

(defun csrf-token (username)
  (urlsafe-sign (lists:flatten (io_lib:format "csrf|~s" (list (to-str username))))))

(defun verify-csrf (username token)
  (=:= (to-str token) (csrf-token username)))

(defun urlsafe-sign (payload)
  (let ((mac (crypto:mac 'hmac 'sha256 (secret-key) payload)))
    (binary_to_list
     (base64:encode mac (maps:from_list
                         (list (tuple 'mode 'urlsafe)
                               (tuple 'padding 'false)))))))

(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))))))

;;---- 防暴力尝试（进程内计数，单节点足够）----

(defun fail-key () 'lamina_auth_fails)

(defun locked? ()
  (let ((until (maps:get 'lock_until (persistent_term:get (fail-key) #M()) 0)))
    (> until (os:system_time (quote second)))))

(defun register-fail ()
  (let ((m (persistent_term:get (fail-key) #M())))
    (let ((fails (+ (maps:get 'count m 0) 1)))
      (let ((m1 (maps:put 'count fails m)))
        (persistent_term:put (fail-key)
                             (if (>= fails (fail-limit))
                                 (maps:put 'lock_until (+ (os:system_time (quote second)) (lock-seconds)) m1)
                                 m1))))))

(defun reset-fails ()
  (persistent_term:erase (fail-key)))