Emacs Double Opt-In CGI Skeleton Script

;;; double-opt-in.el --- Emacs Double Opt-In CGI  -*- lexical-binding: t; -*-
;; #!/usr/bin/env -S emacs --script

;; Copyright (C) 2021-2024 by Jean Louis

;; Author: Jean Louis <bugs@gnu.support>
;; Version: 0.1
;; Package-Requires: (rcd-mail url subr)
;; Keywords: comm
;; URL: https://hyperscope.link/3/9/1/4/3/Emacs-Double-Opt-In-CGI-Skeleton-Script-39143.html

;; This file is not part of GNU Emacs.

;; 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 <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This is Emacs Double Opt-In CGI Skeleton Script. It is your sales
;; and marketing tool for the World Wide Web. Subscribe users, let
;; them confirm the subscription by clicking on the hyperlink in the
;; email, let them unsubscribe when necessary. Use this script to
;; avoid the subscription spam on your websites. This CGI script is
;; completely Emacs based. It requires no database. It dispatches
;; subscription and unsubscription requests by e-mail as attached
;; files containin the Emacs Lisp hash with the subscription,
;; confirmation or unsubscription data.

;; ℹ HOW TO INSTALL?
;; ━━━━━━━━━━━━━━━━━━
;;
;; 1. To run this script as CGI, include as first line the shebang line:
;; #!/usr/bin/env emacs --script
;;
;; 2. Make it executable and configure your WWW server to run CGI.
;;
;; 3. Make sure to rename it to have a proper extension, like ".cgi"

;; ⚠ SECURITY ISSUES
;; ━━━━━━━━━━━━━━━━━━
;;
;; ❰    ❱ PGP encryption of attached files will be enabled later.
;;
;; ❰    ❱ Is it important that redirection URLs are in the URL
;; parameters?  I don't think so. If anybody wish to deconstruct such
;; hyperlinks they may do so and inspect it themselves. I think there
;; is no need to hide the redirection URLs. People are either sold for
;; your services or products and wish to subscribe or not. Work on
;; selling, not on dark patterns and digital online manipulations.
;;
;; ❰DONE❱ By customizing the security PIN one may prevent the abuse of
;; this script, as then only the administrator knows how to construct
;; the MD5 hash.

;; ☑ INSTRUCTIONS
;; ━━━━━━━━━━━━━━━
;;
;; 1. Create a subscription HTML form with following fields:
;;    - "name" as text field visible to public
;;    - "email" as text field visible to public
;;    - "mid" as hidden field, meaning the Mailing list ID
;;    - "action" as hidden field, must be SUBSCRIBE
;;    - "redirect" as hidden field, should be your subscription confirmation page
;;    - "confirmed-redirect" as as hidden field, as that is where
;;       people will move after confirmation
;;
;; Send a GET request:
;; https://www.example.com/double-opt-in.cgi?name=NAME&email=EMAIL&mid=MID&action=SUBSCRIBE&redirect=http://confirm.com/html
;;
;; TODO maybe it shall be fixed to POST request.
;;
;; Redirect to confirmation page or sales page, or confirmation that
;; redirects to sales page.
;;
;; Person receives email with the double opt-in request. User clicks
;; on the email or not. Redirect page should be in the link. This is
;; generic program as for now. TODO. It may become specific later.
;;
;; 2. Create a HTML confirmation page as that is where people will get
;;    confirmation when they click on the double opt-in hyperlink in
;;    their email message. The HTML confirmation page could or should
;;    redirect people further to some other page like sales page or
;;    similar.
;;
;; 3. Create a HTML page to confirm the unsubscribe request of a
;; user. Don't bother user, user has already clicked. Unsubscribe user
;; and offer to user on the same confirmation page to subscribe
;; again. Redirect user again to sales page or similar.
;;
;; 4. Administrator receives Emacs Lisp hash file that is then
;; processed offline. Person is subscribed to specific mailing list
;; or unsubscribed. Database need not be held online.
;;
;; 5. Your offline mailing list system has to construct unsubscription
;; hyperlinks. The unsubscription request arrives by email to
;; administrator in form of the attached Emacs Lisp hash file and is
;; processed offline automatically.
;;

;;; Change Log:

;;; Code:

