ytdl.scm

;; Copyright (c) Iwata <iwata@quasiquote.org>
;;
;; Permission is hereby granted, free of charge, to any person obtaining
;; a copy of this software and associated documentation files (the
;; "Software"), to deal in the Software without restriction, including
;; without limitation the rights to use, copy, modify, merge, publish,
;; distribute, sublicense, and/or sell copies of the Software, and to
;; permit persons to whom the Software is furnished to do so, subject to
;; the following conditions:
;;
;; The above copyright notice and this permission notice shall be included
;; in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

(use srfi-2)
(use http-client)
(use regex)
(use uri)

(use args)
(use iconv)

(define (fetch outfile url)
  (let ((escaped-outfile (string-substitute* outfile '(("'" . "_"))))
        (escaped-url (string-substitute* url '(("'" . "_")))))
    (system (format "ftp -o '~a' '~a'" escaped-outfile escaped-url))))

(define (get-title body)
  (cadr (string-search "<title>(.*)</title>" body)))

(define (high-quality? body)
  (string-search "yt.VideoQualityConstants.HIGH" body))

(define-constant fmt-alist '(("ultra"  . 22)
                             ("best"   . 18)
                             ("mobile" . 17)
                             ("high"   . 6)))

(define (make-quality-format body quality)
  (let ((fmt (alist-ref quality fmt-alist string=?)))
    (or (and fmt
             (high-quality? body)
             (format "&fmt=~a" fmt))
        (and (string->number quality)
             (high-quality? body)
             (format "&fmt=~a" quality))
        "")))

(define (youtube? body)
  (list? (string-search "/watch_fullscreen.*" body)))
(define (google-video? body)
  (list? (string-search "/googleplayer.swf.*" body)))

(define-constant youtube-base-dir "http://www.youtube.com/get_video")
(define (build-youtube-url body option)
  (and-let* ((url-string (car (string-search "/watch_fullscreen.*" body)))
             (query (uri-decode-query
                     (format "http://youtube.com/v~a" url-string)))
             (video-id (alist-ref "video_id" query string=?))
             (t (alist-ref "t" query string=?)))
            (cons
             (cons 'video-id video-id)
             (cons 'url
                   (format "~a?video_id=~a&t=~a~a"
                           youtube-base-dir video-id t option)))))

(define (http:youtube-get url)
  (http:GET
   (http:make-request
    'GET url
    '(("User-Agent" . "Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.9.0.1) Gecko/2008070208 Firefox/3.0.1")
      ("Accept-Charset" . "ISO-8859-1,utf-8;q=0.7,*;q=0.7")
      ("Accept" . "text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5'")
      ("Accept-Language" . "en-us,en;q=0.5")))))

(define (build-google-video-url body)
  #f)
(define (youtube:get-url url-string
                         #!key
                         (quality #f))
  (and-let* ((body (http:youtube-get url-string))
             (title (get-title body)
                    (cadr (string-search "<title>(.*)</title>" body)))
             (url (or (and (youtube? body)
                           (build-youtube-url body (make-quality-format body quality)))
                      (and (google-video? body)
                           (build-google-video-url body)))))
            (list (car url)
                  (cdr url)
                  (cons 'title title))))

(define opts
  (list (args:make-option (q quality) #:required "video format")
        (args:make-option (h help)    #:none     "Display this text"
                          (usage))))

(define (usage)
 (with-output-to-port (current-error-port)
   (lambda ()
     (print "Usage: " (car (argv)) " [options...] url")
     (newline)
     (print (args:usage opts))))
 (exit 1))

(define *iconv-desc* (iconv-open "euc-jp" "utf-8"))

(define (main)
  (receive (options operands)
      (args:parse (command-line-arguments) opts)
    (for-each (lambda (url)
                (and-let* ((ret (youtube:get-url url quality: (alist-ref 'quality options)))
                           (file (format "~a.flv" (alist-ref 'video-id ret)))
                           (title (iconv *iconv-desc* (alist-ref 'title ret))))
                          (print (format "download '~a'" title))
                          (fetch file (alist-ref 'url ret))
                          (create-symbolic-link
                           file
                           (format "~a.flv" title))))
              operands)))

(main)

(exit)