scrobble (empty) → 0.1.0.0
raw patch · 6 files changed
+332/−0 lines, 6 filesdep +basedep +networkdep +old-localesetup-changed
Dependencies added: base, network, old-locale, time, url
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- scrobble.cabal +37/−0
- src/Scrobble.hs +9/−0
- src/Scrobble/Server.hs +224/−0
- src/Server.hs +30/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Chris Done <chrisdone@gmail.com>++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 <chrisdone@gmail.com> 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ scrobble.cabal view
@@ -0,0 +1,37 @@+name: scrobble+version: 0.1.0.0+synopsis: Scrobbling server.+description: A library providing server-side support+ for the Audioscrobbler Realtime Submission protocol:+ <http://www.audioscrobbler.net/development/protocol/>+license: BSD3+license-file: LICENSE+author: Chris Done <chrisdone@gmail.com>+maintainer: Chris Done <chrisdone@gmail.com>+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+ build-depends: base >4 && <5,+ network,+ url,+ time,+ old-locale++executable scrobble-server+ hs-source-dirs: src+ main-is: Server.hs+ other-modules: Scrobble+ build-depends: base >4 && <5,+ network,+ url,+ time,+ old-locale
+ src/Scrobble.hs view
@@ -0,0 +1,9 @@+-- | Export-all interface to the scrobbling API.++module Scrobble+ (module Scrobble.Types+ ,module Scrobble.Server)+ where++import Scrobble.Server+import Scrobble.Types
+ src/Scrobble/Server.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns #-}++-- | A server for scrobbling, based upon the Audioscrobbler Realtime+-- Submission protocol v1.2+-- <http://www.audioscrobbler.net/development/protocol/>++module Scrobble.Server+ (startScrobbleServer)+ 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
+ src/Server.hs view
@@ -0,0 +1,30 @@+-- | 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+ }