diff --git a/scrobble.cabal b/scrobble.cabal
--- a/scrobble.cabal
+++ b/scrobble.cabal
@@ -1,5 +1,5 @@
name: scrobble
-version: 0.1.0.1
+version: 0.2.1.0
synopsis: Scrobbling server.
description: A library providing server-side support
for the Audioscrobbler Realtime Submission protocol:
@@ -19,13 +19,16 @@
library
hs-source-dirs: src
- exposed-modules: Scrobble.Server
- other-modules: Scrobble.Types
+ exposed-modules: Scrobble.Server, Scrobble.Client, Scrobble.Types
build-depends: base >4 && <5,
network,
url,
time,
- old-locale
+ old-locale,
+ pureMD5,
+ MissingH,
+ curl,
+ containers
executable scrobble-server
hs-source-dirs: src
@@ -35,4 +38,7 @@
network,
url,
time,
- old-locale
+ old-locale,
+ MissingH,
+ curl,
+ containers
diff --git a/src/Scrobble.hs b/src/Scrobble.hs
--- a/src/Scrobble.hs
+++ b/src/Scrobble.hs
@@ -2,8 +2,10 @@
module Scrobble
(module Scrobble.Types
- ,module Scrobble.Server)
+ ,module Scrobble.Server
+ ,module Scrobble.Client)
where
import Scrobble.Server
+import Scrobble.Client
import Scrobble.Types
diff --git a/src/Scrobble/Client.hs b/src/Scrobble/Client.hs
new file mode 100644
--- /dev/null
+++ b/src/Scrobble/Client.hs
@@ -0,0 +1,213 @@
+{-# 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)
diff --git a/src/Scrobble/Server.hs b/src/Scrobble/Server.hs
--- a/src/Scrobble/Server.hs
+++ b/src/Scrobble/Server.hs
@@ -6,7 +6,8 @@
--
module Scrobble.Server
- (startScrobbleServer)
+ (startScrobbleServer
+ ,module Scrobble.Types)
where
import Scrobble.Types
diff --git a/src/Scrobble/Types.hs b/src/Scrobble/Types.hs
--- a/src/Scrobble/Types.hs
+++ b/src/Scrobble/Types.hs
@@ -1,9 +1,14 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
-- | Scrobbling data types.
module Scrobble.Types where
-import Data.Time
-import Network
+import Control.Exception
+import Data.Data
+import Data.Time
+import Network
+import Network.URI (URI)
-- | Server configuration.
data Config = Config
@@ -93,7 +98,34 @@
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