extra/webapps/wee-url/wee-url.factor

   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 ;
   9 IN: webapps.wee-url
  10
  11 TUPLE: wee-url < dispatcher ;
  12
  13 TUPLE: short-url short url ;
  14
  15 short-url "SHORT_URLS" {
  16     { "short" "SHORT" TEXT +user-assigned-id+ }
  17     { "url" "URL" TEXT +not-null+ }
  18 } define-persistent
  19
  20 : letter-bank ( -- seq )
  21     CHAR: a CHAR: z [a,b]
  22     CHAR: A CHAR: Z [a,b]
  23     CHAR: 1 CHAR: 0 [a,b]
  24     3append ; foldable
  25
  26 : random-url ( -- string )
  27     1 6 [a,b] random [ letter-bank random ] "" replicate-as ;
  28
  29 : retry ( quot: ( -- ? )  n -- )
  30     swap [ drop ] prepose attempt-all ; inline
  31
  32 : insert-short-url ( short-url -- short-url )
  33     '[ _ dup random-url >>short insert-tuple ] 10 retry ;
  34
  35 : shorten ( url -- short )
  36     short-url new swap >>url dup select-tuple
  37     [ ] [ insert-short-url ] ?if short>> ;
  38
  39 : short>url ( short -- url )
  40     "$wee-url/go/" prepend >url adjust-url ;
  41
  42 : expand-url ( string -- url )
  43     short-url new swap >>short select-tuple url>> ;
  44
  45 : <shorten-action> ( -- action )
  46     <page-action>
  47         { wee-url "shorten" } >>template
  48         [ { { "url" [ v-url ] } } validate-params ] >>validate
  49         [
  50             "$wee-url/show/" "url" value shorten append >url <redirect>
  51         ] >>submit ;
  52
  53 : <show-action> ( -- action )
  54     <page-action>
  55         "short" >>rest
  56         [
  57             { { "short" [ v-one-word ] } } validate-params
  58             "short" value expand-url "url" set-value
  59             "short" value short>url "short" set-value
  60         ] >>init
  61         { wee-url "show" } >>template ;
  62
  63 : <go-action> ( -- action )
  64     <action>
  65         "short" >>rest
  66         [ { { "short" [ v-one-word ] } } validate-params ] >>init
  67         [ "short" value expand-url <redirect> ] >>display ;
  68
  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
  74     <boilerplate>
  75         { wee-url "wee-url" } >>template ;