diff --git a/src/link-header-parser.lisp b/src/link-header-parser.lisp new file mode 100644 index 0000000..ccd06e0 --- /dev/null +++ b/src/link-header-parser.lisp @@ -0,0 +1,108 @@ +;; tinmop: an humble gemini and pleroma client +;; Copyright (C) 2020 cage + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. +;; If not, see [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]]. + +(in-package :link-header-parser) + +(defrule link-start #\< + (:text t)) + +(defrule link-end #\> + (:text t)) + +(defrule field-separator #\; + (:text t)) + +(defrule parameter-separator #\= + (:text t)) + +(defrule parameter-value-quoting #\" + (:text t)) + +(defrule links-separator #\, + (:text t)) + +(defrule alpha (character-ranges (#\a #\z) (#\A #\Z)) + (:text t)) + +(defrule digit (character-ranges (#\0 #\9)) + (:text t)) + +(defrule iri-chars (not link-end) + (:text t)) + +(defrule blank (or #\space #\Newline #\Tab) + (:constant nil)) + +(defrule blanks (* blank) + (:constant nil)) + +(defrule parameter-key-chars (or alpha digit #\_ #\- #\.)) + +(defrule parameter-value-chars (not (or blank field-separator links-separator parameter-value-quoting))) + +(defrule parameter (and (+ parameter-key-chars) + blanks + parameter-separator + blanks + (? parameter-value-quoting) + (+ parameter-value-chars) + (? parameter-value-quoting) + (? field-separator)) + (:function (lambda (a) (cons (text (first a)) + (text (sixth a)))))) + +(defrule parameters-list (+ (and parameter blanks)) + (:function (lambda (a) (mapcar #'first a)))) + +(defrule link-block (and link-start (+ iri-chars) link-end) + (:function (lambda (a) (iri:iri-parse (text (second a)) :null-on-error t)))) + +(defrule link-record (and link-block (? field-separator) blanks (* parameters-list)) + (:function (lambda (a) (append (list (first a)) (fourth a))))) + +(defrule link-header-value (and link-record blanks + (? links-separator) + blanks + (* link-record)) + (:function (lambda (a) (append (list (first a)) (fifth a))))) + +(defun parse-header (header) + (parse 'link-header-value header)) + +(define-constant +link-parameter-relation+ "rel" :test #'string=) + +(defun extract-pagination-id (header direction query-key) + (when-let ((parsed (ignore-errors (parse-header header)))) + (loop for field in parsed do + (let* ((iri (first field)) + (params (second field)) + (relation (assoc +link-parameter-relation+ params :test #'string=)) + (query (uri:query iri))) + (when (string= (cdr relation) direction) + (multiple-value-bind (matched registers) + (cl-ppcre:scan-to-strings (strcat query-key "=([^&]+)") query) + (when matched + (return-from extract-pagination-id (elt registers 0))))))))) + +(define-constant +link-pagination-query-param-max-id+ "max_id" :test #'string=) + +(define-constant +link-pagination-relation-next+ "next" :test #'string=) + +(defun extract-pagination-current-max-id (header) + (extract-pagination-id header + +link-pagination-relation-next+ + +link-pagination-query-param-max-id+)) diff --git a/src/package.lisp b/src/package.lisp index 596ec8a..5726447 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -773,6 +773,17 @@ :ipv6-address-p :iri-to-parent-path)) +(defpackage :link-header-parser + (:use + :cl + :alexandria + :esrap + :cl-ppcre + :text-utils) + (:export + :parse-header + :extract-pagination-current-max-id)) + (defpackage :tour-mode-parser (:use :cl diff --git a/src/tests/link-header-tests.lisp b/src/tests/link-header-tests.lisp new file mode 100644 index 0000000..4149e34 --- /dev/null +++ b/src/tests/link-header-tests.lisp @@ -0,0 +1,43 @@ +;; tinmop: an humble gemini and pleroma client +;; Copyright (C) 2020 cage + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. +;; If not, see [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]]. + +(in-package :link-header-tests) + +(defsuite link-header-suite (all-suite)) + +(defun test-link-header (link-header results) + (let ((parsed (parse-header link-header))) + (loop for field in parsed + for original-field in results do + (when (not (and (iri= (first field) (first original-field)) + (equalp (second field) (second original-field)))) + (return-from test-link-header nil))) + t)) + +(defparameter *test-cases* `(("; rel=\"f\"" . + (("http://invalid/a/b?p=5" (("rel" . "f"))))) + ,(cons (format nil "; rel=\"start\",~%; rel=\"index\"") + '(("https://example.org/" (("rel" . "start"))) + ("https://example.org/index" (("rel" . "index"))))))) + +(deftest test-parsing (link-header-suite) + (loop for (a . b) in *test-cases* do + (assert-true (test-link-header a b) b))) + +(deftest test-extraction-next-pagination-id (link-header-suite) + (let ((link-pagination "; rel=\"next\", ; rel=\"prev\"")) + (assert-equalp "123456" (extract-pagination-current-max-id link-pagination)))) diff --git a/src/tests/package.lisp b/src/tests/package.lisp index bdd3686..fa96c21 100644 --- a/src/tests/package.lisp +++ b/src/tests/package.lisp @@ -55,6 +55,15 @@ :all-tests) (:export)) +(defpackage :link-header-tests + (:use :cl + :alexandria + :clunit + :link-header-parser + :iri + :all-tests) + (:export)) + (defpackage :numeric-tests (:use :cl :clunit diff --git a/tinmop.asd b/tinmop.asd index 56329e3..c5d7445 100644 --- a/tinmop.asd +++ b/tinmop.asd @@ -85,6 +85,7 @@ (:file "stack") (:file "uri-parser") (:file "iri-parser") + (:file "link-header-parser") (:file "tour-mode-parser") (:file "x509-ffi") (:file "x509") @@ -188,6 +189,7 @@ (:file "box-tests") (:file "uri-tests") (:file "iri-tests") + (:file "link-header-tests") (:file "numeric-tests") (:file "text-utils-tests") (:file "mtree-tests")