;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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 , 2012/11/01 22:40 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (module dropbox (make-dropbox-app db account-info-table metadata-cache-table table-scope db-state-change-callback local-state-refresh-interval update-local-state! add-account-info! ls download ) (import chicken scheme) ; Units - http://api.call-cc.org/doc/chicken/language (use data-structures posix srfi-1 files srfi-13 ports) ; 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)) (define local-state-refresh-interval (* 5 60)) ; 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)) ((team) (append `((team/name . ,(if (eqv? 'null v) v (alist-ref 'name v eqv? 'null)))) 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 team/name 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 mime_type 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) ,(string-append path-key "/%"))) '())) ,(where-terms (metadata-cache-table)))))) (define (select-directory-metadata path-key) (let ((path-key (string-append path-key "/%"))) `(select (columns (col ,(metadata-cache-table) path-key revision rev thumb_exists bytes modified path mime_type 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) local-state-refresh-interval) 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) local-state-refresh-interval) ; 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) (let ((path (string-chomp (string-downcase path) "/"))) (if (> (string-length path) 0) (if (equal? #\/ (string-ref path 0)) path (string-append "/" 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 (if (equal? "" path) '(((path-key . "") (mime_type . #f) (revision . #f) (rev . #f) (thumb_exists . #f) (bytes . 0) (modified . #f) (path . "") (is_dir . 1) (icon . "folder_public") (root . "dropbox") (size . "0 bytes") (is_deleted) (hash) (client_mtime))) (perform-read (select-metadata path))))) (cond ((and directory (= 1 (length path-meta)) (not (null? (alist-ref 'is_dir (car path-meta))))) ; ls -d path-meta) ((and directory (null? path-meta)) ; ls -d # Directory entry missing (abort "Directory metadata not found!")) ; TODO: tidy up exns ((null? path-meta) ; ls | ls # 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 (perform-read (select-directory-metadata path))) (else ; ls path-meta)))) ; Downloads a file. ; Downloads the file specified in source to the local path name specified in ; destination. ; destination is a string representing the path name into the local filesystem. ; if dest is a port then we pipe the contents to that port. ; if dest is a string then we pipe the contents into that file on the fs. ; source is an alist that describes the file and can be obtained with a call to ; 'ls'. ; If latest-rev is #f then the revision specified in the metadata will be ; fetched. Otherwise, the lateset revision will be fetched. (define (download source #!optional destination latest-rev progress-callback) (let ((proc (lambda () (parameterize ((callback progress-callback)) (files:get (alist-ref 'root source) (alist-ref 'path-key source) rev: (if latest-rev #f (alist-ref 'rev source))))))) (old-output-port (current-output-port)) (cond ((port? destination) (with-output-to-port destination proc)) ((string? destination) (with-output-to-file destination proc)) (else (proc))))) )