Paste: wiki source code

! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel hashtables calendar random assocs
namespaces make splitting sequences sorting math.order present
io.files io.encodings.ascii
syndication farkup
html.components html.forms
http.server
http.server.dispatchers
furnace
furnace.actions
furnace.redirection
furnace.auth
furnace.auth.login
furnace.boilerplate
furnace.syndication
validators
db.types db.tuples lcs farkup urls ;
IN: webapps.wiki

: wiki-url ( rest path -- url )
    [ "$wiki/" % % "/" % present % ] "" make
    <url> swap >>path ;

: view-url ( title -- url ) "view" wiki-url ;

: edit-url ( title -- url ) "edit" wiki-url ;

: revisions-url ( title -- url ) "revisions" wiki-url ;

: revision-url ( id -- url ) "revision" wiki-url ;

: user-edits-url ( author -- url ) "user-edits" wiki-url ;

TUPLE: wiki < dispatcher ;

SYMBOL: can-delete-wiki-articles?

can-delete-wiki-articles? define-capability

TUPLE: article title revision ;

article "ARTICLES" {
    { "title" "TITLE" { VARCHAR 256 } +not-null+ +user-assigned-id+ }
    { "revision" "REVISION" INTEGER +not-null+ } ! revision id
} define-persistent

: <article> ( title -- article ) article new swap >>title ;

TUPLE: revision id title author date content parsed description ;

