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