blob: 41a9ce5670a6fa846ba766fa09cf4802242158ce (
about) (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
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?)))))))
|
