blob: 8f06b959eb4a7afe8ebc13300d2d36fbdbfe938c (
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
|
#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)))))]))]))))
|
