#lang scheme/base

(require web-server/servlet
         scheme/match)

(provide (rename-out [static-page* static-page])
         static-page? static-page-path
         site? build-site save-site)

(define-struct static-page (path generator)
  #:property prop:procedure
  (lambda (s request)
    (send/suspend/dispatch (static-page-generator s))))

(define static-page*
  (procedure-rename make-static-page 'static-page))

(define (build-site index [root #f])
  (let ([cache (make-hasheq)])
    (build-page index cache root)
    (make-site cache)))

(define-struct site (table))

(define (build-page page cache root)
  (match page
    [(struct static-page (path generator))
     ;(printf "build-page: ~a~n" path)
     (hash-ref! cache
                page
                (lambda ()
                  ;(printf "==> building...~n")
                  (hash-set! cache page 'computing)
                  (let* ([generator (static-page-generator page)]
                         [embed-url (lambda (other-page)
                                      (unless (static-page? other-page)
                                        (error 'build-site "cannot statically generate dynamic page: ~a" other-page))
                                      (build-page other-page cache root)
                                      (let ([path (static-page-path other-page)])
                                        (if root (format "~a/~a" root path) path)))])
                    (generator embed-url))))]))

(define (write-page site page [out (current-output-port)])
  (let ([data (normalize-response #t (hash-ref (site-table site) page))])
    (cond
      [(response/full? data)
       (for ([bytes (response/full-body data)])
         (write-bytes bytes out))]
      [(response/incremental? data)
       (error 'write-page "incremental responses unsupported")])))

(define (save-site site #:root [root (current-directory)] #:exists [exists-flag 'error])
  (for ([(page response) (in-hash (site-table site))])
    (call-with-output-file* (build-path root (static-page-path page))
                            (lambda (out)
                              (write-page site page out))
                            #:mode 'binary
                            #:exists exists-flag))
  (void))