extra/punycode/punycode.factor

   1 ! Copyright (C) 2020 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors arrays ascii assocs byte-arrays combinators
   5 io.encodings.string io.encodings.utf8 kernel lexer linked-assocs
   6 literals locals make math math.order math.parser multiline
   7 namespaces peg.ebnf present prettyprint.backend
   8 prettyprint.custom prettyprint.sections regexp sbufs sequences
   9 sequences.extras sequences.generalizations sets sorting
  10 splitting strings strings.parser urls urls.encoding
  11 urls.encoding.private urls.private ;
  12
  13 IN: punycode
  14
  15 <PRIVATE
  16
  17 <<
  18 CONSTANT: BASE   36
  19 CONSTANT: TMIN   1
  20 CONSTANT: TMAX   26
  21 CONSTANT: SKEW   38
  22 CONSTANT: DAMP   700
  23 CONSTANT: BIAS   72
  24 CONSTANT: N      128
  25 CONSTANT: DIGITS $[ "abcdefghijklmnopqrstuvwxyz0123456789" >byte-array ]
  26 >>
  27
  28 : threshold ( j bias -- T )
  29     [ BASE * ] [ - ] bi* TMIN TMAX clamp ;
  30
  31 :: adapt ( delta! #chars first? -- bias )
  32     delta first? DAMP 2 ? /i delta!
  33     delta dup #chars /i + delta!
  34     0 [ delta $[ BASE TMIN - TMAX * 2 /i ] > ] [
  35         delta $[ BASE TMIN - ] /i delta!
  36         BASE +
  37     ] while BASE delta * delta SKEW + /i + ;
  38
  39 : segregate ( str -- base extended )
  40     [ N < ] partition members natural-sort ;
  41
  42 :: find-pos ( str ch i pos -- i' pos' )
  43     i pos 1 + str [
  44         ch <=> {
  45             { +eq+ [ 1 + t ] }
  46             { +lt+ [ 1 + f ] }
  47             [ drop f ]
  48         } case
  49     ] find-from drop [ drop -1 -1 ] unless* ;
  50
  51 :: insertion-unsort ( str extended -- deltas )
  52     V{ } clone :> accum
  53     N :> oldch!
  54     -1 :> oldi!
  55     extended [| ch |
  56         -1 :> i!
  57         -1 :> pos!
  58         str [ ch < ] count :> curlen
  59         curlen 1 + ch oldch - * :> delta!
  60         [
  61             str ch i pos find-pos pos! i!
  62             i -1 = [
  63                 f
  64             ] [
  65                 i oldi - delta + delta!
  66                 delta 1 - accum push
  67                 i oldi!
  68                 0 delta!
  69                 t
  70             ] if
  71         ] loop
  72         ch oldch!
  73     ] each accum ;
  74
  75 :: encode-delta ( delta! bias -- seq )
  76     SBUF" " clone :> accum
  77     0 :> j!
  78     [
  79         j 1 + j!
  80         j bias threshold :> T
  81         delta T < [
  82             f
  83             delta
  84         ] [
  85             t
  86             delta T - BASE T - /mod T + swap delta!
  87         ] if DIGITS nth accum push
  88     ] loop accum ;
  89
  90 :: encode-deltas ( baselen deltas -- seq )
  91     SBUF" " clone :> accum
  92     BIAS :> bias!
  93     deltas [| delta i |
  94         delta bias encode-delta accum push-all
  95         delta baselen i + 1 + i 0 = adapt bias!
  96     ] each-index accum ;
  97
  98 PRIVATE>
  99
 100 :: >punycode ( str -- punicode )
 101     str segregate :> ( base extended )
 102     str extended insertion-unsort :> deltas
 103     base length deltas encode-deltas
 104     base [ "-" rot 3append ] unless-empty "" like ;
 105
 106 <PRIVATE
 107
 108 ERROR: invalid-digit char ;
 109
 110 :: decode-digit ( ch -- digit )
 111     {
 112         { [ ch CHAR: A CHAR: Z between? ] [ ch CHAR: A - ] }
 113         { [ ch CHAR: 0 CHAR: 9 between? ] [ ch CHAR: 0 26 - - ] }
 114         [ ch invalid-digit ]
 115     } cond ;
 116
 117 :: decode-delta ( extended extpos! bias -- extpos' delta )
 118     0 :> delta!
 119     1 :> w!
 120     0 :> j!
 121     [
 122         j 1 + j!
 123         j bias threshold :> T
 124         extpos extended nth decode-digit :> digit
 125         extpos 1 + extpos!
 126         digit w * delta + delta!
 127         BASE T - w * w!
 128         digit T >=
 129     ] loop extpos delta ;
 130
 131 ERROR: invalid-character char ;
 132
 133 :: insertion-sort ( base extended -- base )
 134     N :> ch!
 135     -1 :> pos!
 136     BIAS :> bias!
 137     0 :> extpos!
 138     extended length :> extlen
 139     [ extpos extlen < ] [
 140         extended extpos bias decode-delta :> ( newpos delta )
 141         delta 1 + pos + pos!
 142         pos base length 1 + /mod pos! ch + ch!
 143         ch 0x10FFFF > [ ch invalid-character ] when
 144         ch pos base insert-nth!
 145         delta base length extpos 0 = adapt bias!
 146         newpos extpos!
 147     ] while base ;
 148
 149 PRIVATE>
 150
 151 : punycode> ( punycode -- str )
 152     CHAR: - over last-index [
 153         ! FIXME: assert all non-basic code-points
 154         [ head >sbuf ] [ 1 + tail ] 2bi >upper
 155     ] [
 156         SBUF" " clone swap >upper
 157     ] if* insertion-sort "" like ;
 158
 159 : idna> ( punycode -- str )
 160     "." split [
 161         "xn--" ?head [ punycode> ] when
 162     ] map "." join ;
 163
 164 : >idna ( str -- punycode )
 165     "." split [
 166         dup [ N < ] all? [
 167             >punycode "xn--" prepend
 168         ] unless
 169     ] map "." join ;
 170
 171 TUPLE: irl < url ;
 172
 173 : <irl> ( -- irl ) irl new ;
 174
 175 GENERIC: >irl ( obj -- irl )
 176
 177 M: f >irl drop <irl> ;
 178
 179 <PRIVATE
 180
 181 : irl-decode ( str -- str' )
 182     "" like R/ (%[a-fA-F0-9]{2})+/ [ url-decode ] re-replace-with ;
 183
 184 : iquery-decode ( str -- decoded )
 185     "+" split "%20" join irl-decode ;
 186
 187 : iquery>assoc ( query -- assoc )
 188     dup [
 189         "&;" split <linked-hash> [
 190             [
 191                 [ "=" split1 [ dup [ iquery-decode ] when ] bi@ swap ] dip
 192                 add-query-param
 193             ] curry each
 194         ] keep
 195     ] when ;
 196
 197 : assoc>iquery ( assoc -- str )
 198     [
 199         [
 200             [
 201                 dup array? [ 1array ] unless
 202                 [ "=" glue , ] with each
 203             ] [ , ] if*
 204         ] assoc-each
 205     ] { } make "&" join ;
 206
 207 ! RFC 3987
 208 EBNF: parse-irl [=[
 209
 210 protocol = [a-zA-Z0-9.+-]+ => [[ irl-decode ]]
 211 username = [^/:@#?]+       => [[ irl-decode ]]
 212 password = [^/:@#?]+       => [[ irl-decode ]]
 213 path     = [^#?]+          => [[ irl-decode ]]
 214 query    = [^#]+           => [[ iquery>assoc ]]
 215 anchor   = .+              => [[ irl-decode ]]
 216 hostname = [^/#?:]+        => [[ irl-decode ]]
 217 port     = [^/#?]+         => [[ url-decode parse-port ]]
 218
 219 auth     = username (":"~ password)? "@"~
 220 host     = hostname (":"~ port)?
 221
 222 url      = (protocol ":"~)?
 223            ("//"~ auth? host?)?
 224            path?
 225            ("?"~ query)?
 226            ("#"~ anchor)?
 227
 228 ]=]
 229
 230 : unparse-ihost-part ( url -- )
 231     {
 232         [ unparse-username-password ]
 233         [ host>> % ]
 234         [ url-port [ ":" % # ] when* ]
 235         [ path>> "/" head? [ "/" % ] unless ]
 236     } cleave ;
 237
 238 : unparse-iauthority ( url -- )
 239     dup host>> [ "//" % unparse-ihost-part ] [ drop ] if ;
 240
 241 M: irl present
 242     [
 243         {
 244             [ unparse-protocol ]
 245             [ unparse-iauthority ]
 246             [ path>> % ]
 247             [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>iquery % ] if ]
 248             [ anchor>> [ "#" % present % ] when* ]
 249         } cleave
 250     ] "" make ;
 251
 252 PRIVATE>
 253
 254 M: string >irl
 255     [ <irl> ] dip parse-irl 5 firstn {
 256         [ >lower >>protocol ]
 257         [
 258             [
 259                 [ first [ first2 [ >>username ] [ >>password ] bi* ] when* ]
 260                 [ second [ first2 [ >>host ] [ >>port ] bi* ] when* ] bi
 261             ] when*
 262         ]
 263         [ >>path ]
 264         [ >>query ]
 265         [ >>anchor ]
 266     } spread dup host>> [ [ "/" or ] change-path ] when ;
 267
 268 M: irl >url
 269     [ <url> ] dip {
 270         [ protocol>> >>protocol ]
 271         [ username>> >>username ]
 272         [ password>> >>password ]
 273         [ host>> [ >idna url-encode ] [ f ] if* >>host ]
 274         [ port>> >>port ]
 275         [ path>> [ url-encode ] [ f ] if* >>path ]
 276         [ query>> >>query ]
 277         [ anchor>> [ url-encode ] [ f ] if* >>anchor ]
 278     } cleave ;
 279
 280 M: url >irl
 281     [ <irl> ] dip {
 282         [ protocol>> >>protocol ]
 283         [ username>> >>username ]
 284         [ password>> >>password ]
 285         [ host>> [ url-decode idna> ] [ f ] if* >>host ]
 286         [ port>> >>port ]
 287         [ path>> [ url-decode ] [ f ] if* >>path ]
 288         [ query>> >>query ]
 289         [ anchor>> [ url-decode ] [ f ] if* >>anchor ]
 290     } cleave ;
 291
 292 SYNTAX: IRL" lexer get skip-blank parse-string >irl suffix! ;
 293
 294 M: irl pprint*
 295     \ IRL" record-vocab
 296     dup present "IRL\" " "\"" pprint-string ;