webview.fnl (4590B)
1 (local { : Gtk : Gdk : WebKit2 : cairo : GLib : GObject } (require :lgi)) 2 (local posix (require :posix)) 3 4 (local Listeners (require :just.listeners)) 5 6 ;; this is a hack, should find out what XDG says 7 (local downloads-directory (.. (os.getenv "HOME") "/" "Downloads")) 8 9 (fn load-easylist-json [store cb] 10 (print "loading easylist from json") 11 (with-open [f (io.open "easylist_min_content_blocker.json" "r")] 12 (let [blocks (f:read "*a")] 13 (store:save "easylist" 14 (GLib.Bytes blocks) 15 nil 16 (fn [self res] 17 (cb (store:save_finish res))))))) 18 19 (fn load-adblocks [content-manager store] 20 (store:fetch_identifiers 21 nil 22 (fn [self res] 23 (let [ids (store:fetch_identifiers_finish res) 24 found (icollect [_ id (pairs ids)] (= id "easylist"))] 25 (if (> (# found) 0) 26 (store:load "easylist" nil 27 (fn [self res] 28 (content-manager:add_filter 29 (store:load_finish res)))) 30 (load-easylist-json 31 store 32 (fn [filter] 33 (content-manager:add_filter filter)))))))) 34 35 (fn scale-surface [source image-width image-height] 36 (let [scaled (cairo.ImageSurface.create 37 cairo.Format.ARGB32 38 image-width image-height) 39 ctx (cairo.Context.create scaled) 40 source-width (cairo.ImageSurface.get_width source) 41 source-height (cairo.ImageSurface.get_height source) 42 scale (/ image-width source-width)] 43 ;; XXX do we need to destroy this context? the example 44 ;; in C called cairo_destroy(cr), but I haven't found a 45 ;; gi equivalent 46 (doto ctx 47 (: :scale scale scale) 48 (: :set_source_surface source 0 0) 49 (: :paint)) 50 scaled)) 51 52 (fn thumbnail-image [widget width height fun] 53 ;; underlying call is async, so use callback 54 (widget:get_snapshot 55 WebKit2.SnapshotRegion.VISIBLE 56 WebKit2.SnapshotOptions.NONE 57 nil 58 (fn [self res] 59 (let [surface (widget:get_snapshot_finish res) 60 scaled (scale-surface surface width height) 61 img (doto (Gtk.Image) (: :set_from_surface scaled))] 62 (fun img))))) 63 64 (fn basename [filename] 65 (string.match filename "[^/]+$")) 66 67 (fn spawn-async [vec] 68 (let [pid (posix.unistd.fork)] 69 (if (> pid 0) true 70 (< pid 0) (assert (= "can't fork" nil)) 71 (do 72 (for [f 3 255] (posix.unistd.close f)) 73 (posix.execp "/usr/bin/env" vec))))) 74 75 (fn download [uri headers] 76 (let [filename 77 (match (headers:get_content_disposition) 78 (disposition attrs) (basename attrs.filename) 79 _ (basename uri))] 80 (print :download uri :to filename) 81 (spawn-async ["foot" 82 "curl" 83 uri 84 "-o" 85 (.. downloads-directory "/" filename)]))) 86 87 { 88 :new 89 (fn [{: content-filter-store}] 90 (let [listeners (Listeners.new) 91 props {} 92 widget (WebKit2.WebView { 93 :on_decide_policy 94 (fn [self decision dtype] 95 (if (and 96 (WebKit2.ResponsePolicyDecision:is_type_of decision) 97 (not (decision:is_mime_type_supported))) 98 (do 99 (download decision.request.uri decision.response.http_headers) 100 (decision:ignore) 101 true) 102 false)) 103 :on_notify 104 (fn [self pspec] 105 (when (not (= pspec.name :parent)) 106 (let [val (. self pspec.name)] 107 (tset props pspec.name val) 108 (listeners:notify pspec.name val)))) 109 })] 110 (when content-filter-store 111 (load-adblocks widget.user_content_manager content-filter-store)) 112 { 113 :listen #(listeners:add $2 $3) 114 :visit (fn [self url] 115 (widget:load_uri url)) 116 :stop-loading #(widget:stop_loading) 117 :refresh #(widget:reload) 118 :go-back #(and (widget:can_go_back) (widget:go_back)) 119 120 :thumbnail-image (fn [self width height fun] 121 (thumbnail-image widget width height fun)) 122 123 :properties props 124 :widget widget 125 })) 126 }