lord 2.20131220 → 2.20140323
raw patch · 21 files changed
+1237/−1167 lines, 21 filesdep ~aeson
Dependency ranges changed: aeson
Files
- CHANGELOG +4/−0
- Radio.hs +0/−241
- Radio/Cmd.hs +0/−118
- Radio/Douban.hs +0/−221
- Radio/EightTracks.hs +0/−264
- Radio/EightTracks/Explore.hs +0/−36
- Radio/EightTracks/User.hs +0/−25
- Radio/Jing.hs +0/−161
- Radio/Reddit.hs +0/−62
- Web/Radio.hs +241/−0
- Web/Radio/Cmd.hs +118/−0
- Web/Radio/Douban.hs +229/−0
- Web/Radio/EightTracks.hs +280/−0
- Web/Radio/EightTracks/Explore.hs +36/−0
- Web/Radio/EightTracks/User.hs +25/−0
- Web/Radio/Jing.hs +165/−0
- Web/Radio/Reddit.hs +62/−0
- bash_completion.d/lord +13/−0
- lord.cabal +38/−10
- main.hs +16/−19
- test/main.hs +10/−10
CHANGELOG view
@@ -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 [<album_url> | <musician_url>]
− Radio.hs
@@ -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
− Radio/Cmd.hs
@@ -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
− Radio/Douban.hs
@@ -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/"
− Radio/EightTracks.hs
@@ -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"
− Radio/EightTracks/Explore.hs
@@ -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-
− Radio/EightTracks/User.hs
@@ -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-
− Radio/Jing.hs
@@ -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)
− Radio/Reddit.hs
@@ -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
+ Web/Radio.hs view
@@ -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
+ Web/Radio/Cmd.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+-- | Module for interfacing <http://cmd.fm>+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
+ Web/Radio/Douban.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+-- | Module for interfacing <http://douban.fm>+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/"
+ Web/Radio/EightTracks.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++-- | Module for interfacing <http://8tracks.com>+--+-- API documentation: <http://8tracks.com/developers/api_v3>+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"
+ Web/Radio/EightTracks/Explore.hs view
@@ -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+
+ Web/Radio/EightTracks/User.hs view
@@ -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+
+ Web/Radio/Jing.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+-- | Module for interfacing <http://jing.fm>+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)
+ Web/Radio/Reddit.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+-- | Module for interfacing <http://radioreddit.com>+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
+ bash_completion.d/lord view
@@ -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
lord.cabal view
@@ -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 (<http://musicpd.org>) as backend by default. Will fallback to mplayer (<http://www.mplayerhq.hu>) 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,
main.hs view
@@ -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
test/main.hs view
@@ -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"