You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

703 lines
36 KiB

This file contains invisible Unicode characters!

This file contains invisible Unicode characters that may be processed differently from what appears below. If your use case is intentional and legitimate, you can safely ignore this warning. Use the Escape button to reveal hidden characters.

#!/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)
(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)))
;; 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))
(let* ((port (mkstemp! (mythconverg-input-file-name)))
(tmpfile (port-filename port)))
(simple-format port statement) (force-output port) (close-port port)
(mythconverg-source 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))
(#t s))))
((list? s)
(map read-from-string s))
(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))
(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)))
(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)))
(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)
(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)
(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))
(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)
(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)
(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)))
(lambda(x) (set! i (+ 1 i)) (string-join (map (lambda(f) (simple-format #f f i)) concat-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)
(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)))))))
(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))))
;;;; 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
;;;; 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")
(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)
;; 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))
(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
(if (eq? (length next-rec) 3) next-rec '()))
(if (eq? (length prev-rec) 3) prev-rec '()))
(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))))
(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)
(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)
((string? (caar files))
(maybe-mv-files (cdr files) (cons (maybe-mv-file (caar files)) rest)))
(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))
(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)))
(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)))
(cond ((null? rgs) '())
((null? (cdr rgs)) (cmd))
(#t (apply cmd (cdr rgs))))))
(simple-format #t "~a" result) (force-output)