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