DODB: correct typing for all functions.

README.md

@@ -6,6 +6,12 @@ When storing simple files directly on the file-system is enough.
 
 This project is a work in progress.
 
+# Constraints (WIP)
+
+TODO:
+- parallelism: run dodb on several threads (solved by a locking system)
+- fs data integrity: in case of a crash, dodb won't corrupt data on disk (solved by a temp file on the same filesystem, then a simple mv)
+
 # Crystal version
 
 Follow [this link for the Crystal version of DODB][dodbcr].

TODO.md

@@ -0,0 +1,10 @@
+- Warning when indexes overlap (data add or update)
+- Data integrity on update (create temporary file with new data, rename old data file, move temporary file, remove old data file)
+- Handle errors (such as permissions) in an explicit way
+- Grooming (create a consistent and convenient API, comments)
+- Improve data search
+- Check for TODOs
+- Check types.
+- Switch to CBOR format.
+- Verify uniqueness before adding data.
+- Allow indexes to be NIL.

dodb.asd

@@ -0,0 +1,22 @@
+(defsystem "dodb"
+  :version "0.1.0"
+  :author "Philippe PITTOLI"
+  :license "ISC"
+  :depends-on ("osicat")
+  :components ((:module "src"
+                :components
+                ((:file "util")
+                 (:file "main"))))
+  :description "When storing simple files directly on the file-system is enough."
+  :in-order-to ((test-op (test-op "dodb/tests"))))
+
+(defsystem "dodb/tests"
+  :author "Philippe PITTOLI"
+  :license "ISC"
+  :depends-on ("dodb"
+               "rove")
+  :components ((:module "tests"
+                :components
+                ((:file "main"))))
+  :description "Test system for dodb"
+  :perform (test-op (op c) (symbol-call :rove :run c)))

src/main.lisp

