basis/urls/encoding/encoding.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel ascii combinators combinators.short-circuit
   4 sequences splitting fry namespaces make assocs arrays strings
   5 io.encodings.string io.encodings.utf8 math math.parser accessors
   6 hashtables present ;
   7 IN: urls.encoding
   8
   9 : url-quotable? ( ch -- ? )
  10     {
  11         [ letter? ]
  12         [ LETTER? ]
  13         [ digit? ]
  14         [ "/_-.:" member? ]
  15     } 1|| ; foldable
  16
  17 ! see http://tools.ietf.org/html/rfc3986#section-2.2
  18 : gen-delim? ( ch -- ? )
  19     ":/?#[]@" member? ; foldable
  20
  21 : sub-delim? ( ch -- ? )
  22     "!$&'()*+,;=" member? ; foldable
  23
  24 : reserved? ( ch -- ? )
  25     [ gen-delim? ] [ sub-delim? ] bi or ; foldable
  26
  27 ! see http://tools.ietf.org/html/rfc3986#section-2.3
  28 : unreserved? ( ch -- ? )
  29     {
  30         [ letter? ]
  31         [ LETTER? ]
  32         [ digit? ]
  33         [ "-._~" member? ]
  34     } 1|| ; foldable
  35
  36 <PRIVATE
  37
  38 : push-utf8 ( ch -- )
  39     1string utf8 encode
  40     [ CHAR: % , >hex >upper 2 CHAR: 0 pad-head % ] each ;
  41
  42 PRIVATE>
  43
  44 : url-encode ( str -- encoded )
  45     [
  46         [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
  47     ] "" make ;
  48
  49 : url-encode-full ( str -- encoded )
  50     [
  51         [ dup unreserved? [ , ] [ push-utf8 ] if ] each
  52     ] "" make ;
  53
  54 <PRIVATE
  55
  56 : url-decode-hex ( index str -- )
  57     2dup length 2 - >= [
  58         2drop
  59     ] [
  60         [ 1 + dup 2 + ] dip subseq  hex> [ , ] when*
  61     ] if ;
  62
  63 : url-decode-% ( index str -- index str )
  64     2dup url-decode-hex ;
  65
  66 : url-decode-iter ( index str -- )
  67     2dup length >= [
  68         2drop
  69     ] [
  70         2dup nth dup CHAR: % = [
  71             drop url-decode-% [ 3 + ] dip
  72         ] [
  73             , [ 1 + ] dip
  74         ] if url-decode-iter
  75     ] if ;
  76
  77 PRIVATE>
  78
  79 : url-decode ( str -- decoded )
  80     [ 0 swap url-decode-iter ] "" make utf8 decode ;
  81
  82 : query-decode ( str -- decoded )
  83     [ dup CHAR: + = [ drop "%20" ] [ 1string ] if ] { } map-as
  84     concat url-decode ;
  85
  86 <PRIVATE
  87
  88 : add-query-param ( value key assoc -- )
  89     [
  90         at [
  91             {
  92                 { [ dup string? ] [ swap 2array ] }
  93                 { [ dup array? ] [ swap suffix ] }
  94                 { [ dup not ] [ drop ] }
  95             } cond
  96         ] when*
  97     ] 2keep set-at ;
  98
  99 : assoc-strings ( assoc -- assoc' )
 100     [
 101         {
 102             { [ dup not ] [ ] }
 103             { [ dup array? ] [ [ present ] map ] }
 104             [ present 1array ]
 105         } cond
 106     ] assoc-map ;
 107
 108 PRIVATE>
 109
 110 : query>assoc ( query -- assoc )
 111     dup [
 112         "&;" split H{ } clone [
 113             [
 114                 [ "=" split1 [ dup [ query-decode ] when ] bi@ swap ] dip
 115                 add-query-param
 116             ] curry each
 117         ] keep
 118     ] when ;
 119
 120 : assoc>query ( assoc -- str )
 121     [
 122         assoc-strings [
 123             [ url-encode ] dip
 124             [ [ url-encode "=" glue , ] with each ] [ , ] if*
 125         ] assoc-each
 126     ] { } make "&" join ;