basis/urls/urls.factor

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