diff --git a/unmaintained/assoc-heaps/assoc-heaps-tests.factor b/unmaintained/assoc-heaps/assoc-heaps-tests.factor deleted file mode 100644 index 24a7730847..0000000000 --- a/unmaintained/assoc-heaps/assoc-heaps-tests.factor +++ /dev/null @@ -1,55 +0,0 @@ -USING: assocs assoc-heaps heaps heaps.private kernel tools.test ; -IN: temporary - -[ -T{ - assoc-heap - f - H{ { 2 1 } } - T{ min-heap T{ heap f V{ { 1 2 } } } } -} -] [ H{ } clone 1 2 pick heap-push ] unit-test - -[ -T{ - assoc-heap - f - H{ { 1 0 } { 2 1 } } - T{ min-heap T{ heap f V{ { 0 1 } { 1 2 } } } } -} -] [ H{ } clone 1 2 pick heap-push 0 1 pick heap-push ] unit-test - -[ T{ assoc-heap f H{ } T{ min-heap T{ heap f V{ } } } } ] -[ - H{ } clone - 1 2 pick heap-push 0 1 pick heap-push - dup heap-pop 2drop dup heap-pop 2drop -] unit-test - - -[ 0 1 ] [ -T{ - assoc-heap - f - H{ { 1 0 } { 2 1 } } - T{ min-heap T{ heap f V{ { 0 1 } { 1 2 } } } } -} heap-pop -] unit-test - -[ 1 2 ] [ -T{ - assoc-heap - f - H{ { 1 0 } { 2 1 } } - T{ max-heap T{ heap f V{ { 1 2 } { 0 1 } } } } -} heap-pop -] unit-test - -[ -T{ - assoc-heap - f - H{ { 1 2 } { 3 4 } } - T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } } } } -} -] [ H{ { 1 2 } { 3 4 } } H{ } clone [ heap-push-all ] keep ] unit-test diff --git a/unmaintained/assoc-heaps/assoc-heaps.factor b/unmaintained/assoc-heaps/assoc-heaps.factor deleted file mode 100755 index 55a5aa7f62..0000000000 --- a/unmaintained/assoc-heaps/assoc-heaps.factor +++ /dev/null @@ -1,45 +0,0 @@ -USING: assocs heaps kernel sequences ; -IN: assoc-heaps - -TUPLE: assoc-heap assoc heap ; - -INSTANCE: assoc-heap assoc -INSTANCE: assoc-heap priority-queue - -C: assoc-heap - -: ( assoc -- obj ) ; -: ( assoc -- obj ) ; - -M: assoc-heap at* ( key assoc-heap -- value ? ) - assoc-heap-assoc at* ; - -M: assoc-heap assoc-size ( assoc-heap -- n ) - assoc-heap-assoc assoc-size ; - -TUPLE: assoc-heap-key-exists ; - -: check-key-exists ( key assoc-heap -- ) - assoc-heap-assoc key? - [ \ assoc-heap-key-exists construct-empty throw ] when ; - -M: assoc-heap set-at ( value key assoc-heap -- ) - [ check-key-exists ] 2keep - [ assoc-heap-assoc set-at ] 3keep - assoc-heap-heap swapd heap-push ; - -M: assoc-heap heap-empty? ( assoc-heap -- ? ) - assoc-heap-assoc assoc-empty? ; - -M: assoc-heap heap-length ( assoc-heap -- n ) - assoc-heap-assoc assoc-size ; - -M: assoc-heap heap-peek ( assoc-heap -- value key ) - assoc-heap-heap heap-peek ; - -M: assoc-heap heap-push ( value key assoc-heap -- ) - set-at ; - -M: assoc-heap heap-pop ( assoc-heap -- value key ) - dup assoc-heap-heap heap-pop swap - rot dupd assoc-heap-assoc delete-at ; diff --git a/unmaintained/assoc-heaps/authors.txt b/unmaintained/assoc-heaps/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/unmaintained/assoc-heaps/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/unmaintained/assoc-heaps/summary.txt b/unmaintained/assoc-heaps/summary.txt deleted file mode 100755 index 07ae2e33f8..0000000000 --- a/unmaintained/assoc-heaps/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Priority search queues diff --git a/unmaintained/webapps/help/authors.txt b/unmaintained/webapps/help/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/unmaintained/webapps/help/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/unmaintained/webapps/help/help.factor b/unmaintained/webapps/help/help.factor deleted file mode 100644 index 28d73607ba..0000000000 --- a/unmaintained/webapps/help/help.factor +++ /dev/null @@ -1,89 +0,0 @@ -! Copyright (C) 2005, 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel furnace furnace.validator http.server.responders - help help.topics html splitting sequences words strings - quotations macros vocabs tools.browser combinators - arrays io.files ; -IN: webapps.help - -! : string>topic ( string -- topic ) - ! " " split dup length 1 = [ first ] when ; - -: show-help ( topic -- ) - serving-html - dup article-title [ - [ help ] with-html-stream - ] simple-html-document ; - -\ show-help { - { "topic" } -} define-action -\ show-help { { "topic" "handbook" } } default-values - -M: link browser-link-href - link-name - dup word? over f eq? or [ - browser-link-href - ] [ - dup array? [ " " join ] when - [ show-help ] curry quot-link - ] if ; - -: show-word ( word vocab -- ) - lookup show-help ; - -\ show-word { - { "word" } - { "vocab" } -} define-action -\ show-word { { "word" "call" } { "vocab" "kernel" } } default-values - -M: f browser-link-href - drop \ f browser-link-href ; - -M: word browser-link-href - dup word-name swap word-vocabulary - [ show-word ] 2curry quot-link ; - -: show-vocab ( vocab -- ) - f >vocab-link show-help ; - -\ show-vocab { - { "vocab" } -} define-action - -\ show-vocab { { "vocab" "kernel" } } default-values - -M: vocab-spec browser-link-href - vocab-name [ show-vocab ] curry quot-link ; - -: show-vocabs-tagged ( tag -- ) - show-help ; - -\ show-vocabs-tagged { - { "tag" } -} define-action - -M: vocab-tag browser-link-href - vocab-tag-name [ show-vocabs-tagged ] curry quot-link ; - -: show-vocabs-by ( author -- ) - show-help ; - -\ show-vocabs-by { - { "author" } -} define-action - -M: vocab-author browser-link-href - vocab-author-name [ show-vocabs-by ] curry quot-link ; - -"help" "show-help" "extra/webapps/help" web-app - -! Hard-coding for factorcode.org -PREDICATE: pathname resource-pathname - pathname-string "resource:" head? ; - -M: resource-pathname browser-link-href - pathname-string - "resource:" ?head drop - "/responder/source/" swap append ; diff --git a/unmaintained/webapps/pastebin/annotate-paste.furnace b/unmaintained/webapps/pastebin/annotate-paste.furnace deleted file mode 100755 index 14a424f776..0000000000 --- a/unmaintained/webapps/pastebin/annotate-paste.furnace +++ /dev/null @@ -1,47 +0,0 @@ -<% USING: io math math.parser namespaces furnace ; %> - -