(defcustom doi-load-path ""
  "Default Double Opt-In load path where all required libraries reside."
    :group 'Double-Opt-In
    :type 'string)

(add-to-list 'load-path doi-load-path)

(require 'custom)
(require 'package)
(package-initialize)
(require 'custom)

(require 'rcd-mail)
;; (require 'subr)
(require 'subr-x)
(require 'url)

;;;; Variables

(defcustom doi-home "/home/data1/protected"
  "Default Double Opt-In $HOME"
    :group 'Double-Opt-In
    :type 'string)

(defcustom doi-general-redirection-url "https://www.example.com"
  "Default Double Opt-In general redirection URL when nothing else works."
    :group 'Double-Opt-In
    :type 'string)

(defcustom doi-to-email "bugs@example.com"
  "Default Double Opt-In recipient's email address"
    :group 'Double-Opt-In
    :type 'string)

(defcustom doi-to-name "Double Opt-In"
  "Default Double Opt-In recipient's name"
    :group 'Double-Opt-In
    :type 'string)

(defcustom doi-from-email "bugs@gnu.support"
  "Default Double Opt-In sender's email address"
    :group 'Double-Opt-In
    :type 'string)

(defcustom doi-from-name "Double Opt-In"
  "Default Double Opt-In sender's name"
    :group 'Double-Opt-In
    :type 'string)

(defcustom doi-sendmail "/home/admin/bin/sendmail"
  "Default Double Opt-In sendmail program path"
    :group 'Double-Opt-In
    :type 'string)

(defcustom doi-subject-prefix "Double Opt-In: "
  "Default Double Opt-In subject prefix"
    :group 'Double-Opt-In
    :type 'string)

(defcustom doi-directory "/home/data1/protected/public_html/doi/"
  "Double Opt-In directory to save requests."
    :group 'Double-Opt-In
    :type 'string)

(defcustom doi-pin ""
  "Double Opt-In security PIN for MD5 hash generation."
    :group 'Double-Opt-In
    :type 'string)

(unless (file-exists-p doi-directory)
  (make-directory doi-directory t))

(defvar doi-actions '("SUBSCRIBE" "CONFIRM" "UNSUBSCRIBE")
  "Possible actions for Double Opt-In.")

(defvar doi-substring-to 3
  "The TO parameter for function `substring' used in the package.")

(defvar doi-debug t
  "Enable variable `doi-debug' to get some meaningful messages.")

(setq debug-on-error nil)
(setq debug-on-quit nil)

;;;; RCD Utilities

(defun rcd-cgi-headers (&optional content-type)
  "Prints basic HTTP headers for HTML"
  (let ((content-type (or content-type "text/html")))
    (princ (format "Content-type: %s\n\n" content-type))))

(defun rcd-cgi-message (message &optional title dont-kill)
  "Return message over HTTP."
  (let ((title (or title "information")))
    (rcd-cgi-headers "text/plain")
    (princ (rcd-report-underlined title message))
    (unless (or dont-kill (eq major-mode 'emacs-lisp-mode))
      (kill-emacs 0))))

(defun rcd-cgi-redirect (url)
  "Redirect to URL."
  (princ (concat "Location: " url "\n\n"))
  (unless (eq major-mode 'emacs-lisp-mode)
    (kill-emacs 0)))

(defun string-to-file-force (string file)
  "Prints string into file, matters not if file exists. Returns FILE as file name."
  (with-temp-file file
    (insert string))
  file)

(defun file-to-string (file)
  "File to string function"
  (with-temp-buffer
    (insert-file-contents file)
    (buffer-string)))

(defun data-to-file (data file)
  "PRIN1 Emacs Lisp DATA to FILE"
  (string-to-file-force (prin1-to-string data) file))

(defun data-from-file (file)
  "Reads and returns Emacs Lisp data from FILE"
  (condition-case nil
      (car (read-from-string
	    (file-to-string file)))
    (error nil)))

(defun rcd-report-underlined (name text)
  "Return report with underlined heading NAME and TEXT."
  (if (not (seq-empty-p text))
      (with-temp-buffer
	(insert (underline-text (upcase name)) text "\n\n")
	(buffer-string))
  ""))

(defun underline-text (text &optional no-newlines char)
  "Asks for TEXT and returns it underlined. If optional
NEW-NEWLINES is true, it will not add new lines."
  (let* ((l (length text))
	 (char (or char "="))
	 (newlines (if no-newlines "" "\n\n")))
    (format "%s\n%s%s" text
	    (with-output-to-string
	      (let ((count 0))
		(while (< count l)
		  (princ char)
		  (setq count (1+ count)))))
	    newlines)))

(defun pad-to-multiple-bytes (string chunk-size)
  "Pad STRING to multiples of CHUNK-SIZE."
  (let* ((bytes (string-bytes string))
	 (multiple (* (ceiling bytes chunk-size) chunk-size)))
    (string-pad string multiple)))

(defun rcd-encrypt-decrypt (enc-dec password &optional decrypt cipher digest)
  "Encrypt or decrypt ENC-DEC with PASSWORD.

Default cipher is CHACHA20-64 or CIPHER as defined by the
function `gnutls-ciphers'.

Default digest is SHA512 or HASH as defined by the function
`gnutls-digests'.

Function encrypts by default, with DECRYPT being anything but
NIL, it will decrypt the ENC-DEC. "
  (let* ((cipher (or cipher "CHACHA20-64"))
	 (cipher-plist (alist-get cipher (gnutls-ciphers) nil nil 'string=))
	 (cipher-key-size (plist-get cipher-plist :cipher-keysize))
	 (key (pad-to-multiple-bytes password cipher-key-size))
	 (digest (or digest "SHA512"))
	 (hash (gnutls-hash-digest digest password))
	 (iv-size (plist-get cipher-plist :cipher-ivsize))
	 (iv (substring hash 0 iv-size))
	 (iv (string-pad iv iv-size))
	 (block-size (plist-get cipher-plist :cipher-blocksize))
	 (enc-dec (if decrypt enc-dec (pad-to-multiple-bytes enc-dec block-size))))
    (if decrypt
	(string-trim (car (gnutls-symmetric-decrypt cipher key iv enc-dec)))
      (car (gnutls-symmetric-encrypt cipher key iv enc-dec)))))

(defun rcd-encrypt-decrypt-base64 (enc-dec password &optional decrypt cipher digest no-line-break)
  "Use base64 encoding and decoding with encryption."
  (let* ((enc-dec (if decrypt (base64-decode-string enc-dec) enc-dec))
	 (enc-dec (rcd-encrypt-decrypt enc-dec password decrypt cipher digest))
	 (enc-dec (if decrypt enc-dec (base64-encode-string enc-dec no-line-break))))
    enc-dec))

;;;; Double Opt-In Functions

(defun doi-send-mail (subject text &optional html)
  "Easy sending emails for Double Opt-In"
  (rcd-mailutils-mail text subject doi-from-name doi-from-email doi-to-name doi-to-email
		      html nil nil doi-sendmail))

(defun doi-file-find (md5)
  "Return existing MD5 file for Double Opt-In.confirmation or NIL."
  (let ((file (concat (file-name-as-directory doi-directory)
		      (file-name-as-directory (substring md5 0 doi-substring-to))
		      md5)))
    (if (file-exists-p file) file nil)))

(defun doi-file (name email phone mid ip action)
  "Return file name for NAME, EMAIL, PHONE, MID, IP and ACTION."
  (let* ((md5 (md5 (format "%s %s %s %s %s %s" name email phone mid ip action)))
	 (directory (concat (file-name-as-directory doi-directory)
			    (file-name-as-directory (substring md5 0 doi-substring-to))))
	 (file (concat directory md5)))
    file))

(defun doi-hash (name email phone mid ip action &optional eid cid md5 redirect)
  "Return hash for NAME, EMAIL, PHONE, MID, IP and ACTION.

EID, CID and MD5 are optional."
  (when (member action doi-actions)
    (let ((hash (make-hash-table :test #'equal)))
      (puthash "name" name hash)
      (puthash "email" email hash)
      (puthash "phone" phone hash)
      (puthash "mid" mid hash)
      (puthash "ip" ip hash)
      (puthash "action" action hash)
      (when eid (puthash "eid" eid hash))
      (when cid (puthash "cid" cid hash))
      (when md5 (puthash "md5" md5 hash))
      (when redirect (puthash "redirect" redirect hash))
      hash)))

;;;; Hash verification and generation

(defun doi-hash-verify (mid eid cid md5 &optional pin)
  "Return MD5 hash for MID, EID, CID and MD5."
  (when (string-equal md5 (doi-md5-generate mid eid cid pin)) t))

(defun doi-md5-generate (mid eid cid &optional pin)
  "Generate MD5 hash for MID, EID and CID"
  (md5 (format "%s %s %s %s" mid eid cid pin)))

;;;; Subscribe request

(defun doi-subscribe-request (hash)
  "Save request for HASH"
  (let* ((name (gethash "name" hash))
	 (email (gethash "email" hash))
	 (mid (gethash "mid" hash))
	 (phone (gethash "phone" hash))
	 (ip (gethash "ip" hash))
	 (action (gethash "action" hash))
	 (redirect (gethash "redirect" hash)))
    (if (and (member action doi-actions)
	     name email mid ip)
	(let* ((file (doi-file name email phone mid ip action))
	       (md5 (file-name-nondirectory file))
	       (directory (file-name-directory file))
	       (file-exists (file-exists-p file)))
	  (puthash "doi-file" file hash)
	  (puthash "md5" md5 hash)
	  (puthash "time" (format-time-string "%Y-%m-%d %H:%M:%S") hash)
	  (make-directory directory t)
	  (when file-exists
	    (doi-send-mail "WARNING: Repeated subscribe request"
			   (format "Subscription request `%s' repeated from IP: %s" md5 ip)))
	  (data-to-file hash file)
	  (doi-send-confirmation-hyperlink hash)
	  (rcd-cgi-redirect redirect))
      (rcd-cgi-message "Could not make subscribe request"))))

(defun doi-send-confirmation-hyperlink (hash)
  (let* ((md5 (gethash "md5" hash))
	 (action "CONFIRM")
	 (mid (gethash "mid" hash))
	 (to-name (gethash "name" hash))
	 (to-email (gethash "email" hash))
	 (to-name (or to-name to-email))
	 (subject (or (gethash "title" hash) "Confirm your subscription"))
	 (redirect (gethash "confirmed-redirect" hash))
	 (server-name (getenv "HTTP_HOST")) ;; TODO not verified if it works with every server
	 (script-name (getenv "SCRIPT_NAME"))
	 (hyperlink (format "https://%s%s?md5=%s&action=%s&redirect=%s&mid=%s" server-name script-name md5 action redirect mid))
	 (message-format "To confirm your subscription please click on the following hyperlink:\n\n%s\n\nThank you.")
	 (text (rcd-report-underlined subject (format message-format hyperlink)))
	 (hyperlink (format "<a href=\"%s\">CONFIRM SUBSCRIPTION</a>" hyperlink))
	 (html (doi-html-message subject (format message-format hyperlink))))
    (rcd-mailutils-mail text subject doi-from-name doi-from-email to-name to-email html)))

(defun doi-html-message (title text)
  "Return HTML page with TITLE, TEXT."
  (format "<html>
<head>
	<title>%s</title>
</head>
<body>
        <h1>%s</h1>
	</p>%s</p>
</body>
</html>" title title text))

;;;; Confirm

;; TODO verify email domain part to be valid with valid MX record.
;; Verify email to look as valid email
;; Verify string sizes not to be as large

(defun doi-confirm-subscription (md5 redirect)
  "Confirm subscription and send file MD5 by email to administrator."
  (let ((file (doi-file-find md5)))
    (cond (file (let ((subject (concat doi-subject-prefix "Subscription Confirmation" ))
		      (text (concat "Double Opt-In Subscription Confirmation File: " md5)))
		  (rcd-mailutils-mail text subject doi-from-name doi-from-email doi-to-name doi-to-email
				      nil nil nil doi-sendmail file)
		  (rcd-cgi-redirect redirect)))
	  (t (rcd-cgi-message (format "Cannot find file `%s'" md5))))))

;; TODO confirm to user that user has been subscribed, send email,
;; fetch some advertising, maybe fetch the redirect HTML and inject
;; into email.

;;;; Unsubscribe for real

(defun doi-unsubscribe-generate-query (mid eid cid pin url &optional redirect)
  "Generate unsubscribe request for mailing list MID.

CID is contact ID.
EID is email ID.
PIN is password.
"
  (let* ((hash (doi-md5-generate mid eid cid pin))
	 (list (list mid eid cid hash redirect))
	 (list-prin1 (prin1-to-string list))
	 (encrypted (rcd-encrypt-decrypt-base64 list-prin1 pin nil nil nil t))
	 (url (concat url "?action=UNSUBSCRIBE&data=" encrypted)))
    url))

(defun doi-unsubscribe-decrypt-query (query pin)
  "Return decrypted QUERY with password PIN."
  (let* ((decrypted (rcd-encrypt-decrypt-base64 query pin t)))
    decrypted))

(defun doi-unsubscribe-encrypted (data ip pin)
  (let* ((lisp (doi-unsubscribe-decrypt-query data pin))
	 (list (car (read-from-string lisp))))
    (cond ((listp list) (let* ((mid (elt list 0))
			       (eid (elt list 1))
			       (cid (elt list 2))
			       (md5 (elt list 3))
			       (redirect (elt list 4)))
			  (if (doi-hash-verify mid eid cid md5 pin)
			      (doi-unsubscribe mid eid cid md5 ip redirect pin)
			    (rcd-cgi-message
			     "Error, inform the website owner that unsubscribe request was not successful."))))
	  (t (rcd-cgi-message "Error, inform the website owner that unsubscribe request was not successful.")))))

;; (doi-unsubscribe-encrypted data "1.2.3.4" doi-pin)

(defun doi-unsubscribe (mid eid cid md5 ip redirect pin)
  (if (doi-hash-verify mid eid cid md5 pin)
    (let* ((subject (concat doi-subject-prefix "Unsubscribe Request"))
	   (text (concat "Double Opt-In Unsubscription: " md5))
	   (hash (doi-hash "" "" "" mid ip "UNSUBSCRIBE" eid cid md5 redirect))
	   (file (md5 (format "%s %s %s %s %s %s" mid eid cid md5 ip redirect)))
	   (directory (concat (file-name-as-directory doi-directory)
			      (file-name-as-directory "unsubscribe")
			      (substring md5 0 doi-substring-to)))
	   (file (concat (file-name-as-directory directory) file))
	   (_ (make-directory directory t))
	   (file (data-to-file hash file)))
      (if (file-exists-p file)
	  (progn
	    (rcd-mailutils-mail text subject doi-from-name doi-from-email doi-to-name doi-to-email
	     			nil nil nil doi-sendmail file)
	    (rcd-cgi-redirect redirect))
	(rcd-cgi-message "Cannot create file, write to administrator")))
    (progn
      (doi-send-mail "DOI: Bad unsubscribe request" (shell-command-to-string "set"))
      (rcd-cgi-message
       (format "Sorry your unsubscribe request cannot be confirmed and your IP %s has been reported." ip)))))

;;;; Delete

(defun doi-delete (md5)
  "Delete Double Opt-In file MD5"
  (let ((file (doi-file-find md5)))
    (when file
      (delete-file file))))

;;;; Parse

(defun doi-parse-query-to-hash (query-string)
  "Parse QUERY-STRING that normally comes from the environment
variable `QUERY_STRING'. Return hash."
  (let* ((query-string (replace-regexp-in-string "\\+" "%20" query-string))
	 (query-string (decode-coding-string (url-unhex-string query-string) 'utf-8))
	 (parts (split-string query-string "&"))
	 (hash (make-hash-table :test #'equal)))
    (while parts
      (let* ((data (split-string (pop parts) "="))
	     (variable (car data))
	     (value (string-trim (cadr data))))
	(puthash variable value hash)))
    hash))

;;;; Accept requests

(defun doi-lead ()
  (setf (getenv "HOME") doi-home)
  (let ((method (getenv "REQUEST_METHOD")))
    (when (string= method "GET")
      (let* ((query-string (getenv "QUERY_STRING"))
	     (ip (getenv "REMOTE_ADDR"))
	     (hash (doi-parse-query-to-hash query-string)))
	(puthash "ip" ip hash)
	(if (and (member (gethash "action" hash) doi-actions)
		 (gethash "redirect" hash) (gethash "mid" hash) (gethash "ip" hash))
	    (cond
	     ;; Unsubscribe
	     ((string-equal (gethash "action" hash) "UNSUBSCRIBE")
	      (doi-unsubscribe-encrypted (gethash "data" hash) (gethash "ip" hash) doi-pin))

	     ;; Confirm subscription
	     ((and (gethash "md5" hash) (stringp (gethash "action" hash)) (gethash "redirect" hash)
		   (string-equal (gethash "action" hash) "CONFIRM"))
	      (doi-confirm-subscription (gethash "md5" hash) (gethash "redirect" hash)))

	     ;; Subscribe request
	     ((and (gethash "name" hash) (gethash "email" hash) (gethash "mid" hash) (gethash "title" hash)
		   (string-equal (gethash "action" hash) "SUBSCRIBE") (gethash "confirmed-redirect" hash))
	      (doi-subscribe-request hash))

	     ;; Default
	     (t (rcd-cgi-redirect doi-general-redirection-url)))
	  (rcd-cgi-redirect doi-general-redirection-url))))))

(doi-lead)

(provide 'double-opt-in)

;;; double-opt-in.el ends here