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.pathnames io.sockets
   6 io.sockets.secure kernel lexer linked-assocs make math
   7 math.parser multiline namespaces peg.ebnf present sequences
   8 sequences.generalizations splitting strings strings.parser
   9 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 EBNF: parse-url [=[
  48
  49 protocol = [a-zA-Z0-9.+-]+ => [[ url-decode ]]
  50 username = [^/:@#?]*       => [[ url-decode ]]
  51 password = [^/:@#?]*       => [[ url-decode ]]
  52 path     = [^#?]+          => [[ url-decode ]]
  53 query    = [^#]+           => [[ query>assoc ]]
  54 anchor   = .+              => [[ url-decode ]]
  55 hostname = [^/#?:]+        => [[ url-decode ]]
  56 ipv6     = "[" [^\]]+ "]"  => [[ concat url-decode ]]
  57 port     = [^/#?]+         => [[ url-decode parse-port ]]
  58
  59 auth     = username (":"~ password?)? "@"~
  60 host     = (ipv6 | hostname) (":"~ port?)?
  61
  62 url      = (protocol ":"~)?
  63            ("//"~ auth? host?)?
  64            path?
  65            ("?"~ query)?
  66            ("#"~ anchor)?
  67
  68 ]=]
  69
  70 PRIVATE>
  71
  72 M: string >url
  73     [ <url> ] dip parse-url 5 firstn {
  74         [ >lower >>protocol ]
  75         [
  76             [
  77                 [ first [ first2 [ >>username ] [ >>password ] bi* ] when* ]
  78                 [ second [ first2 [ >>host ] [ >>port ] bi* ] when* ] bi
  79             ] when*
  80         ]
  81         [ >>path ]
  82         [ >>query ]
  83         [ >>anchor ]
  84     } spread dup host>> [ [ "/" or ] change-path ] when ;
  85
  86 M: pathname >url string>> >url ;
  87
  88 : relative-url ( url -- url' )
  89     clone
  90         f >>protocol
  91         f >>host
  92         f >>port ;
  93
  94 : relative-url? ( url -- ? ) protocol>> not ;
  95
  96 <PRIVATE
  97
  98 : unparse-username-password ( url -- )
  99     dup username>> dup [
 100         % password>> [ ":" % % ] when* "@" %
 101     ] [ 2drop ] if ;
 102
 103 : url-port ( url -- port/f )
 104     [ port>> ] [ protocol>> protocol-port ] bi over =
 105     [ drop f ] when ;
 106
 107 : ipv6-host ( host -- host/ipv6 ipv6? )
 108     dup { [ "[" head? ] [ "]" tail? ] } 1&& [
 109         1 swap [ length 1 - ] [ subseq ] bi t
 110     ] [ f ] if ;
 111
 112 : unparse-host ( url -- host )
 113     host>> ipv6-host [ url-encode ] [ [ "[" "]" surround ] when ] bi* ;
 114
 115 : unparse-host-part ( url -- )
 116     {
 117         [ unparse-username-password ]
 118         [ unparse-host % ]
 119         [ url-port [ ":" % # ] when* ]
 120         [ path>> "/" head? [ "/" % ] unless ]
 121     } cleave ;
 122
 123 ! URL" //foo.com" takes on the protocol of the url it's derived from
 124 : unparse-protocol ( url -- )
 125     protocol>> [ % ":" % ] when* ;
 126
 127 : unparse-authority ( url -- )
 128     dup host>> [ "//" % unparse-host-part ] [ drop ] if ;
 129
 130 M: url present
 131     [
 132         {
 133             [ unparse-protocol ]
 134             [ unparse-authority ]
 135             [ path>> url-encode % ]
 136             [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
 137             [ anchor>> [ "#" % present url-encode % ] when* ]
 138         } cleave
 139     ] "" make ;
 140
 141 PRIVATE>
 142
 143 : url-append-path ( path1 path2 -- path )
 144     {
 145         { [ dup "/" head? ] [ nip ] }
 146         { [ dup empty? ] [ drop ] }
 147         { [ over "/" tail? ] [ append ] }
 148         { [ "/" pick subseq-start not ] [ nip ] }
 149         [ [ "/" split1-last drop "/" ] dip 3append ]
 150     } cond ;
 151
 152 <PRIVATE
 153
 154 : derive-port ( url base -- url' )
 155     over relative-url? [ [ port>> ] either? ] [ drop port>> ] if ;
 156
 157 : derive-path ( url base -- url' )
 158     [ path>> ] bi@ swap url-append-path ;
 159
 160 PRIVATE>
 161
 162 : derive-url ( base url -- url' )
 163     [ clone ] dip over {
 164         [ [ protocol>>  ] either? >>protocol ]
 165         [ [ username>>  ] either? >>username ]
 166         [ [ password>>  ] either? >>password ]
 167         [ [ host>>      ] either? >>host ]
 168         [ derive-port             >>port ]
 169         [ derive-path             >>path ]
 170         [ [ query>>     ] either? >>query ]
 171         [ [ anchor>>    ] either? >>anchor ]
 172     } 2cleave ;
 173
 174 : redacted-url ( url -- url' )
 175     clone [ "xxxxx" and ] change-password ;
 176
 177 ! Half-baked stuff follows
 178 : secure-protocol? ( protocol -- ? )
 179     "https" = ;
 180
 181 : url-addr ( url -- addr )
 182     [
 183         [ host>> ipv6-host drop ]
 184         [ port>> ]
 185         [ protocol>> protocol-port ]
 186         tri or <inet>
 187     ] [
 188         dup protocol>> secure-protocol?
 189         [ host>> ipv6-host drop <secure> ] [ drop ] if
 190     ] bi ;
 191
 192 : set-url-addr ( url addr -- url )
 193     [ [ host>> ] [ inet6? ] bi [ "[" "]" surround ] when >>host ]
 194     [ port>> >>port ] bi ;
 195
 196 : ensure-port ( url -- url' )
 197     clone dup protocol>> '[ _ protocol-port or ] change-port ;
 198
 199 ! Literal syntax
 200 SYNTAX: URL" lexer get skip-blank parse-string >url suffix! ;
 201
 202 { "urls" "prettyprint" } "urls.prettyprint" require-when