aboutsummaryrefslogtreecommitdiff
path: root/readers/article.rkt
blob: df5e8e82eef9504e1874a21f666033419ab53256 (about) (plain)
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
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
#lang typed/racket

(provide read-article)

(require "../entities/article.rkt")
(require (only-in typed/srfi/19 string->date))
(require typed/json)
(require typed/syntax/readerr)

(: json->article (-> JSExpr (U Article-With-Tags String)))
(define (json->article jse)
  (call/cc
   (lambda ([k : (-> String Nothing)])
     (unless (hash? jse) (k "must be a hash"))

     (define id (hash-ref jse 'id (thunk (k "id not found"))))
     (unless (string? id) (k "id must be a string"))

     (define timestamp
       (let ([timestamp (hash-ref jse 'timestamp (thunk (k "timestamp not found")))])
         (unless (string? timestamp) (k "timestamp must be a string"))
         (with-handlers ([exn:fail? (const #f)])
           (string->date timestamp "~Y-~m-~dT~H:~M:~S~z"))))
     (unless (date? timestamp) (k "timestamp must be a iso8600 string"))

     (define hash (hash-ref jse 'hash (thunk (k "hash not found"))))
     (unless (string? hash) (k "hash must be a string"))

     (define title (hash-ref jse 'title (thunk (k "title not found"))))
     (unless (string? title) (k "title must be a string"))

     (define tags (hash-ref jse 'tags (thunk (k "tags not found"))))
     (unless (list? tags) (k "tags must be a list"))
     (unless (andmap string? tags) (k "element of tag must be a string"))

     (define body (hash-ref jse 'html (thunk (k "html not found"))))
     (unless (string? body) (k "html must be a string"))

     (make-article-with-tags id timestamp hash title body tags))))

(: read-article (-> Input-Port (U Article-With-Tags EOF)))
(define (read-article in)
  (let-values ([(l c p) (port-next-location in)])
    (let ([json (read-json in)])
      (cond
        [(eof-object? json) eof]
        [else
         (let ([article (json->article json)])
           (cond
             [(article-with-tags? article) article]
             [else
              (let-values ([(_nl _nc np) (port-next-location in)])
                (raise-read-error (format "read-article: ~a" article)
                                  (object-name in)
                                  l c p
                                  (and p np
                                       (let ([np-p (- np p)])
                                         (and (exact-positive-integer? np-p)
                                              np-p)))))]))]))))