userstats function initial implementation
[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 (require srfi/19)
11
12 (provide message-getter get-refs make-dot-id ins-user-id ins-mid-u from-regexp
13          mid-regexp ref-regexp subj-regexp date-regexp get-date)
14
15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
16
17 (define from-regexp (make-desired-header "From"))
18 (define mid-regexp (make-desired-header "Message-ID"))
19 (define ref-regexp (make-desired-header "References"))
20 (define subj-regexp (make-desired-header "Subject"))
21 (define date-regexp (make-desired-header "Date"))
22
23 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24
25 ;; message-getter: newsgroup_connector number regexp -> (union string false)
26 ;; Do the dirty work of reading the message header info from the newsgroup.
27 ;; Returns false if the article cannot be retreived, and a string otherwise.
28 (define (message-getter group article headers)
29   (with-handlers ([article-not-in-group? (lambda (x) #f)])
30     (extract-desired-headers (head-of-message group article)
31                              headers)))
32
33 ;; get-refs: string -> (listof string)
34 ;; Given an NNTP "References:" header line, will extract all Message-IDs in it
35 (define references-regexp #rx"<[^>]*>")
36 (define (get-refs refline)
37   (let [(ref-match (regexp-match references-regexp refline))]
38     (cond
39       [(boolean? ref-match) empty]
40       [else (cons (car ref-match)
41                   (get-refs (substring refline
42                                        ;; Need to only go to the last matching
43                                        ;; index so that we don't go out of range
44                                        (cdar (regexp-match-positions
45                                                references-regexp
46                                                refline)))))])))
47
48 ;; make-dot-id: void -> string
49 ;; Generates a unique dot ID every time it is called, side effect of
50 ;; incrementing an internal counter is used.
51 ;; Turns an integer (internal counter) into a string of uppercase
52 ;; letters
53 (define counter -1)
54 ;;;;
55 (define (num2list num first)
56   (cond [(and (not first) (zero? num)) '()]
57         [else (cons (+ 65 (modulo num 26))
58                     (num2list (quotient num 26) false))]))
59 (define (num2letters num first)
60   (list->string (reverse
61     (map integer->char (num2list num first)))))
62 (define make-dot-id
63   (lambda ()
64       (begin
65         (set! counter (+ 1 counter))
66         (num2letters counter true))))
67
68 ;; ins-user-id: hash-table string string -> void
69 ;; Inserts user information into a hash table. Takes the table, the username
70 ;; (email address) and a message-id. user is used as the key and MID the
71 ;; value. Each user can post multiple messages, therefore MIDs are stored
72 ;; in another hash table along with the (date/time/order/count?) of the post
73 (define (ins-user-id htable user mid)
74   (let [(uresult (hash-ref htable user #f))]
75     (if (boolean? uresult)
76         ;; New user, create hash with MID
77         (local [(define new-user-htable (make-hash))]
78           (hash-set! new-user-htable mid 0) ; user date instead?
79           (hash-set! htable user new-user-htable))
80         ;; Add MID to hash table (MIDs are assumed to be unique
81         (hash-set! uresult mid (hash-count uresult)))))
82
83 ;; ins-mid-u: hash-table string string -> void
84 ;; Inserts message-ID information into a hash table. Takes the table, the message-id
85 ;; and a username (email address). MID is used as the key and user the
86 ;; value. MIDs are unique, but multiple MIDS may have the same user value
87 (define (ins-mid-u htable mid user)
88   (let [(mresult (hash-ref htable mid #f))]
89     (if (boolean? mresult)
90         ;; New MID, associate with user
91         (hash-set! htable mid user)
92         ;; Mid already exists?
93         (error 'mid-collision))))
94
95 ;; get-date: string -> date
96 ;; Returns an SRFI-19 date object based on the date header from the newsgroup
97 ;; Date headers seem to be either 32,36,37,42 or 43 chars long
98 ;;   can this be generalized better?
99 (define (get-date date-str)
100   (let [(mlen (string-length date-str))]
101     (cond
102       [(= 32 mlen) (string->date (substring date-str 6)
103                                  "~d ~b ~Y ~H:~M:~S ~z")]
104       [(= 36 mlen) (string->date (substring date-str 6)
105                                  "~a, ~d ~b ~Y ~H:~M:~S ~z")]
106       [(= 37 mlen) (string->date (substring date-str 6)
107                                  "~a, ~d ~b ~Y ~H:~M:~S ~z")]
108       [(= 42 mlen) (string->date (substring date-str 6)
109                                  "~a, ~d ~b ~Y ~H:~M:~S ~z")]
110       [(= 43 mlen) (string->date (substring date-str 6)
111                                  "~a, ~d ~b ~Y ~H:~M:~S ~z")]
112       [else (printf "date string was unknown length ~a~n" mlen) #xDEADBEEF])))