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.encodings.string io.encodings.utf8 math
   6 math.parser accessors parser strings.parser lexer
   7 hashtables present peg.ebnf urls.encoding ;
   8 IN: urls
   9
  10 TUPLE: url protocol username password host port path query anchor ;
  11
  12 : <url> ( -- url ) url new ;
  13
  14 : query-param ( url key -- value )
  15     swap query>> at ;
  16
  17 : delete-query-param ( url key -- url )
  18     over query>> delete-at ;
  19
  20 : set-query-param ( url value key -- url )
  21     over [
  22         '[ [ _ _ ] dip ?set-at ] change-query
  23     ] [
  24         nip delete-query-param
  25     ] if ;
  26
  27 : parse-host ( string -- host port )
  28     ":" split1 [ url-decode ] [
  29         dup [
  30             string>number
  31             dup [ "Invalid port" throw ] unless
  32         ] when
  33     ] bi* ;
  34
  35 GENERIC: >url ( obj -- url )
  36
  37 M: f >url drop <url> ;
  38
  39 M: url >url ;
  40
  41 <PRIVATE
  42
  43 EBNF: parse-url
  44
  45 protocol = [a-z]+                   => [[ url-decode ]]
  46 username = [^/:@#?]+                => [[ url-decode ]]
  47 password = [^/:@#?]+                => [[ url-decode ]]
  48 pathname = [^#?]+                   => [[ url-decode ]]
  49 query    = [^#]+                    => [[ query>assoc ]]
  50 anchor   = .+                       => [[ url-decode ]]
  51
  52 hostname = [^/#?]+                  => [[ url-decode ]]
  53
  54 hostname-spec = hostname ("/"|!(.)) => [[ first ]]
  55
  56 auth     = (username (":" password  => [[ second ]])? "@"
  57                                     => [[ first2 2array ]])?
  58
  59 url      = ((protocol "://")        => [[ first ]] auth hostname)?
  60            (pathname)?
  61            ("?" query               => [[ second ]])?
  62            ("#" anchor              => [[ second ]])?
  63
  64 ;EBNF
  65
  66 PRIVATE>
  67
  68 M: string >url
  69     parse-url {
  70         [
  71             first [
  72                 [ first ] ! protocol
  73                 [
  74                     second
  75                     [ first [ first2 ] [ f f ] if* ] ! username, password
  76                     [ second parse-host ] ! host, port
  77                     bi
  78                 ] bi
  79             ] [ f f f f f ] if*
  80         ]
  81         [ second ] ! pathname
  82         [ third ] ! query
  83         [ fourth ] ! anchor
  84     } cleave url boa
  85     dup host>> [ [ "/" or ] change-path ] when ;
  86
  87 : protocol-port ( protocol -- port )
  88     {
  89         { "http" [ 80 ] }
  90         { "https" [ 443 ] }
  91         { "ftp" [ 21 ] }
  92         [ drop f ]
  93     } case ;
  94
  95 <PRIVATE
  96
  97 : unparse-username-password ( url -- )
  98     dup username>> dup [
  99         % password>> [ ":" % % ] when* "@" %
 100     ] [ 2drop ] if ;
 101
 102 : url-port ( url -- port/f )
 103     [ port>> ] [ port>> ] [ protocol>> protocol-port ] tri =
 104     [ drop f ] when ;
 105
 106 : unparse-host-part ( url protocol -- )
 107     %
 108     "://" %
 109     {
 110         [ unparse-username-password ]
 111         [ host>> url-encode % ]
 112         [ url-port [ ":" % # ] when* ]
 113         [ path>> "/" head? [ "/" % ] unless ]
 114     } cleave ;
 115
 116 PRIVATE>
 117
 118 M: url present
 119     [
 120         {
 121             [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ]
 122             [ path>> url-encode % ]
 123             [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
 124             [ anchor>> [ "#" % present url-encode % ] when* ]
 125         } cleave
 126     ] "" make ;
 127
 128 : url-append-path ( path1 path2 -- path )
 129     {
 130         { [ dup "/" head? ] [ nip ] }
 131         { [ dup empty? ] [ drop ] }
 132         { [ over "/" tail? ] [ append ] }
 133         { [ "/" pick start not ] [ nip ] }
 134         [ [ "/" split1-last drop "/" ] dip 3append ]
 135     } cond ;
 136
 137 PRIVATE>
 138
 139 : derive-url ( base url -- url' )
 140     [ clone ] dip over {
 141         [ [ protocol>>  ] either? >>protocol ]
 142         [ [ username>>  ] either? >>username ]
 143         [ [ password>>  ] either? >>password ]
 144         [ [ host>>      ] either? >>host ]
 145         [ [ port>>      ] either? >>port ]
 146         [ [ path>>      ] bi@ swap url-append-path >>path ]
 147         [ [ query>>     ] either? >>query ]
 148         [ [ anchor>>    ] either? >>anchor ]
 149     } 2cleave ;
 150
 151 : relative-url ( url -- url' )
 152     clone
 153         f >>protocol
 154         f >>host
 155         f >>port ;
 156
 157 : relative-url? ( url -- ? ) protocol>> not ;
 158
 159 ! Half-baked stuff follows
 160 : secure-protocol? ( protocol -- ? )
 161     "https" = ;
 162
 163 <PRIVATE
 164
 165 GENERIC: >secure-addr ( addrspec -- addrspec' )
 166
 167 PRIVATE>
 168
 169 : url-addr ( url -- addr )
 170     [
 171         [ host>> ]
 172         [ port>> ]
 173         [ protocol>> protocol-port ]
 174         tri or <inet>
 175     ] [ protocol>> ] bi
 176     secure-protocol? [ >secure-addr ] when ;
 177
 178 : ensure-port ( url -- url' )
 179     clone dup protocol>> '[ _ protocol-port or ] change-port ;
 180
 181 ! Literal syntax
 182 SYNTAX: URL" lexer get skip-blank parse-string >url parsed ;
 183
 184 USING: vocabs vocabs.loader ;
 185
 186 "prettyprint" vocab [
 187     "urls.prettyprint" require
 188 ] when