revision "REVISIONS" {
    { "id" "ID" INTEGER +db-assigned-id+ }
    { "title" "TITLE" { VARCHAR 256 } +not-null+ } ! article id
    { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid
    { "date" "DATE" TIMESTAMP +not-null+ }
    { "content" "CONTENT" TEXT +not-null+ }
    { "parsed" "PARSED" FACTOR-BLOB +not-null+ } ! Farkup AST
    { "description" "DESCRIPTION" TEXT }
} define-persistent

M: revision feed-entry-title
    [ title>> ] [ drop " by " ] [ author>> ] tri 3append ;

M: revision feed-entry-date date>> ;

M: revision feed-entry-url id>> revision-url ;

: reverse-chronological-order ( seq -- sorted )
    [ [ date>> ] compare invert-comparison ] sort ;

: <revision> ( id -- revision )
    revision new swap >>id ;

: compute-html ( revision -- )
    dup content>> parse-farkup >>parsed drop ;

: validate-title ( -- )
    { { "title" [ v-one-line ] } } validate-params ;

: validate-author ( -- )
    { { "author" [ v-username ] } } validate-params ;

: <article-boilerplate> ( responder -- responder' )
    <boilerplate>
        { wiki "page-common" } >>template ;

: <main-article-action> ( -- action )
    <action>
        [ "Front Page" view-url <redirect> ] >>display ;

: latest-revision ( title -- revision/f )
    <article> select-tuple
    dup [ revision>> <revision> select-tuple ] when ;

: <view-article-action> ( -- action )
    <action>

        "title" >>rest

        [ validate-title ] >>init

        [
            "title" value dup latest-revision [
                from-object
                { wiki "view" } <chloe-content>
            ] [
                edit-url <redirect>
            ] ?if
        ] >>display

    <article-boilerplate> ;

: <view-revision-action> ( -- action )
    <page-action>

        "id" >>rest

        [
            validate-integer-id
            "id" value <revision>
            select-tuple from-object
        ] >>init

        { wiki "view" } >>template
    
    <article-boilerplate> ;

: <random-article-action> ( -- action )
    <action>
        [
            article new select-tuples random
            [ title>> ] [ "Front Page" ] if*
            view-url <redirect>
        ] >>display ;

: amend-article ( revision article -- )
    swap id>> >>revision update-tuple ;

: add-article ( revision -- )
    [ title>> ] [ id>> ] bi article boa insert-tuple ;

: add-revision ( revision -- )
    [ compute-html ]
    [ insert-tuple ]
    [
        dup title>> <article> select-tuple
        [ amend-article ] [ add-article ] if*
    ]
    tri ;

: <edit-article-action> ( -- action )
    <page-action>

        "title" >>rest

        [
            validate-title

            "title" value <article> select-tuple
            [ revision>> <revision> select-tuple ]
            [ f <revision> "title" value >>title ]
            if*

            [ title>> "title" set-value ]
            [ content>> "content" set-value ]
            bi
        ] >>init

        { wiki "edit" } >>template

    <article-boilerplate> ;

: <submit-article-action> ( -- action )
    <action>
        [
            validate-title

            {
                { "content" [ v-required ] }
                { "description" [ [ v-one-line ] v-optional ] }
            } validate-params

            f <revision>
                "title" value >>title
                now >>date
                username >>author
                "content" value >>content
                "description" value >>description
            [ add-revision ] [ title>> view-url <redirect> ] bi
        ] >>submit

    <protected>
        "edit wiki articles" >>description ;

: <revisions-boilerplate> ( responder -- responder )
    <boilerplate>
        { wiki "revisions-common" } >>template ;

: list-revisions ( -- seq )
    f <revision> "title" value >>title select-tuples
    reverse-chronological-order ;

: <list-revisions-action> ( -- action )
    <page-action>

        "title" >>rest

        [
            validate-title
            list-revisions "revisions" set-value
        ] >>init

        { wiki "revisions" } >>template

    <revisions-boilerplate>
    <article-boilerplate> ;

: <list-revisions-feed-action> ( -- action )
    <feed-action>

        "title" >>rest

        [ validate-title ] >>init

        [ "Revisions of " "title" value append ] >>title

        [ "title" value revisions-url ] >>url

        [ list-revisions ] >>entries ;

: rollback-description ( description -- description' )
    [ "Rollback of '" swap "'" 3append ] [ "Rollback" ] if* ;

: <rollback-action> ( -- action )
    <action>

        [ validate-integer-id ] >>validate

        [
            "id" value <revision> select-tuple
                f >>id
                now >>date
                username >>author
                [ rollback-description ] change-description
            [ add-revision ]
            [ title>> revisions-url <redirect> ] bi
        ] >>submit
    
    <protected>
        "rollback wiki articles" >>description ;

: list-changes ( -- seq )
    f <revision> select-tuples
    reverse-chronological-order ;

: <list-changes-action> ( -- action )
    <page-action>
        [ list-changes "revisions" set-value ] >>init
        { wiki "changes" } >>template

    <revisions-boilerplate> ;

: <list-changes-feed-action> ( -- action )
    <feed-action>
        [ URL" $wiki/changes" ] >>url
        [ "All changes" ] >>title
        [ list-changes ] >>entries ;

: <delete-action> ( -- action )
    <action>

        [ validate-title ] >>validate

        [
            "title" value <article> delete-tuples
            f <revision> "title" value >>title delete-tuples
            URL" $wiki" <redirect>
        ] >>submit

     <protected>
        "delete wiki articles" >>description
        { can-delete-wiki-articles? } >>capabilities ;

: <diff-action> ( -- action )
    <page-action>

        [
            {
                { "old-id" [ v-integer ] }
                { "new-id" [ v-integer ] }
            } validate-params

            "old-id" "new-id"
            [ value <revision> select-tuple ] bi@
            [
                over title>> "title" set-value
                [ "old" [ from-object ] nest-form ]
                [ "new" [ from-object ] nest-form ]
                bi*
            ]
            [ [ content>> string-lines ] bi@ diff "diff" set-value ]
            2bi
        ] >>init

        { wiki "diff" } >>template

    <article-boilerplate> ;

: <list-articles-action> ( -- action )
    <page-action>

        [
            f <article> select-tuples
            [ [ title>> ] compare ] sort
            "articles" set-value
        ] >>init

        { wiki "articles" } >>template ;

: list-user-edits ( -- seq )
    f <revision> "author" value >>author select-tuples
    reverse-chronological-order ;

: <user-edits-action> ( -- action )
    <page-action>

        "author" >>rest

        [
            validate-author
            list-user-edits "revisions" set-value
        ] >>init

        { wiki "user-edits" } >>template

    <revisions-boilerplate> ;

: <user-edits-feed-action> ( -- action )
    <feed-action>
        "author" >>rest
        [ validate-author ] >>init
        [ "Edits by " "author" value append ] >>title
        [ "author" value user-edits-url ] >>url
        [ list-user-edits ] >>entries ;

: init-sidebars ( -- )
    "Contents" latest-revision [ "contents" [ from-object ] nest-form ] when*
    "Footer" latest-revision [ "footer" [ from-object ] nest-form ] when* ;

: init-relative-link-prefix ( -- )
    URL" $wiki/view/" adjust-url present relative-link-prefix set ;

: <wiki> ( -- dispatcher )
    wiki new-dispatcher
        <main-article-action> "" add-responder
        <view-article-action> "view" add-responder
        <view-revision-action> "revision" add-responder
        <random-article-action> "random" add-responder
        <list-revisions-action> "revisions" add-responder
        <list-revisions-feed-action> "revisions.atom" add-responder
        <diff-action> "diff" add-responder
        <edit-article-action> "edit" add-responder
        <submit-article-action> "submit" add-responder
        <rollback-action> "rollback" add-responder
        <user-edits-action> "user-edits" add-responder
        <list-articles-action> "articles" add-responder
        <list-changes-action> "changes" add-responder
        <user-edits-feed-action> "user-edits.atom" add-responder
        <list-changes-feed-action> "changes.atom" add-responder
        <delete-action> "delete" add-responder
    <boilerplate>
        [ init-sidebars init-relative-link-prefix ] >>init
        { wiki "wiki-common" } >>template ;

: init-wiki ( -- )
    "resource:extra/webapps/wiki/initial-content" directory* keys
    [
        dup file-name ".txt" ?tail [
            swap ascii file-contents
            f <revision>
                swap >>content
                swap >>title
                "slava" >>author
                now >>date
            add-revision
        ] [ 2drop ] if
    ] each ;