1 | ;; TODO: support authorization |
2 | (ns com.github.kyleburton.sandbox.web |
3 | (:import (org.apache.commons.httpclient HttpClient NameValuePair) |
4 | (org.apache.commons.httpclient.methods GetMethod) |
5 | (org.apache.commons.httpclient.auth AuthScope) |
6 | (org.apache.commons.httpclient UsernamePasswordCredentials)) |
7 | (:require [com.github.kyleburton.sandbox.landmark-parser :as lparse] |
8 | [com.github.kyleburton.sandbox.utils :as kutils] |
9 | [com.github.kyleburton.sandbox.swing :as sw]) |
10 | (:use [clojure.contrib.str-utils :as str] |
11 | [clojure.contrib.fcase :only (case)])) |
12 | |
13 | (def *ua* (org.apache.commons.httpclient.HttpClient.)) |
14 | |
15 | (defn map->nvpairs [m] |
16 | (if-let [names (keys m)] |
17 | (into-array (vec (map #(NameValuePair. (.getName %) (m %)) (keys m)))) |
18 | nil)) |
19 | |
20 | (defn ua-get [ua url & [params]] |
21 | (let [req (GetMethod. url) |
22 | pairs (map->nvpairs params)] |
23 | (if pairs |
24 | (.setQueryString req pairs)) |
25 | (.setFollowRedirects req true) |
26 | (.executeMethod ua req) |
27 | (prn (format "ua-get->string: req.uri=%s" (.getURI req))) |
28 | req)) |
29 | |
30 | (defn ua-get->string [ua url & [params]] |
31 | (.getResponseBodyAsString (apply ua-get ua url params))) |
32 | |
33 | (defn #^String get->string [#^String url & [params]] |
34 | (apply ua-get->string *ua* url params)) |
35 | |
36 | ;; (get->string "http://google.com/") |
37 | ;; (get->string "http://intranet.hmsonline.com/confluence/display/SWDEV/Home") |
38 | |
39 | |
40 | (def memoized-get->string |
41 | (fn [& params] |
42 | (apply get->string params))) |
43 | |
44 | (defn strip-html [#^String html] |
45 | (.replaceAll html "<[^>]+>" "")) |
46 | |
47 | (def *ligature->chr* |
48 | {">" ">" |
49 | "<" "<" |
50 | " " " " |
51 | }) |
52 | |
53 | (defn html-decode [#^String html] |
54 | (.replaceAll |
55 | (loop [html html |
56 | [lg & lgs] (keys *ligature->chr*)] |
57 | (prn (format "html-decode: html=%s lg=%s lgs=%s" html lg lgs)) |
58 | (if lg |
59 | (recur (.replceAll html lg (*ligature->chr* lg)) |
60 | lgs) |
61 | html)) |
62 | "&" "&")) |
63 | |
64 | (defmacro with-http-client [[client & params] & body] |
65 | (prn (format "with-http-client: generating, client=%s params=%s body=%s" client params body)) |
66 | `(let [params# (second (kutils/parse-paired-arglist [~@params])) |
67 | client# (org.apache.commons.httpclient.HttpClient.) |
68 | ~client client#] |
69 | (prn (format "with-http-client: params=%s" params#)) |
70 | (when (:user params#) |
71 | (prn (format "with-http-client: setting credentials, :user=%s host=%s port=%s" |
72 | (:user params#) |
73 | (:host params#) |
74 | (:port params#))) |
75 | (.setAuthenticationPreemptive (.getParams client#) true) |
76 | (.setCredentials (.getState client#) |
77 | (AuthScope. (:host params#) |
78 | (:port params#) |
79 | AuthScope/ANY_REALM) |
80 | (UsernamePasswordCredentials. (:user params#) |
81 | (:pass params#)))) |
82 | ~@body)) |
83 | |
84 | (defn form-target [base-uri form] |
85 | (let [action (:action form) |
86 | base (re-sub #"/[^/]*$" "/" (str base-uri))] |
87 | ;; if the action already has a schema on it, just return it |
88 | (cond (re-find #"^http" action) |
89 | action |
90 | true |
91 | (str base action)))) |