root/loop
1
0
Fork 0
Code Issues Pull requests Activity

Implements the SEARCH command.

Browse source
This commit is contained in:
Circling Skies 2026-08-21 12:18:51 -03:00
parent 1536193116
commit b345a8d544
3 changed files with 251 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

118
loop.lisp
View file

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

136
loop.nw
View file

@ -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>>

2
version.lisp
View file

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