hc-travels/travels.lisp

(in-package :travels)

(defun update-indexes (storage old new)
  (declare (optimize (speed 3) (safety 0))
           (type hash-table storage)
           (type (or null list) old)
           (type (or null list) new))
  (let ((id (or (getf old :|id|) (getf new :|id|)))
        (old-user (the (or null fixnum) (getf old :|user|)))
        (new-user (the (or null fixnum) (getf new :|user|)))
        (old-loc (the (or null fixnum) (getf old :|location|)))
        (new-loc (the (or null fixnum) (getf new :|location|))))
    (labels ((update (s o n)
               (when o (setf (gethash o s) (remove id (gethash o s))))
               (when n (push id (gethash n s)))))
      (when (or (null new)
                (null old)
                (and new-user (not (= old-user new-user))))
        (update (or (gethash :user-visits storage)
                    (setf (gethash :user-visits storage) (make-hash-table)))
                old-user new-user))
      (when (or (null new) (null old)
                (and new-loc (not (= old-loc new-loc))))
        (update (or (gethash :location-visits storage)
                    (setf (gethash :location-visits storage) (make-hash-table)))
                old-loc new-loc)))))

(defun loads (bytes)
  (declare (optimize (speed 3) (safety 0))
           (type (simple-array (unsigned-byte 8) (*)) bytes))
  (jojo:parse (trivial-utf-8:utf-8-bytes-to-string bytes)))

(defun dumps (data)
  (declare (optimize (speed 3) (safety 0))
           (type (or null list) data))
  (trivial-utf-8:string-to-utf-8-bytes (jojo:to-json data)))

(defun load-data (pathname)
  (declare (optimize (speed 3) (safety 0)))
  (let ((storage (make-hash-table)))
    (zip:with-zipfile (zip pathname)
      (zip:do-zipfile-entries (name entry zip)
        (let ((data (loads (zip:zipfile-entry-contents entry))))
          (destructuring-bind (entity elements) data
            (let ((entity-storage
                   (or (gethash entity storage)
                       (setf (gethash entity storage)
                             (make-hash-table :size (length (the list elements)))))))
              (loop for item in elements
                 do (setf (gethash (getf item :|id|) entity-storage)
                          (dumps item))
                 when (eq entity :|visits|)
                 do (update-indexes storage nil item)))))))
    storage))

(defvar *storage* nil "data store")
(defvar *storage-users* nil "users store")
(defvar *storage-locations* nil "locations store")
(defvar *storage-visits* nil "visits store")

(let ((keyword-package (find-package :keyword)))
  (defun getkey (place indicator)
    (declare
     (optimize (speed 3) (safety 0))
     (type list place)
     (type symbol indicator))
    (intern (getf place indicator) keyword-package)))

(defparameter +400+ '(400 nil #.(trivial-utf-8:string-to-utf-8-bytes "400")))
(defparameter +404+ '(404 nil #.(trivial-utf-8:string-to-utf-8-bytes "404")))
(defparameter +200-empty+ '(200 (:content-type "application/json")
                            #.(trivial-utf-8:string-to-utf-8-bytes "{}")))

(defun 200-json (data)
  (declare (optimize (speed 3) (safety 0))
           (type list data))
  `(200 (:content-type "application/json") ,(dumps data)))

(defun get-entity (params)
  (declare (optimize (speed 3) (safety 0)))
  (let ((id (parse-integer (getf params :id) :junk-allowed t))
        (entity (the symbol (getkey params :entity))))
    (if id
        (case entity
          ((:|users| :|visits| :|locations|)
           (let ((entity (gethash (the fixnum id) (gethash (the symbol entity) *storage*))))
             (if entity
                 `(200 (:content-type "application/json") ,entity)
                 +404+)))
          (otherwise +404+))
        +404+)))

