#lang racket/base

(require
  (for-syntax racket/base)
  (for-syntax racket/syntax)
  racket/string
  racket/contract
  db)

(provide
  add-stored-base-type
  within-transaction
  ;
  stored-class
  class-repository
  ;
  instanciate
  instance-identifier
  instance-repository
  ;
  open-repository
  init-repository
  save-instance
  save-instances
  find-instance-by-id
  list-instances
  find-instances
  count-instances
  delete-instance-by-id
  delete-instance
  delete-instances
  )

; Abstractions for defining and using objects stored in databases
; For now, only sqlite3 databases are supported

; Each repository supports a number of base types natively, but it is possible to add additional types
(define *additional-types* (make-hash))
(struct struct:type
  (scm ; symbol corresponding to the contract used in structures
   sql ; symbol corresponding to the contract used in storage
   from-sql ; conversion from storage
   to-sql ; conversion to storage
   ))
(define (add-additional-type type)
  (hash-set! *additional-types* (struct:type-scm type) type))

(define-syntax add-stored-base-type
  (syntax-rules ()
    ((_ type sql-type from-sql to-sql)
     (add-additional-type (struct:type (quote type) (quote sql-type) from-sql to-sql)))))

; Repository structure
(struct struct:repository
  (type
   connection))

; Transactions
; Regroup several call within the same transaction, and rollback automatically in case of errors
(define-syntax within-transaction
  (syntax-rules ()
    ((_ repo body ...)
     (let ((conn (struct:repository-connection repo)))
       (call-with-transaction conn
          (lambda ()
            body ...))))))

