optimized

travels.asd

@@ -13,7 +13,7 @@
                :lack
                :quri
                :zip
-               :flexi-streams
+               :trivial-utf-8
                :myway
                :jonathan)
   :serial t

travels.lisp

@@ -1,11 +1,15 @@
 (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 (getf old :|user|))
-        (new-user (getf new :|user|))
-        (old-loc (getf old :|location|))
-        (new-loc (getf new :|location|)))
+        (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)))))
@@ -21,20 +25,30 @@
                     (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 (jojo:parse
-                     (flex:octets-to-string (zip:zipfile-entry-contents entry) :external-format :utf-8)
-                     :as :plist)))
+        (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 elements))))))
+                             (make-hash-table :size (length (the list elements)))))))
               (loop for item in elements
-                 do (setf (gethash (getf item :|id|) entity-storage) item)
+                 do (setf (gethash (getf item :|id|) entity-storage)
+                          (dumps item))
                  when (eq entity :|visits|)
                  do (update-indexes storage nil item)))))))
     storage))
@@ -52,16 +66,13 @@
      (type symbol indicator))
     (intern (getf place indicator) keyword-package)))
 
-(defparameter +400+ '(400 nil nil))
-(defparameter +404+ '(404 nil nil))
-(defparameter +200-empty+ '(200 (:content-type "application/json" :content-length 2) ("{}")))
-(defun 200-json (data)
-  (declare (optimize (speed 3) (safety 0))
-           (type list data))
-  (let ((content (jojo:to-json data)))
-    `(200 (:content-type "application/json"
-           :content-length ,(trivial-utf-8:utf-8-byte-length content))
-          (,content))))
+(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 "{}")))
+
+(defvar *200* '(200 (:content-type "application/json") content))
+(defun 200-json (data) (setf (caddr *200*) (dumps data)) *200*)
 
 (defun get-entity (params)
   (let ((id (parse-integer (getf params :id) :junk-allowed t))
@@ -71,62 +82,66 @@
           ((:|users| :|visits| :|locations|)
            (let ((entity (gethash id (gethash entity *storage*))))
              (if entity
-                 (200-json entity)
+                 `(200 (:content-type "application/json") ,entity)
                  +404+)))
           (otherwise +404+))
         +404+)))
 
 (defun validate-item (item)
-  (declare (type list item)
+  (declare (type (or null list) item)
            (optimize (speed 3) (safety 0)))
-  (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|) (> (length v) 50)) return nil
-     when (and (eq k :|city|) (> (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)))
+  (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= (getf params :id) "new"))
+    (if (or id (string= (the simple-string (getf params :id)) "new"))
         (case entity
           ((:|users| :|visits| :|locations|)
            (handler-case
-               (let ((body (make-string (getf myway:*env* :content-length))))
-                 (read-sequence body (flex:make-flexi-stream
-                                      (getf myway:*env* :raw-body)
-                                      :external-format :utf8))
-                 (let ((item (jojo:parse body))
-                       (entity-storage (gethash entity *storage*)))
-                   (if (validate-item item)
-                       (let ((item-id (getf item :|id|)))
-                         (if id
-                             (if item-id +400+
-                                 (let ((existing (gethash id entity-storage)))
-                                   (if existing
-                                       (progn
-                                         (when (eq entity :|visits|)
-                                           (update-indexes *storage* existing item))
-                                         (loop for (k v) on item by #'cddr
-                                            do (setf (getf existing k) v))
-                                         +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) item)
-                                     +200-EMPTY+)))))
-                       +400+)))
-             (error () +400+)))
-          (otherwise +404+))
+               (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))
@@ -150,6 +165,8 @@
        (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*)))
@@ -161,19 +178,20 @@
                     (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 (aget query-params "country")))
-                      (assert (or (null country) (<= (length country) 50)))
+                          (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 = (gethash v-id *storage-visits*)
-                                            for loc = (gethash (getf visit :|location|) *storage-locations*)
+                                            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 user-visits #'< :key (lambda (v) (getf v :|visited_at|))))))))
+                                        (sort (the list user-visits)
+                                              #'< :key (lambda (v) (getf v :|visited_at|))))))))
                 (error () +400+))
               +404+))
         +404+)))
@@ -211,6 +229,8 @@
          (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*))))
@@ -224,18 +244,21 @@
                           (now (get-unix-time))
                           (from-age (may-integer (aget query-params "fromAge")))
                           (to-age (may-integer (aget query-params "toAge")))
-                          (gender (aget query-params "gender")))
+                          (gender (the (or null string) (aget query-params "gender"))))
                       (assert (or (null gender) (string= gender "m") (string= gender "f")))
-                      (let ((marks (loop for v-id in location-visit-ids
-                                      for visit = (gethash v-id *storage-visits*)
-                                      for user = (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))
-                                      collect (getf visit :|mark|))))
-                        (200-json (list :|avg|
-                                        (if marks
-                                            (/ (apply #'+ marks) (length marks))
-                                            0.0))))))
+                      (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+)))
@@ -258,6 +281,8 @@
   (setf *storage-users* (gethash :|users| *storage*)
         *storage-locations* (gethash :|locations| *storage*)
         *storage-visits* (gethash :|visits| *storage*))
+  #+sbcl (sb-ext:gc)
+  (room)
   (format t "Loaded ~A~%" data)
   (apply #'clack:clackup
          (myway:to-app *mapper*)