2012-09-22 15:46:13 -04:00
|
|
|
! Copyright (C) 2009-2012 John Benediktsson
|
|
|
|
! See http://factorcode.org/license.txt for BSD license
|
|
|
|
|
|
|
|
USING: arrays assocs combinators environment io kernel
|
2015-11-04 16:06:23 -05:00
|
|
|
linked-assocs math.parser regexp sequences splitting strings
|
2016-03-31 02:29:48 -04:00
|
|
|
unicode urls.encoding ;
|
2012-09-22 15:46:13 -04:00
|
|
|
|
|
|
|
IN: cgi
|
|
|
|
|
|
|
|
<PRIVATE
|
|
|
|
|
2017-02-06 19:22:07 -05:00
|
|
|
: query-string ( string -- assoc )
|
2012-09-22 15:46:13 -04:00
|
|
|
query>assoc [ nip ] assoc-filter [
|
|
|
|
[ [ CHAR: \s = ] trim ]
|
|
|
|
[ dup string? [ 1array ] when ] bi*
|
|
|
|
] assoc-map ;
|
|
|
|
|
|
|
|
: parse-get ( -- assoc )
|
2017-02-06 19:22:07 -05:00
|
|
|
"QUERY_STRING" os-env "" or query-string ;
|
2012-09-22 15:46:13 -04:00
|
|
|
|
2017-02-06 19:22:07 -05:00
|
|
|
: content-type ( string -- params media/type )
|
2012-09-22 15:46:13 -04:00
|
|
|
";" split unclip [
|
2017-02-06 19:22:07 -05:00
|
|
|
[ LH{ } clone ] [ first query-string ] if-empty
|
2012-09-22 15:46:13 -04:00
|
|
|
] dip ;
|
|
|
|
|
2017-02-06 19:22:07 -05:00
|
|
|
: multipart ( -- assoc )
|
2012-09-22 15:46:13 -04:00
|
|
|
"multipart unsupported" throw ;
|
|
|
|
|
2017-02-06 19:22:07 -05:00
|
|
|
: urlencoded ( -- assoc )
|
2015-11-04 16:08:15 -05:00
|
|
|
"CONTENT_LENGTH" os-env [ string>number ] [ 0 ] if*
|
2012-09-22 15:46:13 -04:00
|
|
|
read [ "" ] [ "&" append ] if-empty
|
2017-02-06 19:22:07 -05:00
|
|
|
"QUERY_STRING" os-env [ append ] when* query-string ;
|
2012-09-22 15:46:13 -04:00
|
|
|
|
|
|
|
: parse-post ( -- assoc )
|
2017-02-06 19:22:07 -05:00
|
|
|
"CONTENT_TYPE" os-env "" or content-type {
|
|
|
|
{ "multipart/form-data" [ multipart ] }
|
|
|
|
{ "application/x-www-form-urlencoded" [ urlencoded ] }
|
2012-09-22 15:46:13 -04:00
|
|
|
[ drop parse-get ]
|
|
|
|
} case nip ;
|
|
|
|
|
|
|
|
PRIVATE>
|
|
|
|
|
|
|
|
: <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 ;
|