diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor index 4e847cff70..6c62452ec2 100644 --- a/extra/http/server/boilerplate/boilerplate.factor +++ b/extra/http/server/boilerplate/boilerplate.factor @@ -1,7 +1,8 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces boxes sequences strings -io io.streams.string +io io.streams.string arrays +html.elements http http.server http.server.templating ; @@ -28,6 +29,18 @@ SYMBOL: style : write-style ( -- ) style get >string write ; +SYMBOL: atom-feed + +: set-atom-feed ( title url -- ) + 2array atom-feed get >box ; + +: write-atom-feed ( -- ) + atom-feed get value>> [ + + ] when* ; + SYMBOL: nested-template? SYMBOL: next-template @@ -40,6 +53,7 @@ M: f call-template drop call-next-template ; : with-boilerplate ( body template -- ) [ title get [ title set ] unless + atom-feed get [ atom-feed set ] unless style get [ SBUF" " clone style set ] unless [ @@ -54,5 +68,8 @@ M: f call-template drop call-next-template ; ] with-scope ; inline M: boilerplate call-responder - [ responder>> call-responder clone ] [ template>> ] bi - [ [ with-boilerplate ] 2curry ] curry change-body ; + tuck responder>> call-responder + dup "content-type" header "text/html" = [ + clone swap template>> + [ [ with-boilerplate ] 2curry ] curry change-body + ] [ nip ] if ; diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor index 6d3a048ac4..ff87bb71fb 100755 --- a/extra/http/server/components/components-tests.factor +++ b/extra/http/server/components/components-tests.factor @@ -129,3 +129,5 @@ TUPLE: test-tuple text number more-text ; [ t ] [ "wake up sheeple" dup "n" validate = ] unit-test [ ] [ "password" "p" set ] unit-test + +[ ] [ "pub-date" "d" set ] unit-test diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index 50353c6b87..bdcdd95c71 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: html.elements http.server.validators accessors namespaces -kernel io math.parser assocs classes words classes.tuple arrays -sequences splitting mirrors hashtables fry combinators -continuations math ; +USING: accessors namespaces kernel io math.parser assocs classes +words classes.tuple arrays sequences splitting mirrors +hashtables fry combinators continuations math +calendar.format html.elements +http.server.validators ; IN: http.server.components ! Renderer protocol @@ -59,9 +60,14 @@ SYMBOL: values : values-tuple values get mirror-object ; +: render-view-or-summary ( component -- value renderer ) + [ id>> value ] [ component-string ] [ renderer>> ] tri ; + : render-view ( component -- ) - [ id>> value ] [ component-string ] [ renderer>> ] tri - render-view* ; + render-view-or-summary render-view* ; + +: render-summary ( component -- ) + render-view-or-summary render-summary* ; ( id -- component ) + url new-string + 5 >>min-length + 60 >>max-length ; + +M: url validate* + call-next-method dup empty? [ v-url ] unless ; + ! Don't send passwords back to the user TUPLE: password-renderer < field ; @@ -206,20 +223,20 @@ M: captcha validate* drop v-captcha ; ! Text areas -TUPLE: textarea-renderer rows cols ; +TUPLE: text-renderer rows cols ; -: new-textarea-renderer ( class -- renderer ) +: new-text-renderer ( class -- renderer ) new 60 >>cols 20 >>rows ; -: ( -- renderer ) - textarea-renderer new-textarea-renderer ; +: ( -- renderer ) + text-renderer new-text-renderer ; -M: textarea-renderer render-view* +M: text-renderer render-view* drop write ; -M: textarea-renderer render-edit* +M: text-renderer render-edit* > [ number>string =rows ] when* ] [ cols>> [ number>string =cols ] when* ] bi @@ -234,11 +251,35 @@ TUPLE: text < string ; : new-text ( id class -- component ) new-string f >>one-line - >>renderer ; + >>renderer ; : ( id -- component ) text new-text ; +! HTML text component +TUPLE: html-text-renderer < text-renderer ; + +: ( -- renderer ) + html-text-renderer new-text-renderer ; + +M: html-text-renderer render-view* + drop write ; + +TUPLE: html-text < text ; + +: ( id -- component ) + html-text new-text + >>renderer ; + +! Date component +TUPLE: date < string ; + +: ( id -- component ) + date new-string ; + +M: date component-string + drop timestamp>string ; + ! List components SYMBOL: +plain+ SYMBOL: +ordered+ @@ -248,21 +289,27 @@ TUPLE: list-renderer component type ; C: list-renderer -: render-list ( value component -- ) - [ render-summary* ] curry each ; +: render-plain-list ( seq quot component -- ) + swap '[ , @ ] each ; inline -: render-ordered-list ( value component -- ) - [ render-summary* ] curry each ; +: render-ordered-list ( seq quot component -- ) + swap '[ , @ ] each ; inline -: render-unordered-list ( value component -- ) - [ render-summary* ] curry each ; +: render-unordered-list ( seq quot component -- ) + swap '[ , @ ] each ; inline + +: render-list ( value renderer quot -- ) + swap [ component>> ] [ type>> ] bi { + { +plain+ [ render-plain-list ] } + { +ordered+ [ render-ordered-list ] } + { +unordered+ [ render-unordered-list ] } + } case ; inline M: list-renderer render-view* - [ component>> ] [ type>> ] bi { - { +plain+ [ render-list ] } - { +ordered+ [ render-ordered-list ] } - { +unordered+ [ render-unordered-list ] } - } case ; + [ render-view* ] render-list ; + +M: list-renderer render-summary* + [ render-summary* ] render-list ; TUPLE: list < component ; diff --git a/extra/http/server/components/farkup/farkup.factor b/extra/http/server/components/farkup/farkup.factor index fb1c6fd25a..a8d320f82f 100755 --- a/extra/http/server/components/farkup/farkup.factor +++ b/extra/http/server/components/farkup/farkup.factor @@ -4,10 +4,10 @@ USING: splitting kernel io sequences farkup accessors http.server.components ; IN: http.server.components.farkup -TUPLE: farkup-renderer < textarea-renderer ; +TUPLE: farkup-renderer < text-renderer ; -: - farkup-renderer new-textarea-renderer ; +: ( -- renderer ) + farkup-renderer new-text-renderer ; M: farkup-renderer render-view* drop string-lines "\n" join convert-farkup write ; diff --git a/extra/http/server/forms/forms.factor b/extra/http/server/forms/forms.factor index 1b4f7f4d37..f45bf6ec65 100644 --- a/extra/http/server/forms/forms.factor +++ b/extra/http/server/forms/forms.factor @@ -15,7 +15,8 @@ components ; M: form init V{ } clone >>components ; : ( id -- form ) - form f new-component ; + form f new-component + dup >>renderer ; : add-field ( form component -- form ) dup id>> pick components>> set-at ; @@ -68,6 +69,8 @@ M: form init V{ } clone >>components ; tri* ] with-scope ; +M: form component-string drop ; + M: form render-summary* dup summary-template>> render-form ; diff --git a/extra/http/server/templating/chloe/chloe.factor b/extra/http/server/templating/chloe/chloe.factor index 06cf2936ce..8142c5e3b7 100644 --- a/extra/http/server/templating/chloe/chloe.factor +++ b/extra/http/server/templating/chloe/chloe.factor @@ -1,6 +1,6 @@ USING: accessors kernel sequences combinators kernel namespaces classes.tuple assocs splitting words arrays -io.files io.encodings.utf8 html.elements unicode.case +io io.files io.encodings.utf8 html.elements unicode.case tuple-syntax xml xml.data xml.writer xml.utilities http.server http.server.auth @@ -54,6 +54,19 @@ SYMBOL: tags : write-style-tag ( tag -- ) drop ; +: atom-tag ( tag -- ) + [ "title" required-attr ] + [ "href" required-attr ] + bi set-atom-feed ; + +: write-atom-tag ( tag -- ) + drop + "head" tags get member? [ + write-atom-feed + ] [ + atom-feed get value>> second write + ] if ; + : component-attr ( tag -- name ) "component" required-attr ; @@ -63,15 +76,20 @@ SYMBOL: tags : edit-tag ( tag -- ) component-attr component render-edit ; +: summary-tag ( tag -- ) + component-attr component render-summary ; + : parse-query-attr ( string -- assoc ) dup empty? [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ; : a-start-tag ( tag -- ) string =href + dup "value" optional-attr [ value f ] [ + [ "href" required-attr ] + [ "query" optional-attr parse-query-attr ] + bi + ] ?if link>string =href a> ; : process-tag-children ( tag -- ) @@ -126,8 +144,11 @@ SYMBOL: tags { "write-title" [ write-title-tag ] } { "style" [ style-tag ] } { "write-style" [ write-style-tag ] } + { "atom" [ atom-tag ] } + { "write-atom" [ write-atom-tag ] } { "view" [ view-tag ] } { "edit" [ edit-tag ] } + { "summary" [ summary-tag ] } { "a" [ a-tag ] } { "form" [ form-tag ] } { "error" [ error-tag ] } diff --git a/extra/http/server/validators/validators-tests.factor b/extra/http/server/validators/validators-tests.factor index 82827ac450..5e845705ab 100755 --- a/extra/http/server/validators/validators-tests.factor +++ b/extra/http/server/validators/validators-tests.factor @@ -21,3 +21,9 @@ accessors ; [ "slava@factorcodeorg" v-email ] [ "invalid e-mail" = ] must-fail-with + +[ "http://www.factorcode.org" ] +[ "http://www.factorcode.org" v-url ] unit-test + +[ "http:/www.factorcode.org" v-url ] +[ "invalid URL" = ] must-fail-with diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor index 692a5dec7c..7415787c79 100755 --- a/extra/http/server/validators/validators.factor +++ b/extra/http/server/validators/validators.factor @@ -65,7 +65,12 @@ C: validation-error : v-email ( str -- str ) #! From http://www.regular-expressions.info/email.html "e-mail" - R/ [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}/i + R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i + v-regexp ; + +: v-url ( str -- str ) + "URL" + R' (ftp|http|https)://(\w+:?\w*@)?(\S+)(:[0-9]+)?(/|/([\w#!:.?+=&%@!\-/]))?' v-regexp ; : v-captcha ( str -- str ) diff --git a/extra/webapps/planet/authors.txt b/extra/webapps/planet/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/webapps/planet/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/webapps/planet/blog-summary.xml b/extra/webapps/planet/blog-summary.xml new file mode 100644 index 0000000000..712db4ba0d --- /dev/null +++ b/extra/webapps/planet/blog-summary.xml @@ -0,0 +1,7 @@ + + + + + + + diff --git a/extra/webapps/planet/edit-blog.xml b/extra/webapps/planet/edit-blog.xml new file mode 100644 index 0000000000..890b23dcce --- /dev/null +++ b/extra/webapps/planet/edit-blog.xml @@ -0,0 +1,40 @@ + + + + + Edit Blog + + + + + + + + + Blog name: + + + + + Home page: + + + + + Atom feed: + + + + + + + + + + View + | + + + Delete + + diff --git a/extra/webapps/planet/entry-summary.xml b/extra/webapps/planet/entry-summary.xml new file mode 100644 index 0000000000..a87703252c --- /dev/null +++ b/extra/webapps/planet/entry-summary.xml @@ -0,0 +1,10 @@ + + + + + + + Read More... + + + diff --git a/extra/webapps/planet/entry.xml b/extra/webapps/planet/entry.xml new file mode 100644 index 0000000000..a9383d16f2 --- /dev/null +++ b/extra/webapps/planet/entry.xml @@ -0,0 +1,9 @@ + + + + + + + + + diff --git a/extra/webapps/planet/mini-planet.xml b/extra/webapps/planet/mini-planet.xml new file mode 100644 index 0000000000..950191e4c3 --- /dev/null +++ b/extra/webapps/planet/mini-planet.xml @@ -0,0 +1,7 @@ + + + + + + + diff --git a/extra/webapps/planet/page.xml b/extra/webapps/planet/page.xml new file mode 100644 index 0000000000..1278c8174c --- /dev/null +++ b/extra/webapps/planet/page.xml @@ -0,0 +1,64 @@ + + + + + + + + + + + + + + + .link-button { + padding: 0px; + background: none; + border: none; + } + + .inline { + display: inline; + } + + body, button { + font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif; + color:#444; + } + + a, .link { + color: #222; + border-bottom:1px dotted #666; + text-decoration:none; + } + + h1 a { + border: none; + } + + a:hover, .link:hover { + border-bottom:1px solid #66a; + } + + .error { color: #a00; } + + .field-label { + text-align: right; + } + + + + + + + + + + + + + + + diff --git a/extra/webapps/planet/planet.css b/extra/webapps/planet/planet.css new file mode 100644 index 0000000000..ea7b7d896c --- /dev/null +++ b/extra/webapps/planet/planet.css @@ -0,0 +1,30 @@ +h1.planet-title { + font-size:300%; +} + +.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/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor new file mode 100755 index 0000000000..966bcc1d0b --- /dev/null +++ b/extra/webapps/planet/planet.factor @@ -0,0 +1,174 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences sorting locals math +calendar alarms logging concurrency.combinators +db.types db.tuples db +rss xml.writer +http.server +http.server.crud +http.server.forms +http.server.actions +http.server.boilerplate +http.server.templating.chloe +http.server.components ; +IN: webapps.planet + +TUPLE: blog id name www-url atom-url ; + +blog "BLOGS" +{ + { "id" "ID" INTEGER +native-id+ } + { "name" "NAME" { VARCHAR 256 } +not-null+ } + { "www-url" "WWWURL" { VARCHAR 256 } +not-null+ } + { "atom-url" "ATOMURL" { VARCHAR 256 } +not-null+ } +} define-persistent + +: init-blog-table blog ensure-table ; + +: ( id -- todo ) + blog new + swap >>id ; + +: planet-template ( name -- template ) + "resource:extra/webapps/planet/" swap ".xml" 3append ; + +: ( -- form ) + "entry" + "entry" planet-template >>view-template + "entry-summary" planet-template >>summary-template + "title" add-field + "description" add-field + "pub-date" add-field ; + +: ( -- form ) + "blog" + "edit-blog" planet-template >>edit-template + "view-blog" planet-template >>view-template + "blog-summary" planet-template >>summary-template + "id" + hidden >>renderer + add-field + "name" + t >>required + add-field + "www-url" + t >>required + add-field + "atom-url" + t >>required + add-field ; + +: ( -- form ) + "planet-factor" + "planet" planet-template >>view-template + "mini-planet" planet-template >>summary-template + "postings" +plain+ add-field + "blogroll" +unordered+ add-field ; + +: blogroll ( -- seq ) + f select-tuples [ [ name>> ] compare ] sort ; + +TUPLE: planet-factor < dispatcher postings ; + +:: ( planet -- action ) + [let | form [ ] | + + [ + blank-values + + planet postings>> "postings" set-value + blogroll "blogroll" set-value + + form view-form + ] >>display + ] ; + +: safe-head ( seq n -- seq' ) + over length min head ; + +:: planet-feed ( planet -- feed ) + feed new + "[ planet-factor ]" >>title + "http://planet.factorcode.org" >>link + planet postings>> 30 safe-head >>entries ; + +:: ( planet -- action ) + + [ + "text/xml" + [ planet planet-feed feed>xml write-xml ] >>body + ] >>display ; + +: ( name entry -- entry' ) + clone [ ": " swap 3append ] change-title ; + +: fetch-feed ( url -- feed ) + download-feed entries>> ; + +\ fetch-feed DEBUG add-error-logging + +: fetch-blogroll ( blogroll -- entries ) + dup + [ atom-url>> fetch-feed ] parallel-map + [ >r name>> r> [ ] with map ] 2map concat ; + +: sort-entries ( entries -- entries' ) + [ [ pub-date>> ] compare ] sort ; + +: update-cached-postings ( planet -- ) + "webapps.planet" [ + blogroll fetch-blogroll sort-entries >>postings drop + ] with-logging ; + +:: ( planet -- action ) + + [ + planet update-cached-postings + "" f + ] >>display ; + +: start-update-task ( planet -- ) + [ update-cached-postings ] curry 10 minutes every drop ; + +:: ( -- responder ) + [let | blog-form [ ] + blog-ctor [ [ ] ] | + planet-factor new-dispatcher + dup >>default + dup "feed.xml" add-responder + dup "update" add-responder + + ! Administrative CRUD + blog-ctor "" "delete-blog" add-responder + blog-form blog-ctor "view-blog" add-responder + blog-form blog-ctor "view-blog" "edit-blog" add-responder + ] ; + +USING: namespaces io.files io.sockets +db.sqlite smtp +http.server.db +http.server.sessions +http.server.auth.login +http.server.auth.providers.db +http.server.sessions.storage.db ; + +: test-db "planet.db" resource-path sqlite-db ; + +: ( -- responder ) + + + "page" planet-template >>template + ! + ! sessions-in-db >>sessions + test-db ; + +: init-planet ( -- ) + ! test-db [ + ! init-blog-table + ! init-users-table + ! init-sessions-table + ! ] with-db + + + "planet" add-responder + main-responder set-global ; diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml new file mode 100644 index 0000000000..dc762fafc6 --- /dev/null +++ b/extra/webapps/planet/planet.xml @@ -0,0 +1,37 @@ + + + + + Planet Factor + + + + + + + + + + + + planet-factor is an Atom feed aggregator that collects the + contents of Factor-related blogs. It was inspired by + Planet Lisp. + + + + Syndicate + + + Blogroll + + + + Admin: Add Blog + | + Update + + + + + diff --git a/extra/webapps/planet/view-blog.xml b/extra/webapps/planet/view-blog.xml new file mode 100644 index 0000000000..fbc03aff25 --- /dev/null +++ b/extra/webapps/planet/view-blog.xml @@ -0,0 +1,41 @@ + + + + + View Blog + + + + + Blog name: + + + + + Home page: + + + + + + + + + Atom feed: + + + + + + + + + + Edit + | + + + Delete + + +
+ + Read More... +
+ planet-factor is an Atom feed aggregator that collects the + contents of Factor-related blogs. It was inspired by + Planet Lisp. +
+ + Syndicate +