(define-module (views)
  #:use-module (htmlprag)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 match)
  #:use-module (json)
  #:use-module (model)
  #:use-module (safsaf handler-wrappers csrf)
  #:use-module (safsaf handler-wrappers sessions)
  #:use-module (safsaf response-helpers)
  #:use-module (safsaf router)
  #:use-module (safsaf templating)
  #:use-module (safsaf utils)
  #:use-module (safsaf params)
  #:use-module (web request)
  #:use-module (webutils multipart)
  #:export (make-blog-component))

(define %demo-username "admin")
(define %demo-password "password")

(define %pool #f)
(define %session-manager #f)
(define %routes #f)

;;;
;;; JSON helpers
;;;

(define (post->json-alist post)
  (match post
    ((('id . id) ('title . title) ('body . body)
      ('image-url . image-url) ('created-at . created-at))
     `(("id"         . ,id)
       ("title"      . ,title)
       ("body"       . ,body)
       ("image_url"  . ,(or image-url 'null))
       ("created_at" . ,created-at)))))

(define (post-summary->json-alist post)
  (match post
    ((('id . id) ('title . title) ('created-at . created-at))
     `(("id"         . ,id)
       ("title"      . ,title)
       ("created_at" . ,created-at)))))

;;;
;;; View helpers
;;;

(define (render-field label name type value errors)
  `(div (@ (class "field"))
     (label ,label
       ,(if (string=? type "textarea")
            `(textarea (@ (name ,name) (rows "15") (cols "60"))
                       ,value)
            `(input (@ (name ,name) (type ,type) (value ,value)))))
     ,@(map (lambda (err) `(p (@ (class "error")) ,err))
            errors)))

(define (form-errors params field-name)
  (if params
      (field-errors params field-name)
      '()))

(define (wants-json? request)
  (eq? 'application/json
       (negotiate-content-type request '(text/html application/json))))

;;;
;;; File upload helpers
;;;

(define upload-dir "./static/uploads")

(define (ensure-upload-dir!)
  (unless (file-exists? upload-dir)
    (mkdir upload-dir)))

(define (save-upload part)
  (let* ((params (part-content-disposition-params part))
         (filename (assoc-ref params 'filename)))
    (if (or (not filename) (string-null? filename))
        #f
        (let* ((ext (let ((dot (string-rindex filename #\.)))
                      (if dot (substring filename dot) "")))
               (unique-name (string-append
                             (number->string (current-time))
                             "-"
                             (number->string (random 1000000000))
                             ext))
               (file-path (string-append upload-dir "/" unique-name))
               (url-path (string-append "/static/uploads/" unique-name)))
          (ensure-upload-dir!)
          (call-with-output-file file-path
            (lambda (out)
              (let ((body (part-body part)))
                (let loop ()
                  (let ((bv (get-bytevector-some body)))
                    (unless (eof-object? bv)
                      (put-bytevector out bv)
                      (loop)))))))
          url-path))))

;;;
;;; Layout
;;;

(define (logged-in?)
  (and (current-session) #t))

(define (base-layout title content-proc)
  (let ((signed-in? (logged-in?)))
    `(*TOP*
      (*DECL* DOCTYPE html)
      (html
       (head
        (meta (@ (charset "utf-8")))
        (meta (@ (name "viewport")
                (content "width=device-width, initial-scale=1")))
        (title ,title " — Blog")
        (link (@ (rel "stylesheet") (href "/static/style.css"))))
       (body
        (nav
         (a (@ (href ,(path-for %routes 'index))) "Blog")
         ,@(if signed-in?
               `((a (@ (href ,(path-for %routes 'new-post))) "New Post"))
               '())
         ,@(if signed-in?
               `((form (@ (method "POST") (action ,(path-for %routes 'logout))
                          (class "nav-form"))
                   ,(csrf-token-field)
                   (button (@ (type "submit") (class "nav-link")) "Log out")))
               `((a (@ (href ,(path-for %routes 'login))) "Log in"))))
        (main ,content-proc)
        (footer
         (p "Safsaf blog example")))))))

(define (page title shtml)
  (streaming-html-response
   (base-layout title
     (lambda (port) (write-shtml-as-html shtml port)))))

;;;
;;; Auth
;;;

(define (require-login handler)
  (lambda (request body-port)
    (if (logged-in?)
        (handler request body-port)
        (if (wants-json? request)
            (json-response (scm->json-string '(("error" . "unauthorized")))
                           #:code 401)
            (redirect-response (path-for %routes 'login))))))

(define (login-page request body-port)
  (if (logged-in?)
      (redirect-response (path-for %routes 'index))
      (login-form-page #f)))

(define (login-form-page error)
  (page "Log in"
    `(div
      (h1 "Log in")
      ,@(if error
            `((p (@ (class "error")) ,error))
            '())
      (form (@ (method "POST") (action ,(path-for %routes 'login-submit)))
        ,(csrf-token-field)
        ,(render-field "Username" "username" "text" "" '())
        ,(render-field "Password" "password" "password" "" '())
        (button (@ (type "submit")) "Log in"))
      (p (@ (class "post-meta"))
         "Demo credentials: admin / password"))))

(define (handle-login request body-port)
  (let* ((form (parse-form-body request body-port))
         (params (parse-form-params
                   `((username ,as-string #:required)
                     (password ,as-string #:required))
                   form)))
    (if (any-invalid-params? params)
        (login-form-page "Please fill in all fields")
        (let ((username (assq-ref params 'username))
              (password (assq-ref params 'password)))
          (if (and (string=? username %demo-username)
                   (string=? password %demo-password))
              (redirect-response (path-for %routes 'index)
                #:headers (list (session-set %session-manager
                                             `((username . ,username)))))
              (login-form-page "Invalid username or password"))))))

(define (handle-logout request body-port)
  (redirect-response (path-for %routes 'index)
    #:headers (list (session-delete %session-manager))))

;;;
;;; Blog views — content-negotiated
;;;

(define (post-list-item post)
  (match post
    ((('id . id) ('title . title) ('created-at . date))
     `(li (a (@ (href ,(path-for %routes 'show-post
                                 `((id . ,(number->string id))))))
              ,title)
          " "
          (span (@ (class "post-meta")) ,date)))))

(define (list-posts request body-port)
  (let ((posts (db-list-posts %pool)))
    (if (wants-json? request)
        (json-response
         (scm->json-string (list->vector (map post-summary->json-alist posts))))
        (page "Posts"
          `(div
            (h1 "Blog")
            ,(if (null? posts)
                 '(p "No posts yet.")
                 `(ul ,@(map post-list-item posts))))))))

(define (show-post request body-port)
  (let* ((id-str (assoc-ref (current-route-params) 'id))
         (id (and id-str (string->number id-str)))
         (post (and id (db-get-post %pool id))))
    (if (not post)
        (if (wants-json? request)
            (json-response (scm->json-string '(("error" . "not found")))
                           #:code 404)
            (not-found-response "Post not found"))
        (if (wants-json? request)
            (json-response (scm->json-string (post->json-alist post)))
            (match post
              ((('id . _) ('title . title) ('body . body)
                ('image-url . image-url) ('created-at . date))
               (page title
                 `(div
                   (h1 ,title)
                   (p (@ (class "post-meta")) ,date)
                   ,@(if (and image-url (string? image-url))
                         `((img (@ (src ,image-url)
                                   (alt ,title)
                                   (class "header-image"))))
                         '())
                   (pre ,body)
                   ,@(if (logged-in?)
                         `((div (@ (class "post-actions"))
                             (a (@ (href ,(path-for %routes 'edit-post
                                                    `((id . ,id-str)))))
                                "Edit")
                             " "
                             (form (@ (method "POST")
                                      (action ,(path-for %routes 'post-actions
                                                         `((id . ,id-str))))
                                      (class "inline-form"))
                               ,(csrf-token-field)
                               (input (@ (type "hidden")
                                         (name "_method") (value "DELETE")))
                               (button (@ (type "submit") (class "danger"))
                                       "Delete"))))
                         '())
                   (p (a (@ (href ,(path-for %routes 'index)))
                         "Back to posts"))))))))))

;;;
;;; Create
;;;

(define (new-post-form-page result title-val body-val)
  (page "New Post"
    `(div
      (h1 "New Post")
      (form (@ (method "POST") (action ,(path-for %routes 'create-post))
               (enctype "multipart/form-data"))
        ,(csrf-token-field)
        ,(render-field "Title" "title" "text"
                       title-val (form-errors result 'title))
        ,(render-field "Body" "body" "textarea"
                       body-val (form-errors result 'body))
        (div (@ (class "field"))
          (label "Header Image"
            (input (@ (name "image") (type "file")
                      (accept "image/*")))))
        (button (@ (type "submit")) "Create"))
      (p (a (@ (href ,(path-for %routes 'index))) "Back")))))

(define (new-post-form request body-port)
  (new-post-form-page #f "" ""))

(define (create-post request body-port)
  (let* ((parts (parse-multipart-body request body-port))
         (form (multipart-text-fields parts))
         (params (parse-form-params
                   `((title ,as-string #:required)
                     (body  ,as-string #:required))
                   form)))
    (if (any-invalid-params? params)
        (new-post-form-page params
                            (or (assoc-ref form "title") "")
                            (or (assoc-ref form "body") ""))
        (let* ((title (assq-ref params 'title))
               (body (assq-ref params 'body))
               (image-part (parts-ref parts "image"))
               (image-url (and image-part (save-upload image-part)))
               (id (db-create-post! %pool title body image-url)))
          (redirect-response
           (path-for %routes 'show-post
                     `((id . ,(number->string id)))))))))

;;;
;;; Edit / Update
;;;

(define (edit-post-form request body-port)
  (let* ((id-str (assoc-ref (current-route-params) 'id))
         (id (and id-str (string->number id-str)))
         (post (and id (db-get-post %pool id))))
    (if (not post)
        (not-found-response "Post not found")
        (match post
          ((('id . _) ('title . title) ('body . body)
            ('image-url . image-url) ('created-at . _))
           (edit-post-form-page id-str #f title body))))))

(define (edit-post-form-page id-str result title-val body-val)
  (page "Edit Post"
    `(div
      (h1 "Edit Post")
      (form (@ (method "POST")
               (action ,(path-for %routes 'post-actions
                                  `((id . ,id-str))))
               (enctype "multipart/form-data"))
        ,(csrf-token-field)
        (input (@ (type "hidden") (name "_method") (value "PUT")))
        ,(render-field "Title" "title" "text"
                       title-val (form-errors result 'title))
        ,(render-field "Body" "body" "textarea"
                       body-val (form-errors result 'body))
        (div (@ (class "field"))
          (label "Header Image"
            (input (@ (name "image") (type "file")
                      (accept "image/*")))))
        (button (@ (type "submit")) "Update"))
      (p (a (@ (href ,(path-for %routes 'show-post
                                `((id . ,id-str)))))
            "Back")))))

;;;
;;; Update / Delete — core operations
;;;
;;; These take parsed data, not body-port.  Both the direct route handlers
;;; (PUT, DELETE) and the _method dispatcher call these, so body reading
;;; happens in exactly one place per request path.
;;;

(define (do-update-post request parts form)
  "Validate and update the post identified by current-route-params.
PARTS and FORM are already-parsed multipart data."
  (let* ((id-str (assoc-ref (current-route-params) 'id))
         (id (and id-str (string->number id-str)))
         (post (and id (db-get-post %pool id))))
    (if (not post)
        (if (wants-json? request)
            (json-response (scm->json-string '(("error" . "not found")))
                           #:code 404)
            (not-found-response "Post not found"))
        (let ((params (parse-form-params
                        `((title ,as-string #:required)
                          (body  ,as-string #:required))
                        form)))
          (if (any-invalid-params? params)
              (edit-post-form-page id-str params
                                   (or (assoc-ref form "title") "")
                                   (or (assoc-ref form "body") ""))
              (let* ((title (assq-ref params 'title))
                     (body  (assq-ref params 'body))
                     (image-part (and parts (parts-ref parts "image")))
                     (new-image-url (and image-part (save-upload image-part)))
                     (image-url (or new-image-url
                                    (assoc-ref post 'image-url))))
                (db-update-post! %pool id title body image-url)
                (if (wants-json? request)
                    (json-response
                     (scm->json-string (post->json-alist
                                        (db-get-post %pool id))))
                    (redirect-response
                     (path-for %routes 'show-post
                               `((id . ,id-str)))))))))))

(define (do-delete-post request)
  "Delete the post identified by current-route-params."
  (let* ((id-str (assoc-ref (current-route-params) 'id))
         (id (and id-str (string->number id-str)))
         (deleted? (and id (db-delete-post! %pool id))))
    (if (wants-json? request)
        (if deleted?
            (json-response (scm->json-string '(("deleted" . #t))))
            (json-response (scm->json-string '(("error" . "not found")))
                           #:code 404))
        (if deleted?
            (redirect-response (path-for %routes 'index))
            (not-found-response "Post not found")))))

;;;
;;; Route handlers — each reads the body (if needed) then calls the core operation.
;;;

(define (update-post request body-port)
  "PUT /posts/{id} — direct update for API clients and form submissions."
  (let* ((parts (parse-multipart-body request body-port))
         (form (multipart-text-fields parts)))
    (do-update-post request parts form)))

(define (delete-post request body-port)
  "DELETE /posts/{id} — direct delete for API clients."
  (do-delete-post request))

;;;
;;; _method dispatch — HTML forms POST here with a hidden _method field
;;; to simulate PUT and DELETE.
;;;

(define (post-actions request body-port)
  "Handle POST /posts/{id} — dispatches on _method form field.
HTML forms cannot send PUT or DELETE directly, so they POST with a
hidden _method field.  This handler reads the body once, then delegates
to the appropriate core operation.  API clients should use PUT/DELETE
directly instead."
  (let* ((parts (parse-multipart-body request body-port))
         (form (multipart-text-fields parts))
         (method (assoc-ref form "_method")))
    (cond
      ((equal? method "PUT")    (do-update-post request parts form))
      ((equal? method "DELETE") (do-delete-post request))
      (else (bad-request-response)))))

;;;
;;; Component constructor
;;;

(define (make-blog-component pool session-manager)
  (set! %pool pool)
  (set! %session-manager session-manager)
  (set! %routes (make-route-group '()))

  (route-group-add-children! %routes
    (list (route 'GET    '()                 list-posts       #:name 'index)
          (route 'GET    '("login")          login-page       #:name 'login)
          (route 'POST   '("login")          handle-login     #:name 'login-submit)
          (route 'POST   '("logout")         handle-logout    #:name 'logout)
          (route 'GET    '("posts" "new")    (require-login new-post-form)
                 #:name 'new-post)
          (route 'POST   '("posts")          (require-login create-post)
                 #:name 'create-post)
          (route 'GET    '("posts" id)       show-post        #:name 'show-post)
          (route 'GET    '("posts" id "edit") (require-login edit-post-form)
                 #:name 'edit-post)
          ;; _method dispatch: HTML forms POST here with _method=PUT or DELETE.
          (route 'POST   '("posts" id)       (require-login post-actions)
                 #:name 'post-actions)
          ;; Direct HTTP methods for API clients.
          (route 'PUT    '("posts" id)       (require-login update-post)
                 #:name 'update-post)
          (route 'DELETE '("posts" id)       (require-login delete-post)
                 #:name 'delete-post)))
  %routes)