Google Sheets support fixes, zhanna

chatikbot.asd

@@ -20,6 +20,7 @@
                #:plump
                #:sqlite
                #:trivial-utf-8
+               #:uuid
                #:quri
                #:yason)
   :serial t

plugins/gsheets.lisp

@@ -106,6 +106,22 @@
                                  ("q" . "mimeType='application/vnd.google-apps.spreadsheet'")
                                  ("pageToken" . ,next-page-token))))
 
+(defun gsheets-file-watch (token-id file-id webhook &key token expiration payload params)
+  (google-api-call token-id
+                   (format nil "files/~A/watch" file-id) +gdrive-base-uri+
+                   :method :post
+                   :body (append
+                          (list "kind" "api#channel"
+                                "id" (princ-to-string (uuid:make-v4-uuid))
+                                "type" "web_hook"
+                                "address" (quri:render-uri
+                                           (quri:merge-uris (quri:uri (format nil "/hook/~A" webhook))
+                                                            (quri:uri *web-path*))))
+                          (when token (list "token" token))
+                          (when expiration (list "expiration" expiration))
+                          (when payload (list "payload" "true"))
+                          (when params (list "params" params)))))
+
 (defun gsheets-get-sheet (token-id sheet-id &key fields ranges include-grid-data)
   (google-api-call token-id
                    (format nil "spreadsheets/~A" sheet-id) +gsheets-base-uri+
@@ -114,10 +130,12 @@
                                 (when ranges (list (cons "ranges" ranges)))
                                 (when include-grid-data (list (cons "includeGridData" include-grid-data))))))
 
