90 lines
2.2 KiB
Factor
90 lines
2.2 KiB
Factor
! Copyright (C) 2007 Doug Coleman.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: assocs furnace html html.elements http.server
|
|
http.server.responders io kernel math math.ranges
|
|
namespaces random sequences store strings ;
|
|
IN: webapps.wee-url
|
|
|
|
SYMBOL: shortcuts
|
|
SYMBOL: store
|
|
|
|
! "wee-url.store" load-store store set-global
|
|
! H{ } clone shortcuts store get store-variable
|
|
|
|
: set-at-once ( value key assoc -- ? )
|
|
2dup key? [ 3drop f ] [ set-at t ] if ;
|
|
|
|
: responder-url "responder/wee-url" ;
|
|
|
|
: wee-url ( string -- url )
|
|
[
|
|
"http://" %
|
|
host %
|
|
responder-url %
|
|
%
|
|
] "" make ;
|
|
|
|
: letter-bank
|
|
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" ; inline
|
|
|
|
: random-url ( -- string )
|
|
1 6 [a,b] random [ drop letter-bank random ] "" map-as
|
|
dup shortcuts get key? [ drop random-url ] when ;
|
|
|
|
: add-shortcut ( url-long url-short -- url-short )
|
|
shortcuts get set-at-once [
|
|
store get save-store
|
|
] [
|
|
drop
|
|
] if ;
|
|
|
|
: show-submit ( -- )
|
|
serving-html
|
|
"wee-url.com - wee URLs since 2007" [
|
|
<form "get" =method "url-submit" =action form>
|
|
"URL: " write
|
|
<input "text" =type "url" =name input/>
|
|
<input "submit" =type "Submit" =value input/>
|
|
</form>
|
|
] simple-html-document ;
|
|
|
|
\ show-submit { } define-action
|
|
|
|
: url-submitted ( url-long url-short -- )
|
|
"URL Submitted" [
|
|
"URL: " write write nl
|
|
"wee-url: " write
|
|
<a dup wee-url =href a> wee-url write </a> nl
|
|
"Back to " write
|
|
<a responder-url =href a> "wee-url" write </a> nl
|
|
] simple-html-document ;
|
|
|
|
: url-submit ( url -- )
|
|
[ add-shortcut ] keep
|
|
url-submitted ;
|
|
|
|
\ url-submit {
|
|
{ "url" }
|
|
} define-action
|
|
|
|
: url-error ( -- )
|
|
serving-html
|
|
"wee-url error" [
|
|
"No such link." write
|
|
] simple-html-document ;
|
|
|
|
: wee-url-responder ( url -- )
|
|
"url" query-param [
|
|
url-submit drop
|
|
] [
|
|
dup empty? [
|
|
drop show-submit
|
|
] [
|
|
shortcuts get at*
|
|
[ permanent-redirect ] [ drop url-error ] if
|
|
] if
|
|
] if* ;
|
|
|
|
! "wee-url" "wee-url-responder" "extra/webapps/wee-url" web-app
|
|
~
|