steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

HTTPD tools moved to contrib/furnace and updated to use the new framework

darcs
slava 2006-10-19 20:35:58 +00:00
parent 346063e9ac
commit 76f1b3bcfe
12 changed files with 76 additions and 141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
contrib/furnace-pastebin/pastebin.factor
View File

@ -64,8 +64,6 @@ C: pastebin ( -- pastebin )
\ submit-paste [ paste-list ] define-redirect
"pastebin" "paste-list" "contrib/furnace-pastebin" web-app
: annotate-paste ( paste# summary author contents -- )
<annotation> swap get-paste paste-annotations push ;
@ -77,3 +75,5 @@ C: pastebin ( -- pastebin )
} define-action
\ annotate-paste [ "n" show-paste ] define-redirect
"pastebin" "paste-list" "contrib/furnace-pastebin" web-app

2
contrib/furnace/load.factor
View File

@ -3,6 +3,8 @@ REQUIRES: contrib/httpd ;
PROVIDE: contrib/furnace {
"validator.factor"
"responder.factor"
"tools/help.factor"
"tools/browser.factor"
} {
"test/validator.factor"
"test/responder.factor"

4
contrib/furnace/responder.factor
View File

@ -36,7 +36,9 @@ PREDICATE: word action "action" word-prop ;
: action-link ( query action -- url )
[
"/responder/" % "responder" get % "/" %
"/responder/" %
dup word-vocabulary "furnace:" ?head drop %
"/" %
word-name %
] "" make swap build-url ;

59
contrib/httpd/browser-responder.factor → contrib/furnace/tools/browser.factor
View File

@ -1,20 +1,23 @@
! Copyright (C) 2004 Chris Double.
! Copyright (C) 2004 Chris Double
! Copyright (C) 2004, 2006 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
IN: browser-responder
IN: furnace:browser
USING: definitions hashtables help html httpd io kernel memory
namespaces prettyprint sequences words xml ;
namespaces prettyprint sequences words xml furnace arrays ;
: option ( current text -- )
#! Output the HTML option tag for the given text. If
#! it is equal to the current string, make the option selected.
<option tuck = [ "yes" =selected ] when option>
chars>entities write
<option tuck = [ "selected" =selected ] when option>
write
</option> ;
: options ( current seq -- ) [ option ] each-with ;
: list ( current seq name -- )
<select =name "width: 200px;" =style "20" =size "document.forms.main.submit()" =onchange select>
<select =name "width: 200px;" =style "20" =size
"JavaScript:document.getElementById('main').submit();" =onchange
select>
options
</select> ;
@ -24,18 +27,17 @@ namespaces prettyprint sequences words xml ;
: current-word ( -- word )
"word" query-param "vocab" query-param lookup ;
: vocab-list ( -- )
current-vocab vocabs "vocab" list ;
: vocab-list ( vocab -- ) vocabs "vocab" list ;
: word-list ( -- )
current-word [ word-name ] [ f ] if*
current-vocab vocab hash-keys natural-sort "word" list ;
: word-list ( word vocab -- )
[ lookup [ word-name ] [ f ] if* ] keep
vocab hash-keys natural-sort "word" list ;
: word-source ( -- )
#! Write the source for the given word from the vocab as HTML.
current-word [ [ see-help ] with-html-stream ] when* ;
current-word [ see-help ] when* ;
: browser-body ( -- )
: browser-body ( word vocab -- )
#! Write out the HTML for the body of the main browser page.
<table "100%" =width table>
<tr>
@ -45,7 +47,7 @@ namespaces prettyprint sequences words xml ;
</tr>
<tr>
<td "top" =valign "width: 200px;" =style td>
vocab-list
dup vocab-list
</td>
<td "top" =valign "width: 200px;" =style td>
word-list
@ -54,14 +56,27 @@ namespaces prettyprint sequences words xml ;
</tr>
</table> ;
: browser-title ( -- str )
current-word
[ summary ] [ "IN: " current-vocab append ] if* ;
: browser-title ( word vocab -- str )
2dup lookup dup
[ 2nip summary ] [ drop nip "IN: " swap append ] if ;
: browser-responder ( -- )
: browse ( word vocab -- )
#! Display a Smalltalk like browser for exploring words.
serving-html browser-title [
<form "main" =name "" =action "get" =method form>
browser-body
</form>
2dup browser-title [
[
<form "main" =id "browse" =action "get" =method form>
browser-body
</form>
] with-html-stream
] html-document ;
\ browse {
{ "word" }
{ "vocab" "kernel" v-default }
} define-action
"browser" "browse" "contrib/furnace" web-app
M: word browser-link-href
dup word-name swap word-vocabulary \ browse
3array >quotation quot-link ;

26
contrib/furnace/tools/help.factor Normal file
View File

@ -0,0 +1,26 @@
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: furnace:help
USING: furnace help html kernel sequences words strings ;
: string>topic ( string -- topic )
" " split dup length 1 = [ first ] when ;
: show-help ( topic -- )
dup article-title [
[ help ] with-html-stream
] html-document ;
\ show-help {
{ "topic" "handbook" v-default string>topic }
} define-action
"help" "show-help" "contrib/furnace" web-app
M: link browser-link-href
link-name [ \ f ] unless* dup word? [
browser-link-href
] [
dup [ string? ] all? [ " " join ] when
[ show-help ] curry quot-link
] if ;

56
contrib/httpd/darcs-responder.factor
View File

@ -1,56 +0,0 @@
USING: httpd io kernel namespaces sequences xml ;
SYMBOL: darcs-directory
"/var/www/factorcode.org/repos/" darcs-directory set
: darcs-changelog
darcs-directory get cd
"darcs changes --xml" "r" <process-stream> contents xml ;
: rss-item ( { title date author } -- )
"item" [ ] [
{ "title" "pubDate" "author" } [ [ ] text-tag ] 2each
] tag ;
: ?tag-name ( tag -- name/f )
dup tag? [ tag-name ] [ drop f ] if ;
: children-named ( tag name -- seq )
swap tag-children [ ?tag-name = ] subset-with ;
: tag-child ( tag name -- tag )
children-named first ;
: patch>rss-item ( tag -- { title link author date } )
[
dup "name" tag-child tag-children %
tag-props [ "local_date" get , "author" get , ] bind
] { } make ;
SYMBOL: rss-feed-title
SYMBOL: rss-feed-link
SYMBOL: rss-feed-description
"Factor DARCS repository" rss-feed-title set
"http://factorcode.org/repos/" rss-feed-link set
"Recent patches applied to the Factor DARCS repository" rss-feed-description set
: rss-metadata ( -- )
{ rss-feed-title rss-feed-link rss-feed-description }
{ "title" "link" "description" }
[ >r get r> [ ] text-tag ] 2each ;
: rss-feed ( items -- string )
[
"rss" [ "2.0" "version" set ] [
"channel" [ ] [ rss-metadata [ rss-item ] each ] tag
] tag
] make-xml xml>string ;
: changelog>rss-feed ( xml -- string )
"patch" children-named [ patch>rss-item ] map rss-feed ;
: darcs-rss-feed darcs-changelog changelog>rss-feed print ;
"darcs" [ darcs-rss-feed ] add-simple-responder

13
contrib/httpd/default-responders.factor
View File

@ -1,9 +1,7 @@
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: httpd
USING: browser-responder callback-responder file-responder
help-responder inspect-responder io kernel namespaces
prettyprint ;
USING: callback-responder file-responder io kernel namespaces ;
#! Remove all existing responders, and create a blank
#! responder table.
@ -13,9 +11,6 @@ global [
! 404 error message pages are served by this guy
"404" [ no-such-responder ] add-simple-responder
! Online help browsing
"help" [ help-responder ] add-simple-responder
! Used by other responders
"callback" [ callback-responder ] add-simple-responder
@ -27,12 +22,6 @@ global [
] with-scope
] add-simple-responder
! Global variables
"inspector" [ inspect-responder ] add-simple-responder
! Servers Factor word definitions from the image.
"browser" [ browser-responder ] add-simple-responder
! Serves files from a directory stored in the "doc-root"
! variable. You can set the variable in the global namespace,
! or inside the responder.

13
contrib/httpd/help-responder.factor
View File

@ -1,13 +0,0 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: help-responder
USING: hashtables help html httpd io kernel namespaces sequences ;
: help-topic
"topic" query-param dup empty? [ drop "handbook" ] when ;
: help-responder ( -- )
serving-html
help-topic dup article-title [
[ help ] with-html-stream
] html-document ;

2
contrib/httpd/html-tags.factor
View File

@ -128,7 +128,7 @@ SYMBOL: html
: define-attribute-word ( name -- )
dup "=" swap append swap
[ , [ write-attr ] % ] [ ] make html-word drop ;
[ write-attr ] curry html-word drop ;
! Define some closed HTML tags
[

20
contrib/httpd/html.factor
View File

@ -88,18 +88,6 @@ GENERIC: browser-link-href ( presented -- href )
M: object browser-link-href drop f ;
M: word browser-link-href
"/responder/browser/" swap [
dup word-vocabulary "vocab" set word-name "word" set
] make-hash build-url ;
M: link browser-link-href
link-name [ \ f ] unless* dup word? [
browser-link-href
] [
"/responder/help/" swap "topic" associate build-url
] if ;
: resolve-file-link ( path -- link )
#! The file responder needs relative links not absolute
#! links.
@ -201,10 +189,10 @@ M: html-stream stream-terpri [ <br/> ] with-stream* ;
: default-css ( -- )
<style "text/css" =type style>
"A:link { text-decoration: none; color: black; }" print
"A:visited { text-decoration: none; color: black; }" print
"A:active { text-decoration: none; color: black; }" print
"A:hover, A:hover { text-decoration: underline; color: black; }" print
"a:link { text-decoration: none; color: black; }" print
"a:visited { text-decoration: none; color: black; }" print
"a:active { text-decoration: none; color: black; }" print
"a:hover, A:hover { text-decoration: underline; color: black; }" print
</style> ;
: xhtml-preamble

15
contrib/httpd/inspect-responder.factor
View File

@ -1,15 +0,0 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: inspect-responder
USING: callback-responder generic hashtables help html httpd
tools kernel namespaces prettyprint sequences ;
! Mini object inspector
: http-inspect ( obj -- )
dup summary [ describe ] simple-html-document ;
M: general-t browser-link-href
[ http-inspect ] curry t register-html-callback ;
: inspect-responder ( url -- )
serving-html global http-inspect ;

3
contrib/httpd/load.factor
View File

@ -13,9 +13,6 @@ PROVIDE: contrib/httpd {
"prototype-js.factor"
"html.factor"
"file-responder.factor"
"help-responder.factor"
"inspect-responder.factor"
"browser-responder.factor"
"default-responders.factor"
} {
"test/html.factor"