(defun validate-item (item)
  (declare (type (or null list) item)
           (optimize (speed 3) (safety 0)))
  (when item
    (loop for (k v) on item by #'cddr
       unless v return nil
 ;     when (and (eq k :|id|) (not (integerp v))) return nil
 ;     when (and (eq k :|distance|) (not (integerp v))) return nil
 ;     when (and (eq k :|visited_at|) (not (integerp v))) return nil
 ;     when (and (eq k :|country|) (or (not (stringp v)) (> (length v) 50))) return nil
 ;     when (and (eq k :|city|) (or (not (stringp v)) (> (length v) 50))) return nil
 ;     when (and (eq k :|mark|) (or (not (integerp v)) (not (<= 0 (the fixnum v) 5)))) return nil
 ;     when (and (eq k :|user|) (or (not (integerp v)) (not (gethash v *storage-users*)))) return nil
 ;     when (and (eq k :|location|) (or (not (integerp v)) (not (gethash v *storage-locations*)))) return nil
       finally (return t))))

(defun post-entity (params)
  (declare (optimize (speed 3) (safety 0)))
  (let ((id (parse-integer (getf params :id) :junk-allowed t))
        (entity (getkey params :entity)))
    (if (or id (string= (the simple-string (getf params :id)) "new"))
        (case entity
          ((:|users| :|visits| :|locations|)
           (handler-case
               (let* ((body (trivial-utf-8:read-utf-8-string
                                  (getf myway:*env* :raw-body)
                                  :stop-at-eof t))
                      (item (jojo:parse (coerce body 'simple-string)))
                     (entity-storage (gethash entity *storage*)))
                 (if (validate-item item)
                     (let ((item-id (getf item :|id|)))
                       (if id
                           (if item-id +400+
                               (let ((existing-raw (gethash id entity-storage)))
                                 (if existing-raw
                                     (let ((existing (loads existing-raw)))
                                       (when (eq entity :|visits|)
                                         (update-indexes *storage* existing item))
                                       (loop for (k v) on item by #'cddr
                                          do (setf (getf existing k) v))
                                       (setf (gethash id entity-storage)
                                             (dumps existing))
                                       +200-EMPTY+)
                                     +404+)))
                           (let ((e (gethash item-id entity-storage)))
                             (if e +400+
                                 (progn
                                   (when (eq entity :|visits|)
                                     (update-indexes *storage* nil item))
                                   (setf (gethash item-id entity-storage)
                                         (dumps item))
                                   +200-EMPTY+)))))
                     +400+))
))
          (othewise +404+))
        +400+)))

(defun aget (place indicator &key (test #'equal))
  (declare (type list place)
           (type (or string symbol) indicator)
           (type function test)
           (optimize (speed 3) (safety 0)))
  (cdr (assoc indicator place :test test)))

(defun may-integer (string)
  (declare (type (or null string) string))
  (when string
    (parse-integer string)))

(defun matching-location (location country to-distance)
  (and (or (not country) (equal (getf location :|country|) country))
       (or (not to-distance) (< (getf location :|distance|) to-distance))))

(defun matching-visit (visit from-date to-date)
  (and (or (not from-date) (> (getf visit :|visited_at|) from-date))
       (or (not to-date) (< (getf visit :|visited_at|) to-date))))

(defun user-visits (params)
  (declare (optimize (speed 3) (safety 0))
           (type list params))
  (let ((id (parse-integer (getf params :id) :junk-allowed t)))
    (if id
        (let ((user (gethash id *storage-users*)))
          (if user
              (handler-case
                  (let* ((user-visit-ids (gethash id (gethash :user-visits *storage*)))
                         (query-string (getf myway:*env* :query-string))
                         (query-params (and query-string (quri:url-decode-params query-string))))
                    (let ((from-date (may-integer (aget query-params "fromDate")))
                          (to-date (may-integer (aget query-params "toDate")))
                          (to-distance (may-integer (aget query-params "toDistance")))
                          (country (the (or null string) (aget query-params "country"))))
                      ;; (assert (or (null country) (<= (length country) 50)))
                      ;; TODO: Smarter indexes
                      (let ((user-visits (loop for v-id in user-visit-ids
                                            for visit = (loads (gethash v-id *storage-visits*))
                                            for loc = (loads (gethash (getf visit :|location|) *storage-locations*))
                                            when (and visit (matching-visit visit from-date to-date))
                                            when (and loc (matching-location loc country to-distance))
                                            collect (list :|mark| (getf visit :|mark|)
                                                          :|visited_at| (getf visit :|visited_at|)
                                                          :|place| (getf loc :|place|)))))
                        (200-json (list :|visits|
                                        (sort (the list user-visits)
                                              #'< :key (lambda (v) (getf v :|visited_at|))))))))
                (error () +400+))
              +404+))
        +404+)))

(defun smart-f (arg &optional digits)
  (with-output-to-string (s)
    (prin1 (cond ((= (round arg) arg) (round arg))
                 (digits (float (/ (round (* arg (expt 10 digits)))
                                   (expt 10 digits))))
                 (t arg))
           s)))

(defvar *unix-epoch-difference*
  (encode-universal-time 0 0 0 1 1 1970 0))

(defvar *year*
  (round (* 60 60 24 365.25)))

(defun universal-to-unix-time (universal-time)
  (- universal-time *unix-epoch-difference*))

(defun unix-to-universal-time (unix-time)
  (+ unix-time *unix-epoch-difference*))

(defun get-unix-time ()
  (universal-to-unix-time (get-universal-time)))

(defmethod jojo::%to-json ((ratio ratio))
  (jojo:%write-string (smart-f ratio 5)))

(defun matching-user (user from-age to-age gender now)
  (let ((age (/ (- now (getf user :|birth_date|)) *year*)))
    (and (or (not gender) (equal (getf user :|gender|) gender))
         (or (not from-age) (> age from-age))
         (or (not to-age) (< age to-age)))))

(defun location-avg-mark (params)
  (declare (optimize (speed 3) (safety 0))
           (type list params))
  (let ((id (parse-integer (getf params :id) :junk-allowed t)))
    (if id
        (let ((location (gethash id (gethash :|locations| *storage*))))
          (if location
              (handler-case
                  (let* ((location-visit-ids (gethash id (gethash :location-visits *storage*)))
                         (query-string (getf myway:*env* :query-string))
                         (query-params (and query-string (quri:url-decode-params query-string))))
                    (let ((from-date (may-integer (aget query-params "fromDate")))
                          (to-date (may-integer (aget query-params "toDate")))
                          (now (get-unix-time))
                          (from-age (may-integer (aget query-params "fromAge")))
                          (to-age (may-integer (aget query-params "toAge")))
                          (gender (the (or null string) (aget query-params "gender"))))
                      (assert (or (null gender) (string= gender "m") (string= gender "f")))
                      (multiple-value-bind (s c)
                          (loop
                             with sum-marks of-type fixnum = 0
                             with count-marks of-type fixnum = 0
                             for v-id in location-visit-ids
                             for visit = (loads (gethash v-id *storage-visits*))
                             for user = (loads (gethash (getf visit :|user|) *storage-users*))
                             when (and visit (matching-visit visit from-date to-date))
                             when (and user (matching-user user from-age to-age gender now))
                             do (setf sum-marks (+ sum-marks (the fixnum (getf visit :|mark|)))
                                      count-marks (1+ count-marks))
                             finally (return (values sum-marks count-marks)))
                        (200-json (list :|avg| (if (zerop c) 0.0 (/ s c)))))))
                (error () +400+))
              +404+))
        +404+)))

(defvar *mapper* (myway:make-mapper))
(myway:connect *mapper* "/:entity/:id" 'post-entity :method :post)
(myway:connect *mapper* "/:entity/:id" 'get-entity)
(myway:connect *mapper* "/users/:id/visits" 'user-visits)
(myway:connect *mapper* "/locations/:id/avg" 'location-avg-mark)
(myway:connect *mapper* "*" (lambda (p) (declare (ignore p)) +404+))

(defun main (&rest args
             &key
               (data "data.zip")
               (address "0.0.0.0")
               (port 5000)
               (debug nil)
               (use-thread nil) &allow-other-keys)
  (setf *storage* (load-data data))
  (setf *storage-users* (gethash :|users| *storage*)
        *storage-locations* (gethash :|locations| *storage*)
        *storage-visits* (gethash :|visits| *storage*))
  #+sbcl (sb-ext:gc :full t)
  (room)
  (format t "Loaded ~A~%" data)
  (apply #'clack:clackup
         (myway:to-app *mapper*)
         :server :woo
         :address address
         :port port
         :debug debug
         :use-default-middlewares nil
         :use-thread use-thread
         (alexandria:remove-from-plist args :data :address :port :debug :use-thread)))