factor/extra/webapps/pastebin/pastebin.factor

! Copyright (C) 2007, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs sorting sequences kernel accessors
hashtables sequences.lib db.types db.tuples db combinators
calendar calendar.format math.parser rss urls xml.writer
xmode.catalog validators html.components html.templates.chloe
http.server
furnace.actions
furnace.auth
furnace.auth.login
furnace.boilerplate ;
IN: webapps.pastebin

! ! !
! DOMAIN MODEL
! ! !

TUPLE: entity id summary author mode date contents ;

entity f
{
    { "id" "ID" INTEGER +db-assigned-id+ }
    { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
    { "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
    { "mode" "MODE" { VARCHAR 256 } +not-null+ }
    { "date" "DATE" DATETIME +not-null+ }
    { "contents" "CONTENTS" TEXT +not-null+ }
} define-persistent

TUPLE: paste < entity annotations ;

\ paste "PASTES" { } define-persistent

: <paste> ( id -- paste )
    \ paste new
        swap >>id ;

: pastes ( -- pastes )
    f <paste> select-tuples ;

TUPLE: annotation < entity parent ;

annotation "ANNOTATIONS"
{
    { "parent" "PARENT" INTEGER +not-null+ }
} define-persistent

: <annotation> ( parent id -- annotation )
    annotation new
        swap >>id
        swap >>parent ;

: fetch-annotations ( paste -- paste )
    dup annotations>> [
        dup id>> f <annotation> select-tuples >>annotations
    ] unless ;

: paste ( id -- paste )
    <paste> select-tuple fetch-annotations ;

! ! !
! LINKS, ETC
! ! !

: pastebin-link ( -- url )
    URL" $pastebin/list" ;

GENERIC: entity-link ( entity -- url )

: paste-link ( id -- url )
    <url>
        "$pastebin/paste" >>path
        swap "id" set-query-param ;

M: paste entity-link
    id>> paste-link ;

: annotation-link ( parent id -- url )
    <url>
        "$pastebin/paste" >>path
        swap number>string >>anchor
        swap "id" set-query-param ;

M: annotation entity-link
    [ parent>> ] [ id>> ] bi annotation-link ;

! ! !
! PASTE LIST
! ! !

: <pastebin-action> ( -- action )
    <page-action>
        [ pastes "pastes" set-value ] >>init
        "$pastebin/pastebin" >>template ;

: pastebin-feed-entries ( seq -- entries )
    <reversed> 20 short head [
        entry new
            swap
            [ summary>> >>title ]
            [ date>> >>pub-date ]
            [ entity-link adjust-url >>link ]
            tri
    ] map ;

: pastebin-feed ( -- feed )
    feed new
        "Factor Pastebin" >>title
        pastebin-link >>link
        pastes pastebin-feed-entries >>entries ;

: <pastebin-feed-action> ( -- action )
    <feed-action> [ pastebin-feed ] >>feed ;

! ! !
! PASTES
! ! !

: <paste-action> ( -- action )
    <page-action>
        [
            validate-integer-id
            "id" value paste from-object

            "id" value
            "new-annotation" [
                "id" set-value
                mode-names "modes" set-value
                "factor" "mode" set-value
            ] nest-values
        ] >>init

        "$pastebin/paste" >>template ;

: paste-feed-entries ( paste -- entries )
    fetch-annotations annotations>> pastebin-feed-entries ;

: paste-feed ( paste -- feed )
    feed new
        swap
        [ "Paste " swap id>> number>string append >>title ]
        [ entity-link adjust-url >>link ]
        [ paste-feed-entries >>entries ]
        tri ;

: <paste-feed-action> ( -- action )
    <feed-action>
        [ validate-integer-id ] >>init
        [ "id" value paste paste-feed ] >>feed ;

: validate-entity ( -- )
    {
        { "summary" [ v-one-line ] }
        { "author" [ v-one-line ] }
        { "mode" [ v-mode ] }
        { "contents" [ v-required ] }
        { "captcha" [ v-captcha ] }
    } validate-params ;

: deposit-entity-slots ( tuple -- )
    now >>date
    { "summary" "author" "mode" "contents" } deposit-slots ;

: <new-paste-action> ( -- action )
    <page-action>
        [
            "factor" "mode" set-value
            mode-names "modes" set-value
        ] >>init

        "$pastebin/new-paste" >>template

        [
            validate-entity

            f <paste>
            [ deposit-entity-slots ]
            [ insert-tuple ]
            [ id>> paste-link <redirect> ]
            tri
        ] >>submit ;

: <delete-paste-action> ( -- action )
    <action>
        [ validate-integer-id ] >>validate

        [
            "id" value <paste> delete-tuples
            "id" value f <annotation> delete-tuples
            URL" $pastebin/list" <redirect>
        ] >>submit ;

! ! !
! ANNOTATIONS
! ! !

: <new-annotation-action> ( -- action )
    <action>
        [
            { { "id" [ v-integer ] } } validate-params
            "id" value paste-link <redirect>
        ] >>display

        [
            { { "id" [ v-integer ] } } validate-params
            validate-entity
        ] >>validate

        [
            "id" value f <annotation>
            [ deposit-entity-slots ]
            [ insert-tuple ]
            [ entity-link <redirect> ]
            tri
        ] >>submit ;

: <delete-annotation-action> ( -- action )
    <action>
        [ { { "id" [ v-number ] } } validate-params ] >>validate

        [
            f "id" value <annotation> select-tuple
            [ delete-tuples ]
            [ parent>> paste-link <redirect> ]
            bi
        ] >>submit ;

TUPLE: pastebin < dispatcher ;

SYMBOL: can-delete-pastes?

can-delete-pastes? define-capability

: <pastebin> ( -- responder )
    pastebin new-dispatcher
        <pastebin-action> "list" add-main-responder
        <pastebin-feed-action> "list.atom" add-responder
        <paste-action> "paste" add-responder
        <paste-feed-action> "paste.atom" add-responder
        <new-paste-action> "new-paste" add-responder
        <delete-paste-action> { can-delete-pastes? } <protected> "delete-paste" add-responder
        <new-annotation-action> "new-annotation" add-responder
        <delete-annotation-action> { can-delete-pastes? } <protected> "delete-annotation" add-responder
    <boilerplate>
        "$pastebin/pastebin-common" >>template ;

: init-pastes-table \ paste ensure-table ;

: init-annotations-table annotation ensure-table ;