-(defun gsheets-get-sheet-values (token-id sheet-id range &key fields major-dimension)
+(defun gsheets-get-sheet-values (token-id sheet-id ranges &key fields major-dimension)
   (google-api-call token-id
-                   (format nil "spreadsheets/~A/values/~A" sheet-id range) +gsheets-base-uri+
+                   (format nil "spreadsheets/~A/values:batchGet" sheet-id) +gsheets-base-uri+
                    :parameters (append
+                                (loop for range in (if (listp ranges) ranges (list ranges))
+                                   collect (cons "ranges" range))
                                 (when fields (list (cons "fields" fields)))
                                 (when major-dimension (list (cons "majorDimension" major-dimension))))))
 

plugins/zhanna.lisp

@@ -0,0 +1,87 @@
+(in-package #:chatikbot)
+
+(defsetting *zhanna-token-id* nil)
+(defsetting *zhanna-sheet-id* "1kLBodFUwcfbpdqe_d2d01MHij95NAVcKrmpjotYsUQk")
+
+(defun %zh-parse-values (rows)
+  (labels ((non-empty (s)
+             (unless (equal s "") s))
+           (get-el (row idx)
+             (when (> (length row) idx)
+               (non-empty (elt row idx))))
+           (get-item (row start)
+             (cons (get-el row start) (get-el row (1+ start)))))
+    (loop for start to 4 by 2
+       append (loop for row in rows
+                 for item = (get-item row start)
+                 when (car item)
+                 collect (cons (subseq (car item) 0 5) (cdr item))))))
+
+(defparameter +zhanna-dows+ '("вс" "пн" "вт" "ср" "чт" "пт" "сб"))
+(defun zhanna-get-schedule (&rest days)
+  (labels ((dow-range (dow)
+             (format nil "'~A'!A3:F22" (elt +zhanna-dows+ dow))))
+    (let* ((ranges (mapcar #'dow-range days))
+           (resp (gsheets-get-sheet-values *zhanna-token-id* *zhanna-sheet-id* ranges)))
+      (loop for vr in (aget "valueRanges" resp)
+         collect (cons (subseq (aget "range" vr) 1 3)
+                       (%zh-parse-values (aget "values" vr)))))))
+
+(defun %zh-diff-schedule (old-s new-s)
+  (let ((times (mapcar #'car (union old-s new-s :key #'car :test #'equal))))
+    (loop for time in times
+       for new = (aget time new-s)
+       for old = (aget time old-s)
+       unless (equal new old)
+       collect (list (cons new old) time))))
+
+(defun %zh-format-diff (diff)
+  (labels ((join (joined value)
+             (destructuring-bind (change time) value
+               (let ((existing (aget change joined)))
+                 (if existing
+                     (progn
+                       (setf (cdr existing) (append (cdr existing) (list time)))
+                       joined)
+                     (append joined (list value))))))
+           (text-change (change)
+             (destructuring-bind (new . old) change
+               (cond
+                 ((null old) (format nil "🏄 ~A" new))
+                 ((null new) (format nil "💔 ~A" old))
+                 (:otherwise (format nil "~A 🔁 ~A" old new))))))
+    (let ((joined (reduce #'join diff :initial-value (list))))
+      (format nil "~{~A~^~%~}" (loop for (change . times) in joined
+                                  collect (format nil "~A: ~{~A~^, ~}" (text-change change) times))))))
+
+(defsetting *zhanna-subscriptions* nil "chat-ids of schedule changes receivers")
+(defvar *zhanna-last-schedule* nil "Schedule from last cron run")
+(defcron process-zhanna ()
+  (let ((schedule (zhanna-get-schedule 1 2 3 4 5 6 0)))
+    (when *zhanna-last-schedule*
+      (handler-case
+          (let* ((day-changes (loop for dow in +zhanna-dows+
+                                 for new-s = (aget dow schedule)
+                                 for old-s = (aget dow *zhanna-last-schedule*)
+                                 for diff = (%zh-diff-schedule old-s new-s)
+                                 when diff
+                                 collect (format nil "*~A:*~%~A" dow (%zh-format-diff diff))))
+                 (msg (format nil "~{~A~^~%~%~}" day-changes)))
+            (when day-changes
+              (log:info msg)
+              (dolist (chat-id *zhanna-subscriptions*)
+                (bot-send-message chat-id msg :parse-mode "markdown"))))
+        (error (e) (log:error e))))
+    (setf *zhanna-last-schedule* schedule)
+    (values)))
+
+(def-message-cmd-handler zhanna-free-handler (:free :свободна :свободно)
+  (let* ((dows (if args (remove nil (mapcar
+                                     #'(lambda (a) (position a +zhanna-dows+ :test #'equal))
+                                     args))
+                   (list (mod (1+ (local-time:timestamp-day-of-week (local-time:now))) 7))))
+         (schedule (apply #'zhanna-get-schedule dows))
+         (texts (loop for (dow . day-schedule) in schedule
+                   collect (format nil "*~A*~%~{~A~^, ~}" dow
+                                   (mapcar #'car (remove nil day-schedule :key #'cdr :test-not #'eql))))))
+    (bot-send-message chat-id (format nil "Жанна свободна:~%~{~A~^~%~}" texts) :parse-mode "markdown")))

server.lisp

@@ -15,18 +15,19 @@
                           :address *web-iface* :port *web-port*)))))
 (add-hook :starting #'(lambda () (web-start) (values)))
 
-(defun webhookp (request)
-  (equal (concatenate 'string "/" *telegram-token*)
-         (hunchentoot:script-name* request)))
+(defun telegram-hook-p (request)
+  (and (equal (hunchentoot:request-method request) :post)
+       (equal (concatenate 'string "/" *telegram-token*)
+              (hunchentoot:script-name request))))
 
-(hunchentoot:define-easy-handler (webhook-handler :uri #'webhookp :default-request-type :post) ()
+(hunchentoot:define-easy-handler (telegram-webhook-handler :uri #'telegram-hook-p) ()
   (handler-case
       (let ((stream (hunchentoot:raw-post-data :want-stream t)))
         (setf *random-state* (make-random-state t))
         (setf (flex:flexi-stream-external-format stream) :utf-8)
-        (handle-update (yason:parse stream :object-as :alist))
-        "OK")
-    (error (e) (log:error e))))
+        (handle-update (yason:parse stream :object-as :alist)))
+    (error (e) (log:error e)))
+  "OK")
 
 (hunchentoot:define-easy-handler (oauth-handler :uri "/oauth") (code error state)
   (handler-case
@@ -58,3 +59,19 @@
 <h1>Failed :(</h1>
 <p>OAuth failed. You probably didn't allow the access. Try again.</p>
 </html>")
+
+(defun webhookp (request)
+  (let ((name (hunchentoot:script-name request)))
+    (and (> (length name) 6)
+         (equal (subseq name 0 6) "/hook/"))))
+
+(hunchentoot:define-easy-handler (webhook-handler :uri #'webhookp) ()
+  (handler-case
+      (let ((hook (subseq (hunchentoot:script-name*) 6))
+            (data (hunchentoot:raw-post-data :external-format :utf-8)))
+        (setf *random-state* (make-random-state t))
+        (run-hooks :webhook hook
+                   (when data (yason:parse data :object-as :alist))
+                   (hunchentoot:headers-in*)))
+    (error (e) (log:error e)))
+  "OK")

utils.lisp

@@ -386,21 +386,27 @@ is replaced with replacement."
          ,@body
          t))))
 
+(defun symbol-append (&rest symbols)
+  (intern (apply #'concatenate 'string
+                 (mapcar #'symbol-name symbols))))
+
 ;; Schedule
 (defmacro defcron (name (&rest schedule) &body body)
-  (let ((schedule (or schedule '(:minute '* :hour '*))))
+  (let ((schedule (or schedule '(:minute '* :hour '*)))
+        (scheduler (symbol-append name '-scheduler)))
     `(progn
        (defun ,name ()
          (handler-case (progn ,@body)
            (error (e) (log:error e))))
-       (add-hook :starting #'(lambda ()
-                               (clon:schedule-function
-                                ',name (clon:make-scheduler
-                                        (clon:make-typed-cron-schedule
-                                         ,@schedule)
-                                        :allow-now-p t)
-                                :name ',name :thread t)
-                               (values))))))
+       (defun ,scheduler ()
+         (clon:schedule-function
+          ',name (clon:make-scheduler
+                  (clon:make-typed-cron-schedule
+                   ,@schedule)
+                  :allow-now-p t)
+          :name ',name :thread t)
+         (values))
+       (add-hook :starting ',scheduler))))
 
 
 ;; Fix bug in local-time (following symlinks in /usr/share/zoneinfo/