97 lines
2.1 KiB
Factor
97 lines
2.1 KiB
Factor
! Copyright (C) 2008 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: kernel ascii combinators combinators.short-circuit
|
|
sequences splitting fry namespaces make assocs arrays strings
|
|
io.sockets io.sockets.secure io.encodings.string
|
|
io.encodings.utf8 math math.parser accessors hashtables present ;
|
|
IN: urls.encoding
|
|
|
|
: url-quotable? ( ch -- ? )
|
|
{
|
|
[ letter? ]
|
|
[ LETTER? ]
|
|
[ digit? ]
|
|
[ "/_-.:" member? ]
|
|
} 1|| ; foldable
|
|
|
|
<PRIVATE
|
|
|
|
: push-utf8 ( ch -- )
|
|
1string utf8 encode
|
|
[ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
|
|
|
|
PRIVATE>
|
|
|
|
: url-encode ( str -- encoded )
|
|
[
|
|
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
|
|
] "" make ;
|
|
|
|
<PRIVATE
|
|
|
|
: url-decode-hex ( index str -- )
|
|
2dup length 2 - >= [
|
|
2drop
|
|
] [
|
|
[ 1+ dup 2 + ] dip subseq hex> [ , ] when*
|
|
] if ;
|
|
|
|
: url-decode-% ( index str -- index str )
|
|
2dup url-decode-hex ;
|
|
|
|
: url-decode-iter ( index str -- )
|
|
2dup length >= [
|
|
2drop
|
|
] [
|
|
2dup nth dup CHAR: % = [
|
|
drop url-decode-% [ 3 + ] dip
|
|
] [
|
|
, [ 1+ ] dip
|
|
] if url-decode-iter
|
|
] if ;
|
|
|
|
PRIVATE>
|
|
|
|
: url-decode ( str -- decoded )
|
|
[ 0 swap url-decode-iter ] "" make utf8 decode ;
|
|
|
|
: query-decode ( str -- decoded )
|
|
[ dup CHAR: + = [ drop "%20" ] [ 1string ] if ] { } map-as
|
|
concat url-decode ;
|
|
|
|
<PRIVATE
|
|
|
|
: add-query-param ( value key assoc -- )
|
|
[
|
|
at [
|
|
{
|
|
{ [ dup string? ] [ swap 2array ] }
|
|
{ [ dup array? ] [ swap suffix ] }
|
|
{ [ dup not ] [ drop ] }
|
|
} cond
|
|
] when*
|
|
] 2keep set-at ;
|
|
|
|
PRIVATE>
|
|
|
|
: query>assoc ( query -- assoc )
|
|
dup [
|
|
"&;" split H{ } clone [
|
|
[
|
|
[ "=" split1 [ dup [ query-decode ] when ] bi@ swap ] dip
|
|
add-query-param
|
|
] curry each
|
|
] keep
|
|
] when ;
|
|
|
|
: assoc>query ( assoc -- str )
|
|
[
|
|
dup array? [ [ present ] map ] [ present 1array ] if
|
|
] assoc-map
|
|
[
|
|
[
|
|
[ url-encode ] dip
|
|
[ url-encode "=" swap 3append , ] with each
|
|
] assoc-each
|
|
] { } make "&" join ;
|