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 fry io.pathnames
   5 io.sockets io.sockets.secure kernel lexer linked-assocs make
   6 math.parser multiline namespaces peg.ebnf present sequences
   7 sequences.generalizations splitting strings strings.parser
   8 urls.encoding vocabs.loader ;
   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-port ( string -- port/f )
  31     [ f ] [ string>number [ malformed-port ] unless* ] if-empty ;
  32
  33 : parse-host ( string -- host/f port/f )
  34     [
  35         ":" split1-last [ url-decode ] [ parse-port ] bi*
  36     ] [ f f ] if* ;
  37
  38 GENERIC: >url ( obj -- url )
  39
  40 M: f >url drop <url> ;
  41
  42 M: url >url ;
  43
  44 <PRIVATE
  45
  46 EBNF: parse-url [=[
  47
  48 protocol = [a-zA-Z0-9.+-]+ => [[ url-decode ]]
  49 username = [^/:@#?]*       => [[ url-decode ]]
  50 password = [^/:@#?]*       => [[ url-decode ]]
  51 path     = [^#?]+          => [[ url-decode ]]
  52 query    = [^#]+           => [[ query>assoc ]]
  53 anchor   = .+              => [[ url-decode ]]
  54 hostname = [^/#?:]+        => [[ url-decode ]]
  55 port     = [^/#?]+         => [[ url-decode parse-port ]]
  56
  57 auth     = username (":"~ password?)? "@"~
  58 host     = hostname (":"~ port?)?
  59
  60 url      = (protocol ":"~)?
  61            ("//"~ auth? host?)?
  62            path?
  63            ("?"~ query)?
  64            ("#"~ anchor)?
  65
  66 ]=]
  67
  68 PRIVATE>
  69
  70 M: string >url
  71     [ <url> ] dip parse-url 5 firstn {
  72         [ >lower >>protocol ]
  73         [
  74             [
  75                 [ first [ first2 [ >>username ] [ >>password ] bi* ] when* ]
  76                 [ second [ first2 [ >>host ] [ >>port ] bi* ] when* ] bi
  77             ] when*
  78         ]
  79         [ >>path ]
  80         [ >>query ]
  81         [ >>anchor ]
  82     } spread dup host>> [ [ "/" or ] change-path ] when ;
  83
  84 M: pathname >url string>> >url ;
  85
  86 : relative-url ( url -- url' )
  87     clone
  88         f >>protocol
  89         f >>host
  90         f >>port ;
  91
  92 : relative-url? ( url -- ? ) protocol>> not ;
  93
  94 <PRIVATE
  95
  96 : unparse-username-password ( url -- )
  97     dup username>> dup [
  98         % password>> [ ":" % % ] when* "@" %
  99     ] [ 2drop ] if ;
 100
 101 : url-port ( url -- port/f )
 102     [ port>> ] [ protocol>> protocol-port ] bi over =
 103     [ drop f ] when ;
 104
 105 : unparse-host-part ( url -- )
 106     {
 107         [ unparse-username-password ]
 108         [ host>> url-encode % ]
 109         [ url-port [ ":" % # ] when* ]
 110         [ path>> "/" head? [ "/" % ] unless ]
 111     } cleave ;
 112
 113 ! URL" //foo.com" takes on the protocol of the url it's derived from
 114 : unparse-protocol ( url -- )
 115     protocol>> [ % ":" % ] when* ;
 116
 117 : unparse-authority ( url -- )
 118     dup host>> [ "//" % unparse-host-part ] [ drop ] if ;
 119
 120 M: url present
 121     [
 122         {
 123             [ unparse-protocol ]
 124             [ unparse-authority ]
 125             [ path>> url-encode % ]
 126             [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
 127             [ anchor>> [ "#" % present url-encode % ] when* ]
 128         } cleave
 129     ] "" make ;
 130
 131 PRIVATE>
 132
 133 : url-append-path ( path1 path2 -- path )
 134     {
 135         { [ dup "/" head? ] [ nip ] }
 136         { [ dup empty? ] [ drop ] }
 137         { [ over "/" tail? ] [ append ] }
 138         { [ "/" pick subseq-start not ] [ nip ] }
 139         [ [ "/" split1-last drop "/" ] dip 3append ]
 140     } cond ;
 141
 142 <PRIVATE
 143
 144 : derive-port ( url base -- url' )
 145     over relative-url? [ [ port>> ] either? ] [ drop port>> ] if ;
 146
 147 : derive-path ( url base -- url' )
 148     [ path>> ] bi@ swap url-append-path ;
 149
 150 PRIVATE>
 151
 152 : derive-url ( base url -- url' )
 153     [ clone ] dip over {
 154         [ [ protocol>>  ] either? >>protocol ]
 155         [ [ username>>  ] either? >>username ]
 156         [ [ password>>  ] either? >>password ]
 157         [ [ host>>      ] either? >>host ]
 158         [ derive-port             >>port ]
 159         [ derive-path             >>path ]
 160         [ [ query>>     ] either? >>query ]
 161         [ [ anchor>>    ] either? >>anchor ]
 162     } 2cleave ;
 163
 164 : redacted-url ( url -- url' )
 165     clone [ "xxxxx" and ] change-password ;
 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