Fix ordering of pastes

Evgeny PisemskySat Jul 12 16:00:50+0300 2025

3c0f7cf

Fix ordering of pastes

.gitignore unknown status 2

1-
# SPDX-FileCopyrightText: 2021 Li Ian-Xue (b4283) <b4283@pm.me>
2-
#
3-
# SPDX-License-Identifier: GPL-3.0-only
4-
5-
data
modules/pastebin/data.scm
88 
(use-modules (srfi srfi-9)
99 
             (srfi srfi-1)
1010 
             (ice-9 ftw)
11+
             (ice-9 i18n)
1112 
             (ice-9 regex)
1213 
             (ice-9 textual-ports))
1314 
…
7172 
;; input: <pb-data>, text
7273 
;; output: <pb-entry>
7374 
(define (pb-data-new-entry pb-data text)
74-
  (let ((next-filename (get-next-filename pb-data)))
75-
    (call-with-output-file (pb-get-file-path pb-data next-filename)
76-
      (lambda (port)
77-
        (put-string port text)))
75+
  (let* ((next-filename (get-next-filename pb-data))
76+
         (path (pb-get-file-path pb-data next-filename)))
77+
    (unless (file-exists? path)
78+
      (call-with-output-file path
79+
        (lambda (port)
80+
          (put-string port text))))
7881 
    (make-pb-entry next-filename text)))
7982 
8083 
(define (list-files pb-data)
81-
  (scandir (pb-data-dir pb-data) (lambda (filename) (= (string-length filename) 5))))
84+
  (scandir (pb-data-dir pb-data)
85+
           pb-entry-id-valid?
86+
           (lambda (s1 s2)
87+
             (string-locale<? s1 s2 (make-locale LC_ALL "C")))))
8288 
8389 
(define (get-next-filename pb-data)
8490 
  (let ((entries (list-files pb-data)))
modules/pastebin/httpserver.scm
6666 
          (title ,title)
6767 
          (meta (@ (charset "utf-8")))
6868 
          (meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0")))
69-
          (link (@ (rel "stylesheet") (href "https://cdn.simplecss.org/simple.min.css"))))
69+
          (link (@ (rel "stylesheet") (href "https://unpkg.com/simpledotcss/simple.min.css"))))
7070 
         (body ,@body)))
7171 
7272 
(define (list-handler pb-data-path)
…
9292 
                                           (form (@ (method "post")
9393 
                                                    (enctype "multipart/form-data")
9494 
                                                    (action "/post"))
95-
                                                 (fieldset (label (@ (for "form-text"))
96-
                                                                  "Paste content")
97-
                                                           (textarea (@ (id "form-text")
98-
                                                                        (name "text")) "")
99-
                                                           (label (@ (for "form-showurl"))
100-
                                                                  (input (@ (type "checkbox")
101-
                                                                            (id "form-showurl")
102-
                                                                            (name "showUrl")
103-
                                                                            (value "1")))
104-
                                                                  "Show raw URL after paste")
105-
                                                           (input (@ (type "submit")
106-
                                                                     (value "Submit")))))))
95+
                                                 (fieldset (div (label (@ (for "form-text"))
96+
                                                                       "Paste content"))
97+
                                                           (div (textarea (@ (id "form-text")
98+
                                                                             (name "text")) ""))
99+
                                                           (div (label (@ (for "form-showurl"))
100+
                                                                       (input (@ (type "checkbox")
101+
                                                                                 (id "form-showurl")
102+
                                                                                 (name "showUrl")
103+
                                                                                 (value "1")))
104+
                                                                       "Show raw URL after paste"))
105+
                                                           (div (input (@ (type "submit")
106+
                                                                          (value "Submit"))))))))
107107 
                            (footer (p (a (@ (href "https://github.com/pisemsky/guile-pastebin")
108108 
                                             (target "_blank"))
109-
                                          "Source code")))))))
109+
                                          "Source")))))))
110110 
              (display "<!DOCTYPE html>\n" port)
111111 
              (sxml->xml sxml port)))))
