timeliner/src/web.lisp

#|
  This file is a part of timeliner project.
  Copyright (c) 2014 Innokenty Enikeev (me@enikesha.net)
|#

(in-package :cl-user)
(restas:define-module #:timeliner.web
  (:use :cl :parenscript #:timeliner.utils))
(in-package #:timeliner.web)

(restas::register-pkgmodule-traits 'timeliner.web
                                   :render-method (lambda () (make-instance 'timeliner.web::renderer)))

;; Cron
(defvar *run-cron* t "Controls if starting a web should run cron tasks")
(defvar *crons* (list
                 (list #'timeliner.locations:on-cron '(:minute 0 :hour *))
                 (list #'timeliner.twitter:on-cron '(:minute 1 :hour *))
                 (list #'timeliner.foursquare:on-cron '(:minute 5 :hour *))
                 (list #'timeliner.financisto:on-cron '(:minute 0 :hour 7)))
  "List of cron functions with their schedules")
(defvar *cron-timers* nil)

(defmethod restas:initialize-module-instance :before ((module (eql #.*package*)) context)
  (restas:with-context context
    (alexandria:when-let (file (probe-file "config.lisp"))
      (load file))
    (cl-mongo:mongo :host "10.8.0.6")
    (cl-mongo:db.use "timeline")
    (when *run-cron*
      (restas:context-add-variable
       context '*cron-timers*
       (loop for (function schedule) in *crons*
          collect
            (clon:schedule-function function
                                    (clon:make-scheduler
                                     (apply #'clon:make-typed-cron-schedule schedule)
                                     :allow-now-p t)
                                    :thread t))))))

(defmethod restas:finalize-module-instance :after ((module (eql #.*package*)) context)
  (let ((timers (restas:context-symbol-value context '*cron-timers*)))
    (mapcar #'trivial-timers::unschedule-timer timers)))

;; Static file path
(defparameter *resources*
  (merge-pathnames "resources/"
                   (asdf:component-pathname (asdf:find-system '#:timeliner))))

;; Rendering
(defgeneric finalize-page (data)
  (:documentation "Final rendering step"))
(defgeneric render-route-data (route data)
  (:documentation "Process route-specific data"))

(setf (who:html-mode) :html5)
(defclass renderer () ())

(defun scripts (&rest scripts)
  (who:with-html-output-to-string (out)
    (loop for s in scripts
       do (who:htm (:script :src (restas:genurl 'static/js :file s))))))

(defun css (&rest files)
  (who:with-html-output-to-string (out)
    (loop for f in files
       do (who:htm (:link :href (restas:genurl 'static/css :file f) :rel "stylesheet")))))


(defmethod finalize-page ((data list))
  (who:with-html-output-to-string (out nil :prologue t)
    (:html
     (:head
      (:meta :charset "utf-8")
      (:meta :http-equiv "X-UA-Compatible" :content "IE=edge")
      (:meta :name "viewport" :content "width=device-width, initial-scale=1")
      (:title (who:str (getf data :title)))

      (who:str (apply #'css (list* "bootstrap.min.css"
                                   "bootstrap-theme.min.css"
                                   "timeliner.css"
                                   (getf data :styles)))))
     (:body
      (who:str (getf data :menu))
      (:div :class "container"
            (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"
                                       "bootstrap.min.js"
                                       (getf data :scripts))))
      (who:str (getf data :inline-scripts))))))

(defun menu (route)
  (who:with-html-output-to-string (out)
    (:div :class "navbar navbar-inverse navbar-fixed-top"
          :role "navigation"
          (:div :class "container"
                (:div :class "navbar-header"
                      (:button :type "button" :class "navbar-toggle"
                               :data-toggle "collapse"
                               :data-target ".navbar-collapse"
                               (:span :class "sr-only" "Toggle navigation")
                               (:span :class "icon-bar")
                               (:span :class "icon-bar")
                               (:span :class "icon-bar"))
                      (:a :class "navbar-brand"
                          :href (restas:genurl 'index)
                          "Timeliner"))
                (:div :class "collapse navbar-collapse"
                      (:ul :class "nav navbar-nav"
                           (:li :class (case route ('index "active"))
                                (:a :href (restas:genurl 'index) "Home"))
                           (:li :class (case route ('about "active"))
                                (:a :href (restas:genurl 'about) "About"))))))))

(defmethod render-route-data (route data)
  (list*
   :menu (menu route)
   :title (getf data :title "Timeliner")
   data))

(defmethod restas:render-object ((designer renderer) (object list))
  (let ((full-data (render-route-data (restas:route-symbol restas:*route*)
                                      object)))
    (finalize-page full-data)))

(restas:define-route index ("")
  (list))

(restas:define-route day ("day/:date")
  (list :date date))

(defmethod tag/script (body)
  (who:with-html-output-to-string (out)
    (:script :type "text/javascript" (who:str body))))

(defmethod render-route-data ((route (eql 'index)) data)
  (call-next-method route
                    (list :title "Main - Timeliner"
                          :styles '("leaflet.css"
                                    "bootstrap-datepicker.css")
                          :scripts '("moment.min.js"
                                     "bootstrap-datepicker.js"
                                     "bootstrap-datepaginator.min.js"
                                     "leaflet-src.js"
                                     "underscore.js"
                                     "backbone.js"
                                     "timeliner.js")
                          :content
                          (who:with-html-output-to-string (out)
                            (:div :class "row"
                                  (:div :class "col-sm-12"
                                        (:div :id "paginator")))
                            (:div :class "row"
                                  (:div :class "col-sm-6"
                                        (:div :id "events" :class "list-group"
                                              (:a :class "list-group-item"
                                                  "Loading")))
                                  (:div :class "col-sm-6"
                                        (:div :id "map"))))
                          :inline-scripts
                          (tag/script
                           (ps ($ (lambda () (chain *timeliner (start (lisp (getf data :date)))))))))))

(defmethod render-route-data ((route (eql 'day)) data)
  (render-route-data 'index data))


(restas:define-route about ("about/")
  (list :title "About Timeliner"
        :content
        (who:with-html-output-to-string (out)
          (:h1 "About"))))


(restas:define-route api/events ("api/events/"
                                 :method :GET
                                 :content-type "application/json")
  (let* ((start (or (ignore-errors (ms->ts (parse-integer (hunchentoot:get-parameter "start"))))
                    (local-time:today)))
         (end (or (ignore-errors (ms->ts (parse-integer (hunchentoot:get-parameter "end"))))
                  (local-time:timestamp+ start 1 :day))))
    (with-output-to-string (stream)
      (yason:encode
       (cl-mongo:docs
        (cl-mongo:db.sort "events" ($between "ts" start end) :field "ts" :limit 2000))
       stream))))

(restas:define-route api/events/delete ("api/events/:id"
                                        :method :DELETE
                                        :content-type "application/json")
  (cl-mongo:db.delete "events" (cl-mongo:$ "_id" (cl-mongo::make-bson-oid
                                                  :oid (crypto:hex-string-to-byte-array id))))
  "OK")

(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"))
    (("#paginator") (:margin-bottom "10px"))))

(restas:define-route static/css ("css/:file" :content-type "text/css")
  (cond
    ((equal file "timeliner.css") +timeliner.css+)
    (t (merge-pathnames (format nil "css/~A" file) *resources*))))

;;; parenscript macros
(defpsmacro ! (&rest method-calls)
  `(chain ,@method-calls))

(defparameter +timeliner.js+
  (ps
    ;; Base app structure
    (setf (@ window *timeliner)
          (create
           *models (create)
           *collections (create)
           *views (create)
           dispatcher (! _ (clone (@ *backbone *events)))
           :start (lambda (date)
                    (var router (new ((@ *timeliner *router))))
                    (var events (new ((@ *timeliner *collections *events))))
                    (setf (@ *timeliner events) events)
                    (setf (@ events url) (lisp (restas:genurl 'api/events)))
                    (new ((@ *timeliner *views *paginator)
                          (create :el "#paginator"
                                  :date date)))
                    (new ((@ *timeliner *views *events)
                          (create
                           :el "#events"
                           :collection events)))
                    (new ((@ *timeliner *views *map)
                          (create :el "#map"
                                  :collection events)))

                    (! router (on "route:home"
                                  (lambda ()
                                    (var today (! (moment)
                                                  (format "YYYY-MM-DD")))
                                    (! router (navigate
                                               (+ "day/" today)
                                               (create :trigger t :replace t))))))
                    (! router (on "route:day"
                                  (lambda (day)
                                    (! events (fetch
                                               (create
                                                :reset t
                                                :data (create
                                                       :start (!
                                                               (moment day "YYYY-MM-DD")
                                                               (value-of)))))))))
                    (! *backbone history (start (create push-state t)))
                    (setf (@ *timeliner router) router))))
    ;; * Router
    (setf (@ *timeliner *router)
          (! *backbone *router
             (extend (create :routes (create
                                      "" "home"
                                      "day/:day" "day")))))
    ;; * Models
    (setf (@ *timeliner *models *state)
          (! *backbone *model (extend (create
                                       :defaults (create
                                                  :day nil)))))
    (setf (@ *timeliner *models *event)
          (! *backbone *model (extend (create
                                       id-attribute "_id"
                                       :defaults (create
                                                  :ts nil
                                                  :type nil
                                                  :title nil
                                                  :loc nil)))))
    ;; * Collections
    (setf (@ *timeliner *collections *events)
          (! *backbone *collection (extend (create
                                            :model (@ *timeliner *models *event)))))
    ;; * Views
    ;; ** Dialog box
    (setf (@ *timeliner *views *dialog)
          (! *backbone *view
             (extend
              (create
               class-name "modal-dialog modal-sm"
               buttons (list
                        (create :text "Cancel" :class "btn-default" :event "cancel"
                                :attrs (create :data-dismiss "modal"))
                        (create :text "Ok" :class "btn-primary" :event "ok"))
               initialize (lambda (opts)
                            (! _ (extend this (! _ (pick (or opts (create))
                                                         "title" "body" "buttons")))))
               render-button (lambda (btn)
                               (var $btn ($ (who-ps-html
                                             (:button :class "btn"
                                                      (@ btn text)))))
                               (var self this)
                               (when (@ btn class)
                                 (! $btn (add-class (@ btn class))))
                               (when (@ btn attrs)
                                 (! $btn (attr (@ btn attrs))))
                               (! $btn (on "click"
                                           (lambda (e)
                                             (when (@ btn event)
                                               (! self (trigger
                                                        (+ "button:"
                                                         (@ btn event)))))
                                             (! ($ "#modal") (modal "hide")))))
                               $btn)
               render (lambda ()
                        (! this $el (html
                                     (who-ps-html
                                      (:div :class "modal-content"
                                            (:div :class "modal-header"
                                                  (:h4 :class "modal-title" (@ this title)))
                                            (:div :class "modal-body"
                                                  (@ this body))
                                            (:div :class "modal-footer")))))
                        (var self this)
                        (! this $el (find ".modal-footer")
                           (append
                            (loop for b in (@ self buttons)
                               collect (! self (render-button b)))))
                        this)
               show (lambda ()
                      (! ($ "#modal") (html (! this (render) el)) (modal))
                      this)))))
    ;; ** DeleteEventDialog
    (setf (@ *timeliner *views *delete-event)
          (! *timeliner *views *dialog
             (extend
              (create
               title "Delete event?"
               body "Are you sure you want to delete event?"
               buttons (list
                        (create :text "Cancel" :class "btn-default" :event "cancel"
                                :attrs (create :data-dismiss "modal"))
                        (create :text "Delete" :class "btn-danger" :event "delete"))))))
    ;; ** Event
    (setf (@ *timeliner *views *event)
          (! *backbone *view
             (extend
              (create
               tag-name "a"
               class-name "list-group-item"
               :events (create
                        "click" "select"
                        "dblclick" "delete")
               initialize (lambda ()
                            (! this (listen-to (@ this model) "change" (@ this render)))
                            (! this (listen-to (@ this model) "destroy" (@ this remove))))
               icon-class (lambda ()
                            (case (! this model (get :type))
                              (:place "glyphicon glyphicon-map-marker")
                              (:finance "glyphicon glyphicon-usd")
                              (:checkin "glyphicon glyphicon-ok-circle")
                              (:twitter "glyphicon glyphicon-pencil")))
               render (lambda ()
                        (! this $el (attr (create
                                           :href "#"
                                           :data-type (! this model (get :type)))))
                        (! this $el (html
                                     (who-ps-html
                                      (:span :class "label label-info pull-right"
                                             (:span :class "glyphicon glyphicon-time")
                                             " "
                                             (! (moment
                                                 (! this model (get :ts)))
                                                (format "HH:mm")))
                                      (:span :class (! this (icon-class)))
                                      " "
                                      (! this model (get :title)))))
                        this)
               select (lambda (e)
                        (! e (prevent-default))
                        (! this $el
                           (siblings) (remove-class "active") (end)
                           (add-class "active"))
                        (! *timeliner dispatcher
                           (trigger "event:selected" (@ this model))))
               delete (lambda (e)
                        (! this (listen-to-once
                                 (! (new (@ *timeliner *views *delete-event))
                                    (show))
                                 "button:delete"
                                 (lambda ()
                                   (! this model (destroy))))))))))
    ;; ** Events
    (setf
     (@ *timeliner *views *events)
     (! *backbone *view
        (extend
         (create
          initialize (lambda ()
                       (! this (listen-to (@ this collection) "reset" (@ this render))))
          render-one (lambda (event)
                       (var item-view (new ((@ *timeliner *views *event)
                                            (create :model event))))
                       (! this $el (append (@ (! item-view (render)) $el))))
          render (lambda ()
                   (! this $el (empty))
                   (if (> (@ this collection length) 0)
                       (! this collection (each (@ this render-one) this))
                       (! this $el (append (who-ps-html (:li :class "list-group-item"
                                                             "No data")))))
                   this)))))
    ;; ** Paginator
    (setf (@ *timeliner *views *paginator)
          (! *backbone *view
             (extend
              (create
               :events (create selected-date-changed "changed")
               :initialize (lambda (opts)
                             (! this $el (datepaginator))
                             (when (@ opts date)
                               (! this $el (datepaginator "setSelectedDate"
                                                          (list (@ opts date)
                                                                "YYYY-MM-DD")))))
               :changed (lambda (e date)
                          (! *timeliner router
                             (navigate
                              (+ "day/" (! date (format "YYYY-MM-DD")))
                              (create :trigger t))))))))
    ;; ** Map
    (setf (@ *timeliner *views *map)
          (!
           *backbone *view
           (extend
            (create
             initialize (lambda ()
                          (var tile-layer
                               (! *L (tile-layer "http://{s}.tiles.mapbox.com/v3/{id}/{z}/{x}/{y}.png"
                                                 (create :id "enikesha.icd0bj4k" max-Zoom 18))))
                          (setf (@ this events-layer) (! *L (feature-group)))
                          (setf (@ this path-layer) (! *L (polyline (list)
                                                                    (create
                                                                     :weight 4
                                                                     :color "#f30"))))
                          (setf (@ this map)
                                (! *L (map (@ this el)
                                           (create
                                            :center '(59.94 30.33)
                                            :zoom 10
                                            :layers (list tile-layer
                                                          (@ this path-layer)
                                                          (@ this events-layer))))))
                          (! this (listen-to (@ this collection) "reset"
                                             (@ this render)))
                          (! this (listen-to (@ this collection) "change"
                                             (@ this render)))
                          (! this (listen-to (@ this collection) "add"
                                             (@ this render)))
                          (! this (listen-to (@ this collection) "remove"
                                             (@ this render)))
                          (! this (listen-to (@ *timeliner dispatcher) "event:selected"
                                             (@ this highlight))))
             render (lambda ()
                      (! this events-layer (clear-layers))
                      (! this path-layer (splice-lat-lngs 0))
                      (! this collection
                         (each (lambda (e)
                                 (var loc (! e (get "loc")))
                                 (when loc
                                   (var marker (! *L (circle-marker
                                                      (list (@ loc coordinates 1)
                                                            (@ loc coordinates 0))
                                                      (create
                                                       :radius 4
                                                       :weight 1
                                                       :color "#000"
                                                       fill-color "#F00"
                                                       fill-opacity 1))))
                                   (setf (@ e "_layer") marker)
                                   (! this path-layer (add-lat-lng
                                                       (! marker (get-lat-lng))))
                                   (! this events-layer (add-layer marker))))
                               this))
                      (when (@ this collection length)
                        (set-timeout
                         (! _ (bind (lambda ()
                                      (! this map (fit-bounds
                                                   (! this events-layer (get-bounds))
                                                   (create :padding '(50 50)))))
                                    this))
                         200))
                      this)
             highlight (lambda (event)
                         (var layer (@ event "_layer"))
                         (! this events-layer
                            (set-style (create fill-color "#F00")))
                         (if layer
                             (progn
                               (! layer (set-style (create fill-color "#03F")))
                               (when (and (not (@ *L *browser ie))
                                          (not (@ *L *browser opera)))
                                 (! layer (bring-to-front)))
                               (! this map (set-view (! layer (get-lat-lng))
                                                     16)))
                             (! this map (fit-bounds
                                          (! this events-layer (get-bounds))
                                          (create :padding '(50 50))))))))))))

(restas:define-route static/js ("js/:file" :content-type "application/x-javascript")
  (cond
    ((equal file "timeliner.js") +timeliner.js+)
    (t (merge-pathnames (format nil "js/~A" file) *resources*))))

(restas:define-route static/fonts ("fonts/:file")
  (merge-pathnames (format nil "fonts/~A" file) *resources*))