; Stored class info structure
(struct struct:stored-class
  (name ; name (symbol)
   attributes ; attributes (cons symbol contract)
   (repository #:mutable) ; repository attached to the class
   ))

; Stored class instance structure
(struct struct:stored-instance
  (class ; stored-class containing the class informations
   (identifier #:mutable) ; repository unique id for the instance - #f if not stored in the repository
   attributes)) ; map of attribute -> value

; Stored class definition
(define-syntax (stored-class stx)
  (syntax-case stx (:)
    ((_ name (attr : contract) ...)
     (with-syntax ((name? (format-id (syntax name) "~a?" (syntax name)))
                   (((attr-for-get contract-for-get name-attr) ...)
                    (map (lambda (x)
                            (let ((sx (syntax-e x)))
                              (list (car sx) (cadr sx) (format-id (syntax name) "~a-~a" (syntax name) (car sx)))))
                         (syntax->list (syntax ((attr contract) ...)))))
                   (((attr-for-set contract-for-set set-name-attr!) ...)
                    (map (lambda (x)
                            (let ((sx (syntax-e x)))
                              (list (car sx) (cadr sx) (format-id (syntax name) "set-~a-~a!" (syntax name) (car sx)))))
                         (syntax->list (syntax ((attr contract) ...)))))
                  )
       (syntax
         (begin
           (define name
              (struct:stored-class
                (quote name)
                (list (cons (quote attr) (quote contract)) ...)
                #f))
           (define/contract (name? instance)
              (-> any/c boolean?)
              (and (struct:stored-instance? instance)
                   (eq? (quote name) (struct:stored-class-name (struct:stored-instance-class instance)))))
           (begin
             (define/contract (name-attr instance)
                (-> struct:stored-instance? (or/c #f contract-for-get))
                (hash-ref (struct:stored-instance-attributes instance) (quote attr-for-get)))
             ...)
           (begin
             (define/contract (set-name-attr! instance val)
                (-> struct:stored-instance? (or/c #f contract-for-set) void)
                (hash-set! (struct:stored-instance-attributes instance) (quote attr-for-set) val))
             ...)
         ))))))

; Repository
(define/contract (class-repository class)
  (-> struct:stored-class? (or/c #f struct:repository?))
  (struct:stored-class-repository class))

; New instance
(define/contract (instanciate class)
  (-> struct:stored-class? struct:stored-instance?)
  (let ((attributes (make-hash)))
    (for-each
      (lambda (x)
        (hash-set! attributes (car x) #f))
      (struct:stored-class-attributes class))
    (struct:stored-instance class #f attributes)))

; Identifier
(define/contract (instance-identifier instance)
  (-> struct:stored-instance? (or/c #f integer?))
  (struct:stored-instance-identifier instance))

; Repository
(define/contract (instance-repository instance)
  (-> struct:stored-instance? (or/c #f struct:repository?))
  (struct:stored-class-repository
    (struct:stored-instance-class instance)))

; sqlite3 methods

; Open and return a repository
(define (open-repository type . params)
  (struct:repository
    type
    (virtual-connection
      (connection-pool
        (lambda ()
          (cond
            ((eq? type 'sqlite3)
             (sqlite3-connect
                #:database (car params)
                #:mode 'create))
            (#t (error "Unsupported repository type: " type))))))))

; To define sql constraints - specific to sqlite3 for now
(define/contract (sql-typeof repo x)
  (-> struct:repository? symbol? symbol?)
  (case x
    ((exact-integer? integer?) 'integer)
    ((real?) 'real)
    ((string?) 'text)
    ((bytes?) 'blob)
    ; other supported datatypes needing conversion
    ((boolean?) 'integer)
    ; Other types
    (else
      (cond
        ; If this corresponds to an additional type, recall this with the corresponding sql type
        ((hash-has-key? *additional-types* x)
         (sql-typeof repo (struct:type-sql (hash-ref *additional-types* x))))
        ; Unsupported
        (else (error "Unsupported type: " x))))))

; Conversion of data types (racket->sql)
(define (to-sql contract val)
  (case contract
    ((exact-integer? real? string? bytes?) val) ; no translation
    ((integer?) (and val (inexact->exact val))) ; to be sure to store an exact-integer?
    ((boolean?) (if val 1 #f))
    ; Other types
    (else
      (cond
        ; If this corresponds to an additional type, call the converion function and
        ((hash-has-key? *additional-types* contract)
         (let ((type (hash-ref *additional-types* contract)))
            (and
              val
              (to-sql
                (struct:type-sql type)
                ((struct:type-to-sql type) val)))))
        ; Unsupported
        (else (error "Unsupported type: " contract))))))

; Conversion of data types (sql->racket)
(define (from-sql contract val)
  (case contract
    ((exact-integer? integer? real? string? bytes?) val) ; no translation
    ((boolean?) (if (eq? val 1) #t #f))
    ; Other types
    (else
      (cond
        ; If this corresponds to an additional type, call the converion function and
        ((hash-has-key? *additional-types* contract)
         (let ((type (hash-ref *additional-types* contract)))
            (and
              val
              ((struct:type-from-sql type)
               (from-sql
                  (struct:type-sql type)
                  val)))))
        ; Unsupported
        (else (error "Unsupported type: " contract))))))

; SQL table creation - specific to sqlite3 for now
(define/contract (repository-create-table cls)
  (-> struct:stored-class? void)
  (let ((repo (struct:stored-class-repository cls)))
    (query-exec (struct:repository-connection repo)
      (format "create table if not exists ~a (~a)"
        (struct:stored-class-name cls)
        (string-join
          (map
            (lambda (x)
              (format "\"~a\" ~a" (car x) (sql-typeof repo (cdr x))))
            (struct:stored-class-attributes cls))
          ",")))))

; Initialize a repository with a list of classes to store
(define (init-repository repo . classes)
  (let ((conn (struct:repository-connection repo)))
    (for-each
      (lambda (cls)
        (set-struct:stored-class-repository! cls repo)
        (repository-create-table cls))
      classes)))

; Find an instance
; Bind values to attributes
(define (bind-attributes instance keys+contracts vals idx)
  (when (not (null? keys+contracts))
    (hash-set!
      (struct:stored-instance-attributes instance)
      (caar keys+contracts)
      (from-sql (cdar keys+contracts) (sql-null->false (vector-ref vals idx))))
    (bind-attributes instance (cdr keys+contracts) vals (+ idx 1))))

; Find by id
(define/contract (find-instance-by-id cls id)
  (-> struct:stored-class? integer? struct:stored-instance?)
  (let* ((repo (struct:stored-class-repository cls))
         (conn (struct:repository-connection repo))
         (keys+contracts (struct:stored-class-attributes cls))
         (keys (map car keys+contracts))
         (row (apply query-row
                (list conn
                  (format "select ~a from ~a where rowid = ?"
                    (string-join (map symbol->string keys) ",")
                    (struct:stored-class-name cls))
                  id)))
         (instance (instanciate cls))
       )
    (bind-attributes instance keys+contracts row 0)
    (set-struct:stored-instance-identifier! instance id)
    instance))

; Return a list of instances
(define (list-instances cls #:limit (limit #f) #:offset (offset #f) #:descending (desc #f))
  (let* ((repo (struct:stored-class-repository cls))
         (conn (struct:repository-connection repo))
         (keys+contracts (struct:stored-class-attributes cls))
         (keys (map car keys+contracts))
         (rows (apply query-rows
                (append
                  (list conn
                    (format
                      (string-append
                        "select ~a,rowid from ~a order by rowid ~a"
                        (if limit (string-append " limit ?" (if offset " offset ?" "")) ""))
                      (string-join (map symbol->string keys) ",")
                      (struct:stored-class-name cls)
                      (if desc "desc" "asc")))
                  (if limit
                    (if offset
                        (list limit offset)
                        (list limit))
                    (list)))))
        )
    (map
      (lambda (row)
        (let ((instance (instanciate cls)))
          (bind-attributes instance keys+contracts row 0)
          (set-struct:stored-instance-identifier! instance (vector-ref row (length keys)))
          instance))
      rows)))

; Find by value of fields
; Query is in the form (list (cons attr value) ...) and is a conjunction
(define (find-instances cls query #:limit (limit #f) #:offset (offset #f) #:descending (desc #f))
;  (-> struct:stored-class? (listof (cons/c symbol? any/c)) (listof struct:stored-instance?))
  (let* ((repo (struct:stored-class-repository cls))
         (conn (struct:repository-connection repo))
         (keys+contracts (struct:stored-class-attributes cls))
         (keys (map car keys+contracts))
         (rows (apply query-rows
                (append
                  (list
                    conn
                    (format
                      (string-append
                        "select ~a,rowid from ~a where ~a order by rowid ~a"
                        (if limit (string-append " limit ?" (if offset " offset ?" "")) ""))
                      (string-join
                        (map symbol->string keys)
                        ",")
                      (struct:stored-class-name cls)
                      (string-join
                        (map
                          (lambda (x) (string-append (symbol->string (car x)) " is ?"))
                          query)
                        " and ")
                      (if desc "desc" "asc")
                      ))
                  (map
                    (lambda (k+v)
                      (let ((k+c (assoc (car k+v) keys+contracts)))
                        (false->sql-null (to-sql (cdr k+c) (cdr k+v)))))
                    query)
                  (if limit
                    (if offset
                        (list limit offset)
                        (list limit))
                    (list))
                  )))
       )
    (map
      (lambda (row)
        (let ((instance (instanciate cls)))
          (bind-attributes instance keys+contracts row 0)
          (set-struct:stored-instance-identifier! instance (vector-ref row (length keys)))
          instance))
      rows)))

; Return the number of instances in the repository
(define/contract (count-instances cls)
  (-> struct:stored-class? exact-nonnegative-integer?)
  (let* ((repo (struct:stored-class-repository cls))
         (conn (struct:repository-connection repo))
        )
    (query-value conn (format "select count(*) from ~a" (struct:stored-class-name cls)))))

; Store an instance
; Create a new instance in the repository
(define/contract (create-instance instance)
  (-> struct:stored-instance? void)
  (let* ((cls (struct:stored-instance-class instance))
         (repo (struct:stored-class-repository cls))
         (conn (struct:repository-connection repo))
         (keys+contracts (struct:stored-class-attributes cls))
         (keys+values
           (filter
             (lambda (x) x)
             (hash-map
               (struct:stored-instance-attributes instance)
               (lambda (k v)
                 (and v (cons k v))))))
         (keys (map car keys+values))
         (vals (map
                 (lambda (k+v)
                   (let ((k+c (assoc (car k+v) keys+contracts)))
                     (false->sql-null (to-sql (cdr k+c) (cdr k+v)))))
                 keys+values))
        )
    (when (not (null? keys))
      (apply query-exec
        (append
          (list conn
                (format
                  "insert into ~a (~a) values (~a)"
                  (struct:stored-class-name cls)
                  (string-join (map symbol->string keys) ",")
                  (string-join (build-list (length keys) (lambda (x) "?")) ",")))
          vals))
      (set-struct:stored-instance-identifier!
        instance
        (query-value conn "select last_insert_rowid()"))
      )))

; update and existing instance in the repository
(define/contract (update-instance instance)
  (-> struct:stored-instance? void)
  (let* ((cls (struct:stored-instance-class instance))
         (repo (struct:stored-class-repository cls))
         (conn (struct:repository-connection repo))
         (keys+contracts (struct:stored-class-attributes cls))
         (keys+values
           (hash->list
             (struct:stored-instance-attributes instance)))
         (keys (map car keys+values))
         (vals (map
                 (lambda (k+v)
                   (let ((k+c (assoc (car k+v) keys+contracts)))
                     (false->sql-null (to-sql (cdr k+c) (cdr k+v)))))
                 keys+values))
        )
    (apply query-exec
      (append
        (list conn
              (format
                "update ~a set (~a) = (~a) where rowid = ?"
                (struct:stored-class-name cls)
                (string-join (map symbol->string keys) ",")
                (string-join (build-list (length keys) (lambda (x) "?")) ",")))
        vals
        (list (instance-identifier instance))))
    ))

; Save instance: create instance in repository if not present or update it.
; One instance
(define/contract (save-instance instance)
  (-> struct:stored-instance? void)
  (let* ((cls (struct:stored-instance-class instance))
         (repo (struct:stored-class-repository cls))
         (conn (struct:repository-connection repo))
        )
    (if (instance-identifier instance)
        (update-instance instance)
        (create-instance instance))))

; Same as above, but for saving several instances at the same time
(define/contract (save-instances . instances)
  (->* () #:rest (listof struct:stored-instance?) void)
  (for-each
    save-instance
    instances))

; Remove an instance
; From class and id
(define/contract (delete-instance-by-id cls id)
  (-> struct:stored-class? integer? void)
  (when id
    (let* ((repo (struct:stored-class-repository cls))
           (conn (struct:repository-connection repo))
          )
      (query-exec
        conn
        (format "delete from ~a where rowid = ?"
          (struct:stored-class-name cls))
        id))))

; From instance itself
(define/contract (delete-instance instance)
  (-> struct:stored-instance? void)
  (delete-instance-by-id
    (struct:stored-instance-class instance)
    (instance-identifier instance))
  (set-struct:stored-instance-identifier! instance #f))

; Remove instances by value of fields
; Query is in the form (list (cons attr value) ...) and is a conjunction
(define (delete-instances cls query)
;  (-> struct:stored-class? (listof (cons/c symbol? any/c)) (listof struct:stored-instance?))
  (let* ((repo (struct:stored-class-repository cls))
         (conn (struct:repository-connection repo))
         (keys+contracts (struct:stored-class-attributes cls))
         (keys (map car keys+contracts)))
    (apply
      query-exec
      (append
        (list
          conn
          (format "delete from ~a where ~a"
            (struct:stored-class-name cls)
            (string-join
              (map
                (lambda (x) (string-append (symbol->string (car x)) " is ?"))
                query)
              " and ")
            ))
        (map
          (lambda (k+v)
            (let ((k+c (assoc (car k+v) keys+contracts)))
              (false->sql-null (to-sql (cdr k+c) (cdr k+v)))))
          query)
        ))))
