(in-package #:com.liotev.nntp)
(defparameter *cache-authinfo-p* nil
"If t, the user name and password will be saved in the client
object.")
(defparameter *authinfo-file-name*
(str (user-homedir-pathname)
".authinfo")
"The authinfo file name.")
(defparameter *reconnect-on-timeout* t
"Controls if reconnecting is attempted after receiving timeout message
form the server.")
(defparameter *reconnect-on-error* t
"Controls if reconnecting is attempted after an error.")
(defparameter *use-tls* nil
"Controls if TLS is used for connecting to the server.")
(defparameter *authinfo-config-function*
(list 'read-authinfo-file 'ask-autinfo-from-user)
"Function used to read the authinfo configuration.")
(defparameter *clients* nil
"A list to hold all clients.")
(defstruct client
"An nntp client."
host port last-command status-code status-message
stream greating user pass group
article-id article-number tls-p)
(define-condition client-timeout (error)
((client :initarg :client
:reader client))
(:documentation
"A condition to be signaled when the NNTP server sends
a timeout message.")
(:report
(lambda (condition stream)
(let ((user (client-user (client condition)))
(host (client-host (client condition))))
(format stream
"Client ~A got timeout message from server ~A~%"
(str user "@" host) host)))))
(defun open-stream-to-server
(host port &key (use-tls nil use-tls-supplied?))
(let ((stream (usocket:socket-stream
(usocket:socket-connect host port))))
(if use-tls-supplied?
(if use-tls (cl+ssl:make-ssl-client-stream stream)
(values stream nil))
(if (or (string= (str port) "563")
(string= (str port) "443")
*use-tls*)
(values (cl+ssl:make-ssl-client-stream stream) t)
(values stream nil)))))
(defun connect (host port &optional client
&key auth (use-tls nil use-tls-supplied?))
"Connects to the host. If a client is supplied just reconnects the
client."
(format t "-> Connecting to ~a:~a~%" host port)
(multiple-value-bind (stream tls-p)
(if use-tls-supplied?
(open-stream-to-server host port :use-tls use-tls)
(open-stream-to-server host port))
(let ((server-greeting (if tls-p (read-line-tls stream)
(read-line stream))))
(format t "<- ~a~%" server-greeting)
(force-output)
(if (check-status-code (subseq server-greeting 0 3) '("200" "201"))
(if (null client)
(let ((new-client
(make-new-client host port stream server-greeting
tls-p)))
(register-client new-client)
(when auth (authenticate-client new-client)))
(progn
(reset-client client host port stream server-greeting
tls-p)
(when auth (authenticate-client client))))
(error "Invalid server response: ~a~%" server-greeting)))))
(defun authenticate-client (client)
(dolist (func *authinfo-config-function*)
(let ((user-and-pass (funcall func (client-host client))))
(when user-and-pass
(apply #'authinfo
(append user-and-pass
(list client)))
(return client)))))
(defun make-new-client (host port stream server-greeting tls-p)
(make-client
:host host
:port port
:stream stream
:status-message server-greeting
:greating server-greeting
:status-code (subseq server-greeting 0 3)
:tls-p tls-p))
(defun reset-client (client host port stream server-greeting tls-p)
(setf (client-host client) host)
(setf (client-port client) port)
(setf (client-stream client) stream)
(setf (client-greating client) server-greeting)
(setf (client-status-code client) (subseq server-greeting 0 3))
(setf (client-tls-p client) tls-p)
client)
(defun do-command
(command client
&key (reconnect t reconnect-supplied-p))
"Sends the command to the server. In case of a timeout message from
the server, a reconnect will be attempted in the following cases:
* the 'reconnect' key is supplied and it is t
* the 'reconnect' key is not supplied and *reconnect-on-timeout* is t
In case of another error, a reconnect will be attempted if
*reconnect-on-error* is t.
"
(if (or (and reconnect-supplied-p reconnect)
(and (not reconnect-supplied-p) *reconnect-on-timeout*))
(handler-bind ((client-timeout #'reconnect)
(error #'(lambda (c)
(when *reconnect-on-error*
(reconnect c)))))
(send-command command client))
(send-command command client)))
(defun reconnect (condition)
"Function for the 'rconnect' restart"
(format t "A condition of type ~a was signaled: ~A~%"
(type-of condition) condition)
(force-output)
(when (find-restart 'reconnect)
(invoke-restart 'reconnect)) )
(defun send-command (command client)
"Sends the command to the server."
(setf (client-last-command client) command)
(restart-case
(progn (client-write-line command client)
(when (string= (get-status client) "480")
(authenticate-client client)
(client-write-line command client)
(get-status client))
(when (timeout? client)
(error 'client-timeout :client client))
(values (client-status-code client)
(client-status-message client)))
(reconnect ()
(format t "Reconnecting to server ~A~%" (client-host client))
(force-output)
(reconnect-client client)
(let ((*reconnect-on-error* nil))
(send-command command client)))))
(defun timeout? (client)
(when (and (string= "503" (client-status-code client))
(or (search "time out" (client-status-message client))
(search "timeout" (client-status-message client))))
t))
(defun group (group-name client)
"The GROUP nntp command.
Syntax
GROUP group
Responses
211 number low high group Group successfully selected
411 No such newsgroup
Parameters
group Name of newsgroup
number Estimated number of articles in the group
low Reported low water mark
high Reported high water mark
"
(setf (client-group client) group-name)
(do-command (str "group " group-name) client))
(defun listgroup (group-name client)
"The LISTGROUP nntp command.
Syntax
LISTGROUP group
Responses
211 number low high group Group successfully selected
411 No such newsgroup
Parameters
group Name of newsgroup
number Estimated number of articles in the group
low Reported low water mark
high Reported high water mark
"
(setf (client-group client) group-name)
(let ((result (do-command (str "listgroup " group-name) client)))
(values (mapcar (lambda (it)
(parse-integer it :junk-allowed t))
(get-multi-line-response client))
result)))
(defun article (client
&key article-number article-id)
"Retreives an article.
Syntax
ARTICLE message-id
ARTICLE number
ARTICLE
Responses
First form (message-id specified)
220 0|n message-id Article follows (multi-line)
430 No article with that message-id
Second form (article number specified)
220 n message-id Article follows (multi-line)
412 No newsgroup selected
423 No article with that number
Third form (current article number used)
220 n message-id Article follows (multi-line)
412 No newsgroup selected
420 Current article number is invalid
Parameters
number Requested article number
n Returned article number
message-id Article message-id
"
(article-command "article" client :article-number article-number
:article-id article-id)
(when (string= "220" (client-status-code client))
(get-block-response client)))
(defun head (client &key article-number article-id)
"Retreives the article headers.
Syntax
HEAD message-id
HEAD number
HEAD
Responses
First form (message-id specified)
221 0|n message-id Headers follow (multi-line)
430 No article with that message-id
Second form (article number specified)
221 n message-id Headers follow (multi-line)
412 No newsgroup selected
423 No article with that number
Third form (current article number used)
221 n message-id Headers follow (multi-line)
412 No newsgroup selected
420 Current article number is invalid
"
(article-command "head" client :article-number article-number
:article-id article-id)
(when (string= "221" (client-status-code client))
(get-block-response client)))
(defun body (client &key article-number article-id)
"Retreives the article body
Syntax
BODY message-id
BODY number
BODY
Responses
First form (message-id specified)
222 0|n message-id Body follows (multi-line)
430 No article with that message-id
Second form (article number specified)
222 n message-id Body follows (multi-line)
412 No newsgroup selected
423 No article with that number
Third form (current article number used)
222 n message-id Body follows (multi-line)
412 No newsgroup selected
420 Current article number is invalid
Parameters
number Requested article number
n Returned article number
message-id Article message-id
"
(article-command "body" client :article-number article-number
:article-id article-id)
(when (string= "222" (client-status-code client))
(get-block-response client)))
(defun stat (client &key article-number article-id)
"Determines if an article exists, or the message
id of the article.
Syntax
STAT message-id
STAT number
STAT
Responses
First form (message-id specified)
223 0|n message-id Article exists
430 No article with that message-id
Second form (article number specified)
223 n message-id Article exists
412 No newsgroup selected
423 No article with that number
Third form (current article number used)
223 n message-id Article exists
412 No newsgroup selected
420 Current article number is invalid
Parameters
number Requested article number
n Returned article number
message-id Article message-id
"
(article-command "stat" client :article-number article-number
:article-id article-id))
(defun capabilities (client)
"Lists the capabilities of the server.
Syntax
CAPABILITIES [keyword]
Responses
101 Capability list follows (multi-line)
"
(block-command "CAPABILITIES" (list "101") client))
(defun help (client)
(block-command "help" (list "100") client))
(defun block-command (command valid-codes
client)
"Sends a command that expects a block and retreives the block
response."
(do-command command client)
(when (find (client-status-code client) valid-codes :test #'string=)
(get-block-response client)))
(defun article-command (command client
&key article-number article-id)
"Performs an articla related command. Can be one of 'ARTICLE', 'HEAD',
'BODY', 'STAT'."
(if (and (null article-number)
(null article-id))
(do-command command client)
(let ((full-command
(string-trim " " (str command " "
(if (null article-number)
article-id
article-number)))))
(set-article client :article-number article-number
:article-id article-id)
(do-command full-command client))))
(defun set-article (client &key article-number article-id)
"Sets the article in the client"
(setf (client-article-number client) article-number
(client-article-id client) article-id))
(defun get-status (client)
"Reads the status line of the server response, retrurn status code and
status message."
(let ((line (client-read-line client)))
(if line
(progn
(format t "<- ~A~%" line)
(force-output)
(let ((status-code (subseq line 0 (position #\space line)))
(status-message (subseq line (1+ (position #\space line)))))
(setf (client-status-message client) status-message
(client-status-code client) status-code)
(values status-code status-message)))
(error "No response from the server"))))
(defun get-multi-line-response (client)
(loop for line = (cl-nntp::client-read-line client)
until (string= line #.(coerce #(#\. #\return) 'string))
collect
(if (and (> (length line) 2)
(string= ".." line :end2 2))
(subseq line 1)
line)))
(defun authinfo (user pass client)
"Authenticates the client."
(when (null client) (error "Can not authenticate NIL client"))
(when *cache-authinfo-p*
(setf (client-user client) user)
(setf (client-pass client) pass))
(authinfo-user user client)
(cond ((string= (client-status-code client) "381")
(authinfo-pass pass client)
(cond ((string= (client-status-code client) "281")
client)
(t (error "Couldnt authenticate client: ~a"
(client-status-message client)))))
(t (error "Couldnt authenticate client: ~a"
(client-status-message client)))))
(defun register-client (client)
(format t "Registering client ~a ~%" (client-name client))
(when (null (find client *clients* :test #'eq))
(format t "Adding client to *clients*~%")
(setf *clients* (cons client *clients*))))
(defun client-name (client)
(let ((name (str (client-host client) ":" (client-port client)))
(user (client-user client)))
(if user (str user "@" name) name)))
(defun authinfo-user (user client)
"Sends the 'authinfo user' command."
(let ((command (str "AUTHINFO USER " user)))
(client-write-line command client)
(get-status client)))
(defun authinfo-pass (pass client)
"Sends the 'authinfo pass' command."
(let ((command (str "AUTHINFO PASS " pass)))
(client-write-line command client)
(get-status client)))
(defun date (client)
(do-command "date" client))
(defun last-article (client)
(do-command "last" client))
(defun next-article (client)
(do-command "next" client))
(defun get-block-response (client)
"Reads a block response."
(let ((stream (client-stream client)))
(with-output-to-string (s)
(loop
(multiple-value-bind (line nl)
(client-read-line client nil stream)
;; (format t "<- ~A~%" line)
(when (or (string= line ".
")
(string= line ".")
(eq line stream))
(return s))
(write-string line s)
(unless nl
(write-char #\Newline s)))))))
(defun check-status-code (status-code valid-codes)
(if (find status-code valid-codes :test #'string=)
status-code
nil))
(defun disconnect-client (client)
(let ((stream (client-stream client)))
(when (or (null stream)
(not (open-stream-p stream)))
(format t "Client ~a:~a is not connected.~%"
(client-host client) (client-port client))
(return-from disconnect-client client))
(close stream)
(if (open-stream-p stream)
(error "Couldn't close stream: ~A~%" stream)
(setf (client-stream client) nil))
client))
(defun destroy-client (client)
(disconnect-client client)
(setf *clients* (delete client *clients*)))
(defun reconnect-client (client)
(connect (client-host client) (client-port client) client)
(when (client-group client)
(let ((command (str "group " (client-group client))))
(client-write-line command client)
(get-status client)))
(cond ((client-article-number client)
(client-write-line
(str "stat " (client-article-number client))
(get-status client)))
((client-article-id client)
(client-write-line (str "stat " (client-article-id client)) client)
(get-status client))
(t nil)))
(defun read-authinfo-file (server-name &optional
(file-name *authinfo-file-name*))
"Reads user name and passwords from authinfo file."
(when (not (probe-file file-name))
(return-from read-authinfo-file nil))
(let ((lines (split-sequence #\newline (slurp-file file-name))))
(loop for line in lines
do (let ((tokens (split-sequence #\space line)))
(when (and (string= server-name (cadr tokens))
(>= (length tokens) 6))
(return-from read-authinfo-file
(list (fourth tokens) (sixth tokens))))))))
(defun read-line-tls (tls-stream &optional (eof-error-p t) (eof-value nil)
&key max-length)
"Reads a line from a TLS (SSL) stream."
(with-output-to-string (s)
(do ((b (read-byte tls-stream) (read-byte tls-stream))
(count 0 (1+ count)))
((eq (code-char b) #\newline))
(when (eq b 'eof)
(if (and eof-error-p (= 0 (length s)))
(return-from read-line-tls (values eof-value t))
(return-from read-line-tls (values s t))))
(write-char (code-char b) s)
(when (and max-length (> count max-length))
(error "Line to long: ~a~%." s)))
s))
(defun write-line-tls (line tls-stream )
"Writes a line to a TLS (SSL) stream."
(let ((new-line (if (position #\newline line
:start (1- (length line)))
line
(str line #\newline))))
(format t "-> ~a" new-line)
(write-sequence (babel:string-to-octets new-line)
tls-stream)))
(defun client-read-line (client &optional (eof-error-p t) (eof-value nil))
(if (client-tls-p client)
(read-line-tls (client-stream client))
(read-line (client-stream client)
eof-error-p eof-value)))
(defun client-write-line (line client)
(if (client-tls-p client)
(write-line-tls line (client-stream client))
(progn
(format t "-> ~a~%" line)
(write-line (str line #\newline) (client-stream client))))
(force-output (client-stream client)))
(defun ask-autinfo-from-user (server-name)
(format t "Please enter user name for server ~a~%"
server-name)
(let ((user-name (read-line)))
(format t "Please enter password for server ~a~%"
server-name)
(let ((passw (read-line)))
(list user-name passw))))