chatikbot/utils.lisp

(in-package #:chatikbot)

(defvar *backoff-start* 1 "Initial back-off")
(defvar *backoff-max* 64 "Maximum back-off delay")

(defun loop-with-error-backoff (func)
  (let ((backoff *backoff-start*))
    (loop
       do
         (handler-case
             (progn
               (funcall func)
               (setf backoff *backoff-start*))
           (error (e)
             (log:error e)
             (log:info "Backing off for" backoff)
             (sleep backoff)
             (setf backoff (min *backoff-max*
                                (* 2 backoff))))
	   (bordeaux-threads:timeout (e)
             (log:error e)
             (log:info "Backing off for" backoff)
             (sleep backoff)
             (setf backoff (min *backoff-max*
                                (* 2 backoff))))))))

(defun replace-all (string part replacement &key (test #'char=))
  "Returns a new string in which all the occurences of the part
is replaced with replacement."
  (with-output-to-string (out)
    (loop with part-length = (length part)
       for old-pos = 0 then (+ pos part-length)
       for pos = (search part string
                         :start2 old-pos
                         :test test)
       do (write-string string out
                        :start old-pos
                        :end (or pos (length string)))
       when pos do (write-string replacement out)
       while pos)))

(defmacro aget (key alist)
  `(cdr (assoc ,key ,alist :test #'equal)))

(defun mappend (fn &rest lists)
  "Apply fn to each element of lists and append the results."
  (apply #'append (apply #'mapcar fn lists)))

(defun random-elt (choices)
  "Choose an element from a list at random."
  (elt choices (random (length choices))))

(defun flatten (the-list)
  "Append together elements (or lists) in the list."
  (mappend #'(lambda (x) (if (listp x) (flatten x) (list x))) the-list))


;; Circular lists
(defun make-circular (items)
  "Make items list circular"
  (setf (cdr (last items)) items))

(defmacro push-circular (obj circ)
  "Move circ list and set head to obj"
  `(progn
     (pop ,circ)
     (setf (car ,circ) ,obj)))

(defmacro peek-circular (circ)
  "Get head of circular list"
  `(car ,circ))

(defmacro pop-circular (circ)
  "Get head of circular list"
  `(pop ,circ))

(defun flat-circular (circ)
  "Flattens circular list"
  (do ((cur (cdr circ) (cdr cur))
       (head circ)
       result)
      ((eq head cur)
       (nreverse (push (car cur) result)))
    (push (car cur) result)))

(defun http-default (url)
  (let ((uri (puri:uri url)))
    (puri:render-uri
     (if (null (puri:uri-scheme uri))
         (puri:uri (format nil "http://~A" url))
         uri)
     nil)))

;; XML processing
(defun xml-request (url)
  (multiple-value-bind (raw-body status headers uri http-stream)
      (drakma:http-request (http-default url)
                           :force-binary t
                           :decode-content t)
    (declare (ignore status headers http-stream))
    (let* ((dom
            (handler-case
                (plump:parse (flex:octets-to-string raw-body :external-format :utf-8))
              (flex:external-format-encoding-error ()
                (plump:parse (flex:octets-to-string raw-body)))))
           (encoding (ignore-errors
                       (plump:get-attribute (plump:first-child dom) "encoding"))))
      (values
       (if (and encoding (not (equal encoding "utf-8")))
           (plump:parse (flex:octets-to-string
                         raw-body
                         :external-format (intern encoding 'keyword)))
           dom)
       uri))))

(defun get-by-tag (node tag)
  (nreverse (plump::get-elements-by-tag-name node tag)))

;; JSON processing
(defun json-request (url &key (method :get) parameters (object-as :alist))
  (multiple-value-bind (stream status headers uri http-stream)
      (drakma:http-request (http-default url) :method method :parameters parameters
                             :external-format-out :utf-8
                             :force-binary t :want-stream t :decode-content t)
    (declare (ignore status headers))
    (unwind-protect
         (progn
           (setf (flex:flexi-stream-external-format stream) :utf-8)
           (values (yason:parse stream :object-as object-as) uri))
      (ignore-errors (close http-stream)))))

;; Fix bug in local-time (following symlinks in /usr/share/zoneinfo/
;; leads to bad cutoff)
(in-package #:local-time)
(defun reread-timezone-repository (&key (timezone-repository *default-timezone-repository-path*))
  (check-type timezone-repository (or pathname string))
  (multiple-value-bind (valid? error)
      (ignore-errors
        (truename timezone-repository)
        t)
    (unless valid?
      (error "REREAD-TIMEZONE-REPOSITORY was called with invalid PROJECT-DIRECTORY (~A). The error is ~A."
             timezone-repository error)))
  (let* ((root-directory timezone-repository)
         (cutoff-position (length (princ-to-string root-directory))))
    (flet ((visitor (file)
             (handler-case
                 (let* ((full-name (subseq (princ-to-string file) cutoff-position))
                        (name (pathname-name file))
                        (timezone (%realize-timezone (make-timezone :path file :name name))))
                   (setf (gethash full-name *location-name->timezone*) timezone)
                   (map nil (lambda (subzone)
                              (push timezone (gethash (subzone-abbrev subzone)
                                                      *abbreviated-subzone-name->timezone-list*)))
                        (timezone-subzones timezone)))
               (invalid-timezone-file () nil))))
      (setf *location-name->timezone* (make-hash-table :test 'equal))
      (setf *abbreviated-subzone-name->timezone-list* (make-hash-table :test 'equal))
      (cl-fad:walk-directory root-directory #'visitor :directories nil :follow-symlinks nil
                             :test (lambda (file)
                                     (not (find "Etc" (pathname-directory file) :test #'string=))))
      (cl-fad:walk-directory (merge-pathnames "Etc/" root-directory) #'visitor :directories nil))))

(let ((zonepath "/usr/share/zoneinfo/"))
  (when (directory zonepath)
    (local-time:reread-timezone-repository :timezone-repository zonepath)))