Source

dropbox / dropbox.scm

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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))))



)
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.