basis/urls/encoding/encoding.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: arrays ascii assocs byte-arrays combinators
   4 combinators.short-circuit io.encodings io.encodings.string
   5 io.encodings.utf8 kernel linked-assocs make math math.parser
   6 namespaces present sequences sequences.private splitting strings ;
   7 IN: urls.encoding
   8
   9 : url-quotable? ( ch -- ? )
  10     {
  11         [ letter? ]
  12         [ LETTER? ]
  13         [ digit? ]
  14         [ "-._~/:" member? ]
  15     } 1|| ; foldable
  16
  17 ! see https://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 https://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 : hex% ( n -- )
  39     CHAR: % , >hex >upper 2 CHAR: 0 pad-head % ;
  40
  41 : hex-utf8% ( ch -- )
  42     1string utf8 encode [ hex% ] each ;
  43
  44 : (url-encode) ( str quot: ( ch -- ? ) -- encoded )
  45     [
  46         over byte-sequence? [
  47             '[ dup @ [ , ] [ hex% ] if ] each
  48         ] [
  49             [ present ] dip
  50             '[ dup @ [ , ] [ hex-utf8% ] if ] each
  51         ] if
  52     ] "" make ; inline
  53
  54 PRIVATE>
  55
  56 : url-encode ( obj -- encoded )
  57     [ url-quotable? ] (url-encode) ;
  58
  59 : url-encode-full ( obj -- encoded )
  60     [ unreserved? ] (url-encode) ;
  61
  62 <PRIVATE
  63
  64 : utf8% ( ch -- )
  65     building get utf8 encode-char ;
  66
  67 : url-decode-hex ( index str -- )
  68     2dup length 2 - >= [
  69         2drop
  70     ] [
  71         [ 1 + dup 2 + ] dip <slice> hex> [ , ] when*
  72     ] if ;
  73
  74 : url-decode-iter ( index str -- )
  75     2dup length >= [
  76         2drop
  77     ] [
  78         2dup nth-unsafe dup CHAR: % = [
  79             drop 2dup url-decode-hex [ 3 + ] dip
  80         ] [
  81             utf8% [ 1 + ] dip
  82         ] if url-decode-iter
  83     ] if ; inline recursive
  84
  85 PRIVATE>
  86
  87 : url-decode ( str -- decoded )
  88     [ 0 swap url-decode-iter ] "" make utf8 decode ;
  89
  90 <PRIVATE
  91
  92 : add-query-param ( value key assoc -- )
  93     [
  94         {
  95             { [ dup string? ] [ swap 2array ] }
  96             { [ dup array? ] [ swap suffix ] }
  97             { [ dup not ] [ drop ] }
  98         } cond
  99     ] change-at ;
 100
 101 PRIVATE>
 102
 103 : query-decode ( str -- decoded )
 104     "+" split "%20" join url-decode ;
 105
 106 : query>assoc ( query -- assoc )
 107     dup [
 108         "&" split <linked-hash> [
 109             [
 110                 [ "=" split1 [ dup [ query-decode ] when ] bi@ swap ] dip
 111                 add-query-param
 112             ] curry each
 113         ] keep
 114     ] when ;
 115
 116 : assoc>query ( assoc -- str )
 117     [
 118         [
 119             [ url-encode-full ] dip [
 120                 dup array? [ 1array ] unless
 121                 [ url-encode-full "=" glue , ] with each
 122             ] [ , ] if*
 123         ] assoc-each
 124     ] { } make "&" join ;
 125
 126 : escape-uri-component-char? ( ch -- ? )
 127     {
 128         [ letter? ]
 129         [ LETTER? ]
 130         [ digit? ]
 131         [ "-_.!~*'()" member? ]
 132     } 1|| not ; foldable
 133
 134 : encode-uri-component ( str -- str' )
 135     [
 136         [ dup escape-uri-component-char? [ hex-utf8% ] [ , ] if ] each
 137     ] "" make ;
 138
 139 : escape-uri-char? ( ch -- ? )
 140     {
 141         [ letter? ]
 142         [ LETTER? ]
 143         [ digit? ]
 144         [ ";,/?:@&=+$-_.!~*'()#" member? ]
 145     } 1|| not ; foldable
 146
 147 : encode-uri ( str -- str' )
 148     [
 149         [ dup escape-uri-char? [ hex-utf8% ] [ , ] if ] each
 150     ] "" make ;
 151
 152 <PRIVATE
 153
 154 : decode-uri-hex ( index str quot: ( ch -- ? ) -- )
 155     '[
 156         2dup length 2 - >= [
 157             2drop
 158         ] [
 159             [ 1 + dup 2 + ] dip <slice>
 160             dup hex> dup @ [ nip , ] [ CHAR: % , drop % ] if
 161         ] if
 162     ] call ; inline
 163
 164 : decode-uri-iter ( index str quot: ( ch -- ? ) -- )
 165     dup '[
 166         2dup length >= [
 167             2drop
 168         ] [
 169             2dup nth-unsafe dup CHAR: % = [
 170                 drop 2dup _ decode-uri-hex [ 3 + ] dip
 171             ] [
 172                 utf8% [ 1 + ] dip
 173             ] if _ decode-uri-iter
 174         ] if
 175     ] call ; inline recursive
 176
 177 PRIVATE>
 178
 179 : decode-uri-component ( str -- decoded )
 180     [ 0 swap [ escape-uri-component-char? ] decode-uri-iter ] "" make utf8 decode ;
 181
 182 : decode-uri ( str -- decoded )
 183     [ 0 swap [ escape-uri-char? ] decode-uri-iter ] "" make utf8 decode ;