AudioScrobbler.hs

{- Implements the AudioScrobbler HTTP protocol 1.1.
 - The function scrobbler monitor starts a thread which
 - monitors the MPD player and sends new songs to MPD 
 - as per the protocol.
 -}
module Hmpf.AudioScrobbler (scrobblermonitor) where


import Network.Browser
import Network.HTTP
import Network.URI
import Numeric
import Data.Maybe
import Data.Digest.MD5
import Codec.Utils
import Data.List (intersperse, splitAt)
import Data.Char (toLower)
import System.Locale (defaultTimeLocale)
import Data.Time hiding ( utc )
import Hmpf.MPDSession
import Control.Concurrent ( threadDelay)
import Hmpf.ApplicationTypes


scrobblermonitor :: Session ()
scrobblermonitor = do
 st <- get
 case ( lastfmUser st ) of
  Nothing -> lift ( putStrLn "No Last.Fm user configured. Playlist will not be sent to Last.Fm" )
  Just uid -> (lift (putStrLn $ "Playlist will be sent to Last.Fm for '"++(fst uid)++"'" )) >> (scrobblermonitor' Nothing)

scrobblermonitor' :: Maybe Int -> Session ()
scrobblermonitor' ms = do
 lift $ threadDelay 10000000
 st <- status 
 let sid = songid $ st
     e = elapsed $ st
     d = duration $ st
     diff = do -- Is the current song and last song updated different?
      i <- ms
      i' <- sid
      if( i /= i' )
       then return i'
       else fail "No new song"
     cond = do -- Is the current song ready to be updated?
      e' <- e
      d' <- d
      if ( e' > 240 || ( e' >0 && d' `div` e' < 2 && d' > 30 ) )
       then return True
       else fail "Not ready to be updated"
 if ( isNothing ms ) 
  then if ( isNothing cond )
        then scrobblermonitor' Nothing
	else do 
	 Just cs <- currentsong
	 tm <- lift getCurrentTime
	 b <- submit [(cs,tm)]
	 let t = title cs
	     a = artist cs
	 lift . putStrLn $  a ++ "/"  ++ t ++ ": submitted - " ++ ( show b )
	 scrobblermonitor' sid 
  else if ( isNothing diff )
        then scrobblermonitor' ms
	else scrobblermonitor' Nothing


submit :: [(Song,UTCTime)] -> Session Bool
submit songs = do
 st <- get
 case ( scrobble st) of 
  Nothing -> ( handshake >> (submit' songs) )
  _ -> submit' songs

utc :: FormatTime a => a -> String
utc = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S"

host = "post.audioscrobbler.com"

server = fromJust . parseURI $ "http://post.audioscrobbler.com/?hs=true&p=1.1&c=tst&v=1.0&u=mihochan"

req = Request server GET [] ""


submit' :: [ (Song, UTCTime) ] -> Session Bool
submit' songs = do
 st <- get
 let 
  Just (uri,tkn,i) = scrobble st
  Just (uid,passwd) = lastfmUser st
  headers = [ Header HdrContentType "application/x-www-form-urlencoded"
            , Header HdrContentLength (show . length $ query)
            ]
  params = p ++ (concatMap mkParams (zip [0..] songs) )
  query = concat . intersperse "&" . map  (\(a,b) -> (a ++ "=" ++ b)) $ params
  f = escapeURIString isUnreserved
  p = [  ( "u"  , uid ), ( "s"  ,  tkn ) ]
  mkParams :: (Int, ( Song , UTCTime)) -> [ (String,String) ]
  mkParams (i, (song,t)) = 
             [ ( "a[" ++ (show i) ++ "]" , art )
	     , ( "t[" ++ (show i) ++ "]" , trck )
	     , ( "b[" ++ (show i) ++ "]" , alb )
	     , ( "m[" ++ (show i) ++ "]" , "" )
	     , ( "l[" ++ (show i) ++ "]" , lngth )
	     , ( "i[" ++ (show i) ++ "]" , tm ) ]
	where
     	 tm = f $ utc t
         art = f $ artist song
         alb = f $ album song
         trck = f $ title song
         lngth = show . time $ song
 lift ( threadDelay (i * 1000000 ) )
 result <- lift $ simpleHTTP ( Request uri POST headers query )
 case result of 
  Left err -> (lift . putStrLn . show $ err) >> return False
  Right resp -> do
       let ls = lines . rspBody $ resp
           newinterval = (read . last . words $ ( ls !! 1)) :: Int
	   outcome = head . words . head $ ls 
	   msg = unwords . tail . words . head $ ls 
       case ( head . words . head $ ls ) of
        "OK" -> put ( st { scrobble = Just (uri,tkn,i) } ) >> return True
	"FAILED" -> (lift . putStrLn $ msg ) >> put ( st { scrobble = Just (uri,tkn,i) } ) >> return False
	"BADAUTH" -> (lift . putStrLn $ "BADAUTH" ) >> put ( st { scrobble = Nothing } ) >> return False
	_ -> (lift. mapM_ putStrLn  $ ls ) >> put ( st { scrobble = Nothing } ) >> return False



handshake :: Session ()
handshake = do 
 st <- get
 result <- lift (simpleHTTP req)
 case result of
  Left err -> do
     put ( st { scrobble = Nothing } )
     lift . putStrLn . show $ err
     return ()
  Right resp -> do
     let challenge = body !! 1
         uri = fromJust . parseURI . ( !!2 ) $ body
         body = lines . rspBody $ resp
         interval = read . last . words $ ( body !! 3 )
	 tkn = token challenge (snd . fromJust . lastfmUser $ st)
     put ( st { scrobble = Just ( uri , tkn , interval ) } )
     lift . putStrLn $ "Completed handshake"


--Generate a token for a given password and challenge
token :: String -> String -> String
token challenge password = 
 let md5 = map toLower . toHex . hash . convert
     p = md5 password
 in md5 $ p ++ challenge


--Converts an ordinary string into a list of Octets
convert :: String -> [Octet]
convert = map (toEnum . fromEnum) 

--Converts a HEX representation into a list of Octets
fromHex :: String -> [Octet]
fromHex = foldr ( \i -> \lst -> (f i) : lst ) [] . pair
 where
  f :: String -> Octet
  f n = let result = readHex n
        in case result of
	    [(val,"")] -> toEnum val
	    _ -> error "Failed to parse"

--Convert a list of Octets into a HEX string representation
toHex :: [Octet] -> String
toHex = foldr (f.fromEnum) []
 where
  f x = let f' = showHex x
        in \i -> if x < 0x10
	          then '0' : f' i
		  else f' i

pair :: [a] -> [[a]]
pair [] = []
pair xs | length xs `mod` 2 == 1 = [head xs] : ( pair . tail $ xs )
pair (x:y:xs) = [x,y] : ( pair xs )