Annotate

- -
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Summary:" /><% "summary" "*Required" render-error %>
Your name:" /><% "author" "*Required" render-error %>
File type:<% "modes" render-template %>
<% "contents" "*Required" render-error %>
Content:
- -string write %>" /> - - -
diff --git a/unmaintained/webapps/pastebin/annotation.furnace b/unmaintained/webapps/pastebin/annotation.furnace deleted file mode 100755 index e59db32484..0000000000 --- a/unmaintained/webapps/pastebin/annotation.furnace +++ /dev/null @@ -1,11 +0,0 @@ -<% USING: namespaces io furnace calendar ; %> - -

Annotation: <% "summary" get write %>

- - - - - -
Annotation by:<% "author" get write %>
File type:<% "mode" get write %>
Created:<% "date" get timestamp>string write %>
- -<% "syntax" render-template %> diff --git a/unmaintained/webapps/pastebin/authors.txt b/unmaintained/webapps/pastebin/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/unmaintained/webapps/pastebin/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/unmaintained/webapps/pastebin/footer.furnace b/unmaintained/webapps/pastebin/footer.furnace deleted file mode 100644 index 15b90110a0..0000000000 --- a/unmaintained/webapps/pastebin/footer.furnace +++ /dev/null @@ -1,3 +0,0 @@ - - - diff --git a/unmaintained/webapps/pastebin/header.furnace b/unmaintained/webapps/pastebin/header.furnace deleted file mode 100644 index 2c8e79a18d..0000000000 --- a/unmaintained/webapps/pastebin/header.furnace +++ /dev/null @@ -1,23 +0,0 @@ -<% USING: namespaces io furnace sequences xmode.code2html webapps.pastebin ; %> - - - - - - - - <% "title" get write %> - - <% default-stylesheet %> - - - - - -
- <% [ paste-list ] "Paste list" render-link %> | - <% [ new-paste ] "New paste" render-link %> | - <% [ feed.xml ] "Syndicate" render-link %> -
-

