;; FileDataBase: fdb
;; a package implementing a VERY simple database (basically a "file")
;; but with enough multi-user capabilities to be used from W3 servers
;; with bulletproof concurrent access locking
;; principle is that an access can set a lock on a single record for updating
;; this record later on, e.g. by another CGI call from a www browser
;;
;; A database fdb:Base has its records organized as a vector of Structures
;; (of the package defstruct.kl), with the first fields of these records being 
;; there for bookeeping purposes (names prefixed by >), the rest being the 
;; user fields
;;
;; You must define the record type by a fdb:defstruct just like a defstruct
;; (fdb:defstruct calls defstruct but prepends the internal fdb fields)
;;
;; WARNING: This is version 2 of this package, incompatible with bases made 
;; with v1, see scripts/filedatabase-upgrade to upgrade databases
;;
;; There are 2 lock mecanisms: on the database file itself, so that only one
;; process can read or write the file at the same time. This lock is really
;; transient as these operations are very fast. Then there is a logical lock
;; on each record independantly for reading / modifying / saving a record
;; offline by concurrent processes in different sessions. There is no timeouts
;; on logical locks

(require 'defstruct)
(setq *package* "fdb")

(defvar fdb:timeout 30)			;timeout for file locking, seconds

;;a database is a structure filling the memory
;;It is stored as a (setq fdb::base ...TheDatabase...) in a file
;;dates are strings YYYYMMDDHHMMSSD

(defstruct %Base			;the whole base in memory
  filename				;name of the file
  next-id				;next free record id
  plist					;user-defined plist, comments, help...
  record-type				;structure of records
  records				;vector of records
)

(defstruct %Record
  >id					;unique ID (alphanum string)
  >deleted?				;if true, this is garbage
  >locked?				;() or owner of lock (string)
  >lock-date				;if locked, date where lock created
  >creation-date			;of the record
  >modification-date			;of the record
)					; rest of user records follows
;; signature for identification
(setq %:reclen (length %Record))
(setq %:rechead (subseq %Record 2))

;;AUTOLOAD: fdb:defstruct
;;AUTODOC: fdb:defstruct "defines the structure of record of a filedatabase"
;; (fdb:defstruct struct-name fields...)
;;
;; Works exactly like defstruct, but prepends internal fields for fdb use
;;
;;SEE_ALSO: defstruct fdb:create

(defmacro fdb:defstruct (struct-name &rest fields)
  `(defstruct ,struct-name ,@%:rechead ,@fields)
)

;;AUTOLOAD: fdb:open
;;AUTODOC: fdb:open "open a simple database"
;; (fdb:open filename)
;;
;; locks the file, loads the base in memory and returns it, unlocks
;; records is a vector of p-vectors and is get by (fdb:Base-records base)
;; fields in records can  be organized as you want. recommended use as a p-list
;; of names and values, name being a keyword (but can be a symbol or string, 
;; but not a number
;; Base must exist and is returned, if not () is returned.
;; 

(defun fdb:open (filename &key (timeout fdb:timeout))
  (file-lock filename :file t :time timeout :timeout timeout)
  (unwind-protect 
    (if (not (trap-error 'Errors:ErrorCannotLoadFile (fdb::load filename) t))
      (setq fdb::base ())		;no file? return ()
    )
    (file-unlock filename :file t)
  )
  fdb::base
)

(defun fdb::load (filename)
  (load filename)
  (with (record-type (%Base-record-type fdb::base))
    (if (and (boundp (1 record-type)) (structp (eval (1 record-type)))) ()
      (apply defstruct (subseq record-type 1))
)))

;;AUTOLOAD: fdb:create
;;AUTODOC: fdb:create "create a simple database"
;; (fdb:create filename record-type &key plist)
;;
;; creates and returns a base, erasing any existing one in filename.
;; fdb bases are simple databses held in files, not efficient for big amount
;; of data (file is entirely loaded and written back on each primitive), but
;; extremely robust for random concurrent access like via CGI scripts
;;
;; record-type must be one defined by fdb:defstruct
;;
;; WARNING! If you move the database file, you must update it by 
;; fdb:update-filename or it wont work anymore!

(defun fdb:create (filename record-type &key (plist (vector)))
  (if (/= (subseq record-type 2 %:reclen) %:rechead) ;check hidden fields
    (error "record-type must be made by fdb:defstruct!")
  )
  (file-lock filename :file t :time fdb:timeout :timeout fdb:timeout)
  (unwind-protect (progn
      (setq fdb::base (make-fdb:Base	;no file? init a new one
	  :filename filename
	  :next-id "a"
	  :plist plist
	  :record-type record-type
	  :records (vector)
      ))
      (fdb::write-base filename fdb::base)
    )
    (file-unlock filename :file t)
  )
  fdb::base
)

;;AUTOLOAD: fdb:update-filename
;;AUTODOC: fdb:update-filename "update a database after a file move"
;; (fdb:update-filename filename)
;;
;; fdb:update-filename *MUST* be called on the new filename once moved there
;; or the base cannot be accessed anymore!
;; e.g:
;; (sh mv base1 base2)
;; (fdb:update-filename base2)

(defun fdb:update-filename (filename &aux base)
  (setq base (fdb:open filename))
  (%Base-filename base filename)
  (fdb::write-base filename base)
)

;;AUTOLOAD: fdb:edit-record
;;AUTODOC: fdb:edit-record "lock a record for editing"
;; (fdb:edit-record base record &key index owner timeout)
;;
;; Locks the record so that other processes cannot modify the record
;; The record can then be edited in memory, and saved by fdb:save-record
;; Returns the record or a string describing who locked the record
;; WARNING: the record returned will be differnt from the one passed as
;; argument, you must use the return value!
;; if record could not be edited, or () if record was deleted!
;; record can be record id or the record

(defun fdb:edit-record (base record &key index force (timeout fdb:timeout)
    (owner (+ "pid:" (String *current-process-id*) "@" *hostname*))
    &aux
    (id (if (typep record String) record 
	(typep record Vector) (%Record->id record)
    ))
    rec
    (filename (%Base-filename base))
    d
  )
  (file-lock filename :file t :time timeout :timeout timeout)
  (unwind-protect (progn
      (fdb::load filename)
      (replace-list base fdb::base)	;physically update base in mem
      (if (not (and index (setq rec (getn (%Base-records fdb::base) index))
	    (= (%Record->id rec) id)
	))
	(setq rec (%find-record-by-id fdb::base id))
      )
      (if rec 
	(if (and (not force) (%Record->locked? rec)) ;argh, already locked!
	  (setq rec (+ "Locked by " (%Record->locked? rec) " at " 
	      (fdb:fdbdate-to-print (%Record->lock-date rec))
	  ))
	  (progn			;ok, establish lock, and write back
	    (%Record->locked? rec owner)
	    (%Record->lock-date rec (fdb:date-to-fdbdate (cur-date)))
	    (fdb::write-base filename fdb::base)
	))
	(setq rec ())			;record was deleted
    ))
    (file-unlock (%Base-filename base) :file t)
  )
  rec
)

;;AUTOLOAD: fdb:add-record
;;AUTODOC: fdb:add-record "creates a new record in a fdb database"
;; (fdb:add-record base &key index owner timeout)
;;
;; Creates, adds in base, and retunrs a new record withs its user fields set 
;; to ().
;; Locks the record so that other processes cannot modify the record
;; The record can then be edited in memory, and saved by fdb:save-record
;; index can specify at which position the record will be inserted in base
;; (default = appended to end, 0 = inserted at start)

(defun fdb:add-record (base &key index (timeout fdb:timeout)
    (owner (+ "pid:" (String *current-process-id*) "@" *hostname*))
    &aux
    rec
    (filename (%Base-filename base))
    d
  )
  (if (not (typep index Int)) (setq index -1))
  (file-lock filename :file t :time timeout :timeout timeout)
  (unwind-protect (progn
      (fdb::load filename)
      (replace-list base fdb::base)	;physically update base in mem
      ;;avoid making nil records
      (if (> index (length (%Base-records fdb::base))) (setq index -1))
      (insert (%Base-records fdb::base) index
	(setq rec (apply (eval (intern (+ "make-" 
		  (1 (%Base-record-type fdb::base))
	    )))
	    (list
	      :>id (%Base-next-id fdb::base)
	      :>locked? owner
	      :>lock-date (setq d (fdb:date-to-fdbdate (cur-date)))
	      :>creation-date d
	      :>modification-date d
      ))))
      (%Base-next-id fdb::base 
	(fdb:record-id-increment (%Base-next-id fdb::base))
      )
      (fdb::write-base filename fdb::base)
    )
    (file-unlock (%Base-filename base) :file t)
  )
  rec
)

;;AUTOLOAD: fdb:write-base
;;AUTODOC: fdb:write-base "writes a database to a file"
;;(fdb:write-base new-filename base)
;;
;;As the filename where the base resides is stored into the base structure, to
;;move a base you must use this primitive which sets the filename in the base
;;For instance, to update a base moved in shell:
;;    (sh mv file1 file2)
;;    (write-base file2 (fdb:open file2))

(defun fdb:write-base (filename base)
  (%Base-filename base filename)
  (fdb::write-base filename base)
)

(defun fdb::write-base (filename base &aux
    (fd (open (+ filename ".new") :direction :output :if-exists :supersede))
  )
  (print-format fd "(setq fdb::base %r0)\n" base)
  (close fd)
  (if (/= 0 (wait (system (list "mv" (+ filename ".new") filename))))
    (error 'Errors:WriteToFile filename)
  )
)

(defvar Errors:WriteToFile "Cannot write to file %0")

;;AUTOLOAD: fdb:save-record
;;AUTODOC: fdb:save-record "save and unlock an edited record"
;; (fdb:save-record base record &key force)
;;
;; Save a record edited by a previous edit-record 
;; Return () on success or a string describing who locked the record if the 
;; lock has been reset previously, or the string "record deleted" if the
;; record was actually deleted in the meantime.
;; :force t bypasses this check
;; If the record has :>deleted? t, it actually deletes it

(defun fdb:save-record (base record &key index force &aux
    rec
    (filename (%Base-filename base))
    result
  )
  (if (or (not (%Record->locked? record)) (not (%Record->lock-date record)))
    (error "Trying to do a fdb:save-record without fdb:edit-record first")
  )
  (file-lock filename :file t :time fdb:timeout :timeout fdb:timeout)
  (unwind-protect (progn
      (fdb::load filename)
      (if (not (and index (setq rec (getn (%Base-records fdb::base) index))
	    (= (%Record->id rec) (%Record->id record))
	))
	(progn 
	  (if (setq index (fdb:find-index-by-id  fdb::base 
		(%Record->id record)))
	    (setq rec (getn (%Base-records fdb::base) index))
	    (setq index -1)
      )))
      (if (and (not force) rec)
	(if (and (not force) 
	    (or (/= (%Record->locked? rec) (%Record->locked? record))
	      (/= (%Record->lock-date rec) (%Record->lock-date record))
	      ))			;argh, lock reset by somebody!
	  (setq result (+ "Locked by " (%Record->locked? rec) " at " 
	      (fdb:fdbdate-to-print (%Record->lock-date rec))
	  ))
	  ;; ok, put record in base and write
	  (if (%Record->deleted? record) 
	    (if (/= -1 index) (progn	;actually, deletes it
		(delete (%Base-records fdb::base) index)
		(fdb::write-base filename fdb::base)
	    ))
	    (progn			;still there?, save
	      (%Record->locked? record ())
	      (%Record->lock-date record ())
	      (put (%Base-records fdb::base) index record)
	      (fdb::write-base filename fdb::base)
	)))
	(setq result "record deleted") ;record was deleted
      )
      (replace-list base fdb::base)	;physically update base in mem
    )
    (file-unlock (%Base-filename base) :file t)
  )
  result
)

;;AUTOLOAD: fdb:delete-record
;;AUTODOC: fdb:delete-record "delete a record"
;;return string if locked, () if deleted with success

(defun fdb:delete-record (base record &key index force &aux
    rec
  )
  (setq rec (fdb:edit-record base record :index index :force force))
  (if (typep rec Vector) (progn
      (%Record->deleted? rec t)
      (setq rec (fdb:save-record base rec :index index :force force))
  ))
  rec
)

;;AUTOLOAD: fdb:cancel-edit-record
;;AUTODOC: fdb:cancel-edit-record "cancel edition of a record, breaks lock"
;;(fdb:cancel-edit-record base record &key index force)
;;
;;Return the stored definition of record (or nil if it was deleted)

(defun fdb:cancel-edit-record (base record &key index force &aux
    rec
    (id (if (typep record String) record 
	(typep record Vector) (%Record->id record)
    ))
    (filename (%Base-filename base))
  )
  (file-lock filename :file t :time fdb:timeout :timeout fdb:timeout)
  (unwind-protect (progn
      (fdb::load filename)
      (if (not (and index (setq rec (getn (%Base-records fdb::base) index))
	    (= (%Record->id rec) (%Record->id record))
	))
	(progn 
	  (if (setq index (fdb:find-index-by-id  fdb::base 
		(%Record->id record)))
	    (setq rec (getn (%Base-records fdb::base) index))
	    (setq index -1)
      )))
      (if (and rec (or (%Record->locked? rec) (%Record->lock-date rec)))
	(progn			;ok, put record in base and write
	  (%Record->locked? rec ())
	  (%Record->lock-date rec ())
	  (fdb::write-base filename fdb::base)
	  (replace-list base fdb::base)	;physically update base in mem
    )))    
    (file-unlock (%Base-filename base) :file t)
  )
  rec
)

;;AUTOLOAD: fdb:print
;;AUTODOC: fdb:print
;; (fdb:print base &optional fd)
;;
;; pretty-prints the base in a human-readable format

(defun fdb:print (base  &optional (fd *standard-output*) &aux
    (slotnames (subseq (%Base-record-type base) 2))
    value
  )
  (PF fd "filedatabase: %0\n" (%Base-filename base))
  (if (%Base-plist base) (PF fd "plist:  %0\n" (%Base-plist base)))
  (dolist (rec (%Base-records base))
    (if (not (%Record->deleted? rec)) (progn
	(PF fd "  ID: %r0, date: %n1\n" (%Record->id rec) 
	  (fdb:fdbdate-to-print (%Record->modification-date rec))
	)
	(if (%Record->locked? rec)
	  (PF fd "  Locked by %r0 on %n1\n" (%Record->locked? rec)
	    (fdb:fdbdate-to-print (%Record->lock-date rec))
	  )
	)
	(dolist (slot slotnames)
	  (setq value (getn rec slot))
	  (if (and (/= #\> (0 slot)) value (/= "" value) (/= 0 value))
	    (PF fd "    %0: %r1\n" slot value)
	))
  )))
  (flush fd)
)

;; fdb:base-pp
;; a more verbose format

(defun fdb:base-pp (base &aux header)
  (if (not (boundp 'fdb:BaseHeader))
    (defstruct fdb:BaseHeader filename next-id plist record-type)
  )
  (setq header (make-fdb:BaseHeader :filename (fdb:Base-filename base)
      :next-id (fdb:Base-next-id base) :plist (fdb:Base-plist  base)
      :record-type (fdb:Base-record-type base)
  ))
  (struct-pp header)
  (fdb:dolist (r base) (struct-pp r))
)


;;AUTOLOAD: fdb:dolist
;;AUTODOC: fdb:dolist "scans records of a simple database"
;; (fdb:dolist (variable database) forms...)

(defmacro fdb:dolist (variable-decls &rest forms &aux
  )
  `(dolist (,(get variable-decls 0) (%Base-records ,(get variable-decls 1)))
    ,@forms
  )
)

;; misc utils

(defun fdb:find-record-by-id (base id)
  (catch 'Found
    (dolist (rec (%Base-records base))
      (if (= (%Record->id rec) id)
	(throw 'Found rec)
    ))
    ()
  )
)

(defun fdb:find-index-by-id (base id &aux
    (index 0)
  )
  (catch 'Found
    (dolist (rec (%Base-records base))
      (if (= (%Record->id rec) id)
	(throw 'Found index)
      )
      (incf index)
    )
    ()
  )
)

;;dates are strings YYYYMMDDHHMMSSD, which can be sorted

(defun fdb:date-to-fdbdate (d)
  (+ (String (0 d))			;YYYY
    (String (expand-num (1 d) 2))	;MM
    (String (expand-num (2 d) 2))	;DD
    (String (expand-num (3 d) 2))	;HH
    (String (expand-num (4 d) 2))	;MM
    (String (expand-num (5 d) 2))	;SS
    (String (6 d))			;D (day of the week, 0=sunday)
))

(defun fdb:fdbdate-to-date (d)
  (vector
    (Int (subseq d 0 4))		;YYYY
    (Int (subseq d 4 6))		;MM
    (Int (subseq d 6 8))		;DD
    (Int (subseq d 8 10))		;HH
    (Int (subseq d 10 12))		;MM
    (Int (subseq d 14 16))		;SS
    (Int (subseq d 16 17))		;D
))

(defun fdb:fdbdate-to-print (d)
  (html:date (fdb:fdbdate-to-date d))
)
;; record-id arithmetics: base is a-z A-Z 0-9  (base 62)

(defun fdb:record-id-increment (id &aux
    (first-char (0 id))
  )
  (if 
    (= first-char #\z)
    (+ "A" (subseq id 1))
    (= first-char #\Z)
    (+ "0" (subseq id 1))
    (= first-char #\9)
    (+ "a" (if (1 id) (fdb:record-id-increment (subseq id 1)) "a"))
    ;;rest, increment
    (+ (String (list (+ 1 first-char))) (subseq id 1))
))
