1 ! Copyright (C) 2008 Slava Pestov
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors calendar db.tuples db.types farkup
4 furnace.actions furnace.auth furnace.boilerplate
5 furnace.recaptcha furnace.redirection furnace.syndication
6 furnace.utilities html.forms http.server http.server.dispatchers
7 http.server.static kernel lcs make namespaces present random
8 regexp sequences simple-tokenizer sorting splitting unicode urls
12 : wiki-url ( rest path -- url )
13 [ "$wiki/" % % "/" % present % ] "" make
16 : view-url ( title -- url ) "view" wiki-url ;
18 : edit-url ( title -- url ) "edit" wiki-url ;
20 : revisions-url ( title -- url ) "revisions" wiki-url ;
22 : revision-url ( id -- url ) "revision" wiki-url ;
24 : user-edits-url ( author -- url ) "user-edits" wiki-url ;
26 TUPLE: wiki < dispatcher ;
28 SYMBOL: can-delete-wiki-articles?
30 can-delete-wiki-articles? define-capability
32 TUPLE: article title revision ;
35 { "title" "TITLE" { VARCHAR 256 } +not-null+ +user-assigned-id+ }
36 { "revision" "REVISION" INTEGER +not-null+ } ! revision id
39 : <article> ( title -- article ) article new swap >>title ;
41 TUPLE: revision id title author date content description ;
43 revision "REVISIONS" {
44 { "id" "ID" INTEGER +db-assigned-id+ }
45 { "title" "TITLE" { VARCHAR 256 } +not-null+ } ! article id
46 { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid
47 { "date" "DATE" TIMESTAMP +not-null+ }
48 { "content" "CONTENT" TEXT +not-null+ }
49 { "description" "DESCRIPTION" TEXT }
52 M: revision feed-entry-title
53 [ title>> ] [ drop " by " ] [ author>> ] tri 3append ;
55 M: revision feed-entry-date date>> ;
57 M: revision feed-entry-url id>> revision-url ;
59 : reverse-chronological-order ( seq -- sorted )
60 [ date>> ] inv-sort-by ;
62 : <revision> ( id -- revision )
63 revision new swap >>id ;
65 : validate-title ( -- )
66 { { "title" [ v-one-line ] } } validate-params ;
68 : validate-author ( -- )
69 { { "author" [ v-username ] } } validate-params ;
71 : <article-boilerplate> ( responder -- responder' )
73 { wiki "page-common" } >>template ;
75 : <main-article-action> ( -- action )
77 [ "Front Page" view-url <redirect> ] >>display ;
79 : latest-revision ( title -- revision/f )
80 <article> select-tuple
81 dup [ revision>> <revision> select-tuple ] when ;
83 : <view-article-action> ( -- action )
88 [ validate-title ] >>init
96 { wiki "view" } <chloe-content>
102 <article-boilerplate> ;
104 : <view-revision-action> ( -- action )
111 "id" value <revision>
112 select-tuple from-object
115 { wiki "view" } >>template
117 <article-boilerplate> ;
119 : <random-article-action> ( -- action )
122 article new select-tuples random
123 [ title>> ] [ "Front Page" ] if*
127 : amend-article ( revision article -- )
128 swap id>> >>revision update-tuple ;
130 : add-article ( revision -- )
131 [ title>> ] [ id>> ] bi article boa insert-tuple ;
133 : add-revision ( revision -- )
136 dup title>> <article> select-tuple
137 [ amend-article ] [ add-article ] if*
141 : <edit-article-action> ( -- action )
149 "title" value <article> select-tuple
150 [ revision>> <revision> select-tuple ]
151 [ f <revision> "title" value >>title ]
154 [ title>> "title" set-value ]
155 [ content>> "content" set-value ]
159 { wiki "edit" } >>template
161 <article-boilerplate> ;
163 : <submit-article-action> ( -- action )
171 { "content" [ v-required ] }
172 { "description" [ [ v-one-line ] v-optional ] }
176 "title" value >>title
179 "content" value >>content
180 "description" value >>description
181 [ add-revision ] [ title>> view-url <redirect> ] bi
185 "edit wiki articles" >>description ;
187 : <revisions-boilerplate> ( responder -- responder )
189 { wiki "revisions-common" } >>template ;
191 : list-revisions ( -- seq )
192 f <revision> "title" value >>title select-tuples
193 reverse-chronological-order ;
195 : <list-revisions-action> ( -- action )
202 list-revisions "revisions" set-value
205 { wiki "revisions" } >>template
207 <revisions-boilerplate>
208 <article-boilerplate> ;
210 : <list-revisions-feed-action> ( -- action )
215 [ validate-title ] >>init
217 [ "Revisions of " "title" value append ] >>title
219 [ "title" value revisions-url ] >>url
221 [ list-revisions ] >>entries ;
223 : rollback-description ( description -- description' )
224 [ "Rollback to '" "'" surround ] [ "Rollback" ] if* ;
226 : <rollback-action> ( -- action )
229 [ validate-integer-id ] >>validate
232 "id" value <revision> select-tuple
236 [ rollback-description ] change-description
238 [ title>> revisions-url <redirect> ] bi
242 "rollback wiki articles" >>description ;
244 : list-changes ( -- seq )
245 f <revision> select-tuples
246 reverse-chronological-order ;
248 : <list-changes-action> ( -- action )
250 [ list-changes "revisions" set-value ] >>init
251 { wiki "changes" } >>template
253 <revisions-boilerplate> ;
255 : <list-changes-feed-action> ( -- action )
257 [ URL" $wiki/changes" ] >>url
258 [ "All changes" ] >>title
259 [ list-changes ] >>entries ;
261 : <delete-action> ( -- action )
264 [ validate-title ] >>validate
267 "title" value <article> delete-tuples
268 f <revision> "title" value >>title delete-tuples
269 URL" $wiki" <redirect>
273 "delete wiki articles" >>description
274 { can-delete-wiki-articles? } >>capabilities ;
276 : <diff-action> ( -- action )
281 { "old-id" [ v-integer ] }
282 { "new-id" [ v-integer ] }
286 [ value <revision> select-tuple ] bi@
288 over title>> "title" set-value
289 [ "old" [ from-object ] nest-form ]
290 [ "new" [ from-object ] nest-form ]
293 [ [ content>> split-lines ] bi@ lcs-diff "diff" set-value ]
297 { wiki "diff" } >>template
299 <article-boilerplate> ;
301 : <list-articles-action> ( -- action )
305 f <article> select-tuples
310 { wiki "articles" } >>template ;
312 : <search-articles-action> ( -- action )
316 "search" param [ unicode:blank? ] trim
317 dup "search" set-value
321 " " "\s+" replace "\\b" dup surround
322 "i" <optioned-regexp>
327 f <article> select-tuples
329 [ revision>> <revision> select-tuple ] map
330 swap '[ content>> _ [ first-match ] with all? ] filter
333 [ "results" set-value ]
334 [ not "empty" set-value ] bi
337 { wiki "search" } >>template ;
339 : list-user-edits ( -- seq )
340 f <revision> "author" value >>author select-tuples
341 reverse-chronological-order ;
343 : <user-edits-action> ( -- action )
350 list-user-edits "revisions" set-value
353 { wiki "user-edits" } >>template
355 <revisions-boilerplate> ;
357 : <user-edits-feed-action> ( -- action )
360 [ validate-author ] >>init
361 [ "Edits by " "author" value append ] >>title
362 [ "author" value user-edits-url ] >>url
363 [ list-user-edits ] >>entries ;
365 : init-sidebars ( -- )
366 "Contents" latest-revision [ "contents" [ from-object ] nest-form ] when*
367 "Footer" latest-revision [ "footer" [ from-object ] nest-form ] when* ;
369 : init-relative-link-prefix ( -- )
370 URL" $wiki/view/" adjust-url present relative-link-prefix set ;
372 : <wiki> ( -- dispatcher )
374 <main-article-action> "" add-responder
375 <view-article-action> "view" add-responder
376 <view-revision-action> "revision" add-responder
377 <random-article-action> "random" add-responder
378 <list-revisions-action> "revisions" add-responder
379 <list-revisions-feed-action> "revisions.atom" add-responder
380 <diff-action> "diff" add-responder
381 <edit-article-action> "edit" add-responder
382 <submit-article-action> "submit" add-responder
383 <rollback-action> "rollback" add-responder
384 <user-edits-action> "user-edits" add-responder
385 <list-articles-action> "articles" add-responder
386 <search-articles-action> "search" add-responder
387 <list-changes-action> "changes" add-responder
388 <user-edits-feed-action> "user-edits.atom" add-responder
389 <list-changes-feed-action> "changes.atom" add-responder
390 <delete-action> "delete" add-responder
391 "vocab:webapps/wiki/icons/" <static> "icons" add-responder
393 [ init-sidebars init-relative-link-prefix ] >>init
394 { wiki "wiki-common" } >>template ;