Add read-article procedure.

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)))))]))]))))