diff options
| -rw-r--r-- | readers/article.rkt | 57 |
1 files changed, 57 insertions, 0 deletions
diff --git a/readers/article.rkt b/readers/article.rkt new file mode 100644 index 0000000..8f06b95 --- /dev/null +++ b/readers/article.rkt @@ -0,0 +1,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)))))]))])))) |