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         { [ dup LETTER? ] [ CHAR: A - ] }
 113         { [ dup digit? ] [ CHAR: 0 26 - - ] }
 114         [ 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 GENERIC: idna> ( punycode -- obj )
 160
 161 M: object idna>
 162     "." split [
 163         "xn--" ?head [ punycode> ] when
 164     ] map "." join ;
 165
 166 M: url idna> [ idna> ] change-host ;
 167
 168 GENERIC: >idna ( obj -- punycode )
 169
 170 M: object >idna
 171     "." split [
 172         dup [ N < ] all? [
 173             >punycode "xn--" prepend
 174         ] unless
 175     ] map "." join ;
 176
 177 M: url >idna [ >idna ] change-host ;