Port old Wee-URL web app to new framework

diff --git a/extra/webapps/wee-url/shorten.xml b/extra/webapps/wee-url/shorten.xml
new file mode 100644 (file)
index 0000000..8df7774
--- /dev/null
+++ b/extra/webapps/wee-url/shorten.xml
@@ -0,0 +1,10 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+        <t:form t:action="$wee-url">
+               <p>Shorten URL: <t:field t:name="url" t:size="40" /></p>
+               <input type="submit" value="Shorten" />
+       </t:form>
+
+</t:chloe>

diff --git a/extra/webapps/wee-url/show.xml b/extra/webapps/wee-url/show.xml
new file mode 100644 (file)
index 0000000..ba44629
--- /dev/null
+++ b/extra/webapps/wee-url/show.xml
@@ -0,0 +1,11 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+       <p>The URL:</p>
+       <blockquote><t:link t:name="url" /></blockquote>
+       <p>has been shortened to:</p>
+       <blockquote><t:link t:name="short" /></blockquote>
+       <p>enjoy!</p>
+
+</t:chloe>

diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor
new file mode 100644 (file)
index 0000000..afdacf9
--- /dev/null
+++ b/extra/webapps/wee-url/wee-url.factor
@@ -0,0 +1,74 @@
+! Copyright (C) 2007 Doug Coleman.
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math.ranges sequences random accessors combinators.lib
+kernel namespaces fry db.types db.tuples urls validators
+html.components http http.server.dispatchers furnace
+furnace.actions furnace.boilerplate ;
+IN: webapps.wee-url
+
+TUPLE: wee-url < dispatcher ;
+
+TUPLE: short-url short url ;
+
+short-url "SHORT_URLS" {
+    { "short" "SHORT" TEXT +user-assigned-id+ }
+    { "url" "URL" TEXT +not-null+ }
+} define-persistent
+
+: init-short-url-table ( -- )
+    short-url ensure-table ;
+
+: letter-bank ( -- seq )
+    CHAR: a CHAR: z [a,b]
+    CHAR: A CHAR: Z [a,b]
+    CHAR: 1 CHAR: 0 [a,b]
+    3append ; foldable
+
+: random-url ( -- string )
+    1 6 [a,b] random [ drop letter-bank random ] "" map-as ;
+
+: insert-short-url ( short-url -- short-url )
+    '[ , dup random-url >>short insert-tuple ] 10 retry ;
+
+: shorten ( url -- short )
+    short-url new swap >>url dup select-tuple
+    [ ] [ insert-short-url ] ?if short>> ;
+
+: short>url ( short -- url )
+    "$wee-url/go/" prepend >url adjust-url ;
+
+: expand-url ( string -- url )
+    short-url new swap >>short select-tuple url>> ;
+
+: <shorten-action> ( -- action )
+    <page-action>
+        { wee-url "shorten" } >>template
+        [ { { "url" [ v-url ] } } validate-params ] >>validate
+        [
+            "$wee-url/show/" "url" value shorten append >url <redirect>
+        ] >>submit ;
+
+: <show-action> ( -- action )
+    <page-action>
+        "short" >>rest
+        [
+            { { "short" [ v-one-word ] } } validate-params
+            "short" value expand-url "url" set-value
+            "short" value short>url "short" set-value
+        ] >>init
+        { wee-url "show" } >>template ;
+
+: <go-action> ( -- action )
+    <action>
+        "short" >>rest
+        [ { { "short" [ v-one-word ] } } validate-params ] >>init
+        [ "short" value expand-url <redirect> ] >>display ;
+
+: <wee-url> ( -- wee-url )
+    wee-url new-dispatcher
+        <shorten-action> "" add-responder
+        <show-action> "show" add-responder
+        <go-action> "go" add-responder
+    <boilerplate>
+        { wee-url "wee-url" } >>template ;

diff --git a/extra/webapps/wee-url/wee-url.xml b/extra/webapps/wee-url/wee-url.xml
new file mode 100644 (file)
index 0000000..98d1095
--- /dev/null
+++ b/extra/webapps/wee-url/wee-url.xml
@@ -0,0 +1,13 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+       <t:title>WeeURL!</t:title>
+
+       <div class="navbar"><t:a t:href="$wee-url">Shorten URL</t:a></div>
+
+       <h1><t:write-title /></h1>
+
+        <t:call-next-template />
+
+</t:chloe>