;; SPDX-FileCopyrightText: 2026 Andrew Oberstar <andrew@ajoberstar.org>
;; SPDX-License-Identifier: AGPL-3.0-only

(in-package #:org.ajoberstar.quixote.import)

(defun safe-probe-file (path)
  (and path (probe-file path)))

(defun directory-name (directory)
  (car (last (pathname-directory (uiop:ensure-pathname directory)))))

(defparameter +front-orig+ "front_original.pnm")
(defparameter +front-crop+ "front_cropped.pnm")
(defparameter +back-orig+ "back_original.pnm")
(defparameter +back-crop+ "back_cropped.pnm")

(defun png-path (path)
  (merge-pathnames
   (make-pathname :type "png")
   path))

(defun thumb-path (path)
  (merge-pathnames
   (format nil "~A_thumb.jpg" (pathname-name path))
   path))

(defun crop-path (path)
  (merge-pathnames
   (serapeum:string-replace "_original" (file-namestring path) "_cropped")
   path))

;;; State

(defvar *inbox-dir* nil)
(defvar *staging-dir* nil)

(defvar *staged-items* (make-hash-table :test #'eql))
(defvar *staged-items-lock* (bt2:make-lock :name "staged-items"))

(defvar *default-edition-type* "book")

;;; Classes

(defgeneric image-path (image))
(defgeneric image-thumb-path (image))

(defmethod image-path ((image (eql nil)))
  nil)

(defmethod image-thumb-path ((image (eql nil)))
  nil)

(defclass image ()
  ((path :initarg :path :accessor image-path)
   (thumb-path :initarg :thumb-path :accessor image-thumb-path)))

(defun make-image (path)
  (when (safe-probe-file path)
    (make-instance 'image :path path
                          :thumb-path (thumbnail path :overwrite nil))))

(defmethod print-object ((obj image) stream)
  (print-unreadable-object (obj stream :type t)
    (format stream "~A ~@[(~A)~]" (image-path obj) (image-thumb-path obj))))

(defun image-rethumb (image)
  (declare (type image image))
  (with-slots (path thumb-path) image
    (setf thumb-path (thumbnail path))
    image))

(defun image-delete (image)
  (when image
    (with-slots (path thumb-path) image
      (delete-file path)
      (setf path nil)
      (delete-file thumb-path)
      (setf thumb-path nil))))

(defgeneric crop-args-left (crop-args)
  (:method ((crop-args (eql nil)))
    nil))

(defgeneric crop-args-right (crop-args)
  (:method ((crop-args (eql nil)))
    nil))

(defgeneric crop-args-top (crop-args)
  (:method ((crop-args (eql nil)))
    nil))

(defgeneric crop-args-bottom (crop-args)
  (:method ((crop-args (eql nil)))
    nil))

(defgeneric crop-args-rotate (crop-args)
  (:method ((crop-args (eql nil)))
    nil))

(defclass crop-args ()
  ((left :initarg :left :type integer :reader crop-args-left)
   (right :initarg :right :type integer :reader crop-args-right)
   (top :initarg :top :type integer :reader crop-args-top)
   (bottom :initarg :bottom :type integer :reader crop-args-bottom)
   (rotate :initarg :rotate :type integer :reader crop-args-rotate)))

(defun make-crop-args (&key (left 0) (right 0) (top 0) (bottom 0) (rotate 0))
  (make-instance 'crop-args
                 :left left
                 :right right
                 :top top
                 :bottom bottom
                 :rotate rotate))

(defgeneric side-original (side)
  (:method ((side (eql nil)))
    nil))

(defgeneric side-cropped (side)
  (:method ((side (eql nil)))
    nil))

(defgeneric side-crop-args (side)
  (:method ((side (eql nil)))
    nil))

(defclass side ()
  ((original :initarg :original :reader side-original)
   (cropped :initarg :cropped :reader side-cropped)
   (crop-args :initarg :crop-args :reader side-crop-args)))

(defun make-side (original-path &key crop-args)
  (when (safe-probe-file original-path)
    (make-instance 'side :original (make-image original-path)
                         :cropped (make-image (crop-path original-path))
                         :crop-args (or crop-args
                                        (make-crop-args :left 0
                                                        :right 0
                                                        :top 0
                                                        :bottom 0
                                                        :rotate 0)))))

(defmethod print-object ((obj side) stream)
  (print-unreadable-object (obj stream :type t)
    (format stream "~A" (image-path (side-original obj)))))

(defun side-image (side)
  (or (side-cropped side)
      (side-original side)))

(defun side-recrop (side args)
  (declare (type side side))
  (with-slots (original cropped crop-args) side
    (image-delete cropped)
    (let ((crop-path (crop (image-path original)
                           (crop-path (image-path original))
                           :left (crop-args-left args)
                           :right (crop-args-right args)
                           :top (crop-args-top args)
                           :bottom (crop-args-bottom args)
                           :rotate (crop-args-rotate args))))
      (setf crop-args args)
      (setf cropped (make-image crop-path))
      (image-rethumb cropped)))
  side)

(defun side-uncrop (side)
  (with-slots (cropped) side
    (image-delete cropped)
    (setf cropped nil))
  side)

(defclass staged-item ()
  ((id :initarg :id :reader staged-item-id)
   (name :initarg :name :reader staged-item-name)
   (dir :initarg :dir :reader staged-item-dir)
   (front :initarg :front :accessor staged-item-front)
   (back :initarg :back :accessor staged-item-back)
   (isbn :initform nil :accessor staged-item-isbn)
   (edition :initform nil :accessor staged-item-edition)
   (status :initform :staged :accessor staged-item-status)))

(defun make-staged-item (dir)
  (let* ((name (directory-name dir))
         (id (parse-integer (second (uiop:split-string name :separator '(#\-))))))
    (make-instance 'staged-item :id id
                                :name name
                                :dir dir
                                :front (make-side (merge-pathnames +front-orig+ dir))
                                :back (make-side (merge-pathnames +back-orig+ dir)))))

(defun staged-item-cover (item)
  (declare (type staged-item item))
  (covers:make-cover (model:edition-id (staged-item-edition item))))

(defun staged-item-cover-exists-p (item)
  (declare (type staged-item item))
  (covers:cover-exists-p (staged-item-cover item)))

(defmethod staged-item-isbn ((item staged-item))
  (with-slots (isbn) item
    (if (and isbn (not (eql :missing isbn)))
        isbn)))

(defmethod staged-item-edition ((item staged-item))
  (with-slots (edition) item
    (if (and edition (not (eql :missing edition)))
        edition)))

(defun staged-item-paired-p (item)
  (with-slots (front back) item
    (and (safe-probe-file (image-path (side-original front)))
         (safe-probe-file (image-path (side-original back))))))

(defun staged-item-identified-p (item)
  (with-slots (isbn edition) item
    (and isbn edition)))

(defun clear-staged-items ()
  (bt2:with-lock-held (*staged-items-lock*)
    (setf *staged-items* (make-hash-table :test #'eql))))

(defun staged-item (id)
  (bt2:with-lock-held (*staged-items-lock*)
    (gethash id *staged-items*)))

(defun staged-items (&optional (status :staged))
  (bt2:with-lock-held (*staged-items-lock*)
    (loop for item-num in (sort (alexandria:hash-table-keys *staged-items*) #'>)
          for item = (gethash item-num *staged-items*)
          when (eql status (staged-item-status item))
            collect item)))

(defun resolve-staged-authors ()
  (bt2:with-lock-held (*staged-items-lock*)
    (loop for item being the hash-values of *staged-items*
          for edition = (staged-item-edition item)
          when edition
            do (with-accessors ((author model:edition-author)
                                (translator model:edition-translator))
                   edition
                 (when (and author (null (model:author-id author)))
                   (setf author (or (author-match author) author)))
                 (when (and translator (null (model:author-id translator)))
                   (setf translator (or (author-match translator) translator)))))))

(defun staged-authors ()
  (remove-if #'author-match
             (alexandria:hash-table-values
              (loop with authors = (make-hash-table :test #'equalp)
                    for item in (staged-items)
                    for edition = (staged-item-edition item)
                    for author = (when edition (model:edition-author edition))
                    when (and author (model:author-openlibrary-id author))
                      do (setf (gethash (model:author-openlibrary-id author) authors)
                               author)
                    finally (return authors)))))

;;; Import

(defun convert (path output)
  (uiop:run-program (list "magick"
                          (namestring path)
                          (namestring output))))

(defun thumbnail (path &key (output nil) (width 600) (overwrite t))
  (when (safe-probe-file path)
    (let ((output (or output (thumb-path path))))
      (when (or overwrite (not (safe-probe-file output)))
        (uiop:run-program (list "magick"
                                (namestring path)
                                "-filter" "box"
                                "-resize" (format nil "~Dx>" width) ;; max width, preserve aspect ratio
                                "-quality" "85"
                                (namestring output))))
      output)))

(defun crop (path output &key (left 0) (right 0) (top 0) (bottom 0) (rotate 0))
  (uiop:run-program
   (remove-if #'null
              `("magick"
                ,(namestring path)
                ,@(loop for (width height gravity) in `((,left 0 "West")
                                                        (,right 0 "East")
                                                        (0 ,top "North")
                                                        (0 ,bottom "South"))
                        when (or (plusp width) (plusp height))
                          append (list "-gravity" gravity "-chop" (format nil "~Dx~D" width height) "+repage"))
                ,@(when (plusp rotate) (list "-rotate" (format nil "~D" rotate) "+repage"))
                ,(namestring output))))
  output)

(defun barcode (path)
  (multiple-value-bind (out err exit-code)
      (uiop:run-program (list "zbarimg" "--raw" "-Sisbn13.enable"
                              (namestring path))
                        :output '(:string :stripped t)
                        :ignore-error-status t)
    (declare (ignore err))
    (if (zerop exit-code)
        ;; in case multiple barcodes found only return the first
        (first (uiop:split-string out :separator '(#\Newline)))
        nil)))

(defun process-image (path)
  (let* ((scan-num (handler-case
                       (parse-integer (pathname-name path))
                     (error (e)
                       (format t "Error parsing scan-num from ~A: ~A~%" path e)
                       -1)))
         (item-num (ceiling (/ scan-num 2)))
         (side (if (zerop (rem scan-num 2))
                   "back"
                   "front"))
         (item-dir (merge-pathnames (format nil "item-~4,'0D/" item-num) *staging-dir*))
         (staged-path (merge-pathnames (format nil "~A_~A" side "original.pnm") item-dir)))
    (if (minusp scan-num)
        (progn
          ;; keep bad images from being re-handled every 2 seconds
          (rename-file path (merge-pathnames (format nil "~A.bad" (file-namestring path))
                                             path))
          nil)
        (rename-file path (ensure-directories-exist staged-path)))))

(defun process-inbox ()
  (let ((threshold (- (get-universal-time) (* 2 *inbox-watcher-interval*))))
    (loop with any-p = nil
          for image in (when (and *inbox-dir* (probe-file *inbox-dir*))
                         (uiop:directory-files *inbox-dir* "*.pnm"))
          for write-date = (uiop:safe-file-write-date image)
          when (and write-date (<= write-date threshold))
            do (handler-case
                   (progn
                     (format t "Processing image: ~A~%" image)
                     (when (process-image image)
                       (setf any-p t)))
                 (error (e)
                   (format t "Error processing image ~A, continuing: ~A~%" image e)))
          finally (when any-p (notify-stage-worker)))))

(defun staged-item-side (item direction preference crop-args)
  (let ((side (funcall (ecase direction
                         (:front #'staged-item-front)
                         (:back #'staged-item-back))
                       item)))

    (unless (safe-probe-file (image-path (side-original side)))
      (error "No ~A ~A scan for item ~D" direction preference (staged-item-id item)))

    (ecase preference
      (:original
       (side-uncrop side))
      (:crop
       (side-recrop side crop-args)))

    ;; clear identification so we re-lookup
    (when (eql direction :back)
      (bt2:with-lock-held (*staged-items-lock*)
        (when (eql (slot-value item 'edition) :missing)
          (setf (staged-item-isbn item) nil)
          (setf (staged-item-edition item) nil)
          (notify-stage-worker))))

    item))

(defun lookup-staged-item (item isbn)
  (let ((edition (handler-case
                     (lib:book-search isbn)
                   (error (e)
                     (format t "Error searching for ~A: ~A" isbn e)
                     nil))))
    (bt2:with-lock-held (*staged-items-lock*)
      (setf (staged-item-isbn item) (or isbn :missing))
      (setf (staged-item-edition item) (or edition :missing)))))

(defun queue-complete-item (item)
  (bt2:with-lock-held (*staged-items-lock*)
    (setf (staged-item-status item) :completing)
    (notify-complete-worker)))

(defun complete-staged-item (item)
  (format t "Completing item: ~A~%" (staged-item-name item))
  (let ((cover (staged-item-cover item)))

    ;; delete existing, so we can overwrite
    (covers:ensure-cover-empty cover)

    ;; move files into cover dir
    (convert (image-path (side-image (staged-item-front item)))
             (covers:cover-path cover :front nil))
    (thumbnail (image-path (side-image (staged-item-front item)))
               :output (covers:cover-path cover :front t))
    (convert (image-path (side-image (staged-item-back item)))
             (covers:cover-path cover :back nil))
    (thumbnail (image-path (side-image (staged-item-back item)))
               :output (covers:cover-path cover :back t))

    ;; clean up staged dir/item
    (uiop:delete-directory-tree
     (staged-item-dir item)
     :validate (lambda (path)
                 (uiop:subpathp path *staging-dir*))
     :if-does-not-exist :ignore)

    (bt2:with-lock-held (*staged-items-lock*)
      (remhash (staged-item-id item) *staged-items*)))
  (format t "Completed item: ~A~%" (staged-item-name item)))

(defun delete-staged-item (item)
  (uiop:delete-directory-tree (staged-item-dir item)
                              :validate (lambda (path)
                                          (uiop:subpathp path *staging-dir*))
                              :if-does-not-exist :ignore)
  (bt2:with-lock-held (*staged-items-lock*)
    (remhash (staged-item-id item) *staged-items*)))

(defun read-stage (item-dir base)
  (format t "Reading item dir: ~A~%" item-dir)
  (let* ((item (or base (make-staged-item item-dir)))
         (front-orig (safe-probe-file (merge-pathnames +front-orig+ item-dir)))
         (back-orig (safe-probe-file (merge-pathnames +back-orig+ item-dir))))

    (unless (eql :completing (staged-item-status item))
      (bt2:with-lock-held (*staged-items-lock*)
        (setf (staged-item-front item)
              (make-side front-orig :crop-args (side-crop-args (staged-item-front item))))
        (setf (staged-item-back item)
              (make-side back-orig :crop-args (side-crop-args (staged-item-back item)))))

      ;; lookup if not done already
      (when (and (staged-item-paired-p item)
                 (not (staged-item-identified-p item)))
        (let ((path (image-path (side-image (staged-item-back item)))))
          (lookup-staged-item item (barcode path)))))
    item))

(defun process-stage ()
  (let ((seen (make-hash-table :test #'eql)))
    (loop for item-dir in (when (and *staging-dir* (probe-file *staging-dir*))
                            (uiop:subdirectories *staging-dir*))
          for item-name = (directory-name item-dir)
          for item-num = (handler-case
                             (parse-integer (second (uiop:split-string item-name :separator '(#\-))))
                           (error (e)
                             (format t "Error parsing item num from ~A: ~A~%" item-dir e)
                             -1))
          when (plusp item-num)
            do (handler-case
                   (let ((item (read-stage item-dir (gethash item-num *staged-items*))))
                     (bt2:with-lock-held (*staged-items-lock*)
                       (setf (gethash item-num *staged-items*) item))
                     (setf (gethash item-num seen) t))
                 (error (e)
                   (format t "Error processing staged dir ~A, continuing: ~A~%" item-name e))))
    ;; remove stale staged items
    (bt2:with-lock-held (*staged-items-lock*)
      (loop for item-num being the hash-keys of *staged-items*
            unless (gethash item-num seen)
              do (remhash item-num *staged-items*)))))

(defun author-match (author)
  (when author
    (let ((olid (model:author-openlibrary-id author)))
      (when olid
        (first
         (db:search-authors `((:field "olid" ,olid)) :limit 1))))))

(defun author-matches (author)
  (db:search-authors `((:field "author" ,(model:author-name author)))))

(defun edition-match (edition)
  (let ((olid (model:edition-openlibrary-id edition)))
    (when olid
      (first
       (db:search-editions `((:field "olid" ,olid)) :limit 1)))))

(defun edition-matches (edition)
  (alexandria:hash-table-values
   (loop with results = (make-hash-table)
         for edition in (append
                         (db:search-editions `((:field "edition" ,(model:edition-title edition))))
                         (db:search-editions `((:field "isbn" ,(model:edition-isbn edition)))))
         do (setf (gethash (model:edition-id edition) results) edition)
         finally (return results))))

;;; Complete Worker

(defvar *complete-worker-semaphore* (bt2:make-semaphore :name "complete-worker"))
(defvar *complete-worker-thread* nil)
(defvar *complete-worker-stop* nil)

(defun start-complete-worker ()
  (stop-complete-worker)
  (format t "Starting complete worker~%")
  (setf *complete-worker-stop* nil)
  (setf *complete-worker-thread*
        (bt2:make-thread
         (lambda ()
           (loop
             (bt2:wait-on-semaphore *complete-worker-semaphore*)
             (when *complete-worker-stop*
               (format t "Exiting complete worker loop~%")
               (return))
             (handler-case
                 (loop for item in (staged-items :completing)
                       do (handler-case
                              (complete-staged-item item)
                            (error (e)
                              (format t "Error completing item ~A: ~A~%" (staged-item-name item) e)
                              (setf (staged-item-status item) :failed))))
               (error (e)
                 (format t "Error during process complete, continuing: ~A~%" e)))))
         :name "complete-worker")))

(defun stop-complete-worker ()
  (when (and *complete-worker-thread* (bt2:thread-alive-p *complete-worker-thread*))
    (setf *complete-worker-stop* t)
    (bt2:signal-semaphore *complete-worker-semaphore*)
    (bt2:join-thread *complete-worker-thread*))
  (setf *complete-worker-thread* nil))

(defun notify-complete-worker ()
  (bt2:signal-semaphore *complete-worker-semaphore*))

;;; Stage Worker

(defvar *stage-worker-semaphore* (bt2:make-semaphore :name "stage-worker"))
(defvar *stage-worker-thread* nil)
(defvar *stage-worker-stop* nil)

(defun start-stage-worker ()
  (stop-stage-worker)
  (format t "Starting stage worker~%")
  (setf *stage-worker-stop* nil)
  (setf *stage-worker-thread*
        (bt2:make-thread
         (lambda ()
           (loop
             (bt2:wait-on-semaphore *stage-worker-semaphore*)
             (when *stage-worker-stop*
               (format t "Exiting stage worker loop~%")
               (return))
             (handler-case
                 (process-stage)
               (error (e)
                 (format t "Error during process stage, continuing: ~A~%" e)))))
         :name "stage-worker")))

(defun stop-stage-worker ()
  (when (and *stage-worker-thread* (bt2:thread-alive-p *stage-worker-thread*))
    (setf *stage-worker-stop* t)
    (bt2:signal-semaphore *stage-worker-semaphore*)
    (bt2:join-thread *stage-worker-thread*))
  (setf *stage-worker-thread* nil))

(defun notify-stage-worker ()
  (bt2:signal-semaphore *stage-worker-semaphore*))

;;; Inbox Worker

(defvar *inbox-worker-semaphore* (bt2:make-semaphore :name "inbox-worker"))
(defvar *inbox-worker-thread* nil)
(defvar *inbox-worker-stop* nil)

(defun start-inbox-worker ()
  (stop-inbox-worker)
  (format t "Starting inbox worker~%")
  (setf *inbox-worker-stop* nil)
  (setf *inbox-worker-thread*
        (bt2:make-thread
         (lambda ()
           (loop
             (bt2:wait-on-semaphore *inbox-worker-semaphore*)
             (when *inbox-worker-stop*
               (format t "Exiting inbox worker loop~%")
               (return))
             (handler-case
                 (process-inbox)
               (error (e)
                 (format t "Error during process inbox, continuing: ~A~%" e)))))
         :name "inbox-worker")))

(defun stop-inbox-worker ()
  (when (and *inbox-worker-thread* (bt2:thread-alive-p *inbox-worker-thread*))
    (setf *inbox-worker-stop* t)
    (bt2:signal-semaphore *inbox-worker-semaphore*)
    (bt2:join-thread *inbox-worker-thread*))
  (setf *inbox-worker-thread* nil))

(defun notify-inbox-worker ()
  (bt2:signal-semaphore *inbox-worker-semaphore*))

;;; Inbox Watcher

(defvar *inbox-watcher-thread* nil)
(defvar *inbox-watcher-stop* nil)
(defvar *inbox-watcher-interval* 2)

(defun start-inbox-watcher ()
  (stop-inbox-watcher)
  (format t "Starting inbox watcher~%")
  (setf *inbox-watcher-stop* nil)
  (setf *inbox-watcher-thread*
        (bt2:make-thread
         (lambda ()
           (handler-case
               (loop
                 (when *inbox-watcher-stop*
                   (format t "Exiting inbox watcher loop~%")
                   (return))
                 (notify-inbox-worker)
                 (sleep *inbox-watcher-interval*))
             (error (e)
               (format t "Exiting inbox watcher loop: ~A~%" e))))
         :name "inbox-watcher")))

(defun stop-inbox-watcher ()
  (when (and *inbox-watcher-thread* (bt2:thread-alive-p *inbox-watcher-thread*))
    (setf *inbox-watcher-stop* t)
    (bt2:join-thread *inbox-watcher-thread*))
  (setf *inbox-watcher-thread* nil))

;;; Lifecycle

(defun stop ()
  (format t "Stopping importer~%")

  (stop-inbox-watcher)
  (stop-inbox-worker)
  (stop-stage-worker)
  (stop-complete-worker))

(defun start (&key media-dir)
  (format t "Starting importer~%")

  (setf *inbox-dir* (merge-pathnames "inbox/" media-dir))
  (setf *staging-dir* (merge-pathnames "staging/" media-dir))

  (start-complete-worker)
  (notify-complete-worker)
  (start-stage-worker)
  (notify-stage-worker)
  (start-inbox-worker)
  (start-inbox-watcher)
  (notify-inbox-worker))
