Permalink
Browse files

added server javascript and map/reduce

  • Loading branch information...
fons
fons committed Apr 30, 2010
1 parent d67f700 commit c30fc5fe717e0cc375e82135e89fe141bfab573b
Showing with 459 additions and 49 deletions.
  1. +2 −0 cl-mongo.asd
  2. +17 −4 src/bson.lisp
  3. +28 −3 src/db.lisp
  4. +9 −0 src/document.lisp
  5. +82 −0 src/js.lisp
  6. +67 −28 src/mongo-syntax.lisp
  7. +24 −11 src/mongo.lisp
  8. +27 −0 src/mr.lisp
  9. +23 −0 src/packages.lisp
  10. +15 −2 src/shell.lisp
  11. +157 −1 test/regression.lisp
  12. +8 −0 test/test-utils.lisp
View
@@ -14,6 +14,7 @@
:babel
:documentation-template
:lisp-unit
+ :parenscript
:usocket)
:serial t
:components
@@ -32,6 +33,7 @@
(:file "bson-array")
(:file "document")
(:file "mongo-syntax")
+ (:file "js.lisp")
(:file "bson-encode-container")
(:file "protocol")
(:file "mongo")
View
@@ -189,19 +189,32 @@ clashed with the encoding for booleans..
(:documentation "return data and the remaining array"))
(defmethod bson-decode ( (code t) (array t) )
- (format t "~% code : ~A ~%" code)
- (format t "~% array : ~A ~% " array)
+; (format t "~% code : ~A ~%" code)
+; (format t "~% array : ~A ~% " array)
(values array (make-octet-vector 1 :init-fill 1)))
(defmethod bson-decode ( (code (eql +bson-data-number+)) array)
(values (decode-double-float-bits (octet-to-int64 (subseq array 0 8))) (subseq array 8)))
-
-(defmethod bson-decode ( (code (eql +bson-data-string+)) array)
+
+(defmethod to-cstring (array)
(let* ((size (octet-to-int32 (subseq array 0 4)))
(str (null-terminated-octet-to-string (subseq array 4 (+ 4 size)) size))
(rest (subseq array (+ 4 size))))
(values str rest)))
+(defmethod bson-decode ( (code (eql +bson-data-string+)) array)
+ (to-cstring array))
+
+; (let* ((size (octet-to-int32 (subseq array 0 4)))
+; (str (null-terminated-octet-to-string (subseq array 4 (+ 4 size)) size))
+; (rest (subseq array (+ 4 size))))
+ ; (values str rest)))
+
+(defmethod bson-decode ( (code (eql +bson-data-code+)) array)
+ (to-cstring array))
+
+
+
(defmethod bson-decode ( (code (eql +bson-data-binary+)) array)
(let* ((type (octet-to-byte (subseq array 4 5)))
(size (if (eql type #x02) (octet-to-int32 (subseq array 5 9)) (octet-to-int32 (subseq array 0 4))))
View
@@ -98,6 +98,7 @@ found in the collection. ':multi' : Update all documents identified by the sele
:options (update-options :upsert upsert :multi-update multi))
:timeout 0)))
+;(defgeneric db.find-and-modify (collection query
(defgeneric db.save ( collection document &key)
(:documentation "
@@ -111,7 +112,11 @@ In other words this a a helper-function build around *db.insert* and *db.update*
(db.update collection (kv "_id" (_id document) ) document :mongo (or mongo (mongo) ) :upsert t))
(defmethod db.save ( (collection string) (document hash-table) &key (mongo nil) )
- (db.insert collection document :mongo (or mongo (mongo)) ))
+ (let ((_id (gethash "_id" document)))
+ (db.update collection (kv "_id" _id) document :mongo (or mongo (mongo) ) :upsert t)))
+
+(defmethod db.save ( (collection string) (document kv-container) &key (mongo nil) )
+ (db.save collection (kv->ht document) :mongo (or mongo (mongo))))
(defun headerp (val)
(and (consp val) (= 1 (length val))))
@@ -193,7 +198,7 @@ Stop iterating and clean up the iterator on the server by making a server call.
Delete a document from a collection. The *document* field is used to identify the document to
be deleted.
You can enter a list of documents. In that the server will be contacted to delete each one of these.
-It may be more efficient to run a delete script on he server side.
+It may be more efficient to run a delete script on the server side.
"))
(defmethod db.delete ( (collection t) (document (eql nil)) &key (mongo nil) ))
@@ -209,6 +214,15 @@ It may be more efficient to run a delete script on he server side.
(dolist (doc documents)
(db.delete collection doc :mongo mongo)))
+(defmethod db.delete ( (collection string) (document kv-container) &key (mongo nil))
+ (let ((mongo (or mongo (mongo) )))
+ (mongo-message mongo (mongo-delete (full-collection-name mongo collection)
+ (bson-encode-container document )) :timeout 0)))
+
+(defmethod db.delete ( (collection string) (kv pair) &key (mongo nil))
+ (let ((mongo (or mongo (mongo) )))
+ (mongo-message mongo (mongo-delete (full-collection-name mongo collection)
+ (bson-encode (pair-key kv) (pair-value kv))) :timeout 0)))
;
; key -> (string asc)
@@ -353,6 +367,17 @@ For most commands you can just uses the key-value shown in the mongo documentati
"Show all the collections in the current database."
(db.find "system.namespaces" 0 :mongo mongo))
+(defgeneric db.distinct ( collection key &key )
+ (:documentation "Return all the distinct values of this key in the collection "))
+
+(defmethod db.distinct ( (collection string) (key string) &key (mongo nil) )
+ (db.find "$cmd" (kv (kv "distinct" collection) (kv "key" key)) :limit 1 :mongo mongo))
+
+
+
+(defun count-it(collection key)
+ (db.find "$cmd" (kv (kv "distinct" collection) (kv "key" key))))
+
(defgeneric db.count ( collection selector &key )
(:documentation "
Count all the collections satifying the criterion set by the selector.
@@ -367,7 +392,7 @@ all the documents in the collection.
(db.count collection nil :mongo mongo))
(defmethod db.count ( (collection t) (selector pair ) &key (mongo nil) )
- (call-next-method collection (kv->ht selector) :mongo mongo))
+ (db.count collection (kv->ht selector) :mongo mongo))
(defgeneric db.eval ( code &rest rest)
(:documentation "run javascript code server side"))
View
@@ -72,6 +72,15 @@ is supplied.
(if exists-p (format stream " ~A -> ~A ~%" key (vpr value) )))))
(format stream "}~%")))
+(defun hash-keys (ht)
+ (let ((lst))
+ (with-hash-table-iterator (iterator ht)
+ (dotimes (repeat (hash-table-count ht))
+ (multiple-value-bind (exists-p key value) (iterator)
+ (if exists-p (push key lst)))))
+ (nreverse lst)))
+
+
;
; suppress the printing of the object id if the objectis locally generated
;
View
@@ -0,0 +1,82 @@
+(in-package :cl-mongo)
+
+#|
+ Enable javascript in the lisp using parenscript
+|#
+
+;-------
+
+(defparameter *js-definitions* (make-hash-table) "hash table containing client side javascript")
+
+(defmacro jsdef (name)
+ "Return the body of the javascript function; otherwise nill."
+ `(multiple-value-bind (value found) (gethash ',name *js-definitions*)
+ (when found value)))
+
+(defmacro jssrvdef (name)
+ "Return the body of the javascript function as installed on the server; otherwise nill."
+ `(db.find "system.js" (kv "_id" (string-downcase ',name))))
+
+
+; (if found
+; value
+; ',name)))
+
+(defmacro defjs (name args &body body)
+ "Define client side javascript. Works like defun; body is in lisp, with parenscript
+ additions, like return. So (defjs hello (x y) (return (+ x y))) defines an adder.
+ macro creates a lisp function which sends the javascript function over to the mongo
+ server to be evaluated. Result is processed and returned to the reader.
+ This will execute 10 times on the server :
+ (mapcar (lambda (x) (hello 10 x)) (list 1 2 3 4 5 6 7 8 9 10))"
+ `(let* ((js-body (parenscript:ps (lambda ,args ,@body))))
+ (setf (gethash ',name *js-definitions*) js-body)
+ (defun ,name ,args
+ (get-element "retval" (car (docs (db.eval js-body ,@args)))))))
+
+(defmacro defsrvjs (name args &body body)
+ "Creates a function which stores and executes javascript on the server. The first time
+ the function is called the javascript function is stored on the server. Subsequent calls will
+ call out to the server.
+ Works like defun; the function body is defined in lisp, with parenscript additions. Since
+ the body of the function already resides on the server this should have less impact on
+ the network. Use :install t to reinstall."
+ `(let* ((js-body (make-bson-code (parenscript:ps (lambda ,args ,@body))))
+ (server nil)
+ (func-name (string-downcase ',name))
+ (arg-list (format nil "(~{~a~^, ~})" ',args))
+ (jslambda (format nil "function ~A {return ~A~A;}" arg-list func-name arg-list)))
+ (flet ((install (name)
+ (setf server (mongo) )
+ (db.save "system.js" (kv (kv "_id" name) (kv "value" js-body)))))
+ (setf (gethash ',name *js-definitions*) js-body)
+ (defun ,name ,(append args '(&key (install nil)))
+ (progn
+ (when (or install (not server)) (install func-name))
+ (get-element "retval" (car (docs (db.eval jslambda ,@args)))))))))
+
+
+(defmacro install-js (name)
+ "Allows server based javascripts the be installed without being run."
+ `(db.save "system.js" (kv (kv "_id" (string-downcase ',name)) (kv "value" (jsdef ,name)))))
+
+;this may not be on the server; this is just to make sure..
+(defmacro remove-js (name)
+ `(progn (remhash ',name *js-definitions*)
+ (db.delete "system.js" (kv "_id" (string-downcase ',name)))))
+
+(ps:defpsmacro for-each (collection fun)
+ "for-each is a parenscript macro which will map fun over every item in the mongodb collection."
+ `( (slot-value ((slot-value ,collection 'find)) 'for-each) #',fun))
+
+(ps:defpsmacro transform (collection fun)
+ "for-each is a parenscript macro which will map fun over every item in the mongodb collection.
+ It will then save the item."
+ `( (slot-value ((slot-value ,collection 'find)) 'for-each)
+ (lambda (obj)
+ (,fun obj)
+ ((slot-value ,collection 'save) obj))))
+
+
+
+
View
@@ -99,6 +99,7 @@
(defmacro $size (&rest args)
`($op "$size" ,@args))
+
(defun empty-str(str)
(if (and str (zerop (length str)))
(format nil "\"\"")
@@ -120,38 +121,11 @@
(defmacro $where (&rest args)
`(kv "$where" ,@args))
-#|
-
-($index "foo" "field" :unique :asc)
-($index+ "foo" ("field1" :unique :asc) ("field2") )
-($index+ "foo" ("field1" :unique :asc :dropDups ) ("field2") )
-($index- "foo" *)
-($index- "foo" *)
-
-|#
-;(set-keys (list :asc :desc :drop-dups))
(defmacro set-keys (&rest args)
`(cond ( (null ,@args) nil)
( t (reduce (lambda (u v) (append u v)) (mapcar (lambda (x) (list x t)) ,@args)))))
-;($index "foo" :unique :drop-duplicates :asc ("k" "l") :desc ("m" "n") )
-;($index "foo" :asc "k" )
-;($index "foo" :rm ....)
-;($index "foo" :show)
-
-
-; `(destructuring-bind (f1 f1 &key asc desc) (unwrap ($exp+ ,@args) )
-; (format t "~A ~A ~A ~A" f1 f2 asc desc)))
-;($index* "foo" "k" :desc)
-;($index* "foo" ("k" :desc) )
-;($index* "foo" "k" )
-
-;($index "foo" :unique :drop-duplicates :asc ("k" "l") :desc ("m" "n" "o"))
-
-;($index "foo" :drop :all)
-;($index "foo" :drop :asc "k")
-
(defun collect-args (lst &optional accum)
(cond ( (atom lst) (values (list lst) nil))
( (null lst) (values (nreverse accum) lst))
@@ -164,6 +138,8 @@
`(cond ( (consp ,args) (reduce (lambda (x y) (kv x y ) ) (mapcar (lambda (x) (kv x ,value) ) ,args)))
( t (kv ,args ,value))))
+
+
(defmacro $index (collection &rest args)
`(multiple-value-bind (spec fields) (collect-args (unwrap ($exp+ ,@args)))
(destructuring-bind (&key show rm all unique drop-duplicates asc desc) (append (set-keys spec) fields)
@@ -178,4 +154,67 @@
:unique unique :drop-duplicates drop-duplicates)))))))
-;;(db.find "foo" ($ ($ "$min" ($ "value-1" 600)) ($ "$max" ($ "value-1" 610)) ($ "query" ($ nil nil) )) )
+;;(db.find "foo" ($ ($ "$min" ($ "value-1" 600)) ($ "$max" ($ "value-1" 610)) ($ "query" ($ nil nil) )) )
+
+
+;(normalize-args (list :min '("k" 1) '("z" 89) :max '("l" 2) ))
+
+(defun normalize-args (lst &optional accum)
+ (cond ( (null lst) (nreverse accum))
+ ( (keywordp (car lst) ) (normalize-args (cddr lst)
+ (cons (list (cadr lst)) (cons (car lst) accum))))
+ (t (normalize-args (cdr lst) (cons (cons (car lst) (car accum) ) (cdr accum) )))))
+
+(defmacro construct-container-lst* (args)
+ `(reduce (lambda (x y) (kv x y ) ) (mapcar (lambda (x) (kv (car x) (cadr x))) ,args)))
+
+(defmacro $range (&rest args)
+ `(let ((lst ($exp+ ,@args)))
+ (destructuring-bind (&key min max) (normalize-args lst)
+ (let ((min-arg (when min (kv "$min" (construct-container-lst* min))))
+ (max-arg (when max (kv "$max" (construct-container-lst* max))))
+ (query (kv "query" (kv nil nil))))
+ (if min-arg
+ (kv query min-arg max-arg)
+ (kv query max-arg))))))
+
+(defmacro upd (op &rest args)
+ (cond ( (consp (car args) ) `(kv ,op (construct-container-lst* ($exp+ ,@args))))
+ ( t `(kv ,op (construct-container-lst* (list ($exp+ ,@args)))))))
+
+(defmacro $inc (&rest args)
+ `(upd "$inc" ,@args))
+
+(defmacro $set (&rest args)
+ `(upd "$set" ,@args))
+
+; ( $unset "k" "l")
+(defmacro $unset (&rest args)
+ `(kv "$unset" (construct-container* 1 (unwrap ($exp+ ,@args)))))
+
+(defmacro $push (&rest args)
+ `(upd "$push" ,@args))
+
+; `(kv "$push" (construct-container-lst* (list ($exp+ ,@args)))))
+
+(defmacro $push-all (&rest args)
+ `(upd "$pushAll" ,@args))
+
+(defmacro $add-to-set (&rest args)
+ `(upd "$addToSet" ,@args))
+
+(defmacro $pop-back (&rest args)
+ `(kv "$pop" (construct-container* 1 (unwrap ($exp+ ,@args)))))
+
+(defmacro $pop-front (&rest args)
+ `(kv "$pop" (construct-container* -1 (unwrap ($exp+ ,@args)))))
+
+(defmacro $pull (&rest args)
+ `(upd "$pull" ,@args))
+
+(defmacro $pull-all (&rest args)
+ `(upd "$pullAll" ,@args))
+
+(defmacro $where (&rest args)
+ `(kv "$where" ,@args))
+
Oops, something went wrong.

0 comments on commit c30fc5f

Please sign in to comment.