From f2b38856663df3afa4382fe31d47fc1f79cbb5ad Mon Sep 17 00:00:00 2001 From: Jon Zeppieri Date: Mon, 29 Aug 2011 21:46:03 -0400 Subject: [PATCH] Moved `net/nntp' code from unit to module. original commit: df5fef0c95631daca92d5dbbe5822765b43e8e5b --- collects/net/nntp-unit.rkt | 312 +------------------------------------ 1 file changed, 5 insertions(+), 307 deletions(-) diff --git a/collects/net/nntp-unit.rkt b/collects/net/nntp-unit.rkt index 408f0a9..0650418 100644 --- a/collects/net/nntp-unit.rkt +++ b/collects/net/nntp-unit.rkt @@ -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@)