basis/urls/urls.factor

   1 ! Copyright (C) 2008, 2011 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 USING: accessors arrays assocs combinators fry hashtables io.pathnames
   5 io.sockets kernel lexer linked-assocs make math.parser namespaces
   6 peg.ebnf present sequences splitting strings strings.parser
   7 urls.encoding vocabs.loader ;
   8
   9 IN: urls
  10
  11 TUPLE: url protocol username password host port path query anchor ;
  12
  13 : <url> ( -- url ) url new ;
  14
  15 : query-param ( url key -- value )
  16     swap query>> at ;
  17
  18 : set-or-delete ( val key query -- )
  19     pick [ set-at ] [ delete-at drop ] if ;
  20
  21 : set-query-param ( url value key -- url )
  22     pick query>> [ <linked-hash> ] unless* [ set-or-delete ] keep >>query ;
  23
  24 ERROR: malformed-port ;
  25
  26 : parse-host ( string -- host/f port/f )
  27     [
  28         ":" split1-last [ url-decode ]
  29         [ dup [ string>number [ malformed-port ] unless* ] when ] bi*
  30     ] [ f f ] if* ;
  31
  32 GENERIC: >url ( obj -- url )
  33
  34 M: f >url drop <url> ;
  35
  36 M: url >url ;
  37
  38 <PRIVATE
  39
  40 EBNF: parse-url
  41
  42 protocol = [a-z+]+                  => [[ url-decode ]]
  43 username = [^/:@#?]+                => [[ url-decode ]]
  44 password = [^/:@#?]+                => [[ url-decode ]]
  45 pathname = [^#?]+                   => [[ url-decode ]]
  46 query    = [^#]+                    => [[ query>assoc ]]
  47 anchor   = .+                       => [[ url-decode ]]
  48
  49 hostname = [^/#?]+                  => [[ url-decode ]]
  50
  51 hostname-spec = hostname ("/"|!(.)) => [[ first ]]
  52
  53 auth     = (username (":" password  => [[ second ]])? "@"
  54                                     => [[ first2 2array ]])?
  55
  56 url      = (((protocol "://") => [[ first ]] auth hostname)
  57                     | (("//") => [[ f ]] auth hostname))?
  58            (pathname)?
  59            ("?" query               => [[ second ]])?
  60            ("#" anchor              => [[ second ]])?
  61
  62 ;EBNF
  63
  64 PRIVATE>
  65
  66 M: string >url
  67     [ <url> ] dip
  68     parse-url {
  69         [
  70             first [
  71                 [ first >>protocol ]
  72                 [
  73                     second
  74                     [ first [ first2 [ >>username ] [ >>password ] bi* ] when* ]
  75                     [ second parse-host [ >>host ] [ >>port ] bi* ] bi
  76                 ] bi
  77             ] when*
  78         ]
  79         [ second >>path ]
  80         [ third >>query ]
  81         [ fourth >>anchor ]
  82     } cleave
  83     dup host>> [ [ "/" or ] change-path ] when ;
  84
  85 M: pathname >url string>> >url ;
  86
  87 : relative-url ( url -- url' )
  88     clone
  89         f >>protocol
  90         f >>host
  91         f >>port ;
  92
  93 : relative-url? ( url -- ? ) protocol>> not ;
  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 -- )
 107     {
 108         [ unparse-username-password ]
 109         [ host>> url-encode % ]
 110         [ url-port [ ":" % # ] when* ]
 111         [ path>> "/" head? [ "/" % ] unless ]
 112     } cleave ;
 113
 114 ! URL" //foo.com" takes on the protocol of the url it's derived from
 115 : unparse-protocol ( url -- )
 116     dup protocol>> [
 117         % "://" % unparse-host-part
 118     ] [
 119         dup host>> [
 120             "//" % unparse-host-part
 121         ] [
 122             drop
 123         ] if
 124     ] if* ;
 125
 126 M: url present
 127     [
 128         {
 129             [ unparse-protocol ]
 130             [ path>> url-encode % ]
 131             [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
 132             [ anchor>> [ "#" % present url-encode % ] when* ]
 133         } cleave
 134     ] "" make ;
 135
 136 PRIVATE>
 137
 138 : url-append-path ( path1 path2 -- path )
 139     {
 140         { [ dup "/" head? ] [ nip ] }
 141         { [ dup empty? ] [ drop ] }
 142         { [ over "/" tail? ] [ append ] }
 143         { [ "/" pick start not ] [ nip ] }
 144         [ [ "/" split1-last drop "/" ] dip 3append ]
 145     } cond ;
 146
 147 <PRIVATE
 148
 149 : derive-port ( url base -- url' )
 150     over relative-url? [ [ port>> ] either? ] [ drop port>> ] if ;
 151
 152 : derive-path ( url base -- url' )
 153     [ path>> ] bi@ swap url-append-path ;
 154
 155 PRIVATE>
 156
 157 : derive-url ( base url -- url' )
 158     [ clone ] dip over {
 159         [ [ protocol>>  ] either? >>protocol ]
 160         [ [ username>>  ] either? >>username ]
 161         [ [ password>>  ] either? >>password ]
 162         [ [ host>>      ] either? >>host ]
 163         [ derive-port             >>port ]
 164         [ derive-path             >>path ]
 165         [ [ query>>     ] either? >>query ]
 166         [ [ anchor>>    ] either? >>anchor ]
 167     } 2cleave ;
 168
 169 ! Half-baked stuff follows
 170 : secure-protocol? ( protocol -- ? )
 171     "https" = ;
 172
 173 <PRIVATE
 174
 175 GENERIC# >secure-addr 1 ( addrspec host -- addrspec' )
 176
 177 PRIVATE>
 178
 179 : url-addr ( url -- addr )
 180     [
 181         [ host>> ]
 182         [ port>> ]
 183         [ protocol>> protocol-port ]
 184         tri or <inet>
 185     ]
 186     [ host>> ]
 187     [ protocol>> ] tri
 188     secure-protocol? [ >secure-addr ] [ drop ] if ;
 189
 190 : set-url-addr ( url addr -- url )
 191     [ host>> >>host ] [ port>> >>port ] bi ;
 192
 193 : ensure-port ( url -- url' )
 194     clone dup protocol>> '[ _ protocol-port or ] change-port ;
 195
 196 ! Literal syntax
 197 SYNTAX: URL" lexer get skip-blank parse-short-string >url suffix! ;
 198
 199 { "urls" "prettyprint" } "urls.prettyprint" require-when
 200 { "urls" "io.sockets.secure" } "urls.secure" require-when