diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,9 @@ CHANGELOG +2.20131220 -> 2.20140323 + - Update to aeson-0.7 + - Fix douban listen musician/album + 2.20131203 -> 2.20131220 - Update to fast-logger-2.0 - New command: lord douban listen [ | ] diff --git a/Radio.hs b/Radio.hs deleted file mode 100644 --- a/Radio.hs +++ /dev/null @@ -1,241 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - --- | A generic interface to online radio services -module Radio - ( SongMeta(..) - , Radio(..) - , NeedLogin(..) - , getLordDir - , getPidFile - , getLogFile - , getStateFile - , writeLog - ) where - -import Codec.Binary.UTF8.String (encodeString) -import Control.Applicative ((<$>)) -import Control.Concurrent (forkIO, threadDelay) -import Control.Concurrent.MVar -import Control.Monad (liftM, when, void) -import Data.Aeson hiding (encode) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as C -import Data.Maybe (isJust, fromJust) -import Data.Monoid ((<>)) -import Data.Yaml -import Network.MPD hiding (play, pause, Value) -import qualified Network.MPD as MPD -import Network.MPD.Core (getResponse) -import Network.Wai.Logger (ZonedDate, clockDateCacher) -import System.Directory (doesFileExist, getHomeDirectory) -import System.IO -import System.IO.Unsafe (unsafePerformIO) -import System.Log.FastLogger -import System.Process - - -eof :: MVar () -eof = unsafePerformIO newEmptyMVar - -data SongMeta = SongMeta - { artist :: String - , album :: String - , title :: String - } - -instance Show SongMeta where - show meta = artist meta ++ " - " ++ title meta - -class FromJSON a => Radio a where - data Param a :: * - - parsePlaylist :: Value -> [a] - - getPlaylist :: Param a -> IO [a] - - songUrl :: Param a -> a -> IO String - - songMeta :: a -> SongMeta - - tagged :: a -> Bool - - reportRequired :: a -> Bool - reportRequired _ = False - - report :: Param a -> a -> IO () - report _ _ = return () - - reportLoop :: Param a -> a -> IO () - reportLoop param x = do - time <- liftM stTime <$> withMPD status - case time of - Right (elapsed, _) -> - if elapsed < 30 - then threadDelay (5*1000000) >> reportLoop param x - else report param x - Left err -> print err - - play :: LoggerSet -> Param a -> [a] -> IO () - play logger reqData xxs = do - st <- withMPD status - case st of - Right _ -> playWithMPD logger reqData xxs - Left _ -> playWithMplayer logger reqData xxs - --- MPD can play remote m4a files directly since version-0.18 -playWithMPD :: Radio a => LoggerSet -> Param a -> [a] -> IO () -playWithMPD logger reqData [] = - getPlaylist reqData >>= playWithMPD logger reqData -playWithMPD logger reqData (x:xs) = do - surl <- songUrl reqData x - print surl - when (surl /= "") $ do - logAndReport logger reqData x - mpdLoad $ Path $ C.pack surl - takeMVar eof -- Finished - playWithMPD logger reqData xs - where - mpdLoad :: Path -> IO () - mpdLoad path = do - withMPD $ do - clear - add path - withMPD $ MPD.play Nothing - - mpdTag $ songMeta x - mpdPlay - mpdPlay :: IO () - mpdPlay = do - st <- mpdState - if st == Right Stopped - then putMVar eof () - else mpdPlay - -playWithMplayer :: Radio a => LoggerSet -> Param a -> [a] -> IO () -playWithMplayer logger reqData [] = - getPlaylist reqData >>= playWithMplayer logger reqData -playWithMplayer logger reqData (x:xs) = do - surl <- songUrl reqData x - when (surl /= "") $ do - logAndReport logger reqData x - let sh = "mplayer -cache 2048 -cache-min 5 -novideo " ++ surl - void $ waitForProcess =<< runCommand sh - playWithMplayer logger reqData xs - -logAndReport :: Radio a => LoggerSet -> Param a -> a -> IO () -logAndReport logger reqData x = do - writeLog logger (show $ songMeta x) - getStateFile >>= flip writeFile (show $ songMeta x) - -- Report song played if needed - when (reportRequired x) $ void (forkIO $ reportLoop reqData x) - -mpdState :: IO (MPD.Response State) -mpdState = do - withMPD $ idle [PlayerS] - -- This will block until paused/finished. - - st <- liftM stState <$> withMPD status - print st - return st - --- "addtagid" command is available since mpd-0.19 -mpdTag :: SongMeta -> IO () -mpdTag meta = void $ withMPD $ do - cs <- currentSong - when (isJust cs) $ do - let (Id sid) = fromJust $ sgId $ fromJust cs - void $ do - addTag sid arTag - addTag sid alTag - addTag sid tiTag - where - addTag sid tag = getResponse $ "addtagid " ++ show sid ++ tag - arTag = " artist \"" ++ artist meta ++ "\"" - alTag = " album \"" ++ album meta ++ "\"" - tiTag = " title \"" ++ title meta ++ "\"" - -class (Radio a, ToJSON (Param a), ToJSON (Config a)) => NeedLogin a where - login :: String -> IO (Param a) - login keywords = do - hSetBuffering stdout NoBuffering - hSetEcho stdin True - putStrLn "Please Log in" - putStr "Email: " - email <- getLine - putStr "Password: " - hSetEcho stdin False - pwd <- getLine - hSetEcho stdin True - putStrLn "" - mtoken <- createSession keywords email pwd - case mtoken of - Just tok -> do - saveToken tok - return tok - Nothing -> do - putStrLn "ERROR: Invalid email or password!" - login keywords - - createSession :: String -> String -> String -> IO (Maybe (Param a)) - - data Config a :: * - - mkConfig :: Param a -> Config a - - saveToken :: Param a -> IO () - saveToken tok = do - home <- getLordDir - let yml = home ++ "/lord.yml" - exist <- doesFileExist yml - bs <- if exist - then B.readFile yml - else return "" - let config = mkConfig tok - B.writeFile yml $ B.append bs (encode config) - putStrLn $ "Your token has been saved to " ++ yml - - mkParam :: Param a -> String -> Param a - - readToken :: FromJSON (Config a) - => (Config a -> Param a) -> String -> IO (Maybe (Param a)) - readToken selector keywords = do - home <- Radio.getLordDir - let yml = home ++ "/lord.yml" - exist <- doesFileExist yml - if exist - then do - conf <- decodeFile yml - case conf of - Nothing -> error $ "Invalid YAML file: " ++ show conf - Just c -> - case fromJSON c of - Success tok -> return $ Just $ - mkParam (selector tok) keywords - Error err -> do - print $ "Parse token failed: " ++ show err - return Nothing - else return Nothing - -getLordDir :: IO FilePath -getLordDir = (++ "/.lord") <$> getHomeDirectory - -getPidFile :: IO FilePath -getPidFile = (++ "/lord.pid") <$> getLordDir - -getLogFile :: IO FilePath -getLogFile = (++ "/lord.log") <$> getLordDir - -getStateFile :: IO FilePath -getStateFile = (++ "/lordstate") <$> getLordDir - -formatLogMessage :: IO ZonedDate -> String -> IO LogStr -formatLogMessage getdate msg = do - now <- getdate - return $ toLogStr now <> " : " <> toLogStr (encodeString msg) <> "\n" - -writeLog :: LoggerSet -> String -> IO () -writeLog l msg = do - (loggerDate, _) <- clockDateCacher - formatLogMessage loggerDate msg >>= pushLogStr l diff --git a/Radio/Cmd.hs b/Radio/Cmd.hs deleted file mode 100644 --- a/Radio/Cmd.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} --- | Module of http://cmd.fm -module Radio.Cmd where - -import qualified Control.Exception as E -import Control.Monad (liftM) -import Data.Aeson -import qualified Data.ByteString.Char8 as C -import Data.Conduit (($$+-)) -import Data.Conduit.Attoparsec (sinkParser) -import qualified Data.HashMap.Strict as HM -import GHC.Generics (Generic) -import Network.HTTP.Conduit -import Network.HTTP.Types (renderQuery) -import Network.HTTP.Types.Header (hLocation) -import Network.HTTP.Types.Status (status302) - -import qualified Radio - - -data Cmd = Cmd - { sc_id :: Int - , title :: String - , artwork_url :: String - , description :: String - , duration :: Int - --, genre :: String - , tag_list :: String - , waveform_url :: String - , stream_url :: String - --, last_listened :: Int - , main_type :: String - --, created_at :: String - --, updated_at :: String - } deriving (Show, Generic) - -instance FromJSON Cmd - -instance Radio.Radio Cmd where - data Param Cmd = Genre String - - parsePlaylist val = - case fromJSON val of - Success s -> s - Error err -> error $ "Parse playlist failed: " ++ show err - - getPlaylist (Genre g) = do - let url = "http://cmd.fm/api/tracks/search" - query = [ ("genre", Just $ C.pack g) - , ("limit", Just $ C.pack "10") ] - initReq <- parseUrl url - let req = initReq { method = "GET" - , queryString = renderQuery False query - } - withManager $ \manager -> do - res <- http req manager - liftM Radio.parsePlaylist (responseBody res $$+- sinkParser json) - - songUrl _ x = do - initReq <- parseUrl url - let req = initReq { method = "GET" - , queryString = renderQuery False query - } - E.catch (withManager $ \manager -> - httpLbs req { redirectCount = 0 } manager >> return "") - (\e -> case e of - (StatusCodeException s hdr _) -> - if s == status302 then redirect hdr - else return "" - otherException -> print otherException >> return "" - ) - where - url = stream_url x - query = [("client_id", Just $ C.pack "2b659ea66970555922d89ce9c07b2d0d")] - redirect hdr = case HM.lookup hLocation $ HM.fromList hdr of - Just u -> return $ C.unpack u - Nothing -> return "" - - songMeta x = Radio.SongMeta "" "" (title x) - - tagged _ = False - --- Currently, no api is provided to retrieve genre list. -genres :: IO [String] -genres = return - ["80s","Abstract","Acid Jazz","Acoustic" - ,"Acoustic Rock","Alternative","Ambient","Avantgarde" - ,"Ballads","Blues","Blues Rock","Breakbeats" - ,"Chillout","Chiptunes","Choir","Classic Rock" - ,"Classical","Classical Guitar","Contemporary","Dance" - ,"Dancehall","Death Metal","Dirty South","Disco" - ,"Dream Pop","Drum & Bass","Dub","Dubstep" - ,"Easy Listening","Electro House","Electronic","Electronic Pop" - ,"Electronic Rock","Folk Rock","Funk","Glitch" - ,"Grime","Grindcore","Grunge","Hard Rock", - "Hardcore","Heavy Metal","Hip-Hop","House" - ,"Indie","Indie Pop","Industrial Metal","Instrumental" - ,"Instrumental Rock","J-Pop","Jazz","Jazz Funk" - ,"Jazz Fusion","K-Pop","Latin Jazz","Metalcore" - ,"Minimal","Modern Jazz","Moombahton","New Wave" - ,"Nu Jazz","Opera","Orchestral","Piano" - ,"Pop","Post Hardcore","Post Rock","Progressive House" - ,"Progressive Metal","Progressive Rock","Punk" - ,"R&B","Rap","Reggae","Reggaeton","Riddim" - ,"Rock","Rock 'n' Roll","Shoegaze","Singer / Songwriter" - ,"Smooth Jazz","Soul","Synth Pop","Tech House" - ,"Techno","Thrash Metal","Trance","Trap" - ,"Trip-hop","Turntablism","Underground"] - -pprGenres :: [String] -> IO () -pprGenres [] = return () -pprGenres gs = do - putStrLn $ foldr1 f (take 4 gs) - pprGenres $ drop 4 gs - where - f a b = a ++ concat (replicate (20 - length a) " ") ++ b diff --git a/Radio/Douban.hs b/Radio/Douban.hs deleted file mode 100644 --- a/Radio/Douban.hs +++ /dev/null @@ -1,221 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} --- | Module of http://douban.fm -module Radio.Douban where - -import Codec.Binary.UTF8.String (encodeString) -import Control.Applicative ((<$>), (<*>)) -import Control.Monad -import Data.Aeson -import qualified Data.ByteString.Char8 as C -import Data.Char (isDigit) -import Data.Conduit (($$+-)) -import Data.Conduit.Attoparsec (sinkParser) -import qualified Data.HashMap.Strict as HM -import Data.List (isPrefixOf) -import Data.Maybe (fromJust, fromMaybe) -import qualified Data.Text as T -import Network.HTTP.Conduit -import Network.HTTP.Types (urlEncode, renderQuery, Query) -import Prelude hiding (id) -import System.Console.ANSI -import Text.HTML.DOM (parseLBS) -import Text.XML.Cursor - -import qualified Radio - - -data Douban = Douban - { picture :: String - , albumtitle :: String - -- , company :: String - -- , rating_avg :: Float - -- , public_time :: String - , ssid :: Maybe String - , album :: String - -- , like :: Int - , artist :: String - , url :: String - , title :: String - , subtype :: String - -- , length :: Int - , sid :: String - , aid :: String - } deriving Show - -instance FromJSON Douban where - parseJSON (Object v) = Douban <$> - v .: "picture" <*> - v .: "albumtitle" <*> - v .:? "ssid" <*> - v .: "album" <*> - --v .: "like" <*> - v .: "artist" <*> - v .: "url" <*> - v .: "title" <*> - v .: "subtype" <*> - v .: "sid" <*> - v .: "aid" - parseJSON _ = mzero - - -getPlaylist' :: Query -> IO [Douban] -getPlaylist' query = do - let rurl = "http://douban.fm/j/mine/playlist" - initReq <- parseUrl rurl - let req = initReq { method = "GET" - , queryString = renderQuery False query - } - withManager $ \manager -> do - res <- http req manager - liftM Radio.parsePlaylist (responseBody res $$+- sinkParser json) - -musicianId :: String -> IO (Maybe String) -musicianId mname = do - let rurl = "http://music.douban.com/subject_search/?search_text=" ++ - C.unpack (urlEncode True (C.pack $ encodeString mname)) - rsp <- simpleHttp rurl - let cursor = fromDocument $ parseLBS rsp - href = cursor $// element "a" - >=> attributeIs "class" "ll musician_title " - &| attribute "href" - return $ Just $ filter isDigit $ T.unpack $ head $ head href - -albumPlayable :: Int -> IO Bool -albumPlayable aId = do - res <- simpleHttp $ aPattern ++ show aId - let cursor = fromDocument $ parseLBS res - start_radio = cursor $// element "div" - >=> attributeIs "class" "start_radio" - return $ not $ null start_radio - where - aPattern = "http://music.douban.com/subject/" - -mkQuery :: Int -> String -> Query -mkQuery cid context = - [ ("type", Just "n") - , ("channel", Just $ C.pack $ show cid) - , ("context", Just $ C.pack context) - , ("from", Just "lord") - ] - -instance Radio.Radio Douban where - data Param Douban = ChannelId Int - | Album Int - | MusicianId Int - | MusicianName String - - -- TODO: those without ssid filed are ads, filter them out! - parsePlaylist (Object hm) = do - let songs = HM.lookup "song" hm - case fromJSON $ fromMaybe Null songs of - Success s -> s - Error _ -> [] - parsePlaylist _ = error "Unrecognized playlist format." - - getPlaylist (ChannelId cid) = getPlaylist' $ mkQuery cid "" - getPlaylist (Album aId) = do - playable <- albumPlayable aId - if playable then getPlaylist' $ - mkQuery 0 $ "channel:0|subjetc_id:" ++ show aId - else error "This album can not be played." - getPlaylist (MusicianId mid) = - getPlaylist' $ mkQuery 0 $ "channel:0|musician_id" ++ show mid - getPlaylist (MusicianName mname) = do - mmid <- musicianId mname - Radio.getPlaylist (MusicianId $ read $ fromJust mmid) - - songUrl _ x = return $ url x - - songMeta x = Radio.SongMeta (artist x) (albumtitle x) (title x) - - -- Songs from douban.fm comes with no tags! - tagged _ = False - -data Channel = Channel - { intro :: String - , name :: String - , song_num :: Int - -- , creator :: Creator - , banner :: String - , cover :: String - , id :: Int - , hot_songs :: [String] - } deriving (Eq, Show) - -instance FromJSON Channel where - parseJSON (Object v) = Channel <$> - v .: "intro" <*> - v .: "name" <*> - v .: "song_num" <*> - v .: "banner" <*> - v .: "cover" <*> - v .: "id" <*> - v .: "hot_songs" - parseJSON _ = mzero - - -pprChannels :: [Channel] -> IO () -pprChannels chs = - forM_ chs (\c -> do - setSGR [SetConsoleIntensity BoldIntensity] - putStr $ "* " ++ name c - setSGR [SetColor Foreground Vivid Green] - putStrLn $ " cid=" ++ show (id c) - setSGR [Reset] - let folding = foldr (\x acc -> - if x `elem` "\r\n" then ' ':acc else x:acc) [] - putStrLn $ " Intro: " ++ folding (intro c) - putStr " Hot songs: " - forM_ (hot_songs c) (\s -> putStr $ s ++ ", ") - putStrLn "" - ) - --- | Return a list of hot channels. -hot :: IO [Channel] -hot = search' rurl - where - rurl = "http://douban.fm/j/explore/hot_channels" - - --- | Return a list of up trending channels. -trending :: IO [Channel] -trending = search' rurl - where - rurl = "http://douban.fm/j/explore/up_trending_channels" - - --- | Return a list of channels matching provided keywords. -search :: String -> IO [Channel] -search [] = return [] -search key = search' rurl - where - rurl = "http://douban.fm/j/explore/search?query=" ++ - -- encodeString: encode chinese characters - C.unpack (urlEncode True (C.pack $ encodeString key)) - - -search' :: String -> IO [Channel] -search' rurl = do - req <- parseUrl rurl - (Object hm) <- withManager $ \manager -> do - res <- http req manager - responseBody res $$+- sinkParser json - - let (Object hm') = fromJust $ HM.lookup "data" hm - resData = fromJust $ HM.lookup "channels" hm' - channels = fromJSON resData :: Result [Channel] - case channels of - Success c -> return c - Error err -> putStrLn err >> print resData >> return [] - -douban :: String -> Radio.Param Douban -douban k - | isChId k = ChannelId $ read k - | aPattern `isPrefixOf` k = Album $ read $ init $ drop (length aPattern) k - | mPattern `isPrefixOf` k = MusicianId $ read $ init $ drop (length mPattern) k - | otherwise = MusicianName k - where - isChId = and . fmap isDigit - aPattern = "http://music.douban.com/subject/" - mPattern = "http://music.douban.com/musician/" diff --git a/Radio/EightTracks.hs b/Radio/EightTracks.hs deleted file mode 100644 --- a/Radio/EightTracks.hs +++ /dev/null @@ -1,264 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - --- | Module of http://8tracks.com --- API documentation: http://8tracks.com/developers/api_v3 -module Radio.EightTracks where - -import qualified Control.Exception as E -import Control.Monad (forM_, liftM) -import Control.Concurrent.MVar -import Data.Aeson -import Data.Aeson.Types (defaultOptions, Options(..)) -import qualified Data.ByteString.Char8 as C -import Data.Maybe (fromMaybe, fromJust) -import Data.CaseInsensitive (mk) -import Data.Char (isDigit) -import Data.Conduit (($$+-)) -import Data.Conduit.Attoparsec (sinkParser, ParseError) -import qualified Data.List as L -import GHC.Generics (Generic) -import Network.HTTP.Types -import Network.HTTP.Conduit -import Prelude hiding (id) -import System.Console.ANSI -import System.IO.Unsafe (unsafePerformIO) - -import Radio -import qualified Radio.EightTracks.Explore as Exp -import qualified Radio.EightTracks.User as U - - -running :: MVar () -running = unsafePerformIO newEmptyMVar - -apiKey :: String -apiKey = "1de30eb2b8fe85b1740cfbee3fdbb928e2c7249b" - -verHdr, keyHdr :: Header -verHdr = (mk "X-Api-Version", "3") -keyHdr = (mk "X-Api-Key", C.pack apiKey) - -type ETParam = Radio.Param EightTracks - --- | Response from http://8tracks.com/sets/new.json --- `play_token` is the value of interest -data PlaySession = PlaySession - { play_token :: String - , status :: String - , errors :: Maybe String - , notices :: Maybe String - , api_version :: Int - } deriving (Show, Generic) -instance FromJSON PlaySession - --- | Response from /play.json /next.json --- `track` is the value of interest -data PlayResponse = PlayResponse - { play_set :: MixSet - , play_status :: String - } deriving (Show, Generic) -instance FromJSON PlayResponse where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 5 } - -data MixSet = MixSet - { at_beginning :: Bool - , at_last_track :: Bool - , at_end :: Bool - , skip_allowed :: Bool - , track :: EightTracks - } deriving (Show, Generic) -instance FromJSON MixSet - -data EightTracks = EightTracks - { id :: Int - , track_file_stream_url :: String - , name :: String - , performer :: String - , release_name :: Maybe String - , url :: String - } deriving (Show, Generic) -instance FromJSON EightTracks - --- | Response from http://8tracks.com/mixes/14.json or --- http://8tracks.com/dp/electrominimalicious.json --- `info_mix` is the value of interest -data MixInfo = MixInfo - { info_mix :: Exp.Mix - , info_status :: String - } deriving (Show, Generic) -instance FromJSON MixInfo where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 5 } - -instance Radio.Radio EightTracks where - data Param EightTracks = Token - { userToken :: String - , userName :: String - , playToken :: Int - , mixId :: Int - } deriving (Show, Generic) - - parsePlaylist val = - case fromJSON val of - Success s -> [track $ play_set s] - Error err -> error $ "Parse playlist failed: " ++ show err - - -- Request play.json will record current mix to listening history. - -- Request next.json won't. - getPlaylist tok = E.catch - (do - justStarted <- isEmptyMVar running - rurl <- if justStarted - then do - putMVar running () - return $ "http://8tracks.com/sets/" ++ show (playToken tok) ++ "/play.json" - else - return $ "http://8tracks.com/sets/" ++ show (playToken tok) ++ "/next.json" - getPlaylist' rurl) - (\e -> do - -- When reached the last track in this mix. Play it again - print (e :: E.SomeException) - let rurl = "http://8tracks.com/sets/" ++ show (playToken tok) ++ "/play.json" - getPlaylist' rurl) - where - usrHdr = (mk "X-User-Token", C.pack $ userToken tok) - - getPlaylist' rurl = do - let query = [ ("mix_id", C.pack $ show $ mixId tok) ] - - initReq <- parseUrl rurl - let req = initReq { requestHeaders = [verHdr, keyHdr, usrHdr] - , queryString = renderSimpleQuery False query } - withManager $ \manager -> do - res <- http req manager - liftM Radio.parsePlaylist (responseBody res $$+- sinkParser json) - - songUrl _ x = return $ track_file_stream_url x - - songMeta x = Radio.SongMeta (performer x) - (fromMaybe "" $ release_name x) (name x) - - tagged _ = False - - reportRequired _ = True - - -- From api-doc: In order to be legal and pay royalties properly, - -- at 30 seconds, report song played - report tok x = do - initReq <- parseUrl rurl - let usrHdr = (mk "X-User-Token", C.pack $ userToken tok) - req = initReq { requestHeaders = [verHdr, keyHdr, usrHdr] - , queryString = renderSimpleQuery False query } - res <- withManager $ \manager -> httpLbs req manager - print $ responseBody res - where - rurl = "http://8tracks.com/sets/" ++ show (playToken tok) ++ "/report.json" - query = [ ("track_id", C.pack $ show $ id x) - , ("mix_id", C.pack $ show $ mixId tok) ] - -instance FromJSON ETParam -instance ToJSON ETParam - -instance NeedLogin EightTracks where - createSession strMixId email pwd = do - mId <- getMixId strMixId - initReq <- parseUrl rurl - let req = initReq { method = "POST" - , queryString = renderSimpleQuery False query - , requestHeaders = [verHdr] } - res <- withManager $ \manager -> httpLbs req manager - case eitherDecode $ responseBody res of - Right r -> do - pTok <- newPlayToken - return $ Just $ Token (U.user_token $ U.user r) - (U.login $ U.user r) pTok mId - Left err -> print err >> return Nothing - where - rurl = "http://8tracks.com/sessions.json" - query = [ ("login", C.pack email), ("password", C.pack pwd) ] - - data Config EightTracks = Config { eight :: ETParam } deriving Generic - - mkConfig = Config - - mkParam param key = param { mixId = read key } - -instance FromJSON (Radio.Config EightTracks) -instance ToJSON (Radio.Config EightTracks) - -newPlayToken :: IO Int -newPlayToken = do - res <- simpleHttp rurl - let ses = fromJust (decode res :: Maybe PlaySession) - return $ read $ play_token ses - where - rurl = "http://8tracks.com/sets/new.json?api_version=3&api_key=" ++ apiKey - -smartUrl :: String -> String -smartUrl smartId = - "http://8tracks.com/mix_sets/" ++ smartId ++ ".json?include=mixes" - -smartGet :: String -> IO [Exp.Mix] -smartGet smartId = get (smartUrl smartId) (Exp.mixes . Exp.mix_set) - -search :: String -> IO [Exp.Mix] -search [] = return [] -search key = smartGet $ "keyword:" ++ key - -featured, trending, newest :: IO [Exp.Mix] -featured = smartGet "collection:homepage" -trending = smartGet "all" -newest = smartGet "all:recent" - -pprMixes :: [Exp.Mix] -> IO () -pprMixes mixes = - forM_ mixes (\m -> do - setSGR [SetConsoleIntensity BoldIntensity] - putStr $ "* " ++ Exp.name m - setSGR [SetColor Foreground Vivid Green] - putStr $ " id=" ++ show (Exp.id m) - putStr $ " ▶" ++ show (Exp.plays_count m) - putStr $ " ♥" ++ show (Exp.likes_count m) - putStrLn $ " (" ++ show (Exp.tracks_count m) ++ " tracks)" - setSGR [Reset] - putStrLn $ " Description: " ++ - unlines (map (" " ++) (lines $ Exp.description m)) - putStrLn $ " Tags: " ++ Exp.tag_list_cache m - putStrLn "" - ) - -get :: FromJSON a => String -> (a -> b) -> IO b -get rurl selector = do - initReq <- parseUrl rurl - let req = initReq { requestHeaders = [verHdr, keyHdr] } - val <- E.catches - (withManager $ \manager -> do - res <- http req manager - responseBody res $$+- sinkParser json) - [ E.Handler (\e -> print (e :: ParseError) >> - error "The mix you are trying to access may be private.") - , E.Handler (\e -> case e of - (StatusCodeException s _ _) -> - error $ show s - otherException -> - error $ show otherException) - ] - - case fromJSON val of - Success v -> return $ selector v - Error err -> error err - -getMixId :: String -> IO Int -getMixId m - | isNumerical m = return $ read m - | otherwise = do - let mixUrl = if domain `L.isPrefixOf` m - then m - else (domain ++) - (if "/" `L.isPrefixOf` m then m else '/' : m) - get (mixUrl ++ ".json") (Exp.id . info_mix) - where - isNumerical = and . fmap isDigit - domain = "http://8tracks.com" diff --git a/Radio/EightTracks/Explore.hs b/Radio/EightTracks/Explore.hs deleted file mode 100644 --- a/Radio/EightTracks/Explore.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Radio.EightTracks.Explore where -import Data.Aeson (FromJSON) -import GHC.Generics (Generic) - -data Mix = Mix - { id :: Int - , path :: String - , web_path :: String - , name :: String - , description :: String - , plays_count :: Int - , likes_count :: Int - , tag_list_cache:: String - , duration :: Int - , tracks_count :: Int - } deriving (Show, Generic) - -instance FromJSON Mix - -data MixSet = MixSet - { mixes :: [Mix] - , smart_id :: String - , smart_type:: String - } deriving (Show, Generic) - -instance FromJSON MixSet - -data MixExplore = MixExplore - { mix_set :: MixSet - , status :: String - } deriving (Show, Generic) - -instance FromJSON MixExplore - diff --git a/Radio/EightTracks/User.hs b/Radio/EightTracks/User.hs deleted file mode 100644 --- a/Radio/EightTracks/User.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Radio.EightTracks.User where -import Data.Aeson (FromJSON) -import GHC.Generics (Generic) - -data User = User - { user_token:: String - , id :: Int - , login :: String - , web_path :: String - } deriving (Show, Generic) -instance FromJSON User - -data Session = Session - { user :: User - , status :: String - , errors :: Maybe String - , notices :: String - , logged_in :: Bool - , api_version :: Int - } deriving (Show, Generic) - -instance FromJSON Session - diff --git a/Radio/Jing.hs b/Radio/Jing.hs deleted file mode 100644 --- a/Radio/Jing.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} --- | Module of http://jing.fm --- It's a bit tricky to play jing.fm --- Notice the `play` function of **instance Radio** -module Radio.Jing where - -import Codec.Binary.UTF8.String (encodeString) -import Control.Applicative ((<$>), (<*>)) -import qualified Control.Exception as E -import Control.Monad (liftM, mzero) -import Data.Aeson -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as C -import qualified Data.HashMap.Strict as HM -import Data.Maybe (fromJust, fromMaybe) -import qualified Data.Text as T -import Data.CaseInsensitive (mk) -import Data.Conduit (runResourceT, ($$+-)) -import Data.Conduit.Attoparsec (sinkParser) -import GHC.Generics (Generic) -import Network.HTTP.Types -import Network.HTTP.Conduit - -import Radio - -type JingParam = Radio.Param Jing - -data Jing = Jing - { abid :: Int -- album id - , aid :: Int -- artist id - , an :: String -- album name - , atn :: String -- artist name - , d :: String - , fid :: String - , fs :: Int -- file size - , mid :: ByteString - , n :: String -- song name - , tid :: Int - --, y :: Bool - } deriving (Show, Generic) - -instance FromJSON Jing - -data Usr = Usr - { userid :: Int - , usernick :: ByteString - } deriving Show - -instance FromJSON Usr where - parseJSON (Object v) = Usr <$> - v .: "id" <*> - v .: "nick" - parseJSON _ = mzero - -instance Radio.Radio Jing where - data Param Jing = Token - { aToken :: ByteString - , rToken :: ByteString - , uid :: Int - , nick :: ByteString - , cmbt :: String - , highquality :: Bool - } deriving (Show, Generic) - - parsePlaylist (Object hm) = do - let songs = HM.lookup "result" hm >>= - \(Object hm') -> HM.lookup "items" hm' - case fromJSON $ fromMaybe Null songs of - Success s -> s - Error err -> error $ "Parse playlist failed: " ++ show err - parsePlaylist _ = error "Unrecognized playlist format." - - getPlaylist tok = do - let url = "http://jing.fm/api/v1/search/jing/fetch_pls" - query = [ ("q", C.pack $ encodeString $ cmbt tok) - , ("ps", "10") - , ("st", "0") - , ("u", C.pack $ show $ uid tok) - , ("tid", "0") - , ("mt", "") - , ("ss", "true") - ] - aHdr = (mk "Jing-A-Token-Header", aToken tok) :: Header - rHdr = (mk "Jing-R-Token-Header", rToken tok) :: Header - - initReq <- parseUrl url - let req = initReq { requestHeaders = [aHdr, rHdr] } - - -- urlEncodeBody adds a content-type request header and - -- changes the method to POST. - let req' = urlEncodedBody query req - withManager $ \manager -> do - res <- http req' manager - liftM Radio.parsePlaylist (responseBody res $$+- sinkParser json) - - songUrl tok x = E.catch - (do - let url = "http://jing.fm/api/v1/media/song/surl" - type_ = if highquality tok then "NO" else "MM" - query = [ ("type", Just type_) - , ("mid", Just $ mid x) - ] :: Query - aHdr = (mk "Jing-A-Token-Header", aToken tok) :: Header - rHdr = (mk "Jing-R-Token-Header", rToken tok) :: Header - - initReq <- parseUrl url - let req = initReq { method = "POST" - , requestHeaders = [aHdr, rHdr] - , queryString = renderQuery False query - } - (Object hm) <- withManager $ \manager -> do - res <- http req manager - responseBody res $$+- sinkParser json - let (String surl) = fromJust $ HM.lookup "result" hm - return $ T.unpack surl) - (\e -> print (e :: E.SomeException) >> Radio.songUrl tok x) - - songMeta x = Radio.SongMeta (atn x) (an x) (n x) - - -- Songs from jing.fm comes with tags! - tagged _ = True - -instance FromJSON JingParam -instance ToJSON JingParam - -instance NeedLogin Jing where - createSession keywords email pwd = do - let url = "http://jing.fm/api/v1/sessions/create" - query = [ ("email", C.pack email) , ("pwd", C.pack pwd) ] - req <- parseUrl url - let req' = urlEncodedBody query req - res <- withManager $ \manager -> http req' manager - let hmap = HM.fromList $ responseHeaders res - atoken = HM.lookup "Jing-A-Token-Header" hmap - rtoken = HM.lookup "Jing-R-Token-Header" hmap - parseToken :: Value -> Maybe JingParam - parseToken (Object hm) = do - let user = HM.lookup "result" hm >>= - \(Object hm') -> HM.lookup "usr" hm' - case fromJSON $ fromMaybe Null user of - Success u -> Token <$> atoken - <*> rtoken - <*> (Just $ userid u) - <*> (Just $ usernick u) - <*> Just keywords - <*> Just True - Error err -> error $ "Retrieve token failed: " ++ show err - parseToken _ = error "Unrecognized token format." - liftM parseToken (runResourceT $ responseBody res $$+- sinkParser json) - - data Config Jing = Config { jing :: JingParam } deriving Generic - - mkConfig = Config - - mkParam param key = param { cmbt = key } - -instance FromJSON (Radio.Config Jing) -instance ToJSON (Radio.Config Jing) diff --git a/Radio/Reddit.hs b/Radio/Reddit.hs deleted file mode 100644 --- a/Radio/Reddit.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} --- | Module of http://radioreddit.com -module Radio.Reddit where - -import Control.Monad (liftM) -import Data.Aeson -import Data.Conduit (($$+-)) -import Data.Conduit.Attoparsec (sinkParser) -import qualified Data.HashMap.Strict as HM -import Data.Maybe (fromMaybe) -import GHC.Generics (Generic) -import Network.HTTP.Conduit - -import qualified Radio - -data Reddit = Reddit - { title :: String - , artist :: String - , preview_url :: String - , download_url :: Maybe String - } deriving (Show, Generic) - -instance FromJSON Reddit - -instance Radio.Radio Reddit where - data Param Reddit = Genre String - - parsePlaylist (Object hm) = do - let songs = HM.lookup "songs" hm >>= - \(Object hm') -> HM.lookup "song" hm' - case fromJSON $ fromMaybe Null songs of - Success s -> s - Error err -> error $ "Parse playlist failed: " ++ show err - parsePlaylist _ = error "Unrecognized playlist format." - - getPlaylist (Genre g) = do - let url = "http://radioreddit.com/api/" ++ g ++ "/status.json" - req <- parseUrl url - withManager $ \manager -> do - res <- http req manager - liftM Radio.parsePlaylist (responseBody res $$+- sinkParser json) - - songUrl _ x = return $ fromMaybe (preview_url x) (download_url x) - - songMeta x = Radio.SongMeta (artist x) "" (title x) - - tagged _ = False - -genres :: IO [String] -genres = return - [ "main", "electronic", "rock", "metal" - , "indie", "hiphop", "random", "talk" ] - -pprGenres :: [String] -> IO () -pprGenres [] = return () -pprGenres gs = do - putStrLn $ foldr1 f (take 4 gs) - pprGenres $ drop 4 gs - where - f a b = a ++ concat (replicate (20 - length a) " ") ++ b diff --git a/Web/Radio.hs b/Web/Radio.hs new file mode 100644 --- /dev/null +++ b/Web/Radio.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +-- | A generic interface to online radio services +module Web.Radio + ( SongMeta(..) + , Radio(..) + , NeedLogin(..) + , getLordDir + , getPidFile + , getLogFile + , getStateFile + , writeLog + ) where + +import Codec.Binary.UTF8.String (encodeString) +import Control.Applicative ((<$>)) +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.MVar +import Control.Monad (liftM, when, void) +import Data.Aeson hiding (encode) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C +import Data.Maybe (isJust, fromJust) +import Data.Monoid ((<>)) +import Data.Yaml +import Network.MPD hiding (play, pause, Value) +import qualified Network.MPD as MPD +import Network.MPD.Core (getResponse) +import Network.Wai.Logger (ZonedDate, clockDateCacher) +import System.Directory (doesFileExist, getHomeDirectory) +import System.IO +import System.IO.Unsafe (unsafePerformIO) +import System.Log.FastLogger +import System.Process + + +eof :: MVar () +eof = unsafePerformIO newEmptyMVar + +data SongMeta = SongMeta + { artist :: String + , album :: String + , title :: String + } + +instance Show SongMeta where + show meta = artist meta ++ " - " ++ title meta + +class FromJSON a => Radio a where + data Param a :: * + + parsePlaylist :: Value -> [a] + + getPlaylist :: Param a -> IO [a] + + songUrl :: Param a -> a -> IO String + + songMeta :: a -> SongMeta + + tagged :: a -> Bool + + reportRequired :: a -> Bool + reportRequired _ = False + + report :: Param a -> a -> IO () + report _ _ = return () + + reportLoop :: Param a -> a -> IO () + reportLoop param x = do + time <- liftM stTime <$> withMPD status + case time of + Right (elapsed, _) -> + if elapsed < 30 + then threadDelay (5*1000000) >> reportLoop param x + else report param x + Left err -> print err + + play :: LoggerSet -> Param a -> [a] -> IO () + play logger reqData xxs = do + st <- withMPD status + case st of + Right _ -> playWithMPD logger reqData xxs + Left _ -> playWithMplayer logger reqData xxs + +-- MPD can play remote m4a files directly since version-0.18 +playWithMPD :: Radio a => LoggerSet -> Param a -> [a] -> IO () +playWithMPD logger reqData [] = + getPlaylist reqData >>= playWithMPD logger reqData +playWithMPD logger reqData (x:xs) = do + surl <- songUrl reqData x + print surl + when (surl /= "") $ do + logAndReport logger reqData x + mpdLoad $ Path $ C.pack surl + takeMVar eof -- Finished + playWithMPD logger reqData xs + where + mpdLoad :: Path -> IO () + mpdLoad path = do + withMPD $ do + clear + add path + withMPD $ MPD.play Nothing + + mpdTag $ songMeta x + mpdPlay + mpdPlay :: IO () + mpdPlay = do + st <- mpdState + if st == Right Stopped + then putMVar eof () + else mpdPlay + +playWithMplayer :: Radio a => LoggerSet -> Param a -> [a] -> IO () +playWithMplayer logger reqData [] = + getPlaylist reqData >>= playWithMplayer logger reqData +playWithMplayer logger reqData (x:xs) = do + surl <- songUrl reqData x + when (surl /= "") $ do + logAndReport logger reqData x + let sh = "mplayer -cache 2048 -cache-min 5 -novideo " ++ surl + void $ waitForProcess =<< runCommand sh + playWithMplayer logger reqData xs + +logAndReport :: Radio a => LoggerSet -> Param a -> a -> IO () +logAndReport logger reqData x = do + writeLog logger (show $ songMeta x) + getStateFile >>= flip writeFile (show $ songMeta x) + -- Report song played if needed + when (reportRequired x) $ void (forkIO $ reportLoop reqData x) + +mpdState :: IO (MPD.Response State) +mpdState = do + withMPD $ idle [PlayerS] + -- This will block until paused/finished. + + st <- liftM stState <$> withMPD status + print st + return st + +-- "addtagid" command is available since mpd-0.19 +mpdTag :: SongMeta -> IO () +mpdTag meta = void $ withMPD $ do + cs <- currentSong + when (isJust cs) $ do + let (Id sid) = fromJust $ sgId $ fromJust cs + void $ do + addTag sid arTag + addTag sid alTag + addTag sid tiTag + where + addTag sid tag = getResponse $ "addtagid " ++ show sid ++ tag + arTag = " artist \"" ++ artist meta ++ "\"" + alTag = " album \"" ++ album meta ++ "\"" + tiTag = " title \"" ++ title meta ++ "\"" + +class (Radio a, ToJSON (Param a), ToJSON (Config a)) => NeedLogin a where + login :: String -> IO (Param a) + login keywords = do + hSetBuffering stdout NoBuffering + hSetEcho stdin True + putStrLn "Please Log in" + putStr "Email: " + email <- getLine + putStr "Password: " + hSetEcho stdin False + pwd <- getLine + hSetEcho stdin True + putStrLn "" + mtoken <- createSession keywords email pwd + case mtoken of + Just tok -> do + saveToken tok + return tok + Nothing -> do + putStrLn "ERROR: Invalid email or password!" + login keywords + + createSession :: String -> String -> String -> IO (Maybe (Param a)) + + data Config a :: * + + mkConfig :: Param a -> Config a + + saveToken :: Param a -> IO () + saveToken tok = do + home <- getLordDir + let yml = home ++ "/lord.yml" + exist <- doesFileExist yml + bs <- if exist + then B.readFile yml + else return "" + let config = mkConfig tok + B.writeFile yml $ B.append bs (encode config) + putStrLn $ "Your token has been saved to " ++ yml + + mkParam :: Param a -> String -> Param a + + readToken :: FromJSON (Config a) + => (Config a -> Param a) -> String -> IO (Maybe (Param a)) + readToken selector keywords = do + home <- getLordDir + let yml = home ++ "/lord.yml" + exist <- doesFileExist yml + if exist + then do + conf <- decodeFile yml + case conf of + Nothing -> error $ "Invalid YAML file: " ++ show conf + Just c -> + case fromJSON c of + Success tok -> return $ Just $ + mkParam (selector tok) keywords + Error err -> do + print $ "Parse token failed: " ++ show err + return Nothing + else return Nothing + +getLordDir :: IO FilePath +getLordDir = (++ "/.lord") <$> getHomeDirectory + +getPidFile :: IO FilePath +getPidFile = (++ "/lord.pid") <$> getLordDir + +getLogFile :: IO FilePath +getLogFile = (++ "/lord.log") <$> getLordDir + +getStateFile :: IO FilePath +getStateFile = (++ "/lordstate") <$> getLordDir + +formatLogMessage :: IO ZonedDate -> String -> IO LogStr +formatLogMessage getdate msg = do + now <- getdate + return $ toLogStr now <> " : " <> toLogStr (encodeString msg) <> "\n" + +writeLog :: LoggerSet -> String -> IO () +writeLog l msg = do + (loggerDate, _) <- clockDateCacher + formatLogMessage loggerDate msg >>= pushLogStr l diff --git a/Web/Radio/Cmd.hs b/Web/Radio/Cmd.hs new file mode 100644 --- /dev/null +++ b/Web/Radio/Cmd.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +-- | Module for interfacing +module Web.Radio.Cmd where + +import qualified Control.Exception as E +import Control.Monad (liftM) +import Data.Aeson +import qualified Data.ByteString.Char8 as C +import Data.Conduit (($$+-)) +import Data.Conduit.Attoparsec (sinkParser) +import qualified Data.HashMap.Strict as HM +import GHC.Generics (Generic) +import Network.HTTP.Conduit +import Network.HTTP.Types (renderQuery) +import Network.HTTP.Types.Header (hLocation) +import Network.HTTP.Types.Status (status302) + +import qualified Web.Radio as Radio + + +data Cmd = Cmd + { sc_id :: Int + , title :: String + , artwork_url :: String + , description :: String + , duration :: Int + --, genre :: String + , tag_list :: String + , waveform_url :: String + , stream_url :: String + --, last_listened :: Int + , main_type :: String + --, created_at :: String + --, updated_at :: String + } deriving (Show, Generic) + +instance FromJSON Cmd + +instance Radio.Radio Cmd where + data Param Cmd = Genre String + + parsePlaylist val = + case fromJSON val of + Success s -> s + Error err -> error $ "Parse playlist failed: " ++ show err + + getPlaylist (Genre g) = do + let url = "http://cmd.fm/api/tracks/search" + query = [ ("genre", Just $ C.pack g) + , ("limit", Just $ C.pack "10") ] + initReq <- parseUrl url + let req = initReq { method = "GET" + , queryString = renderQuery False query + } + withManager $ \manager -> do + res <- http req manager + liftM Radio.parsePlaylist (responseBody res $$+- sinkParser json) + + songUrl _ x = do + initReq <- parseUrl url + let req = initReq { method = "GET" + , queryString = renderQuery False query + } + E.catch (withManager $ \manager -> + httpLbs req { redirectCount = 0 } manager >> return "") + (\e -> case e of + (StatusCodeException s hdr _) -> + if s == status302 then redirect hdr + else return "" + otherException -> print otherException >> return "" + ) + where + url = stream_url x + query = [("client_id", Just $ C.pack "2b659ea66970555922d89ce9c07b2d0d")] + redirect hdr = case HM.lookup hLocation $ HM.fromList hdr of + Just u -> return $ C.unpack u + Nothing -> return "" + + songMeta x = Radio.SongMeta "" "" (title x) + + tagged _ = False + +-- Currently, no api is provided to retrieve genre list. +genres :: IO [String] +genres = return + ["80s","Abstract","Acid Jazz","Acoustic" + ,"Acoustic Rock","Alternative","Ambient","Avantgarde" + ,"Ballads","Blues","Blues Rock","Breakbeats" + ,"Chillout","Chiptunes","Choir","Classic Rock" + ,"Classical","Classical Guitar","Contemporary","Dance" + ,"Dancehall","Death Metal","Dirty South","Disco" + ,"Dream Pop","Drum & Bass","Dub","Dubstep" + ,"Easy Listening","Electro House","Electronic","Electronic Pop" + ,"Electronic Rock","Folk Rock","Funk","Glitch" + ,"Grime","Grindcore","Grunge","Hard Rock", + "Hardcore","Heavy Metal","Hip-Hop","House" + ,"Indie","Indie Pop","Industrial Metal","Instrumental" + ,"Instrumental Rock","J-Pop","Jazz","Jazz Funk" + ,"Jazz Fusion","K-Pop","Latin Jazz","Metalcore" + ,"Minimal","Modern Jazz","Moombahton","New Wave" + ,"Nu Jazz","Opera","Orchestral","Piano" + ,"Pop","Post Hardcore","Post Rock","Progressive House" + ,"Progressive Metal","Progressive Rock","Punk" + ,"R&B","Rap","Reggae","Reggaeton","Riddim" + ,"Rock","Rock 'n' Roll","Shoegaze","Singer / Songwriter" + ,"Smooth Jazz","Soul","Synth Pop","Tech House" + ,"Techno","Thrash Metal","Trance","Trap" + ,"Trip-hop","Turntablism","Underground"] + +pprGenres :: [String] -> IO () +pprGenres [] = return () +pprGenres gs = do + putStrLn $ foldr1 f (take 4 gs) + pprGenres $ drop 4 gs + where + f a b = a ++ concat (replicate (20 - length a) " ") ++ b diff --git a/Web/Radio/Douban.hs b/Web/Radio/Douban.hs new file mode 100644 --- /dev/null +++ b/Web/Radio/Douban.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +-- | Module for interfacing +module Web.Radio.Douban + ( Douban (..) + , Channel (..) + , douban + , hot + , trending + , search + , pprChannels + ) where + +import Codec.Binary.UTF8.String (encodeString) +import Control.Applicative ((<$>), (<*>)) +import Control.Monad +import Data.Aeson +import qualified Data.ByteString.Char8 as C +import Data.Char (isDigit) +import Data.Conduit (($$+-)) +import Data.Conduit.Attoparsec (sinkParser) +import qualified Data.HashMap.Strict as HM +import Data.List (isPrefixOf) +import Data.Maybe (fromJust, fromMaybe) +import qualified Data.Text as T +import Network.HTTP.Conduit +import Network.HTTP.Types (urlEncode, renderQuery, Query) +import Prelude hiding (id) +import System.Console.ANSI +import Text.HTML.DOM (parseLBS) +import Text.XML.Cursor + +import qualified Web.Radio as Radio + + +data Douban = Douban + { picture :: String + , albumtitle :: String + -- , company :: String + -- , rating_avg :: Float + -- , public_time :: String + , ssid :: Maybe String + , album :: String + -- , like :: Int + , artist :: String + , url :: String + , title :: String + , subtype :: String + -- , length :: Int + , sid :: String + , aid :: String + } deriving Show + +instance FromJSON Douban where + parseJSON (Object v) = Douban <$> + v .: "picture" <*> + v .: "albumtitle" <*> + v .:? "ssid" <*> + v .: "album" <*> + --v .: "like" <*> + v .: "artist" <*> + v .: "url" <*> + v .: "title" <*> + v .: "subtype" <*> + v .: "sid" <*> + v .: "aid" + parseJSON _ = mzero + + +getPlaylist' :: Query -> IO [Douban] +getPlaylist' query = do + let rurl = "http://douban.fm/j/mine/playlist" + initReq <- parseUrl rurl + let req = initReq { method = "GET" + , queryString = renderQuery False query + } + withManager $ \manager -> do + res <- http req manager + liftM Radio.parsePlaylist (responseBody res $$+- sinkParser json) + +musicianId :: String -> IO (Maybe String) +musicianId mname = do + let rurl = "http://music.douban.com/subject_search/?search_text=" ++ + C.unpack (urlEncode True (C.pack $ encodeString mname)) + rsp <- simpleHttp rurl + let cursor = fromDocument $ parseLBS rsp + href = cursor $// element "a" + >=> attributeIs "class" "ll musician_title " + &| attribute "href" + return $ Just $ filter isDigit $ T.unpack $ head $ head href + +albumPlayable :: Int -> IO Bool +albumPlayable aId = do + res <- simpleHttp $ aPattern ++ show aId + let cursor = fromDocument $ parseLBS res + start_radio = cursor $// element "div" + >=> attributeIs "class" "start_radio" + return $ not $ null start_radio + where + aPattern = "http://music.douban.com/subject/" + +mkQuery :: Int -> String -> Query +mkQuery cid context = + [ ("type", Just "n") + , ("channel", Just $ C.pack $ show cid) + , ("context", Just $ C.pack context) + , ("from", Just "lord") + ] + +instance Radio.Radio Douban where + data Param Douban = ChannelId Int + | Album Int + | MusicianId Int + | MusicianName String + + -- TODO: those without ssid filed are ads, filter them out! + parsePlaylist (Object hm) = do + let songs = HM.lookup "song" hm + case fromJSON $ fromMaybe Null songs of + Success s -> s + Error _ -> [] + parsePlaylist _ = error "Unrecognized playlist format." + + getPlaylist (ChannelId cid) = getPlaylist' $ mkQuery cid "" + getPlaylist (Album aId) = do + playable <- albumPlayable aId + if playable then getPlaylist' $ + mkQuery 0 $ "channel:0|subject_id:" ++ show aId + else error "This album can not be played." + getPlaylist (MusicianId mid) = + getPlaylist' $ mkQuery 0 $ "channel:0|musician_id:" ++ show mid + getPlaylist (MusicianName mname) = do + mmid <- musicianId mname + Radio.getPlaylist (MusicianId $ read $ fromJust mmid) + + songUrl _ x = return $ url x + + songMeta x = Radio.SongMeta (artist x) (albumtitle x) (title x) + + -- Songs from douban.fm comes with no tags! + tagged _ = False + +data Channel = Channel + { intro :: String + , name :: String + , song_num :: Int + -- , creator :: Creator + , banner :: String + , cover :: String + , id :: Int + , hot_songs :: [String] + } deriving (Eq, Show) + +instance FromJSON Channel where + parseJSON (Object v) = Channel <$> + v .: "intro" <*> + v .: "name" <*> + v .: "song_num" <*> + v .: "banner" <*> + v .: "cover" <*> + v .: "id" <*> + v .: "hot_songs" + parseJSON _ = mzero + + +pprChannels :: [Channel] -> IO () +pprChannels chs = + forM_ chs (\c -> do + setSGR [SetConsoleIntensity BoldIntensity] + putStr $ "* " ++ name c + setSGR [SetColor Foreground Vivid Green] + putStrLn $ " cid=" ++ show (id c) + setSGR [Reset] + let folding = foldr (\x acc -> + if x `elem` "\r\n" then ' ':acc else x:acc) [] + putStrLn $ " Intro: " ++ folding (intro c) + putStr " Hot songs: " + forM_ (hot_songs c) (\s -> putStr $ s ++ ", ") + putStrLn "" + ) + +-- | Return a list of hot channels. +hot :: IO [Channel] +hot = search' rurl + where + rurl = "http://douban.fm/j/explore/hot_channels" + + +-- | Return a list of up trending channels. +trending :: IO [Channel] +trending = search' rurl + where + rurl = "http://douban.fm/j/explore/up_trending_channels" + + +-- | Return a list of channels matching provided keywords. +search :: String -> IO [Channel] +search [] = return [] +search key = search' rurl + where + rurl = "http://douban.fm/j/explore/search?query=" ++ + -- encodeString: encode chinese characters + C.unpack (urlEncode True (C.pack $ encodeString key)) + + +search' :: String -> IO [Channel] +search' rurl = do + req <- parseUrl rurl + (Object hm) <- withManager $ \manager -> do + res <- http req manager + responseBody res $$+- sinkParser json + + let (Object hm') = fromJust $ HM.lookup "data" hm + resData = fromJust $ HM.lookup "channels" hm' + channels = fromJSON resData :: Result [Channel] + case channels of + Success c -> return c + Error err -> putStrLn err >> print resData >> return [] + +douban :: String -> Radio.Param Douban +douban k + | isChId k = ChannelId $ read k + | aPattern `isPrefixOf` k = Album $ read $ init $ drop (length aPattern) k + | mPattern `isPrefixOf` k = MusicianId $ read $ init $ drop (length mPattern) k + | otherwise = MusicianName k + where + isChId = and . fmap isDigit + aPattern = "http://music.douban.com/subject/" + mPattern = "http://music.douban.com/musician/" diff --git a/Web/Radio/EightTracks.hs b/Web/Radio/EightTracks.hs new file mode 100644 --- /dev/null +++ b/Web/Radio/EightTracks.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Module for interfacing +-- +-- API documentation: +module Web.Radio.EightTracks + ( EightTracks (..) + , PlaySession (..) + , PlayResponse (..) + , MixSet (..) + , MixInfo (..) + , getMixId + , featured + , newest + , trending + , search + , pprMixes + , ETParam + , eight + , userName + ) where + +import qualified Control.Exception as E +import Control.Monad (forM_, liftM) +import Control.Concurrent.MVar +import Data.Aeson +import Data.Aeson.Types (defaultOptions, Options(..)) +import qualified Data.ByteString.Char8 as C +import Data.Maybe (fromMaybe, fromJust) +import Data.CaseInsensitive (mk) +import Data.Char (isDigit) +import Data.Conduit (($$+-)) +import Data.Conduit.Attoparsec (sinkParser, ParseError) +import qualified Data.List as L +import GHC.Generics (Generic) +import Network.HTTP.Types +import Network.HTTP.Conduit +import Prelude hiding (id) +import System.Console.ANSI +import System.IO.Unsafe (unsafePerformIO) + +import Web.Radio +import qualified Web.Radio.EightTracks.Explore as Exp +import qualified Web.Radio.EightTracks.User as U + + +running :: MVar () +running = unsafePerformIO newEmptyMVar + +apiKey :: String +apiKey = "1de30eb2b8fe85b1740cfbee3fdbb928e2c7249b" + +verHdr, keyHdr :: Header +verHdr = (mk "X-Api-Version", "3") +keyHdr = (mk "X-Api-Key", C.pack apiKey) + +type ETParam = Param EightTracks + +-- | Response from http://8tracks.com/sets/new.json +-- `play_token` is the value of interest +data PlaySession = PlaySession + { play_token :: String + , status :: String + , errors :: Maybe String + , notices :: Maybe String + , api_version :: Int + } deriving (Show, Generic) +instance FromJSON PlaySession + +-- | Response from /play.json /next.json +-- `track` is the value of interest +data PlayResponse = PlayResponse + { play_set :: MixSet + , play_status :: String + } deriving (Show, Generic) +instance FromJSON PlayResponse where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 5 } + +data MixSet = MixSet + { at_beginning :: Bool + , at_last_track :: Bool + , at_end :: Bool + , skip_allowed :: Bool + , track :: EightTracks + } deriving (Show, Generic) +instance FromJSON MixSet + +data EightTracks = EightTracks + { id :: Int + , track_file_stream_url :: String + , name :: String + , performer :: String + , release_name :: Maybe String + , url :: String + } deriving (Show, Generic) +instance FromJSON EightTracks + +-- | Response from http://8tracks.com/mixes/14.json or +-- http://8tracks.com/dp/electrominimalicious.json +-- `info_mix` is the value of interest +data MixInfo = MixInfo + { info_mix :: Exp.Mix + , info_status :: String + } deriving (Show, Generic) +instance FromJSON MixInfo where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 5 } + +instance Radio EightTracks where + data Param EightTracks = Token + { userToken :: String + , userName :: String + , playToken :: Int + , mixId :: Int + } deriving (Show, Generic) + + parsePlaylist val = + case fromJSON val of + Success s -> [track $ play_set s] + Error err -> error $ "Parse playlist failed: " ++ show err + + -- Request play.json will record current mix to listening history. + -- Request next.json won't. + getPlaylist tok = E.catch + (do + justStarted <- isEmptyMVar running + rurl <- if justStarted + then do + putMVar running () + return $ "http://8tracks.com/sets/" ++ show (playToken tok) ++ "/play.json" + else + return $ "http://8tracks.com/sets/" ++ show (playToken tok) ++ "/next.json" + getPlaylist' rurl) + (\e -> do + -- When reached the last track in this mix. Play it again + print (e :: E.SomeException) + let rurl = "http://8tracks.com/sets/" ++ show (playToken tok) ++ "/play.json" + getPlaylist' rurl) + where + usrHdr = (mk "X-User-Token", C.pack $ userToken tok) + + getPlaylist' rurl = do + let query = [ ("mix_id", C.pack $ show $ mixId tok) ] + + initReq <- parseUrl rurl + let req = initReq { requestHeaders = [verHdr, keyHdr, usrHdr] + , queryString = renderSimpleQuery False query } + withManager $ \manager -> do + res <- http req manager + liftM parsePlaylist (responseBody res $$+- sinkParser json) + + songUrl _ x = return $ track_file_stream_url x + + songMeta x = SongMeta (performer x) + (fromMaybe "" $ release_name x) (name x) + + tagged _ = False + + reportRequired _ = True + + -- From api-doc: In order to be legal and pay royalties properly, + -- at 30 seconds, report song played + report tok x = do + initReq <- parseUrl rurl + let usrHdr = (mk "X-User-Token", C.pack $ userToken tok) + req = initReq { requestHeaders = [verHdr, keyHdr, usrHdr] + , queryString = renderSimpleQuery False query } + res <- withManager $ \manager -> httpLbs req manager + print $ responseBody res + where + rurl = "http://8tracks.com/sets/" ++ show (playToken tok) ++ "/report.json" + query = [ ("track_id", C.pack $ show $ id x) + , ("mix_id", C.pack $ show $ mixId tok) ] + +instance FromJSON ETParam +instance ToJSON ETParam + +instance NeedLogin EightTracks where + createSession strMixId email pwd = do + mId <- getMixId strMixId + initReq <- parseUrl rurl + let req = initReq { method = "POST" + , queryString = renderSimpleQuery False query + , requestHeaders = [verHdr] } + res <- withManager $ \manager -> httpLbs req manager + case eitherDecode $ responseBody res of + Right r -> do + pTok <- newPlayToken + return $ Just $ Token (U.user_token $ U.user r) + (U.login $ U.user r) pTok mId + Left err -> print err >> return Nothing + where + rurl = "http://8tracks.com/sessions.json" + query = [ ("login", C.pack email), ("password", C.pack pwd) ] + + data Config EightTracks = Config { eight :: ETParam } deriving Generic + + mkConfig = Config + + mkParam param key = param { mixId = read key } + +instance FromJSON (Config EightTracks) +instance ToJSON (Config EightTracks) + +newPlayToken :: IO Int +newPlayToken = do + res <- simpleHttp rurl + let ses = fromJust (decode res :: Maybe PlaySession) + return $ read $ play_token ses + where + rurl = "http://8tracks.com/sets/new.json?api_version=3&api_key=" ++ apiKey + +smartUrl :: String -> String +smartUrl smartId = + "http://8tracks.com/mix_sets/" ++ smartId ++ ".json?include=mixes" + +smartGet :: String -> IO [Exp.Mix] +smartGet smartId = get (smartUrl smartId) (Exp.mixes . Exp.mix_set) + +search :: String -> IO [Exp.Mix] +search [] = return [] +search key = smartGet $ "keyword:" ++ key + +featured, trending, newest :: IO [Exp.Mix] +featured = smartGet "collection:homepage" +trending = smartGet "all" +newest = smartGet "all:recent" + +pprMixes :: [Exp.Mix] -> IO () +pprMixes mixes = + forM_ mixes (\m -> do + setSGR [SetConsoleIntensity BoldIntensity] + putStr $ "* " ++ Exp.name m + setSGR [SetColor Foreground Vivid Green] + putStr $ " id=" ++ show (Exp.id m) + putStr $ " ▶" ++ show (Exp.plays_count m) + putStr $ " ♥" ++ show (Exp.likes_count m) + putStrLn $ " (" ++ show (Exp.tracks_count m) ++ " tracks)" + setSGR [Reset] + putStrLn $ " Description: " ++ + unlines (map (" " ++) (lines $ Exp.description m)) + putStrLn $ " Tags: " ++ Exp.tag_list_cache m + putStrLn "" + ) + +get :: FromJSON a => String -> (a -> b) -> IO b +get rurl selector = do + initReq <- parseUrl rurl + let req = initReq { requestHeaders = [verHdr, keyHdr] } + val <- E.catches + (withManager $ \manager -> do + res <- http req manager + responseBody res $$+- sinkParser json) + [ E.Handler (\e -> print (e :: ParseError) >> + error "The mix you are trying to access may be private.") + , E.Handler (\e -> case e of + (StatusCodeException s _ _) -> + error $ show s + otherException -> + error $ show otherException) + ] + + case fromJSON val of + Success v -> return $ selector v + Error err -> error err + +getMixId :: String -> IO Int +getMixId m + | isNumerical m = return $ read m + | otherwise = do + let mixUrl = if domain `L.isPrefixOf` m + then m + else (domain ++) + (if "/" `L.isPrefixOf` m then m else '/' : m) + get (mixUrl ++ ".json") (Exp.id . info_mix) + where + isNumerical = and . fmap isDigit + domain = "http://8tracks.com" diff --git a/Web/Radio/EightTracks/Explore.hs b/Web/Radio/EightTracks/Explore.hs new file mode 100644 --- /dev/null +++ b/Web/Radio/EightTracks/Explore.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Web.Radio.EightTracks.Explore where +import Data.Aeson (FromJSON) +import GHC.Generics (Generic) + +data Mix = Mix + { id :: Int + , path :: String + , web_path :: String + , name :: String + , description :: String + , plays_count :: Int + , likes_count :: Int + , tag_list_cache:: String + , duration :: Int + , tracks_count :: Int + } deriving (Show, Generic) + +instance FromJSON Mix + +data MixSet = MixSet + { mixes :: [Mix] + , smart_id :: String + , smart_type:: String + } deriving (Show, Generic) + +instance FromJSON MixSet + +data MixExplore = MixExplore + { mix_set :: MixSet + , status :: String + } deriving (Show, Generic) + +instance FromJSON MixExplore + diff --git a/Web/Radio/EightTracks/User.hs b/Web/Radio/EightTracks/User.hs new file mode 100644 --- /dev/null +++ b/Web/Radio/EightTracks/User.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Web.Radio.EightTracks.User where +import Data.Aeson (FromJSON) +import GHC.Generics (Generic) + +data User = User + { user_token:: String + , id :: Int + , login :: String + , web_path :: String + } deriving (Show, Generic) +instance FromJSON User + +data Session = Session + { user :: User + , status :: String + , errors :: Maybe String + , notices :: String + , logged_in :: Bool + , api_version :: Int + } deriving (Show, Generic) + +instance FromJSON Session + diff --git a/Web/Radio/Jing.hs b/Web/Radio/Jing.hs new file mode 100644 --- /dev/null +++ b/Web/Radio/Jing.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +-- | Module for interfacing +module Web.Radio.Jing + ( Jing (..) + , JingParam + , jing + , nick + ) where + +import Codec.Binary.UTF8.String (encodeString) +import Control.Applicative ((<$>), (<*>)) +import qualified Control.Exception as E +import Control.Monad (liftM, mzero) +import Data.Aeson +import qualified Data.ByteString.Char8 as C +import qualified Data.HashMap.Strict as HM +import Data.Maybe (fromJust, fromMaybe) +import qualified Data.Text as T +import Data.CaseInsensitive (mk) +import Data.Conduit (runResourceT, ($$+-)) +import Data.Conduit.Attoparsec (sinkParser) +import GHC.Generics (Generic) +import Network.HTTP.Types +import Network.HTTP.Conduit + +import Web.Radio + +type JingParam = Param Jing + +data Jing = Jing + { abid :: Int -- album id + , aid :: Int -- artist id + , an :: String -- album name + , atn :: String -- artist name + , d :: String + , fid :: String + , fs :: Int -- file size + , mid :: String + , n :: String -- song name + , tid :: Int + --, y :: Bool + } deriving (Show, Generic) + +instance FromJSON Jing + +data Usr = Usr + { userid :: Int + , usernick :: String + } deriving Show + +instance FromJSON Usr where + parseJSON (Object v) = Usr <$> + v .: "id" <*> + v .: "nick" + parseJSON _ = mzero + +instance Radio Jing where + data Param Jing = Token + { aToken :: String + , rToken :: String + , uid :: Int + , nick :: String + , cmbt :: String + , highquality :: Bool + } deriving (Show, Generic) + + parsePlaylist (Object hm) = do + let songs = HM.lookup "result" hm >>= + \(Object hm') -> HM.lookup "items" hm' + case fromJSON $ fromMaybe Null songs of + Success s -> if null s then error "Nothing found. Please try other keywords." + else s + Error err -> error $ "Parse playlist failed: " ++ show err + ++ "\nYour token may have expired. Delete ~/.lord/lord.yml to relogin." + parsePlaylist _ = error "Unrecognized playlist format." + + getPlaylist tok = do + let url = "http://jing.fm/api/v1/search/jing/fetch_pls" + query = [ ("q", C.pack $ encodeString $ cmbt tok) + , ("ps", "10") + , ("st", "0") + , ("u", C.pack $ show $ uid tok) + , ("tid", "0") + , ("mt", "") + , ("ss", "true") + ] + aHdr = (mk "Jing-A-Token-Header", C.pack $ aToken tok) :: Header + rHdr = (mk "Jing-R-Token-Header", C.pack $ rToken tok) :: Header + + initReq <- parseUrl url + let req = initReq { requestHeaders = [aHdr, rHdr] } + + -- urlEncodeBody adds a content-type request header and + -- changes the method to POST. + let req' = urlEncodedBody query req + withManager $ \manager -> do + res <- http req' manager + liftM parsePlaylist (responseBody res $$+- sinkParser json) + + songUrl tok x = E.catch + (do + let url = "http://jing.fm/api/v1/media/song/surl" + type_ = if highquality tok then "NO" else "MM" + query = [ ("type", Just type_) + , ("mid", Just $ C.pack $ mid x) + ] :: Query + aHdr = (mk "Jing-A-Token-Header", C.pack $ aToken tok) :: Header + rHdr = (mk "Jing-R-Token-Header", C.pack $ rToken tok) :: Header + + initReq <- parseUrl url + let req = initReq { method = "POST" + , requestHeaders = [aHdr, rHdr] + , queryString = renderQuery False query + } + (Object hm) <- withManager $ \manager -> do + res <- http req manager + responseBody res $$+- sinkParser json + let (String surl) = fromJust $ HM.lookup "result" hm + return $ T.unpack surl) + (\e -> print (e :: E.SomeException) >> songUrl tok x) + + songMeta x = SongMeta (atn x) (an x) (n x) + + -- Songs from jing.fm comes with tags! + tagged _ = True + +instance FromJSON JingParam +instance ToJSON JingParam + +instance NeedLogin Jing where + createSession keywords email pwd = do + let url = "http://jing.fm/api/v1/sessions/create" + query = [ ("email", C.pack email) , ("pwd", C.pack pwd) ] + req <- parseUrl url + let req' = urlEncodedBody query req + res <- withManager $ \manager -> http req' manager + let hmap = HM.fromList $ responseHeaders res + atoken = HM.lookup "Jing-A-Token-Header" hmap + rtoken = HM.lookup "Jing-R-Token-Header" hmap + parseToken :: Value -> Maybe JingParam + parseToken (Object hm) = do + let user = HM.lookup "result" hm >>= + \(Object hm') -> HM.lookup "usr" hm' + case fromJSON $ fromMaybe Null user of + Success u -> Token <$> fmap C.unpack atoken + <*> fmap C.unpack rtoken + <*> (Just $ userid u) + <*> (Just $ usernick u) + <*> Just keywords + <*> Just True + Error err -> error $ "Retrieve token failed: " ++ show err + parseToken _ = error "Unrecognized token format." + liftM parseToken (runResourceT $ responseBody res $$+- sinkParser json) + + data Config Jing = Config { jing :: JingParam } deriving Generic + + mkConfig = Config + + mkParam param key = param { cmbt = key } + +instance FromJSON (Config Jing) +instance ToJSON (Config Jing) diff --git a/Web/Radio/Reddit.hs b/Web/Radio/Reddit.hs new file mode 100644 --- /dev/null +++ b/Web/Radio/Reddit.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +-- | Module for interfacing +module Web.Radio.Reddit where + +import Control.Monad (liftM) +import Data.Aeson +import Data.Conduit (($$+-)) +import Data.Conduit.Attoparsec (sinkParser) +import qualified Data.HashMap.Strict as HM +import Data.Maybe (fromMaybe) +import GHC.Generics (Generic) +import Network.HTTP.Conduit + +import qualified Web.Radio as Radio + +data Reddit = Reddit + { title :: String + , artist :: String + , preview_url :: String + , download_url :: Maybe String + } deriving (Show, Generic) + +instance FromJSON Reddit + +instance Radio.Radio Reddit where + data Param Reddit = Genre String + + parsePlaylist (Object hm) = do + let songs = HM.lookup "songs" hm >>= + \(Object hm') -> HM.lookup "song" hm' + case fromJSON $ fromMaybe Null songs of + Success s -> s + Error err -> error $ "Parse playlist failed: " ++ show err + parsePlaylist _ = error "Unrecognized playlist format." + + getPlaylist (Genre g) = do + let url = "http://radioreddit.com/api/" ++ g ++ "/status.json" + req <- parseUrl url + withManager $ \manager -> do + res <- http req manager + liftM Radio.parsePlaylist (responseBody res $$+- sinkParser json) + + songUrl _ x = return $ fromMaybe (preview_url x) (download_url x) + + songMeta x = Radio.SongMeta (artist x) "" (title x) + + tagged _ = False + +genres :: IO [String] +genres = return + [ "main", "electronic", "rock", "metal" + , "indie", "hiphop", "random", "talk" ] + +pprGenres :: [String] -> IO () +pprGenres [] = return () +pprGenres gs = do + putStrLn $ foldr1 f (take 4 gs) + pprGenres $ drop 4 gs + where + f a b = a ++ concat (replicate (20 - length a) " ") ++ b diff --git a/bash_completion.d/lord b/bash_completion.d/lord new file mode 100644 --- /dev/null +++ b/bash_completion.d/lord @@ -0,0 +1,13 @@ +_lord() +{ + local cmdline + CMDLINE=(--bash-completion-index $COMP_CWORD) + + for arg in ${COMP_WORDS[@]}; do + CMDLINE=(${CMDLINE[@]} --bash-completion-word $arg) + done + + COMPREPLY=( $(/home/rnons/.cabal/bin/lord "${CMDLINE[@]}") ) +} + +complete -o filenames -F _lord lord diff --git a/lord.cabal b/lord.cabal --- a/lord.cabal +++ b/lord.cabal @@ -1,5 +1,5 @@ name: lord -version: 2.20131220 +version: 2.20140323 synopsis: A command line interface to online radios. description: A unified command line interface to several online radios, use mpd () as backend by default. Will fallback to mplayer () when mpd is unavailable. @@ -48,22 +48,50 @@ build-type: Simple cabal-version: >=1.10 tested-with: GHC == 7.6.3 -Extra-Source-Files: CHANGELOG +data-files: bash_completion.d/lord +extra-source-files: CHANGELOG source-repository head type: git location: git://github.com/rnons/lord.git +library + build-depends: base >= 4 && < 5, + aeson >= 0.7, + ansi-terminal >= 0.6, + attoparsec-conduit >= 1.0, + bytestring >= 0.9, + case-insensitive >= 1.0, + conduit >= 1.0, + data-default >= 0.5, + directory >= 1.1, + fast-logger >= 2.0, + html-conduit >= 1.1, + http-conduit >= 1.9, + http-types >= 0.8, + libmpd >= 0.8, + process >= 1.1, + text >= 0.11, + transformers >= 0.3, + unix >= 2.5, + unordered-containers >= 0.2, + wai-logger >= 2.0, + utf8-string >= 0.3, + xml-conduit >= 1.1, + yaml >= 0.8 + exposed-modules: Web.Radio + Web.Radio.Cmd, + Web.Radio.Douban, + Web.Radio.EightTracks, + Web.Radio.EightTracks.Explore, + Web.Radio.Jing, + Web.Radio.Reddit + other-modules: Web.Radio.EightTracks.User + ghc-options: -Wall -fno-warn-unused-do-bind + default-language: Haskell2010 + executable lord main-is: main.hs - other-modules: Radio, - Radio.Cmd, - Radio.Douban, - Radio.EightTracks, - Radio.EightTracks.Explore, - Radio.EightTracks.User, - Radio.Jing, - Radio.Reddit ghc-options: -Wall -fno-warn-unused-do-bind build-depends: base >= 4 && < 5, aeson >= 0.6, diff --git a/main.hs b/main.hs --- a/main.hs +++ b/main.hs @@ -1,7 +1,5 @@ import Control.Monad (void, when) -import qualified Data.ByteString.Char8 as C import Data.Default (def) -import GHC.IO.FD (openFile, stdout) import Network.MPD (withMPD, clear, status, stState) import Network.MPD.Commands.Extensions (toggle) import Options.Applicative @@ -9,21 +7,21 @@ import System.Directory (createDirectoryIfMissing) import System.Environment (getArgs, getProgName) import System.Exit (exitWith, exitSuccess, ExitCode(..)) -import System.IO ( IOMode(AppendMode) - , hPutStr, stderr, SeekMode(..) ) -import System.Log.FastLogger (newLoggerSet, defaultBufSize) +import System.IO (hPutStr, stderr, SeekMode(..)) +import System.Log.FastLogger ( newFileLoggerSet, newStdoutLoggerSet + , defaultBufSize ) import System.Posix.Daemon import System.Posix.Files (stdFileMode) import System.Posix.IO ( fdWrite, createFile, setLock , LockRequest(..) ) import System.Posix.Process (getProcessID) -import Radio -import qualified Radio.Cmd as Cmd -import Radio.Douban -import qualified Radio.EightTracks as ET -import Radio.Jing -import qualified Radio.Reddit as Reddit +import Web.Radio +import qualified Web.Radio.Cmd as Cmd +import Web.Radio.Douban +import qualified Web.Radio.EightTracks as ET +import Web.Radio.Jing +import qualified Web.Radio.Reddit as Reddit data Options = Options { optCommand :: Command @@ -216,7 +214,7 @@ putStrLn $ "Welcome back, " ++ ET.userName tok' listen nodaemon tok' _ -> do - param <- login k :: IO (Radio.Param ET.EightTracks) + param <- login k :: IO (Param ET.EightTracks) listen nodaemon param etSearch :: String -> IO () @@ -227,13 +225,13 @@ tok <- readToken jing k case tok of Just tok' -> do - putStrLn $ "Welcome back, " ++ C.unpack (nick tok') + putStrLn $ "Welcome back, " ++ nick tok' listen nodaemon tok' _ -> do - param <- login k :: IO (Radio.Param Jing) + param <- login k :: IO (Param Jing) listen nodaemon param -listen :: Radio a => Bool -> Radio.Param a -> IO () +listen :: Radio a => Bool -> Param a -> IO () listen nodaemon param = do -- mplayer backend won't work in daemon mode! st <- withMPD status @@ -244,11 +242,10 @@ return True pid <- getPidFile - logger <- if nodaemon' then newLoggerSet defaultBufSize stdout - else do + logger <- if nodaemon' then newStdoutLoggerSet defaultBufSize + else do fp <- getLogFile - (fd, _) <- openFile fp AppendMode True - newLoggerSet defaultBufSize fd + newFileLoggerSet defaultBufSize fp let listen' = play logger param [] running <- isRunning pid when running $ killAndWait pid diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -3,12 +3,12 @@ import Test.Hspec import Test.HUnit -import Radio -import qualified Radio.Cmd as Cmd -import Radio.EightTracks -import Radio.Douban -import Radio.Jing -import qualified Radio.Reddit as Reddit +import Web.Radio (getPlaylist, readToken) +import qualified Web.Radio.Cmd as Cmd +import Web.Radio.EightTracks +import Web.Radio.Douban +import Web.Radio.Jing +import qualified Web.Radio.Reddit as Reddit main :: IO () @@ -26,15 +26,15 @@ it "douban: given album url" $ do ss <- getPlaylist $ douban "http://music.douban.com/subject/3044758/" - assertNotNull ss + assert $ albumtitle (head ss) == "變形記" it "douban: given musician url" $ do ss <- getPlaylist $ douban "http://music.douban.com/musician/104585/" - assertNotNull ss + assert $ artist (head ss) == "万能青年旅店" it "douban: given musician name" $ do - ss <- getPlaylist $ douban "Sigur RóS" - assertNotNull ss + ss <- getPlaylist $ douban "Sigur Rós" + assert $ artist (head ss) == "Sigur Rós" it "8tracks: given mix id" $ do tok <- readToken eight "14"