Photos

src/financisto.lisp

@@ -1,7 +1,7 @@
 (in-package :cl-user)
 (defpackage #:timeliner.financisto
   (:use :cl #:timeliner.utils :cl-mongo)
-  (:export #:import-financisto-events #:on-cron))
+  (:export #:*financisto-backup-path* #:on-cron))
 (in-package #:timeliner.financisto)
 
 (defvar *financisto-backup-path* #P"/home/enikesha/Documents/backups/financisto/")

src/locations.lisp

@@ -136,8 +136,8 @@
 (defun point->doc (point)
   (when point
     (kv (kv :type "Point") ; GeoJSON Point
-        (kv :coordinates (list (geo:longitude-deg point)
-                               (geo:latitude-deg point))))))
+        (kv :coordinates (list (float (geo:longitude-deg point))
+                               (float (geo:latitude-deg point)))))))
 
 (defun make-location-doc (loc)
   (kv

src/photos.lisp

@@ -0,0 +1,114 @@
+(in-package :cl-user)
+(defpackage #:timeliner.photos
+  (:use :cl #:timeliner.utils :cl-mongo :zpb-exif)
+  (:export #:*photos-path*
+           #:*photos-ignore*
+           #:on-cron))
+(in-package #:timeliner.photos)
+
+(defvar *photos-path* nil "Root path to search photos")
+(defvar *photos-types* '("JPG" "PNG") "Allowed types of photos")
+(defvar *photos-ignore* nil "Ignored filenames")
+
+(defun make-photo-doc (photo)
+  (let* ((ts (aget :created-at photo)))
+    (kv
+     (kv :ts ts)
+     (kv :type "photo")
+     (kv :title (format nil "Photo taken: ~A" (aget :name photo)))
+     (kv :photo (kv
+                 (kv "path" (aget :path photo))
+                 (kv "modified" (aget :modified photo))
+                 (kv "length" (aget :length photo))
+                 (kv "dimensions" (aget :dim photo))))
+     (kv :loc (timeliner.locations:point->doc
+               (or (aget :location photo)
+                   (timeliner.locations:find-location-at (ts->ms ts))))))))
+
+(defun degrees-to-rational (deg ref)
+  (when deg
+    (let ((rational
+           (+ (elt deg 0)
+              (/ (elt deg 1) 60)
+              (/ (elt deg 2) 3600))))
+      (if (member ref '("N" "E") :test #'equal)
+          rational
+          (- rational)))))
+
+(defun exif-to-point (exif)
+  (when exif
+    (let ((lat (degrees-to-rational (exif-value :GPSLatitude exif)
+                                    (exif-value :GPSLatitudeRef exif)))
+          (lon (degrees-to-rational (exif-value :GPSLongitude exif)
+                                    (exif-value :GPSLongitudeRef exif))))
+      (and lat lon (geo:point-deg lat lon)))))
+
+(defun exif-to-taken (exif)
+  (when exif
+    (or (parsed-exif-value :DateTimeOriginal exif)
+        (parsed-exif-value :DateTime exif))))
+
+(defun exif-to-dim (exif)
+  (when exif
+    (let ((width (and exif (or (exif-value :PixelXDimension exif)
+                               (exif-value :ImageWidth exif))))
+          (height (and exif (or (exif-value :PixelYDimension exif)
+                                (exif-value :ImageHeight exif)))))
+      (and width height (list width height)))))
+
+(defun load-photo-info (path modified)
+  (with-open-file (in path :element-type '(unsigned-byte 8))
+    (let ((length (file-length in))
+          (exif (ignore-errors (make-exif in))))
+      (list
+       (cons :name (pathname-name path))
+       (cons :path (namestring path))
+       (cons :modified modified)
+       (cons :length length)
+       (cons :created-at (local-time:universal-to-timestamp
+                          (or (exif-to-taken exif) modified)))
+       (cons :dim (exif-to-dim exif))
+       (cons :location (exif-to-point exif))))))
+
+(defun load-existing-photos ()
+  (let ((photos (make-hash-table :test #'equal)))
+    (mongo-iter
+     #'(lambda (d)
+         (setf (gethash (get-element "photo.path" d) photos)
+               (list (get-element "photo.modified" d)
+                     (doc-id d))))
+     "events" ($ "type" "photo") :selector ($ ($ "photo.path" 1)
+                                              ($ "photo.modified" 1)))
+    photos))
+
+(defun import-photo-events ()
+  (let ((existing (load-existing-photos)))
+    (labels ((test-path (p)
+               (if (directory-pathname-p p)
+                   (not (member (car (last (pathname-directory p)))
+                                *photos-ignore*
+                                :test #'equal))
+                   (member (pathname-type p :case :common)
+                           *photos-types* :test #'equal)))
+             (handle (p)
+               (let* ((name (namestring p))
+                      (modified (file-write-date p))
+                      (prev (gethash name existing)))
+                 (if (and prev (= modified (first prev)))
+                     (remhash name existing) ;; so that existing would only contains deleted files
+                     (handler-case
+                         (let ((info (load-photo-info p modified)))
+                           (db.insert "events" (make-photo-doc info))
+                           (log:info "Added" info))
+                       (error (e) (log:error "Error adding photo" name e)))))))
+      (walk-directory *photos-path* #'handle :test #'test-path)
+      ;; Remove events for missing files
+      (loop for name being the hash-keys in existing
+         do (log:info "Deleting missing" name)
+           (db.delete "events" ($ "_id" (cl-mongo::make-bson-oid
+                                         :oid (second (gethash name existing)))))))))
+
+(defun on-cron ()
+  (handler-case
+      (import-photo-events)
+    (error (e) (log:error e))))

src/utils.lisp

@@ -12,7 +12,11 @@
    #:doc->plist
    #:load-chrome-cookie-jar
    #:today
-   #:save-events))
+   #:save-events
+   #:mongo-iter
+   #:directory-pathname-p
+   #:list-directory
+   #:walk-directory))
 (in-package :timeliner.utils)
 
 (defun ts->ms (ts)
@@ -145,3 +149,115 @@
                                                       :expires (if (equal expires 0) nil (floor expires 1000))
                                                       :securep (equal secure-p 1)
                                                       :http-only-p (equal http-only-p 1))))))
+
+(defun mongo-iter (fn collection query &key selector (max-per-call 0) (mongo (cl-mongo:mongo)))
+  (let ((result (db.find collection query :selector selector :limit max-per-call :mongo mongo)))
+    (loop
+       do (multiple-value-bind (iterator collection docs) (db.iterator result)
+            (mapc fn docs)
+            (when (zerop iterator) (return))
+            (setf result (db.next collection iterator :mongo mongo :limit max-per-call))))))
+
+;; From 'Practical Common Lisp' by Peter Seibel
+(defun component-present-p (value)
+  (and value (not (eql value :unspecific))))
+
+(defun directory-pathname-p (p)
+  (and
+   (not (component-present-p (pathname-name p)))
+   (not (component-present-p (pathname-type p)))
+   p))
+
+(defun pathname-as-directory (name)
+  (let ((pathname (pathname name)))
+    (when (wild-pathname-p pathname)
+      (error "Can't reliably convert wild pathnames."))
+    (if (not (directory-pathname-p name))
+      (make-pathname
+       :directory (append (or (pathname-directory pathname) (list :relative))
+                          (list (file-namestring pathname)))
+       :name      nil
+       :type      nil
+       :defaults pathname)
+      pathname)))
+
+(defun directory-wildcard (dirname)
+  (make-pathname
+   :name :wild
+   :type #-clisp :wild #+clisp nil
+   :defaults (pathname-as-directory dirname)))
+
+(defun list-directory (dirname)
+  (when (wild-pathname-p dirname)
+    (error "Can only list concrete directory names."))
+  (let ((wildcard (directory-wildcard dirname)))
+
+    #+(or sbcl cmu lispworks)
+    (directory wildcard)
+
+    #+openmcl
+    (directory wildcard :directories t)
+
+    #+allegro
+    (directory wildcard :directories-are-files nil)
+
+    #+clisp
+    (nconc
+     (directory wildcard)
+     (directory (clisp-subdirectories-wildcard wildcard)))
+
+    #-(or sbcl cmu lispworks openmcl allegro clisp)
+    (error "list-directory not implemented")))
+
+#+clisp
+(defun clisp-subdirectories-wildcard (wildcard)
+  (make-pathname
+   :directory (append (pathname-directory wildcard) (list :wild))
+   :name nil
+   :type nil
+   :defaults wildcard))
+
+(defun file-exists-p (pathname)
+  #+(or sbcl lispworks openmcl)
+  (probe-file pathname)
+
+  #+(or allegro cmu)
+  (or (probe-file (pathname-as-directory pathname))
+      (probe-file pathname))
+
+  #+clisp
+  (or (ignore-errors
+        (probe-file (pathname-as-file pathname)))
+      (ignore-errors
+        (let ((directory-form (pathname-as-directory pathname)))
+          (when (ext:probe-directory directory-form)
+            directory-form))))
+
+  #-(or sbcl cmu lispworks openmcl allegro clisp)
+  (error "file-exists-p not implemented"))
+
+(defun pathname-as-file (name)
+  (let ((pathname (pathname name)))
+    (when (wild-pathname-p pathname)
+      (error "Can't reliably convert wild pathnames."))
+    (if (directory-pathname-p name)
+      (let* ((directory (pathname-directory pathname))
+             (name-and-type (pathname (first (last directory)))))
+        (make-pathname
+         :directory (butlast directory)
+         :name (pathname-name name-and-type)
+         :type (pathname-type name-and-type)
+         :defaults pathname))
+      pathname)))
+
+(defun walk-directory (dirname fn &key directories (test (constantly t)))
+  (labels
+      ((walk (name)
+         (cond
+           ((directory-pathname-p name)
+            (when (and directories (funcall test name))
+              (funcall fn name))
+            (when (funcall test name)
+              (dolist (x (list-directory name)) (walk x))))
+           ((funcall test name) (funcall fn name)))))
+    (walk (pathname-as-directory dirname))))

src/web.lisp

@@ -94,7 +94,7 @@
                                    (getf data :styles)))))
      (:body
       (who:str (getf data :menu))
-      (:div :class "container"
+      (:div :class "container-fluid"
             (who:str (getf data :content)))
       (:div :id "modal" :class "modal fade" :tabindex "-1" :role "dialog" :aria-hidden "true")
       (who:str (apply #'scripts (list* "jquery.min.js"
@@ -164,12 +164,14 @@
                                   (:div :class "col-sm-12"
                                         (:div :id "paginator")))
                             (:div :class "row"
-                                  (:div :class "col-sm-6"
+                                  (:div :class "col-sm-4"
                                         (:div :id "events" :class "list-group"
                                               (:a :class "list-group-item"
                                                   "Loading")))
-                                  (:div :class "col-sm-6"
-                                        (:div :id "map"))))
+                                  (:div :class "col-sm-4"
+                                        (:div :id "map"))
+                                  (:div :class "col-sm-4"
+                                        (:div :id "details"))))
                           :inline-scripts
                           (tag/script
                            (ps ($ (lambda () (chain *timeliner (start (lisp (getf data :date)))))))))))
@@ -210,8 +212,8 @@
 (defparameter +timeliner.css+
   (css-lite:css
     (("body") (:padding-top "70px" :padding-bottom "30px"))
-    (("#map") (:height "600px" :border-radius "6px"))
-    (("#events") (:height "600px" :overflow-y "scroll"))
+    (("#map") (:height "750px" :border-radius "6px"))
+    (("#events") (:height "750px" :overflow-y "scroll"))
     (("#paginator") (:margin-bottom "10px"))))
 
 (restas:define-route static/css ("css/:file" :content-type "text/css")
@@ -219,6 +221,9 @@
     ((equal file "timeliner.css") +timeliner.css+)
     (t (merge-pathnames (format nil "css/~A" file) *resources*))))
 
+(restas:define-route static ("static/")
+  (pathname (hunchentoot:get-parameter "p")))
+
 ;;; parenscript macros
 (defpsmacro ! (&rest method-calls)
   `(chain ,@method-calls))
@@ -247,6 +252,9 @@
                     (new ((@ *timeliner *views *map)
                           (create :el "#map"
                                   :collection events)))
+                    (new ((@ *timeliner *views *details)
+                          (create :el "#details"
+                                  :collection events)))
 
                     (! router (on "route:home"
                                   (lambda ()
@@ -367,7 +375,8 @@
                               (:place "glyphicon glyphicon-map-marker")
                               (:finance "glyphicon glyphicon-usd")
                               (:checkin "glyphicon glyphicon-ok-circle")
-                              (:twitter "glyphicon glyphicon-pencil")))
+                              (:twitter "glyphicon glyphicon-pencil")
+                              (:photo "glyphicon glyphicon-picture")))
                render (lambda ()
                         (! this $el (attr (create
                                            :href "#"
@@ -417,6 +426,44 @@
                        (! this $el (append (who-ps-html (:li :class "list-group-item"
                                                              "No data")))))
                    this)))))
+    ;; ** Details
+    (setf
+     (@ *timeliner *views *details)
+     (! *backbone *view
+        (extend
+         (create
+          initialize (lambda ()
+                       (! this (listen-to (@ *timeliner dispatcher) "event:selected"
+                                          (@ this highlight))))
+          highlight (lambda (event)
+                      (var item (@ *timeliner *views *detail-views
+                                              (! event (get :type))))
+                      (setf (! this child)
+                            (if item
+                                (new (item (create :model event)))
+                                nil))
+                      (! this (render)))
+          render (lambda ()
+                   (! this $el (empty))
+                   (when (@ this child)
+                     (! this child (render))
+                     (! this $el (append (@ this child $el))))
+                   this)))))
+    (setf (! *timeliner *views *detail-views) (create))
+    (setf
+     (! *timeliner *views *detail-views :photo)
+     (! *backbone *view
+        (extend
+         (create
+          render (lambda ()
+                   (! this $el (html
+                                (who-ps-html
+                                 (:img :class "photo img-responsive"
+                                       :src (concatenate 'string
+                                                         (lisp (restas:genurl 'static))
+                                                         "?p="
+                                                         (! this model (get :photo) path))))))
+                   this)))))
     ;; ** Paginator
     (setf (@ *timeliner *views *paginator)
           (! *backbone *view

timeliner.asd

@@ -52,7 +52,8 @@ THE SOFTWARE.
                :cl-oauth
                :cl-date-time-parser
                :log4cl
-               :cl-fad)
+               :cl-fad
+               :zpb-exif)
   :components ((:module "src"
                 :components
                 ((:file "utils")
@@ -60,11 +61,13 @@ THE SOFTWARE.
                  (:file "financisto" :depends-on ("utils"))
                  (:file "foursquare" :depends-on ("utils"))
                  (:file "twitter" :depends-on ("utils"))
+                 (:file "photos" :depends-on ("utils"))
                  (:file "web" :depends-on ("utils"
                                            "locations"
                                            "financisto"
                                            "foursquare"
-                                           "twitter")))))
+                                           "twitter"
+                                           "photos")))))
   :description "Personal Timeline"
   :long-description
   #.(with-open-file (stream (merge-pathnames