#!/usr/bin/guile \
-e ffmpeg-myth -s
!#
;;-*- geiser-scheme-implementation: guile -*-
;;-*- coding: utf-8 -*-

(use-modules (ice-9 rdelim) (ice-9 regex) (ice-9 popen))
(use-modules (srfi srfi-1))
(use-modules (srfi srfi-9 gnu))
(use-modules ((rnrs) :version (6)))
;;(use-modules ((guile json)))

(define mysql-cnf "~/my.cnf")
(define mysql-bin "mysql")
(define mythtv-db "mythconverg")
(define mysql-row-sep #\newline)
(define mysql-col-sep #\tab)
(define ffmpeg-bin "/usr/bin/ffmpeg")
(define ffprobe-bin "/usr/bin/ffprobe")
(define ffprobe-separator #\page) ;; 
(define ffmpeg-transcoding-options  "-c:v libx264 -preset slow -crf 21 -c:a ac3 -g 60 -keyint_min 30")
(define ffmpeg-transcoded-file-muxer 'mpegts) ;; 'matroska
(define recordings-directory "/var/lib/mythtv/recordings")
(define watched-recordings-directory "/var/lib/mythtv/watched-recordings")
(define working-directory "/mnt/lvraid5/ffmpeg-cut-list.d")
(define mythtv-recorded-table->metadata-list '(chanid starttime endtime title subtitle description season episode recordid seriesid programid inetref previouslyshown originalairdate))
(define (mythconverg-input-file-name)
  (string-copy (string-join (list working-directory "ffmpeg-mythconverg.XXXXXX") "/")))
(define shell-command-log #t)

(define (roundx x) (inexact->exact (round x)))

(define (write-to-file obj filename)
  (let ((port (open-file filename "w")))
    (catch 'write-error
      ;; thunk
      (lambda () (simple-format port "~a" obj) (force-output) (close port))
      ;; handler
      (lambda () (close port) 'write-error))))

(define* (shell-command-to-string* cmd args)
  (let* ((port (apply open-pipe* (append (list OPEN_READ cmd) args)))
	 (str (read-string port)))
    (close port)
    str))

(define* (shell-command-to-string cmd)
  (cond (shell-command-log
	 (simple-format #t "shell-command-to-string: ~a\n" cmd) (force-output)))
  (catch 'shell-command-error
    ;; thunk
    (lambda ()
      (let* ((port (open-pipe cmd OPEN_READ))
	     (str (read-string port))
	     (wtpd (close-pipe port))
	     (xval (status:exit-val wtpd)))
	(if (or (eqv? xval #f) (> xval 0)) (throw 'shell-command-error cmd str))
	(cond (shell-command-log
	       (simple-format #t "shell-command-to-string result: ~a\n" str) (force-output)))
	str))
    ;; handler
    (lambda (key cmd str)
      (simple-format #t "ERROR: in command ~a\nstring: ~a\n" cmd str)
      (throw 'error-in-shell-command-to-string cmd str))))

(define (mysql-escape-quote str)
  ;;  (string-join (string-split str #\') "'\"'\"'"))
  (string-join (string-split str #\') "\""))
(define (mythconverg-execute0 statement)
  (shell-command-to-string (simple-format #f "~a --defaults-file=~a --database=~a --execute='~a'" mysql-bin mysql-cnf mythtv-db (mysql-escape-quote statement))))
(define (mythconverg-source file)
  (mythconverg-execute0 (simple-format #f "source ~a" file)))
(define (mythconverg-execute statement)
  (cond ((< (string-length statement) 1024) ;; really could use < ARG_MAX (see getconf ARG_MAX)
	 (mythconverg-execute0 statement))
	(#t
	 (let* ((port (mkstemp! (mythconverg-input-file-name)))
		(tmpfile (port-filename port)))
	   (simple-format port statement) (force-output port) (close-port port)
	   (mythconverg-source tmpfile)
	   tmpfile))))

(define mysql-cmd "")
(define (mysql-start-transaction cmd)
  (set! mysql-cmd (simple-format #f "start transaction; ~a" cmd)))
(define (mysql-continue cmd)
  (set! mysql-cmd (simple-format #f "~a ~a" mysql-cmd cmd)))
(define (mysql-commit cmd)
  (set! mysql-cmd (simple-format #f "~a ~a commit;" mysql-cmd cmd)))



(define (elt n l)
  (let ((n* (if (>= n 0) n (+ (length l) n))))
    (car (drop l n*))))
(define (read-from-string s)
  (cond ((string? s)
	 (let ((r (with-input-from-string s read)))
	   (cond ((eof-object? r) s)
		 ((not (symbol? r)) r)
		 ((string= s (simple-format #f "~a" r))
		  r)
		 (#t s))))
	((list? s)
	 (map read-from-string s))
	(#t
	 (error "read-from-string" "encountered a not list/string"))))
(define (dsv-splitter s d)
  (cond ((string? s)
	 (string-split s d))
	((list? s)
	 (map (lambda(x) (dsv-splitter x d)) s))
	(#t
	 (error "dsv-splitter" "encountered a not list/string"))))
(define* (ffprobe-out-parser s)
  (dsv-splitter (delete "" (dsv-splitter s #\newline)) ffprobe-separator))
(define (k-v-parser s)
  (read-from-string (dsv-splitter s #\=)))
(define (map-cons l)
  (apply (lambda(x y) (map cons x y)) l))
(define (make-dotted-alist s)
  (cond ((and (list? s) (= 2 (length s)) (symbol? (car s)))
	 (cons (car s) (cadr s)))
	((and (list? s) (> (length s) 2))
	 (map make-dotted-alist s))
	(#t s)))



(define (mysql-parse-row r)
  (map read-from-string (string-split r mysql-col-sep)))
(define (mysql-parse-output s)
  (map mysql-parse-row (drop-right (string-split s mysql-row-sep) 1)))
(define (mythconverg-execute+parse statement)
  (mysql-parse-output (mythconverg-execute statement)))



(define (mythconverg-select* table chanid starttime)
  (mythconverg-execute+parse (simple-format #f "select * from ~a where chanid=~a and starttime=~a;" table chanid starttime)))
(define (mythconverg-get-recorded chanid starttime)
  (map-cons (mythconverg-select* "recorded" chanid starttime)))
(define (mythconverg-get-recordedmarkup chanid starttime)
  (map (lambda(x) (drop x 2)) (mythconverg-select* "recordedmarkup" chanid starttime)))


(define (ffprobe-video-packets file filter-rule)
  (let ((frame-info (read-from-string (ffprobe-out-parser
		     (shell-command-to-string (simple-format #f "~a -v error -select_streams v:0 -show_entries frame=pkt_pts_time,pkt_pos,pict_type,coded_picture_number,interlaced_frame:side_data=nil -print_format csv=nokey=1:print_section=0:s='~a' -i '~a'" ffprobe-bin ffprobe-separator file)))))
	(c -1))
    (define (add-coded_picture_number l)
      (set! c (+ c 1))
      (list (first l) (second l) (third l) c (fifth l)))
    (filter filter-rule (map add-coded_picture_number frame-info))))

(define (ffprobe-i-frames file)
  ;; filter out bad I-frames with N/A data in either the time (1) or frame number slot (2)
  (ffprobe-video-packets file (lambda(l) (and (eq? 'I (third l)) (not (eq? 'N/A (first l))) (not (eq? 'N/A (second l)))))))

(define (ffprobe-stream-info file)
  (let* ((stream-info (shell-command-to-string (simple-format #f "~a -v error -show_streams -print_format csv=nokey=0:s='~a' -i '~a'" ffprobe-bin ffprobe-separator file))))
    (map make-dotted-alist (k-v-parser (ffprobe-out-parser stream-info)))))


(define (mysql-get-cut/skip-list chanid starttime cut-or-skip)
  (let* ((s-e (if (eq? cut-or-skip 'cut) '(1 . 0) '(4 . 5)))
	 (s (mythconverg-execute+parse (simple-format #f "select mark,type from recordedmarkup where chanid=~a and starttime=~a and (type=~a or type=~a) order by mark;" chanid starttime (car s-e) (cdr s-e))))
	 (f (mythconverg-execute+parse (simple-format #f "select data from recordedmarkup where chanid=~a and starttime=~a and type=34;" chanid starttime))))
    (list (if (null? s) s (cdr s)) (if (null? f) f (cdr f)))))

(define (mythtv-make-concat-list s f)
  (let* ((mark first) (type second)
	 (start-of-cut? (lambda(x) (or (eq? x 1) (eq? x 4))))
	 (end-of-cut?   (lambda(x) (or (eq? x 0) (eq? x 5))))
	 (start 1) (end 0))
    (define (cl l acc)
      (if (null? l) (reverse acc)
	  (cond ((end-of-cut? (cdar l))
		 (cl (cddr l) (if (< (caar l) (caadr l)) (append (list (cons (caar l) (caadr l))) acc) acc)))
		(#t
		 (cl (cdr l) acc)))))
    (cond ((null? s)
	   (set! s '((0 0))))
	  ((and (start-of-cut? (cadar s)) (> (caar s) 0))
	   (set! s (append '((0 0)) s))))
    (if (end-of-cut?   (cadr (last s)))
	(set! s (append s (list (list (if (null? f) (greatest-fixnum) (caar f)) 1)))))
    (set! s (map (lambda(x) (if (start-of-cut? (cadr x)) (cons (car x) start) (cons (car x) end)))
		 s))
    (cl s '())))

(define (mythtv-get-retention-list chanid starttime cut-or-skip)
  (apply mythtv-make-concat-list (mysql-get-cut/skip-list chanid starttime cut-or-skip)))

(define (mythtv-find-nearest-i-frame-before/after idx frame-info test i-frame)
  (cond ((null? frame-info) i-frame)
	(#t
	 (let* ((i-frame (car frame-info))
		(cpn (fourth i-frame)))
	   (if (test cpn idx) i-frame (mythtv-find-nearest-i-frame-before/after idx (cdr frame-info) test i-frame))))))
(define (mythtv-find-nearest-i-frame-before idx frame-info)
  (mythtv-find-nearest-i-frame-before/after idx frame-info >= (first frame-info)))
(define (mythtv-find-nearest-i-frame-after idx frame-info)
  (mythtv-find-nearest-i-frame-before/after idx (reverse frame-info) <= (last frame-info)))

(define-immutable-record-type recording
  (make-recording chanid starttime recorded-table streams-info i-frame-info retain-list)
  recording?
  (chanid recording-chanid set-recording-chanid!)
  (starttime recording-starttime set-recording-starttime!)
  (recorded-table recording-recorded-table set-recording-recorded-table!)
  (streams-info recording-streams-info set-recording-streams-info!)
  (i-frame-info recording-i-frame-info set-recording-i-frame-info!)
  (retain-list recording-retain-list set-recording-retain-list!))

;; make a readable printer for the recording record
(define* (recording-printer rec #:optional (port #t))
    (define (rec-printer fg)
      (let ((field (car fg)) (getter (cdr fg)))
	(simple-format port "(~s . ~s)\n" field (getter rec))))
  (let ((fields+getters (list
			 (cons 'chanid recording-chanid)
			 (cons 'starttime recording-starttime)
			 (cons 'recorded-table recording-recorded-table)
			 (cons 'streams-info recording-streams-info)
			 (cons 'i-frame-info recording-i-frame-info)
			 (cons 'retain-list recording-retain-list))))
    (simple-format port "'(")
    (map rec-printer fields+getters)
    (simple-format port ")\n")))

(set-record-type-printer! recording recording-printer)
			  
(define (create-record-data chanid starttime cut-or-skip)
  (let* ((rec-tbl (mythconverg-get-recorded chanid starttime))
	 (recmkp-tbl (mythconverg-get-recordedmarkup chanid starttime))
	 (input-file (simple-format #f "~a/~a" recordings-directory (assv-ref rec-tbl 'basename)))
	 (strms-inf (ffprobe-stream-info input-file))
	 (i-frm-nfo (ffprobe-i-frames input-file))
	 (rtn-lst (mythtv-get-retention-list chanid starttime cut-or-skip)))
    (make-recording chanid starttime rec-tbl strms-inf i-frm-nfo rtn-lst)))

(define (re-create-record-data r-d)
  (if (recording? r-d) r-d
    (let ((lookup (lambda (key) (assv-ref r-d key))))
      (apply make-recording (map lookup '(chanid starttime recorded-table streams-info i-frame-info retain-list))))))

(define recording-file-endings3 '("mpg" "mp4" "mkv" "h264-ts" "h264.ts" "h265.ts"))
(define recording-file-endings2 '("ts"))
(define transcoded-file-ending "h264.ts") ;; mkv
(define remuxed-ts-file-ending "h264.ts")

(define (recording-basename rec)
  (assv-ref (recording-recorded-table rec) 'basename))
(define (recording-filesize rec)
  (assv-ref (recording-recorded-table rec) 'filesize))
(define (recording-av-stream-info rec type)
  (define (rvsi s r) (cond ((null? s) r)
			   ((eqv? (assv-ref (car s) 'codec_type) type)
			    (rvsi (cdr s) (cons (car s) r)))
			   (#t (rvsi (cdr s) r))))
  (rvsi (recording-streams-info rec) '()))
(define (recording-video-stream-ffmpeg-filt rec scale?)
  (define (iter f l i acc)
    (cond ((null? l) (reverse acc))
	  (#t
	   (iter f (cdr l) (+ 1 i) (cons (f i) acc)))))
  (let* ((v (car (recording-av-stream-info rec 'video)))
	 (a (reverse (recording-av-stream-info rec 'audio)))
	 (rtn (recording-retain-list rec))
	 ;;(sar (assv-ref v 'sample_aspect_ratio))
	 (dar     (assv-ref v 'display_aspect_ratio))
	 (height  (assv-ref v 'height))
	 (width   (assv-ref v 'width))
	 (idx     (assv-ref v 'index))
	 (aidx    (map (lambda(s) (assv-ref s 'index)) a))
	 (scale-flt (if scale? (let ((fmt (simple-format #f "[~~a:~a] scale=w=~a:h=~a,setdar=~a,setpts=PTS-STARTPTS [v~~a];" idx width height dar)))
		      (lambda (i) (simple-format #f fmt i i))) (lambda (i) "")))
	 (av-ptr (lambda (i) (string-join (cons (if scale? (simple-format #f "[v~a]" i) (simple-format #f "[~a:~a]" idx i)) (map (lambda (a) (simple-format #f "[~a:~a]" i a)) aidx)))))
	 (out-ptr (lambda (i) (simple-format #f "[out~a]" i)))
	 (n (length rtn))
	 (concat (simple-format #f "concat=n=~a:v=1:a=~a [out0]" n (length aidx)))
	 (mappings (lambda (i) (simple-format #f "-map '[out~a]'" i))))
    (string-join (append (list "'") (iter scale-flt rtn 0 '()) (iter av-ptr rtn 0 '()) (list concat) (iter out-ptr aidx 1 '()) (list "' ") (iter mappings (cons 0 aidx) 0 '())))))
(define* (ffmpeg-split+scale+transcode-recording rec #:optional (scale? #t))
  (let* ((basename (recording-basename rec))
	 (rootname+ext (string-split basename #\.))
	 (rootname (car rootname+ext))
	 (in-file (simple-format #f "~a/~a" recordings-directory basename))
	 (out-file (simple-format #f "~a/~a.~a" working-directory rootname transcoded-file-ending))
	 (m-d (mythtv-recorded-table->metadata rec))
	 (cut-times (myth-convert-i-frame-indices-to-times (recording-retain-list rec) (recording-i-frame-info rec)))
	 (seek-fn (lambda(c) (simple-format #f " -ss ~a -t ~a -i '~a'" (car c) (- (cdr c) (car c)) in-file)))
	 (filter (recording-video-stream-ffmpeg-filt rec scale?))
	 (options ffmpeg-transcoding-options)
	 (cmd (simple-format #f "~a -y ~a -filter_complex ~a ~a ~a ~a" ffmpeg-bin (string-join (map seek-fn cut-times)) filter options m-d out-file)))
    (shell-command-to-string cmd)
    cmd))


(define (recording-new-file-name file-name ending)
  (let* ((base+exts (string-split file-name #\.))
	 (base (car base+exts)))
    (simple-format #f "~a.~a" base ending)))
(define* (create-record-data-for-transcode rec)
  (let* ((rtn-list '())
	 (tr-rec rec)
	 (rec-tbl (copy-tree (recording-recorded-table tr-rec)))
	 (basename (recording-basename tr-rec))
	 (tr-basename (recording-new-file-name basename transcoded-file-ending))
	 (input-file    (simple-format #f "~a/~a" recordings-directory basename))
	 (input-tr-file (simple-format #f "~a/~a" working-directory tr-basename))
	 (tr-filesize (stat:size (stat input-tr-file)))
	 (strms-inf (ffprobe-stream-info input-tr-file))
	 (i-frm-nfo (ffprobe-i-frames input-tr-file)))
    (set! rec-tbl (assv-set! rec-tbl 'basename tr-basename))
    (set! rec-tbl (assv-set! rec-tbl 'filesize tr-filesize))
    (set! rec-tbl (assv-set! rec-tbl 'cutlist 0))
    (set! rec-tbl (assv-set! rec-tbl 'commflagged 0))
    (set! rec-tbl (assv-set! rec-tbl 'bookmark 0))
    (set! rec-tbl (assv-set! rec-tbl 'transcoded 1))
    (set-fields tr-rec ((recording-recorded-table) rec-tbl)
		((recording-streams-info) strms-inf)
		((recording-i-frame-info) i-frm-nfo)
		((recording-retain-list) rtn-list))))

 ;; (define (ffmpeg-split+retain-recording rec)
 ;;   (let* ((basename (recording-basename rec))
 ;; 	 (rootname+ext (string-split basename #\.))
 ;; 	 (rootname (car rootname+ext)) (ext (cadr rootname+ext))
 ;; 	 (in-file (simple-format #f "~a/~a" recordings-directory basename))
 ;; 	 (out-file (simple-format #f "~a/~a.mkv" working-directory rootname))
 ;; 	 (out-ffconcat (simple-format #f "~a/~a.ffconcat" working-directory rootname))
 ;; 	 (frames-list (string-join (map (lambda(x)(simple-format #f "~a,~a" (car x)(cdr x))) (recording-retain-list rec)) "," 'infix))
 ;; 	 (out-file-tmp (simple-format #f "~a/~a_%05d.~a" working-directory rootname ext))
 ;; 	 (ffmpeg-cut (simple-format #f "ffmpeg -fflags '+genpts' -ignore_unknown -y -i \"~a\" -codec copy -map 0 -map -0:d -f segment -segment_list \"~a\" -segment_frames \"~a\" \"~a\"" in-file out-ffconcat frames-list out-file-tmp)))
 ;;     (shell-command-to-string ffmpeg-cut)))
 
(define (myth-convert-i-frame-indices-to-times indices i-frame-info)
  ;; index = ((a . b) ... )
  (let* ((start_time (caar i-frame-info))
	 (normalize-times (lambda (l)
			    (cons (- (car l) start_time) (- (cdr l) start_time)))))
    (define (m-c-i-f-i-t-t indices times)
      (cond ((null? indices) times)
	    (#t
	     (m-c-i-f-i-t-t (cdr indices)
			    (append times
				    (list (cons (car (mythtv-find-nearest-i-frame-after (caar indices) i-frame-info)) (car (mythtv-find-nearest-i-frame-before (cdar indices) i-frame-info)))))))))
    (map normalize-times (m-c-i-f-i-t-t indices '()))))

(define (mythtv-recorded-table->metadata rec)
  (let* ((r-t (recording-recorded-table rec))
	 (m-d (map (lambda (x) (assv x r-t)) mythtv-recorded-table->metadata-list))
	 (sanitize (lambda (s) (if (string? s) (string-delete (lambda(c) (or (eqv? c #\") (eqv? c #\'))) s) s))))
    (string-join (map (lambda (x) (simple-format #f "-metadata \"~a=~a\"" (car x) (sanitize (cdr x)))) m-d) " ")))

(define* (ffmpeg-filter-streams streams-info #:optional (max 2) (filter-lst '(video audio)))
  (let* ((codec-type (lambda (x) (assv-ref x 'codec_type) ))
	 (filter-fn (lambda(x) (memq (codec-type x) filter-lst))))
    (define (sorter l)
      (stable-sort l (lambda (a b) (string> (symbol->string (codec-type a)) (symbol->string (codec-type b))))))
    (define (selector l max acc)
      (cond ((or (= max 0) (null? l)) acc) (#t (selector (cdr l) (- max 1) (append acc (list (car l)))))))
    (selector (sorter (filter filter-fn streams-info)) max '())))

(define (ffmpeg-outstreams-templates rec max-streams)
  (let* ((streams-info (ffmpeg-filter-streams (recording-streams-info rec) max-streams))
	 (s-i (map (lambda (x) (cons (substring (symbol->string (assv-ref x 'codec_type)) 0 1) (assv-ref x 'index))) streams-info))
	 (concat-template (map (lambda(s) (simple-format #f "[~~a:~a]" (cdr s))) s-i))
	 (i -1) (j -1)
	 (output-template (map (lambda(x) (set! j (+ 1 j)) (simple-format #f "[out~a]" j)) streams-info)))
    (cons
     (lambda(x) (set! i (+ 1 i)) (string-join (map (lambda(f) (simple-format #f f i)) concat-template) " "))
     output-template)))

(define* (ffmpeg-split+transcode-recording rec #:optional (max-streams 4)
					   (transcoded-file-ending transcoded-file-ending)
					   (ffmpeg-transcoded-file-muxer ffmpeg-transcoded-file-muxer))
  (let* ((basename (recording-basename rec))
	 (rootname+ext (string-split basename #\.))
	 (rootname (car rootname+ext))
	 (in-file (simple-format #f "~a/~a" recordings-directory basename))
	 (out-file (simple-format #f "~a/~a.~a" working-directory rootname transcoded-file-ending))
	 (m-d (if (eq? ffmpeg-transcoded-file-muxer 'matroska) (mythtv-recorded-table->metadata rec) ""))
	 (cut-times (myth-convert-i-frame-indices-to-times (recording-retain-list rec) (recording-i-frame-info rec)))
	 (seek-fn (lambda(c) (simple-format #f " -ss ~a -t ~a -i '~a'" (car c) (- (cdr c) (car c)) in-file)))
	 (concat-info (ffmpeg-outstreams-templates rec max-streams))
	 (instreams (string-join (map (car concat-info) cut-times) " "))
	 (outstreams (cdr concat-info))
	 (mappings (map (lambda (x) (simple-format #f " -map '~a'" x)) outstreams))
	 (cmd (simple-format #f "~a -y ~a -filter_complex '~a concat=n=~a:v=1:a=~a ~a' ~a ~a ~a -f ~a ~a" ffmpeg-bin (string-join (map seek-fn cut-times)) instreams (length cut-times) (- (length outstreams) 1) (string-join outstreams) ffmpeg-transcoding-options (string-join mappings) m-d ffmpeg-transcoded-file-muxer out-file)))
    (shell-command-to-string cmd)
    cmd))
    
(define (mythconverg-update-recorded-seek-table rec)
  (let* ((i-frm-nfo (recording-i-frame-info rec))
	 (start_pts (caar i-frm-nfo))
	 (chanid (recording-chanid rec))
	 (starttime (recording-starttime rec))
	 (start-time (assv-ref (recording-recorded-table rec) 'starttime)))
    (define (type-9/33-marks l acc)
      (cond ((null? l) acc)
	    ;; for some reason, ffmpeg's i-frame # is 2 less than that mythtv reports
	    ;; after frame 0
	    ;; (i-frame offset time)
	    ((not (number? (first (car l))))
		 (type-9/33-marks (cdr l) acc))
	    ((null? acc)
	     (type-9/33-marks (cdr l) (list (list (fourth (car l)) (second (car l)) (inexact->exact (round (* (- (first (car l)) start_pts) 1000)))))))
	    (#t
	     (type-9/33-marks (cdr l) (append acc (list (list (+ 2 (fourth (car l))) (second (car l)) (inexact->exact (round (* (- (first (car l)) start_pts) 1000))))))))))
    (define (printer* tpe x)
      (simple-format #f "insert into recordedseek (chanid,starttime,mark,offset,type) values (~a,~a,~a,~a,~a);\n" chanid starttime (car x) (if (= tpe 9) (cadr x) (caddr x)) tpe))
    (define (printer9 x) (printer* 9 x))
    (define (printer33 x) (printer* 33 x))
    (let* ((marks (type-9/33-marks i-frm-nfo '()))
	   (delete-recseek (simple-format #f "delete from recordedseek where chanid=~a and starttime=~a and (type=9 or type=33);\n" chanid starttime))
	   (insert-9 (string-join (map printer9 marks)))
	   (insert-33 (string-join (map printer33 marks))))
      (mysql-continue (string-join (list delete-recseek insert-9 insert-33))))))

(define (HH:MM:SS.x->milliseconds t)
  (let ((tm (read-from-string (string-split t #\:))))
    (roundx (* 1000 (+ (* 3600 (first tm)) (* 60 (second tm)) (third tm))))))
(define (mythconverg-recordedmarkup-type34 rec)
  (fourth (last (recording-i-frame-info rec))))
(define (mythconverg-recordedmarkup-type33 rec)
  (let* ((vid (car (filter (lambda(l) (eq? (assq-ref l 'codec_type) 'video)) (recording-streams-info rec))))
	 (dur0 (assq-ref vid 'duration))
	 (dur1 (assq-ref vid 'tag:DURATION)))
    (cond ((number? dur0) (roundx (* 1000 dur0)))
	  ((string? dur1) (HH:MM:SS.x->milliseconds dur1))
	  (#t 0))))
(define* (mythconverg-update-recordedmarkup-table rec #:optional (continuation mysql-continue))
  (let* ((chanid (recording-chanid rec))
	 (starttime (recording-starttime rec))
	 (last-i-frame (mythconverg-recordedmarkup-type34 rec))
	 (duration (mythconverg-recordedmarkup-type33 rec)))
    (continuation (simple-format #f "delete from ltbrecordedmarkup where chanid=~a and starttime=~a; insert into ltbrecordedmarkup (chanid,starttime,mark,type,data) select chanid,starttime,mark,type,data from recordedmarkup where chanid=~a and starttime=~a and type>=0; delete from recordedmarkup where chanid=~a and starttime=~a and (type<=5 or type>=33); insert into recordedmarkup (chanid,starttime,mark,type,data) values (~a,~a,0,34,~a); insert into recordedmarkup (chanid,starttime,mark,type,data) values (~a,~a,0,33,~a);" chanid starttime chanid starttime chanid starttime chanid starttime last-i-frame chanid starttime duration))))

;; should be identical to above, except the tables are reversed
(define (mythconverg-update-recordedmarkup-table-rollback rec)
  (let ((sanitize+continue (lambda (s)
			     (mysql-continue (string-downcase
			      (regexp-substitute/global #f " recordedmarkup"
							(regexp-substitute/global #f " ltbrecordedmarkup" s 'pre " RECORDEDMARKUP" 'post) 'pre " LTBRECORDEDMARKUP" 'post))))))
    (mythconverg-update-recordedmarkup-table rec sanitize+continue)))

(define* (mythconverg-update-recorded-table rec tr-rec #:optional (mv? #t))
  (let* ((chanid (recording-chanid rec))
	 (starttime (recording-starttime rec))
	 (basename (recording-basename rec))
	 (tr-basename (recording-basename tr-rec))
	 (input-file    (simple-format #f "~a/~a" recordings-directory basename))
	 (input-tr-file (simple-format #f "~a/~a" working-directory tr-basename))
	 (tr-filesize (assv-ref (recording-recorded-table tr-rec) 'filesize)))
    ;; change timestamp on transcoded file to original timestamp and move it to recordings directory
    (if mv? (shell-command-to-string (simple-format #f "touch --reference='~a' '~a' && mv '~a' '~a'" input-file input-tr-file input-tr-file recordings-directory)))
    (mysql-commit (simple-format #f "update recorded set autoexpire=0, preserve=1, cutlist=0, commflagged=0, bookmark=0, transcoded=1, filesize=~a, basename=\"~a\" where chanid=~a and starttime=~a;" tr-filesize tr-basename chanid starttime))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;                       MYTH-CLEAN-RECORDINGS
;;;; - on successful transcode, FFMPEG-MYTH0 calls MYTHCONVERG-UPDATE-LTBTRANSCODEDTOBEDELETED
;;;;  which adds an entry in the sql table ltbtranscodedtobedeleted for the file that was transcoded.
;;;; - MYTH-CLEAN-RECORDING-DIRECTORY queries ltbtranscodedtobedeleted for the list of files with an
;;;;   expiry date before now+n days; it executes SHELL-CMD on that list; if there are no expired files
;;;;   it returns an empty list, otherwise the list of files
;;;; - MYTHCONVERG-UPDATE-DELETED-LTBTRANSCODEDTOBEDELETED takes the list of files from 
;;;;   MYTH-CLEAN-RECORDING-DIRECTORY and sets the deleted flag on each one in the the ltbtranscodedtobedeleted
;;;;   table.
;;;;
;;;;   Debug/test: shell-cmd <- echo ; continuation <- (lambda(x) x)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define* (mythconverg-update-ltbtranscodedtobedeleted rec #:optional (continuation mysql-continue))
  (let* ((basename (if (recording? rec) (recording-basename rec) rec)))
    (continuation (simple-format #f "insert into ltbtranscodedtobedeleted (basename,deleted,expirydate) values ('~a',0,NOW() + interval 14 day);" basename))))
(define* (myth-clean-recording-directory #:optional (expiration-date 1) (shell-cmd "rm -f"))
  (let* ((safe-cdr (lambda (x) (if (null? x) x (cdr x))))
	 (expired-recordings (map car (safe-cdr (mythconverg-execute+parse (simple-format #f "select basename from ltbtranscodedtobedeleted where deleted=0 and expirydate <= NOW() + interval ~a day;" expiration-date))))))
    (cond ((null? expired-recordings)
	   (simple-format #t "myth-clean-recording-directory: no transcoded recordings to remove. Done.\n")
	   '())
	  (#t
	   (simple-format #t "myth-clean-recording-directory: removing transcoded files\n~a\n" (string-join expired-recordings ","))
	   (let ((cmd (simple-format #f "~a ~a" shell-cmd (string-join (map (lambda(s) (string-concatenate (list recordings-directory "/" s "*"))) expired-recordings) " "))))
	     (catch 'error-in-shell-command-to-string
	       ;; thunk - return expired-recordings list
	       (lambda ()
		 (shell-command-to-string cmd)
		 expired-recordings)
	       ;; handler - return empty list in case of error
	       (lambda (key cmd str)
		 '())))))))
(define* (mythconverg-update-deleted-ltbtranscodedtobedeleted bnl #:optional (continuation mythconverg-execute))
  (let ((sql-cmds (map (lambda(f) (simple-format #f "update ltbtranscodedtobedeleted set deleted=1 where basename='~a';" f)) bnl)))
    (unless (null? bnl)
      (mysql-start-transaction (string-join sql-cmds "\n"))
      (mysql-commit "")
      (continuation mysql-cmd))))
(define* (myth-clean-recordings-update-deleted-ltbtranscodedtobedeleted #:optional (expiration-date 1) (shell-cmd "rm -f") (continuation mythconverg-execute))
  (mythconverg-update-deleted-ltbtranscodedtobedeleted
   (myth-clean-recording-directory expiration-date shell-cmd) continuation))

(define* (myth-find-adjacent-recording chanid starttime #:optional (order 'default))
  (let* ((endtime  (caadr (mythconverg-execute+parse (simple-format #f "select endtime from recorded where chanid=~a and starttime = ~a;" chanid starttime))))
	 (next-rec0 (cdr (mythconverg-execute+parse (simple-format #f "select basename,title from recorded where chanid=~a and starttime >= ~a and starttime <= '~a' order by starttime limit 2;" chanid starttime endtime))))
	 (prev-rec0 (cdr (mythconverg-execute+parse (simple-format #f "select basename,title from recorded where chanid=~a and endtime   >= ~a and starttime <= ~a order by starttime limit 2;" chanid starttime starttime))))
	 (next-rec (cons 'after  next-rec0))
	 (prev-rec (cons 'before prev-rec0))
	 )
    ;;(list 'next next-rec (length next-rec) 'before prev-rec (length prev-rec))
    (case order
      ((after)
       (if (eq? (length next-rec) 3) next-rec '()))
      ((before)
       (if (eq? (length prev-rec) 3) prev-rec '()))
      ((default)
       (cond ((eqv? (length next-rec) 3) next-rec)
	     ((eqv? (length prev-rec) 3) prev-rec)
	     (else '())))
       (else '()))))

(define* (myth-merge-two-recordings chanid starttime #:optional (order 'default))
  (let* ((rec1+2 (myth-find-adjacent-recording chanid starttime order))
	 (bn1 (caadr rec1+2))
	 (bn2 (caaddr rec1+2))
	 (bn (if (eq? 'after (car rec1+2)) bn1 bn2))
	 (concat (simple-format #f "ffconcat version 1.0\nfile ~a/~a\nfile ~a/~a\n" recordings-directory bn1 recordings-directory bn2))
	 (port (mkstemp! (mythconverg-input-file-name)))
	 (tmpfile (port-filename port))
	 (cmd (simple-format #f "~a -y -safe 0 -f concat -i ~a -codec copy -ignore_unknown -map 0 -map -0:d ~a/~a && touch --reference='~a/~a' ~a/~a && mv ~a/~a ~a/~a.premerge && mv ~a/~a ~a/." ffmpeg-bin tmpfile working-directory bn recordings-directory bn working-directory bn recordings-directory bn recordings-directory bn working-directory bn recordings-directory)))
    (simple-format port concat) (force-output port) (close-port port)
    (shell-command-to-string cmd)
    (mythutil-rebuild (re-create-record-data (list (cons 'chanid chanid) (cons 'starttime starttime))))
    cmd))

(define (ffmpeg-remux-to-h264-ts chanid starttime)
  (let* ((r (mythconverg-get-recorded chanid starttime))
	 (bn (assv-ref r 'basename))
	 (infile (simple-format #f "~a/~a" recordings-directory bn))
	 (outfile (simple-format #f "~a/~a" working-directory (recording-new-file-name bn remuxed-ts-file-ending)))
	 (remux-cmd (simple-format #f "~a -y -i ~a -codec copy -map 0 -f mpegts ~a  && touch --reference='~a' ~a && mv ~a ~a/." ffmpeg-bin infile outfile infile outfile outfile recordings-directory))
	 (bn-cmd (simple-format #f "update recorded set basename='~a' where chanid=~a and starttime='~a';" (recording-new-file-name bn remuxed-ts-file-ending) chanid starttime)))
    (shell-command-to-string remux-cmd)
    (mythconverg-execute bn-cmd)
    (mythutil-rebuild (re-create-record-data r))))

(define (ffmpeg-remux->concat chanid starttime)
  (let* ((r (mythconverg-get-recorded chanid starttime))
	 (bn (assv-ref r 'basename))
	 (infile (simple-format #f "~a/~a" recordings-directory bn))
	 (outfile (simple-format #f "~a/~a" working-directory (recording-new-file-name bn transcoded-file-ending)))
	 (remux-cmd (simple-format #f "~a -y -i ~a -codec copy -map 0 -f mpegts ~a  && touch --reference='~a' ~a && mv ~a ~a/." ffmpeg-bin infile outfile infile outfile outfile recordings-directory)))
    (shell-command-to-string remux-cmd)
    (mythutil-rebuild (re-create-record-data r))))


(define (mythutil-rebuild rec)
  (let* ((chanid (recording-chanid rec))
	 (starttime (recording-starttime rec)))
    (define (rebuild tbl)
      (shell-command-to-string (simple-format #f "mythutil --chanid=~a --starttime='~a' --clear~a" chanid starttime tbl)))
    (map rebuild '(skiplist cutlist seektable))
    (shell-command-to-string (simple-format #f "mythcommflag --chanid=~a --starttime='~a' --rebuild" chanid starttime))))

(define* (mythconverg-pending-jobs #:optional (days 7))
  (let ((basenames (mythconverg-execute+parse (simple-format #f "select basename from recorded where cutlist=1 and lastmodified>=now() - interval ~a day and not(recgroup = 'Deleted') order by starttime;" days))))
    (define (parse-basename bn)
      (read-from-string (string-split (car (string-split (car bn) #\.)) #\_)))
    (cond ((null? basenames)
	   (simple-format #t "mythconverg-pending-jobs: no jobs.\n") (force-output) '())
	  (#t (map parse-basename (cdr basenames))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ROLLBACK  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The recording records for old+new are written to the log file after a    ;;
;; transcoding. Use rollback-transcoding to rollback to the old recording.  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define* (rollback-transcoding old+new #:optional (update-database #f))
  ;; rec = old recording
  ;; tr-rec = transcoded recording
  (let* ((rec (re-create-record-data (car old+new)))
	 (tr-rec (re-create-record-data (cadr old+new))))
    (catch #t (lambda ()
		;; mysql-start-transaction here
		(mysql-start-transaction "")
		(mythconverg-update-recorded-seek-table rec)
		(mythconverg-update-recordedmarkup-table-rollback rec)
		;; last arg is #f so that no mv/touch is done
		(mythconverg-update-recorded-table tr-rec rec #f)
		;; mysql-commit in this step
		(if update-database (mythconverg-execute mysql-cmd))
		(list 'updated (recording-basename rec)))
      (lambda (key . args)
      	(list 'error (recording-basename rec))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; File-system handling
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (move-file old new)
  (shell-command-to-string (simple-format #f "mv ~a ~a" old new)))
(define (symlink-file target linkname)
  (shell-command-to-string (simple-format #f "ln -s -r ~a ~a" target linkname)))
(define (symlink? name)
  (eq? 'symlink (stat:type (lstat name))))
(define (file-chain name)
  (letrec ((dereference (lambda (s rst)
			  (if (eq? #f s)
			      rst
			      (dereference (if (symlink? s) (readlink s) #f) (cons s rst))))))
    (dereference name '())))
(define (delete-file-chain name)
  (letrec ((delete-file1 (lambda (file)
			   (catch #t (lambda ()
				       (delete-file file))
			     (lambda (key . args)
			       (simple-format #t "delete-file: Error ~a, ~a\n" key args))))))
    (map delete-file1 (file-chain name))))

(define (mythtv-move+symlink-watched-files0 files)
  (letrec ((maybe-mv-files (lambda (files . rest)
			     (cond ((null? files)
				    rest)
				   ((string? (caar files))
				    (maybe-mv-files (cdr files) (cons (maybe-mv-file (caar files)) rest)))
				   (#t
				    (maybe-mv-files (cdr files) (cons (caar files) 'skipped) rest)))))
	   (maybe-mv-file (lambda (file)
			    (let ((f (simple-format #f "~a/~a" recordings-directory file))
				  (n (simple-format #f "~a/~a" watched-recordings-directory file)))
			      (cond ((not (access? f F_OK))
				     (cons f 'file-does-not-exist))
				    ((symlink? f)
				     (cons f 'symlink))
				    (#t
				     (move-file f n)
				     (symlink-file n f)
				     (cons f n)))))))
    (maybe-mv-files files)))

(define* (mythtv-move-and-symlink-watched-files #:optional (files '()))
  (let ((watched (if (null? files) (mythconverg-execute+parse "select basename from recorded where watched=1 and (basename like '%.h264.ts' or basename like '%.mkv');") files)))
    (mythtv-move+symlink-watched-files0 watched)))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  MAIN  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (ffmpeg-myth1 chanid starttime cut-or-skip)
  (let* ((rec (create-record-data chanid starttime cut-or-skip))
	 (cmd (ffmpeg-split+transcode-recording rec))
	 (tr-rec (create-record-data-for-transcode rec)))
    (catch #t (lambda ()
		;; mysql-start-transaction here
		(mysql-start-transaction "")
		(mythconverg-update-recorded-seek-table tr-rec)
		(mythconverg-update-recordedmarkup-table tr-rec)
		(unless (equal? (recording-basename rec) (recording-basename tr-rec))
		  (mythconverg-update-ltbtranscodedtobedeleted rec))
		;; mysql-commit in this step
		(mythconverg-update-recorded-table rec tr-rec)
		(mythconverg-execute mysql-cmd)
		(list rec tr-rec))
      (lambda (key . args)
	(list rec tr-rec 'error)))))
(define (ffmpeg-myth0 chanid starttime cut-or-skip)
  (catch #t
    ;; thunk
    (lambda () (ffmpeg-myth1 chanid starttime cut-or-skip))
    ;; handler
    (lambda (key . rest) (simple-format #t "Error in ffmpeg-myth0: key=~a\nrest=~a\n" key rest) '())))


(define (ffmpeg-myth-cut c-s)
  (ffmpeg-myth0 (car c-s) (cadr c-s) 'cut))
(define (ffmpeg-myth-skip c-s)
  (ffmpeg-myth0 (car c-s) (cadr c-s) 'skip))
(define* (ffmpeg-myth-do-pending-jobs #:optional (days 7))
  (let ((days (if (number? days) days 7))
	(how-many-running? (read-from-string (shell-command-to-string "ps -C ffmpeg-myth.scm -o pid=,time= | wc -l"))))
    (cond ((eq? how-many-running? 1)
	   (map ffmpeg-myth-cut (mythconverg-pending-jobs days)))
	  (#t
	   (simple-format #t "ffmpeg-myth-do-pending-jobs: found ~a instances of ffmpeg-myth.scm running. Abort.\n" how-many-running?)))))

(define* (tmp-test #:optional (x 7))
  (simple-format #t "~a\n" x) (force-output))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  MAIN  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (ffmpeg-myth args)
  (display args) (newline)
  ;;(shell-command-to-string #t "printenv") (newline)
  (let* ((rgs (read-from-string (cdr args)))
	 (cmd (eval (car rgs) (interaction-environment)))
	 (result 
	  (cond ((null? rgs) '())
		((null? (cdr rgs)) (cmd))
		(#t (apply cmd (cdr rgs))))))
    (simple-format #t "~a" result) (force-output)
    result))