factor/extra/http/server/validators/validators.factor

! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences math namespaces
math.parser assocs new-slots regexp fry unicode.categories
combinators.cleave sequences ;
IN: http.server.validators

TUPLE: validation-error value reason ;

: validation-error ( value reason -- * )
    \ validation-error construct-boa throw ;

: v-default ( str def -- str )
    over empty? spin ? ;

: v-required ( str -- str )
    dup empty? [ "required" validation-error ] when ;

: v-min-length ( str n -- str )
    over length over < [
        [ "must be at least " % # " characters" % ] "" make
        validation-error
    ] [
        drop
    ] if ;

: v-max-length ( str n -- str )
    over length over > [
        [ "must be no more than " % # " characters" % ] "" make
        validation-error
    ] [
        drop
    ] if ;

: v-number ( str -- n )
    dup string>number [ ] [
        "must be a number" validation-error
    ] ?if ;

: v-min-value ( x n -- x )
    2dup < [
        [ "must be at least " % # ] "" make
        validation-error
    ] [
        drop
    ] if ;

: v-max-value ( x n -- x )
    2dup > [
        [ "must be no more than " % # ] "" make
        validation-error
    ] [
        drop
    ] if ;

: v-regexp ( str what regexp -- str )
    >r over r> matches?
    [ drop ] [ "invalid " swap append validation-error ] if ;

: 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
    v-regexp ;

: v-captcha ( str -- str )
    dup empty? [ "must remain blank" validation-error ] unless ;

: v-one-line ( str -- str )
    dup "\r\n" seq-intersect empty?
    [ "must be a single line" validation-error ] unless ;

: v-one-word ( str -- str )
    dup [ alpha? ] all?
    [ "must be a single word" validation-error ] unless ;