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