#lang typed/racket

(provide read-article)

(require "../entities/article.rkt")
(require (only-in "../utils/date.rkt" 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? (lambda (_e)
                                      (k "timestamp must be a iso8600 string"))])
           (string->date timestamp "~Y-~m-~dT~H:~M:~S~z"))))

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