Improving URL library

extra/namespaces/lib/lib.factor

@@ -2,7 +2,7 @@
 ! USING: kernel quotations namespaces sequences assocs.lib ;
 
 USING: kernel namespaces namespaces.private quotations sequences
-       assocs.lib math.parser math sequences.lib locals ;
+       assocs.lib math.parser math sequences.lib locals mirrors ;
 
 IN: namespaces.lib
 
@@ -58,3 +58,9 @@ MACRO:: nmake ( quot exemplars -- )
             ] with-scope
         ]
     ] ;
+
+: make-object ( quot class -- object )
+    new [ <mirror> swap bind ] keep ; inline
+
+: with-object ( object quot -- )
+    [ <mirror> ] dip bind ; inline

extra/urls/urls-tests.factor

@@ -87,6 +87,18 @@ urls [
     swap [ 1array ] [ [ url>string ] curry ] bi* unit-test
 ] assoc-each
 
+[ "b" ] [ "a" "b" url-append-path ] unit-test
+
+[ "a/b" ] [ "a/c" "b" url-append-path ] unit-test
+
+[ "a/b" ] [ "a/" "b" url-append-path ] unit-test
+
+[ "/b" ] [ "a" "/b" url-append-path ] unit-test
+
+[ "/b" ] [ "a/b/" "/b" url-append-path ] unit-test
+
+[ "/xxx/bar" ] [ "/xxx/baz" "bar" url-append-path ] unit-test
+
 [
     TUPLE{ url
         protocol: "http"
@@ -95,10 +107,6 @@ urls [
         path: "/a/path"
     }
 ] [
-    TUPLE{ url
-        path: "/a/path"
-    }
-
     TUPLE{ url
         protocol: "http"
         host: "www.apple.com"
@@ -106,29 +114,7 @@ urls [
         path: "/foo"
     }
 
-    derive-url
-] unit-test
-
-[
     TUPLE{ url
-        protocol: "http"
-        host: "www.apple.com"
-        port: 1234
-        path: "/a/path/relative/path"
-        query: H{ { "a" "b" } }
-        anchor: "foo"
-    }
-] [
-    TUPLE{ url
-        path: "relative/path"
-        query: H{ { "a" "b" } }
-        anchor: "foo"
-    }
-
-    TUPLE{ url
-        protocol: "http"
-        host: "www.apple.com"
-        port: 1234
         path: "/a/path"
     }
 
@@ -145,12 +131,32 @@ urls [
         anchor: "foo"
     }
 ] [
+    TUPLE{ url
+        protocol: "http"
+        host: "www.apple.com"
+        port: 1234
+        path: "/a/path/"
+    }
+
     TUPLE{ url
         path: "relative/path"
         query: H{ { "a" "b" } }
         anchor: "foo"
     }
 
+    derive-url
+] unit-test
+
+[
+    TUPLE{ url
+        protocol: "http"
+        host: "www.apple.com"
+        port: 1234
+        path: "/a/path/relative/path"
+        query: H{ { "a" "b" } }
+        anchor: "foo"
+    }
+] [
     TUPLE{ url
         protocol: "http"
         host: "www.apple.com"
@@ -158,5 +164,31 @@ urls [
         path: "/a/path/"
     }
 
+    TUPLE{ url
+        path: "relative/path"
+        query: H{ { "a" "b" } }
+        anchor: "foo"
+    }
+
+    derive-url
+] unit-test
+
+[
+    TUPLE{ url
+        protocol: "http"
+        host: "www.apple.com"
+        path: "/xxx/baz"
+    }
+] [
+    TUPLE{ url
+        protocol: "http"
+        host: "www.apple.com"
+        path: "/xxx/bar"
+    }
+
+    TUPLE{ url
+        path: "baz"
+    }
+
     derive-url
 ] unit-test

extra/urls/urls.factor

@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 USING: kernel unicode.categories combinators sequences splitting
 fry namespaces assocs arrays strings mirrors
 io.encodings.string io.encodings.utf8
@@ -89,17 +91,25 @@ IN: urls
 
 TUPLE: url protocol host port path query anchor ;
 
+: query-param ( request key -- value )
+    swap query>> at ;
+
+: set-query-param ( request value key -- request )
+    pick query>> set-at ;
+
+: parse-host ( string -- host port )
+    ":" split1 [ url-decode ] [
+        dup [
+            string>number
+            dup [ "Invalid port" throw ] unless
+        ] when
+    ] bi* ;
+
 : parse-host-part ( protocol rest -- string' )
     [ "protocol" set ] [
         "//" ?head [ "Invalid URL" throw ] unless
         "/" split1 [
-            ":" split1
+            parse-host [ "host" set ] [ "port" set ] bi*
-            [ url-decode "host" set ] [
-                dup [
-                    string>number
-                    dup [ "Invalid port" throw ] unless
-                ] when "port" set
-            ] bi*
         ] [ "/" prepend ] bi*
     ] bi* ;
 
@@ -131,13 +141,20 @@ TUPLE: url protocol host port path query anchor ;
         ] bind
     ] "" make ;
 
-: fix-relative-path ( url base -- url base )
+: url-append-path ( path1 path2 -- path )
-    over path>> '[
+    {
-        "/" ?tail drop "/" , 3append
+        { [ dup "/" head? ] [ nip ] }
-    ] change-path
+        { [ dup empty? ] [ drop ] }
-    [ f >>path ] dip ; inline
+        { [ over "/" tail? ] [ append ] }
+        { [ "/" pick start not ] [ nip ] }
+        [ [ "/" last-split1 drop "/" ] dip 3append ]
+    } cond ;
 
-: derive-url ( url base -- url' )
+: derive-url ( base url -- url' )
-    clone
+    [ clone dup ] dip
-    over path>> "/" head? [ fix-relative-path ] unless
+    2dup [ path>> ] bi@ url-append-path
-    [ <mirror> swap <mirror> [ nip ] assoc-filter update ] keep ;
+    [ [ <mirror> ] bi@ [ nip ] assoc-filter update ] dip
+    >>path ;
+
+: relative-url ( url -- url' )
+    clone f >>protocol f >>host f >>port ;