init.fnl (8711B)
1 (local lgi (require :lgi)) 2 (local dbus (require :dbus_proxy)) 3 (local Gio lgi.Gio) 4 (local GLib lgi.GLib) 5 (local GV lgi.GLib.Variant) 6 (local GtkLayerShell lgi.GtkLayerShell) 7 (local variant dbus.variant) 8 (local Gtk lgi.Gtk) 9 10 (fn relpath [filename] 11 (.. (os.getenv "EUFON_PATH") "/crier/" filename)) 12 13 (local dbus-service-attrs 14 { 15 :bus dbus.Bus.SESSION 16 :name "org.freedesktop.Notifications" 17 :interface "org.freedesktop.Notifications" 18 :path "/org/freedesktop/Notifications" 19 }) 20 21 (local bus (dbus.Proxy:new 22 { 23 :bus dbus.Bus.SESSION 24 :name "org.freedesktop.DBus" 25 :interface "org.freedesktop.DBus" 26 :path "/org/freedesktop/DBus" 27 })) 28 29 30 (local DBUS_NAME_FLAG_DO_NOT_QUEUE 4) 31 (local DBUS_REQUEST_NAME_REPLY_PRIMARY_OWNER 1) 32 (local DBUS_REQUEST_NAME_REPLY_IN_QUEUE 2) 33 (local DBUS_REQUEST_NAME_REPLY_EXISTS 3) 34 (local DBUS_REQUEST_NAME_REPLY_ALREADY_OWNER 4) 35 36 37 (let [ret (bus:RequestName dbus-service-attrs.name 38 DBUS_NAME_FLAG_DO_NOT_QUEUE)] 39 (match ret 40 DBUS_REQUEST_NAME_REPLY_PRIMARY_OWNER 41 true 42 43 DBUS_REQUEST_NAME_REPLY_ALREADY_OWNER 44 true 45 46 DBUS_REQUEST_NAME_REPLY_IN_QUEUE 47 (error "unexpected DBUS_REQUEST_NAME_REPLY_IN_QUEUE") 48 49 DBUS_REQUEST_NAME_REPLY_EXISTS 50 (error "already running"))) 51 52 (let [css (: (io.open (relpath "styles.css")) :read "*a") 53 style_provider (Gtk.CssProvider)] 54 (style_provider:load_from_data css) 55 (Gtk.StyleContext.add_provider_for_screen 56 (lgi.Gdk.Screen.get_default) 57 style_provider 58 Gtk.STYLE_PROVIDER_PRIORITY_APPLICATION 59 )) 60 61 ;; for each open message there is a widget 62 ;; when a message is closed, we need to find its widget 63 ;; and remove it from the container 64 ;; if there are no messages left, hide the windox 65 66 (fn make-window [] 67 (let [window (Gtk.Window {:on_destroy Gtk.main_quit}) 68 box (Gtk.Box { 69 :orientation Gtk.Orientation.VERTICAL 70 })] 71 (window:add box) 72 (when true 73 (GtkLayerShell.init_for_window window) 74 (GtkLayerShell.set_layer window GtkLayerShell.Layer.TOP) 75 (GtkLayerShell.auto_exclusive_zone_enable window) 76 77 (GtkLayerShell.set_margin window GtkLayerShell.Edge.TOP 1) 78 (GtkLayerShell.set_margin window GtkLayerShell.Edge.BOTTOM 10) 79 80 (GtkLayerShell.set_anchor window GtkLayerShell.Edge.TOP 1) 81 (GtkLayerShell.set_anchor window GtkLayerShell.Edge.LEFT 1) 82 (GtkLayerShell.set_anchor window GtkLayerShell.Edge.RIGHT 1)) 83 (window:hide) 84 {:window window :box box})) 85 86 (local window (make-window)) 87 88 (local notifications {}) 89 90 (fn update-window [] 91 (each [id widget (pairs notifications)] 92 (if (not (widget.widget:get_parent)) 93 (window.box:pack_start widget.widget false false 5))) 94 (if (next notifications) 95 (window.window:show_all) 96 (window.window:hide))) 97 98 (var notification-id 10) 99 (fn next-notification-id [] 100 (set notification-id (+ notification-id 1)) 101 notification-id) 102 103 (fn delete-notification [id] 104 (let [widget (. notifications id)] 105 (if widget 106 (do 107 (tset notifications id nil) 108 (window.box:remove widget.widget) 109 (update-window) 110 true) 111 (values nil "no notification with that id")))) 112 113 114 (fn update-notification-widget [widget noti] 115 (doto widget 116 (: :set-summary noti.summary) 117 (: :set-body noti.body) 118 (: :set-icon noti.app-icon) 119 (: :set-buttons noti.actions))) 120 121 (fn emit-action [id action] 122 (bus.connection:emit_signal 123 nil ; destination 124 dbus-service-attrs.path 125 dbus-service-attrs.interface 126 "ActionInvoked" 127 (GV "(us)" [id action]))) 128 129 (fn make-notification-widget [id] 130 (let [summary (Gtk.Label { :name "summary" }) 131 body (Gtk.Label) 132 icon (Gtk.Image) 133 event-box (Gtk.EventBox { 134 :on_button_press_event #(emit-action id "default") 135 }) 136 messages (Gtk.Box { :orientation Gtk.Orientation.VERTICAL}) 137 icon-and-messages (Gtk.Box { 138 :name "notification" 139 :orientation Gtk.Orientation.HORIZONTAL 140 }) 141 buttons (Gtk.Box { :orientation Gtk.Orientation.HORIZONTAL}) 142 with-buttons (Gtk.Box { :orientation Gtk.Orientation.VERTICAL}) 143 ] 144 (messages:pack_start summary false false 0) 145 (messages:pack_start body true false 0) 146 (icon-and-messages:pack_start icon false false 0) 147 (icon-and-messages:pack_start messages true true 0) 148 (with-buttons:pack_start icon-and-messages false false 0) 149 (with-buttons:pack_start buttons false false 0) 150 (event-box:add with-buttons) 151 { 152 :set-summary (fn [self value] 153 (set summary.label value)) 154 :set-body (fn [self value] 155 (set body.label value)) 156 :set-buttons (fn [self actions] 157 (each [_ child (ipairs (buttons:get_children))] 158 (print child) 159 (child:destroy)) 160 (when actions 161 (each [key label (pairs actions)] 162 (if (not (= key "default")) 163 (buttons:pack_start (Gtk.Button { 164 :on_clicked 165 #(emit-action id key) 166 :label label }) 167 true false 0))))) 168 :set-icon (fn [self value] 169 (when value 170 (icon:set_from_icon_name 171 value 172 Gtk.IconSize.DND 173 ))) 174 :widget event-box 175 })) 176 177 (fn timeout-ms [noti] 178 (if (or (not noti.timeout) (= noti.timeout -1)) 179 5000 180 (> noti.timeout 0) 181 noti.timeout 182 (= noti.timeout 0) 183 nil)) 184 185 (fn add-notification [noti] 186 (let [id (if (= noti.id 0) (next-notification-id) noti.id) 187 widget (or (. notifications id) (make-notification-widget id)) 188 timeout (timeout-ms noti)] 189 (when timeout 190 (lgi.GLib.timeout_add 191 lgi.GLib.PRIORITY_DEFAULT timeout #(do (delete-notification id) nil))) 192 193 (update-notification-widget widget noti) 194 (tset notifications id widget) 195 (update-window) 196 id)) 197 198 (fn parse-actions [list] 199 (let [out {}] 200 (for [i 1 (# list) 2] 201 (tset out (. list i) (. list (+ 1 i)))) 202 out)) 203 204 (fn make-notification [sender id icon summary body actions hints timeout] 205 { 206 :sender sender 207 :id id 208 :app-icon icon 209 :summary summary 210 :body body 211 :actions (parse-actions actions) 212 :hints hints 213 :timeout timeout 214 }) 215 216 217 (local interface-info 218 (let [xml (: (io.open (relpath "interface.xml") "r") :read "*a") 219 node-info (Gio.DBusNodeInfo.new_for_xml xml)] 220 (. node-info.interfaces 1))) 221 222 (local dbus-methods 223 { 224 "GetCapabilities" #["actions" "body" "persistence"] 225 "GetServerInformation" #(values "crier" "telent" "0.1" "1.2") 226 "Notify" #(add-notification (make-notification $...)) 227 "CloseNotification" (fn [id] 228 (let [(won err) (delete-notification id)] 229 (if won (values) (error err)))) 230 }) 231 232 (fn args-signature [args] 233 (var sig "") 234 (each [_ v (ipairs args)] 235 (set sig (.. sig v.signature))) 236 sig) 237 238 (fn handle-dbus-method-call [conn sender path interface method params invocation] 239 (when (and (= path dbus-service-attrs.path) 240 (= interface dbus-service-attrs.interface)) 241 (let [p (dbus.variant.strip params) 242 info (interface-info:lookup_method method) 243 sig (args-signature info.out_args)] 244 (match (table.pack (pcall (. dbus-methods method) (table.unpack p))) 245 [true & vals] 246 (invocation:return_value (GV (.. "(" sig ")") vals)) 247 _ 248 (invocation:return_value nil))))) 249 250 (fn handle-dbus-get [conn sender path interface name] 251 (when (and (= path dbus-service-attrs.path) 252 (= interface dbus-service-attrs.interface) 253 (= name "Visible")) 254 (lgi.GLib.Variant "b" true))) 255 256 (Gio.DBusConnection.register_object 257 bus.connection 258 dbus-service-attrs.path 259 interface-info 260 (lgi.GObject.Closure handle-dbus-method-call) 261 (lgi.GObject.Closure handle-dbus-get) 262 (lgi.GObject.Closure (fn [a] (print "set")))) 263 264 265 (add-notification { 266 :app-icon "dialog-information" 267 :body "This is an example notifiddcation." 268 :id 3 269 :sender "notify-send" 270 :summary "Hello world!" 271 }) 272 273 (Gtk:main)