lord 1.20131124 → 1.20131130
raw patch · 9 files changed
+594/−189 lines, 9 files
Files
- Radio.hs +155/−21
- Radio/Douban.hs +17/−17
- Radio/EightTracks.hs +232/−0
- Radio/EightTracks/Explore.hs +32/−0
- Radio/EightTracks/User.hs +25/−0
- Radio/Jing.hs +46/−140
- lord.cabal +39/−7
- main.hs +39/−1
- test/main.hs +9/−3
Radio.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -5,6 +6,7 @@ module Radio ( SongMeta(..) , Radio(..)+ , NeedLogin(..) , getLordDir , getPidFile , getLogFile@@ -14,16 +16,24 @@ import Codec.Binary.UTF8.String (encodeString) import Control.Applicative ((<$>))+import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.MVar-import Control.Monad (when)-import Data.Aeson (FromJSON, Value)+import qualified Control.Exception as E+import Control.Monad (liftM, when, void)+import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C+import Data.Conduit (runResourceT, ($$+-))+import Data.Conduit.Binary (sinkFile)+import Data.Yaml+import Network.HTTP.Conduit hiding (path) import Network.MPD hiding (play, Value) import qualified Network.MPD as MPD-import System.Directory (getHomeDirectory)+import System.Directory (doesFileExist, getHomeDirectory)+import System.IO import System.IO.Unsafe (unsafePerformIO) import System.Log.FastLogger +eof :: MVar () eof = unsafePerformIO newEmptyMVar data SongMeta = SongMeta @@ -45,38 +55,162 @@ tagged :: a -> Bool + -- Mpd can play remote mp3 files directly.+ -- For m4a files, lord download it as ~/.lord/lord.m4a+ playable :: a -> Bool+ playable _ = True++ 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 :: Logger -> Param a -> [a] -> IO () play logger reqData [] = getPlaylist reqData >>= play logger reqData- play logger reqData (x:xs) = do+ play logger reqData (x:xs)+ | playable x = do surl <- songUrl reqData x print surl when (surl /= "") $ do let song = artist (songMeta x) ++ " - " ++ title (songMeta x) writeLog logger song getStateFile >>= flip writeFile song+ -- Report song played if needed+ when (reportRequired x) $ void (forkIO $ reportLoop reqData x) mpdLoad $ Path $ C.pack surl takeMVar eof -- Finished play logger reqData xs+ | otherwise = do+ surl <- songUrl reqData x+ print surl+ req <- parseUrl surl+ home <- getLordDir+ manager <- newManager def+ forkIO $ E.catch + (do+ let song = artist (songMeta x) ++ " - " ++ title (songMeta x)+ writeLog logger song + getStateFile >>= flip writeFile song+ -- Report song played if needed+ when (reportRequired x) $ void (forkIO $ reportLoop reqData x) -mpdLoad :: Path -> IO ()-mpdLoad path = do- withMPD $ do- clear- add path- withMPD $ MPD.play Nothing- mpdPlay+ runResourceT $ do + res <- http req manager+ responseBody res $$+- sinkFile (home ++ "/lord.m4a")+ -- This will block until eof. -mpdPlay :: IO ()-mpdPlay = do- withMPD $ idle [PlayerS] - -- This will block until paused/finished.+ putMVar eof ())+ (\e -> do+ print (e :: E.SomeException)+ writeLog logger $ show e+ play logger reqData xs+ )+ threadDelay (3*1000000)+ mpdLoad m4a+ play logger reqData xs+ where+ m4a = "lord/lord.m4a" - st <- withMPD status- let st' = fmap stState st- print st'- if st' == Right Stopped - then putMVar eof ()- else mpdPlay+ mpdLoad :: Path -> IO ()+ mpdLoad path+ | playable x = do+ withMPD $ do+ clear+ add path+ withMPD $ MPD.play Nothing+ mpdPlay+ | otherwise = do+ s <- withMPD $ do+ clear+ update [Path "lord"]+ add path+ case s of+ Right _ -> do+ withMPD $ MPD.play Nothing+ mpdPlay+ _ -> mpdLoad path++ 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++ mpdPlay :: IO ()+ mpdPlay+ | playable x = do+ st <- mpdState+ if st == Right Stopped + then putMVar eof ()+ else mpdPlay+ | otherwise = do+ st <- mpdState+ bd <- isEmptyMVar eof+ if st == Right Stopped + then if bd + then do -- Slow Network+ withMPD $ MPD.play Nothing+ mpdPlay+ else do+ withMPD clear+ takeMVar eof -- Finished+ else mpdPlay -- Pause++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++ readToken :: String -> IO (Maybe (Param a)) getLordDir :: IO FilePath getLordDir = (++ "/.lord") <$> getHomeDirectory
Radio/Douban.hs view
@@ -61,8 +61,8 @@ getPlaylist' :: Query -> IO [Douban] getPlaylist' query = do- let url = "http://douban.fm/j/mine/playlist"- initReq <- parseUrl url+ let rurl = "http://douban.fm/j/mine/playlist"+ initReq <- parseUrl rurl let req = initReq { method = "GET" , queryString = renderQuery False query }@@ -71,10 +71,10 @@ liftM Radio.parsePlaylist (responseBody res $$+- sinkParser json) musicianID :: String -> IO (Maybe String)-musicianID name = do- let url = "http://music.douban.com/search/" ++ - (C.unpack $ urlEncode True (C.pack $ encodeString name))- rsp <- simpleHttp url+musicianID mname = do+ let rurl = "http://music.douban.com/search/" ++ + (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 "@@ -98,8 +98,8 @@ , ("from", Just "lord") ] getPlaylist' query- getPlaylist (Musician name) = do- mId <- musicianID name+ getPlaylist (Musician mname) = do+ mId <- musicianID mname let query = [ ("type", Just "n") , ("channel", Just "0") , ("context", Just $ C.pack ("channel:0|musician_id:" ++ fromJust mId))@@ -113,7 +113,7 @@ -- Songs from douban.fm comes with no tags! tagged _ = False-+ data Channel = Channel { intro :: String , name :: String@@ -155,31 +155,31 @@ -- | Return a list of hot channels. hot :: IO [Channel]-hot = search' url+hot = search' rurl where- url = "http://douban.fm/j/explore/hot_channels"+ rurl = "http://douban.fm/j/explore/hot_channels" -- | Return a list of up trending channels. trending :: IO [Channel]-trending = search' url+trending = search' rurl where- url = "http://douban.fm/j/explore/up_trending_channels"+ 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' url+search key = search' rurl where - url = "http://douban.fm/j/explore/search?query=" ++ + 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' url = do- req <- parseUrl url+search' rurl = do+ req <- parseUrl rurl (Object hm) <- withManager $ \manager -> do res <- http req manager responseBody res $$+- sinkParser json
+ Radio/EightTracks.hs view
@@ -0,0 +1,232 @@+{-# 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 (fromJust)+import Data.Yaml hiding (decode)+import Data.CaseInsensitive (mk)+import Data.Conduit (($$+-))+import Data.Conduit.Attoparsec (sinkParser)+import GHC.Generics (Generic)+import Network.HTTP.Types +import Network.HTTP.Conduit+import Prelude hiding (id)+import System.Console.ANSI+import System.Directory (doesFileExist)+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 Param a = Radio.Param EightTracks++data PlaySession = PlaySession+ { play_token :: String+ , status :: String+ , errors :: Maybe String+ , notices :: Maybe String+ , api_version :: Int+ } deriving (Show, Generic)++data EightTracks = EightTracks + { id :: Int+ , track_file_stream_url :: String+ , name :: String+ , performer :: String+ , release_name :: String+ , url :: String+ } deriving (Show, Generic)++data MixSet = MixSet+ { at_beginning :: Bool+ , at_last_track :: Bool+ , at_end :: Bool+ , skip_allowed :: Bool+ , track :: EightTracks+ } deriving (Show, Generic)++data MixResponse = MixResponse+ { mix_set :: MixSet+ , mix_status :: String+ } deriving (Show, Generic)++instance FromJSON PlaySession+instance FromJSON EightTracks+instance FromJSON MixSet++instance FromJSON MixResponse where+ parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 4 }++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 $ mix_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) (release_name x) (name x)++ tagged _ = False+ + playable _ = 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 (Radio.Param EightTracks)+instance ToJSON (Radio.Param EightTracks)++instance NeedLogin EightTracks where+ createSession strMixId email pwd = do+ 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) ]+ mId = read strMixId :: Int++ data Config EightTracks = Config { eight :: Radio.Param EightTracks } deriving Generic++ mkConfig tok = Config tok++ readToken mid = 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 $ (eight tok) { mixId = read mid }+ Error err -> do+ print $ "Parse token failed: " ++ show err+ return Nothing+ else return Nothing++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 ++search :: String -> IO [Exp.Mix]+search [] = return []+search key = search' rurl+ where + rurl = "http://8tracks.com/mix_sets/keyword:" ++ key ++ ".json?include=mixes"++search' :: String -> IO [Exp.Mix]+search' rurl = do+ initReq <- parseUrl rurl+ let req = initReq { requestHeaders = [verHdr, keyHdr] }+ val <- withManager $ \manager -> do+ res <- http req manager+ responseBody res $$+- sinkParser json++ case fromJSON val of+ Success v -> return $ Exp.mixes $ Exp.mix_set v+ Error err -> putStrLn err >> return []++pprMixes :: [Exp.Mix] -> IO ()+pprMixes mixes =+ forM_ mixes (\m -> do+ setSGR [SetConsoleIntensity BoldIntensity]+ putStr $ "* " ++ Exp.name m + setSGR [SetColor Foreground Vivid Green]+ putStrLn $ " id=" ++ show (Exp.id m)+ setSGR [Reset]+ putStrLn $ " Description: " ++ Exp.description m+ putStrLn $ " Tags: " ++ Exp.tag_list_cache m+ putStrLn ""+ )
+ Radio/EightTracks/Explore.hs view
@@ -0,0 +1,32 @@+{-# 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+ , tag_list_cache :: String+ } 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+
+ Radio/EightTracks/User.hs view
@@ -0,0 +1,25 @@+{-# 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+
Radio/Jing.hs view
@@ -9,8 +9,6 @@ import Codec.Binary.UTF8.String (encodeString) import Control.Applicative ((<$>), (<*>))-import Control.Concurrent (forkIO, threadDelay)-import Control.Concurrent.MVar import qualified Control.Exception as E import Control.Monad (liftM, mzero) import Data.Aeson@@ -22,23 +20,16 @@ import Data.Yaml import Data.CaseInsensitive (mk) import Data.Conduit (runResourceT, ($$+-))-import Data.Conduit.Binary (sinkFile) import Data.Conduit.Attoparsec (sinkParser) import GHC.Generics (Generic) import Network.HTTP.Types import Network.HTTP.Conduit-import Network.MPD hiding (play, Value, Query)-import qualified Network.MPD as MPD-import System.IO-import System.IO.Unsafe (unsafePerformIO) import System.Directory (doesFileExist) import Radio type Param a = Radio.Param Jing -downloaded = unsafePerformIO newEmptyMVar- data Jing = Jing { abid :: Int -- album id , aid :: Int -- artist id@@ -127,146 +118,61 @@ responseBody res $$+- sinkParser json let (String surl) = fromJust $ HM.lookup "result" hm return $ T.unpack surl)- (\e -> print (e :: E.SomeException) >> songUrl tok x)+ (\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-- -- The media file jing.fm provides is of m4a type.- -- MPD is unable to stream m4a file, as a result, lord streams it to - -- ~/.lord/lord.m4a- play logger reqData [] = Radio.getPlaylist reqData >>= Radio.play logger reqData- play logger reqData (x:xs) = do- surl <- Radio.songUrl reqData x- print surl- req <- parseUrl surl- home <- Radio.getLordDir- manager <- newManager def- threadId <- forkIO $ E.catch - (do- let song = artist (songMeta x) ++ " - " ++ title (songMeta x)- getStateFile >>= flip writeFile song-- runResourceT $ do - res <- http req manager- responseBody res $$+- sinkFile (home ++ "/lord.m4a")- -- This will block until downloaded.-- writeLog logger song - putMVar downloaded ())- (\e -> do- print (e :: E.SomeException)- Radio.writeLog logger $ show e- Radio.play logger reqData xs- )- --mtid <- newMVar threadId- threadDelay 3000000- mpdLoad- Radio.play logger reqData xs--mpdLoad :: IO ()-mpdLoad = do- --m4a <- (++ "/lord.m4a") <$> Radio.getLordDir- let m4a = "lord/lord.m4a"- s <- withMPD $ do- clear- update [Path "lord"]- add m4a- case s of- Right _ -> do- withMPD $ MPD.play Nothing- mpdPlay- _ -> mpdLoad--mpdPlay :: IO ()-mpdPlay = do- withMPD $ idle [PlayerS] - -- This will block until paused/finished.-- st <- withMPD status- let st' = fmap stState st- print st'- bd <- isEmptyMVar downloaded- if st' == Right Stopped - then if bd - then do -- Slow Network- withMPD $ MPD.play Nothing- mpdPlay- else do- withMPD clear- takeMVar downloaded -- Finished- else mpdPlay -- Pause+ + playable _ = False instance FromJSON (Radio.Param Jing) instance ToJSON (Radio.Param Jing) -login :: String -> IO (Radio.Param Jing)-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+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 (Radio.Param Jing)+ 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) -createSession :: String -> String -> String -> IO (Maybe (Radio.Param Jing))-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 (Radio.Param Jing)- 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 :: Radio.Param Jing } deriving Generic -saveToken :: Radio.Param Jing -> IO ()-saveToken tok = do- home <- Radio.getLordDir- let yml = home ++ "/lord.yml"- encodeFile yml tok- putStrLn "Your token has been saved to ~/lord.yml"+ mkConfig tok = Config tok -readToken :: String -> IO (Maybe (Radio.Param Jing))-readToken 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 $ tok { cmbt = keywords }- Error err -> error $ "Parse token failed: " ++ show err- else return Nothing+ readToken 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 $ (jing tok) { cmbt = keywords }+ Error err -> error $ "Parse token failed: " ++ show err+ else return Nothing++instance FromJSON (Radio.Config Jing)+instance ToJSON (Radio.Config Jing)
lord.cabal view
@@ -1,21 +1,50 @@ name: lord-version: 1.20131124+version: 1.20131130 synopsis: A command line interface to online radios. description: - A unified interface to online radio service providers, use mpd as backend.+ A unified interface to several online radio service providers, use @mpd@ (<http://musicpd.org>) as backend. . Supported radios:- <http://radioreddit.com>- <http://cmd.fm>- <http://douban.fm>- <http://jing.fm>+ .+ * <http://8tracks.com>+ .+ * <http://cmd.fm>+ .+ * <http://radioreddit.com>+ .+ * <http://douban.fm>+ .+ * <http://jing.fm>+ .+ Commands:+ .+ > lord -h+ > lord status+ > lord kill+ >+ > lord 8tracks listen <mix_id> [--no-daemon]+ > lord 8tracks search <keywords>+ >+ > lord cmd listen <genre> [--no-daemon]+ > lord cmd genres+ >+ > lord douban listen [<channel_id> | <musician>] [--no-daemon]+ > lord douban search <keywords>+ > lord douban hot+ > lord douban trending+ >+ > lord jing listen <keywords> [--no-daemon]+ >+ > lord reddit listen <genre> [--no-daemon]+ > lord reddit genres+ homepage: https://github.com/rnons/lord bug-reports: https://github.com/rnons/lord/issues license: PublicDomain license-file: LICENSE author: rnons maintainer: remotenonsense@gmail.com-category: Web+category: Web, Music build-type: Simple cabal-version: >=1.10 tested-with: GHC == 7.6.3@@ -30,6 +59,9 @@ 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
main.hs view
@@ -20,6 +20,7 @@ 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 @@ -30,6 +31,7 @@ data Command = CmdFM CmdSubCommand | DoubanFM DoubanSubCommand+ | EightTracks ETSubCommand | JingFM JingSubCommand | RedditFM RedditSubCommand | Status@@ -46,6 +48,10 @@ | DoubanSearch String deriving (Eq, Show) +data ETSubCommand = ETListen String+ | ETSearch String+ deriving (Eq, Show)+ data JingSubCommand = JingListen String deriving (Eq, Show) @@ -61,6 +67,8 @@ (progDesc "cmd.fm commander")) <> command "douban" (info (helper <*> doubanOptions) (progDesc "douban.fm commander"))+ <> command "8tracks" (info (helper <*> etOptions)+ (progDesc "8tracks.com commander")) <> command "jing" (info (helper <*> jingOptions) (progDesc "jing.fm commander")) <> command "reddit" (info (helper <*> redditOptions)@@ -88,6 +96,10 @@ DoubanHot -> doubanHot DoubanTrending -> doubanTrending DoubanSearch key -> doubanSearch key+ EightTracks subCommand ->+ case subCommand of+ ETListen mId -> etListen nodaemon mId+ ETSearch key -> etSearch key JingFM (JingListen key) -> jingListen nodaemon key RedditFM subCommand -> case subCommand of@@ -142,6 +154,16 @@ (info (pure DoubanTrending) (progDesc "trending up channels")) ) +etOptions :: Parser Command+etOptions = EightTracks <$> subparser+ ( command "listen"+ (info (helper <*> (ETListen <$> argument str (metavar "mix id")))+ (progDesc "Provide mix id to listen to 8tracks.com"))+ <> command "search"+ (info (helper <*> (ETSearch <$> argument str (metavar "KEYWORDS")))+ (progDesc "search mixes"))+ )+ jingOptions :: Parser Command jingOptions = JingFM <$> subparser ( command "listen" @@ -174,6 +196,20 @@ where isChId = and . fmap isDigit +etListen :: Bool -> Keywords -> IO ()+etListen nodaemon k = do+ tok <- readToken k+ case tok of+ Just tok' -> do+ putStrLn $ "Welcome back, " ++ ET.userName tok'+ listen nodaemon tok'+ _ -> do + param <- login k :: IO (Radio.Param ET.EightTracks)+ listen nodaemon param++etSearch :: String -> IO ()+etSearch key = ET.search key >>= ET.pprMixes+ jingListen :: Bool -> Keywords -> IO () jingListen nodaemon k = do tok <- readToken k@@ -181,7 +217,9 @@ Just tok' -> do putStrLn $ "Welcome back, " ++ C.unpack (nick tok') listen nodaemon tok'- _ -> login k >>= listen nodaemon+ _ -> do + param <- login k :: IO (Radio.Param Jing)+ listen nodaemon param listen :: Radio a => Bool -> Radio.Param a -> IO () listen nodaemon param = do
test/main.hs view
@@ -5,8 +5,9 @@ import Radio import qualified Radio.Cmd as Cmd-import Radio.Jing+import qualified Radio.EightTracks as ET import Radio.Douban+import Radio.Jing import qualified Radio.Reddit as Reddit @@ -29,8 +30,13 @@ ss <- Radio.getPlaylist (Musician "Sigur RóS") assert $ length ss > 0 - it "jing" $ do- tok <- readToken "postrock"+ it "8tracks: given mix id" $ do+ tok <- readToken "14" :: IO (Maybe (Radio.Param ET.EightTracks))+ ss <- Radio.getPlaylist $ fromJust tok+ assert $ length ss > 0++ it "jing: given keywords" $ do+ tok <- readToken "postrock" :: IO (Maybe (Radio.Param Jing)) ss <- Radio.getPlaylist $ fromJust tok assert $ length ss > 0