initial foreign-key support

Author: corpix

deta-lib/private/dialect/postgresql.rkt

@@ -48,17 +48,21 @@
          (display (quote/standard table))
 
          (displayln "(")
-         (define n-fields (length fields))
          (for ([i (in-naturals 1)]
                [f (in-list fields)])
-           (emit-field-ddl f (= i n-fields)))
+           (emit-field-ddl f (= i 1)))
+         (for ([i (in-naturals 1)]
+               [f (in-list fields)])
+           (emit-field-constraints f))
          (displayln ")")]
 
         [(drop-table table)
          (display "DROP TABLE IF EXISTS ")
          (displayln (quote/standard table))]))))
 
-(define (emit-field-ddl f last?)
+(define (emit-field-ddl f first?)
+  (unless first?
+    (display ","))
   (define type
     (if (field-auto-increment? f)
         "SERIAL"
@@ -75,10 +79,21 @@
     (display " PRIMARY KEY"))
 
   (when (field-unique? f)
-    (display " UNIQUE"))
-
-  (unless last?
-    (displayln ",")))
+    (display " UNIQUE")))
+
+(define (emit-field-constraints f)
+  (display ",")
+  (when (field-foreign-key? f)
+    (display " FOREIGN KEY")
+    (display "(")
+    (display (quote/standard (field-name f)))
+    (display ")")
+    (display " REFERENCES ")
+    (define fk (field-foreign-key f))
+    (display (quote/standard (foreign-key-schema fk)))
+    (display "(")
+    (display (quote/standard (foreign-key-field fk)))
+    (display ")")))
 
 (define (emit-expr e)
   (emit-expr/standard e))

deta-lib/private/dialect/sqlite3.rkt

@@ -52,18 +52,23 @@
          (display "CREATE TABLE IF NOT EXISTS ")
          (display (quote/standard table))
 
-         (displayln "(")
+         (display "(")
          (define n-fields (length fields))
          (for ([i (in-naturals 1)]
                [f (in-list fields)])
-           (emit-field-ddl f (= i n-fields)))
+           (emit-field-ddl f (= i 1)))
+         (for ([i (in-naturals 1)]
+               [f (in-list fields)])
+           (emit-field-constraints f))
          (displayln ")")]
 
         [(drop-table table)
          (display "DROP TABLE IF EXISTS ")
          (displayln (quote/standard table))]))))
 
-(define (emit-field-ddl f last?)
+(define (emit-field-ddl f first?)
+  (unless first?
+    (display ","))
   (display (quote/standard (field-name f)))
   (display " ")
   (display (type-declaration (field-type f) 'sqlite3))
@@ -78,10 +83,21 @@
     (display " AUTOINCREMENT"))
 
   (when (field-unique? f)
-    (display " UNIQUE"))
-
-  (unless last?
-    (displayln ",")))
+    (display " UNIQUE")))
+
+(define (emit-field-constraints f)
+  (when (field-foreign-key? f)
+    (display ",")
+    (display " FOREIGN KEY")
+    (display "(")
+    (display (quote/standard (field-name f)))
+    (display ")")
+    (display " REFERENCES ")
+    (define fk (field-foreign-key f))
+    (display (quote/standard (foreign-key-schema fk)))
+    (display "(")
+    (display (quote/standard (foreign-key-field fk)))
+    (display ")")))
 
 (define (emit-expr e)
   (match e

deta-lib/private/field.rkt

@@ -7,6 +7,9 @@
  make-field
  (struct-out field)
 
+ make-foreign-key
+ (struct-out foreign-key)
+
  id->column-name)
 
 (struct field
@@ -18,6 +21,8 @@
    setter
    updater
    primary-key?
+   foreign-key?
+   foreign-key
    auto-increment?
    nullable?
    unique?
@@ -31,6 +36,8 @@
                     #:setter setter
                     #:updater updater
                     #:primary-key? primary-key?
+                    #:foreign-key? foreign-key?
+                    #:foreign-key foreign-key
                     #:auto-increment? auto-increment?
                     #:nullable? nullable?
                     #:unique? unique?
@@ -43,11 +50,21 @@
          setter
          updater
          primary-key?
+         foreign-key?
+         foreign-key
          auto-increment?
          nullable?
          unique?
          virtual?))
 
