Welcome to the CHICKEN Scheme pasting service

(use filepath
     args
     miscmacros
     fmt
     srfi-1
     http-client
     rss
     ports
     posix
     files
     progress-indicators
     uri-generic)

(define *feedfile*  "~/.podcasts/feeds")
(define *storage-location* "~/Music/podcasts/")

(define supported-mimes
  '("audio/mpeg" "audio/x-m4a" "audio/x-mp3" "audio/mp3" "application/octet-stream" "application/ogg"))

(define supported-uri-schemes '(http https))

(define (pretty-filesize size)
  (fmt #f (num/si size 1024 "B")))

(define (read/write filename length outport #!optional (bs (* 1024 2)))
  (let ((bar (make-progress-bar frame: (string-append filename ": [~a~a~a~a|~a]") width: 40 max: length)))
    (let loop ((size length))
      (let* ((bytes (min bs size)))
        (if (zero? size) #t
            (let ((input (read-string bytes)))
              (if input
                  (write-string input bytes outport)
                  (when (> bytes 0)
                    (error "Missing ~a from input" (pretty-filesize bytes))))
              (advance-progress-bar! bar bytes)
              (loop (- size bytes))))))
    (finish-progress-bar! bar)))

(define (create-dir/parents file)
  (fold (lambda (d p)
		(let ((new (filepath:join-path (list p d))))
		  (unless (directory-exists? new)
		      (create-directory new))
		  new))
	      ""
	      (filepath:split-path (filepath:drop-file-name file)))
  #t) 					;return something meaningful

(define (make-filename title extension)
  (string-append (string-translate (string-downcase title) " /" "_-") extension))

(define (get-file-port file)
  (file-open file
	     (+ open/wronly open/creat)))

(define (get-length length-string)
  (let ((n (irregex-match-substring
	    (irregex-search '(seq (* whitespace)
				  (submatch (+ num))
				  (* whitespace))
			    length-string) 1)))
    (or (string->number n)
	(error "I need a valid input length instead of" length-string))))

(define (filename-from-url u)
  (filepath:take-file-name u))

(define (download-enclosure item-title enclosure dest catcher)
  (let* ((url (rss:enclosure-url enclosure))
	 (extension (filepath:take-extension (rss:enclosure-url enclosure)))
	 (filename (filename-from-url url))
         (target-location (string-append dest "/" filename))
         (temp-file (string-append target-location ".part"))
         (length (get-length (rss:enclosure-length enclosure)))
         (fd (get-file-port temp-file))
         (outport (open-output-file* fd)))
    (if (equal? catcher 'curl)
        (unless (zero? (system (string-intersperse (list "curl" "-L"  "-o" temp-file url))))
          (printf "\tStill cannot download ~a~%" url)
          (file-close fd)
          (delete-file temp-file))
        (condition-case
         (with-input-from-request
          url
          #f
          (if (zero? length)
              (begin
                (print "Downloading " filename)
                (print "This podcast has no valid length, using simple copy-port w/o output!")
                (lambda () (copy-port (current-input-port) outport)))
              (lambda ()(read/write filename length outport))))
         (e (exn net i/o)
            (printf "~%\tError while downloading ~a to ~a:~%\t~a~%"
                    url
                    filename
                    ((condition-property-accessor 'exn 'message) e))
            (printf "\tRetrying with curl...~%")
            (unless (zero? (system (string-intersperse (list "curl" "-L"  "-o" temp-file url))))
              (printf "\tStill cannot download ~a~%" url)
              (file-close fd)
              (delete-file temp-file)))
         (e (exn http unsupported-uri-scheme)
            (print "Cannot download " url " with http-client, shelling out to curl")
            (unless (zero? (system (string-intersperse (list "curl" "-L"  "-o" temp-file url))))
              (printf "\tUrl scheme ~a is not supported. Cannot download ~a~%"
                      ((condition-property-accessor 'unsupported-uri-scheme 'uri-scheme) e)
                      url)
              (file-close fd)
              (delete-file temp-file)))))
    (when (file-exists? temp-file)
      (print " done.")
      (rename-file temp-file target-location))))

(define (is-new? title url dest)
  (let* ((filename (filepath:join-path
		    (list dest (filename-from-url url)))))
    (create-dir/parents filename)
    (not (file-exists? filename))))

(define (fetch-item i dest catcher)
  (let ((title (rss:item-title i))
        (enclosures (rss:item-enclosures i)))
    (for-each
     (lambda (e)
       (let* ((url (rss:enclosure-url e))
	     (type (rss:enclosure-type e))
	     (file (filename-from-url url)))
	 (if (member type supported-mimes)
	     (if (is-new? title url dest)
                 (download-enclosure title e dest catcher))
	     #t))) ;(printf "\nUnknown enclosure type ~S for title ~S, skipping it.\n" type title))))
     enclosures)))

(define (fetch-podcast! title link dir #!key last-episodes catcher)
  (and-let* ((feed (with-input-from-request link #f rss:read))
             (items/audio-enclosures (filter (lambda (i) (not (null? (rss:item-enclosures i))))
                                             (rss:feed-items feed)))
             (items (if last-episodes
                        (take items/audio-enclosures last-episodes)
                        items/audio-enclosures)))
    (if (null? items) (printf "No items found in RSS feed ~S" title)
        (for-each (lambda (i) (fetch-item i dir catcher)) items))))

(define (load-feeds file)
  (or (ignore-errors (with-input-from-file *feedfile* read)) '()))

(define (add-feed! feed)
  (let ((feeds '())
        (file #f))
    (dynamic-wind
        (lambda ()
          (set! feeds (load-feeds *feedfile*))
          (set! file (open-output-file* (file-open *feedfile*
                                                   (+ open/wronly open/creat)))))
        (lambda ()
                (let* ((old-feeds (or (load-feeds *feedfile*) '()))
                       (new-podcast (retrieve-metadata feed)))
                  (set! feeds (cons new-podcast old-feeds))))
        (lambda ()
          (when (port? file)
            (write feeds file)
            (file-close file))))))

(define options (list (args:make-option
                       (a add)
                       (optional: "URL")
                       "add a feed to the feedfile."
                       (add-feed! arg))))

(define (main)
  (create-dir/parents *feedfile*)
  (create-dir/parents *storage-location*)
  (fmt #t "Reading feeds from " *feedfile*)
  (for-each (lambda (e)
              (fmt #t "\rProcessing podcast " (first e) "\x1b[0K" nl)
              (or (fetch-podcast! (first e)
                                  (second e)
                                  (filepath:join-path (list *storage-location* (third e)))
                                  catcher: (and (>= (length e) 4) (fourth e)))
                  (fmt #t "Could not fetch the whole podcast" nl)))
            (load-feeds *feedfile*))
  (fmt #t "\rdone." "\x1b[0K" nl))

(main)

#|

Causes the following error while downloading episode 20 of
this feed file:

(("Alternativlos" "http://alternativlos.org/alternativlos.rss" "alternativlos"))

Error: call of non-procedure: #

        Call history:

        http-client.scm:128: connections-owner    
        http-client.scm:163: connections          
        http-client.scm:163: hash-table-ref/default       
        http-client.scm:121: open-output-string   
        http-client.scm:121: ##sys#check-output-port      
        http-client.scm:121: uri-common#uri-host          
        http-client.scm:121: ##sys#print          
        http-client.scm:121: ##sys#write-char-0   
        http-client.scm:121: uri-common#uri-port          
        uri-common.scm:153: uri-generic#uri-port          
        uri-common.scm:154: uri-generic#uri-scheme        
        uri-common.scm:154: alist-ref     
        http-client.scm:121: ##sys#print          
        http-client.scm:121: get-output-string    
            [download-enclosure] (k354 (##core#lambda () (##core#let ((kvar348 (and349 (##sys#structure? exvar347 (##core#quote condi......
            [download-enclosure] (##sys#structure? exvar347 (##core#quote condition))     <--

|#

(use extras http-client progress-indicators filepath)

(define *s* (make-string 2048))

(define o (open-output-file "/tmp/a.mp3"))

(define (read/write filename length outport #!optional (bs (* 1024 2)))
  (let ((bar (make-progress-bar
               frame:
               (string-append filename ": [~a~a~a~a|~a]")
               width:
               40
               max:
               length)))
    (let loop ((size length))
      (let* ((bytes (min bs size)))
        (if (zero? size)
          #t
          (let ((input (read-string! bytes *s*)))
            (if (> input 0)
              (begin
                (write-string *s* bytes outport)
                (advance-progress-bar! bar bytes))
              (when (> bytes 0)
                    (error "Missing ~a from input" (pretty-filesize bytes))))
            (loop (- size bytes))))))
   (finish-progress-bar! bar)))

(define (filename-from-url u) (filepath:take-file-name u))
(define (get-file-port file) (file-open file (+ open/wronly open/creat)))

(define (download-enclosure url length dest catcher)
  (let* ((filename (filename-from-url url))
         (target-location (string-append dest "/" filename))
         (temp-file (string-append target-location ".part"))
         (fd (get-file-port temp-file))
         (outport (open-output-file* fd)))
    (if (equal? catcher 'curl)
      (unless
        (zero? (system
                 (string-intersperse (list "curl" "-L" "-o" temp-file url))))
        (printf "\tStill cannot download ~a~%" url)
        (file-close fd)
        (delete-file temp-file))
      (condition-case
        (with-input-from-request
          url
          #f
          (if (zero? length)
            (begin
              (print "Downloading " filename)
              (print "This podcast has no valid length, using simple copy-port w/o output!")
              (lambda () (copy-port (current-input-port) outport)))
            (lambda () (read/write filename length outport))))
        (e (exn net i/o)
           (printf
             "~%\tError while downloading ~a to ~a:~%\t~a~%"
             url
             filename
             ((condition-property-accessor 'exn 'message) e))
           (printf "\tRetrying with curl...~%")
           (unless
             (zero? (system
                      (string-intersperse
                        (list "curl" "-L" "-o" temp-file url))))
             (printf "\tStill cannot download ~a~%" url)
             (file-close fd)
             (delete-file temp-file)))
        (e (exn http unsupported-uri-scheme)
           (print "Cannot download "
                  url
                  " with http-client, shelling out to curl")
           (unless
             (zero? (system
                      (string-intersperse
                        (list "curl" "-L" "-o" temp-file url))))
             (printf
               "\tUrl scheme ~a is not supported. Cannot download ~a~%"
               ((condition-property-accessor
                  'unsupported-uri-scheme
                  'uri-scheme)
                e)
               url)
             (file-close fd)
             (delete-file temp-file)))))
    (when (file-exists? temp-file)
          (print " done.")
          (rename-file temp-file target-location))))

(download-enclosure  "http://localhost:8888/alternativlos-17.mp3" 89885440 "/tmp" #f)

(use http-client)

(define *s* (make-string 2048))

(define (read/write length outport)
  (let loop ((size length))
    (let* ((bytes (min 1024 size)))
      (unless (zero? size)
        (write-string *s* bytes outport)
        (loop (- size bytes))))))

(define (download-enclosure url length dest)
  (let* ((target-location (string-append dest "/tempfile"))
         (temp-file (string-append target-location ".part"))
         (outport (open-output-file temp-file)))
    #;(read/write length outport)         ; No bug
    (with-input-from-request url #f (lambda () (read/write length outport))) ; bug
    (when (file-exists? temp-file)
          (print " done.")
          (rename-file temp-file target-location))))

(download-enclosure "http://alternativlos.cdn.as250.net/alternativlos-17.mp3" 89885440 "/tmp")

(use http-client ports)

(define outport (open-output-file "/tmp/f"))
(with-input-from-request
   "http://alternativlos.cdn.as250.net/alternativlos-17.mp3"
   #f 
   (lambda () (copy-port (current-input-port) outport)))