/lib/web.arc

  1; written by Mark Huetsch
  2; same license as Arc
  3
  4($ (require openssl))
  5($ (xdef ssl-connect (lambda (host port)
  6                       (ar-init-socket
  7                         (lambda () (ssl-connect host port))))))
  8
  9(load "lib/re.arc")
 10(load "lib/util.arc")
 11
 12(def parse-server-cookies (s)
 13  (map [map trim _]
 14       (map [matchsplit "=" _]
 15            (tokens s #\;))))
 16
 17(def read-headers ((o s (stdin)))
 18  (accum a
 19    (whiler line (readline s) blank
 20      (a line))))
 21
 22(def parse-server-headers (lines)
 23  (let http-response (tokens car.lines)
 24    (list
 25      (map http-response '(0 1 2))
 26      (some [aand (begins-rest "Set-Cookie:" _) parse-server-cookies.it]
 27            cdr.lines))))
 28
 29(def args->query-string (args)
 30  (if args
 31    (let equals-list (map [joinstr _ "="] (pair (map [coerce _ 'string] args)))
 32      (joinstr equals-list "&"))
 33    ""))
 34
 35(def parse-url (url)
 36  (withs ((resource url)    (split-by "://" (ensure-resource:strip-after url "#"))
 37          (host+port path+query)  (split-by "/" url)
 38          (host portstr)    (split-by ":" host+port)
 39          (path query)      (split-by "?" path+query))
 40    (obj resource resource
 41         host     host
 42         port     (or (only.int portstr) default-port.resource)
 43         filename path
 44         query    query)))
 45
 46; TODO: only handles https for now
 47(def default-port(resource)
 48  (if (is resource "https")
 49    443
 50    80))
 51
 52(def encode-cookie (o)
 53  (let joined-list (map [joinstr _ #\=] (tablist o))
 54    (+ "Cookie: "
 55       (if (len> joined-list 1)
 56         (reduce [+ _1 "; " _2] joined-list)
 57         (car joined-list))
 58       ";")))
 59
 60; TODO this isn't very pretty
 61(def get-or-post-url (url (o args) (o method "GET") (o cookie))
 62  (withs (method            (upcase method)
 63          parsed-url        (parse-url url)
 64          args-query-string (args->query-string args)
 65          full-args         (joinstr (list args-query-string (parsed-url 'query)) "&")
 66          request-path      (+ "/" (parsed-url 'filename)
 67                               (if (and (is method "GET") (> (len full-args) 0))
 68                                   (+ "?" full-args)))
 69          header-components (list (+ method " " request-path " HTTP/1.0")
 70                                  (+ "Host: " (parsed-url 'host))
 71                                  "User-Agent: Mozilla/5.0 (Windows; U; Windows NT 5.1; uk; rv:1.9.1.2) Gecko/20090729 Firefox/3.5.2"))
 72    (when (is method "POST")
 73      (pushend (+ "Content-Length: "
 74                  (len (utf-8-bytes full-args)))
 75               header-components)
 76      (pushend "Content-Type: application/x-www-form-urlencoded"
 77               header-components))
 78    (when cookie
 79      (push (encode-cookie cookie) header-components))
 80    (withs (header          (reduce [+ _1 "\r\n" _2] header-components)
 81            body            (if (is method "POST") (+ full-args "\r\n"))
 82            request-message (+ header "\r\n\r\n" body))
 83      (let (in out) (if (is "https" (parsed-url 'resource))
 84                      (ssl-connect (parsed-url 'host) (parsed-url 'port))
 85                      (socket-connect (parsed-url 'host) (parsed-url 'port)))
 86        (disp request-message out)
 87        (with (header (parse-server-headers (read-headers in))
 88               body   (tostring (whilet line (readline in) (prn line))))
 89          (close in out)
 90          (list header body))))))
 91
 92(def get-url (url)
 93  ((get-or-post-url url) 1))
 94
 95(def post-url (url args)
 96  ((get-or-post-url url args "POST") 1))
 97
 98
 99
100(def split-by(delim s)
101  (iflet idx (posmatch delim s)
102    (list (cut s 0 idx) (cut s (+ idx len.delim)))
103    (list s nil)))
104
105(def strip-after(s delim)
106  ((split-by delim s) 0))
107
108(def ensure-resource(url)
109  (if (posmatch "://" url)
110    url
111    (+ "http://" url)))
112
113
114
115(def google (q)
116  (get-url (+ "www.google.com/search?q=" (urlencode q))))
117
118; just some preliminary hacking
119(mac w/browser body
120  `(withs (cookies* (table)
121                    get-url
122                    (fn (url) (let (parsed-header html) (get-or-post-url url '() "GET" cookies*)
123                                (= cookies* (fill-table cookies* (flat (parsed-header 1))))
124                                html))
125                    post-url
126                    (fn (url args) (let (parsed-header html) (get-or-post-url url args "POST" cookies*)
127                                     (= cookies* (fill-table cookies* (flat (parsed-header 1))))
128                                     html)))
129     (do ,@body)))