diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index 691bcb866e..c9fef618f8 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -25,11 +25,11 @@ TUPLE: cairo-gadget < texture-gadget dim quot ; M: cairo-gadget cache-key* [ dim>> ] [ quot>> ] bi 2array ; : render-cairo ( dim quot -- bytes format ) - >r 2^-bounds r> copy-cairo GL_BGRA ; + >r 2^-bounds r> copy-cairo GL_BGRA ; inline -M: cairo-gadget render* - [ dim>> dup ] [ quot>> ] bi - render-cairo render-bytes* ; +! M: cairo-gadget render* +! [ dim>> dup ] [ quot>> ] bi +! render-cairo render-bytes* ; ! maybe also texture>png ! : cairo>png ( gadget path -- ) diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index bac141d6d2..0fe2f3577e 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -149,6 +149,9 @@ M: retryable execute-statement* ( statement type -- ) : select-tuples ( tuple -- tuples ) dup dup class do-select ; +: count-tuples ( tuple -- n ) + select-tuples length ; + : select-tuple ( tuple -- tuple/f ) dup dup class f f f 1 do-select ?first ; diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor new file mode 100644 index 0000000000..7c33265d39 --- /dev/null +++ b/extra/dns/server/server.factor @@ -0,0 +1,139 @@ + +USING: kernel + combinators + sequences + math + io.sockets + unicode.case + accessors + combinators.cleave + newfx + dns ; + +IN: dns.server + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: records ( -- vector ) V{ } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: filter-by-name ( records name -- records ) swap [ name>> = ] with filter ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: {name-type-class} ( obj -- array ) + { [ name>> >lower ] [ type>> ] [ class>> ] } ; + +: rr=query? ( obj obj -- ? ) [ {name-type-class} ] bi@ = ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: matching-rrs ( query -- rrs ) records [ rr=query? ] with filter ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: matching-rrs? ( query -- query rrs/f ? ) dup matching-rrs dup empty? not ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: matching-cname? ( query -- query rr/f ? ) + dup clone CNAME >>type matching-rrs + dup empty? [ drop f f ] [ 1st t ] if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +DEFER: query->rrs + +: query-canonical ( query rr -- rrs ) + tuck [ clone ] [ rdata>> ] bi* >>name query->rrs prefix-on ; + +: query->rrs ( query -- rrs/f ) + { + { [ matching-rrs? ] [ nip ] } + { [ drop matching-cname? ] [ query-canonical ] } + { [ drop t ] [ drop f ] } + } + cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: delegate-servers? ( name -- name rrs ? ) + dup NS IN query boa matching-rrs dup empty? not ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: delegate-servers ( name -- rrs ) + { + { [ dup "" = ] [ drop { } ] } + { [ delegate-servers? ] [ nip ] } + { [ drop t ] [ cdr-name delegate-servers ] } + } + cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: delegate-addresses ( rrs-ns -- rrs-a ) + [ rdata>> A IN query boa matching-rrs ] map concat ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: have-delegates? ( query -- query rrs-ns ? ) + dup name>> delegate-servers dup empty? not ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: fill-additional ( message -- message ) + dup authority-section>> delegate-addresses >>additional-section ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: no-records-with-name? ( query -- query ? ) + dup name>> records [ name>> = ] with filter empty? ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: find-answer ( message -- message ) + dup message-query ! message query + { + { [ dup query->rrs dup ] [ nip >>answer-section 1 >>aa ] } + { [ drop have-delegates? ] [ nip >>authority-section fill-additional ] } + { [ drop no-records-with-name? ] [ drop NAME-ERROR >>rcode ] } + { [ drop t ] [ ] } + } + cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: (socket) ( -- vec ) V{ f } ; + +: socket ( -- socket ) (socket) 1st ; + +: init-socket-on-port ( port -- ) + f swap 0 (socket) as-mutate ; + +: init-socket ( -- ) 53 init-socket-on-port ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: loop ( -- ) + socket receive + swap + parse-message + find-answer + message->ba + swap + socket send + loop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: start ( -- ) init-socket loop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MAIN: start \ No newline at end of file diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 862ed80e11..3566d45c5b 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -151,7 +151,7 @@ CHLOE: a : form-magic ( tag -- ) [ modify-form ] each-responder nested-values get " " join f like form-nesting-key hidden-form-field - "for" optional-attr [ hidden render ] when* ; + "for" optional-attr [ "," split [ hidden render ] each ] when* ; : form-start-tag ( tag -- ) [ diff --git a/extra/help/html/html.factor b/extra/help/html/html.factor new file mode 100644 index 0000000000..b1bf8958a8 --- /dev/null +++ b/extra/help/html/html.factor @@ -0,0 +1,5 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: help.html + + diff --git a/extra/opengl/gadgets/gadgets-tests.factor b/extra/opengl/gadgets/gadgets-tests.factor new file mode 100644 index 0000000000..499ec9730a --- /dev/null +++ b/extra/opengl/gadgets/gadgets-tests.factor @@ -0,0 +1,4 @@ +IN: opengl.gadgets.tests +USING: tools.test opengl.gadgets ; + +\ render* must-infer diff --git a/extra/pango/cairo/cairo.factor b/extra/pango/cairo/cairo.factor index f6c1ee498d..1ff5328ee0 100644 --- a/extra/pango/cairo/cairo.factor +++ b/extra/pango/cairo/cairo.factor @@ -100,7 +100,7 @@ destructors accessors namespaces kernel cairo ; >r alien>> pango-layout r> with-variable ; inline : with-pango-cairo ( quot -- ) - cr pango_cairo_create_layout swap with-layout ; + cr pango_cairo_create_layout swap with-layout ; inline MEMO: dummy-cairo ( -- cr ) CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create cairo_create ; diff --git a/extra/pango/cairo/gadgets/gadgets.factor b/extra/pango/cairo/gadgets/gadgets.factor index 5fb579c1a1..a21affc364 100644 --- a/extra/pango/cairo/gadgets/gadgets.factor +++ b/extra/pango/cairo/gadgets/gadgets.factor @@ -18,7 +18,7 @@ M: pango-cairo-backend construct-pango : setup-layout ( gadget -- quot ) [ font>> ] [ text>> ] bi - '[ , layout-font , layout-text ] ; + '[ , layout-font , layout-text ] ; inline M: pango-cairo-gadget render* ( gadget -- ) setup-layout [ layout-size dup ] diff --git a/extra/urls/urls-tests.factor b/extra/urls/urls-tests.factor index a718989476..87c9b91950 100644 --- a/extra/urls/urls-tests.factor +++ b/extra/urls/urls-tests.factor @@ -1,7 +1,7 @@ IN: urls.tests USING: urls urls.private tools.test tuple-syntax arrays kernel assocs -present ; +present accessors ; [ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello world" ] [ "hello%20world" url-decode ] unit-test @@ -224,3 +224,5 @@ urls [ [ "a" ] [ "a" "b" set-query-param "b" query-param ] unit-test + +[ "foo#3" ] [ URL" foo" clone 3 >>anchor present ] unit-test diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor index bb4d17e1f5..7e74fd1115 100644 --- a/extra/urls/urls.factor +++ b/extra/urls/urls.factor @@ -170,7 +170,7 @@ M: url present [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ] [ path>> url-encode % ] [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ] - [ anchor>> [ "#" % url-encode % ] when* ] + [ anchor>> [ "#" % present url-encode % ] when* ] } cleave ] "" make ; diff --git a/extra/webapps/blogs/blogs-common.xml b/extra/webapps/blogs/blogs-common.xml new file mode 100644 index 0000000000..38005e6f1c --- /dev/null +++ b/extra/webapps/blogs/blogs-common.xml @@ -0,0 +1,31 @@ + + + + + Recent Posts + + + + + +

+ + + +
diff --git a/extra/webapps/blogs/blogs.css b/extra/webapps/blogs/blogs.css new file mode 100644 index 0000000000..66676796a4 --- /dev/null +++ b/extra/webapps/blogs/blogs.css @@ -0,0 +1,15 @@ +.post-form { + border: 2px solid #666; + padding: 10px; + background: #eee; +} + +.post-title { + background-color:#f5f5ff; + padding: 3px; +} + +.post-footer { + text-align: right; + font-size:90%; +} diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor new file mode 100644 index 0000000000..60911b4947 --- /dev/null +++ b/extra/webapps/blogs/blogs.factor @@ -0,0 +1,253 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences sorting math.order math.parser +urls validators html.components db.types db.tuples calendar +http.server.dispatchers +furnace furnace.actions furnace.auth.login furnace.boilerplate +furnace.sessions furnace.syndication ; +IN: webapps.blogs + +TUPLE: blogs < dispatcher ; + +: view-post-url ( id -- url ) + number>string "$blogs/post/" prepend >url ; + +: view-comment-url ( parent id -- url ) + [ view-post-url ] dip >>anchor ; + +: list-posts-url ( -- url ) + URL" $blogs/" ; + +: user-posts-url ( author -- url ) + "$blogs/by/" prepend >url ; + +TUPLE: entity id author date content ; + +GENERIC: entity-url ( entity -- url ) + +M: entity feed-entry-url entity-url ; + +entity f { + { "id" "ID" INTEGER +db-assigned-id+ } + { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid + { "date" "DATE" TIMESTAMP +not-null+ } + { "content" "CONTENT" TEXT +not-null+ } +} define-persistent + +M: entity feed-entry-date date>> ; + +TUPLE: post < entity title comments ; + +M: post feed-entry-title + [ author>> ] [ drop ": " ] [ title>> ] tri 3append ; + +M: post entity-url + id>> view-post-url ; + +\ post "BLOG_POSTS" { + { "title" "TITLE" { VARCHAR 256 } +not-null+ } +} define-persistent + +: ( id -- post ) \ post new swap >>id ; + +: init-posts-table \ post ensure-table ; + +TUPLE: comment < entity parent ; + +comment "COMMENTS" { + { "parent" "PARENT" INTEGER +not-null+ } ! post id +} define-persistent + +M: comment feed-entry-title + author>> "Comment by " prepend ; + +M: comment entity-url + [ parent>> ] [ id>> ] bi view-comment-url ; + +: ( parent id -- post ) + comment new + swap >>id + swap >>parent ; + +: init-comments-table comment ensure-table ; + +: post ( id -- post ) + [ select-tuple ] [ f select-tuples ] bi + >>comments ; + +: reverse-chronological-order ( seq -- sorted ) + [ [ date>> ] compare invert-comparison ] sort ; + +: validate-author ( -- ) + { { "author" [ [ v-username ] v-optional ] } } validate-params ; + +: list-posts ( -- posts ) + f "author" value >>author + select-tuples [ dup id>> f count-tuples >>comments ] map + reverse-chronological-order ; + +: ( -- action ) + + [ + list-posts "posts" set-value + ] >>init + + { blogs "list-posts" } >>template ; + +: ( -- action ) + + [ "Recent Posts" ] >>title + [ list-posts ] >>entries + [ list-posts-url ] >>url ; + +: ( -- action ) + + "author" >>rest + [ + validate-author + list-posts "posts" set-value + ] >>init + { blogs "user-posts" } >>template ; + +: ( -- action ) + + [ validate-author ] >>init + [ "Recent Posts by " "author" value append ] >>title + [ list-posts ] >>entries + [ "author" value user-posts-url ] >>url ; + +: ( -- action ) + + [ validate-integer-id "id" value post "post" set-value ] >>init + [ "post" value feed-entry-title ] >>title + [ "post" value entity-url ] >>url + [ "post" value comments>> ] >>entries ; + +: ( -- action ) + + "id" >>rest + + [ + validate-integer-id + "id" value post from-object + + "id" value + "new-comment" [ + "parent" set-value + ] nest-values + ] >>init + + { blogs "view-post" } >>template ; + +: validate-post ( -- ) + { + { "title" [ v-one-line ] } + { "content" [ v-required ] } + } validate-params ; + +: ( -- action ) + + [ + validate-post + uid "author" set-value + ] >>validate + + [ + f + dup { "title" "content" } deposit-slots + uid >>author + now >>date + [ insert-tuple ] [ entity-url ] bi + ] >>submit + + { blogs "new-post" } >>template ; + +: ( -- action ) + + [ + validate-integer-id + "id" value select-tuple from-object + ] >>init + + [ + validate-integer-id + validate-post + ] >>validate + + [ + "id" value select-tuple + dup { "title" "content" } deposit-slots + [ update-tuple ] [ entity-url ] bi + ] >>submit + + { blogs "edit-post" } >>template ; + +: ( -- action ) + + [ + validate-integer-id + { { "author" [ v-username ] } } validate-params + ] >>validate + [ + "id" value delete-tuples + "author" value user-posts-url + ] >>submit ; + +: validate-comment ( -- ) + { + { "parent" [ v-integer ] } + { "content" [ v-required ] } + } validate-params ; + +: ( -- action ) + + + [ + validate-comment + uid "author" set-value + ] >>validate + + [ + "parent" value f + "content" value >>content + uid >>author + now >>date + [ insert-tuple ] [ entity-url ] bi + ] >>submit ; + +: ( -- action ) + + [ + validate-integer-id + { { "parent" [ v-integer ] } } validate-params + ] >>validate + [ + f "id" value delete-tuples + "parent" value view-post-url + ] >>submit ; + +: ( -- dispatcher ) + blogs new-dispatcher + "" add-responder + "posts.atom" add-responder + "by" add-responder + "by.atom" add-responder + "post" add-responder + "post.atom" add-responder + + "make a new blog post" >>description + "new-post" add-responder + + "edit a blog post" >>description + "edit-post" add-responder + + "delete a blog post" >>description + "delete-post" add-responder + + "make a comment" >>description + "new-comment" add-responder + + "delete a comment" >>description + "delete-comment" add-responder + + { blogs "blogs-common" } >>template ; diff --git a/extra/webapps/blogs/edit-post.xml b/extra/webapps/blogs/edit-post.xml new file mode 100644 index 0000000000..da88a78ab0 --- /dev/null +++ b/extra/webapps/blogs/edit-post.xml @@ -0,0 +1,29 @@ + + + + + Edit: + +
+ + +

Title:

+

+ +
+
+ + + +
diff --git a/extra/webapps/blogs/list-posts.xml b/extra/webapps/blogs/list-posts.xml new file mode 100644 index 0000000000..9c9685fe74 --- /dev/null +++ b/extra/webapps/blogs/list-posts.xml @@ -0,0 +1,35 @@ + + + + + Recent Posts + + + +

+ + + +

+ +

+ +

+ + + +
+ +
diff --git a/extra/webapps/blogs/new-post.xml b/extra/webapps/blogs/new-post.xml new file mode 100644 index 0000000000..9cb0250518 --- /dev/null +++ b/extra/webapps/blogs/new-post.xml @@ -0,0 +1,17 @@ + + + + + New Post + +
+ + +

Title:

+

+ +
+
+ + +
diff --git a/extra/webapps/blogs/user-posts.xml b/extra/webapps/blogs/user-posts.xml new file mode 100644 index 0000000000..95fae23b34 --- /dev/null +++ b/extra/webapps/blogs/user-posts.xml @@ -0,0 +1,41 @@ + + + + + + Recent Posts by + + + + Recent Posts by + + + + +

+ + + +

+ +

+ +

+ + + +
+ +
diff --git a/extra/webapps/blogs/view-post.xml b/extra/webapps/blogs/view-post.xml new file mode 100644 index 0000000000..3489f1e331 --- /dev/null +++ b/extra/webapps/blogs/view-post.xml @@ -0,0 +1,60 @@ + + + + + + : + + + + Recent Posts by + + + + +

+ +

+ + + + +
+ +

+ Comment by on : +

+ +

+ +

+ + Delete Comment + +
+ + + +

New Comment

+ +
+ +

+

+
+
+ +
+ +
diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index 44899cba31..d17a912ad8 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -12,6 +12,7 @@ furnace.sessions furnace.auth.login furnace.auth.providers.db furnace.boilerplate +webapps.blogs webapps.pastebin webapps.planet webapps.todo @@ -38,13 +39,17 @@ IN: webapps.factor-website init-articles-table init-revisions-table + init-postings-table + init-comments-table + init-short-url-table ] with-db ; TUPLE: factor-website < dispatcher ; : ( -- responder ) - factor-website new-dispatcher + factor-website new-dispatcher + "blogs" add-responder "todo" add-responder "pastebin" add-responder "planet" add-responder diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml index ea69c7bf7d..1c138fc8c0 100644 --- a/extra/webapps/pastebin/paste.xml +++ b/extra/webapps/pastebin/paste.xml @@ -53,6 +53,7 @@ + diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml index 96343bc5fa..fe4d23bd3b 100644 --- a/extra/webapps/planet/planet.xml +++ b/extra/webapps/planet/planet.xml @@ -19,7 +19,7 @@

- +

diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 1cecbc1094..a588b880d3 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -51,6 +51,9 @@ todo "TODO" { "description" [ v-required ] } } validate-params ; +: view-todo-url ( id -- url ) + "$todo-list/view" >>path swap "id" set-query-param ; + : ( -- action ) [ 0 "priority" set-value ] >>init @@ -62,14 +65,7 @@ todo "TODO" [ f dup { "summary" "priority" "description" } deposit-slots - [ insert-tuple ] - [ - - "$todo-list/view" >>path - swap id>> "id" set-query-param - - ] - bi + [ insert-tuple ] [ id>> view-todo-url ] bi ] >>submit ; : ( -- action ) @@ -89,23 +85,19 @@ todo "TODO" [ f dup { "id" "summary" "priority" "description" } deposit-slots - [ update-tuple ] - [ - - "$todo-list/view" >>path - swap id>> "id" set-query-param - - ] - bi + [ update-tuple ] [ id>> view-todo-url ] bi ] >>submit ; +: todo-list-url ( -- url ) + URL" $todo-list/list" ; + : ( -- action ) [ validate-integer-id ] >>validate [ "id" get delete-tuples - URL" $todo-list/list" + todo-list-url ] >>submit ; : ( -- action ) diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 611bba4c70..1dc6ef4ae8 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -15,14 +15,14 @@ validators db.types db.tuples lcs farkup urls ; IN: webapps.wiki -: title-url ( title action -- url ) - "$wiki/" prepend >url swap "title" set-query-param ; +: view-url ( title -- url ) + "$wiki/view/" prepend >url ; -: view-url ( title -- url ) "view" title-url ; +: edit-url ( title -- url ) + "$wiki/edit" >url swap "title" set-query-param ; -: edit-url ( title -- url ) "edit" title-url ; - -: revisions-url ( title -- url ) "revisions" title-url ; +: revisions-url ( title -- url ) + "$wiki/revisions" >url swap "title" set-query-param ; : revision-url ( id -- url ) "$wiki/revision" >url swap "id" set-query-param ;