+(struct foreign-key
+  (schema
+   field))
+
+(define (make-foreign-key #:schema schema
+                          #:field field)
+  (foreign-key schema field))
+
 (define (id->column-name id)
   (let* ([name (cond
                  [(symbol? id) (symbol->string id)]

deta-lib/private/schema.rkt

@@ -20,7 +20,8 @@
    pre-persist-hook
    pre-delete-hook
    fields
-   primary-key))
+   primary-key
+   foreign-key))
 
 (define (make-schema #:id id
                      #:table table
@@ -39,6 +40,9 @@
                            "at most one field may be marked as a #:primary-key"
                            "bad fields" (map field-id pk-fields)))
 
+  (define fk-fields
+    (filter field-foreign-key? fields))
+
   (define the-schema
     (schema id
             table
@@ -49,7 +53,8 @@
             pre-persist-hook
             pre-delete-hook
             fields
-            (findf field-primary-key? pk-fields)))
+            (findf field-primary-key? pk-fields)
+            (findf field-foreign-key? fk-fields)))
 
   (begin0 the-schema
     (unless virtual?

deta-lib/schema.rkt

@@ -72,7 +72,7 @@
 
   (define-template-metafunction (make-fld-maker stx)
     (syntax-parse stx
-      [(_ struct-id fld-id fld-name fld-type fld-pk? fld-ai? fld-nullable? fld-unique? fld-virtual?)
+      [(_ struct-id fld-id fld-name fld-type fld-pk? fld-fk? fld-fk fld-ai? fld-nullable? fld-unique? fld-virtual?)
        (with-syntax ([getter-id  (format-id #'struct-id "~a-~a"        #'struct-id #'fld-id)]
                      [setter-id  (format-id #'struct-id "set-~a-~a"    #'struct-id #'fld-id)]
                      [updater-id (format-id #'struct-id "update-~a-~a" #'struct-id #'fld-id)])
@@ -83,6 +83,8 @@
                        #:setter setter-id
                        #:updater updater-id
                        #:primary-key? fld-pk?
+                       #:foreign-key? fld-fk?
+                       #:foreign-key fld-fk
                        #:auto-increment? fld-ai?
                        #:nullable? fld-nullable?
                        #:unique? fld-unique?
@@ -111,8 +113,14 @@
                 (optional-arg ... ...)
                 struct-pred-id))]))
 
+  (define-syntax-class fk
+    (pattern (schema:id field:id)
+             #:with ctor-arg (with-syntax* ([schema-id (format-id #'schema "~a-schema" #'schema)])
+                               #'(foreign-key (schema-table schema-id) (id->column-name 'field)))))
+
   (define-syntax-class fld
     (pattern (id:id type:expr (~alt (~optional (~and #:primary-key primary-key))
+                                    (~optional (~seq #:foreign-key foreign-key:fk))
                                     (~optional (~and #:auto-increment auto-increment))
                                     (~optional (~and #:nullable nullable))
                                     (~optional (~and #:unique unique))
@@ -126,6 +134,10 @@
              #:with required? (if (or (attribute auto-increment)
                                       (attribute nullable)) #'#f #'t)
              #:with primary-key? (if (attribute primary-key) #'#t #'#f)
+             #:with foreign-key? (if (attribute foreign-key) #'#t #'#f)
+             #:with foreign-key-ctor-arg (if (attribute foreign-key)
+                                         (attribute foreign-key.ctor-arg)
+                                         #'#f)
              #:with auto-increment? (if (attribute auto-increment) #'#t #'#f)
              #:with nullable? (if (attribute nullable) #'#t #'#f)
              #:with unique? (if (attribute unique) #'#t #'#f)
@@ -143,6 +155,7 @@
                                [else                    #'(ctor-kwd  id)]))
 
     (pattern ((id:id default:expr) type:expr (~alt (~optional (~and #:primary-key primary-key))
+                                                   (~optional (~seq #:foreign-key foreign-key:fk))
                                                    (~optional (~and #:auto-increment auto-increment))
                                                    (~optional (~and #:nullable nullable))
                                                    (~optional (~and #:unique unique))
@@ -164,6 +177,10 @@
 
              #:with required? #'#f
              #:with primary-key? (if (attribute primary-key) #'#t #'#f)
+             #:with foreign-key? (if (attribute foreign-key) #'#t #'#f)
+             #:with foreign-key-ctor-arg (if (attribute foreign-key)
+                                         (attribute foreign-key.ctor-arg)
+                                         #'#f)
              #:with auto-increment? (if (attribute auto-increment) #'#t #'#f)
              #:with nullable? (if (attribute nullable) #'#t #'#f)
              #:with unique? (if (attribute unique) #'#t #'#f)
@@ -239,6 +256,8 @@
                                                          f.name
                                                          f.type
                                                          f.primary-key?
+                                                         f.foreign-key?
+                                                         f.foreign-key-ctor-arg
                                                          f.auto-increment?
                                                          f.nullable?
                                                          f.unique?

examples/music.rkt

@@ -0,0 +1,69 @@
+#lang racket/base
+
+(require db
+         deta
+         threading)
+
+(define-schema artist
+  ([id id/f #:primary-key #:auto-increment]
+   [name string/f #:unique]))
+
+(define-schema album
+  ([id id/f #:primary-key #:auto-increment]
+   [title string/f #:unique]
+   [artist-id id/f #:foreign-key (artist id)]
+   [year-published integer/f #:nullable]))
+
+(define conn
+  (sqlite3-connect #:database 'memory))
+
+(void
+ (create-all! conn)
+
+ (insert! conn
+          (make-album #:title "Nevermind"
+                      #:artist-id (artist-id (insert-one! conn (make-artist #:name "Nirvana")))
+                      #:year-published 1991)
+          (make-album #:title "Achtung Baby"
+                      #:artist-id (artist-id (insert-one! conn (make-artist #:name "U2")))
+                      #:year-published 1991)
+          (make-album #:title "The Miseducation of Lauryn Hill"
+                      #:artist-id (artist-id (insert-one! conn (make-artist #:name "Lauryn Hill")))
+                      #:year-published 1998)))
+
+(define (albums-before year)
+  (~> (from album #:as a)
+      (where (< a.year-published ,year))))
+
+(define (albums-between start-year end-year)
+  (~> (from album #:as a)
+      (where (between a.year-published ,start-year ,end-year))))
+
+(displayln "Albums published before 1995:")
+(for ([a (in-entities conn (albums-before 1995))])
+  (displayln (album-title a)))
+
+(displayln "")
+(displayln "Albums published between 1990 and 2000:")
+(for ([a (in-entities conn (albums-between 1990 2000))])
+  (displayln (album-title a)))
+
+(define-schema album-with-artists
+  #:virtual
+  ([id id/f #:primary-key #:auto-increment]
+   [title string/f #:unique]
+   [artist-id id/f #:foreign-key (artist id)]
+   [year-published integer/f #:nullable]
+   [name string/f]))
+
+(displayln "")
+(displayln "All albums with artist names:")
+(for ([a (in-entities conn (~> (from album #:as al)
+                               (join artist
+                                     #:as at
+                                     #:on (= al.artist_id at.id))
+                               (select al.* at.name)
+                               (project-onto album-with-artists-schema)))])
+  (displayln (format "Artist: ~v, album: ~v"
+                     (album-with-artists-name a)
+                     (album-with-artists-title a))))