@@ -0,0 +1,368 @@
+(declaim (optimize (speed 3) (safety 3)))
+(defpackage :dodb
+  (:use :common-lisp :util :osicat)
+  ; TODO
+  (:export
+     :db/new           ; new database
+     :db/new-index     ; symlinks based on an unique ID
+     :db/new-partition ; symlinks based on a shared ID
+     :db/add           ; add a new value in the DB
+     :db/update        ; update a value in the DB
+     :db/del           ; del a value from the DB
+     :db/get-by-index     ;
+     :db/get-by-partition ;
+     :db/drop-everything  ;
+     :db-data             ;
+    ))
+(in-package dodb)
+
+(declaim (ftype (function (pathname) integer) filename->integer))
+(declaim (inline filename->integer))
+(defun filename->integer (filename)
+  (declare (type pathname filename))
+  (parse-integer (pathname-name filename))) ; pathname-name returns the basename
+
+(declaim (ftype (function (string) string) to-upper-case))
+(declaim (inline to-upper-case))
+(defun to-upper-case (some-string)
+  (declare (type string some-string))
+  (format nil "~@:(~a~)" some-string))
+
+; Example: 18 -> 000000000000018
+(declaim (ftype (function (integer) string) number->filename))
+(declaim (inline number->filename))
+(defun number->filename (number)
+  (declare (type integer number))
+  (format nil "~15,'0D" number))
+
+(declaim (ftype (function (character) boolean) is-forbidden-character-p))
+(declaim (inline is-forbidden-character-p))
+(defun is-forbidden-character-p (some-char)
+  (declare (type character some-char))
+  (member some-char (list #\/ #\\)))
+
+(declaim (ftype (function (string) string) protect-file-system))
+(declaim (inline protect-file-system))
+(defun protect-file-system (value)
+  (declare (type string value))
+  (substitute-if #\_ #'is-forbidden-character-p value))
+
+(declaim (ftype (function (atom) string) value->safe-string))
+(defun value->safe-string (value)
+  (protect-file-system (typecase value
+            (string value)
+            (symbol (symbol-name value))
+            (t      (format nil "~A" value)))))
+
+; index = 1-1
+; partition = 1-n
+(defstruct db
+  path                           ; Path
+  (indexes    (make-hash-table)) ; {String => #'FUNCTION-NAME}
+  (partitions (make-hash-table)) ; {String => #'FUNCTION-NAME}
+  (current-index 0)              ; Int
+  (data (make-hash-table)))      ; {Int -> struct}
+
+; db/new ensures directory '<path>/data/' exist,
+; then loads values from existing files, if any, and puts them into db-data.
+(declaim (ftype (function (string) db) db/new))
+(defun db/new (path)
+  (declare (type string path))
+  (let ((data          (make-hash-table))
+        (data-dir-path (concatenate 'string path "/data/"))
+        (current-index 0))
+
+    (ensure-directories-exist data-dir-path)
+
+    (loop for filename in (osicat:list-directory data-dir-path)
+          do (let ((id    (filename->integer          filename))
+                   (value (util:read-object-from-file filename)))
+               (if (> id current-index)
+                 (setf current-index id))
+               (setf (gethash id data) value)))
+
+    (make-db
+      :path path
+      :data data
+      :current-index current-index)))
+
+; Example: returns "./storage/cars/indexes/by_name/".
+(declaim (ftype (function (string string) string) db/index/get-directory-path))
+(declaim (inline db/index/get-directory-pathispatch))
+(defun db/index/get-directory-path (dbpath index-name)
+  (declare (type string dbpath index-name))
+  (concatenate 'string dbpath "/indexes/by_" index-name "/"))
+
+; Example: returns "./storage/cars/partitions/by_color/Red/".
+(declaim (ftype (function (string string string) string) db/partition/get-directory-path))
+(defun db/partition/get-directory-path (dbpath name object-attribute)
+  (declare (type string dbpath name object-attribute))
+  (concatenate 'string dbpath "/partitions/by_" name "/" object-attribute "/"))
+
+; Example: "./storage/cars/" "name" #'vehicle-name object -> "./storage/cars/indexes/by_name/Corvet".
+(declaim (ftype (function (string string function atom) string) db/index/get-symlink-path))
+(defun db/index/get-symlink-path (dbpath index-name fsymbol object)
+  (declare (type string dbpath index-name))
+  (declare (type function fsymbol))
+  (let* ((value            (funcall fsymbol object))
+         (symlink-basename (value->safe-string value)))
+    (concatenate 'string
+      (db/index/get-directory-path dbpath index-name)
+      symlink-basename)))
+
+; Example: "./storage/cars/" "name" #'vehicle-name object "0000000015"
+;   -> (osicat:make-link "./storage/cars/indexes/by_name/Corvet"
+;          :target "../../data/0000000015"
+;          :hard nil)
+(declaim (ftype (function (string string function atom string) null) db/index/new))
+(defun db/index/new (dbpath index-name fsymbol object file-name)
+  (declare (type string dbpath index-name file-name))
+  (declare (type function fsymbol))
+  (let ((symlink-path (db/index/get-symlink-path dbpath index-name fsymbol object)))
+    (declare (type string symlink-path))
+
+    ; works even when the database directory is moved
+    (osicat:make-link symlink-path
+      :target (concatenate 'string "../../data/" file-name)
+      :hard nil))
+  (values nil))
+
+(declaim (ftype (function (string string function atom) null) db/index/del))
+(defun db/index/del (dbpath index-name fsymbol object)
+  (declare (type string dbpath index-name))
+  (declare (type function fsymbol))
+  (delete-file (db/index/get-symlink-path dbpath index-name fsymbol object))
+  (values nil))
+
+; Example: "./storage/cars/" "color" #'vehicle-color object "0000000015".
+;   -> "./storage/cars/partitions/by_color/Red/0000000015".
+(declaim (ftype (function (string string function atom string) string) db/partition/get-symlink-path))
+(defun db/partition/get-symlink-path (dbpath partition-name fsymbol object file-name)
+  (declare (type string dbpath partition-name file-name))
+  (declare (type function fsymbol))
+  (let* ((object-attribute (funcall fsymbol object))
+         (safe-value (value->safe-string object-attribute))
+         ; example: "./storage/cars/partitions/by_color/Red/"
+         (dirpath    (db/partition/get-directory-path dbpath partition-name safe-value)))
+  (concatenate 'string dirpath file-name)))
+
+; Example: "./storage/cars/" "color" #'vehicle-color object "0000000015"
+;   -> (osicat:make-link "./storage/cars/partitions/by_color/Red/0000000015"
+;          :target "../../../data/0000000015"
+;          :hard nil)
+(declaim (ftype (function (string string function atom string) null) db/partition/new))
+(defun db/partition/new (dbpath partition-name fsymbol object file-name)
+  (declare (type string dbpath partition-name file-name))
+  (declare (type function fsymbol))
+  (let ((symlink-path
+      (db/partition/get-symlink-path dbpath partition-name fsymbol object file-name)))
+
+    (ensure-directories-exist symlink-path)
+
+    ; works even when the database directory is moved
+    (osicat:make-link symlink-path
+      :target (concatenate 'string "../../../data/" file-name)
+      :hard nil))
+  (values nil))
+
+(declaim (ftype (function (string string function atom string) null) db/partition/del))
+(defun db/partition/del (dbpath partition-name fsymbol object file-basename)
+  (declare (type string dbpath partition-name file-basename))
+  (declare (type function fsymbol))
+  (delete-file (db/partition/get-symlink-path dbpath partition-name fsymbol object file-basename))
+  (values nil))
+
+(declaim (ftype (function (db string function) null) db/new-index))
+(defun db/new-index (database index-name fsymbol)
+  (declare (type db database))
+  (declare (type string index-name))
+  (declare (type function fsymbol))
+  (let ((dbpath (db-path database))
+        (index-name (value->safe-string index-name)))
+    ; create a directory for the indexes
+    (ensure-directories-exist
+      (concatenate 'string dbpath "/indexes/by_" index-name "/"))
+  
+    ; add this new index to the list
+    (setf (gethash index-name (db-indexes database)) fsymbol)
+  
+    ; generate index for all DB elements
+    (maphash #'(lambda (number object)
+        (handler-case (db/index/new dbpath index-name fsymbol object (number->filename number))
+          (OSICAT-POSIX:EEXIST ()
+            (format t "dodb:db/new-index: symlink already exists, ignoring.~&"))))
+      (db-data database)))
+  (values nil))
+
+(declaim (ftype (function (string string function atom string atom) null) db/partition/update))
+(defun db/partition/update (dbpath partition-name fsymbol object file-name old-object)
+  (declare (type string dbpath partition-name file-name))
+  (declare (type function fsymbol))
+  (let ((new-value (funcall fsymbol object))
+        (old-value (funcall fsymbol old-object)))
+    (if (not (equal new-value old-value))
+      (progn
+        ; delete old partition
+        (db/partition/del dbpath partition-name fsymbol old-object file-name)
+        ; create new partition
+        (db/partition/new dbpath partition-name fsymbol     object file-name)))))
+
+(declaim (ftype (function (db string function) null) db/new-partition))
+(defun db/new-partition (database partition-name fsymbol)
+  (declare (type db database))
+  (declare (type string partition-name))
+  (declare (type function fsymbol))
+  (let ((dbpath         (db-path database))
+        (partition-name (value->safe-string partition-name)))
+    ; create a directory for the partitions
+    (ensure-directories-exist
+      (concatenate 'string dbpath "/partitions/by_" partition-name "/"))
+
+    ; add this new partition to the list
+    (setf (gethash partition-name (db-partitions database)) fsymbol)
+
+    ; generate partition for all DB elements
+    (maphash #'(lambda (number object)
+        (handler-case (db/partition/new dbpath partition-name fsymbol object (number->filename number))
+          (OSICAT-POSIX:EEXIST ()
+            (format t "dodb:db/new-partition: symlink already exists, ignoring.~&"))))
+      (db-data database)))
+    (values nil))
+
+; Example: "./storage/cars/data/000000000000018".
+(declaim (ftype (function (string string) string) get-filepath))
+(defun get-filepath (dbpath file-name)
+  (declare (type string dbpath file-name))
+  (concatenate 'string dbpath "/data/" file-name))
+
+(declaim (ftype (function (db atom) integer) db/add))
+(defun db/add (database object)
+  (declare (type db database))
+  (incf (db-current-index database))
+  (let* ((file-basename     (number->filename (db-current-index database)))
+         (dbpath            (db-path database))
+         (tmp-file-basename (concatenate 'string file-basename "_tmp"))
+         (tmp-file-path     (get-filepath dbpath tmp-file-basename)))
+
+    ; write object to temporary file
+    (util:write-object-to-file object tmp-file-path)
+
+    ; rename the temporary file
+    (rename-file tmp-file-path file-basename)
+
+    ; generate indexes
+    (maphash #'(lambda (index-name fsymbol)
+        (db/index/new dbpath index-name fsymbol object file-basename))
+      (db-indexes database))
+
+    ; generate partitions
+    (maphash #'(lambda (partition-name fsymbol)
+        (db/partition/new dbpath partition-name fsymbol object file-basename))
+      (db-partitions database)))
+
+  ; store new in-memory data
+  ; database.data[database.current-index] = object
+  (setf (gethash (db-current-index database) (db-data database)) object)
+  (db-current-index database))
+
+(declaim (ftype (function (db integer) null) db/del))
+(defun db/del (database object-index)
+  (declare (type db database))
+  (declare (type integer object-index))
+  (let ((file-basename (number->filename object-index))
+        (dbpath        (db-path database))
+        (object        (gethash object-index (db-data database))))
+    ; remove data file
+    (delete-file (get-filepath dbpath file-basename))
+
+    ; handle indexes
+    (maphash #'(lambda (index-name fsymbol)
+        (db/index/del dbpath index-name fsymbol object))
+      (db-indexes database))
+
+    ; handle partitions
+    (maphash #'(lambda (partition-name fsymbol)
+        (db/partition/del dbpath partition-name fsymbol object file-basename))
+      (db-partitions database))
+
+    ; remove in-memory data
+    (remhash object-index (db-data database)))
+  (values nil))
+
+; Search for the data from the FS.
+(declaim (ftype (function (db string atom) integer) db/get-by-index))
+(defun db/get-by-index (database index-name attribute-value)
+  (declare (type db database))
+  (declare (type string index-name))
+  (let ((value (value->safe-string attribute-value)))
+    (filename->integer
+      (osicat:read-link
+        (concatenate 'string
+          (db/index/get-directory-path (db-path database) index-name) "/" value)))))
+
+; Search for the data from the FS.
+(declaim (ftype (function (db string atom) cons) db/get-by-partition))
+(defun db/get-by-partition (database name attribute-value)
+  (declare (type db database))
+  (declare (type string name))
+  (let ((value (value->safe-string attribute-value))
+        (dbpath (db-path database)))
+    (loop for filename in (osicat:list-directory (db/partition/get-directory-path dbpath name value))
+          collect (filename->integer filename))))
+
+(declaim (ftype (function (string string function atom string atom) null) db/index/update))
+(defun db/index/update (dbpath index-name fsymbol object file-name old-object)
+  (declare (type string dbpath index-name file-name))
+  (declare (type function fsymbol))
+  (let ((new-value    (funcall fsymbol object))
+        (old-value    (funcall fsymbol old-object))
+        (symlink-path (db/index/get-symlink-path dbpath index-name fsymbol object)))
+    (if (not (equal new-value old-value))
+        ; display a message in case the new index is already used by another object
+        (if (probe-file symlink-path)
+          (format t "dodb:db/index/update: the value ~a is already used by another object.~&" new-value)
+          (progn
+            ; delete old index
+            (db/index/del dbpath index-name fsymbol old-object)
+            ; create new index
+            (db/index/new dbpath index-name fsymbol object file-name))))))
+
+; TODO: check database integrity (redundancy)
+; TODO: locking
+(declaim (ftype (function (db integer) null) db/update))
+(defun db/update (database object-index)
+  (declare (type db database))
+  (declare (type integer object-index))
+  (let* ((object            (gethash object-index (db-data database)))
+         (dbpath            (db-path database))
+         (file-basename     (number->filename object-index))
+         (file-path         (get-filepath dbpath file-basename))
+         (old-object        (util:read-object-from-file file-path))
+         (tmp-file-basename (concatenate 'string file-basename "_tmp"))
+         (tmp-file-path     (get-filepath dbpath tmp-file-basename)))
+
+    ; write object to temporary file
+    (util:write-object-to-file object tmp-file-path)
+
+    (delete-file file-path)
+
+    ; rename the temporary file
+    (rename-file tmp-file-path file-basename)
+
+    ; handle indexes
+    (maphash #'(lambda (index-name fsymbol)
+        (db/index/update dbpath index-name fsymbol object file-basename old-object))
+      (db-indexes database))
+
+    ; handle partitions
+    (maphash #'(lambda (partition-name fsymbol)
+        (db/partition/update dbpath partition-name fsymbol object file-basename old-object))
+      (db-partitions database)))
+  (values nil))
+
+(declaim (ftype (function (db) null) db/drop-everything))
+(defun db/drop-everything (database)
+  (declare (type db database))
+  (osicat:delete-directory-and-files (db-path database))
+  (clrhash (db-data database))
+  (values nil))

src/scenario.lisp

@@ -0,0 +1,32 @@
+(defpackage :dodb-scenario
+  (:use :common-lisp :dodb))
+(in-package dodb-scenario)
+
+(defstruct vehicle name color (nb-of-lights 4))
+
+(defparameter cars (dodb:db/new "/tmp/storage/cars/"))
+
+(dodb:db/add cars (make-vehicle :name "Corvet"       :color "Red"))
+(dodb:db/add cars (make-vehicle :name "Ferrari"      :color "Red"))
+(dodb:db/add cars (make-vehicle :name "Deudeuch"     :color "Beige"))
+(dodb:db/add cars (make-vehicle :name "BMW"          :color "Blue"))
+(dodb:db/add cars (make-vehicle :name "Suzuki Wagon" :color "Blue"    :nb-of-lights 6))
+
+(dodb:db/new-index     cars "name"         #'vehicle-name)
+(dodb:db/new-partition cars "color"        #'vehicle-color)
+(dodb:db/new-partition cars "nb-of-lights" #'vehicle-nb-of-lights)
+
+(dodb:db/new-partition cars "\ot//her\\par/tit" #'vehicle-color)
+(dodb:db/new-index cars "\ot//her\\i/name/r" #'vehicle-name)
+
+(format t "~&~S~&" cars)
+
+(format t "db/get-by-index ~S~&" (dodb:db/get-by-index cars "name" "Corvet"))
+
+(format t "db/get-by-partition red cars:~&")
+(loop for car in (dodb:db/get-by-partition cars "color" "Red")
+      do (format t "- ~S~&" car))
+
+(let ((suzuki (dodb:db/get-by-index cars "name" "Suzuki Wagon")))
+  (setf (vehicle-color (gethash suzuki (dodb:db-data cars))) "White")
+  (dodb:db/update cars suzuki))

src/util.lisp

@@ -0,0 +1,26 @@
+(defpackage :util
+  (:use :common-lisp)
+  (:nicknames :ut)
+  (:export :write-object-to-file
+           :read-file
+           :read-object-from-file))
+(in-package util)
+
+(defun read-file (infile)
+  (with-open-file (instream infile
+                            :direction :input
+                            :if-does-not-exist nil)
+    (when instream 
+      (let ((string (make-string (file-length instream))))
+        (read-sequence string instream)
+          string))))
+
+(defun read-object-from-file (infile)
+  (read-from-string (read-file infile)))
+
+(defun write-object-to-file (object outfile)
+  (with-open-file (my-file outfile
+                           :direction :output
+                           :if-exists :supersede
+                           :if-does-not-exist :create)
+      (format my-file "~&~S~&" object)))

tests/main.lisp

@@ -0,0 +1,11 @@
+(defpackage dodb/tests/main
+  (:use :cl
+        :dodb
+        :rove))
+(in-package :dodb/tests/main)
+
+;; NOTE: To run this test file, execute `(asdf:test-system :dodb)' in your Lisp.
+
+(deftest test-target-1
+  (testing "should (= 1 1) to be true"
+    (ok (= 1 1))))