Commits

Anonymous committed c157186

The beginnings of a basic Dropbox client

Currently we can read the metadata from from Dropbox and use it to keep our
local state up-to-date. We use the metadata to provide a directory listing
tool.

The metadata is persisted in an sqlite database.
The user needs to supply a database handle and the names of two tables.
The two tables must, at least, have the columns required to store the
Dropbox metadata. Additional columns may be present. In particular, extra
PRIMARY KEY fields may be present. This may be desirable in the case where
the user wants to use this client and a single database to access a number
of different dropbox accounts.
When the client accesses the tables, the queries can be scoped by providing
an alist of column names and their values in the 'table-scope' parameter.
This is intended to support the multi-account use case.

The following CREATE TABLE statements can be used as a guide as to the
schema for the two tables:

CREATE TABLE "dropbox_attrib" (
"referral_link" TEXT,
"display_name" TEXT,
"uid" TEXT,
"country" TEXT,
"quota_info/normal" INTEGER,
"quota_info/shared" INTEGER,
"quota_info/quota" INTEGER,
"email" TEXT,"cursor" TEXT,
"account-info-last-modified" INTEGER NOT NULL,
"account-info-last-complete" INTEGER,
"metadata-cache-last-modified" INTEGER,
"metadata-cache-last-complete" INTEGER,
"retry-after" INTEGER);

CREATE TABLE "dropbox_metadata_cache" (
"path-key" TEXT NOT NULL ,
"size" TEXT,
"bytes" INTEGER,
"path" TEXT NOT NULL,
"is_dir" INTEGER,
"is_deleted" INTEGER,
"rev" TEXT,
"hash" TEXT,
"thumb_exists" INTEGER,
"icon" TEXT,
"modified" INTEGER,
"client_mtime" INTEGER,
"mime_type" TEXT,
"root" TEXT NOT NULL,
"revision" INTEGER,
PRIMARY KEY ("path-key"));

Signed-off-by: Andy Bennett <andyjpb@knodium.com>

Comments (0)

Files changed (3)

  ; altogether. `depends' is an alias to `needs'.
  ; Notice that you should NOT put Chicken units (e.g., srfi-1, srfi-13
  ; and many others) in `needs' or in `depends'.
