diff --git a/collects/net/nntp-unit.rkt b/collects/net/nntp-unit.rkt index 408f0a9059..0650418617 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@) diff --git a/collects/net/nntp.rkt b/collects/net/nntp.rkt index 816aa5047d..da8ae8dfdb 100644 --- a/collects/net/nntp.rkt +++ b/collects/net/nntp.rkt @@ -1,6 +1,325 @@ #lang racket/base -(require racket/unit "nntp-sig.rkt" "nntp-unit.rkt") -(define-values/invoke-unit/infer nntp@) +(require racket/tcp) -(provide-signature-elements nntp^) +(provide (struct-out communicator) + connect-to-server connect-to-server* disconnect-from-server + authenticate-user open-news-group + head-of-message body-of-message + newnews-since generic-message-command + make-desired-header extract-desired-headers + + (struct-out nntp) + (struct-out unexpected-response) + (struct-out bad-status-line) + (struct-out premature-close) + (struct-out bad-newsgroup-line) + (struct-out non-existent-group) + (struct-out article-not-in-group) + (struct-out no-group-selected) + (struct-out article-not-found) + (struct-out authentication-rejected)) + +;; 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)) diff --git a/collects/net/scribblings/nntp.scrbl b/collects/net/scribblings/nntp.scrbl index d63ceca3c2..dbace6999d 100644 --- a/collects/net/scribblings/nntp.scrbl +++ b/collects/net/scribblings/nntp.scrbl @@ -135,6 +135,10 @@ Raised when the server reject an authentication attempt.} @section{NNTP Unit} +@margin-note{@racket[nntp@] and @racket[nntp^] are deprecated. +They exist for backward-compatibility and will likely be removed in +the future. New code should use the @racketmodname[net/nntp] module.} + @defmodule[net/nntp-unit] @defthing[nntp@ unit?]{