Add procedures for database operation.

2 files changed, 164 insertions, 0 deletions

diff --git a/db/articles.rkt b/db/articles.rkt
new file mode 100644
index 0000000..b549dc9
--- /dev/null
+++ b/db/articles.rkt
@@ -0,0 +1,137 @@
+#lang typed/racket
+(require "../entities/article.rkt")
+(require typed/db)
+
+(module untyped-db-ops racket
+  (require db
+           db/util/datetime
+           "../entities/article.rkt")
+
+  (provide fetch-article
+           fetch-latest-articles
+           fetch-article-tags
+           fetch-article-taggings
+           insert-article-tagging
+           delete-article-tagging
+           fetch-article-hashes
+           update-article
+           insert-article)
+
+  (define (fetch-article conn article-id)
+    (match-let ([(vector timestamp hash title body)
+                 (query-row conn "SELECT timestamp, hash, title, body FROM diary.articles WHERE article_id = $1" article-id)])
+      (make-article article-id (sql-datetime->srfi-date timestamp) hash title body)))
+
+  (define (fetch-latest-articles conn limit)
+    (define article-list
+      (for/list ([(article-id timestamp hash title body)
+                  (in-query conn "
+SELECT article_id, timestamp, hash, title, body FROM diary.articles ORDER BY timestamp DESC LIMIT $1
+"
+                            limit)])
+        (make-article article-id (sql-datetime->srfi-date timestamp) hash title body)))
+    (define article-tags
+      (for/hash ([(article-id l)
+                  (in-query conn
+                            "
+SELECT article_id, name FROM diary.tags
+  JOIN diary.article_taggings USING (tag_id)
+ WHERE article_id = any ($1)
+"
+                            (map article-id article-list)
+                            #:group #("article_id"))])
+        (values article-id (vector->list (car l)))))
+    (map (lambda (article)
+           (cond
+             [(hash-ref article-tags (article-id article) #f)
+              => (curry article->article-with-tags article)]
+             [else
+              (article->article-with-tags article '())]))
+         article-list))
+
+  (define (fetch-article-tags conn article-id)
+    (for/list ([tag (in-query conn "
+SELECT name FROM diary.tags
+  JOIN diary.article_taggings USING (tag_id)
+ WHERE article_id = $1
+ ORDER BY name
+"
+                              article-id)])
+      tag))
+
+  (define (delete-article-tagging conn article_id tag_id)
+    (query-exec conn
+                "
+DELETE FROM diary.article_taggings
+WHERE article_id = $1
+  AND tag_id = $2
+"
+                article_id
+                tag_id))
+
+  (define (fetch-article-taggings conn article-id)
+    (for/set ([tag-id (in-query conn "SELECT tag_id FROM diary.article_taggings WHERE article_id = $1" article-id)])
+      tag-id))
+
+  (define (insert-article-tagging conn article_id tag_id)
+    (query-exec conn
+                "
+INSERT INTO diary.article_taggings(article_id, tag_id)
+VALUES($1, $2)
+"
+                article_id
+                tag_id))
+
+  (define (insert-tag conn name)
+    (query-value conn
+                 "
+INSERT INTO diary.tags(name)
+VALUES($1)
+RETURNING tag_id
+"
+                 name))
+
+  (define (fetch-article-hashes conn)
+    (for/hash ([(article-id hash)
+                (in-query conn "SELECT article_id, hash FROM diary.articles")])
+      (values article-id hash)))
+
+  (define (insert-article conn article)
+    (query-exec conn
+                "
+INSERT INTO diary.articles(article_id, timestamp, hash, title, body)
+VALUES($1, $2, $3, $4, $5)
+"
+                (article-id article)
+                (srfi-date->sql-timestamp-tz (article-timestamp article))
+                (article-hash article)
+                (article-title article)
+                (article-body article)))
+
+  (define (update-article conn article)
+    (query-exec conn
+                "
+UPDATE diary.articles
+   SET timestamp = $2,
+       hash = $3,
+       title = $4,
+       body = $5
+ WHERE article_id = $1
+       AND hash <> $3
+"
+                (article-id article)
+                (srfi-date->sql-timestamp-tz (article-timestamp article))
+                (article-hash article)
+                (article-title article)
+                (article-body article))))
+
+(require/typed/provide (submod "." untyped-db-ops)
+  [fetch-article (-> Connection String Article)]
+  [fetch-latest-articles (-> Connection Natural (Listof Article-With-Tags))]
+  [fetch-article-tags (-> Connection String (Listof String))]
+  [fetch-article-hashes (-> Connection (Immutable-HashTable String String))]
+  [fetch-article-taggings (-> Connection String (Setof Integer))]
+  [insert-article-tagging (-> Connection String Integer Void)]
+  [delete-article-tagging (-> Connection String Integer Void)]
+  [update-article (-> Connection Article Void)]
+  [insert-article (-> Connection Article Void)])
diff --git a/db/tags.rkt b/db/tags.rkt
new file mode 100644
index 0000000..eee2141
--- /dev/null
+++ b/db/tags.rkt
@@ -0,0 +1,27 @@
+#lang typed/racket
+(require typed/db)
+
+(module untyped-db-ops racket
+  (require db
+           db/util/datetime
+           "../entities/article.rkt")
+  (provide fetch-tag-ids
+           insert-tag)
+
+  (define (fetch-tag-ids conn)
+    (for/hash ([(name tag-id)
+                (in-query conn "SELECT name, tag_id FROM diary.tags")])
+      (values name tag-id)))
+
+  (define (insert-tag conn name)
+    (query-value conn
+                 "
+INSERT INTO diary.tags(name)
+VALUES($1)
+RETURNING tag_id
+"
+                 name)))
+
+(require/typed/provide (submod "." untyped-db-ops)
+  [fetch-tag-ids (-> Connection (Immutable-HashTable String Integer))]
+  [insert-tag (-> Connection String Integer)])