basis/urls/urls.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.sockets io.sockets.secure io.encodings.string
   6 io.encodings.utf8 math math.parser accessors parser
   7 strings.parser lexer prettyprint.backend hashtables present ;
   8 IN: urls
   9
  10 : url-quotable? ( ch -- ? )
  11     #! In a URL, can this character be used without
  12     #! URL-encoding?
  13     {
  14         [ letter? ]
  15         [ LETTER? ]
  16         [ digit? ]
  17         [ "/_-." member? ]
  18     } 1|| ; foldable
  19
  20 <PRIVATE
  21
  22 : push-utf8 ( ch -- )
  23     1string utf8 encode
  24     [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
  25
  26 PRIVATE>
  27
  28 : url-encode ( str -- str )
  29     [
  30         [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
  31     ] "" make ;
  32
  33 <PRIVATE
  34
  35 : url-decode-hex ( index str -- )
  36     2dup length 2 - >= [
  37         2drop
  38     ] [
  39         [ 1+ dup 2 + ] dip subseq  hex> [ , ] when*
  40     ] if ;
  41
  42 : url-decode-% ( index str -- index str )
  43     2dup url-decode-hex [ 3 + ] dip ;
  44
  45 : url-decode-+-or-other ( index str ch -- index str )
  46     dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ;
  47
  48 : url-decode-iter ( index str -- )
  49     2dup length >= [
  50         2drop
  51     ] [
  52         2dup nth dup CHAR: % = [
  53             drop url-decode-%
  54         ] [
  55             url-decode-+-or-other
  56         ] if url-decode-iter
  57     ] if ;
  58
  59 PRIVATE>
  60
  61 : url-decode ( str -- str )
  62     [ 0 swap url-decode-iter ] "" make utf8 decode ;
  63
  64 <PRIVATE
  65
  66 : add-query-param ( value key assoc -- )
  67     [
  68         at [
  69             {
  70                 { [ dup string? ] [ swap 2array ] }
  71                 { [ dup array? ] [ swap suffix ] }
  72                 { [ dup not ] [ drop ] }
  73             } cond
  74         ] when*
  75     ] 2keep set-at ;
  76
  77 PRIVATE>
  78
  79 : query>assoc ( query -- assoc )
  80     dup [
  81         "&" split H{ } clone [
  82             [
  83                 [ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip
  84                 add-query-param
  85             ] curry each
  86         ] keep
  87     ] when ;
  88
  89 : assoc>query ( hash -- str )
  90     [
  91         dup array? [ [ present ] map ] [ present 1array ] if
  92     ] assoc-map
  93     [
  94         [
  95             [ url-encode ] dip
  96             [ url-encode "=" swap 3append , ] with each
  97         ] assoc-each
  98     ] { } make "&" join ;
  99
 100 TUPLE: url protocol username password host port path query anchor ;
 101
 102 : <url> ( -- url ) url new ;
 103
 104 : query-param ( url key -- value )
 105     swap query>> at ;
 106
 107 : set-query-param ( url value key -- url )
 108     '[ [ _ _ ] dip ?set-at ] change-query ;
 109
 110 : parse-host ( string -- host port )
 111     ":" split1 [ url-decode ] [
 112         dup [
 113             string>number
 114             dup [ "Invalid port" throw ] unless
 115         ] when
 116     ] bi* ;
 117
 118 <PRIVATE
 119
 120 : parse-host-part ( url protocol rest -- url string' )
 121     [ >>protocol ] [
 122         "//" ?head [ "Invalid URL" throw ] unless
 123         "@" split1 [
 124             [
 125                 ":" split1 [ >>username ] [ >>password ] bi*
 126             ] dip
 127         ] when*
 128         "/" split1 [
 129             parse-host [ >>host ] [ >>port ] bi*
 130         ] [ "/" prepend ] bi*
 131     ] bi* ;
 132
 133 PRIVATE>
 134
 135 GENERIC: >url ( obj -- url )
 136
 137 M: f >url drop <url> ;
 138
 139 M: url >url ;
 140
 141 M: string >url
 142     <url> swap
 143     ":" split1 [ parse-host-part ] when*
 144     "#" split1 [
 145         "?" split1
 146         [ url-decode >>path ]
 147         [ [ query>assoc >>query ] when* ] bi*
 148     ]
 149     [ url-decode >>anchor ] bi* ;
 150
 151 <PRIVATE
 152
 153 : unparse-username-password ( url -- )
 154     dup username>> dup [
 155         % password>> [ ":" % % ] when* "@" %
 156     ] [ 2drop ] if ;
 157
 158 : unparse-host-part ( url protocol -- )
 159     %
 160     "://" %
 161     {
 162         [ unparse-username-password ]
 163         [ host>> url-encode % ]
 164         [ port>> [ ":" % # ] when* ]
 165         [ path>> "/" head? [ "/" % ] unless ]
 166     } cleave ;
 167
 168 M: url present
 169     [
 170         {
 171             [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ]
 172             [ path>> url-encode % ]
 173             [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
 174             [ anchor>> [ "#" % present url-encode % ] when* ]
 175         } cleave
 176     ] "" make ;
 177
 178 : url-append-path ( path1 path2 -- path )
 179     {
 180         { [ dup "/" head? ] [ nip ] }
 181         { [ dup empty? ] [ drop ] }
 182         { [ over "/" tail? ] [ append ] }
 183         { [ "/" pick start not ] [ nip ] }
 184         [ [ "/" last-split1 drop "/" ] dip 3append ]
 185     } cond ;
 186
 187 PRIVATE>
 188
 189 : derive-url ( base url -- url' )
 190     [ clone ] dip over {
 191         [ [ protocol>> ] either? >>protocol ]
 192         [ [ username>> ] either? >>username ]
 193         [ [ password>> ] either? >>password ]
 194         [ [ host>>     ] either? >>host ]
 195         [ [ port>>     ] either? >>port ]
 196         [ [ path>>     ] bi@ swap url-append-path >>path ]
 197         [ [ query>>    ] either? >>query ]
 198         [ [ anchor>>   ] either? >>anchor ]
 199     } 2cleave ;
 200
 201 : relative-url ( url -- url' )
 202     clone
 203         f >>protocol
 204         f >>host
 205         f >>port ;
 206
 207 ! Half-baked stuff follows
 208 : secure-protocol? ( protocol -- ? )
 209     "https" = ;
 210
 211 : url-addr ( url -- addr )
 212     [ [ host>> ] [ port>> ] bi <inet> ] [ protocol>> ] bi
 213     secure-protocol? [ <secure> ] when ;
 214
 215 : protocol-port ( protocol -- port )
 216     {
 217         { "http" [ 80 ] }
 218         { "https" [ 443 ] }
 219         { "ftp" [ 21 ] }
 220     } case ;
 221
 222 : ensure-port ( url -- url' )
 223     dup protocol>> '[ _ protocol-port or ] change-port ;
 224
 225 ! Literal syntax
 226 : URL" lexer get skip-blank parse-string >url parsed ; parsing
 227
 228 M: url pprint* dup present "URL\" " "\"" pprint-string ;