timeliner/src/utils.lisp

(in-package :cl-user)

(defpackage #:timeliner.utils
  (:use :cl :cl-mongo :sqlite)
  (:export
   #:ts->ms
   #:ms->ts
   #:$between
   #:make-keyword
   #:starts-with
   #:aget
   #:doc->plist
   #:load-chrome-cookie-jar
   #:today
   #:save-events))
(in-package :timeliner.utils)

(defun ts->ms (ts)
  (+ (* 1000 (local-time:timestamp-to-unix ts))
     (floor (local-time:nsec-of ts) 1000000)))

(defun ms->ts (ms)
  (multiple-value-bind (unix msec) (floor ms 1000)
    (local-time:unix-to-timestamp unix :nsec (* msec 1000000))))

(defun today ()
  (local-time:adjust-timestamp (local-time:now)
    (set :hour 0)
    (set :minute 0)
    (set :sec 0)
    (set :nsec 0)))

(defun save-events (events)
  (dolist (e events)
    (db.insert "events" e)))

(defgeneric $between (a from to)
  (:documentation "cl-mongo between query"))

(defmethod $between (a from to)
  (kv ($>= a from) ($< a to)))

(defmethod $between (a (from local-time:timestamp) (to local-time:timestamp))
  ($between a
            (cl-mongo::make-bson-time (ts->ms from))
            (cl-mongo::make-bson-time (ts->ms to))))

(defun make-keyword (name) (values (intern (string-upcase name) "KEYWORD")))

(defun starts-with (str with)
  (string= (subseq str 0 (min (length str)
                              (length with)))
           with))

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

(defvar *decode-doc-to* :plist "Document object type")
(defgeneric decode-element (element)
  (:documentation "Convert cl-mongo element to preferred type"))

(defmethod decode-element (element)
  element)

(defmethod decode-element ((element document))
  (case *decode-doc-to*
    (:plist (doc->plist element))))

(defmethod decode-element ((element cl-mongo::bson-time))
  (ms->ts (cl-mongo::raw element)))

(defun doc->plist (doc)
  (let ((*decode-doc-to* :plist)
        result)
    (loop for key in (get-keys doc)
       do (setf (getf result (make-keyword key))
                (decode-element (get-element key doc))))
    result))

(defmethod yason:encode ((object document) &optional (stream *standard-output*))
  (let ((hash (cl-mongo::elements object)))
    (unless (cl-mongo::_local object)
      (setf (gethash "_id" hash)
            (crypto:byte-array-to-hex-string (doc-id object))))
    (yason:encode hash stream)))

(defmethod yason:encode ((object cl-mongo::bson-time) &optional (stream *standard-output*))
  (yason:encode (cl-mongo::raw object) stream))

;; Google Chrome Cookies loading
(defvar *chrome-cookie-password*
  (crypto:ascii-string-to-byte-array "peanuts")
  "Password for PBKDF2")
(defvar *chrome-cookie-salt*
  (crypto:ascii-string-to-byte-array "saltysalt")
  "Salt for PBKDF2")
(defvar *chrome-cookie-iterations* 1 "PBKDF2 iteration count")
(defvar *chrome-cookie-key-length* 16 "PBKDF2 key length")

(defun chrome-make-cookie-cipher ()
  (crypto:make-cipher 'crypto:aes :mode 'crypto:cbc
                      :key (crypto:derive-key
                            (crypto:make-kdf 'crypto:pbkdf2 :digest 'crypto:sha1)
                            *chrome-cookie-password*
                            *chrome-cookie-salt*
                            *chrome-cookie-iterations*
                            *chrome-cookie-key-length*)
                      :initialization-vector (crypto:ascii-string-to-byte-array
                                              "                ")))

(defvar *chrome-cookie-file*
  (merge-pathnames #P".config/google-chrome/Default/Cookies"
                   (user-homedir-pathname)))
(defparameter +temp-cookie-file+ #P"cookies.sqlite")

(define-condition bad-encoding-error (simple-error) ())

(defun chrome-cookie-decode (value)
  (when (mismatch (subseq value 0 3)
                  (mapcar #'char-code (coerce "v10" 'list)))
    (error 'bad-encoding-verion))
  (crypto:decrypt-in-place (chrome-make-cookie-cipher) value :start 3)
  (coerce (mapcar #'code-char (subseq (coerce value 'list)
                                      3 (- (length value)
                                           (elt value (1- (length value)))))) 'string))

(defun load-chrome-cookie-jar (domain)
  ;; Workaround chrome sometimes locking cookies database
  (cl-fad:copy-file *chrome-cookie-file* +temp-cookie-file+ :overwrite t)
  (sqlite:with-open-database (db +temp-cookie-file+)
    (make-instance 'drakma:cookie-jar
                   :cookies (loop
                               for (name host-key value path expires secure-p http-only-p encrypted)
                               in (sqlite::execute-to-list
                                   db (format nil "select name, host_key, value, path, expires_utc, secure, httponly, encrypted_value from cookies where host_key like '%~A%'" domain))
                               collect (make-instance 'drakma:cookie
                                                      :name name
                                                      :domain host-key
                                                      :value (if (string= value "")
                                                                 (chrome-cookie-decode encrypted)
                                                                 value)
                                                      :path path
                                                      :expires (if (equal expires 0) nil (floor expires 1000))
                                                      :securep (equal secure-p 1)
                                                      :http-only-p (equal http-only-p 1))))))