;;; -*- Mode:Common-Lisp; Package:NNTP; Base:10; Fonts:(CPTFONT HL12B HL12I MEDFNB) -*-


(defparameter 4*TIMEOUT** 60.
  "2Open connection timeout period (in seconds).*")

(defparameter 4*REMOTE-PORT** 119.
  "2TCP Port number of remote NNTP server.*")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;1;;*
;1;; NNTP Response codes*
;1;;*
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defparameter 4*HELP-CODE** 100.)

(defparameter 4*SERVER-READY-WITH-POSTING-CODE** 200.)

(defparameter 4*SERVER-READY-WITHOUT-POSTING-CODE** 201.)

(defparameter 4*CLOSING-CONNECTION-CODE** 205.)

(defparameter 4*GROUP-SELECTED-CODE** 211.)

(defparameter 4*LIST-CODE** 215.)

(defparameter 4*ARTICLE-RETRIEVED-HEAD-AND-BODY-FOLLOW-CODE** 220.)

(defparameter 4*ARTICLE-RETRIEVED-HEAD-FOLLOWS-CODE** 221.)

(defparameter 4*ARTICLE-RETRIEVED-BODY-FOLLOWS-CODE** 222.)

(defparameter 4*ARTICLE-RETRIEVED-REQUEST-TEXT-SEPARATELY-CODE** 223.)

(defparameter 4*LIST-OF-NEW-NEWSGROUPS-FOLLOWS-CODE** 230.)

(defparameter 4*ARTICLE-POSTED-OK-CODE** 240.)

(defparameter 4*SEND-ARTICLE-TO-BE-POSTED-CODE** 340.)

(defparameter 4*NO-SUCH-GROUP-CODE** 411.)

(defparameter 4*NO-SELECTED-NEWSGROUP-CODE** 412.)

(defparameter 4*POSTING-NOT-ALLOWED-CODE** 440.)

(defparameter 4*POSTING-FAILED-CODE** 441.)

