iitalics/format-tracks.rkt

## format-tracks.rkt
#lang racket/base
(require
 racket/string
 racket/port
 racket/system
 racket/match
 racket/format)

(module+ test
  (require
   rackunit racket/port))

;; -----------------------------------------------------------------------------
;; Utils

(define-syntax-rule (regexp-case str-expr
                                 [re formals body ...]
                                 ...
                                 [#t else-body ...])
  (let ([str str-expr])
    (cond
      [(regexp-match re str)
       => (λ (groups)
            (apply (λ formals body ...)
                   (cdr groups)))]
      ...
      [else else-body ...])))


;; -----------------------------------------------------------------------------
;; Parameters

(define current-get-info-file-path
  (make-parameter
   (λ (audio-file-path)
     (path-replace-extension audio-file-path
                             #".info"))))

(define current-get-output-dir-path
  (make-parameter
   (λ (audio-file-path)
     (path-replace-extension audio-file-path #""))))

(define current-find-album-art-path
  (make-parameter
   (λ (audio-file-path)
     (for*/first ([ext (in-list '(#".png" #".jpg" #".jpeg" #".tiff"))]
                  [path (in-value (path-replace-extension audio-file-path ext))]
                  #:when (file-exists? path))
       path))))

(define current-output-extension
  (make-parameter #".mp3"))

(define current-ffmpeg
  (make-parameter "/usr/bin/ffmpeg"))

(define (get-info-file-path af)
  ((current-get-info-file-path) af))

(define (get-output-dir-path af)
  ((current-get-output-dir-path) af))

(define (find-album-art-path af)
  ((current-find-album-art-path) af))

(define (path-add-output-extension p)
  (path-add-extension p (current-output-extension) #"."))

(module+ test
  (check-equal? (get-info-file-path "bar/foo.flac")
                (string->path "bar/foo.info"))
  (check-equal? (get-output-dir-path "bar/foo.mp3")
                (string->path "bar/foo"))
  (check-equal? (path-add-output-extension "bar/foo/one")
                (string->path "bar/foo/one.mp3")))


;; --------------------------------------------------------------------------------
;; Info files

;; meta : (hasheq symbol => string)
;; tracks : (listof track-info)
(struct album-info [meta tracks]
  #:transparent)

;; title : string
;; number start end : nat
(struct track-info [title number start end]
  #:transparent)

;; (read-album-info [port]) -> album-info
;; port : input-port
(define (read-album-info [port (current-input-port)])

  ;; #px"([0-9]+:)*[0-9]+" -> nat
  (define (time-string->seconds ts)
    (for/fold ([acc 0])
              ([part (in-list (string-split ts ":"))])
      (+ (* acc 60)
         (string->number part))))

  ; parse lines
  (define-values [tracks-unsorted meta]
    (for/fold ([tracks '()]
               [meta (hasheq)])
              ([line (in-lines port)])
      (regexp-case
       line

       [#px"^\\*\\s+([a-z]*)\\s+(.*)"
        (key value)
        (define meta* (hash-set meta
                                (string->symbol key)
                                (string-trim value)))
        (values tracks meta*)]

       [#px"^([^*].+)\\s((\\d{1,2}:)+\\d{2})"
        (title start _)
        (define track (track-info (string-trim title)
                                  #f                           ; number
                                  (time-string->seconds start) ; start
                                  #f))                         ; end
        (values (cons track tracks) meta)]

       [#t
        (values tracks meta)])))

  ; sort tracks by starting time
  (define tracks
    (sort tracks-unsorted <
          #:key track-info-start))

  ; fill in track-info-number and track-info-end
  (define tracks*
    (for/list ([t  (in-list tracks)]
               [t* (in-list (append (cdr tracks) (list #f)))]
               [i  (in-naturals 1)])
      (struct-copy track-info t
                   [number i]
                   [end (and t* (track-info-start t*))])))

  (album-info meta tracks*))

(module+ test
  (define t1 (+ 23 (* 60 1)))
  (define t2 (+ 45 (* 60 23) (* 60 60 1)))

  (check-equal?
   (with-input-from-string
     (string-append "* foo hello world\n"
                    "SO NG  1:23\n"
                    "* bar    hey   \n"
                    "SAN G     01:23:45\n"
                    "S ING     0:00\n")
     read-album-info)
   (album-info
    (hasheq 'foo "hello world"
            'bar "hey")
    (list (track-info "S ING" 1 0 t1)
          (track-info "SO NG" 2 t1 t2)
          (track-info "SAN G" 3 t2 #f)))))


;; --------------------------------------------------------------------------------
;; String manip

;; track-title->file-part : string -> string
(define (track-title->file-part title-string)
  ; remove parenthesis and the text inside of them (doesn't support nesting, but that is
  ; okay)
  (define (remove-parens s)
    (regexp-case
     s
     [#px"^(.+)[(\\[].+?[)\\]](.*)"
      (before after)
      (remove-parens (string-append (string-trim before)
                                    after))]
     [#t s]))

  ; group into words (groups of alphabetic chars)
  (define (split-words s)
    (let loop ([acc '()] [chars (string->list s)])
      (cond
        [(null? chars) (list (reverse acc))]
        ; important chars
        [(or (char-alphabetic? (car chars))
             (char-numeric? (car chars)))
         (loop (cons (car chars) acc)
               (cdr chars))]
        ; ignored chars
        [(member (car chars) '(#\'))
         (loop acc
               (cdr chars))]
        ; everything else breaks works
        [else
         (cons (reverse acc)
               (loop '() (cdr chars)))])))

  ; write chars to current-output-port in titlecase
  (define (write-titlecase chars)
    (unless (null? chars)
      (write-char (char-upcase (car chars)))
      (for ([c (in-list (cdr chars))])
        (write-char (char-downcase c)))))

  (with-output-to-string
    (λ ()
      (for-each write-titlecase
                (split-words (remove-parens title-string))))))

;; track-info -> path
(define (track-info-file-name trk)
  (path-add-output-extension
   (format "~a.~a"
           (~a (track-info-number trk)
               #:pad-string "0" #:width 2 #:align 'right)
           (track-title->file-part (track-info-title trk)))))


(module+ test
  (check-equal?
   (track-title->file-part "foo (ft. somebody) bar")
   "FooBar")
  (check-equal?
   (track-title->file-part "foo (ft. somebody) (remix)")
   "Foo")
  (check-equal?
   (track-title->file-part "the, quick: brown fox!! (ft. somebody) [remix]")
   "TheQuickBrownFox")
  (check-equal?
   (track-title->file-part "igor's theme")
   "IgorsTheme")

  (check-equal?
   (track-info-file-name
    (track-info "foo bar" 4 0 #f))
   (string->path "04.FooBar.mp3")))


;; --------------------------------------------------------------------------------
;; IO

(struct exn:fail:ffmpeg exn:fail [status output])

(define (raise-ffmpeg-error sc out)
  (make-exn:fail (format "ffmpeg process failed with status ~a" sc)
                 (current-continuation-marks)
                 sc out))

;; (clip-audio ..) -> string
;; input-file-path, output-file-path : path
;; art-file-path : (or path #f)
;; start : nat
;; end : (or nat #f)
;; meta : (hasheq symbol => string)
;; --
;; raises exn:fail:ffmpeg
(define (clip-audio #:in input-file-path
                    #:out output-file-path
                    #:art [art-file-path #f]
                    #:meta meta
                    start end)

  (define (seconds->string n)
    (format "~as" n))

  (define general-flags
    `("-y"))

  (define infile-flags
    (append `("-ss" ,(seconds->string start))
            (if end
              (list "-t" (seconds->string (- end start)))
              (list))))

  (define outfile-flags
    (append (apply append
                   (for/list ([(k v) (in-hash meta)])
                     `("-metadata:g" ,(format "~a=~a" k v))))
            (list "-map" "0"
                  "-map" "1")))

  (define-values [sp sp-out sp-in sp-err]
    (apply subprocess `(#f #f #f
                        ,(current-ffmpeg)
                        ,@general-flags
                        ,@infile-flags
                        "-i" ,(path->string input-file-path)
                        ,@(if art-file-path
                            (list "-i" (path->string art-file-path))
                            (list))
                        ,@outfile-flags
                        ,(path->string output-file-path))))

  (subprocess-wait sp)

  (define sc (subprocess-status sp))
  (define out (string-append
               (port->string sp-err)
               (port->string sp-out)))

  (if (zero? sc)
    out
    (raise-ffmpeg-error sc out)))

;; (format-tracks path) -> void
(define (format-tracks audio-file-path)
  (define info-file-path (get-info-file-path audio-file-path))
  (define art-file-path  (find-album-art-path audio-file-path))
  (define output-dir-path (get-output-dir-path audio-file-path))

  (unless (file-exists? audio-file-path)
    (error (format "audio file ~s does not exist!"
                   (path->string audio-file-path))))

  (define alb
    (with-handlers ([exn:fail:filesystem?
                     (λ (e)
                       (error (format "info file ~s does not exist!"
                                      (path->string info-file-path))))])
      (with-input-from-file info-file-path
        read-album-info)))

  (with-handlers ([exn:fail:filesystem?
                   (λ (e)
                     (error (format "output directory ~s already exists!"
                                    (path->string output-dir-path))))])
    (make-directory output-dir-path))

  ;; -----

  (define notifs (make-channel))

  (when art-file-path
    (printf "using album art: ~a\n"
            (path->string art-file-path)))

  (printf "processing ~a tracks for album ~s\n----------------------------------------\n"
          (length (album-info-tracks alb))
          (hash-ref (album-info-meta alb)
                    'album
                    "(no title given)"))

  (for ([trk (in-list (album-info-tracks alb))])

    (define dest-path
      (build-path output-dir-path
                  (track-info-file-name trk)))

    (define meta
      (hash-set* (album-info-meta alb)
                 'track (number->string (track-info-number trk))
                 'title (track-info-title trk)))

    (thread
     (λ ()
       (with-handlers ([exn:fail?
                        (λ (ex) (channel-put notifs `(failed ,trk ,ex)))])
         (clip-audio #:in audio-file-path
                     #:art art-file-path
                     #:out dest-path
                     #:meta meta
                     (track-info-start trk)
                     (track-info-end trk))
         (channel-put notifs `(ok ,trk))))))

  (let loop ([n 0])
    (when (< n (length (album-info-tracks alb)))
      (match (channel-get notifs)
        [`(failed ,trk ,ex)
         (printf "FAILED: ~s\n" (track-info-title trk))
         (with-output-to-file "log.txt"
           #:exists 'append
           (λ ()
             (match ex
               [(exn:fail:ffmpeg _ _ sc out)
                (printf "STATUS CODE: ~a\n" sc)
                (write-string out)]
               [(exn msg _)
                (write-string msg)])))

         (loop (add1 n))]

        [`(ok ,trk)
         (printf "finished ~s\n" (track-info-title trk))
         (loop (add1 n))])))

  (printf "----------------------------------------\n")
  (printf "all finished\n"))

;; =============================================================================

(module+ main
  (require racket/cmdline)

  (command-line
   #:once-each
   [("-d" "--info-file")
    info-file "Info file (defaults to audio file, with extension `.info'"
    (current-get-info-file-path (λ (_) (string->path info-file)))]
   [("-i" "--output-dir")
    info-file "Output directory (defaults to audio file with no extension"
    (current-get-output-dir-path (λ (_) (string->path info-file)))]
   [("-a" "--art")
    art-file "Album art file"
    (current-find-album-art-path (λ (_) (string->path art-file)))]

   #:args (audio-file)
   (format-tracks (string->path audio-file))))
	#lang racket/base
	(require
	racket/string
	racket/port
	racket/system
	racket/match
	racket/format)

	(module+ test
	(require
	rackunit racket/port))

	;; -----------------------------------------------------------------------------
	;; Utils

	(define-syntax-rule (regexp-case str-expr
	[re formals body ...]
	...
	[#t else-body ...])
	(let ([str str-expr])
	(cond
	[(regexp-match re str)
	=> (λ (groups)
	(apply (λ formals body ...)
	(cdr groups)))]
	...
	[else else-body ...])))


	;; -----------------------------------------------------------------------------
	;; Parameters

	(define current-get-info-file-path
	(make-parameter
	(λ (audio-file-path)
	(path-replace-extension audio-file-path
	#".info"))))

	(define current-get-output-dir-path
	(make-parameter
	(λ (audio-file-path)
	(path-replace-extension audio-file-path #""))))

	(define current-find-album-art-path
	(make-parameter
	(λ (audio-file-path)
	(for*/first ([ext (in-list '(#".png" #".jpg" #".jpeg" #".tiff"))]
	[path (in-value (path-replace-extension audio-file-path ext))]
	#:when (file-exists? path))
	path))))

	(define current-output-extension
	(make-parameter #".mp3"))

	(define current-ffmpeg
	(make-parameter "/usr/bin/ffmpeg"))

	(define (get-info-file-path af)
	((current-get-info-file-path) af))

	(define (get-output-dir-path af)
	((current-get-output-dir-path) af))

	(define (find-album-art-path af)
	((current-find-album-art-path) af))

	(define (path-add-output-extension p)
	(path-add-extension p (current-output-extension) #"."))

	(module+ test
	(check-equal? (get-info-file-path "bar/foo.flac")
	(string->path "bar/foo.info"))
	(check-equal? (get-output-dir-path "bar/foo.mp3")
	(string->path "bar/foo"))
	(check-equal? (path-add-output-extension "bar/foo/one")
	(string->path "bar/foo/one.mp3")))


	;; --------------------------------------------------------------------------------
	;; Info files

	;; meta : (hasheq symbol => string)
	;; tracks : (listof track-info)
	(struct album-info [meta tracks]
	#:transparent)

	;; title : string
	;; number start end : nat
	(struct track-info [title number start end]
	#:transparent)

	;; (read-album-info [port]) -> album-info
	;; port : input-port
	(define (read-album-info [port (current-input-port)])

	;; #px"([0-9]+:)*[0-9]+" -> nat
	(define (time-string->seconds ts)
	(for/fold ([acc 0])
	([part (in-list (string-split ts ":"))])
	(+ (* acc 60)
	(string->number part))))

	; parse lines
	(define-values [tracks-unsorted meta]
	(for/fold ([tracks '()]
	[meta (hasheq)])
	([line (in-lines port)])
	(regexp-case
	line

	[#px"^\\\\s+([a-z])\\s+(.*)"
	(key value)
	(define meta* (hash-set meta
	(string->symbol key)
	(string-trim value)))
	(values tracks meta*)]

	[#px"^([^*].+)\\s((\\d{1,2}:)+\\d{2})"
	(title start _)
	(define track (track-info (string-trim title)
	#f ; number
	(time-string->seconds start) ; start
	#f)) ; end
	(values (cons track tracks) meta)]

	[#t
	(values tracks meta)])))

	; sort tracks by starting time
	(define tracks
	(sort tracks-unsorted <
	#:key track-info-start))

	; fill in track-info-number and track-info-end
	(define tracks*
	(for/list ([t (in-list tracks)]
	[t* (in-list (append (cdr tracks) (list #f)))]
	[i (in-naturals 1)])
	(struct-copy track-info t
	[number i]
	[end (and t* (track-info-start t*))])))

	(album-info meta tracks*))

	(module+ test
	(define t1 (+ 23 (* 60 1)))
	(define t2 (+ 45 (* 60 23) (* 60 60 1)))

	(check-equal?
	(with-input-from-string
	(string-append "* foo hello world\n"
	"SO NG 1:23\n"
	"* bar hey \n"
	"SAN G 01:23:45\n"
	"S ING 0:00\n")
	read-album-info)
	(album-info
	(hasheq 'foo "hello world"
	'bar "hey")
	(list (track-info "S ING" 1 0 t1)
	(track-info "SO NG" 2 t1 t2)
	(track-info "SAN G" 3 t2 #f)))))


	;; --------------------------------------------------------------------------------
	;; String manip

	;; track-title->file-part : string -> string
	(define (track-title->file-part title-string)
	; remove parenthesis and the text inside of them (doesn't support nesting, but that is
	; okay)
	(define (remove-parens s)
	(regexp-case
	s
	[#px"^(.+)[(\\[].+?[)\\]](.*)"
	(before after)
	(remove-parens (string-append (string-trim before)
	after))]
	[#t s]))

	; group into words (groups of alphabetic chars)
	(define (split-words s)
	(let loop ([acc '()] [chars (string->list s)])
	(cond
	[(null? chars) (list (reverse acc))]
	; important chars
	[(or (char-alphabetic? (car chars))
	(char-numeric? (car chars)))
	(loop (cons (car chars) acc)
	(cdr chars))]
	; ignored chars
	[(member (car chars) '(#\'))
	(loop acc
	(cdr chars))]
	; everything else breaks works
	[else
	(cons (reverse acc)
	(loop '() (cdr chars)))])))

	; write chars to current-output-port in titlecase
	(define (write-titlecase chars)
	(unless (null? chars)
	(write-char (char-upcase (car chars)))
	(for ([c (in-list (cdr chars))])
	(write-char (char-downcase c)))))

	(with-output-to-string
	(λ ()
	(for-each write-titlecase
	(split-words (remove-parens title-string))))))

	;; track-info -> path
	(define (track-info-file-name trk)
	(path-add-output-extension
	(format "~a.~a"
	(~a (track-info-number trk)
	#:pad-string "0" #:width 2 #:align 'right)
	(track-title->file-part (track-info-title trk)))))


	(module+ test
	(check-equal?
	(track-title->file-part "foo (ft. somebody) bar")
	"FooBar")
	(check-equal?
	(track-title->file-part "foo (ft. somebody) (remix)")
	"Foo")
	(check-equal?
	(track-title->file-part "the, quick: brown fox!! (ft. somebody) [remix]")
	"TheQuickBrownFox")
	(check-equal?
	(track-title->file-part "igor's theme")
	"IgorsTheme")

	(check-equal?
	(track-info-file-name
	(track-info "foo bar" 4 0 #f))
	(string->path "04.FooBar.mp3")))


	;; --------------------------------------------------------------------------------
	;; IO

	(struct exn:fail:ffmpeg exn:fail [status output])

	(define (raise-ffmpeg-error sc out)
	(make-exn:fail (format "ffmpeg process failed with status ~a" sc)
	(current-continuation-marks)
	sc out))

	;; (clip-audio ..) -> string
	;; input-file-path, output-file-path : path
	;; art-file-path : (or path #f)
	;; start : nat
	;; end : (or nat #f)
	;; meta : (hasheq symbol => string)
	;; --
	;; raises exn:fail:ffmpeg
	(define (clip-audio #:in input-file-path
	#:out output-file-path
	#:art [art-file-path #f]
	#:meta meta
	start end)

	(define (seconds->string n)
	(format "~as" n))

	(define general-flags
	`("-y"))

	(define infile-flags
	(append `("-ss" ,(seconds->string start))
	(if end
	(list "-t" (seconds->string (- end start)))
	(list))))

	(define outfile-flags
	(append (apply append
	(for/list ([(k v) (in-hash meta)])
	`("-metadata:g" ,(format "~a=~a" k v))))
	(list "-map" "0"
	"-map" "1")))

	(define-values [sp sp-out sp-in sp-err]
	(apply subprocess `(#f #f #f
	,(current-ffmpeg)
	,@general-flags
	,@infile-flags
	"-i" ,(path->string input-file-path)
	,@(if art-file-path
	(list "-i" (path->string art-file-path))
	(list))
	,@outfile-flags
	,(path->string output-file-path))))

	(subprocess-wait sp)

	(define sc (subprocess-status sp))
	(define out (string-append
	(port->string sp-err)
	(port->string sp-out)))

	(if (zero? sc)
	out
	(raise-ffmpeg-error sc out)))

	;; (format-tracks path) -> void
	(define (format-tracks audio-file-path)
	(define info-file-path (get-info-file-path audio-file-path))
	(define art-file-path (find-album-art-path audio-file-path))
	(define output-dir-path (get-output-dir-path audio-file-path))

	(unless (file-exists? audio-file-path)
	(error (format "audio file ~s does not exist!"
	(path->string audio-file-path))))

	(define alb
	(with-handlers ([exn:fail:filesystem?
	(λ (e)
	(error (format "info file ~s does not exist!"
	(path->string info-file-path))))])
	(with-input-from-file info-file-path
	read-album-info)))

	(with-handlers ([exn:fail:filesystem?
	(λ (e)
	(error (format "output directory ~s already exists!"
	(path->string output-dir-path))))])
	(make-directory output-dir-path))

	;; -----

	(define notifs (make-channel))

	(when art-file-path
	(printf "using album art: ~a\n"
	(path->string art-file-path)))

	(printf "processing ~a tracks for album ~s\n----------------------------------------\n"
	(length (album-info-tracks alb))
	(hash-ref (album-info-meta alb)
	'album
	"(no title given)"))

	(for ([trk (in-list (album-info-tracks alb))])

	(define dest-path
	(build-path output-dir-path
	(track-info-file-name trk)))

	(define meta
	(hash-set* (album-info-meta alb)
	'track (number->string (track-info-number trk))
	'title (track-info-title trk)))

	(thread
	(λ ()
	(with-handlers ([exn:fail?
	(λ (ex) (channel-put notifs `(failed ,trk ,ex)))])
	(clip-audio #:in audio-file-path
	#:art art-file-path
	#:out dest-path
	#:meta meta
	(track-info-start trk)
	(track-info-end trk))
	(channel-put notifs `(ok ,trk))))))

	(let loop ([n 0])
	(when (< n (length (album-info-tracks alb)))
	(match (channel-get notifs)
	[`(failed ,trk ,ex)
	(printf "FAILED: ~s\n" (track-info-title trk))
	(with-output-to-file "log.txt"
	#:exists 'append
	(λ ()
	(match ex
	[(exn:fail:ffmpeg _ _ sc out)
	(printf "STATUS CODE: ~a\n" sc)
	(write-string out)]
	[(exn msg _)
	(write-string msg)])))

	(loop (add1 n))]

	[`(ok ,trk)
	(printf "finished ~s\n" (track-info-title trk))
	(loop (add1 n))])))

	(printf "----------------------------------------\n")
	(printf "all finished\n"))

	;; =============================================================================

	(module+ main
	(require racket/cmdline)

	(command-line
	#:once-each
	[("-d" "--info-file")
	info-file "Info file (defaults to audio file, with extension `.info'"
	(current-get-info-file-path (λ (_) (string->path info-file)))]
	[("-i" "--output-dir")
	info-file "Output directory (defaults to audio file with no extension"
	(current-get-output-dir-path (λ (_) (string->path info-file)))]
	[("-a" "--art")
	art-file "Album art file"
	(current-find-album-art-path (λ (_) (string->path art-file)))]

	#:args (audio-file)
	(format-tracks (string->path audio-file))))