- (needs oauth intarweb uri-common medea rest-bind)
+ (needs oauth intarweb uri-common medea rest-bind ssql vector-lib sql-de-lite)
 
  ; A list of eggs required for TESTING ONLY.  See the `Tests' section.
  ; Just like `needs' and `depends', `test-depends' should NOT contain
  (test-depends test)
 
  (author "Andy Bennett <andyjpb@knodium.com>")
- (synopsis "Bindings to the Dropbox REST-like API."))
+ (synopsis "Bindings to the Dropbox REST-like API and a basic Dropbox client."))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; A basic Dropbox client
+;;;
+;;;  Copyright (C) 2012, Andy Bennett
+;;;  All rights reserved.
+;;;
+;;;  Redistribution and use in source and binary forms, with or without
+;;;  modification, are permitted provided that the following conditions are met:
+;;;
+;;;  Redistributions of source code must retain the above copyright notice, this
+;;;  list of conditions and the following disclaimer.
+;;;  Redistributions in binary form must reproduce the above copyright notice,
+;;;  this list of conditions and the following disclaimer in the documentation
+;;;  and/or other materials provided with the distribution.
+;;;  Neither the name of the author nor the names of its contributors may be
+;;;  used to endorse or promote products derived from this software without
+;;;  specific prior written permission.
+;;;
+;;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;;;  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;;;  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;;  ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE
+;;;  LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;;;  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;;;  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;;  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;;;  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;;;  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;;;  POSSIBILITY OF SUCH DAMAGE.
+;;;
+;;; Andy Bennett <andyjpb@knodium.com>, 2012/11/01 22:40
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(module dropbox
+	(make-dropbox-app
+	  db
+	  account-info-table
+	  metadata-cache-table
+	  table-scope
+	  db-state-change-callback
+	  update-local-state!
+	  add-account-info!
+	  ls
+	  )
+
+(import chicken scheme)
+
+; Units - http://api.call-cc.org/doc/chicken/language
+(use data-structures posix srfi-1 files srfi-13)
+
+; Eggs - http://wiki.call-cc.org/chicken-projects/egg-index-4.html
+(use dropbox-lolevel ssql vector-lib sql-de-lite)
+
+
+(define table-scope (make-parameter '()))
+(define db (make-parameter #f))
+(define account-info-table   (make-parameter #f))
+(define metadata-cache-table (make-parameter #f))
+(define db-state-change-callback (make-parameter #f))
+
+
+; https://www.dropbox.com/developers/reference/api#date-format
+; "%a, %d %b %Y %H:%M:%S %z"
+; string->time cannot currently handle offsets further than 12 hours off UTC.
+; NZ is currently +1300 so that may constitute a problem depending on whether
+; Dropbox ever send us non UTC times.
+;
+; %z seems to be libc specific. It exists on Linuxes and OS Xs but not NetBSDs
+(define (string->seconds str)
+ (let* ((time (string->time str "%a, %d %b %Y %H:%M:%S %z"))
+        (tz (vector-ref time 9)))
+  (+ tz (utc-time->seconds time))))
+
+(define (where-terms table)
+ (let ((terms (map (lambda (a) `(= (col ,table ,(car a)) ,(cdr a))) (table-scope))))
+  (if (null? terms)
+   '(= 1 1)
+   `(and ,@terms))))
+
+; Account Info
+(define (filter-account-info account-info)
+  (fold
+    (lambda (m state)
+      (let ((k (car m))
+	    (v (cdr m)))
+	(case k
+	  ((quota_info)
+	   (append `((quota_info/normal . ,(alist-ref 'normal v))
+		     (quota_info/shared . ,(alist-ref 'shared v))
+		     (quota_info/quota  . ,(alist-ref 'quota  v)))
+		     state))
+	  (else
+	    (cons `(,k . ,v) state)))))
+    '()
+    account-info))
+
+(define (select-account-info)
+  `(select (columns (col ,(account-info-table)
+			 referral_link display_name uid country
+			 quota_info/normal quota_info/shared quota_info/quota
+			 email cursor
+			 account-info-last-modified account-info-last-complete
+			 metadata-cache-last-modified metadata-cache-last-complete
+			 retry-after))
+	  (from ,(account-info-table))
+	  (where ,(where-terms (account-info-table)))))
+
+(define (add-account-info account-info)
+  (let ((now (current-seconds)))
+    `(insert (into ,(account-info-table))
+	     (columns ,@(map car (table-scope))
+		      account-info-last-modified account-info-last-complete
+		      ,@(map car account-info))
+	     (values #(,@(map cdr (table-scope))
+			,now ,now
+			,@(map cdr account-info))))))
+
+(define (update-account-info account-info old-account-info)
+  (let* ((now (current-seconds))
+	 (changed (any (lambda (x)
+			 (not (equal? (->string (cdr x))
+				      (->string (alist-ref (car x) old-account-info)))))
+		       account-info)))
+    `(update ,(account-info-table)
+	     (set (account-info-last-complete ,now)
+		  ,@(if changed
+		      `((account-info-last-modified ,now)
+			,@(map (lambda (a) `(,(car a) ,(cdr a))) account-info))
+		      '()))
+	     (where ,(where-terms (account-info-table))))))
+
+(define (update-cursor new-cursor has-more old-cursor)
+  (let ((now (current-seconds)))
+    `(update ,(account-info-table)
+	     (set ,@(if (equal? new-cursor old-cursor)
+		      '()
+		      `((cursor ,new-cursor)
+			(metadata-cache-last-modified ,now)))
+		  ,@(if has-more '() `((metadata-cache-last-complete ,now))))
+	     (where ,(where-terms (account-info-table))))))
+
+; Metadata
+(define (filter-metadata metadata)
+  (map
+    (lambda (m)
+      (let ((k (car m))
+	    (v (cdr m)))
+	`(,k .
+	     ,(case k
+		((thumb_exists is_dir is_deleted)
+		 (if v 1 'NULL))
+		((modified client_mtime)
+		 (string->seconds v))
+		(else v)))))
+    metadata))
+
+(define (select-metadata path-key #!optional recursive)
+ `(select (columns (col ,(metadata-cache-table)
+			path-key revision rev thumb_exists bytes modified path
+			is_dir icon root size is_deleted hash client_mtime))
+	  (from ,(metadata-cache-table))
+	  (where (and (or (= (col ,(metadata-cache-table) path-key) ,path-key)
+			  ,@(if recursive
+			      `((like (col ,(metadata-cache-table) path-key) ,(make-absolute-pathname path-key "%")))))
+		      ,(where-terms (metadata-cache-table))))))
+
+(define (select-directory-metadata path-key)
+  (let ((path-key (make-absolute-pathname path-key "%")))
+    `(select (columns (col ,(metadata-cache-table)
+			   path-key revision rev thumb_exists bytes modified path
+			   is_dir icon root size is_deleted hash client_mtime))
+	     (from ,(metadata-cache-table))
+	     (where (and (like (col ,(metadata-cache-table) path-key) ,path-key)
+			 (not (like (col ,(metadata-cache-table) path-key) ,(string-append path-key "/%")))
+			 ,(where-terms (metadata-cache-table)))))))
+
+(define (add-metadata path-key metadata)
+  ; https://www.dropbox.com/developers/reference/api#delta
+  ; instructs us to add parents if they're not already there.
+  ; However, we would have to conjure up rev, revision, and other metadata.
+  ; Furthermore, the fold and consing across the metadata causes all the
+  ; queries to end up in reverse order: we'd have to run them as we went along.
+  ; Dropbox seems to send us all the intermediate data, so lets wait and see if
+  ; we ever come across a case where it doesn't.
+  `(insert (into ,(metadata-cache-table))
+	   (columns ,@(map car (table-scope)) path-key ,@(map car metadata))
+	   (values #(,@(map cdr (table-scope)) ,path-key ,@(map cdr metadata)))))
+
+(define (update-metadata path-key metadata)
+  `(update ,(metadata-cache-table)
+	   (set ,@(map (lambda (a) `(,(car a) ,(cdr a))) metadata))
+	   (where (and
+		    (= (col ,(metadata-cache-table) path-key) ,path-key)
+		    ,(where-terms (metadata-cache-table))))))
+
+(define (update-or-add-metadata path-key metadata)
+  (if (null? (perform-read (select-metadata path-key)))
+    (add-metadata path-key metadata)
+    (update-metadata path-key metadata)))
+
+(define (invalidate-cache)
+ ; HACK: add the root directory
+ `(delete from ,(metadata-cache-table)
+	 (where ,(where-terms (metadata-cache-table)))))
+
+(define (delete-metadata path-key)
+  `(delete from ,(metadata-cache-table)
+	   (where (and
+		    (or
+		      (= (col ,(metadata-cache-table) path-key) ,path-key)
+		      (like (col ,(metadata-cache-table) path-key) ,(make-pathname path-key "%")))
+		    ,(where-terms (metadata-cache-table))))))
+
+; Database
+(define (perform-query! action)
+  (let* ((q (ssql->sql #f action))
+	 (q (sql (db) q)))
+    (query fetch-alists q)))
+
+(define perform-read perform-query!)
+
+(define (perform-action! action)
+  (let ((proc (lambda ()
+		(let ((r (perform-query! action)))
+		  (if (procedure? (db-state-change-callback))
+		    ((db-state-change-callback) (db) (table-scope)))
+		  r))))
+    (if (autocommit? (db))
+      (with-deferred-transaction (db) proc)
+      (proc))))
+
+(define (perform-actions! actions)
+  (with-deferred-transaction
+    (db)
+    (lambda ()
+      (let ((r (map perform-query! actions)))
+	(if (procedure? (db-state-change-callback))
+	  ((db-state-change-callback) (db) (table-scope)))
+	r))))
+
+
+; Interface
+(define (add-account-info!)
+ (perform-action! (add-account-info (filter-account-info (account/info)))))
+
+(define (update-account-info! old-account-info)
+ (perform-action! (update-account-info (filter-account-info (account/info)) old-account-info)))
+
+
+(define (update-metadata! cursor #!optional (old-cursor cursor))
+
+  (let* ((delta    (delta cursor: cursor))
+	 (has_more (alist-ref 'has_more delta))
+	 (reset    (or (not cursor) (alist-ref 'reset delta)))
+	 (cursor   (alist-ref 'cursor delta)))
+
+    ; generates an action that updates a single piece of metadata.
+    (define (generate-action i state delta)
+      (cons
+	(let ((path-key (vector-ref delta 0))
+	      (metadata (vector-ref delta 1)))
+	  (if (eqv? 'null metadata)
+	    (delete-metadata path-key)
+	    (if reset
+	      (add-metadata path-key (filter-metadata metadata))
+	      (update-or-add-metadata path-key (filter-metadata metadata)))))
+	state))
+
+    ; returns a list of actions to be applied to the metadata database.
+    (define (generate-actions delta)
+      `(,@(if reset (list (invalidate-cache)) '())
+	 ,@(vector-fold generate-action '() (alist-ref 'entries delta))
+	 ,(update-cursor cursor has_more old-cursor)))
+
+    (perform-actions! (generate-actions delta))
+    (if has_more
+      (update-metadata! cursor old-cursor)
+      cursor)))
+
+
+(define (update-local-state! #!key force-account-info force-metadata metadata-from-scratch)
+  (let* ((account-info (perform-read (select-account-info)))
+	 (accounts (length account-info))
+	 (_ (assert (<= accounts 1)))
+	 (account-info (if (null? account-info) '() (car account-info)))
+	 (a (lambda (k) (let ((v (alist-ref k account-info))) (if (null? v) #f v))))
+	 (now (current-seconds))
+	 (metadata-cache-last-modified (or (a 'metadata-cache-last-modified) 0))
+	 (metadata-cache-last-complete       (or (a 'metadata-cache-last-complete) 0))
+	 (account-info-last-modified   (or (a 'account-info-last-modified) 0))
+	 (account-info-last-complete   (or (a 'account-info-last-complete) 0))
+	 (ratelimited                  (>= (or (a 'retry-after) 0) now))
+	 (cursor (if metadata-from-scratch #f (a 'cursor))))
+    (if (and ratelimited force-metadata)
+      (abort "force-metadata was specified but rate limiting timeout has not expired!"))
+    (if (not ratelimited)
+      (begin
+	(if (= 0 accounts)
+	  (add-account-info!))
+	(if (and
+	      (= 1 accounts)
+	      (or
+		(> (- now account-info-last-complete) (* 5 60))
+		force-account-info))
+	  (update-account-info! account-info))
+	(if (or
+	      (< metadata-cache-last-complete metadata-cache-last-modified) ; we know the metadata is not complete
+	      (> (- now metadata-cache-last-complete) (* 5 60)) ; or we last checked it more than five minutes ago
+	      force-metadata)
+	  (update-metadata! cursor))
+	#t)
+      #f))) ; TODO: #t for changed, #f for no change, exn for ratelimited
+
+
+(define (canonicalise-path path)
+ (string-chomp (string-downcase path) "/"))
+
+; returns a list files
+; if path is a file the list is of length 1
+; if path is a directory the list contains the nodes in the directory
+;   ...but only if there is a metadata entry for the directory OR the directory
+;   has immediate children who have metadata entries.
+; there are edgecases: the path canonicalisation allows a trailing slash after
+; any valid pathname, regardless of whether it is a file or a directory.
+(define (ls path #!optional directory)
+  ; TODO: update-local-state! (conditional on some parameter flag)
+  (let* ((path (canonicalise-path path))
+	 (path-meta (perform-read (select-metadata path)))
+	 )
+    (cond
+      ((and directory
+	    (= 1 (length path-meta))
+	    (not (null? (alist-ref 'is_dir (car path-meta))))) ; ls -d <directory>
+       path-meta)
+      ((and directory
+	    (null? path-meta)) ; ls -d <directory>  # Directory entry missing
+       (abort "Directory metadata not found!")) ; TODO: tidy up exns
+      ((null? path-meta) ; ls <file> | ls <directory> # Directory entry missing or file not found
+       (let ((path-meta (perform-read (select-directory-metadata path))))
+	 (if (null? path-meta)
+	   (abort "Path not found!") ; TODO: tidy up exns
+	   path-meta)))
+      ((and (= 1 (length path-meta))
+	    (not (null? (alist-ref 'is_dir (car path-meta))))) ; ls <directory>
+       (perform-read (select-directory-metadata path)))
+      (else ; ls <file>
+	path-meta))))
+
+
+
+)
+
   '((version "0.1") ;; version number should be a string
     (static "dropbox-lolevel.o"))) ;; for static linking
 
+(compile -s -O2 -d1 dropbox.scm -j dropbox)
+(compile -s dropbox.import.scm -O2 -d0)
+(compile -c -O2 -d1 dropbox.scm -unit dropbox -j dropbox)
+(install-extension
+  ; Name of your extension:
+  'dropbox
+  ; Files to install for your extension:
+  '("dropbox.o" "dropbox.so" "dropbox.import.so")
+  ; Assoc list with properties for your extension:
+  '((version "0.1") ;; version number should be a string
+    (static "dropbox.o")))
+