Wapp

Check-in [3e71cc718c]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:First prototype of a URL shortener script.
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: 3e71cc718ced291ea5e0f3843a19b2494cde675feb2e28b294bf6dd72f782a0a
User & Date: drh 2024-05-19 20:15:58.335
Context
2024-05-19
20:46
Updates and fixes to the url-shortener.tcl demo (check-in: e74cb059e3 user: drh tags: trunk)
20:15
First prototype of a URL shortener script. (check-in: 3e71cc718c user: drh tags: trunk)
2024-04-14
19:36
Update the built-in SQLite to the latest 3.46.0 alpha version. (check-in: 3dfe5da86a user: drh tags: trunk)
Changes
Side-by-Side Diff Ignore Whitespace Patch
Added examples/url-shortener.tcl. 

































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

#!/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>&nbsp</td>
    <td><input type="submit" name="s1" value="Submit">
    <input type="submit" name="cancel" value="Cancel">
    </tr>
    </table>
    </form>
  }
}

wapp-start $argv