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