guile-pastebin/pastebin/data.scm

data.scm

1
(define-module (pastebin data))
2
3
(use-modules (srfi srfi-9)
4
             (srfi srfi-1)
5
             (ice-9 ftw)
6
             (ice-9 regex)
7
             (ice-9 textual-ports))
8
9
(export <pb-data>
10
        <pb-entry>
11
        pb-entry-id
12
        pb-entry-id-valid?
13
        pb-entry-text
14
        pb-data-open
15
        pb-data-close
16
        call-with-dir-as-pb-data
17
        pb-data-get-top
18
        pb-data-new-entry
19
        pb-get-file-path)
20
21
(define-record-type <pb-data>
22
  (make-pb-data dir)
23
  pb-data?
24
  (dir pb-data-dir set-pb-data-dir!))
25
26
(define-record-type <pb-entry>
27
  (make-pb-entry id text)
28
  pb-entry?
29
  (id pb-entry-id set-pb-entry-id!)
30
  (text pb-entry-text set-pb-entry-text!))
31
32
(define (pb-entry-id-valid? id)
33
  (and (= (string-length id) 5)
34
       (string-match "[0-9A-Za-z]{5}" id)
35
       #t))
36
37
;; input: dir: string
38
;; output: <pb-data>
39
(define (pb-data-open dir)
40
  (make-pb-data dir))
41
42
(define (pb-data-close pb-data) #t)
43
44
(define (call-with-dir-as-pb-data dir p)
45
  (let ((pb-data (pb-data-open dir)))
46
    (let ((R (p pb-data)))
47
      (pb-data-close pb-data)
48
      R)))
49
50
(define (pb-get-file-path pb-data filename)
51
  (string-append (pb-data-dir pb-data) "/" filename))
52
53
;; input: <pb-data>, integer
54
;; output: list of <pb-entry>
55
(define (pb-data-get-top pb-data n)
56
  (map
57
   (lambda (filename)
58
     (make-pb-entry
59
      filename
60
      (call-with-input-file (pb-get-file-path pb-data filename)
61
        (lambda (port)
62
          (get-string-all port)))))
63
   (let ((file-ls (list-files pb-data)))
64
     (reverse (take-right file-ls (min n (length file-ls)))))))
65
66
;; input: <pb-data>, text
67
;; output: <pb-entry>
68
(define (pb-data-new-entry pb-data text)
69
  (let ((next-filename (get-next-filename pb-data)))
70
    (call-with-output-file (pb-get-file-path pb-data next-filename)
71
      (lambda (port)
72
        (put-string port text)))
73
    (make-pb-entry next-filename text)))
74
75
(define (list-files pb-data)
76
  (scandir (pb-data-dir pb-data) (lambda (filename) (= (string-length filename) 5))))
77
78
(define (get-next-filename pb-data)
79
  (let ((entries (list-files pb-data)))
80
    (if (null? entries)
81
        "00000"
82
        (get-next-5digit (last entries)))))
83
84
(define (get-next-5digit str)
85
  (let A ((add #t)
86
          (char-int-ls (reverse (map char->integer (string->list str))))
87
          (result '()))
88
    (if (null? char-int-ls)
89
        (list->string (map integer->char result))
90
        (if add
91
            (let* ((hd (car char-int-ls)) (tl (cdr char-int-ls)))
92
              (if (= hd #x7A)
93
                  (A #t tl (cons #x30 result))
94
                  (A #f tl (cons (case hd
95
                                   ((#x39) #x41)
96
                                   ((#x5A) #x61)
97
                                   (else (1+ hd))) result))))
98
            (A #f '() (append (reverse char-int-ls) result))))))
99