(defparameter 4*ERROR-CODES** `((,*NO-SELECTED-NEWSGROUP-CODE* . *NO-SELECTED-NEWSGROUP-CODE*)
				  (,*NO-SUCH-GROUP-CODE* . *NO-SUCH-GROUP-CODE*)
				  (,*POSTING-NOT-ALLOWED-CODE* . *POSTING-NOT-ALLOWED-CODE*)
				  (,*POSTING-FAILED-CODE* . *POSTING-FAILED-CODE*)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;1;;*
;1;; NNTP COMMANDS*
;1;;*
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun 4ARTICLE-COMMAND* (nntp-stream article-id &optional (error t))
  "2Send the ARTICLE command to the NNTP server.  The article-id is
either the message-id string or the article number from the current newsgroup.
Return T and the response string if successful.  If error is set to T then signal
an error condition if no such article exists.  If error is set to NIL then return
NIL and the response string if no such article exists.*"
  (write-command-and-validate nntp-stream (format nil "article ~a" article-id) *article-retrieved-head-and-body-follow-code*
			      error))


(defun 4BODY-COMMAND* (nntp-stream article-id &optional (error t))
  "2Send the BODY command to the NNTP server.  The article-id is either
the message-id string or the article number from the current newsgroup.  Return
T and the response string if successful.  If error is set to t then signal an error
condition if no such article exists.  If error is set to NIL then return NIL and the
response string if no such article exists.*"
  (write-command-and-validate nntp-stream (format nil "body ~a" article-id) *article-retrieved-body-follows-code* error))


(defun 4CLOSE-NNTP-STREAM* (nntp-stream)
  "2Close the NNTP connection.*"
  (if (streamp nntp-stream)
      (close nntp-stream))
  t)


(defun 4FLUSH-NNTP-STREAM* (nntp-stream)
  "2Flush the output from the NNTP stream.  Return :EOF when completed.*"
  (let (line eof)
    (loop
      (multiple-value-setq (line eof) (send nntp-stream :line-in nil))
      (and eof (return :eof)))))


(defun 4GROUP-COMMAND* (nntp-stream newsgroup &optional (error t))
  "2Send the GROUP command to the NNTP server.  Return T and the
response string if successful.  If error is set to t then signal an error condition if
no such group exists.  If error is set to NIL then return NIL and the response
string if no such group exists.*"
  (write-command-and-validate nntp-stream (format nil "group ~a" newsgroup) *group-selected-code* error))


(defun 4HEAD-COMMAND* (nntp-stream article-id &optional (error t))
  "2Send the HEAD command to the NNTP server.  The article-id is either
the message-id string or the article number from the current newsgroup.  Return
T and the response string if successful.  If error is set to t then signal an error
condition if no such article exists.  If error is set to NIL then return NIL and the
response string if no such article exists.*"
  (write-command-and-validate nntp-stream (format nil "head ~a" article-id) *article-retrieved-head-follows-code* error))


(defun 4HELP-COMMAND* (nntp-stream &optional (error t))
  "2Send the HELP command to the NNTP server.  Return T and the
response string if successful.  If error is set to t then signal an error condition if
help is unavailable.  If error is set to NIL then return NIL and the response string
if help is unavailable.*"
  (write-command-and-validate nntp-stream "help" *help-code* error))


(defun 4LIST-COMMAND* (nntp-stream &optional (error t))
  "2Send the LIST command to the NNTP server.  Return T and the
response string if successful.  If error is set to t then signal an error condition if
unsuccessful.  If error is set to NIL then return NIL and the response string if
unsuccessful.*"
  (write-command-and-validate nntp-stream "list" *list-code* error))


(defun 4NEWNEWS-COMMAND* (nntp-stream newsgroups date time &optional (error t))
  "2Send the NEWNEWS command to the NNTP server.  The DATE string
is in the format YYMMDD.  The TIME string is in the format HHMMSS.  Return
T and the response string if successful.  If error is set to t then signal an error
condition if unsuccessful.  If error is set to NIL then return NIL and the response
string if unsuccessful.*"
  (write-command-and-validate nntp-stream (format nil "newnews ~a ~a ~a" newsgroups date time)
			      *list-of-new-newsgroups-follows-code* error))


(defun 4OPEN-NNTP-STREAM* (host &optional (error t))
  "2Open the NNTP server and return the stream, server status value and server message.
If error is T then signal an error.  If error is nil then return an error object.*"
  (let (server-status server-message
	(nntp-stream (open-nntp-stream-1 host :error error)))
    (cond
      ((errorp nntp-stream)
       nntp-stream)
      (t
       (multiple-value-setq (server-status server-message) (read-response-code-from-nntp-stream nntp-stream t))
       (cond
	 ((not (or (equal server-status *server-ready-with-posting-code*)
		   (equal server-status *server-ready-without-posting-code*)))
	  (close-nntp-stream nntp-stream)
	  (if error
	      (ferror 'nntp-open "~a" server-message)
	      (make-instance 'ferror :condition-names '(nntp-open) :format-string "~a" :format-args (list server-message))))
	 (t
	  (values nntp-stream server-status server-message)))))))


(defun 4POST-COMMAND* (nntp-stream &optional (error t))
  "2Send the POST command to the NNTP server.  If error is set to t then
signal an error condition if unsuccessful.  If error is set to NIL then return NIL
and the response string if unsuccessful.*"
  (write-command-and-validate nntp-stream "post" *send-article-to-be-posted-code* error))


(defun 4POSTEND-COMMAND* (nntp-stream &optional (error t))
  "2Complete the posting.  Return T and the response string if successful.  If
error is set to t then signal an error condition if posting failed.  If error is set
to NIL then return NIL and the response string if posting failed.*"
  (write-text nntp-stream (format nil "~%"))
  (write-end-of-text nntp-stream)
  (multiple-value-bind (code response-string) (read-response-code-from-nntp-stream nntp-stream)
    (cond
      ((equal code *article-posted-ok-code*)
       (values t response-string))
      (t
       (if error
	   (ferror code (format nil "~a" response-string))
	   (values nil response-string))))))


(defun 4PRINT-NNTP-STREAM* (nntp-stream &optional (output-stream t))
  "2Print the contents of the NNTP stream to output-stream (until eof).
When output-stream is T then *standard-output* is used.  Return the number
of lines printed.*"
  (loop with count = 0 do
    (multiple-value-bind (line eof) (read-nntp-stream nntp-stream)
      (cond
	(eof (return count))
	(t
	 (incf count)
	 (format output-stream "~%~a" line))))))


(defun 4QUIT-COMMAND* (nntp-stream &optional (error t))
  "2Send the QUIT command to the NNTP server and close the connection.
Return T and the response string if successful.  If error is set to t then signal
an error condition if unsuccessful.  If error is set to NIL then return NIL and the
response string if unsuccessful.*"
  (write-command-and-validate nntp-stream "quit" *closing-connection-code* error)
  (close-nntp-stream nntp-stream))


(defun 4READ-NNTP-STREAM* (nntp-stream &optional (leader nil))
  "2Read one line from the NNTP stream.  If leader is nil (the default), the
stream does not bother to copy the string, and the caller should not rely on the
contents of that string after the next operation on the stream.  If leader it t,
the stream makes a copy.*"
  (send nntp-stream :line-in leader))

  
(defun 4READ-RESPONSE-CODE-FROM-NNTP-STREAM* (nntp-stream &optional (leader nil))
  "2Read the response code and response message from the NNTP stream..*"
  (let ((response-message (read-nntp-stream nntp-stream leader)))
    (values (read-from-string response-message nil nil) response-message)))


(defun 4STAT-COMMAND* (nntp-stream article-number &optional (error t))
  "2Send the STAT command to the NNTP server.  Return T and the
response string if successful.  If error is set to t then signal an error condition if
no such article exists.  If error is set to NIL then return NIL and the response
string if no such article exists.*"
  (write-command-and-validate nntp-stream (format nil "stat ~a" article-number)
			      *article-retrieved-request-text-separately-code* error))


(defun 4WRITE-COMMAND-AND-VALIDATE* (nntp-stream command valid-code error)
  "2Send the NNTP command to the NNTP server.  The valid-code is the expected
code returned by the server.  Return T and the response string if successful.  If
error is set to T then signal an error condition if no such article exists.  If error
is set to NIL then return NIL and the response string if no such article exists.*"
  (multiple-value-bind (code response-string) (write-command nntp-stream command)
    (cond
      ((equal code valid-code) 
       (values t response-string))
      (t
       (if error
	   (ferror (or (cdr (assoc code *error-codes*)) code) (format nil "~a" response-string))
	   (values nil response-string))))))


(defun 4WRITE-END-OF-TEXT* (nntp-stream)
  "2Write a single period to the NNTP stream to indicate end of text.*"
  (send nntp-stream :string-out (format nil "~%.~%"))  ;1Can't use :line-out because it has been modified to send double period.*	
  (send nntp-stream :force-output)
  t)


(defun 4WRITE-COMMAND* (nntp-stream command)
  "2Send an NNTP command to the NNTP server and read the response.  Return
the response code and the response message.*"
  (send nntp-stream :line-out command)
  (send nntp-stream :force-output)
  (read-response-code-from-nntp-stream nntp-stream))


(defun 4WRITE-TEXT* (nntp-stream text)
  "2Send text to the NNTP server.*"
  (send nntp-stream :line-out text)
  (send nntp-stream :force-output))


(defun 4XHDR-COMMAND* (nntp-stream field &optional (error t))
  "2Send the XHDR command to the NNTP server.  Return T and the response
string if successful.  If error is set to T then signal an error condition on error.
If error is set to NIL then return NIL and the response string if no such article
exists.*"
  (write-command-and-validate nntp-stream (format nil "xhdr ~a" field)
			      *article-retrieved-head-follows-code* error))
  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;1;;*
;1;; This function modifies the TCP stream somewhat.  A closure is wrapped around the*
;1;; stream to enhance the :LINE-IN and :LINE-OUT methods.  All other TCP stream methods*
;1;; remain unchanged.*
;1;;*
;1;; The primary reason :LINE-IN was modified was to be able to detect end of file*
;1;; (more appropriately end of data) on the NNTP stream.  The remote NNTP server*
;1;; indicates end of data by a single period on a line.  The secondary reason was to*
;1;; collapse double periods at the beginning of a line.  The remote NNTP server sends a*
;1;; double period in order to represent an actual single period on a line.*
;1;;*
;1;; The primary reason :LINE-OUT was modified was to transparently expand a line*
;1;; beginning with a period to a double period during transmission.  A single period on*
;1;; a line indicates end of text and can be sent by calling the function*
;1;; NNTP:WRITE-END-OF-TEXT.*
;1;;*
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun 4OPEN-NNTP-STREAM-1* (host &key &optional (remote-port *remote-port*) (timeout *timeout*) (error nil))
  "2Establish an NNTP connection and return a stream object for accessing that connection.*"
  (let ((nntp-stream (ip:open-stream host
				     :remote-port remote-port
				     :timeout timeout
				     :error error	
				     :characters :ascii)))
    (if (errorp nntp-stream)
	nntp-stream
	(open-nntp-stream-2 nntp-stream))))


(defun 4OPEN-NNTP-STREAM-2* (nntp-stream)
  #'(lambda (method &rest args)
	      (cond
		;1;;New :line-in method*
		((eq method :line-in)
		  (multiple-value-bind (line eof) (apply nntp-stream :line-in args)
		    (cond
		      ;1;Blank line, do nothing.*
		      ((zerop (length line)))
		      ;1;Period found in column one.  *
		      ((equal (aref line 0) #\.)
		       (cond
			 ;1;A single period on a line indicates end of data.*
			 ((= (length line) 1)
			  (setf eof t))
			 ;1;Collapse double period to single period.*
			 ((equal (aref line 1) #\.)
			  (if (array-has-fill-pointer-p line)
			      (loop for i from 1 to (1- (length line)) do
				    (setf (aref line (1- i)) (aref line i))
				    finally (setf (fill-pointer line) (1- i)))
			      (setf line (subseq line 1 (length line)))))))
		      ;1;Otherwise, do nothing.*
		      (t nil))
		    ;1;Return :line-in values.  *
		    (values line eof)))
		;1;;New :line-out method*
		((eq method :line-out)
		 (cond
		   ;1;;The line begins with a period, we must send a double period.  Note:  the (car args) is the actual string.*
		   ((and (> (length (car args)) 0) (equal (aref (car args) 0) #\.))
		    (apply nntp-stream :line-out (append (list (string-append "." (car args))) (cdr args))))
		   ;1;;Send the line as is.*
		   (t
		    (apply nntp-stream :line-out args))))
		;1;;Else, all other methods are executed as before.*
		(t
		  (apply nntp-stream method args)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;1;;*
;1;; MISCELLANEOUS*
;1;;*
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun 4PARSE-GROUP* (message)
  "2Parse the response returned from the NNTP GROUP command. * 2Return three
values, the* 2estimated number of articles in the group, first article number, and
last article number.*"
  (let (dummy number-of-articles first-article-number last-article-number index)
    (multiple-value-setq (dummy index) (read-from-string message nil nil))
    (multiple-value-setq (number-of-articles index) (read-from-string message nil nil :start index))
    (multiple-value-setq (first-article-number index) (read-from-string message nil nil :start index))
    (multiple-value-setq (last-article-number index) (read-from-string message nil nil :start index))
    (values number-of-articles first-article-number last-article-number)))