unmaintained/wee-url/responder.factor

   1 ! Copyright (C) 2006 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: generic assocs help html httpd
   4 io kernel math namespaces prettyprint sequences store strings ;
   5 IN: wee-url-responder
   6
   7 SYMBOL: wee-shortcuts
   8 SYMBOL: wee-store
   9
  10 "wee-url.store" load-store wee-store set-global
  11 H{ } clone wee-shortcuts wee-store get store-variable
  12
  13 : responder-url "responder-url" get ;
  14
  15 : wee-url ( string -- url )
  16     [
  17         "http://" %
  18         host %
  19         responder-url %
  20         %
  21     ] "" make ;
  22
  23 : letter-bank
  24     "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" ;
  25
  26 : random-letter letter-bank length random letter-bank nth ;
  27
  28 : random-url ( -- string )
  29     6 random 1+ [ drop random-letter ] map >string
  30     dup wee-shortcuts get key? [ drop random-url ] when ;
  31
  32 : prepare-wee-url ( url -- url )
  33     CHAR: : over member? [ "http://" swap append ] unless ;
  34
  35 : set-symmetric-hash ( obj1 obj2 hash -- )
  36     3dup set-at swapd set-at ;
  37
  38 : add-shortcut ( url-long -- url-short )
  39     dup wee-shortcuts get at* [
  40         nip
  41     ] [
  42         drop
  43         random-url [ wee-shortcuts get set-symmetric-hash ] keep
  44         wee-store get save-store
  45     ] if ;
  46
  47 : url-prompt ( -- )
  48     serving-html
  49     "wee-url.com - wee URLs since 2007" [
  50         <form "get" =method responder-url =action form>
  51             "URL: " write
  52             <input "text" =type "url" =name input/>
  53             <input "submit" =type "Submit" =value input/>
  54         </form>
  55     ] simple-html-document ;
  56
  57 : url-submitted ( url-long url-short -- )
  58     "URL Submitted" [
  59         "URL: " write write nl
  60         "wee-url: " write
  61         <a dup wee-url =href a> wee-url write </a> nl
  62         "Back to " write
  63         <a responder-url =href a> "wee-url" write </a> nl
  64     ] simple-html-document ;
  65
  66 : url-submit ( url -- )
  67     serving-html
  68     prepare-wee-url [ add-shortcut ] keep url-submitted ;
  69
  70 : url-error ( -- )
  71     serving-html
  72     "wee-url error" [
  73         "No such link." write
  74     ] simple-html-document ;
  75
  76 : wee-url-responder ( url -- )
  77     "url" query-param [
  78         url-submit drop
  79     ] [
  80         dup empty? [
  81             drop url-prompt
  82         ] [
  83             wee-shortcuts get at*
  84             [ permanent-redirect ] [ drop url-error ] if
  85         ] if
  86     ] if* ;
  87
  88 [
  89     "wee-url" "responder" set
  90     [ wee-url-responder ] "get" set
  91 ] make-responder