1 ! Copyright (C) 2007 Doug Coleman.
2 ! Copyright (C) 2008 Slava Pestov.
3 ! See http://factorcode.org/license.txt for BSD license.
4 USING: math.ranges sequences random accessors
5 kernel namespaces fry db.types db.tuples urls validators
6 html.components html.forms http http.server.dispatchers furnace
7 furnace.actions furnace.boilerplate furnace.redirection
8 furnace.utilities continuations ;
11 TUPLE: wee-url < dispatcher ;
13 TUPLE: short-url short url ;
15 short-url "SHORT_URLS" {
16 { "short" "SHORT" TEXT +user-assigned-id+ }
17 { "url" "URL" TEXT +not-null+ }
20 : letter-bank ( -- seq )
26 : random-url ( -- string )
27 1 6 [a,b] random [ letter-bank random ] "" replicate-as ;
29 : retry ( quot: ( -- ? ) n -- )
30 swap [ drop ] prepose attempt-all ; inline
32 : insert-short-url ( short-url -- short-url )
33 '[ _ dup random-url >>short insert-tuple ] 10 retry ;
35 : shorten ( url -- short )
36 short-url new swap >>url dup select-tuple
37 [ ] [ insert-short-url ] ?if short>> ;
39 : short>url ( short -- url )
40 "$wee-url/go/" prepend >url adjust-url ;
42 : expand-url ( string -- url )
43 short-url new swap >>short select-tuple url>> ;
45 : <shorten-action> ( -- action )
47 { wee-url "shorten" } >>template
48 [ { { "url" [ v-url ] } } validate-params ] >>validate
50 "$wee-url/show/" "url" value shorten append >url <redirect>
53 : <show-action> ( -- action )
57 { { "short" [ v-one-word ] } } validate-params
58 "short" value expand-url "url" set-value
59 "short" value short>url "short" set-value
61 { wee-url "show" } >>template ;
63 : <go-action> ( -- action )
66 [ { { "short" [ v-one-word ] } } validate-params ] >>init
67 [ "short" value expand-url <redirect> ] >>display ;
69 : <wee-url> ( -- wee-url )
70 wee-url new-dispatcher
71 <shorten-action> "" add-responder
72 <show-action> "show" add-responder
73 <go-action> "go" add-responder
75 { wee-url "wee-url" } >>template ;