;; kasi-totp.el --- TOTP support for kasi  -*- lexical-binding:t -*-

;; Copyright (C) 2026 Vineet K

;; Author: Vineet K <git@vineetk.net>
;; Keywords: processes

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; TOTP code taken from Mastering Emacs which took from Jürgen Hötzel's `totp.el'.
;; Base32 code taken from same Mastering Emacs article.
;; HMAC code taken from Sean McAfee.
;; https://www.masteringemacs.org/article/securely-generating-totp-tokens-emacs
;; https://github.com/juergenhoetzel/emacs-totp
;; https://github.com/grimnebulin/emacs-hmac

;;; Code:
(require 'bindat)
(require 'cl-lib)
(require 'hexl)
(require 'subr-x)

(defconst hmac-algorithm-blocksizes
  '((md5 . 64)
    (sha1 . 64)
    (sha224 . 64)
    (sha256 . 64)
    (sha384 . 128)
    (sha512 . 128))
  "Mapping from HMAC algorithm to the algorithm's blocksize.")

(defun hmac (algorithm key message &optional binary)
  "Compute the HMAC for a given message, private key and algorithm.

ALGORITHM is a symbol naming one of the algorithms recognized by
`secure-hash'.  KEY is a the private key to use.  MESSAGE, a
string, is the message to hash.  If BINARY is non-nil, the hmac
will be returned as a binary string, otherwise as a hexadecimal
string."
  (if-let (blocksize (alist-get algorithm hmac-algorithm-blocksizes))
      (progn
        (when (> (length key) blocksize)
          (setq key (secure-hash algorithm key)))
        (when (< (length key) blocksize)
          (setq key (string-as-unibyte (concat key (make-string (- blocksize (length key)) 0)))))
        (let* ((key-list (string-to-list key))
               (o-key-pad (apply #'unibyte-string
                                 (cl-map 'list #'logxor
                                          key-list
                                          (string-to-list (make-string blocksize #x5c)))))
               (i-key-pad (apply #'unibyte-string
                                 (cl-map 'list #'logxor
                                          key-list
                                          (string-to-list (make-string blocksize #x36)))))
               (inner (secure-hash algorithm (concat i-key-pad message) nil nil t)))
          (secure-hash algorithm (concat o-key-pad inner) nil nil binary)))
    (error "Unsupported hash algorithm %s" algorithm)))

(defconst base32-alphabet
  (let ((tbl (make-char-table nil)))
    (dolist (mapping '(("A" . 0) ("B" . 1) ("C" . 2) ("D" . 3) 
                       ("E" . 4) ("F" . 5) ("G" . 6)
                       ("H" . 7) ("I" . 8) ("J" . 9) ("K" . 10) 
                       ("L" . 11) ("M" . 12) ("N" . 13)
                       ("O" . 14) ("P" . 15) ("Q" . 16) ("R" . 17) 
                       ("S" . 18) ("T" . 19) ("U" . 20)
                       ("V" . 21) ("W" . 22) ("X" . 23) ("Y" . 24) 
                       ("Z" . 25) ("2" . 26) ("3" . 27)
                       ("4" . 28) ("5" . 29) ("6" . 30) ("7" . 31)))
      (aset tbl (string-to-char (car mapping)) (cdr mapping)))
    tbl)
  "Base-32 mapping table, as defined in RFC 4648.")

(defun base32-hex-decode (string)
  "The cheats' version of base-32 decode.

This is not a 100% faithful implementation of RFC 4648. The
concept of encoding partial quanta is not implemented fully."
  (setq string (upcase string))
  (let* ((trimmed-array (string-trim-right string "=+"))
         (hex (format "%X" (seq-reduce
                            (lambda (acc char) (+ (ash acc 5) (aref base32-alphabet char)))
                            trimmed-array 0))))
    (if (cl-oddp (length hex))
        (concat "0" hex)
      hex)))

(defun totp--hex-decode-string (string)
  "Hex-decode STRING and return the result as a unibyte string."
  (apply #'unibyte-string
         (seq-map (lambda (s) (hexl-htoi (aref s 0) (aref s 1)))
                  (seq-partition string 2))))

(defun totp (string)
  "Return a TOTP token using the secret hex STRING and current time."
  (let* ((key-bytes (totp--hex-decode-string (upcase (base32-hex-decode string))))
         (counter (truncate (/ (time-to-seconds) 30)))
         ;; we have to manually split the 64 bit number (u64 not supported in Emacs 27.2)
         (counter-bytes (bindat-pack  '((:high u32) (:low u32))
                                      `((:high . ,(ash counter -32)) (:low . ,(logand counter #xffffffff)))))
         (mac (hmac 'sha1 key-bytes counter-bytes t))
         (offset (logand (bindat-get-field (bindat-unpack '((:offset u8)) mac 19) :offset) #xf)))
    (format "%06d"
            (mod
             (logand (bindat-get-field (bindat-unpack '((:totp-pin u32)) mac  offset) :totp-pin)
                     #x7fffffff)
             (expt 10 6)))))

(provide 'kasi-totp)