diff --git a/loop.lisp b/loop.lisp index 188d40d..25c5539 100644 --- a/loop.lisp +++ b/loop.lisp @@ -69,7 +69,8 @@ ("QUIT" ,#'cmd-quit "politely says good-bye") ("DATE" ,#'cmd-date "displays the current date at this server") ("UNLOCK-ACCOUNT" ,#'cmd-unlock-account "unlocks an account") - ("REPL" ,#'cmd-repl "lets you hack away"))) + ("REPL" ,#'cmd-repl "lets you hack away") + ("SEARCH" ,#'cmd-search "is your search engine"))) (defun set-up-tables! () (labels ((build-commands-assoc (ls) @@ -1125,7 +1126,7 @@ all-articles))) (when all-articles (setf (client-article *client*) (car all-articles))) - (prepend-response-with (fmt "~a ~a ~a ~a list follows" group-len group-low group-high g) + (prepend-response-with (fmt "~a ~a ~a ~a article list follows" group-len group-low group-high g) (make-response :code 211 :request r :multi-line 'yes @@ -1688,6 +1689,119 @@ :data "The REPL has been *explicitly* disabled by the sysadmin. :(" :request r))) +(defun all-groups () + "Reads the groups/ directory producing a list of all group names." + (let ((groups (directory "groups/*/"))) + (mapcar (lambda (path) + (str:trim (first (last (pathname-directory path))))) + groups))) + +(defun group-article-path (group article-id) + "Returns the relative filesystem path string for an article in a group." + (fmt "groups/~a/~a" group article-id)) + +(defun get-header-from-file (filepath target-header) + "Extracts TARGET-HEADER from FILEPATH using LOOP's native parsing pipeline." + (if (probe-file filepath) + (ignore-errors + (let* ((headers-raw (read-headers-raw filepath)) + (headers-str (bytes->string headers-raw)) + (hds (parse-headers headers-str)) + (val (get-header (string-downcase target-header) hds))) + (if (string= val "") "(none)" val))) + "(none)")) + +(defun cmd-search (r) + "Executes the SEARCH command, producing at most 10 positive matches. +The first argument must be a single group name. That's the limitation +we impose right now." + (with-auth + (let* ((args (request-args r)) + (group (car args)) + (queries (cdr args))) + (when (null group) + (return-from cmd-search (make-response :code 412 :request r :data "you must specify a group"))) + (when (not (group? group)) + (make-response :code 412 :request r :data "no such group")) + (when (null queries) + (return-from cmd-search (make-response :code 412 :request r :data "you must provide query strings"))) + (let ((match-count 0) + (results '())) + (catch 'search-done + (let ((g group)) + (let ((articles (get-articles g))) + (dolist (art-num articles) + (let* ((filepath (group-article-path g art-num)) + (snippet (scan-article-for-search filepath queries))) + (when snippet + (when (> match-count 0) (push "" results)) ;; a spacer between separate articles + (dolist (line (format-search-result filepath snippet)) + (push line results)) + (incf match-count) + (when (>= match-count 10) + (throw 'search-done t)))))))) + (if (> match-count 0) + (prepend-response-with (format nil "200 found ~a matches (10 maximum)" match-count) + (make-response :code 200 + :request r + :multi-line 'yes + :data (str:join (crlf-string) (nreverse results)))) + (make-response :code 430 :request r :data "no articles found")))))) + +(defun format-search-result (filepath snippet) + "Formats headers and the context block for a single matched article into a list of strings." + (let ((from (or (get-header-from-file filepath "from") "(none)")) + (date (or (get-header-from-file filepath "date") "(none)")) + (newsgroup (or (get-header-from-file filepath "newsgroups") "(none)")) + (msg-id (or (get-header-from-file filepath "message-id") "(none)")) + (scissors "--8<-------------------------------------------------------->8---") + (lines '())) + (push (fmt "From: ~a" from) lines) + (push (fmt "Date: ~a" date) lines) + (push (fmt "Newsgroups: ~a" newsgroup) lines) + (push (fmt "Message-ID: ~a" msg-id) lines) + (push "" lines) + (push scissors lines) + (when (first snippet) (push (first snippet) lines)) + (push (second snippet) lines) + (when (third snippet) (push (third snippet) lines)) + (push scissors lines) + (nreverse lines))) + +(defun scan-article-for-search (filepath queries) + "Scans an article line by line. Returns a 3-line context snippet around the first + match if ALL queries are found in the article. Extremely memory efficient." + (when (probe-file filepath) + (with-open-file (stream filepath :direction :input :element-type 'character :external-format :latin-1) + (let ((prev-line nil) + (curr-line (read-line stream nil nil)) + (next-line (read-line stream nil nil)) + (unfound-queries (copy-list queries)) + (snippet nil)) + (loop while curr-line do + (let ((matched-any nil)) + ;; Check current line against all remaining unfound queries + (dolist (q unfound-queries) + (when (search q curr-line :test #'char-equal) + (setf matched-any t) + (setf unfound-queries (remove q unfound-queries :test #'string-equal)))) + + ;; Capture the very first matched context block + (when (and matched-any (null snippet)) + (setf snippet (list prev-line curr-line next-line)))) + + ;; Early exit if all queries are found + (when (null unfound-queries) + (return-from scan-article-for-search snippet)) + + ;; Shift the 3-line sliding window + (setf prev-line curr-line + curr-line next-line + next-line (read-line stream nil nil))) + + ;; If EOF reached, ensure ALL queries were found before returning the snippet + (if (null unfound-queries) snippet nil))))) + (defun notify-group-created (g) (post-notification :subject (fmt "new group ~a by ~a" g (client-username *client*)) diff --git a/loop.nw b/loop.nw index e2a010c..171779a 100644 --- a/loop.nw +++ b/loop.nw @@ -501,7 +501,8 @@ commands, which is essentially what the user sees when asks for ("QUIT" ,#'cmd-quit "politely says good-bye") ("DATE" ,#'cmd-date "displays the current date at this server") ("UNLOCK-ACCOUNT" ,#'cmd-unlock-account "unlocks an account") - ("REPL" ,#'cmd-repl "lets you hack away"))) + ("REPL" ,#'cmd-repl "lets you hack away") + ("SEARCH" ,#'cmd-search "is your search engine"))) (defun set-up-tables! () (labels ((build-commands-assoc (ls) @@ -2839,7 +2840,7 @@ they're skilled enough. (defparameter *enable-nntp-repl* t) @ -\subsection{CAPABILITIES} +\subsection{{\tt CAPABILITIES}} <>= (defun cmd-capabilities (r) @@ -2859,6 +2860,136 @@ they're skilled enough. (fmt "IMPLEMENTATION LOOP ~a" *git-hash*)))) @ +\subsection{{\tt SEARCH}} + +Oh, yes, we've implemented a \verb|SEARCH| command. We want to +encourage users to reference articles by their message-ids so that +people can cross-reference discussions that might be very old. + +First thing to keep in mind here is that we're now having to decide in +which encoding we will interpret articles. We'll apply the following +trick. We'll continue to consider articles are mere byte sequences, +but just so we can use string functions for a more reasonable source +code, we choose the LATIN encoding because it perfectly maps to the +0--255 byte range. In other words, ISO-8859-1 is an encoding that's +really no encoding at all---it's more suitable to the task than 7-bit +ASCII. + +<>= +(defun all-groups () + "Reads the groups/ directory producing a list of all group names." + (let ((groups (directory "groups/*/"))) + (mapcar (lambda (path) + (str:trim (first (last (pathname-directory path))))) + groups))) + +(defun group-article-path (group article-id) + "Returns the relative filesystem path string for an article in a group." + (fmt "groups/~a/~a" group article-id)) + +(defun get-header-from-file (filepath target-header) + "Extracts TARGET-HEADER from FILEPATH using LOOP's native parsing pipeline." + (if (probe-file filepath) + (ignore-errors + (let* ((headers-raw (read-headers-raw filepath)) + (headers-str (bytes->string headers-raw)) + (hds (parse-headers headers-str)) + (val (get-header (string-downcase target-header) hds))) + (if (string= val "") "(none)" val))) + "(none)")) + +(defun cmd-search (r) + "Executes the SEARCH command, producing at most 10 positive matches. +The first argument must be a single group name. That's the limitation +we impose right now." + (with-auth + (let* ((args (request-args r)) + (group (car args)) + (queries (cdr args))) + (when (null group) + (return-from cmd-search (make-response :code 412 :request r :data "you must specify a group"))) + (when (not (group? group)) + (make-response :code 412 :request r :data "no such group")) + (when (null queries) + (return-from cmd-search (make-response :code 412 :request r :data "you must provide query strings"))) + (let ((match-count 0) + (results '())) + (catch 'search-done + (let ((g group)) + (let ((articles (get-articles g))) + (dolist (art-num articles) + (let* ((filepath (group-article-path g art-num)) + (snippet (scan-article-for-search filepath queries))) + (when snippet + (when (> match-count 0) (push "" results)) ;; a spacer between separate articles + (dolist (line (format-search-result filepath snippet)) + (push line results)) + (incf match-count) + (when (>= match-count 10) + (throw 'search-done t)))))))) + (if (> match-count 0) + (prepend-response-with (format nil "200 found ~a matches (10 maximum)" match-count) + (make-response :code 200 + :request r + :multi-line 'yes + :data (str:join (crlf-string) (nreverse results)))) + (make-response :code 430 :request r :data "no articles found")))))) + +(defun format-search-result (filepath snippet) + "Formats headers and the context block for a single matched article into a list of strings." + (let ((from (or (get-header-from-file filepath "from") "(none)")) + (date (or (get-header-from-file filepath "date") "(none)")) + (newsgroup (or (get-header-from-file filepath "newsgroups") "(none)")) + (msg-id (or (get-header-from-file filepath "message-id") "(none)")) + (scissors "--8<-------------------------------------------------------->8---") + (lines '())) + (push (fmt "From: ~a" from) lines) + (push (fmt "Date: ~a" date) lines) + (push (fmt "Newsgroups: ~a" newsgroup) lines) + (push (fmt "Message-ID: ~a" msg-id) lines) + (push "" lines) + (push scissors lines) + (when (first snippet) (push (first snippet) lines)) + (push (second snippet) lines) + (when (third snippet) (push (third snippet) lines)) + (push scissors lines) + (nreverse lines))) + +(defun scan-article-for-search (filepath queries) + "Scans an article line by line. Returns a 3-line context snippet around the first + match if ALL queries are found in the article. Extremely memory efficient." + (when (probe-file filepath) + (with-open-file (stream filepath :direction :input :element-type 'character :external-format :latin-1) + (let ((prev-line nil) + (curr-line (read-line stream nil nil)) + (next-line (read-line stream nil nil)) + (unfound-queries (copy-list queries)) + (snippet nil)) + (loop while curr-line do + (let ((matched-any nil)) + ;; Check current line against all remaining unfound queries + (dolist (q unfound-queries) + (when (search q curr-line :test #'char-equal) + (setf matched-any t) + (setf unfound-queries (remove q unfound-queries :test #'string-equal)))) + + ;; Capture the very first matched context block + (when (and matched-any (null snippet)) + (setf snippet (list prev-line curr-line next-line)))) + + ;; Early exit if all queries are found + (when (null unfound-queries) + (return-from scan-article-for-search snippet)) + + ;; Shift the 3-line sliding window + (setf prev-line curr-line + curr-line next-line + next-line (read-line stream nil nil))) + + ;; If EOF reached, ensure ALL queries were found before returning the snippet + (if (null unfound-queries) snippet nil))))) +@ + \section{Publication of news} If you're interested in being notified about what's going on in the @@ -3705,6 +3836,7 @@ something to think about. <> <> <> +<> <> <> <
> diff --git a/version.lisp b/version.lisp index b0a900f..34fca00 100644 --- a/version.lisp +++ b/version.lisp @@ -1,2 +1,2 @@ (in-package :loop) -(defparameter *git-hash* "33b3a7d") +(defparameter *git-hash* "1536193")