NetEase.hs

{-# LANGUAGE OverloadedStrings, RecordWildCards, LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}

module FM.NetEase (
  initSession
, login
, encryptPassword
, fetchFM
, fetchRecommend
, fetchPlayLists
, fetchPlayList
, fetchUrl
, fetchLyrics
) where

import           Control.Exception
import           Control.Monad.IO.Class
import           Control.Monad.Reader
import           Control.Monad.Catch (throwM)
import qualified Data.Aeson as JSON
import           Data.Aeson ((.:), (.:?))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BL
import           Data.Char (isDigit)
import           Data.Default.Class
import           Data.IORef
import           Data.List (find)
import           Data.Time.Clock (getCurrentTime)
import           Data.Typeable
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.TLS as HTTP
import qualified Network.HTTP.Types.Header as HTTP
import qualified Network.HTTP.Types.Status as HTTP
import qualified Network.HTTP.Types.URI as HTTP
import           System.Random (getStdRandom, randomR)

import           FM.Session
import qualified FM.Song as Song
import           FM.NetEase.JSON
import           FM.NetEase.Crypto

class IsQuery q where
  fromQuery :: q -> BS.ByteString

instance IsQuery () where
  fromQuery () = BS.empty

data Session = Session {
  sessionManager :: HTTP.Manager
, sessionUserId  :: IORef Int
, sessionCsrf    :: IORef String
, sessionSecure  :: Bool
, sessionCookies :: IORef HTTP.CookieJar
} deriving (Typeable)

instance IsSession Session

data HTTPMethod = Post | Get | PostAndSaveCookies

data NetEaseException = NetEaseHTTPException HTTP.HttpException
                      | NetEaseStatusCodeException Int (HTTP.Response String)
                      | NetEaseParseException String
                      | NetEaseOtherExceptipon Int (Maybe String)
  deriving (Typeable, Show)

instance Exception NetEaseException

data ResponseMessage = ResponseMessage Int (Maybe String)

instance JSON.FromJSON ResponseMessage where
  parseJSON (JSON.Object v) = ResponseMessage <$> v .: "code" <*> v .:? "message"
  parseJSON _ = fail "invalid response"

validateJSON :: (MonadIO m) => Either String a -> (a -> m b) -> m b
validateJSON r f = case r of
  Right x -> f x
  Left err -> liftIO $ throwM $ NetEaseParseException err

sendRequest :: (MonadIO m, IsQuery q) => Session -> HTTPMethod -> String -> q -> m BS.ByteString
sendRequest Session {..} method url query = liftIO $ case method of
    Get -> catch get (throwM . NetEaseHTTPException)
    Post -> catch (post False) (throwM . NetEaseHTTPException)
    PostAndSaveCookies -> catch (post True) (throwM . NetEaseHTTPException)
  where
    initRequest request = do
      cookies <- liftIO $ readIORef sessionCookies
      return request { HTTP.requestHeaders = [ (HTTP.hAccept, "*/*")
                                             , (HTTP.hAcceptEncoding, "gzip,deflate,sdch")
                                             , (HTTP.hAcceptLanguage, "zh-CN,zh;q=0.8,gl;q=0.6,zh-TW;q=0.4")
                                             , (HTTP.hConnection, "keep-alive")
                                             , (HTTP.hContentType, "application/x-www-form-urlencoded")
                                             , (HTTP.hHost, "music.163.com")
                                             , (HTTP.hReferer, "http://music.163.com/search/")
                                             ]
                     , HTTP.cookieJar = Just cookies
                     , HTTP.secure = sessionSecure
                     , HTTP.port = if sessionSecure then 443 else 80
                     }

    post saveCookies = do
      initialRequest <- initRequest =<< HTTP.parseUrl url
      send saveCookies $ initialRequest { HTTP.method = "POST"
                                        , HTTP.requestBody = HTTP.RequestBodyBS $ fromQuery query
                                        }

    get = do
      let action = mconcat [ url, "?", BS8.unpack $ fromQuery query ]
      initialRequest <- initRequest =<< HTTP.parseUrl action
      send False $ initialRequest { HTTP.method = "GET" }

    send saveCookies request = do
      response <- fmap BL.toStrict <$> HTTP.httpLbs request sessionManager
      let HTTP.Status {..} = HTTP.responseStatus response
      case statusCode of
        200 -> do
          when saveCookies $ do
            now <- getCurrentTime
            let updateCookieJar = fst . HTTP.updateCookieJar response request now
            modifyIORef' sessionCookies updateCookieJar
          let body = HTTP.responseBody response
          validateJSON (JSON.eitherDecode (BL.fromStrict body)) $ \case
            ResponseMessage 200 _ -> return body
            ResponseMessage rc m -> throwM (NetEaseOtherExceptipon rc m)
        _ -> throwM (NetEaseStatusCodeException statusCode (BS8.unpack <$> response))

initSession :: (MonadIO m) => Bool -> m SomeSession
initSession sessionSecure = liftIO $ do
  sessionManager <- HTTP.newManager (if sessionSecure then HTTP.tlsManagerSettings else HTTP.defaultManagerSettings)
  sessionUserId <- newIORef 0
  sessionCsrf <- newIORef []
  sessionCookies <- newIORef (HTTP.createCookieJar [])
  return $ SomeSession Session {..}

data NetEaseQuery = FetchLyrics Song.SongId
                  | FetchPlayLists Int
                  | FetchPlayList Int
                  | EncryptData BS.ByteString BS.ByteString

instance IsQuery NetEaseQuery where
  fromQuery (EncryptData text key) = HTTP.renderSimpleQuery False
    [ ("params", text), ("encSecKey", key) ]

  fromQuery (FetchLyrics id) = HTTP.renderSimpleQuery False
    [ ("os", "osx"), ("id", BS8.pack (show id)), ("lv", "-1"), ("kv", "-1"), ("tv", "-1") ]

  fromQuery (FetchPlayLists uid) = HTTP.renderSimpleQuery False
    [ ("offset", "0"), ("limit", "1000"), ("uid", BS8.pack (show uid)) ]

  fromQuery (FetchPlayList id) = HTTP.renderSimpleQuery False
    [ ("id", BS8.pack (show id)) ]

createSecretKey :: (MonadIO m) => Int -> m BS.ByteString
createSecretKey n = mconcat <$> replicateM n (toHex <$> liftIO (getStdRandom $ randomR (0 :: Int, 15)))

encryptQuery :: (MonadIO m) => BS.ByteString -> m NetEaseQuery
encryptQuery q = do
  secretKey <- createSecretKey 16
  return $ EncryptData (encryptAES secretKey q) (encryptRSA secretKey)

login :: (MonadIO m, MonadReader Session m) => String -> String -> m ()
login userName password = do
  session@Session {..} <- ask
  let isPhone = length userName == 11 && all isDigit userName
  let loginURL | isPhone = "http://music.163.com/weapi/login/cellphone"
               | otherwise = "http://music.163.com/weapi/login"
  request <- encryptQuery $ encodeJSON $ JSON.object $ if isPhone
               then [ ("phone", JSON.toJSON $ BS8.pack userName)
                    , ("password", JSON.toJSON $ BS8.pack password)
                    , ("rememberLogin", JSON.toJSON False)
                    ]
               else [ ("username", JSON.toJSON $ BS8.pack userName)
                    , ("password", JSON.toJSON $ BS8.pack password)
                    , ("rememberLogin", JSON.toJSON False)
                    ]
  body <- sendRequest session PostAndSaveCookies loginURL request
  validateJSON (decodeUserId body) (liftIO . writeIORef sessionUserId)
  cookies <- liftIO $ HTTP.destroyCookieJar <$> readIORef sessionCookies
  let csrf = BS8.unpack . HTTP.cookie_value <$> find (\HTTP.Cookie {..} -> cookie_name == "__csrf") cookies
  case csrf of
    Just csrf -> liftIO $ writeIORef sessionCsrf csrf
    Nothing -> return ()

fetchFM :: (MonadIO m, MonadReader Session m) => m [Song.Song]
fetchFM = do
  session <- ask
  body <- sendRequest session Get "http://music.163.com/api/radio/get" ()
  validateJSON (decodeFM body) return

fetchRecommend :: (MonadIO m, MonadReader Session m) => m [Song.Song]
fetchRecommend = do
  session@Session {..} <- ask
  csrf <- liftIO $ readIORef sessionCsrf
  let url = "http://music.163.com/weapi/v1/discovery/recommend/songs?csrf_token=" ++ csrf
  request <- encryptQuery $ encodeJSON $ JSON.object
    [ ("offset", JSON.toJSON (0 :: Int))
    , ("total", JSON.toJSON True)
    , ("limit", JSON.toJSON (20 :: Int))
    , ("csrf_token", JSON.toJSON csrf)
    ]
  body <- sendRequest session Post url request
  validateJSON (decodeRecommend body) return

fetchPlayLists :: (MonadIO m, MonadReader Session m) => m [(Int, String)]
fetchPlayLists = do
  session@Session {..} <- ask
  userId <- liftIO $ readIORef sessionUserId
  if userId == 0
     then return []
     else do
       body <- sendRequest session Get "http://music.163.com/api/user/playlist" (FetchPlayLists userId)
       validateJSON (decodePlayLists body) return

fetchPlayList :: (MonadIO m, MonadReader Session m) => Int -> m [Song.Song]
fetchPlayList id = do
  session <- ask
  body <- sendRequest session Get "http://music.163.com/api/playlist/detail" (FetchPlayList id)
  validateJSON (decodePlayList body) return

fetchUrl :: (MonadIO m, MonadReader Session m) => Song.Song -> m (Maybe String)
fetchUrl Song.Song {..} = do
  session@Session {..} <- ask
  csrf <- liftIO $ readIORef sessionCsrf
  let url = "http://music.163.com/weapi/song/enhance/player/url?csrf_token=" ++ csrf
  request <- encryptQuery $ encodeJSON $ JSON.object
    [ ("ids", JSON.toJSON [uid])
    , ("br", JSON.toJSON (320000 :: Int))
    , ("csrf_token", JSON.toJSON csrf)
    ]
  body <- sendRequest session Post url request
  case decodeUrl body of
    Right [url] -> return (Just url)
    _ -> return Nothing

fetchLyrics :: (MonadIO m, MonadReader Session m) => Song.Song -> m Song.Lyrics
fetchLyrics Song.Song {..} = do
  session <- ask
  body <- sendRequest session Get "http://music.163.com/api/song/lyric" (FetchLyrics uid)
  return $ either (const def) Song.parseLyrics (decodeLyrics body)