git.csclub.uwaterloo.ca Git - kspaans/nntp-to-dot/blob - 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])))