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 <PRIVATE
  18
  19 : push-utf8 ( ch -- )
  20     1string utf8 encode
  21     [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
  22
  23 PRIVATE>
  24
  25 : url-encode ( str -- encoded )
  26     [
  27         [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
  28     ] "" make ;
  29
  30 <PRIVATE
  31
  32 : url-decode-hex ( index str -- )
  33     2dup length 2 - >= [
  34         2drop
  35     ] [
  36         [ 1+ dup 2 + ] dip subseq  hex> [ , ] when*
  37     ] if ;
  38
  39 : url-decode-% ( index str -- index str )
  40     2dup url-decode-hex ;
  41
  42 : url-decode-iter ( index str -- )
  43     2dup length >= [
  44         2drop
  45     ] [
  46         2dup nth dup CHAR: % = [
  47             drop url-decode-% [ 3 + ] dip
  48         ] [
  49             , [ 1+ ] dip
  50         ] if url-decode-iter
  51     ] if ;
  52
  53 PRIVATE>
  54
  55 : url-decode ( str -- decoded )
  56     [ 0 swap url-decode-iter ] "" make utf8 decode ;
  57
  58 : query-decode ( str -- decoded )
  59     [ dup CHAR: + = [ drop "%20" ] [ 1string ] if ] { } map-as
  60     concat url-decode ;
  61
  62 <PRIVATE
  63
  64 : add-query-param ( value key assoc -- )
  65     [
  66         at [
  67             {
  68                 { [ dup string? ] [ swap 2array ] }
  69                 { [ dup array? ] [ swap suffix ] }
  70                 { [ dup not ] [ drop ] }
  71             } cond
  72         ] when*
  73     ] 2keep set-at ;
  74
  75 PRIVATE>
  76
  77 : query>assoc ( query -- assoc )
  78     dup [
  79         "&;" split H{ } clone [
  80             [
  81                 [ "=" split1 [ dup [ query-decode ] when ] bi@ swap ] dip
  82                 add-query-param
  83             ] curry each
  84         ] keep
  85     ] when ;
  86
  87 : assoc>query ( assoc -- str )
  88     [
  89         dup array? [ [ present ] map ] [ present 1array ] if
  90     ] assoc-map
  91     [
  92         [
  93             [ url-encode ] dip
  94             [ url-encode "=" glue , ] with each
  95         ] assoc-each
  96     ] { } make "&" join ;