! 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 ; IN: http.server.components ! Renderer protocol GENERIC: render-summary* ( value renderer -- ) GENERIC: render-view* ( value renderer -- ) GENERIC: render-edit* ( value id renderer -- ) M: object render-summary* render-view* ; TUPLE: field type ; C: field M: field render-view* drop write ; M: field render-edit* > =type [ =id ] [ =name ] bi =value input/> ; : render-error ( message -- ) write ; TUPLE: hidden < field ; : hidden ( -- renderer ) T{ hidden f "hidden" } ; inline M: hidden render-view* 2drop ; ! Component protocol SYMBOL: components TUPLE: component id required default renderer ; : component ( name -- component ) dup components get at [ ] [ "No such component: " prepend throw ] ?if ; GENERIC: init ( component -- component ) M: component init ; GENERIC: validate* ( value component -- result ) GENERIC: component-string ( value component -- string ) SYMBOL: values : value values get at ; : set-value values get set-at ; : blank-values H{ } clone values set ; : from-tuple values set ; : values-tuple values get mirror-object ; : render-view ( component -- ) [ id>> value ] [ component-string ] [ renderer>> ] tri render-view* ; > ] [ renderer>> ] bi render-edit* ; : render-edit-error ( component -- ) [ id>> value ] keep [ [ value>> ] dip render-edit-string ] [ drop reason>> render-error ] 2bi ; : value-or-default ( component -- value ) [ id>> value ] [ default>> ] bi or ; : render-edit-value ( component -- ) [ value-or-default ] [ component-string ] [ render-edit-string ] tri ; PRIVATE> : render-edit ( component -- ) dup id>> value validation-error? [ render-edit-error ] [ render-edit-value ] if ; : validate ( value component -- result ) '[ , over empty? [ [ default>> [ v-default ] when* ] [ required>> [ v-required ] when ] bi ] [ validate* ] if ] with-validator ; : new-component ( id class renderer -- component ) swap new swap >>renderer swap >>id init ; inline ! String input fields TUPLE: string < component one-line min-length max-length ; : new-string ( id class -- component ) "text" new-component t >>one-line ; inline : ( id -- component ) string new-string ; M: string validate* [ one-line>> [ v-one-line ] when ] [ min-length>> [ v-min-length ] when* ] [ max-length>> [ v-max-length ] when* ] tri ; M: string component-string drop ; ! Username fields TUPLE: username < string ; M: username init 2 >>min-length 20 >>max-length ; : ( id -- component ) username new-string ; M: username validate* call-next-method v-one-word ; ! E-mail fields TUPLE: email < string ; : ( id -- component ) email new-string 5 >>min-length 60 >>max-length ; M: email validate* call-next-method dup empty? [ v-email ] unless ; ! Don't send passwords back to the user TUPLE: password-renderer < field ; : password-renderer T{ password-renderer f "password" } ; : blank-password >r >r drop "" r> r> ; M: password-renderer render-edit* blank-password call-next-method ; ! Password fields TUPLE: password < string ; M: password init 6 >>min-length 60 >>max-length ; : ( id -- component ) password new-string password-renderer >>renderer ; M: password validate* call-next-method v-one-word ; ! Number fields TUPLE: number < string min-value max-value ; : ( id -- component ) number new-string ; M: number validate* [ v-number ] [ [ min-value>> [ v-min-value ] when* ] [ max-value>> [ v-max-value ] when* ] bi ] bi* ; M: number component-string drop dup [ number>string ] when ; ! Integer fields TUPLE: integer < number ; : ( id -- component ) integer new-string ; M: integer validate* call-next-method v-integer ; ! Simple captchas TUPLE: captcha < string ; : ( id -- component ) captcha new-string ; M: captcha validate* drop v-captcha ; ! Text areas TUPLE: textarea-renderer rows cols ; : new-textarea-renderer ( class -- renderer ) new 60 >>cols 20 >>rows ; : ( -- renderer ) textarea-renderer new-textarea-renderer ; M: textarea-renderer render-view* drop write ; M: textarea-renderer render-edit* ; TUPLE: text < string ; : new-text ( id class -- component ) new-string f >>one-line >>renderer ; : ( id -- component ) text new-text ; ! List components SYMBOL: +plain+ SYMBOL: +ordered+ SYMBOL: +unordered+ TUPLE: list-renderer component type ; C: list-renderer : render-list ( value component -- ) [ render-summary* ] curry each ; : render-ordered-list ( value component -- ) [
  • render-summary*
  • ] curry each ; : render-unordered-list ( value component -- ) [
  • render-summary*
  • ] curry each ; M: list-renderer render-view* [ component>> ] [ type>> ] bi { { +plain+ [ render-list ] } { +ordered+ [
      render-ordered-list
    ] } { +unordered+ [
      render-unordered-list
    ] } } case ; TUPLE: list < component ; : ( id component type -- list ) list swap new-component ; M: list component-string drop ;