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: accessors continuations db.tuples db.types fry furnace.actions
   5 furnace.boilerplate furnace.redirection furnace.utilities html.forms
   6 http.server.dispatchers kernel math ranges random random.data
   7 sequences urls validators ;
   8 IN: webapps.wee-url
   9
  10 TUPLE: wee-url < dispatcher ;
  11
  12 TUPLE: short-url short url ;
  13
  14 short-url "SHORT_URLS" {
  15     { "short" "SHORT" TEXT +user-assigned-id+ }
  16     { "url" "URL" TEXT +not-null+ }
  17 } define-persistent
  18
  19 : random-url ( -- string )
  20     6 random 1 + random-string ;
  21
  22 : retry ( quot: ( -- ? )  n -- )
  23     swap [ drop ] prepose attempt-all ; inline
  24
  25 : insert-short-url ( short-url -- short-url )
  26     '[ _ dup random-url >>short insert-tuple ] 10 retry ;
  27
  28 : shorten ( url -- short )
  29     short-url new swap >>url dup select-tuple
  30     [ ] [ insert-short-url ] ?if short>> ;
  31
  32 : short>url ( short -- url )
  33     "$wee-url/go/" prepend >url adjust-url ;
  34
  35 : expand-url ( string -- url )
  36     short-url new swap >>short select-tuple url>> ;
  37
  38 : <shorten-action> ( -- action )
  39     <page-action>
  40         { wee-url "shorten" } >>template
  41         [ { { "url" [ v-url ] } } validate-params ] >>validate
  42         [
  43             "$wee-url/show/" "url" value shorten append >url <redirect>
  44         ] >>submit ;
  45
  46 : <show-action> ( -- action )
  47     <page-action>
  48         "short" >>rest
  49         [
  50             { { "short" [ v-one-word ] } } validate-params
  51             "short" value expand-url "url" set-value
  52             "short" value short>url "short" set-value
  53         ] >>init
  54         { wee-url "show" } >>template ;
  55
  56 : <go-action> ( -- action )
  57     <action>
  58         "short" >>rest
  59         [ { { "short" [ v-one-word ] } } validate-params ] >>init
  60         [ "short" value expand-url <redirect> ] >>display ;
  61
  62 : <wee-url> ( -- wee-url )
  63     wee-url new-dispatcher
  64         <shorten-action> "" add-responder
  65         <show-action> "show" add-responder
  66         <go-action> "go" add-responder
  67     <boilerplate>
  68         { wee-url "wee-url" } >>template ;