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 qualified Data.ByteString.Lazy.Char8 as LC
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.Browser (browse, request, setOutHandler)
import Network.HTTP (getRequest)
import Network.HTTP.Base (rspBody)
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
, ssid :: Maybe String
, album :: String
, artist :: String
, url :: String
, title :: String
, subtype :: String
, sid :: String
, aid :: String
} deriving Show
instance FromJSON Douban where
parseJSON (Object v) = Douban <$>
v .: "picture" <*>
v .: "albumtitle" <*>
v .:? "ssid" <*>
v .: "album" <*>
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
| Programme Int
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)
getPlaylist (Programme pid) =
getPlaylist' $ mkQuery 0 $ "channel:0|programme_id:" ++ show pid
songUrl _ x = return $ url x
songMeta x = Radio.SongMeta (artist x) (albumtitle x) (title x)
tagged _ = False
data Channel = Channel
{ intro :: String
, name :: String
, song_num :: Int
, 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 ""
)
hot :: IO [Channel]
hot = search' rurl
where
rurl = "http://douban.fm/j/explore/hot_channels"
trending :: IO [Channel]
trending = search' rurl
where
rurl = "http://douban.fm/j/explore/up_trending_channels"
search :: String -> IO [Channel]
search [] = return []
search key = search' rurl
where
rurl = "http://douban.fm/j/explore/search?query=" ++
C.unpack (urlEncode True (C.pack $ encodeString key))
search' :: String -> IO [Channel]
search' rurl = do
(_, rsp) <- browse $ do
setOutHandler $ const (return ())
request $ getRequest rurl
let (Object hm) = fromJust $ decode $ LC.pack $ rspBody rsp
(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 $ takeWhile isDigit $ drop (length aPattern) k
| mPattern `isPrefixOf` k =
MusicianId $ read $ takeWhile isDigit $ drop (length mPattern) k
| pPattern `isPrefixOf` k =
Programme $ read $ takeWhile isDigit $ drop (length pPattern) k
| otherwise = MusicianName k
where
isChId = and . fmap isDigit
aPattern = "http://music.douban.com/subject/"
mPattern = "http://music.douban.com/musician/"
pPattern = "http://music.douban.com/programme/"