SchemeBBS

Check-in [a47867c42f]
Login
☰Home Timeline Branches Tags Tickets Wiki Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Allow to quote every single posts as comma separated values. Deduplicate regex code
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | origin/master | trunk
Files: files | file ages | folders
SHA3-256: a47867c42f34156ae332979bf512c17e7a41bfc16c68462d1f392a60a5ae5f3f
User & Date: ben.bitdiddle@protonmail.com 2020-06-11 01:29:38
Context
2020-06-11
11:42
display the list of boards on top of pages check-in: c5926fd0ab user: ben.bitdiddle@protonmail.com tags: origin/master, trunk
01:29
Allow to quote every single posts as comma separated values. Deduplicate regex code check-in: a47867c42f user: ben.bitdiddle@protonmail.com tags: origin/master, trunk
2020-06-10
21:51
add board list check-in: 079fd1a4a6 user: ben.bitdiddle@protonmail.com tags: origin/master, trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to bbs.scm. 










1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
..
66
67
68
69
70
71
72

73
74
75
76
77
78
79
80
81
82
83
84

85



86
87
88
89
90


91
92
93
94
95
96
97
98
99
100
101
102
103
104

105
106
107
108
109
110
111
...
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
...
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
...
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379










(load-option 'format)
(load "lib/utils")
(load "deps/irregex")
(load "deps/srfi-26")
(load "deps/httpio")
(load "deps/server")
(load "lib/html")
(load "lib/parameters")
(load "lib/markup")
(load "templates")

(define *sexp* "data/sexp")
(define *html* "data/html")
(define *frontpage-threads* 10)
(define *max-headline-size* 78)
(define *max-post-size* 8192)
(define *max-posts* 300)
(define *board-list* (map pathname-name (cddr (directory-read "data/sexp/*"))))


(define (get-form-hash)
  "TODO"
  (call-with-input-file "hash" read))

;;; helpers

................................................................................
(define (route req)
  (let* ((fullpath (uri->string (http-request-uri req)))
	 (path (string-split (ignore-qstring fullpath) #\/))
	 (query-string (get-query-string fullpath))
	 (method (http-request-method req))
	 (headers (http-request-headers req))
	 (ip (http-header 'x-forwarded-for headers #f)))

    ;(pp ip)
    (pp req)
    ;(pp headers)
    (pp (http-header 'x-forwarded-for headers #f))
    ;(pp (http-header 'host headers #f))
    (cond ((equal? method "GET")
	   (match path
	     (() () '(200 () "site root"))
	     ((,board) () (view-index board))
	     ((,board "list") () (view-list board))
	     ((,board "preferences") () (set-preferences board query-string))
	     ((,board ,thread) (integer? (string->number thread)) (view-thread board thread))

	     ((,board ,thread ,posts) (and (integer? (string->number thread)) (range? posts) (< (string-length posts) 40))



	      (view-thread board thread posts))
	     (_ () not-found)))
          ((equal? method "POST")
           (match path
	     ((,board "post") () (post-thread board req query-string))


	     ((,board ,thread "post") (integer? (string->number thread)) (post-message board thread req query-string))
	     (_ () method-not-allowed)))
          (else method-not-allowed))))

;;; errors
(define bad-request
  `(400 () "Bad Request"))
(define not-found
  `(404 () "Not found"))
(define method-not-allowed
  '(405 () "Method not allowed"))

(define (title board)
  (string-append "/" board "/ - SchemeBBS"))

;;; views
(define (thread-template board thread posts headline filter-func)
  (main-template (title board) (thread-view board thread posts headline filter-func) "thread"))

(define (list-template board threads)
  (main-template (title board) (list-view board threads)))

................................................................................
		  (rangeonce (if norange "unused" (posts-range range)))
		  (filter-func (if norange
				   (lambda (e) #t)
				   (lambda (e) (vector-ref rangeonce (car e))))))
	     (cond (norange
		    (if (not (file-exists? cache))
			(write-and-serve cache (thread-template board thread posts headline filter-func))
			(serve-file cache))) ;; we shouldn't go here, reverse proxy fetches the page itself
                   ((and (string->number range)
                         (> (string->number range) (length posts)))
                    not-found)
                   (else (make-response (thread-template board thread posts headline filter-func))))))
          (else not-found))))

(define (range? posts)
  (irregex-match "[1-9][0-9]{0,2}(-[1-9][0-9]{0,2})?(,[1-9][0-9]{0,2}(-[1-9][0-9]{0,2})?){0,20}" posts))

(define (posts-range range)
  (define (expand-range x)
    (cond ((> (length x) 1)
           (let* ((a (string->number (car x)))
                  (b (string->number (cadr x)))
                  (low (if (> a *max-posts*) *max-posts* a))
................................................................................
(define (view-list board)
  (let* ((path (make-path *sexp* board "list"))
         (cache (make-path *html* board "list"))
         (threads (if (file-exists? path) (call-with-input-file path read) '())))
    (cond ((file-exists? path)
	   (if (not (file-exists? cache))
	       (write-and-serve cache (list-template board threads))
	       (serve-file cache))) ;; we shouldn't go there with a reverse proxy
	  (else not-found))))

(define (view-index board)
  (let* ((path (make-path *sexp* board "index"))
	 (cache (make-path *html* board "index"))
	 (threads (if (file-exists? path)
		      (call-with-input-file path read)
................................................................................
	     (cons thread threads)
	     (cons thread (take threads (dec *frontpage-threads*)))))))))

(define (get-next-thread-number threads)
  (if (null? threads)
      1
      (inc (apply max (map car threads)))))


(define (validate-form params message #!optional headline)
  (let ((fake-message (lookup-def 'message params ""))
        (fake-name (lookup-def 'name params ""))
        (hash (lookup-def 'ornamentum params "")))
    (cond ((and (not (default-object? headline)) (string-null? headline))
           '(empty-headline . "New threads must have a headline"))

>
>
>
>
>
>
>
>
>











<
<
<
<
<
<
<
<







 







>












>
|
>
>
>





>
>
|













>







 







|


|




|







 







|







 







<








1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20








21
22
23
24
25
26
27
..
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
...
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
...
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
...
374
375
376
377
378
379
380

381
382
383
384
385
386
387

(define *sexp* "data/sexp")
(define *html* "data/html")
(define *frontpage-threads* 10)
(define *max-headline-size* 78)
(define *max-post-size* 8192)
(define *max-posts* 300)
(define *board-list* (map pathname-name (cddr (directory-read "data/sexp/*"))))
(define *range-regex* "[1-9][0-9]{0,2}(-[1-9][0-9]{0,2})?(,[1-9][0-9]{0,2}(-[1-9][0-9]{0,2})?)")
 
(load-option 'format)
(load "lib/utils")
(load "deps/irregex")
(load "deps/srfi-26")
(load "deps/httpio")
(load "deps/server")
(load "lib/html")
(load "lib/parameters")
(load "lib/markup")
(load "templates")










(define (get-form-hash)
  "TODO"
  (call-with-input-file "hash" read))

;;; helpers

................................................................................
(define (route req)
  (let* ((fullpath (uri->string (http-request-uri req)))
	 (path (string-split (ignore-qstring fullpath) #\/))
	 (query-string (get-query-string fullpath))
	 (method (http-request-method req))
	 (headers (http-request-headers req))
	 (ip (http-header 'x-forwarded-for headers #f)))
    ;TODO: logging
    ;(pp ip)
    (pp req)
    ;(pp headers)
    (pp (http-header 'x-forwarded-for headers #f))
    ;(pp (http-header 'host headers #f))
    (cond ((equal? method "GET")
	   (match path
	     (() () '(200 () "site root"))
	     ((,board) () (view-index board))
	     ((,board "list") () (view-list board))
	     ((,board "preferences") () (set-preferences board query-string))
	     ((,board ,thread) (integer? (string->number thread)) (view-thread board thread))
	     ((,board ,thread ,posts)
	      (and (integer? (string->number thread)) (range? posts)
		   ; on slower hardware you should change (* *max-posts*  8) below to a lesser value
		   ; see also the posts-range function and lib/markup.scm:quotelink
		   (< (string-length posts) (* *max-posts*  8)))
	      (view-thread board thread posts))
	     (_ () not-found)))
          ((equal? method "POST")
           (match path
	     ((,board "post") () (post-thread board req query-string))
	     ((,board ,thread "post")
	      (integer? (string->number thread))
	      (post-message board thread req query-string))
	     (_ () method-not-allowed)))
          (else method-not-allowed))))

;;; errors
(define bad-request
  `(400 () "Bad Request"))
(define not-found
  `(404 () "Not found"))
(define method-not-allowed
  '(405 () "Method not allowed"))

(define (title board)
  (string-append "/" board "/ - SchemeBBS"))

;;; views
(define (thread-template board thread posts headline filter-func)
  (main-template (title board) (thread-view board thread posts headline filter-func) "thread"))

(define (list-template board threads)
  (main-template (title board) (list-view board threads)))

................................................................................
		  (rangeonce (if norange "unused" (posts-range range)))
		  (filter-func (if norange
				   (lambda (e) #t)
				   (lambda (e) (vector-ref rangeonce (car e))))))
	     (cond (norange
		    (if (not (file-exists? cache))
			(write-and-serve cache (thread-template board thread posts headline filter-func))
			(serve-file cache)))
                   ((and (string->number range)
                         (> (string->number range) (length posts)))
                    not-found) ; TODO: doesn't return a 404 for ranges of inexistent posts
                   (else (make-response (thread-template board thread posts headline filter-func))))))
          (else not-found))))

(define (range? posts)
  (irregex-match (string-append *range-regex* "{0," (number->string *max-posts*) "}") posts))

(define (posts-range range)
  (define (expand-range x)
    (cond ((> (length x) 1)
           (let* ((a (string->number (car x)))
                  (b (string->number (cadr x)))
                  (low (if (> a *max-posts*) *max-posts* a))
................................................................................
(define (view-list board)
  (let* ((path (make-path *sexp* board "list"))
         (cache (make-path *html* board "list"))
         (threads (if (file-exists? path) (call-with-input-file path read) '())))
    (cond ((file-exists? path)
	   (if (not (file-exists? cache))
	       (write-and-serve cache (list-template board threads))
	       (serve-file cache)))
	  (else not-found))))

(define (view-index board)
  (let* ((path (make-path *sexp* board "index"))
	 (cache (make-path *html* board "index"))
	 (threads (if (file-exists? path)
		      (call-with-input-file path read)
................................................................................
	     (cons thread threads)
	     (cons thread (take threads (dec *frontpage-threads*)))))))))

(define (get-next-thread-number threads)
  (if (null? threads)
      1
      (inc (apply max (map car threads)))))


(define (validate-form params message #!optional headline)
  (let ((fake-message (lookup-def 'message params ""))
        (fake-name (lookup-def 'name params ""))
        (hash (lookup-def 'ornamentum params "")))
    (cond ((and (not (default-object? headline)) (string-null? headline))
           '(empty-headline . "New threads must have a headline"))

Changes to lib/markup.scm. 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
...
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
...
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204

;(load "utils/irregex/irregex")

(define markup->sxml)
(let ()

;;; global vars, needed for quotelinks
(define *board* #f)
(define *thread* #f)

;;; utils

(define (empty-line? line)
  (or (string-null? line) (irregex-match '(* white) line)))


(define (add-line-to-block blocks line tag)
  (if (null? blocks)
      `((,tag ,line))
      (let ((last-block-tag (caar blocks))
            (last-block-content (cdar blocks))
            (other-blocks (cdr blocks)))
................................................................................
  (define (join l res)
    (if (null?  l)
        res
        (join (cdr l) (string-append (car l) "\n" res))))
  (let ((lines (cdr codeblock)))
    `(pre (code ,(join (cdr lines) (car lines))))))

;;;

(define (format-blockquote bq)
  (define (make-paragraphs l res)
    (cond ((null? l) (if (for-all? (cdar res) empty-line?) (cdr res) res))
          ((and (empty-line? (car l)) (or (null? res) (null? (cdar res))))
           (make-paragraphs (cdr l) res))
          ((empty-line? (car l))
           (make-paragraphs (cdr l) (add-empty-tag res 'p)))
................................................................................
                (cond ((string? e)
                       (string->sxml markup e))
                      ((eq? (car e) 'del)
                       `(,(cons 'del (lines->sxml markup (cdr e)))))
                      (else `(,e))))
              l))


(define (transform-rule name regex transform)
  (define (dispatch op)
    (cond ((eq? op 'name) name)
          ((eq? op 'regex) regex)
          ((eq? op 'transform) transform)))
  dispatch)

................................................................................
    'del
    (irregex "~~[^ ].*?[^ ]~~|~~[^ ]~~")
    (lambda (sub) `(del ,(substring sub 2 (- (string-length sub) 2))))))

(define quotelink
  (transform-rule
    'quotelink
    (irregex ">>[1-9][0-9]{0,2}(-[1-9][0-9]{0,2})?(,[1-9][0-9]{0,2}(-[1-9][0-9]{0,2})?){0,20}")
    (lambda (sub) `(a (@ (href ,(string-append
                                  "/" *board*
                                  "/" *thread*
                                  "/" (string-tail sub 2))))
                         ,sub))))

(define link
  (transform-rule
    'link
    (irregex "https?:\/\/[^ \n]*")
    (lambda (sub) `(a (@ (href ,sub)) ,sub))))


(define line-scanner-order (list
  del code link quotelink bold italic))

(define (line-scanner l)
  ((apply compose (map (lambda (tr) (partial lines->sxml tr)) line-scanner-order)) l))


<
<











<







 







<
<







 







<







 







|











<










1
2
3
4
5
6
7
8
9
10
11

12
13
14
15
16
17
18
..
66
67
68
69
70
71
72


73
74
75
76
77
78
79
...
134
135
136
137
138
139
140

141
142
143
144
145
146
147
...
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190

191
192
193
194
195
196
197



(define markup->sxml)
(let ()

;;; global vars, needed for quotelinks
(define *board* #f)
(define *thread* #f)

;;; utils

(define (empty-line? line)
  (or (string-null? line) (irregex-match '(* white) line)))


(define (add-line-to-block blocks line tag)
  (if (null? blocks)
      `((,tag ,line))
      (let ((last-block-tag (caar blocks))
            (last-block-content (cdar blocks))
            (other-blocks (cdr blocks)))
................................................................................
  (define (join l res)
    (if (null?  l)
        res
        (join (cdr l) (string-append (car l) "\n" res))))
  (let ((lines (cdr codeblock)))
    `(pre (code ,(join (cdr lines) (car lines))))))



(define (format-blockquote bq)
  (define (make-paragraphs l res)
    (cond ((null? l) (if (for-all? (cdar res) empty-line?) (cdr res) res))
          ((and (empty-line? (car l)) (or (null? res) (null? (cdar res))))
           (make-paragraphs (cdr l) res))
          ((empty-line? (car l))
           (make-paragraphs (cdr l) (add-empty-tag res 'p)))
................................................................................
                (cond ((string? e)
                       (string->sxml markup e))
                      ((eq? (car e) 'del)
                       `(,(cons 'del (lines->sxml markup (cdr e)))))
                      (else `(,e))))
              l))


(define (transform-rule name regex transform)
  (define (dispatch op)
    (cond ((eq? op 'name) name)
          ((eq? op 'regex) regex)
          ((eq? op 'transform) transform)))
  dispatch)

................................................................................
    'del
    (irregex "~~[^ ].*?[^ ]~~|~~[^ ]~~")
    (lambda (sub) `(del ,(substring sub 2 (- (string-length sub) 2))))))

(define quotelink
  (transform-rule
    'quotelink
    (irregex (string-append ">>" *range-regex* "{0," (number->string (- *max-posts* 1)) "}"))
    (lambda (sub) `(a (@ (href ,(string-append
                                  "/" *board*
                                  "/" *thread*
                                  "/" (string-tail sub 2))))
                         ,sub))))

(define link
  (transform-rule
    'link
    (irregex "https?:\/\/[^ \n]*")
    (lambda (sub) `(a (@ (href ,sub)) ,sub))))


(define line-scanner-order (list
  del code link quotelink bold italic))

(define (line-scanner l)
  ((apply compose (map (lambda (tr) (partial lines->sxml tr)) line-scanner-order)) l))

This page was generated in about 0.006s by Fossil 2.16 [7aedd56758] 2021-07-02 12:46:01