Cleanup: moved major functions into their own modules
[kspaans/nntp-to-dot] / common.ss
1 ;; Copyright (C) 2009  Kyle Spaans
2 ;;  this program is distributed under the GPL v2 or (at your option)
3 ;;  any later version.
4
5 ;; Some common helper functions
6
7 #lang scheme
8
9 (require net/nntp)
10
11 (provide message-getter get-refs make-dot-id ins-user-id ins-mid-u from-regexp
12          mid-regexp ref-regexp subj-regexp date-regexp)
13
14 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
15
16 (define from-regexp (make-desired-header "From"))
17 (define mid-regexp (make-desired-header "Message-ID"))
18 (define ref-regexp (make-desired-header "References"))
19 (define subj-regexp (make-desired-header "Subject"))
20 (define date-regexp (make-desired-header "Date"))
21
22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23
24 ;; message-getter: newsgroup_connector number regexp -> (union string false)
25 ;; Do the dirty work of reading the message header info from the newsgroup.
26 ;; Returns false if the article cannot be retreived, and a string otherwise.
27 (define (message-getter group article headers)
28   (with-handlers ([article-not-in-group? (lambda (x) #f)])
29     (extract-desired-headers (head-of-message group article)
30                              headers)))
31
32 ;; get-refs: string -> (listof string)
33 ;; Given an NNTP "References:" header line, will extract all Message-IDs in it
34 (define references-regexp #rx"<[^>]*>")
35 (define (get-refs refline)
36   (let [(ref-match (regexp-match references-regexp refline))]
37     (cond
38       [(boolean? ref-match) empty]
39       [else (cons (car ref-match)
40                   (get-refs (substring refline
41                                        ;; Need to only go to the last matching
42                                        ;; index so that we don't go out of range
43                                        (cdar (regexp-match-positions
44                                                references-regexp
45                                                refline)))))])))
46
47 ;; make-dot-id: void -> string
48 ;; Generates a unique dot ID every time it is called, side effect of
49 ;; incrementing an internal counter is used.
50 ;; Turns an integer (internal counter) into a string of uppercase
51 ;; letters
52 (define counter -1)
53 ;;;;
54 (define (num2list num first)
55   (cond [(and (not first) (zero? num)) '()]
56         [else (cons (+ 65 (modulo num 26))
57                     (num2list (quotient num 26) false))]))
58 (define (num2letters num first)
59   (list->string (reverse
60     (map integer->char (num2list num first)))))
61 (define make-dot-id
62   (lambda ()
63       (begin
64         (set! counter (+ 1 counter))
65         (num2letters counter true))))
66
67 ;; ins-user-id: hash-table string string -> void
68 ;; Inserts user information into a hash table. Takes the table, the username
69 ;; (email address) and a message-id. user is used as the key and MID the
70 ;; value. Each user can post multiple messages, therefore MIDs are stored
71 ;; in another hash table along with the (date/time/order/count?) of the post
72 (define (ins-user-id htable user mid)
73   (let [(uresult (hash-ref htable user #f))]
74     (if (boolean? uresult)
75         ;; New user, create hash with MID
76         (local [(define new-user-htable (make-hash))]
77           (hash-set! new-user-htable mid 0) ; user date instead?
78           (hash-set! htable user new-user-htable))
79         ;; Add MID to hash table (MIDs are assumed to be unique
80         (hash-set! uresult mid (hash-count uresult)))))
81
82 ;; ins-mid-u: hash-table string string -> void
83 ;; Inserts message-ID information into a hash table. Takes the table, the message-id
84 ;; and a username (email address). MID is used as the key and user the
85 ;; value. MIDs are unique, but multiple MIDS may have the same user value
86 (define (ins-mid-u htable mid user)
87   (let [(mresult (hash-ref htable mid #f))]
88     (if (boolean? mresult)
89         ;; New MID, associate with user
90         (hash-set! htable mid user)
91         ;; Mid already exists?
92         (error 'mid-collision))))