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