#lang racket/base

(require racket-audio
         racket/file
         racket/list
         racket-mimetypes
         racket/path
         racket/string)

(provide (struct-out music-library)
         (struct-out browser-entry)
         (struct-out track)
         (struct-out artwork)
         make-music-libraries
         library-contains-audio-file?
         browse-library
         browser-entry->tracks
         track-artwork)

(struct music-library
  (id name root)
  #:transparent)

(struct browser-entry
  (name kind relative-path)
  #:transparent)

(struct track
  (file title artist album duration mime-type)
  #:transparent)

(struct artwork
  (mime-type data)
  #:transparent)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define supported-extensions
  (audio-supported-extensions))

(define cover-file-names
  '("cover.jpg" "cover.jpeg" "cover.png"
    "folder.jpg" "folder.jpeg" "folder.png"
    "front.jpg" "front.jpeg" "front.png"))

;;; Checks whether a path has an extension supported by racket-audio.
(define (audio-file? file)
  (let ((extension (path-get-extension file)))
    (if (eq? extension #f)
        #f
        (let ((extension-name
               (string-downcase
                (string-trim
                 (bytes->string/utf-8 extension)
                 "."))))
          (if (member extension-name supported-extensions)
              #t
              #f)))))

;;; Checks whether the final path element starts with a dot.
(define (hidden-name? path)
  (string-prefix? (path->string path) "."))

;;; Derives a fallback track title from the file name without its extension.
(define (file-title file)
  (let* ((name (file-name-from-path file))
         (without-extension
          (if name
              (path-replace-extension name #"")
              file)))
    (path->string without-extension)))

;;; Returns a non-empty string value or the supplied fallback.
(define (nonempty value fallback)
  (if (and (string? value)
           (not (string=? (string-trim value) "")))
      value
      fallback))

;;; Reads audio metadata and converts a file path to a track value.
;;; File-name and MIME-type fallbacks are used when metadata cannot be read.
(define (path->track file)
  (let ((fallback-title (file-title file)))
    (with-handlers
        ((exn:fail?
          (λ (_)
            (track file fallback-title "" "" #f
                   (mimetype-for-ext file)))))
      (call-with-id3-tags
       file
       (λ (tags)
         (if (tags-valid? tags)
             (track file
                    (nonempty (tags-title tags) fallback-title)
                    (nonempty (tags-artist tags) "")
                    (nonempty (tags-album tags) "")
                    (let ((length (tags-length tags)))
                      (if (and (number? length) (positive? length))
                          length
                          #f))
                    (mimetype-for-ext file))
             (track file fallback-title "" "" #f
                    (mimetype-for-ext file))))))))

;;; Builds the filesystem path represented by a library-relative path.
(define (library-path library relative-path)
  (if (null? relative-path)
      (music-library-root library)
      (apply build-path
             (music-library-root library)
             relative-path)))

;;; Classifies a path as a container, supported track or unusable entry.
(define (path-kind path)
  (cond
    ((directory-exists? path) 'container)
    ((and (file-exists? path)
          (audio-file? path))
     'track)
    (else #f)))

;;; Orders browser entries with containers first and names alphabetically.
(define (entry<? first second)
  (cond
    ((and (eq? (browser-entry-kind first) 'container)
          (eq? (browser-entry-kind second) 'track))
     #t)
    ((and (eq? (browser-entry-kind first) 'track)
          (eq? (browser-entry-kind second) 'container))
     #f)
    (else
     (string-ci<? (browser-entry-name first)
                  (browser-entry-name second)))))

;;; Recursively converts the browsable contents of a directory to tracks.
(define (directory-tracks library relative-path)
  (append-map
   (λ (entry)
     (if (eq? (browser-entry-kind entry) 'container)
         (directory-tracks library
                           (browser-entry-relative-path entry))
         (list
          (path->track
           (library-path library
                         (browser-entry-relative-path entry))))))
   (browse-library library relative-path)))

;;; Produces a resolved complete path, or #f when resolution fails.
(define (complete-path/safe path)
  (with-handlers ((exn:fail? (λ (_) #f)))
    (simplify-path (path->complete-path path) #t)))

;;; Checks whether file is located below root without traversing upward.
(define (path-below-root? root file)
  (let* ((relative (find-relative-path root file))
         (elements (explode-path relative)))
    (and (relative-path? relative)
         (not (member 'up elements)))))

;;; Recognizes a library specification containing a display name and path.
(define (named-library-specification? specification)
  (and (list? specification)
       (= (length specification) 2)
       (string? (car specification))
       (path-string? (cadr specification))))

;;; Extracts the optional display name and path from a library specification.
(define (specification-values specification)
  (cond
    ((named-library-specification? specification)
     (values (string-trim (car specification))
             (cadr specification)))
    ((path-string? specification)
     (values #f specification))
    (else
     (raise-argument-error
      'make-music-libraries
      "(or/c path-string? (list/c string? path-string?))"
      specification))))

;;; Reads embedded ID3 artwork from a track, returning #f when unavailable.
(define (embedded-artwork item)
  (with-handlers ((exn:fail? (λ (_) #f)))
    (call-with-id3-tags
     (track-file item)
     (λ (tags)
       (if (not (tags-valid? tags))
           #f
           (let ((picture (tags-picture tags)))
             (if (eq? picture #f)
                 #f
                 (let ((mime (id3-picture-mimetype picture)))
                   (artwork
                    (if (and (string? mime)
                             (not (string=? mime "")))
                        mime
                        "application/octet-stream")
                    (id3-picture-bytes picture))))))))))

;;; Checks whether a path names an existing conventional cover image.
(define (cover-file? candidate)
  (let ((name (file-name-from-path candidate)))
    (cond
      ((eq? name #f) #f)
      ((not (file-exists? candidate)) #f)
      ((member (path->string name)
               cover-file-names
               string-ci=?) #t)
      (else #f))))

;;; Searches the track directory for a conventional cover image.
(define (cover-artwork item)
  (with-handlers ((exn:fail? (λ (_) #f)))
    (let* ((track-directory (path-only (track-file item)))
           (directory (if (eq? track-directory #f)
                          (current-directory)
                          track-directory))
           (cover (findf cover-file?
                         (directory-list directory #:build? #t))))
      (if (eq? cover #f)
          #f
          (let ((mime (mimetype-for-ext cover)))
            (artwork (if (string? mime)
                         mime
                         "application/octet-stream")
                     (file->bytes cover)))))))

;;; Validates one normalized library root and constructs its public value.
(define (named-root->music-library named-root index)
  (let ((configured-name (car named-root))
        (root (cadr named-root)))
    (unless (directory-exists? root)
      (raise-arguments-error
       'make-music-libraries
       "music library is not an existing directory"
       "path" root))
    (let* ((name (file-name-from-path root))
           (default-name (if (eq? name #f)
                             (path->string root)
                             (path->string name))))
      (music-library
       (format "library-~a" index)
       (cond
         ((eq? configured-name #f) default-name)
         ((string=? configured-name "") default-name)
         (else configured-name))
       root))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Check whether a supported audio file belongs to a music library.
; pre    : Libraries contains music-library values; file may be any value.
; post   : The file system remains unchanged.
; result : #t when file exists below a configured root, otherwise #f.
; internals: audio-file? first rejects unsupported files. complete-path/safe
;            resolves the candidate and each library root. The named loop calls
;            path-below-root? until one root contains the file; that helper uses
;            find-relative-path and rejects paths containing an 'up element.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (library-contains-audio-file? libraries file)
  (cond
    ((not (path-string? file)) #f)
    ((not (file-exists? file)) #f)
    ((not (audio-file? file)) #f)
    (else
     (let ((full-file (complete-path/safe file)))
       (if (eq? full-file #f)
           #f
           (let loop ((remaining libraries))
             (if (null? remaining)
                 #f
                 (let ((root
                        (complete-path/safe
                         (music-library-root (car remaining)))))
                   (cond
                     ((eq? root #f)
                      (loop (cdr remaining)))
                     ((path-below-root? root full-file) #t)
                     (else
                      (loop (cdr remaining))))))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Turn configured directory paths into music libraries.
; pre    : Every value is a path or a (display-name path) list.
; post   : No directory contents or audio metadata have been read.
; result : Libraries in configuration order, without duplicate roots.
; internals: specification-values separates each optional name from its path.
;            map normalizes the paths and remove-duplicates compares their
;            roots. The named loop calls named-root->music-library to validate
;            each directory and assign its sequential library id.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-music-libraries specifications)
  (let ((roots
         (remove-duplicates
          (map (λ (specification)
                 (let-values (((name path)
                               (specification-values specification)))
                   (list name
                         (normal-case-path
                          (path->complete-path path)))))
               specifications)
          (λ (first second)
            (equal? (cadr first) (cadr second))))))
    (let loop ((remaining roots)
               (index 0))
      (if (null? remaining)
          '()
          (cons (named-root->music-library (car remaining) index)
                (loop (cdr remaining) (add1 index)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Read the artwork associated with a track.
; pre    : Item names a local audio file.
; post   : The audio file and optional neighbouring image remain unchanged.
; result : Embedded artwork, a conventional folder cover, or #f.
; internals: embedded-artwork first reads the picture stored in the audio tags.
;            Only when that returns #f does cover-artwork search the track's
;            directory for one of the names in cover-file-names.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (track-artwork item)
  (let ((embedded (embedded-artwork item)))
    (if (eq? embedded #f)
        (cover-artwork item)
        embedded)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : List the immediate folders and supported audio files in a library.
; pre    : Relative-path was produced by a previous browse result.
; post   : Child directories are listed before tracks; metadata is not read.
; result : Browser entries for one directory level.
; internals: library-path resolves the requested directory. directory-list and
;            path-kind supply filter-map with usable children; hidden-name?
;            removes hidden containers. sort uses entry<? to put containers
;            first and compare names without regard to case.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (browse-library library relative-path)
  (let ((path (library-path library relative-path)))
    (unless (directory-exists? path)
      (raise-arguments-error
       'browse-library
       "library directory does not exist"
       "path" path))
    (sort
     (filter-map
      (λ (name)
        (let* ((full-path (build-path path name))
               (kind (path-kind full-path)))
          (cond
            ((eq? kind #f) #f)
            ((eq? kind 'container)
             (if (hidden-name? name)
                 #f
                 (browser-entry
                  (path->string name)
                  kind
                  (append relative-path (list name)))))
            (else
             (browser-entry
              (path->string name)
              kind
              (append relative-path (list name)))))))
      (directory-list path))
     entry<?)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Resolve a selected browser entry to playable tracks.
; pre    : Entry belongs to library and was produced by browse-library.
; post   : Track metadata is read; containers are traversed recursively.
; result : One track, or all supported tracks below the selected container.
; internals: A track entry is resolved by library-path and read by path->track.
;            A container is passed to directory-tracks, which recursively calls
;            browse-library and path->track in browser sort order.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (browser-entry->tracks library entry)
  (if (eq? (browser-entry-kind entry) 'container)
      (directory-tracks library
                        (browser-entry-relative-path entry))
      (list
       (path->track
        (library-path library
                      (browser-entry-relative-path entry))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for module library.rkt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(module+ test
  (require rackunit)

  (define root
    (make-temporary-file "rkt-web-library-~a" 'directory))

  (define outside-file
    (make-temporary-file "rkt-web-outside-~a.mp3"))

  (dynamic-wind
    void
    (λ ()
      (make-directory (build-path root "Album"))
      (make-directory (build-path root ".Hidden"))
      (call-with-output-file
       (build-path root "Album" "inside.mp3") void)
      (call-with-output-file (build-path root "track.mp3") void)
      (call-with-output-file (build-path root "cover.jpg") void)
      (call-with-output-file (build-path root "ignored.txt") void)
      (let* ((libraries (make-music-libraries (list root)))
             (entries (browse-library (car libraries) '())))
        (check-equal? (length libraries) 1)
        (check-equal? (length entries) 2)
        (check-equal? (browser-entry-name (car entries)) "Album")
        (check-eq? (browser-entry-kind (car entries)) 'container)
        (check-equal? (browser-entry-name (cadr entries)) "track.mp3")
        (check-eq? (browser-entry-kind (cadr entries)) 'track)
        (check-equal?
         (length
          (browser-entry->tracks (car libraries) (car entries)))
         1)
        (check-true
         (library-contains-audio-file?
          libraries
          (build-path root "track.mp3")))
        (check-true
         (library-contains-audio-file?
          libraries
          (build-path root "Album" "inside.mp3")))
        (check-false
         (library-contains-audio-file?
          libraries
          (build-path root "cover.jpg")))
        (check-false
         (library-contains-audio-file?
          libraries
          outside-file))
        (check-equal?
         (length (make-music-libraries (list root root)))
         1)
        (check-equal?
         (music-library-name
          (car (make-music-libraries
                (list (list "Luisterkamer" root)))))
         "Luisterkamer")
        (check-equal?
         (artwork-mime-type
          (track-artwork
           (track (build-path root "track.mp3")
                  "Track" "" "" #f "audio/mpeg")))
         "image/jpeg")))
    (λ ()
      (delete-directory/files root)
      (delete-file outside-file))))