suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Moved `net/nntp' code from unit to module.

Browse Source 
original commit: df5fef0c95631daca92d5dbbe5822765b43e8e5b
This commit is contained in:
Jon Zeppieri 2011-08-29 21:46:03 -04:00 committed by Eli Barzilay
parent 78bce17be3
commit f2b3885666
1 changed files with 5 additions and 307 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

312
collects/net/nntp-unit.rkt
View File

@ -1,310 +1,8 @@
#lang racket/unit
#lang racket/base
(require racket/tcp "nntp-sig.rkt")
(require racket/unit
"nntp-sig.rkt" "nntp.rkt")
(import)
(export nntp^)
(define-unit-from-context nntp@ nntp^)
;; sender : oport
;; receiver : iport
;; server : string
;; port : number
(define-struct communicator (sender receiver server port))
;; code : number
;; text : string
;; line : string
;; communicator : communicator
;; group : string
;; article : number
(define-struct (nntp exn) ())
(define-struct (unexpected-response nntp) (code text))
(define-struct (bad-status-line nntp) (line))
(define-struct (premature-close nntp) (communicator))
(define-struct (bad-newsgroup-line nntp) (line))
(define-struct (non-existent-group nntp) (group))
(define-struct (article-not-in-group nntp) (article))
(define-struct (no-group-selected nntp) ())
(define-struct (article-not-found nntp) (article))
(define-struct (authentication-rejected nntp) ())
;; signal-error :
;; (exn-args ... -> exn) x format-string x values ... ->
;; exn-args -> ()
;; - throws an exception
(define (signal-error constructor format-string . args)
(lambda exn-args
(raise (apply constructor
(apply format format-string args)
(current-continuation-marks)
exn-args))))
;; default-nntpd-port-number :
;; number
(define default-nntpd-port-number 119)
;; connect-to-server*:
;; input-port output-port -> communicator
(define connect-to-server*
(case-lambda
[(receiver sender)
(connect-to-server* receiver sender "unspecified" "unspecified")]
[(receiver sender server-name port-number)
(file-stream-buffer-mode sender 'line)
(let ([communicator (make-communicator sender receiver server-name
port-number)])
(let-values ([(code response)
(get-single-line-response communicator)])
(case code
[(200 201) communicator]
[else ((signal-error make-unexpected-response
"unexpected connection response: ~s ~s"
code response)
code response)])))]))
;; connect-to-server :
;; string [x number] -> commnicator
(define connect-to-server
(lambda (server-name (port-number default-nntpd-port-number))
(let-values ([(receiver sender)
(tcp-connect server-name port-number)])
(connect-to-server* receiver sender server-name port-number))))
;; close-communicator :
;; communicator -> ()
(define (close-communicator communicator)
(close-input-port (communicator-receiver communicator))
(close-output-port (communicator-sender communicator)))
;; disconnect-from-server :
;; communicator -> ()
(define (disconnect-from-server communicator)
(send-to-server communicator "QUIT")
(let-values ([(code response)
(get-single-line-response communicator)])
(case code
[(205)
(close-communicator communicator)]
[else
((signal-error make-unexpected-response
"unexpected dis-connect response: ~s ~s"
code response)
code response)])))
;; authenticate-user :
;; communicator x user-name x password -> ()
;; the password is not used if the server does not ask for it.
(define (authenticate-user communicator user password)
(define (reject code response)
((signal-error make-authentication-rejected
"authentication rejected (~s ~s)"
code response)))
(define (unexpected code response)
((signal-error make-unexpected-response
"unexpected response for authentication: ~s ~s"
code response)
code response))
(send-to-server communicator "AUTHINFO USER ~a" user)
(let-values ([(code response) (get-single-line-response communicator)])
(case code
[(281) (void)] ; server doesn't ask for a password
[(381)
(send-to-server communicator "AUTHINFO PASS ~a" password)
(let-values ([(code response)
(get-single-line-response communicator)])
(case code
[(281) (void)] ; done
[(502) (reject code response)]
[else (unexpected code response)]))]
[(502) (reject code response)]
[else (reject code response)
(unexpected code response)])))
;; send-to-server :
;; communicator x format-string x list (values) -> ()
(define (send-to-server communicator message-template . rest)
(let ([sender (communicator-sender communicator)])
(apply fprintf sender
(string-append message-template "\r\n")
rest)
(flush-output sender)))
;; parse-status-line :
;; string -> number x string
(define (parse-status-line line)
(if (eof-object? line)
((signal-error make-bad-status-line "eof instead of a status line")
line)
(let ([match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line)
((signal-error make-bad-status-line
"malformed status line: ~s" line)
line)))])
(values (string->number (car match))
(cadr match)))))
;; get-one-line-from-server :
;; iport -> string
(define (get-one-line-from-server server->client-port)
(read-line server->client-port 'return-linefeed))
;; get-single-line-response :
;; communicator -> number x string
(define (get-single-line-response communicator)
(let* ([receiver (communicator-receiver communicator)]
[status-line (get-one-line-from-server receiver)])
(parse-status-line status-line)))
;; get-rest-of-multi-line-response :
;; communicator -> list (string)
(define (get-rest-of-multi-line-response communicator)
(let ([receiver (communicator-receiver communicator)])
(let loop ([r '()])
(let ([l (get-one-line-from-server receiver)])
(cond
[(eof-object? l)
((signal-error make-premature-close
"port prematurely closed during multi-line response")
communicator)]
[(string=? l ".") (reverse r)]
[(string=? l "..") (loop (cons "." r))]
[else (loop (cons l r))])))))
;; get-multi-line-response :
;; communicator -> number x string x list (string)
;; -- The returned values are the status code, the rest of the status
;; response line, and the remaining lines.
(define (get-multi-line-response communicator)
(let* ([receiver (communicator-receiver communicator)]
[status-line (get-one-line-from-server receiver)])
(let-values ([(code rest-of-line)
(parse-status-line status-line)])
(values code rest-of-line (get-rest-of-multi-line-response communicator)))))
;; open-news-group :
;; communicator x string -> number x number x number
;; -- The returned values are the number of articles, the first
;; article number, and the last article number for that group.
(define (open-news-group communicator group-name)
(send-to-server communicator "GROUP ~a" group-name)
(let-values ([(code rest-of-line)
(get-single-line-response communicator)])
(case code
[(211)
(let ([match (map string->number
(cdr
(or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line)
((signal-error make-bad-newsgroup-line
"malformed newsgroup open response: ~s"
rest-of-line)
rest-of-line))))])
(let ([number-of-articles (car match)]
[first-article-number (cadr match)]
[last-article-number (caddr match)])
(values number-of-articles
first-article-number
last-article-number)))]
[(411)
((signal-error make-non-existent-group
"group ~s does not exist on server ~s"
group-name (communicator-server communicator))
group-name)]
[else
((signal-error make-unexpected-response
"unexpected group opening response: ~s" code)
code rest-of-line)])))
;; generic-message-command :
;; string x number -> communicator x (number U string) -> list (string)
(define (generic-message-command command ok-code)
(lambda (communicator message-index)
(send-to-server communicator (string-append command " ~a")
(if (number? message-index)
(number->string message-index)
message-index))
(let-values ([(code response)
(get-single-line-response communicator)])
(if (= code ok-code)
(get-rest-of-multi-line-response communicator)
(case code
[(423)
((signal-error make-article-not-in-group
"article id ~s not in group" message-index)
message-index)]
[(412)
((signal-error make-no-group-selected
"no group selected"))]
[(430)
((signal-error make-article-not-found
"no article id ~s found" message-index)
message-index)]
[else
((signal-error make-unexpected-response
"unexpected message access response: ~s" code)
code response)])))))
;; head-of-message :
;; communicator x (number U string) -> list (string)
(define head-of-message
(generic-message-command "HEAD" 221))
;; body-of-message :
;; communicator x (number U string) -> list (string)
(define body-of-message
(generic-message-command "BODY" 222))
;; newnews-since :
;; communicator x (number U string) -> list (string)
(define newnews-since
(generic-message-command "NEWNEWS" 230))
;; make-desired-header :
;; string -> desired
(define (make-desired-header raw-header)
(regexp
(string-append
"^"
(list->string
(apply append
(map (lambda (c)
(cond
[(char-lower-case? c)
(list #\[ (char-upcase c) c #\])]
[(char-upper-case? c)
(list #\[ c (char-downcase c) #\])]
[else
(list c)]))
(string->list raw-header))))
":")))
;; extract-desired-headers :
;; list (string) x list (desired) -> list (string)
(define (extract-desired-headers headers desireds)
(filter (lambda (header)
(ormap (lambda (matcher) (regexp-match matcher header))
desireds))
headers))
(provide nntp@)