112112 
run unknown status 1
1+
#!/usr/bin/env sh
2+
3+
# SPDX-FileCopyrightText: 2025 Evgeny Pisemsky <mail@pisemsky.site>
4+
#
5+
# SPDX-License-Identifier: GPL-3.0-only
6+
7+
export GUILE_LOAD_PATH="modules:$GUILE_LOAD_PATH"
8+
export PATH="scripts:tests:$PATH"
9+
10+
exec "$@"
tests/pastebin-data unknown status 1
1+
#!/usr/bin/env sh
2+
exec guile -s "$0" "$@"
3+
!#
4+
5+
;;; SPDX-FileCopyrightText: 2025 Evgeny Pisemsky <mail@pisemsky.site>
6+
;;;
7+
;;; SPDX-License-Identifier: GPL-3.0-only
8+
9+
(use-modules (srfi srfi-1)
10+
             (srfi srfi-26)
11+
             (srfi srfi-64)
12+
             (pastebin data))
13+
14+
(define (new-n-entries pb-data n)
15+
  (map (cut pb-data-new-entry pb-data <>)
16+
       (map number->string (iota n))))
17+
18+
(test-begin "pastebin-data")
19+
20+
(test-begin "pb-entry-id-valid?")
21+
(test-assert (pb-entry-id-valid? "00000"))
22+
(test-assert (pb-entry-id-valid? "0001A"))
23+
(test-assert (pb-entry-id-valid? "0002b"))
24+
(test-assert (not (pb-entry-id-valid? "0../0")))
25+
(test-assert (not (pb-entry-id-valid? "12-34")))
26+
(test-assert (not (pb-entry-id-valid? "0000")))
27+
(test-assert (not (pb-entry-id-valid? "000000")))
28+
(test-end "pb-entry-id-valid?")
29+
30+
(test-begin "pb-data-new-entry")
31+
(let* ((dir (tmpnam))
32+
       (pb-data (pb-data-open dir)))
33+
  (mkdir dir)
34+
  (let ((entry-list (new-n-entries pb-data 100)))
35+
    (test-equal "00000" (pb-entry-id (list-ref entry-list 0)))
36+
    (test-equal "00001" (pb-entry-id (list-ref entry-list 1)))
37+
    (test-equal "00009" (pb-entry-id (list-ref entry-list 9)))
38+
    (test-equal "0000A" (pb-entry-id (list-ref entry-list 10)))
39+
    (test-equal "0000B" (pb-entry-id (list-ref entry-list 11)))
40+
    (test-equal "0000Z" (pb-entry-id (list-ref entry-list 35)))
41+
    (test-equal "0000a" (pb-entry-id (list-ref entry-list 36)))
42+
    (test-equal "0000b" (pb-entry-id (list-ref entry-list 37)))
43+
    (test-equal "0000z" (pb-entry-id (list-ref entry-list 61)))
44+
    (test-equal "00010" (pb-entry-id (list-ref entry-list 62)))
45+
    (test-equal "0001A" (pb-entry-id (list-ref entry-list 72)))
46+
    (test-equal "0001a" (pb-entry-id (list-ref entry-list 98)))))
47+
(test-end "pb-data-new-entry")
48+
49+
(test-begin "pb-data-get-top")
50+
(let* ((dir (tmpnam))
51+
       (pb-data (pb-data-open dir)))
52+
  (mkdir dir)
53+
  (new-n-entries pb-data 5)
54+
  (let ((top-5 (pb-data-get-top pb-data 5)))
55+
    (test-equal "00004" (pb-entry-id (first top-5)))
56+
    (test-equal "00000" (pb-entry-id (last top-5))))
57+
  (new-n-entries pb-data 195)
58+
  (let ((top-20 (pb-data-get-top pb-data 20)))
59+
    (test-equal "0003D" (pb-entry-id (first top-20)))
60+
    (test-equal "0002u" (pb-entry-id (last top-20)))))
61+
(test-end "pb-data-get-top")
62+
63+
(test-end "pastebin-data")
64+
65+
;; Local Variables:
66+
;; mode: scheme
67+
;; End: