Tamarind.

author: Kaz Kylheku <kaz@kylheku.com> 2016-03-02 06:57:09 -0800
committer: Kaz Kylheku <kaz@kylheku.com> 2016-03-02 06:57:09 -0800
commit: 92241abe22d0976d115fbd4caacbf5121d5d5c04 (patch)
tree: 6336e561ea34d297a25413594a29f1a4359581be
parent: 84ffdada07f03facc90cb7cfc6adacd19025d2c9 (diff)
download: tamarind-92241abe22d0976d115fbd4caacbf5121d5d5c04.tar.gz
tamarind-92241abe22d0976d115fbd4caacbf5121d5d5c04.tar.bz2
tamarind-92241abe22d0976d115fbd4caacbf5121d5d5c04.zip
15 files changed, 543 insertions, 0 deletions
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..3785f70
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,19 @@
+CFLAGS += -O2 -DPWD=\"$(shell pwd)\"
+
+PROG := sutxr.cgi
+
+.PHONY: all
+all: $(PROG) perms
+
+$(PROG):: $(PROG).c
+
+$(PROG)::
+	chmod u+s $@
+
+.PHONY: perms
+
+perms:
+	chmod u+s main.txr
+
+clean:
+	-rm $(PROG)
diff --git a/alias-list-form.txr b/alias-list-form.txr
new file mode 100644
index 0000000..11adaa9
--- /dev/null
+++ b/alias-list-form.txr
@@ -0,0 +1,84 @@
+@(define alias-list-form (userid))
+@  (load-aliases userid aliases)
+@  (headers)
+@  (output)
+<!doctype html public "-//W3C//DTD HTML 4.01//EN">
+<html>
+<head>
+<title>Tamarind Throwaway Mail Alias Manager</title>
+@csslink
+</head>
+<body onload="document.aliaslist.memo.focus();">
+<h2>Welcome to Tamarind, @userid!</h2>
+<form name="logout" method="post" action="?logout">
+  <div>
+    <input type="submit" name="logout" value="Log Out">
+  </div>
+</form>
+<h3>Your mail aliases:</h2>
+<form name="aliaslist" method="post" action="?update-aliases">
+@  (end)
+@  (if aliases)
+@    (output)
+  <div>
+    <table cellspacing="10">
+      <tr>
+        <th align="right">
+          <input type="button" name="delete" value="Del" onclick="submit();"
+                 title="Permantently delete the checkboxed aliases."></th>
+        <th align="left">Alias</th>
+        <th align="left">Date Created</th>
+        <th align="left">Memo</th>
+      </tr>
+@(repeat :vars (aliases))
+      <tr>
+        <td align="center">
+          <input type="checkbox" name="chkbox-@{aliases.address}"
+                 title="Check this box if you wish to delete this alias. @\
+                        You can check multiple aliases and then delete @\
+                        them at the same time with @\
+                        the Del button above."></td>
+        <td><a href="mailto:@{aliases.address}@@@domain"
+               title="This is an e-mail alias. Messages sent to this @\
+                      address are delivered to your @userid@@@domain @\
+                      inbox.  You can tell these messages are for the @\
+                      alias because they are addressed @\
+                      To: <@{aliases.address}@@@domain>. If you @\
+                      delete the alias, it can no longer be used to @\
+                      send you e-mail. Attempts to send e-mail to a deleted @\
+                      alias result in a non-delivery notice (bounce).">@\
+            @{aliases.address}@@@domain</a></td>
+        <td>@(time-string-local aliases.creation-time "%Y-%m-%d %H:%M %Z")</td>
+        <td>@{aliases.(get-html-memo)}&nbsp;@\
+            <sup>[<a href="?edit=@{aliases.address}">edit</a>]</sup></td>
+      </tr>
+@(end)
+    </table>
+  </div>
+  <div>
+  </div>
+@    (end)
+@  (else)
+@    (output)
+  <p>You have none. Use the field and button below to create one.</p>
+@    (end)
+@  (end)
+@  (output)
+  <div>
+    <label for="memo">Memo:</label>
+    <input type="text" name="memo" value="" size="60"
+           title="When you click Create New to generate a new @\
+                  e-mail alias, information entered into this box @\
+                  will be associated with that alias. Use it to track @\
+                  the purpose of the alias, such as who it was given @\
+                  to (which web site or vendor and so forth). Do not @\
+                  include the date; aliases are dated.">
+    <input type="submit" name="create" value="Create New"
+           title="Create a new random e-mail alias, @\
+                  with the Memo attached.">
+  </div>
+</form>
+</body>
+</html>
+@  (end)
+@(end)
diff --git a/aliases.txr b/aliases.txr
new file mode 100644
index 0000000..38a52d6
--- /dev/null
+++ b/aliases.txr
@@ -0,0 +1,133 @@
+@(do
+   (defstruct (alias address memo creation-time) nil
+     address memo creation-time
+     (:postinit (alias)
+       (ifa (stringp alias.creation-time)
+         (set it (int-str it))))
+     (:method equal (alias) alias.address)
+     (:method get-decoded-memo (alias)
+       (url-decode alias.memo))
+     (:method get-html-memo (alias)
+       (let* ((mem alias.(get-decoded-memo))
+              (html (html-encode mem)))
+         (ifa (< (length mem) 60)
+           html
+           `<span title="@(html-encode mem)">         \
+              @(html-encode [mem 0..27])            \ \
+              [<a href="mailto:@mem"                  \
+                  onclick="return false;">...</a>]  \ \
+              @(html-encode [mem -27..t])</span>`)))))
+@(define load-aliases (user aliases))
+@  (local time memo)
+@  (bind lock @(acquire-lock "/etc/aliases"))
+@  (try)
+@    (next "/etc/aliases")
+@    (maybe)
+@      (skip)
+# aliases for @user
+@      (collect :vars (aliases))
+# memo @memo
+# created @time
+@address: @user
+@        (bind aliases @(new (alias address memo time)))
+@      (until)
+# end
+@      (end)
+@    (or)
+@      (bind aliases nil)
+@    (end)
+@  (finally)
+@    (do (release-lock lock))
+@  (end)
+@(end)
+@;
+@(define store-aliases (user aliases))
+@  (local before oldaliases after)
+@  (bind lock @(acquire-lock "/etc/aliases"))
+@  (try)
+@    (next "/etc/aliases")
+@    (collect)
+@before
+@    (last)
+# aliases for @user
+@    (end)
+@    (collect)
+@oldaliases
+@    (until)
+# aliases for @(skip)
+@    (end)
+@    (collect)
+@after
+@    (end)
+@    (output "/etc/aliases.tmp" :named out)
+@      (repeat)
+@before
+@      (end)
+# aliases for @user
+@      (repeat :vars (aliases))
+# memo @{aliases.memo}
+# created @{aliases.creation-time}
+@{aliases.address}: @user
+@      (end)
+# end
+@      (repeat)
+@after
+@      (end)
+@    (end)
+@    (do
+       (let ((backup-stamp (time-string-local (time) "%Y%m%d-%H%M")))
+         (each* ((j (range 30 0))
+                 (i (rest j)))
+           (if (path-file-p `/etc/aliases.@i`)
+             (rename-path `/etc/aliases.@i` `/etc/aliases.@j`)))
+         (rename-path "/etc/aliases" "/etc/aliases.0")
+         (rename-path "/etc/aliases.tmp" "/etc/aliases")))
+@  (finally)
+@    (do (release-lock lock))
+@  (end)
+@(end)
+@;
+@(define invent-alias (alias))
+@(bind alias @(let ((n1 (rand 1000))
+                    (n2 (rand 1000))
+                    (n3 (rand 10000)))
+                (format nil `~,03s-~,03s-~,04s` n1 n2 n3)))
+@(end)
+@;
+@(define update-aliases (userid postdata))
+@  (local memo aliases delaliases)
+@  (bind url-args @(split-str postdata "&"))
+@  (next :list url-args)
+@  (collect :vars (delaliases))
+chkbox-@delaliases=on
+@  (end)
+@  (next :list url-args)
+@  (gather)
+memo=@memo
+@  (end)
+@  (next :list url-args)
+@  (cases)
+@    (skip)
+create=@(skip)
+@    (load-aliases userid aliases)
+@    (invent-alias new-address)
+@    (do (push (new (alias new-address memo (time))) aliases))
+@    (store-aliases userid aliases)
+@  (or)
+@    (load-aliases userid aliases)
+@    (store-aliases userid @[set-diff aliases delaliases equal])
+@  (end)
+@(end)
+@;
+@(define update-memo (userid edit-alias new-memo))
+@  (local aliases)
+@  (load-aliases userid aliases)
+@  (bind existing-alias @(find edit-alias aliases))
+@  (if existing-alias)
+@    (do (set existing-alias.memo new-memo))
+@    (store-aliases userid aliases)
+@    (alias-list-form userid)
+@  (else)
+@    (error-form "Not Found" `Alias @{edit-alias} doesn't seem to exist!`)
+@  (end)
+@(end)
diff --git a/auth.txr b/auth.txr
new file mode 100644
index 0000000..f2c062e
--- /dev/null
+++ b/auth.txr
@@ -0,0 +1,19 @@
+@(do
+  (defun put-binary-str (str stream)
+    (let ((len (length str)))
+      (put-byte (trunc len 256) stream)
+      (put-byte (mod len 256) stream)
+      (put-string str stream)))
+
+  (defun sasl-auth (user pass)
+    (let ((sock (open-socket af-unix sock-stream)))
+      (sock-connect sock (new sockaddr-un path "/var/run/saslauthd/mux"))
+      (put-binary-str user sock)
+      (put-binary-str pass sock)
+      (put-binary-str "" sock)
+      (put-binary-str "" sock)
+      (let ((response (get-string sock)))
+        (equal [response 2..4] "OK")))))
+@(define auth (userid password))
+@  (require (sasl-auth userid password))
+@(end)
diff --git a/edit-memo-form.txr b/edit-memo-form.txr
new file mode 100644
index 0000000..36e1679
--- /dev/null
+++ b/edit-memo-form.txr
@@ -0,0 +1,34 @@
+@(define edit-memo-form (userid edit-alias))
+@  (local alias)
+@  (load-aliases userid aliases)
+@  (headers)
+@  (output)
+<!doctype html public "-//W3C//DTD HTML 4.01//EN">
+<html>
+<head>
+<title>Tamarind Throwaway Mail Alias Manager</title>
+@csslink
+</head>
+<body onload="document.editmemo.memo.focus();">
+<h2>Edit the memo for @{edit-alias}</h2>
+<form name="editmemo" method="post" action="?update-memo&@{edit-alias}">
+@  (end)
+@  (bind alias @(find edit-alias aliases))
+@  (if alias)
+@    (output)
+  <div>
+    <label for="memo">Memo:</label>
+    <input type="text" name="memo" @\
+           value="@{alias.(get-decoded-memo)}" size="60">
+    <input type="submit" name="update" value="Update">
+  </div>
+</form>
+</body>
+</html>
+@    (end)
+@  (else)
+@    (output)
+<h2>Oops, something is wrong: @{edit-alias} doesn't seem to exist.</h2>
+@    (end)
+@  (end)
+@(end)
diff --git a/error-form.txr b/error-form.txr
new file mode 100644
index 0000000..3982a6f
--- /dev/null
+++ b/error-form.txr
@@ -0,0 +1,22 @@
+@(define error-form (heading message))
+@  (headers)
+@  (next :env)
+@  (skip)
+REDIRECT_URL=@self
+@  (output)
+<!doctype html public "-//W3C//DTD HTML 4.01//EN">
+<html>
+<head>
+<title>Error!</title>
+@csslink
+</head>
+<body>
+<h2>@heading</h2>
+
+<p>@message</p>
+
+Go <a href="@self">back</a> to main page.
+</body>
+</html>
+@  (end)
+@(end)
diff --git a/headers.txr b/headers.txr
new file mode 100644
index 0000000..c4d0c8e
--- /dev/null
+++ b/headers.txr
@@ -0,0 +1,22 @@
+@(do
+   (defstruct header nil
+     name
+     value
+     (:method equal (hdr) hdr.name))
+
+   (defvar custom-headers ()))
+@(define headers)
+@  (output)
+Content-type: text/html;charset=UTF-8
+@    (repeat :vars (custom-headers))
+@{custom-headers.name}: @{custom-headers.value}
+@    (end)
+
+@  (end)
+@(end)
+@(define replace-header (name val))
+@  (do (pushnew (new header name name value val) custom-headers))
+@(end)
+@(define add-header (name val))
+@  (do (push (new header name name value val) custom-headers))
+@(end)
diff --git a/lockdir.tl b/lockdir.tl
new file mode 100644
index 0000000..3d6fe0f
--- /dev/null
+++ b/lockdir.tl
@@ -0,0 +1,19 @@
+(defun acquire-lock (path)
+  (let ((lock `@path.#lock#`)
+        (start-time (time)))
+    (while (< (- (time) start-time) 30)
+      (catch (if (mkdir lock #o700)
+               (return-from acquire-lock lock))
+        (file-error (e)
+          (unless (= 17 (errno))
+            (throw 'file-error e))
+          (usleep 1000000))))
+    (error "acquire-lock: unable to acquire ~a" lock))) 
+
+(defun release-lock (lock)
+  (ignerr (remove-path lock)))
+
+(defmacro with-lock (path . body)
+  (let ((lock (gensym)))
+    ^(with-resources ((,lock (acquire-lock ,path) (release-lock ,lock)))
+       ,*body)))
diff --git a/logging.txr b/logging.txr
new file mode 100644
index 0000000..77d98ad
--- /dev/null
+++ b/logging.txr
@@ -0,0 +1,13 @@
+@(do
+   (openlog "tamarind" log-pid log-daemon))
+@(if debug-enable)
+@  (define dbg (string))
+@    (do (syslog log-debug "~a" string))
+@  (end)
+@(else)
+@  (define dbg (string))
+@  (end)
+@(end)
+@(define inf (string))
+@  (do (syslog log-info "~a" string))
+@(end)
diff --git a/login-form.txr b/login-form.txr
new file mode 100644
index 0000000..0e1fde7
--- /dev/null
+++ b/login-form.txr
@@ -0,0 +1,31 @@
+@(define login-form (message))
+@  (headers)
+@  (output)
+<!doctype html public "-//W3C//DTD HTML 4.01//EN">
+<html>
+<head>
+<title>Login to Tamarind</title>
+@csslink
+</head>
+<body onload="document.login.userid.focus();">
+@(if message `<H2>@message</H2>`)
+<form name="login" method="post" action="?auth">
+  <table cellspacing="7">
+    <tr>
+      <td><label for="userid">Userid:</label></td>
+      <td><input type="text" name="userid" value=""></td>
+    </tr>
+    <tr>
+      <td><label for="password">Password:</label></td>
+      <td><input type="password" name="password" value=""></td>
+    </tr>
+  </table>
+  <br>
+  <div>
+    <input type="submit" value="Login">
+  </div>
+</form>
+</body>
+</html>
+@  (end)
+@(end)
diff --git a/main.txr b/main.txr
new file mode 100755
index 0000000..cc364c7
--- /dev/null
+++ b/main.txr
@@ -0,0 +1,79 @@
+#!/usr/local/bin/txr
+@(next :args)
+@(bind debug-enable t)
+@(load "logging")
+@(load "headers")
+@(load "auth")
+@(load "session")
+@(load "lockdir")
+@(load "random")
+@(load "aliases")
+@(load "login-form")
+@(load "error-form")
+@(load "alias-list-form")
+@(load "edit-memo-form")
+@(load "startup")
+@(bind csslink "")
+@(do (randomize))
+@(startup domain)
+@(next :env)
+@(gather :vars (clientip (cookie-userid nil) (cookie-sessid nil)))
+REMOTE_ADDR=@clientip
+@(sess-cookie cookie-userid cookie-sessid)
+@(end)
+@(check-session session-valid-p cookie-userid cookie-sessid clientip)
+@(next :env)
+@(if session-valid-p)
+@  (skip)
+@  (cases)
+QUERY_STRING=logout
+@    (remove-session cookie-userid)
+@    (login-form "Logged out; you may log in again.")
+@  (or)
+QUERY_STRING=update-aliases
+@    (next *stdin*)
+@postdata
+@    (cases)
+@      (update-aliases cookie-userid postdata)
+@      (alias-list-form cookie-userid)
+@    (or)
+@      (error-form "Invalid input" `Unable to parse POST data: @postdata`)
+@    (end)
+@  (or)
+QUERY_STRING=edit=@{edit-alias}
+@    (edit-memo-form cookie-userid edit-alias)
+@  (or)
+QUERY_STRING=update-memo&@{edit-alias}
+@    (cases)
+@      (next *stdin*)
+memo=@{new-memo}&@(skip)
+@      (update-memo cookie-userid edit-alias new-memo)
+@    (or)
+@      (error-form "Invalid input" `Unable to parse POST data`)
+@    (end)
+@  (or)
+QUERY_STRING=@(skip)
+@    (alias-list-form cookie-userid)
+@  (end)
+@(else)
+@  (skip)
+@  (cases)
+QUERY_STRING=auth
+@    (cases)
+@      (next *stdin*)
+userid=@userid&password=@password
+@      (set password @(url-decode password))
+@      (auth userid password)
+@      (ensure-session userid clientip)
+@      (alias-list-form userid)
+@    (or)
+@      (login-form "Invalid login; try again!")
+@    (end)
+@  (or)
+QUERY_STRING=@(skip)
+@   (login-form @(if cookie-userid
+                   "Invalid or expired session; Please log in."
+                   "Please log in."))
+@  (end)
+@(end)
+@(do (save-random-state))
diff --git a/random.tl b/random.tl
new file mode 100644
index 0000000..3b188e4
--- /dev/null
+++ b/random.tl
@@ -0,0 +1,8 @@
+(defun get-urand-num (noctets)
+  (with-stream (s (open-file "/dev/urandom"))
+    (reduce-left (op + (* @1 256) @2) (take noctets (gun (get-byte s))))))
+
+(defun randomize ()
+  (set *random-state* (make-random-state (get-urand-num 8))))
+
+(defun save-random-state ())
diff --git a/session.txr b/session.txr
new file mode 100644
index 0000000..0a2b8a0
--- /dev/null
+++ b/session.txr
@@ -0,0 +1,29 @@
+@(define ensure-session (userid clientip))
+@  (do (ensure-dir ".sessions" #o700))
+@  (bind sessionid @(rand (expt 2 128)))
+@  (output `.sessions/@userid`)
+@userid @sessionid @clientip @(time)
+@  (end)
+@  (add-header "Set-Cookie" `tamarind-login=@userid:@sessionid`)
+@(end)
+@;
+@(define remove-session (userid))
+@  (do (ignerr (remove-path `.sessions/@userid`)))
+@  (add-header "Set-Cookie" `tamarind-login=;max-age=0`)
+@(end)
+@;
+@(define sess-cookie (userid sessionid))
+HTTP_COOKIE=@(skip)tamarind-login=@userid:@{sessionid /\d+/}@(skip)
+@(end)
+@;
+@(define check-session (valid-p userid sessid clientip))
+@  (cases)
+@    (require (and userid sessid))
+@    (next `.sessions/@{userid}` :nothrow)
+@{userid} @{sessid} @clientip @timestamp
+@    (require (< (- (time) (int-str timestamp)) (* 3600 169)))
+@    (bind valid-p t)
+@  (or)
+@    (bind valid-p nil)
+@  (end)
+@(end)
diff --git a/startup.txr b/startup.txr
new file mode 100644
index 0000000..39ba7bc
--- /dev/null
+++ b/startup.txr
@@ -0,0 +1,21 @@
+@(define startup (domain))
+@  (cases)
+@    (next "/etc/mailname" :nothrow)
+@domain
+@  (or)
+@    (error-form "Configuration Missing" "Cannot read /etc/mailname file")
+@    (fail)
+@  (end)
+@  (if (not (zerop (geteuid))))
+@    (error-form "Installation Problem" "Wrong script permissions")
+@    (fail)
+@  (end)
+@  (cases)
+@    (next :env)
+@    (skip)
+HTTPS=on
+@  (or)
+@    (error-form "Security Problem" "Not redirected to HTTPS!")
+@    (fail)
+@  (end)
+@(end)
diff --git a/sutxr.cgi.c b/sutxr.cgi.c
new file mode 100644
index 0000000..02a4861
--- /dev/null
+++ b/sutxr.cgi.c
@@ -0,0 +1,10 @@
+#include <unistd.h>
+#include <stdlib.h>
+
+int main(void)
+{
+  execl("/usr/local/bin/txr",
+        "/usr/local/bin/txr",
+        PWD "/main.txr", (char *) 0);
+  return EXIT_FAILURE;
+}
author	Kaz Kylheku <kaz@kylheku.com>	2016-03-02 06:57:09 -0800
committer	Kaz Kylheku <kaz@kylheku.com>	2016-03-02 06:57:09 -0800
commit	92241abe22d0976d115fbd4caacbf5121d5d5c04 (patch)
tree	6336e561ea34d297a25413594a29f1a4359581be
parent	84ffdada07f03facc90cb7cfc6adacd19025d2c9 (diff)
download	tamarind-92241abe22d0976d115fbd4caacbf5121d5d5c04.tar.gz tamarind-92241abe22d0976d115fbd4caacbf5121d5d5c04.tar.bz2 tamarind-92241abe22d0976d115fbd4caacbf5121d5d5c04.zip