ivy json->racquel migration tool

migrate-tool.rkt

#lang racket/base
; migrate-tool.rkt
(require db/base
         db/sqlite3
         json
         racket/class
         racket/contract
         racket/dict
         racket/list
         racket/string
         racquel)

(define ivy-path
  (cond [(eq? (system-type) 'unix)
         ; check XDG variable first, then default
         ; to ~/.config/ivy
         (let ([xdg (getenv "XDG_CONFIG_HOME")])
           (if xdg
               (build-path xdg "ivy")
               (build-path (find-system-path 'home-dir)
                           ".config/ivy")))]
        [(eq? (system-type) 'windows)
         (normal-case-path
          (build-path (find-system-path 'home-dir)
                      "appdata/local/ivy"))]
        [(eq? (system-type) 'macosx)
         (build-path (find-system-path 'home-dir)
                     "Library/Application Support/ivy")]))

(define db-file (build-path ivy-path "catalog.sqlite"))
(define master-file (build-path ivy-path "catalog.json"))
(define master (make-hash))

; path for cached thumbnails
(define thumbnails-path (build-path ivy-path "thumbnails"))

(unless (directory-exists? ivy-path)
  (make-directory ivy-path))

(unless (directory-exists? thumbnails-path)
  (make-directory thumbnails-path))

(define sqlc
  (sqlite3-connect
   #:database db-file
   #:mode 'create))

(let ([json-port (open-input-file master-file)])
  ; Racket v6.2.1 read-json returns immutable hash.
  ; we need to operate with a mutable one
  (set! master (hash-copy (read-json json-port)))
  (close-input-port json-port))

(define (save-dict! dct)
  (with-output-to-file master-file
    (λ () (write-json dct))
    #:exists 'truncate/replace
    #:mode 'text))

(query-exec sqlc
            "create table if not exists tags(Tag_label string not null, Image_List string);")
(query-exec sqlc
            "create table if not exists images(Path string not null, Tag_List string);")

; a single tag class which is associated with a list of images
(define tag%
  (data-class object%
              (table-name "tags")
              (init-column (label "" "Tag_Label"))
              (column (imagelist "" "Image_List")) ; one long list of the images
              (primary-key label)
              (super-new)
              
              (define/public (get-images)
                (define imgs (get-column imagelist this))
                (string-split imgs ","))
              
              ; img is the image's path
              (define/public (add-img img)
                (define path (if (string? img) img (get-column path img)))
                (define il (string-split (get-column imagelist this) ","))
                (unless (member path il)
                  (set! imagelist (string-join (sort (append il (list path)) string<?) ","))))
              
              (define/public (del-img img)
                (define path (if (string? img) img (get-column path img)))
                (define il (get-images))
                (when (member path il)
                  (set! imagelist (string-join (sort (remove path il) string<?) ","))))))

; a single image class which is associated with a list of tags
; path should be a string
(define image%
  (data-class object%
              (table-name "images")
              (init-column (path "" "Path")) ; string
              (column (taglist "" "Tag_List")) ; one long string of the tags
              (primary-key path)
              (super-new)
              
              (define/public (get-tags)
                (define tags (get-column taglist this))
                (string-split tags ","))
              
              ; tag is the tag's label
              (define/public (add-tag tag)
                (define label (if (string? tag) tag (get-column label tag)))
                (define tl (string-split (get-column taglist this) ","))
                (unless (member label tl)
                  (set! taglist (string-join (sort (append tl (list label)) string<?) ","))))
              
              (define/public (del-tag tag)
                (define label (if (string? tag) tag (get-column label tag)))
                (define tl (get-tags))
                (when (member label tl)
                  (set! taglist (string-join (sort (remove label tl) string<?) ","))))))

(define/contract (db-has-key? #:db-conn [db-conn sqlc] table key)
  (->* ([or/c "images" "tags"] string?) (#:db-conn connection?) boolean?)
  (define objs
    (case table
      [("images") (select-data-objects db-conn image% (where (= path ?)) key)]
      [("tags") (select-data-objects db-conn tag% (where (= label ?)) key)]))
  (not (empty? objs)))

(define (export-json! dct sql)
  (define total (length (dict->list dct)))
  (for ([(key tags) (in-dict dct)]
        [i (in-naturals 1)])
    (define path-str (symbol->string key))
    (printf "Adding key ~v (~a / ~a)~n" path-str i total)
    
    (define img-obj
      (if (db-has-key? #:db-conn sql "images" path-str)
          (make-data-object sql image% path-str)
          (new image% [path path-str])))
    ; add all the tags to it
    (map (λ (t) (send img-obj add-tag t)) tags)
    (save-data-object sql img-obj)
    
    ; create all the tag objects (unless they already exist), add the image to them
    (for ([tag (in-list tags)])
      (define tag-obj
        (if (db-has-key? #:db-conn sql "tags" tag)
            (make-data-object sql tag% tag)
            (new tag% [label tag])))
      (send tag-obj add-img path-str)
      (save-data-object sql tag-obj))))

(export-json! master sqlc)

(disconnect sqlc)