basis/urls/urls.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays ascii assocs classes combinators
   4 combinators.short-circuit fry hashtables io.encodings.string
   5 io.encodings.utf8 io.sockets kernel lexer make math math.parser
   6 namespaces parser peg.ebnf present sequences splitting strings
   7 strings.parser urls.encoding ;
   8 IN: urls
   9
  10 TUPLE: url protocol username password addr 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 ERROR: malformed-port ;
  28
  29 : parse-host ( string -- host/f port/f )
  30     [
  31         ":" split1-last [ url-decode ]
  32         [ dup [ string>number [ malformed-port ] unless* ] when ] bi*
  33     ] [ f f ] if* ;
  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     [ <url> ] dip
  70     parse-url {
  71         [
  72             first [
  73                 [ first >>protocol ]
  74                 [
  75                     second
  76                     [ first [ first2 [ >>username ] [ >>password ] bi* ] when* ]
  77                     [ second parse-host <inet> >>addr ] bi
  78                 ] bi
  79             ] when*
  80         ]
  81         [ second >>path ]
  82         [ third >>query ]
  83         [ fourth >>anchor ]
  84     } cleave
  85     dup addr>> [ [ "/" or ] change-path ] when ;
  86
  87 <PRIVATE
  88
  89 : inet>url ( inet -- url ) [ <url> ] dip >>addr ;
  90
  91 PRIVATE>
  92
  93 M: inet >url inet>url ;
  94 M: inet4 >url inet>url ;
  95 M: inet6 >url inet>url ;
  96
  97 : protocol-port ( protocol -- port )
  98     {
  99         { "http" [ 80 ] }
 100         { "https" [ 443 ] }
 101         { "ftp" [ 21 ] }
 102         [ drop f ]
 103     } case ;
 104
 105 <PRIVATE
 106
 107 : unparse-username-password ( url -- )
 108     dup username>> dup [
 109         % password>> [ ":" % % ] when* "@" %
 110     ] [ 2drop ] if ;
 111
 112 : url-port ( url -- port/f )
 113     [ addr>> port>> ]
 114     [ addr>> port>> ]
 115     [ protocol>> protocol-port ] tri =
 116     [ drop f ] when ;
 117
 118 : unparse-host-part ( url protocol -- )
 119     %
 120     "://" %
 121     {
 122         [ unparse-username-password ]
 123         [ addr>> host>> url-encode % ]
 124         [ url-port [ ":" % # ] when* ]
 125         [ path>> "/" head? [ "/" % ] unless ]
 126     } cleave ;
 127
 128 PRIVATE>
 129
 130 M: url present
 131     [
 132         {
 133             [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ]
 134             [ path>> url-encode % ]
 135             [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
 136             [ anchor>> [ "#" % present url-encode % ] when* ]
 137         } cleave
 138     ] "" make ;
 139
 140 : url-append-path ( path1 path2 -- path )
 141     {
 142         { [ dup "/" head? ] [ nip ] }
 143         { [ dup empty? ] [ drop ] }
 144         { [ over "/" tail? ] [ append ] }
 145         { [ "/" pick start not ] [ nip ] }
 146         [ [ "/" split1-last drop "/" ] dip 3append ]
 147     } cond ;
 148
 149 PRIVATE>
 150
 151 : derive-url ( base url -- url' )
 152     [ clone ] dip over {
 153         [ [ protocol>>  ] either? >>protocol ]
 154         [ [ username>>  ] either? >>username ]
 155         [ [ password>>  ] either? >>password ]
 156         [ [ addr>>      ] either? >>addr ]
 157         [ [ path>>      ] bi@ swap url-append-path >>path ]
 158         [ [ query>>     ] either? >>query ]
 159         [ [ anchor>>    ] either? >>anchor ]
 160     } 2cleave ;
 161
 162 : relative-url ( url -- url' )
 163     clone
 164         f >>protocol
 165         f >>addr ;
 166
 167 : relative-url? ( url -- ? ) protocol>> not ;
 168
 169 ! Half-baked stuff follows
 170 : secure-protocol? ( protocol -- ? )
 171     "https" = ;
 172
 173 <PRIVATE
 174
 175 GENERIC: >secure-addr ( addrspec -- addrspec' )
 176
 177 PRIVATE>
 178
 179 : url-addr ( url -- addr )
 180     [
 181         [ addr>> ]
 182         [ [ addr>> port>> ] [ protocol>> protocol-port ] bi or ] bi with-port
 183     ] [ protocol>> ] bi
 184     secure-protocol? [ >secure-addr ] when ;
 185
 186 : ensure-port ( url -- url' )
 187     clone dup protocol>> '[
 188         dup port>> _ protocol-port or with-port
 189     ] change-addr ;
 190
 191 ! Literal syntax
 192 SYNTAX: URL" lexer get skip-blank parse-string >url suffix! ;
 193
 194 USE: vocabs.loader
 195
 196 { "urls" "prettyprint" } "urls.prettyprint" require-when