Implements the SEARCH command.

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*))

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}}
 
 <<Command capabilities.lisp>>=
 (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.
+
+<<Command search.lisp>>=
+(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.
 <<Command users.lisp>>
 <<Command dd.lisp>>
 <<Command repl.lisp>>
+<<Command search.lisp>>
 <<Broadcasting.lisp>>
 <<Command-line parsing.lisp>>
 <<Main loop.lisp>>

version.lisp

@@ -1,2 +1,2 @@
 (in-package :loop)
-(defparameter *git-hash* "33b3a7d")
+(defparameter *git-hash* "1536193")