<% "title" get write %>

diff --git a/unmaintained/webapps/pastebin/modes.furnace b/unmaintained/webapps/pastebin/modes.furnace deleted file mode 100644 index 18bbec180a..0000000000 --- a/unmaintained/webapps/pastebin/modes.furnace +++ /dev/null @@ -1,7 +0,0 @@ -<% USING: furnace xmode.catalog sequences kernel html.elements assocs io sorting continuations ; %> - - diff --git a/unmaintained/webapps/pastebin/new-paste.furnace b/unmaintained/webapps/pastebin/new-paste.furnace deleted file mode 100755 index b21e19734d..0000000000 --- a/unmaintained/webapps/pastebin/new-paste.furnace +++ /dev/null @@ -1,51 +0,0 @@ -<% USING: continuations furnace namespaces ; %> - -<% - "New paste" "title" set - "header" render-template -%> - -
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Summary:" /><% "summary" "*Required" render-error %>
Your name:" /><% "author" "*Required" render-error %>
File type:<% "modes" render-template %>
<% "contents" "*Required" render-error %>
Content:
- - - -
- -<% "footer" render-template %> diff --git a/unmaintained/webapps/pastebin/paste-list.furnace b/unmaintained/webapps/pastebin/paste-list.furnace deleted file mode 100644 index 51813ecf97..0000000000 --- a/unmaintained/webapps/pastebin/paste-list.furnace +++ /dev/null @@ -1,33 +0,0 @@ -<% USING: namespaces furnace sequences ; %> - -<% - "Pastebin" "title" set - "header" render-template -%> - - - - - - -
- - - - - - - <% "pastes" get [ "paste-summary" render-component ] each %> -
Summary:Paste by:Date:
- 		-
-

This pastebin is written in Factor. It is inspired by lisppaste. -

-

It can be used for collaborative development over IRC. You can post code for review, and annotate other people's code. Syntax highlighting for over a hundred file types is supported. -

-

- <% "webapps.pastebin" browse-webapp-source %>

