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
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
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)
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 :: 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
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))
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]
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]
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
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
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)]
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)
parsePost :: String -> Maybe [(String, String)]
parsePost body = fmap url_params (importURL ("http://x/x?" ++ body))
requestMethod :: [String] -> Maybe (String,URL)
requestMethod headers =
case words (concat (take 1 headers)) of
[method,importURL -> Just url,_] ->
return (method,url)
_ -> Nothing
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
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)
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