Add a script for registering articles.

1 files changed, 88 insertions, 0 deletions

diff --git a/scripts/register-articles.rkt b/scripts/register-articles.rkt
new file mode 100644
index 0000000..41a9ce5
--- /dev/null
+++ b/scripts/register-articles.rkt
@@ -0,0 +1,88 @@
+#lang typed/racket
+
+(require typed/db)
+(require "../entities/article.rkt")
+(require "../db/connection.rkt")
+(require "../db/articles.rkt")
+(require "../db/tags.rkt")
+(require "../readers/article.rkt")
+
+(: make-db-conn (-> String String Connection))
+(define (make-db-conn database user)
+  (connect #:database database #:user user #:socket 'guess))
+
+(: register-articles (-> Connection Path-String Void))
+(define (register-articles db-conn path)
+  (define article-hashes (fetch-article-hashes db-conn))
+  (call-with-input-file path
+    (lambda ([in : Input-Port])
+      (for/fold
+          ([tag-ids : (Immutable-HashTable String Integer)
+                    (fetch-tag-ids db-conn)])
+          ([article (in-port read-article in)])
+        (cond
+          [(hash-ref article-hashes (article-id article) #f)
+           => (lambda ([h : String])
+                (cond
+                  [(string=? h (article-hash article)) tag-ids]
+                  [else
+                   (update-article db-conn article)
+                   (begin0 (register-tags db-conn article tag-ids)
+                     (displayln (format "updated: ~a, ~a"
+                                (article-id article)
+                                (article-title article))))]))]
+          [else
+           (insert-article db-conn article)
+           (begin0 (register-tags db-conn article tag-ids)
+             (displayln (format "registered: ~a, ~a"
+                                (article-id article)
+                                (article-title article))))]))))
+  (void))
+
+(: register-tags (-> Connection
+                     Article-With-Tags
+                     (Immutable-HashTable String Integer)
+                     (Immutable-HashTable String Integer)))
+(define (register-tags db-conn article tag-ids)
+  (define (register-new-tags)
+    (for/fold ([s : (Setof Integer)
+                  (set)]
+               [tag-ids : (Immutable-HashTable String Integer)
+                        tag-ids]
+               [taggings : (Setof Integer)
+                         (fetch-article-taggings db-conn (article-id article))])
+              ([tag (article-tags article)])
+      (cond [(hash-ref tag-ids tag #f)
+             => (lambda ([tag-id : Integer])
+                  (values (set-add s tag-id)
+                          tag-ids
+                          taggings))]
+            [else
+             (let ([tag-id : Integer (insert-tag db-conn tag)])
+               (insert-article-tagging db-conn (article-id article) tag-id)
+               (values (set-add s tag-id)
+                       (hash-set tag-ids tag tag-id)
+                       (set-add taggings tag-id)))])))
+  (let-values ([(current-tag-ids tag-ids taggings)
+                (register-new-tags)])
+    (for ([tag-id (in-set (set-subtract taggings current-tag-ids))])
+      (delete-article-tagging db-conn (article-id article) tag-id))
+    tag-ids))
+
+(module+ main
+  (require racket/cmdline)
+  (define database (box "diary"))
+  (define username (box "postgres"))
+  (command-line #:program "register-articles"
+                #:once-each
+                [("-d" "--database") name
+                                     "Database name"
+                                     (set-box! database (assert name string?))]
+                [("-u" "--user") name
+                                 "Username"
+                                 (set-box! username (assert (assert name string?)))]
+                #:args (filename)
+                (let ([db-conn (make-db-conn (unbox database) (unbox username))])
+                  (call-with-transaction db-conn
+                    (thunk
+                     (register-articles db-conn (assert filename string?)))))))