Paste: cgi

! Copyright (C) 2009 John Benediktsson
! See http://factorcode.org/license.txt for BSD license

USING: assocs combinators environment io kernel math.parser
regexp sequences splitting strings unicode.case ;

IN: cgi

<PRIVATE

: set-at-each ( assoc sequence -- assoc' )
    [ [ second ] [ first ] bi pick set-at ] each ;

: push-at-each ( assoc sequence -- assoc' )
   ! '[ swap _ push-at ] assoc-each ;
    [ [ second ] [ first ] bi pick push-at ] each ;

: (unquote) ( s -- s' )
    [ 2 short head 16 base> [ 1string ] [ "" ] if* ] 
    [ 2 short tail ] bi append ;

: unquote ( s -- s' ) 
    "%" split { "" } append [ 1 head ] [ 1 tail ] bi
    [ (unquote) ] map append concat ;

: (query-string) ( string -- assoc' ) 
    "&" split [ ";" split ] map concat [ "=" split ] map 
    [ length 2 = ] filter [ second empty? not ] filter 
    [ H{ } clone ] dip push-at-each 
    [ [ unquote ] map ] assoc-map ;

: (content-type) ( string -- params media/type )
    ";" split unclip [ 
        [ "=" split ] map [ H{ } clone ] dip set-at-each 
    ] dip ;

: parse-get ( -- assoc ) 
    "QUERY_STRING" os-env "" or (query-string) ;

: (multipart) ( -- assoc ) 
    H{ } clone "multipart unsupported" throw ;

: (urlencoded) ( -- assoc ) 
    "CONTENT_LENGTH" os-env "0" or string>number 
    read [ "" ] [ "&" append ] if-empty
    "QUERY_STRING" os-env [ append ] when* (query-string) ;

: parse-post ( -- assoc ) 
    "CONTENT_TYPE" os-env "" or (content-type) {
       { "multipart/form-data"               [ (multipart) ] }
       { "application/x-www-form-urlencoded" [ (urlencoded) ] }
       [ drop parse-get ]
   } case nip ;

PRIVATE>

! TUPLE: cgi-form method form type ;

: <cgi-form> ( -- assoc ) 
    "REQUEST_METHOD" os-env "GET" or >upper {
        { "GET"  [ parse-get ] }
        { "POST" [ parse-post ] }
        [ "Unknown request method" throw ] 
    } case ;

: <cgi-simple-form> ( -- assoc )
    <cgi-form> [ first ] assoc-map ;

: cgi-escape ( s -- s' )
    R/ &/ "&amp;" re-replace
    R/ </ "&lt;" re-replace
    R/ >/ "&gt;" re-replace
    R/ "/ "&quot;" re-replace ;

: cgi-unescape ( s -- s' )
    R/ &lt;/ "<" re-replace
    R/ &gt;/ ">" re-replace
    R/ &quot;/ "\"" re-replace
    R/ &amp;/ "&" re-replace ;