-
-
- -<% "footer" render-template %> diff --git a/unmaintained/webapps/pastebin/paste-summary.furnace b/unmaintained/webapps/pastebin/paste-summary.furnace deleted file mode 100644 index dc25fe1924..0000000000 --- a/unmaintained/webapps/pastebin/paste-summary.furnace +++ /dev/null @@ -1,12 +0,0 @@ -<% USING: continuations namespaces io kernel math math.parser -furnace webapps.pastebin calendar sequences ; %> - - - - - <% "summary" get write %> - - - <% "author" get write %> - <% "date" get timestamp>string write %> - diff --git a/unmaintained/webapps/pastebin/pastebin.factor b/unmaintained/webapps/pastebin/pastebin.factor deleted file mode 100755 index 36a72795db..0000000000 --- a/unmaintained/webapps/pastebin/pastebin.factor +++ /dev/null @@ -1,119 +0,0 @@ -USING: calendar furnace furnace.validator io.files kernel -namespaces sequences http.server.responders html math.parser rss -xml.writer xmode.code2html math calendar.format ; -IN: webapps.pastebin - -TUPLE: pastebin pastes ; - -: ( -- pastebin ) - V{ } clone pastebin construct-boa ; - - pastebin set-global - -TUPLE: paste -summary author channel mode contents date -annotations n ; - -: ( summary author channel mode contents -- paste ) - f V{ } clone f paste construct-boa ; - -TUPLE: annotation summary author mode contents ; - -C: annotation - -: get-paste ( n -- paste ) - pastebin get pastebin-pastes nth ; - -: show-paste ( n -- ) - serving-html - get-paste - [ "show-paste" render-component ] with-html-stream ; - -\ show-paste { { "n" v-number } } define-action - -: new-paste ( -- ) - serving-html - [ "new-paste" render-template ] with-html-stream ; - -\ new-paste { } define-action - -: paste-list ( -- ) - serving-html - [ - [ show-paste ] "show-paste-quot" set - [ new-paste ] "new-paste-quot" set - pastebin get "paste-list" render-component - ] with-html-stream ; - -\ paste-list { } define-action - -: paste-link ( paste -- link ) - paste-n number>string [ show-paste ] curry quot-link ; - -: safe-head ( seq n -- seq' ) - over length min head ; - -: paste-feed ( -- entries ) - pastebin get pastebin-pastes 20 safe-head [ - { - paste-summary - paste-link - paste-date - } get-slots timestamp>rfc3339 f swap - ] map ; - -: feed.xml ( -- ) - "text/xml" serving-content - "pastebin" - "http://pastebin.factorcode.org" - paste-feed feed>xml write-xml ; - -\ feed.xml { } define-action - -: add-paste ( paste pastebin -- ) - >r now over set-paste-date r> - pastebin-pastes 2dup length swap set-paste-n push ; - -: submit-paste ( summary author channel mode contents -- ) - [ pastebin get add-paste ] keep - paste-link permanent-redirect ; - -\ new-paste -\ submit-paste { - { "summary" v-required } - { "author" v-required } - { "channel" } - { "mode" v-required } - { "contents" v-required } -} define-form - -\ new-paste { - { "channel" "#concatenative" } - { "mode" "factor" } -} default-values - -: annotate-paste ( n summary author mode contents -- ) - swap get-paste - [ paste-annotations push ] keep - paste-link permanent-redirect ; - -[ "n" show-paste ] -\ annotate-paste { - { "n" v-required v-number } - { "summary" v-required } - { "author" v-required } - { "mode" v-required } - { "contents" v-required } -} define-form - -\ show-paste { - { "mode" "factor" } -} default-values - -: style.css ( -- ) - "text/css" serving-content - "style.css" send-resource ; - -\ style.css { } define-action - -"pastebin" "paste-list" "extra/webapps/pastebin" web-app diff --git a/unmaintained/webapps/pastebin/show-paste.furnace b/unmaintained/webapps/pastebin/show-paste.furnace deleted file mode 100755 index 30129eda24..0000000000 --- a/unmaintained/webapps/pastebin/show-paste.furnace +++ /dev/null @@ -1,21 +0,0 @@ -<% USING: namespaces io furnace sequences xmode.code2html calendar ; %> - -<% - "Paste: " "summary" get append "title" set - "header" render-template -%> - - - - - - -
Paste by:<% "author" get write %>
Created:<% "date" get timestamp>string write %>
File type:<% "mode" get write %>
- -<% "syntax" render-template %> - -<% "annotations" get [ "annotation" render-component ] each %> - -<% model get "annotate-paste" render-component %> - -<% "footer" render-template %> diff --git a/unmaintained/webapps/pastebin/style.css b/unmaintained/webapps/pastebin/style.css deleted file mode 100644 index 4a469f92cb..0000000000 --- a/unmaintained/webapps/pastebin/style.css +++ /dev/null @@ -1,41 +0,0 @@ -body { - font:75%/1.6em "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif; - color:#888; -} - -h1.pastebin-title { - font-size:300%; -} - -a { - color:#222; - border-bottom:1px dotted #ccc; - text-decoration:none; -} - -a:hover { - border-bottom:1px solid #ccc; -} - -pre.code { - border:1px dashed #ccc; - background-color:#f5f5f5; - padding:5px; - font-size:150%; - color:#000000; -} - -.navbar { - background-color:#eeeeee; - padding:5px; - border:1px solid #ccc; -} - -.infobox { - border: 1px solid #C1DAD7; - padding: 10px; -} - -.error { - color: red; -} diff --git a/unmaintained/webapps/pastebin/syntax.furnace b/unmaintained/webapps/pastebin/syntax.furnace deleted file mode 100755 index 17b64b920b..0000000000 --- a/unmaintained/webapps/pastebin/syntax.furnace +++ /dev/null @@ -1,3 +0,0 @@ -<% USING: xmode.code2html splitting namespaces ; %> - -
<% "contents" get string-lines "mode" get htmlize-lines %>
diff --git a/unmaintained/webapps/planet/authors.txt b/unmaintained/webapps/planet/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/unmaintained/webapps/planet/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/unmaintained/webapps/planet/planet.factor b/unmaintained/webapps/planet/planet.factor deleted file mode 100755 index 9a5f8eeb97..0000000000 --- a/unmaintained/webapps/planet/planet.factor +++ /dev/null @@ -1,129 +0,0 @@ -USING: sequences rss arrays concurrency.combinators kernel -sorting html.elements io assocs namespaces math threads vocabs -html furnace http.server.templating calendar math.parser -splitting continuations debugger system http.server.responders -xml.writer prettyprint logging calendar.format ; -IN: webapps.planet - -: print-posting-summary ( posting -- ) -

- dup entry-title write
- - "Read More..." write - -

; - -: print-posting-summaries ( postings -- ) - [ print-posting-summary ] each ; - -: print-blogroll ( blogroll -- ) - ; - -: format-date ( date -- string ) - rfc3339>timestamp timestamp>string ; - -: print-posting ( posting -- ) -

- - dup entry-title write-html - -

-

- dup entry-description write-html -

-

- entry-pub-date format-date write -

; - -: print-postings ( postings -- ) - [ print-posting ] each ; - -SYMBOL: default-blogroll -SYMBOL: cached-postings - -: safe-head ( seq n -- seq' ) - over length min head ; - -: mini-planet-factor ( -- ) - cached-postings get 4 safe-head print-posting-summaries ; - -: planet-factor ( -- ) - serving-html [ "planet" render-template ] with-html-stream ; - -\ planet-factor { } define-action - -: planet-feed ( -- feed ) - "[ planet-factor ]" - "http://planet.factorcode.org" - cached-postings get 30 safe-head ; - -: feed.xml ( -- ) - "text/xml" serving-content - planet-feed feed>xml write-xml ; - -\ feed.xml { } define-action - -: style.css ( -- ) - "text/css" serving-content - "style.css" send-resource ; - -\ style.css { } define-action - -SYMBOL: last-update - -: ( author entry -- entry' ) - clone - [ ": " swap entry-title 3append ] keep - [ set-entry-title ] keep ; - -: fetch-feed ( url -- feed ) - download-feed feed-entries ; - -\ fetch-feed DEBUG add-error-logging - -: fetch-blogroll ( blogroll -- entries ) - dup 0 swap 1 - [ fetch-feed ] parallel-map - [ [ ] with map ] 2map concat ; - -: sort-entries ( entries -- entries' ) - [ [ entry-pub-date ] compare ] sort ; - -: update-cached-postings ( -- ) - default-blogroll get - fetch-blogroll sort-entries - cached-postings set-global ; - -: update-thread ( -- ) - millis last-update set-global - [ update-cached-postings ] "RSS feed update slave" spawn drop - 10 60 * 1000 * sleep - update-thread ; - -: start-update-thread ( -- ) - [ - "webapps.planet" [ - update-thread - ] with-logging - ] "RSS feed update master" spawn drop ; - -"planet" "planet-factor" "extra/webapps/planet" web-app - -{ - { "Berlin Brown" "http://factorlang-fornovices.blogspot.com/feeds/posts/default" "http://factorlang-fornovices.blogspot.com" } - { "Chris Double" "http://www.blogger.com/feeds/18561009/posts/full/-/factor" "http://www.bluishcoder.co.nz/" } - { "Elie Chaftari" "http://fun-factor.blogspot.com/feeds/posts/default" "http://fun-factor.blogspot.com/" } - { "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" } - { "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" } - { "Gavin Harrison" "http://gmh33.blogspot.com/feeds/posts/default" "http://gmh33.blogspot.com/" } - { "Kio M. Smallwood" - "http://sekenre.wordpress.com/feed/atom/" - "http://sekenre.wordpress.com/" } - { "Phil Dawes" "http://www.phildawes.net/blog/category/factor/feed/atom" "http://www.phildawes.net/blog/" } - { "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" } - { "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" } -} default-blogroll set-global diff --git a/unmaintained/webapps/planet/planet.furnace b/unmaintained/webapps/planet/planet.furnace deleted file mode 100644 index 4c6676c0a2..0000000000 --- a/unmaintained/webapps/planet/planet.furnace +++ /dev/null @@ -1,45 +0,0 @@ -<% USING: namespaces html.elements webapps.planet sequences -furnace ; %> - - - - - - - - planet-factor - - - - - -

[ planet-factor ]

- - - - - -
<% cached-postings get 20 safe-head print-postings %> -

- planet-factor is an Atom/RSS aggregator that collects the - contents of Factor-related blogs. It is inspired by - Planet Lisp. -

-

- - Syndicate -

-

- This webapp is written in Factor.
- <% "webapps.planet" browse-webapp-source %> -

-

Blogroll

- <% default-blogroll get print-blogroll %> -

- If you want your weblog added to the blogroll, just ask. -

-
- - - diff --git a/unmaintained/webapps/planet/style.css b/unmaintained/webapps/planet/style.css deleted file mode 100644 index 7a66d8d495..0000000000 --- a/unmaintained/webapps/planet/style.css +++ /dev/null @@ -1,45 +0,0 @@ -body { - font:75%/1.6em "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif; - color:#888; -} - -h1.planet-title { - font-size:300%; -} - -a { - color:#222; - border-bottom:1px dotted #ccc; - text-decoration:none; -} - -a:hover { - border-bottom:1px solid #ccc; -} - -.posting-title { - background-color:#f5f5f5; -} - -pre, code { - color:#000000; - font-size:120%; -} - -.infobox { - border-left: 1px solid #C1DAD7; -} - -.posting-date { - text-align: right; - font-size:90%; -} - -a.more { - display:block; - padding:0 0 5px 0; - color:#333; - text-decoration:none; - text-align:right; - border:none; -} diff --git a/unmaintained/wee-url/load.factor b/unmaintained/wee-url/load.factor deleted file mode 100644 index 96d27164e8..0000000000 --- a/unmaintained/wee-url/load.factor +++ /dev/null @@ -1,4 +0,0 @@ -REQUIRES: apps/http-server libs/store ; - -PROVIDE: apps/wee-url -{ +files+ { "responder.factor" } } ; diff --git a/unmaintained/wee-url/responder.factor b/unmaintained/wee-url/responder.factor deleted file mode 100644 index 4d7b076cb6..0000000000 --- a/unmaintained/wee-url/responder.factor +++ /dev/null @@ -1,91 +0,0 @@ -! Copyright (C) 2006 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: generic assocs help html httpd -io kernel math namespaces prettyprint sequences store strings ; -IN: wee-url-responder - -SYMBOL: wee-shortcuts -SYMBOL: wee-store - -"wee-url.store" load-store wee-store set-global -H{ } clone wee-shortcuts wee-store get store-variable - -: responder-url "responder-url" get ; - -: wee-url ( string -- url ) - [ - "http://" % - host % - responder-url % - % - ] "" make ; - -: letter-bank - "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" ; - -: random-letter letter-bank length random letter-bank nth ; - -: random-url ( -- string ) - 6 random 1+ [ drop random-letter ] map >string - dup wee-shortcuts get key? [ drop random-url ] when ; - -: prepare-wee-url ( url -- url ) - CHAR: : over member? [ "http://" swap append ] unless ; - -: set-symmetric-hash ( obj1 obj2 hash -- ) - 3dup set-at swapd set-at ; - -: add-shortcut ( url-long -- url-short ) - dup wee-shortcuts get at* [ - nip - ] [ - drop - random-url [ wee-shortcuts get set-symmetric-hash ] keep - wee-store get save-store - ] if ; - -: url-prompt ( -- ) - serving-html - "wee-url.com - wee URLs since 2007" [ -
- "URL: " write - - -
- ] simple-html-document ; - -: url-submitted ( url-long url-short -- ) - "URL Submitted" [ - "URL: " write write nl - "wee-url: " write - wee-url write nl - "Back to " write - "wee-url" write nl - ] simple-html-document ; - -: url-submit ( url -- ) - serving-html - prepare-wee-url [ add-shortcut ] keep url-submitted ; - -: 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 url-prompt - ] [ - wee-shortcuts get at* - [ permanent-redirect ] [ drop url-error ] if - ] if - ] if* ; - -[ - "wee-url" "responder" set - [ wee-url-responder ] "get" set -] make-responder diff --git a/unmaintained/wee-url/wee-url.factor b/unmaintained/wee-url/wee-url.factor deleted file mode 100644 index ead2ee8976..0000000000 --- a/unmaintained/wee-url/wee-url.factor +++ /dev/null @@ -1,89 +0,0 @@ -! 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" [ -
- "URL: " write - - -
- ] simple-html-document ; - -\ show-submit { } define-action - -: url-submitted ( url-long url-short -- ) - "URL Submitted" [ - "URL: " write write nl - "wee-url: " write - wee-url write nl - "Back to " write - "wee-url" write 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 -~