scrobble-0.2.1.0/0000755000000000000000000000000012043326777011644 5ustar0000000000000000scrobble-0.2.1.0/scrobble.cabal0000644000000000000000000000260712043326777014430 0ustar0000000000000000name: scrobble version: 0.2.1.0 synopsis: Scrobbling server. description: A library providing server-side support for the Audioscrobbler Realtime Submission protocol: license: BSD3 license-file: LICENSE author: Chris Done maintainer: Chris Done copyright: 2012 Chris Done category: Network build-type: Simple cabal-version: >=1.8 source-repository head type: git location: https://github.com/chrisdone/scrobble library hs-source-dirs: src exposed-modules: Scrobble.Server, Scrobble.Client, Scrobble.Types build-depends: base >4 && <5, network, url, time, old-locale, pureMD5, MissingH, curl, containers executable scrobble-server hs-source-dirs: src main-is: Server.hs other-modules: Scrobble build-depends: base >4 && <5, network, url, time, old-locale, MissingH, curl, containers scrobble-0.2.1.0/LICENSE0000644000000000000000000000303212043326777012647 0ustar0000000000000000Copyright (c) 2012, Chris Done All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Chris Done nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. scrobble-0.2.1.0/Setup.hs0000644000000000000000000000005612043326777013301 0ustar0000000000000000import Distribution.Simple main = defaultMain scrobble-0.2.1.0/src/0000755000000000000000000000000012043326777012433 5ustar0000000000000000scrobble-0.2.1.0/src/Server.hs0000644000000000000000000000153612043326777014242 0ustar0000000000000000-- | A server program that merely accepts scrobbles and prints them to standard output. module Main where import Scrobble import Control.Monad import System.Environment -- | Main scrobbling server. main :: IO () main = do (port:_) <- fmap (map read) getArgs startScrobbleServer (config port) handlers where config port = Config (fromIntegral port) "localhost" (60*60) handlers = Handlers { handleHandshake = \s -> putStrLn $ "New session: " ++ show s , handleExpire = \s -> putStrLn $ "Session expired: " ++ show s , handleNowPlaying = \s np -> putStrLn $ "Now playing: " ++ show np , handleSubmissions = \s subs -> do forM_ subs $ \sub -> putStrLn $ "Listened: " ++ show sub return True } scrobble-0.2.1.0/src/Scrobble.hs0000644000000000000000000000037312043326777014525 0ustar0000000000000000-- | Export-all interface to the scrobbling API. module Scrobble (module Scrobble.Types ,module Scrobble.Server ,module Scrobble.Client) where import Scrobble.Server import Scrobble.Client import Scrobble.Types scrobble-0.2.1.0/src/Scrobble/0000755000000000000000000000000012043326777014166 5ustar0000000000000000scrobble-0.2.1.0/src/Scrobble/Types.hs0000644000000000000000000001114412043326777015627 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} -- | Scrobbling data types. module Scrobble.Types where import Control.Exception import Data.Data import Data.Time import Network import Network.URI (URI) -- | Server configuration. data Config = Config { cfgPort :: PortNumber -- ^ Port to listen on. , cfgHost :: String -- ^ Host name used for server (probably just localhost). , cfgExpire :: NominalDiffTime -- ^ Number of seconds of inactivity before a session expires. } deriving (Show) -- | Event handlers. data Handlers = Handlers { handleHandshake :: Session -> IO () -- ^ Initial connection hand-shake. , handleExpire :: Session -> IO () -- ^ Session expiry. , handleNowPlaying :: Session -> NowPlaying -> IO () -- ^ Now-playing notification. , handleSubmissions :: Session -> [Submission] -> IO Bool -- ^ Played tracks submission. } -- | A scrobbling session. data Session = Session { sesHandshake :: Bool -- ^ Does the session require handshake? , sesVersion :: String -- ^ Version of the protocol. , sesClientId :: String -- ^ Client (music player's) id. , sesClientVer :: String -- ^ Client version. , sesUser :: String -- ^ Username. , sesTimestamp :: UTCTime -- ^ Timestamp of connection. , sesToken :: String -- ^ Session token. } deriving (Show) -- | A now playing track. data NowPlaying = NowPlaying { npArtist :: String -- ^ Artist name. , npTrack :: String -- ^ Track title. , npAlbum :: Maybe String -- ^ Album name (if any). , npLength :: Maybe Integer -- ^ Track length in seconds (if known). , npPosition :: Maybe Integer -- ^ Track position (if known). , npMusicBrainz :: Maybe String -- ^ MusicBrainz track id (if known). } deriving (Show) -- | A track submission. data Submission = Submission { subArtist :: String -- ^ Artist name. , subTrack :: String -- ^ Track title. , subTimestamp :: UTCTime -- ^ Track timestamp. , subSource :: Source -- ^ Source of track. , subRating :: Maybe Rating -- ^ Rating (if any). , subLength :: Maybe Integer -- ^ Track length (if any). , subAlbum :: Maybe String -- ^ Album (if any). , subPosition :: Maybe Integer -- ^ Track position in album (if any). , subMusicBrainz :: Maybe String -- ^ MusicBrainz track id (if any). } deriving (Show) -- | A rating of a track. -- -- Note: Currently, a web-service must also be called to set love/ban -- status. We anticipate that this will be phased out soon, and the -- submission service will handle the whole process. data Rating = Love -- ^ Love (on any mode if the user has manually loved the -- track). This implies a listen. | Ban -- ^ Ban (only if source=L). This implies a skip, and the -- client should skip to the next track when a ban happens. | Skip -- ^ Skip (only if source=L). deriving (Enum,Eq,Show,Read) -- | The source of the track. Required, must be one of the following -- codes: -- -- Please note, for the time being, sources other than P and L are not -- supported. data Source = UserChosen -- ^ Chosen by the user | NonPersonlizedBroadcast -- ^ Non-personalised broadcast -- (e.g. Shoutcast, BBC Radio 1) | Personalized -- ^ Personalised recommendation except Last.fm -- (e.g. Pandora, Launchcast) | LastFm -- ^ Last.fm (any mode). In this case, the 5-digit Last.fm -- recommendation key must be appended to this source ID to -- prove the validity of the submission (for example, -- "o[0]=L1b48a"). | Unknown -- ^ Source unknown. deriving (Show,Enum,Eq,Read) -- | Server response. data Response = OK | BANNED | BADAUTH | FAILED String | BADSESSION deriving Show -- | A scrobbling client. data Client = Client { cliToken :: String -- ^ Session token. , cliNowPlaying :: URI -- ^ Now playing URL to submit to. , cliSubmit :: URI -- ^ URL to submit listened tracks to. } deriving (Show) -- | Details for creating a scrobbling client. data Details = Details { detPassword :: String , detUsername :: String , detClient :: String -- ^ E.g. “qlb”. , detVersion :: String -- ^ E.g. “0.9.2”. , detServer :: URI -- ^ See defaultServer in "Scrobble.Client". } deriving (Show) -- | Scrobble exception. data ScrobblerError = ScrobblerBanned | ScrobblerBadAuth | ScrobblerBadTime | ScrobblerFailed String | ScrobblerHardFail | ScrobblerSubmitFail String | ScrobblerNowPlayingFail String deriving (Show,Typeable,Data) instance Exception ScrobblerError scrobble-0.2.1.0/src/Scrobble/Client.hs0000644000000000000000000001573612043326777015754 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecordWildCards #-} -- | A client for scrobbling, based upon the Audioscrobbler Realtime -- Submission protocol v1.2 -- -- -- Example: -- -- @ -- import Scrobble.Client -- import Data.Time -- -- example = do -- client <- newClient Details -- { detPassword = \"YOURPASS\" -- , detUsername = \"YOURUSER\" -- , detClient = \"qlb\" -- , detVersion = \"0.9.2\" -- , detServer = defaultServer -- } -- nowPlaying client NowPlaying -- { npArtist = \"Kasabian\" -- , npTrack = \"Ladies and Gentlemen\" -- , npAlbum = Just \"West Ryder Pauper Lunatic Asylum\" -- , npLength = Just 288 -- , npPosition = Nothing -- , npMusicBrainz = Nothing -- } -- timestamp <- getCurrentTime -- submitTracks client -- [Submission { subArtist = \"Kasabian\" -- , subTrack = \"Ladies and Gentlemen\" -- , subTimestamp = timestamp -- , subSource = UserChosen -- , subRating = Nothing -- , subLength = Just 288 -- , subAlbum = Just \"West Ryder Pauper Lunatic Asylum\" -- , subPosition = Nothing -- , subMusicBrainz = Nothing -- }] -- @ module Scrobble.Client (newClient ,nowPlaying ,submitTracks ,defaultServer ,module Scrobble.Types) where import Scrobble.Types import Control.Arrow import Control.Exception import Control.Monad import Data.Hash.MD5 (Str(..),md5s) import Data.List import Data.Maybe import Data.Time import Data.Time.Clock.POSIX import Network.Curl import Network.URI import System.Locale -- | Get a session token. -- -- The algorithm for generating this token is as follows: -- token := md5(md5(password) + timestamp) -- -- The md5() function takes a string and returns the 32-byte ASCII -- hexadecimal representation of the MD5 hash, using lower case -- characters for the hex values. getToken :: String -- ^ The password. -> IO (String,String) -- ^ A session token and timestamp. getToken password = do timestamp <- getCurrentTime let et = epoch timestamp return (md5 (md5 password ++ et),et) where md5 = md5s . Str -- | Create a client session. Throws "ScrobblerError". newClient :: Details -> IO Client newClient Details{..} = withCurlDo $ do (token,timestamp) <- getToken detPassword let params = [("hs","true") ,("p","1.2") ,("c",detClient) ,("v",detVersion) ,("u",detUsername) ,("t",timestamp) ,("a",token)] response <- curlGrab (setQuery detServer params) [CurlHttpHeaders [ "Host: " ++ host | Just host <- [fmap uriRegName (uriAuthority detServer)] ]] parseAuth response -- | Parse the auth response. parseAuth :: CurlGrab -> IO Client parseAuth CurlGrab{..} = case lines grabBody of ["OK",token,parseURI -> Just nowplaying,parseURI -> Just submit] -> return (Client token nowplaying submit) ["BANNED"] -> throw ScrobblerBanned ["BADAUTH"] -> throw ScrobblerBadAuth ["BADTIME"] -> throw ScrobblerBadTime [other] | isPrefixOf failed other -> throw (ScrobblerFailed (drop (length failed) other)) | otherwise -> throw ScrobblerHardFail where failed = "FAILED " -- | Default Audioscrobbler server: http://post.audioscrobbler.com/ defaultServer :: URI defaultServer = fromJust (parseURI "http://post.audioscrobbler.com/") -- | Send a now playing message. Throws "ScrobblerError". nowPlaying :: Client -> NowPlaying -> IO () nowPlaying client@Client{..} nowplaying = do CurlGrab{grabBody} <- curlGrab cliNowPlaying [CurlPost True ,CurlPostFields (map keyval (makeNowPlaying client nowplaying))] unless (trim grabBody == "OK") $ throw (ScrobblerNowPlayingFail grabBody) -- | Make a now playing query. makeNowPlaying :: Client -> NowPlaying -> [(String,String)] makeNowPlaying Client{..} NowPlaying{..} = [("s",cliToken) ,("a",npArtist) ,("t",npTrack) ,("b",fromMaybe "" npAlbum) ,("l",maybe "" show npLength) ,("n",maybe "" show npPosition) ,("m",fromMaybe "" npMusicBrainz)] -- | Submit track(s). Throws "ScrobblerError". submitTracks :: Client -> [Submission] -> IO () submitTracks client@Client{..} submissions = do CurlGrab{grabBody} <- curlGrab cliSubmit [CurlPost True ,CurlPostFields (map keyval params)] unless (trim grabBody == "OK") $ throw (ScrobblerSubmitFail grabBody) where params = [("s",cliToken)] ++ concat (zipWith (makeSubmission client) [0..] submissions) -- | Make a now playing query. makeSubmission :: Client -> Integer -> Submission -> [(String,String)] makeSubmission Client{..} i Submission{..} = map hookup [("a",subArtist) ,("t",subTrack) ,("i",epoch subTimestamp) ,("o",fromMaybe "U" (lookup subSource sources)) ,("r",fromMaybe "" (subRating >>= \r -> lookup r ratings)) ,("l",maybe "" show subLength) ,("b",fromMaybe "" subAlbum) ,("n",maybe "" show subPosition) ,("m",fromMaybe "" subMusicBrainz)] where sources = [(UserChosen,"P") ,(NonPersonlizedBroadcast,"R") ,(Personalized,"E") ,(LastFm,"L")] ratings = [(Love,"L"),(Ban,"B"),(Skip,"S")] hookup (k,v) = (k ++ "[" ++ show i ++ "]",v) -------------------------------------------------------------------------------- -- Utilities -- | Encode post parameters to a string. encodePost :: [(String,String)] -> String encodePost = intercalate "&" . map (keyval . (encode *** encode)) where encode = escapeURIString isUnescapedInURI -- | Make a key=val string. keyval :: (String,String) -> String keyval (key,val) = key ++ "=" ++ val -- | Set a URI's query. setQuery :: URI -> [(String,String)] -> URI setQuery uri assoc = uri { uriQuery = "?" ++ encodePost assoc } -- | Format a time to UNIX number. epoch :: UTCTime -> String epoch = formatTime defaultTimeLocale "%s" -- | Just strip whitespace. trim :: String -> String trim = unwords . words -------------------------------------------------------------------------------- -- Make Curl's API not crappy. -- | Grab a URL with curl. curlGrab :: URI -> [CurlOption] -> IO CurlGrab curlGrab url options = do CurlResponse{..} <- curlGetResponse_ (show url) options return $ CurlGrab respCurlCode respStatus respStatusLine respHeaders respBody -- | A sane data type. data CurlGrab = CurlGrab { grabCode :: CurlCode , grabStatus :: Int , grabStatusLine :: String , grabHeaders :: [(String,String)] , grabBody :: String } deriving (Show) scrobble-0.2.1.0/src/Scrobble/Server.hs0000644000000000000000000001675212043326777016003 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ViewPatterns #-} -- | A server for scrobbling, based upon the Audioscrobbler Realtime -- Submission protocol v1.2 -- module Scrobble.Server (startScrobbleServer ,module Scrobble.Types) where import Scrobble.Types import Control.Applicative hiding (optional) import Control.Concurrent import Control.Exception import Control.Monad import Data.Char import Data.List import Data.Time import Network import Network.URL import Numeric import Prelude hiding (catch) import System.IO import System.Locale -------------------------------------------------------------------------------- -- Server -- | Start a scrobbling server. startScrobbleServer :: Config -> Handlers -> IO () startScrobbleServer cfg handlers = do hSetBuffering stdout NoBuffering clients <- newMVar [] listener <- listenOn (PortNumber (cfgPort cfg)) expire <- forkIO $ expireClients handlers cfg clients flip finally (do sClose listener; killThread expire) $ forever $ do (h,_,_) <- accept listener forkIO $ do hSetBuffering h NoBuffering headers <- getHeaders h case requestMethod headers of Just ("GET",url_params -> params) -> handleInit cfg handlers h clients params Just ("POST",url) -> do rest <- hGetContents h case requestBody headers rest of Nothing -> return () Just body -> dispatch handlers h clients url body _ -> return () hClose h -- | Expire client sessions after inactivity. expireClients :: Handlers -> Config -> MVar [Session] -> IO () expireClients handlers cfg clients = forever $ do threadDelay (1000 * 1000 * 60) now <- getCurrentTime modifyMVar_ clients $ filterM $ \client -> do let expired = diffUTCTime now (sesTimestamp client) > cfgExpire cfg when expired $ handleExpire handlers client return (not expired) -- | Handle initial handshake. handleInit :: Config -> Handlers -> Handle -> MVar [Session] -> [(String,String)] -> IO () handleInit cfg handlers h clients params = case params of (makeSession -> Just sess) -> do handleHandshake handlers sess modifyMVar_ clients (return . (sess :)) reply h [show OK ,sesToken sess ,selfurl "nowplaying" ,selfurl "submit"] _ -> reply h [show BADAUTH] where selfurl x = "http://" ++ cfgHost cfg ++ ":" ++ show (cfgPort cfg) ++ "/" ++ x -- | Dispatch on commands. dispatch :: Handlers -> Handle -> MVar [Session] -> URL -> String -> IO () dispatch handlers h clients url body = case parsePost body of Nothing -> error "Unable to parse POST body." Just params -> withSession h clients params $ \sess -> case url_path url of "nowplaying" -> handleNow handlers h sess params "submit" -> handleSubmit handlers h sess params _ -> error $ "Unknown URL: " ++ url_path url -- | Look up the session and do something with it. withSession :: Handle -> MVar [Session] -> [(String,String)] -> (Session -> IO ()) -> IO () withSession h clients params go = case lookup "s" params of Nothing -> error "No session given." Just token -> do modifyMVar_ clients $ \sessions -> do case find ((==token) . sesToken) sessions of Nothing -> do reply h [show BADSESSION] return sessions Just sess -> do go sess now <- getCurrentTime return (sess { sesTimestamp = now } : (filter ((/=token) . sesToken) sessions)) -- | Handle now playing command. handleNow handlers h sess params = do case makeNowPlaying params of Nothing -> error $ "Invalid now playing notification: " ++ show params Just np -> do handleNowPlaying handlers sess np reply h [show OK] -- | Handle submit command. handleSubmit handlers h sess params = do case makeSubmissions params of Nothing -> error $ "Unable to parse submissions: " ++ show params Just subs -> do ok <- handleSubmissions handlers sess subs when ok $ reply h [show OK] -------------------------------------------------------------------------------- -- Command data structures -- | Make a session from a parameter set. makeSession :: [(String,String)] -> Maybe Session makeSession params = Session <$> bool (get "hs") <*> get "p" <*> get "c" <*> get "v" <*> get "u" <*> time (get "t") <*> get "a" where get k = lookup k params -- | Make a now-playing notification. makeNowPlaying :: [(String,String)] -> Maybe NowPlaying makeNowPlaying params = NowPlaying <$> get "a" <*> get "t" <*> optional (get "b") <*> mint (get "l") <*> mint (get "n") <*> optional (get "m") where get k = lookup k params -- | Make a batch of track submissions. makeSubmissions :: [(String,String)] -> Maybe [Submission] makeSubmissions params = forM [0..length (filter (isPrefixOf "a[" . fst) params) - 1] $ \i -> do let get k = lookup (k ++ "[" ++ show i ++ "]") params Submission <$> get "a" <*> get "t" <*> time (get "i") <*> source (get "o") <*> rating (get "r") <*> mint (get "l") <*> optional (get "b") <*> mint (get "n") <*> optional (get "m") where source m = m >>= \s -> lookup s sources where sources = [("P",UserChosen) ,("R",NonPersonlizedBroadcast) ,("E",Personalized) ,("L",LastFm) ,("U",Unknown)] rating m = m >>= \r -> fmap Just (lookup r ratings) <|> return Nothing where ratings = [("L",Love),("B",Ban),("S",Skip)] -------------------------------------------------------------------------------- -- Some param parsing utilities time m = m >>= parseTime defaultTimeLocale "%s" bool = fmap (=="true") mint m = m >>= \x -> case reads x of [(n,"")] -> return (Just n) _ -> return Nothing optional m = do v <- m if null v then return Nothing else return (Just v) -------------------------------------------------------------------------------- -- HTTP utilities -- | Parse a POST request's parameters. parsePost :: String -> Maybe [(String, String)] parsePost body = fmap url_params (importURL ("http://x/x?" ++ body)) -- | Get the request method. requestMethod :: [String] -> Maybe (String,URL) requestMethod headers = case words (concat (take 1 headers)) of [method,importURL -> Just url,_] -> return (method,url) _ -> Nothing -- | Get the request body. requestBody :: [String] -> String -> Maybe String requestBody headers body = do len <- lookup "content-length:" (map (break (==' ') . map toLower) headers) case readDec (unwords (words len)) of [(l,"")] -> return (take l body) _ -> Nothing -- | Read up to the headers. getHeaders :: Handle -> IO [String] getHeaders h = go [] where go ls = do l <- hGetLine h if l == "\r" then return (reverse ls) else go (l : ls) -- | Make a HTTP reply. reply :: Handle -> [String] -> IO () reply h rs = hPutStrLn h resp where body = unlines rs resp = unlines ["HTTP/1.1 200 OK" ,"Content-Length: " ++ show (length body) ,""] ++ body