path: root/emms-librefm-stream.el

;;; emms-librefm-stream.el --- Libre.FM streaming  -*- lexical-binding: t; -*-

;; Copyright (C) 2014  Free Software Foundation, Inc.

;; Author: Yoni Rabkin <yrk@gnu.org>

;; Keywords: emms, libre.fm, GNU FM

;; EMMS is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;;
;; EMMS is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
;; License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with EMMS; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
;; MA 02110-1301, USA.


;;; Code:

(require 'xml)
(require 'emms-playlist-mode)
(require 'emms-librefm-scrobbler)


(defvar emms-librefm-stream-host-url
  "alpha.libre.fm"
  "URL for the streaming host")

(defvar emms-librefm-stream-host-base-path
  ""
  "URL for the streaming host base path")

(defvar emms-librefm-stream-session-id
  ""
  "Session ID for radio.")

(defvar emms-librefm-stream-debug
  ""
  "Temporary debug information.")

(defvar emms-librefm-stream-station-name
  ""
  "Last station name tuned to.")

(defvar emms-librefm-stream-emms-tracklist
  ""
  "List of tracks for streaming.")

(defvar emms-librefm-stream-playlist-buffer-name
  "*Emms GNU FM*"
  "Name for non-interactive Emms GNU FM buffer.")

(defvar emms-librefm-stream-playlist-buffer nil
  "Non-interactive Emms GNU FM buffer.")

(defvar emms-librefm-stream-connect-method "https://"
  "Method of connecting to server.")


;;; ------------------------------------------------------------------
;;; HTTP
;;; ------------------------------------------------------------------

(defun emms-librefm-stream-assert-http ()
  "Assert a sane HTTP response from the server.

This function must be called inside the response buffer. Leaves
point after the HTTP headers."
  (goto-char (point-min))
  (when (not (re-search-forward "^.*200 OK$" (point-at-eol) t))
    (error "bad HTTP server response"))
  ;; go to the start of the FM response
  (when (not (re-search-forward "\n\n" (point-max) t))
    (error "bad FM server response")))


;;; ------------------------------------------------------------------
;;; radio handshake
;;; ------------------------------------------------------------------

(defun emms-librefm-stream-tune-handshake-string ()
  "Create the tune handshake string."
  (when (not emms-librefm-scrobbler-username)
    (error "null username"))
  (when (not emms-librefm-scrobbler-password)
    (error "null password"))
  (let ((url (concat emms-librefm-stream-connect-method
		     emms-librefm-stream-host-url
		     "/radio/handshake.php?"
		     "version=1.3.0.58" "&"
		     "platform=linux" "&"
		     "username=" (url-encode-url emms-librefm-scrobbler-username) "&"
		     "passwordmd5=" (md5 emms-librefm-scrobbler-password) "&"
		     "language=en")))
    url))

(defun emms-librefm-stream-tune-handshake-call ()
  "Make the tune handshake call."
  (let ((url-request-method "POST"))
    (ignore url-request-method)
    (let ((response
	   (url-retrieve-synchronously
	    (emms-librefm-stream-tune-handshake-string))))
      (setq emms-librefm-stream-debug
	    (with-current-buffer response
	      (buffer-substring-no-properties (point-min)
					      (point-max))))
      response)))

(defun emms-librefm-stream-handle-tune-handshake-response (resbuf)
  "Handle the tune handshake server response."
  (when (not (bufferp resbuf))
    (error "response not a buffer"))
  (with-current-buffer resbuf
    (emms-librefm-stream-assert-http)
    (let (radio-session-id
	  base-url
	  base-path
	  (start (point)))

      (if (re-search-forward "^session=\\(.*\\)$" (point-max) t)
	  (setq radio-session-id (match-string-no-properties 1))
	(error "no radio session ID from server"))

      (goto-char start)
      (if (re-search-forward "^base_url=\\(.*\\)$" (point-max) t)
	  (setq base-url (match-string-no-properties 1))
	(error "no base url from server"))

      (goto-char start)
      (if (re-search-forward "^base_path=\\(.*\\)$" (point-max) t)
	  (setq base-path (match-string-no-properties 1))
	(error "no base path from server"))

      (setq emms-librefm-stream-session-id radio-session-id
	    emms-librefm-stream-host-url base-url
	    emms-librefm-stream-host-base-path base-path))

    (message "radio handshake successful")))

(defun emms-librefm-stream-tune-handshake ()
  "Make and handle the tune handshake."
  (emms-librefm-stream-handle-tune-handshake-response
   (emms-librefm-stream-tune-handshake-call)))


;;; ------------------------------------------------------------------
;;; tuning
;;; ------------------------------------------------------------------

(defun emms-librefm-stream-tune-string (session-id station)
  "Create the tune string."
  (when (not session-id)
    (error "null session id"))
  (when (not station)
    (error "null station"))
  (let ((url (concat emms-librefm-stream-connect-method
		     emms-librefm-stream-host-url
		     emms-librefm-stream-host-base-path
		     "/adjust.php?"
		     "session=" session-id "&"
		     "url=" (url-encode-url station))))
    url))

(defun emms-librefm-stream-tune-call (session-id station)
  "Make the tune call."
  (let ((url-request-method "POST"))
    (ignore url-request-method)
    (let ((response
	   (url-retrieve-synchronously
	    (emms-librefm-stream-tune-string
	     session-id station))))
      (setq emms-librefm-stream-debug
	    (with-current-buffer response
	      (buffer-substring-no-properties (point-min)
					      (point-max))))
      response)))

(defun emms-librefm-stream-handle-tune-response (resbuf)
  "Handle the tune server response."
  (when (not (bufferp resbuf))
    (error "response not a buffer"))
  (with-current-buffer resbuf
    (emms-librefm-stream-assert-http)
    (let (response
	  stationname
	  (start (point)))

      (if (re-search-forward "^response=\\(.*\\)$" (point-max) t)
	  (setq response (match-string-no-properties 1))
	(error "no response status code"))
      (when (not (string= response "OK"))
	(error "tune response not OK"))

      (goto-char start)
      (if (re-search-forward "^stationname=\\(.*\\)$" (point-max) t)
	  (setq stationname (match-string-no-properties 1))
	(error "no stationname from server"))

      (setq emms-librefm-stream-station-name stationname)

      (message "successfully tuned to: %s" stationname))))

(defun emms-librefm-stream-tune (station)
  "Make and handle tune call."
  (emms-librefm-stream-handle-tune-response
   (emms-librefm-stream-tune-call
    emms-librefm-stream-session-id
    station)))


;;; ------------------------------------------------------------------
;;; radio.getPlaylist
;;; ------------------------------------------------------------------

(defun emms-librefm-stream-getplaylist-string (radio-session-id)
  "Create the getplaylist string."
  (when (not radio-session-id)
    (error "null radio session id"))
  (let ((url (concat emms-librefm-stream-connect-method
		     emms-librefm-stream-host-url
		     emms-librefm-stream-host-base-path
		     "/xspf.php?"
		     "sk=" radio-session-id "&"
		     "discovery=0"          "&"
		     "desktop=1.3.0.58")))
    url))

(defun emms-librefm-stream-getplaylist-call (session-id)
  "Make the getplaylist call."
  (let ((url-request-method "POST"))
    (ignore url-request-method)
    (let ((response
	   (url-retrieve-synchronously
	    (emms-librefm-stream-getplaylist-string session-id))))
      (setq emms-librefm-stream-debug
	    (with-current-buffer response
	      (buffer-substring-no-properties (point-min)
					      (point-max))))
      response)))

(defun emms-librefm-stream-handle-getplaylist-response (resbuf)
  "Handle the getplaylist server response."
  (when (not (bufferp resbuf))
    (error "response not a buffer"))
  (with-current-buffer resbuf
    (emms-librefm-stream-assert-http)
    (xml-parse-region (point) (point-max))))

(defun emms-librefm-stream-getplaylist ()
  "Make and handle radio.getPlaylist."
  (emms-librefm-stream-handle-getplaylist-response
   (emms-librefm-stream-getplaylist-call
    emms-librefm-stream-session-id)))


;;; ------------------------------------------------------------------
;;; XSPF
;;; ------------------------------------------------------------------
(defun emms-librefm-stream-xspf-find (tag data)
  "Return the tracklist portion of PLAYLIST or nil."
  (let ((tree (copy-tree data))
	result)
    (while (and tree (not result))
      (let ((this (car tree)))
	(when (and (listp this)
		   (eq (car this) tag))
	  (setq result this)))
      (setq tree (cdr tree)))
    result))

(defun emms-librefm-stream-xspf-tracklist (playlist)
  "Return the tracklist portion of PLAYLIST or nil."
  (emms-librefm-stream-xspf-find 'trackList (car playlist)))

(defun emms-librefm-stream-xspf-get (tag track)
  "Return the data associated with TAG in TRACK."
  (nth 2 (emms-librefm-stream-xspf-find tag track)))

(defun emms-librefm-stream-xspf-convert-track (track)
  "Convert TRACK to an Emms track."
  (let ((location (emms-librefm-stream-xspf-get 'location track))
	(title    (emms-librefm-stream-xspf-get 'title track))
	(album    (emms-librefm-stream-xspf-get 'album track))
	(creator  (emms-librefm-stream-xspf-get 'creator track))
	(duration (emms-librefm-stream-xspf-get 'duration track)))
    (let ((emms-track (emms-dictionary '*track*)))
      (emms-track-set emms-track 'name location)
      (emms-track-set emms-track 'info-artist creator)
      (emms-track-set emms-track 'info-title title)
      (emms-track-set emms-track 'info-album album)
      (emms-track-set emms-track 'info-playing-time
		      (/ (string-to-number duration)
			 1000))
      (emms-track-set emms-track 'type 'url)
      emms-track)))

(defun emms-librefm-stream-xspf-convert-tracklist (tracklist)
  "Convert TRACKLIST to a list of Emms tracks."
  (let (tracks)
    (mapc
     #'(lambda (e)
	 (when (and (listp e)
		    (eq 'track (car e)))
	   (setq tracks
		 (append tracks
			 `(,(emms-librefm-stream-xspf-convert-track e))))))
     tracklist)
    tracks))


;;; ------------------------------------------------------------------
;;; stream
;;; ------------------------------------------------------------------

(defun emms-librefm-stream-set-librefm-playlist-buffer ()
  "Setup the GNU FM buffer and make it `emms-playlist-buffer'."
  (when (not (buffer-live-p emms-librefm-stream-playlist-buffer))
    (setq emms-librefm-stream-playlist-buffer
	  (emms-playlist-new
	   emms-librefm-stream-playlist-buffer-name)))
  (setq emms-playlist-buffer emms-librefm-stream-playlist-buffer))

(defun emms-librefm-stream-queue ()
  "Queue streaming tracks."
  (let ((tracklist
	 (emms-librefm-stream-xspf-tracklist
	  (emms-librefm-stream-getplaylist))))
    (when (not tracklist)
      (setq emms-librefm-stream-emms-tracklist nil)
      (error "could not find tracklist"))
    (setq emms-librefm-stream-emms-tracklist
	  (emms-librefm-stream-xspf-convert-tracklist tracklist))

    (emms-librefm-stream-set-librefm-playlist-buffer)

    (with-current-emms-playlist
      (goto-char (point-max))
      (save-excursion
	(mapc
	 #'(lambda (track)
	     (emms-playlist-insert-track track))
	 emms-librefm-stream-emms-tracklist)))))

(defun emms-librefm-stream-queue-loader ()
  "Queue more streaming music if needed."
  (with-current-emms-playlist
    (goto-char (if emms-playlist-mode-selected-overlay
		   (overlay-start emms-playlist-mode-selected-overlay)
		 (point-min)))
    (when (and (eq (current-buffer)
		   emms-librefm-stream-playlist-buffer)
	       (not (next-single-property-change (point-at-eol)
						 'emms-track)))
      (emms-librefm-stream-queue))))

(defun emms-librefm-stream (station)
  "Stream STATION from a GNU FM server."
  (interactive "sEnter station URL: ")
  (when (not (stringp station))
    (error "bad argument"))

  (add-hook 'emms-player-finished-hook
	    'emms-librefm-stream-queue-loader)
  
  (emms-librefm-stream-tune-handshake)
  (emms-librefm-stream-tune station)

  (message "tuned to %s, getting playlist..."
	   emms-librefm-stream-station-name)

  (emms-librefm-stream-queue)
  (with-current-emms-playlist
    (emms-playlist-mode-play-current-track)))


(provide 'emms-librefm-stream)

;;; emms-librefm-stream.el ends here