#!/usr/bin/wapptclsh
#
# This script implements a simple URL shortener backed by an SQLite database.
#
# For administrative access, this script must be invoked via the
# Fossil CGI extension mechanism:
#
# https://fossil-scm.org/home/doc/trunk/www/serverext.wiki
#
# That is because administrative access uses the FOSSIL_CAPABILITIES and
# FOSSIL_USER environment variables. However, for ordinary shortener
# redirects, this routine can be run as an ordinary CGI. So the intended
# use case is:
#
# 1. Set up a CGI (perhaps called just "/u") on the website to act
# as the normal redirect site.
#
# 2. Set up a separate CGI (at something like "/fossil/ext/urlshortener")
# uses the same database as (1) and serving as the administration
# point for creating, editing, and deleting short URLs.
#
#
########
#
# Setup:
set BASEURL https://sqlite.org/u
set ADMIN_CAPABILITY i
set DATABASE /url-shortener.db
#
########
package require wapp
# Open the shortener database. Initialize it if necessary.
#
proc open-database {} {
global DATABASE
sqlite3 db $DATABASE
db eval {
CREATE TABLE IF NOT EXISTS url(
name TEXT PRIMARY KEY,
redir TEXT,
user TEXT,
ctime DATE,
mtime DATE,
notes TEXT
) WITHOUT ROWID;
}
}
# Debugging: show the environment
proc wapp-page-env {} {
wapp-allow-xorigin-params
wapp-trim {
<h1>Wapp Environment</h1>
<pre>%html([wapp-debug-env])</pre>
}
}
# Issue the "Not Found" page
proc wapp-page-notfound {} {
wapp-reply-code "404 Not Found"
wapp-trim {
<h1>Not Found</h1>
<p>No such resource:
"%html%([wapp-param BASE_URL])%%html%([wapp-param PATH_INFO])%"</p>
}
}
# Do a redirect
proc wapp-default {} {
set x [wapp-param PATH_HEAD {}]
if {$x==""} {
wapp-page-search
return
}
open-database
set redir [db one {SELECT redir FROM url WHERE name=$x}]
if {$redir==""} {
wapp-page-notfound
return
}
wapp-redirect $redir
}
# Check credentials. Return true to abort because credentials
# are invalid.
#
proc check-credentials {} {
global ADMIN_CAPABILITY env
if {![info exists env(FOSSIL_CAPABILITIES)]} {
wapp-page-notfound
return 1
}
return 0
}
# Search for an existing entry
#
proc wapp-page-search {} {
if {[check-credentials]} return
set base [wapp-param BASE_URL]
wapp-trim {
<h1>Admin URL Shortener At %html%($::DATABASE)%</h1>
<p><a href="%url($base)/editentry">Create-New-URL</a>
<p>
<form>
Search: <input type="text" size="60" name="s">
<input type="submit" name="s1" value="Go">
</form>
}
if {[wapp-param-exists s]} {
set s [wapp-param s]
wapp-trim {
<h2>Search results for %html($s):</h2><ol>
}
open-database
set pattern %$s%
set cnt 0
db eval {
SELECT name, redir FROM url
WHERE name LIKE $pattern OR redir LIKE $pattern
} {
wapp-trim {
<li><a href="%url($base)/editentry/%url($name)">%html($name)</a>
}
incr cnt
}
wapp-trim {</ol>}
if {$cnt==0} {
wapp-trim {
<p>No matches found</p>
}
}
}
}
# Create or edit a new URL shortener entry.
#
# Name of the entry to be editted is in PATH_TAIL. Or if PATH_TAIL is
# blank, create a new entry.
#
proc wapp-page-editentry {} {
global BASEURL
if {[check-credentials]} return
if {[wapp-param-exists cancel]} {
wapp-redirect [wapp-param BASEURL]/search
return
}
open-database
set hardname [wapp-param PATH_TAIL {}]
set name [wapp-param name $hardname]
set redir [wapp-param redir {}]
set notes [wapp-param notes {}]
wapp-trim {
<head></head>
<body>
}
set errmsg {}
if {[wapp-param-exists s1]} {
if {$hardname==""} {
set e [db one {SELECT count(*) FROM url WHERE name=$name}]
if {$e==1} {
set errmsg "Shortened URL name "$name" already exists.\
Pick a different name."
} elseif {[string length $name]<4} {
set errmsg "Shortened URL name "$name" too short.\
Must be at least 4 characters."
} elseif {[regexp {[^a-z0-9]} $name]} {
set errmsg "Shortened URL name "$name" contains invalid characters. \
The name must be lower-case ASCII letters and digits only."
} else {
set user $::env(FOSSIL_USER)
db eval {
INSERT INTO url(name,redir,user,notes,ctime,mtime)
VALUES($name,$redir,$user,$notes,datetime(),datetime())
}
set hardname $name
}
} else {
db eval {
UPDATE url SET redir=$redir, notes=$notes, mtime=datetime()
WHERE name=$name
}
}
}
set ctime {}
set user {}
set mtime {}
if {$hardname==""} {
wapp-trim {
<h1>Create A New Shortened URL</h1>
}
if {$errmsg!=""} {
wapp-trim {
<p style='color:red;'>%html($errmsg)</p>
}
}
wapp-trim {
<form method="POST">
<table border="0" cellpadding="0" cellspacing="10">
<tr>
<td align="right">Shortened-URL:</td>
<td>%html($BASEURL)/<input type="text" name="name" value="%html($name)" size="10">
</tr>
}
} else {
wapp-trim {
<h1>Edit Shortened URL: %html($BASEURL)/%html($hardname)</h1>
<form method="POST">
<input type="hidden" name="name" value="%html($hardname)">
<table border="0" cellpadding="0" cellspacing="10">
<tr>
<td align="right">Shortened-URL:</td>
<td>%html($BASEURL)/%html($hardname)
</tr>
}
db eval {
SELECT ctime, mtime, user, redir, notes FROM url WHERE name=$name
} break
set redir [wapp-param redir $redir]
set notes [wapp-param notes $notes]
}
wapp-trim {
<tr>
<td align="right">Redirect-To:</td>
<td><input type="text" name="redir" value="%html($redir)" size="70"></td>
</tr>
}
if {$ctime!=""} {
if {$user==""} {set user ???}
wapp-trim {
<tr><td align="right">Created:</td>
<td>%html($ctime) by %html($user)</td></tr>
}
}
if {$mtime!="" && $mtime!=$ctime} {
wapp-trim {
<tr><td align="right">Modified:</td><td>%html($ctime)</td></tr>
}
}
wapp-trim {
<tr>
<td align="right">Notes:</td>
<td><input type="text" name="notes" value="%html($notes)" size="70"></td>
</tr>
<tr>
<td> </td>
<td><input type="submit" name="s1" value="Submit">
<input type="submit" name="cancel" value="Cancel">
</tr>
</table>
</form>
}
}
wapp-start $argv