{-# LANGUAGE OverloadedStrings #-}
module Network.Radio.BronyRadioGermany.Streaming
(
getStreamInfo,
getTrackInfo,
getTrackList,
getHistory,
postUpVote,
postUpVoteFresh,
postDownVote,
postDownVoteFresh,
postAutoDJRequest,
postAutoDJTrackRequest,
radioStream,
AutoDjRequestError(..))
where
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans
import Data.Aeson hiding (encode)
import Data.Time.Clock
import qualified Data.Text as T
import Data.Text.Encoding
import Streaming
import qualified Streaming.Prelude as S
import qualified Data.ByteString.Streaming.Char8 as Q
import Data.ByteString.Streaming.HTTP
import Data.ByteString.Streaming.Aeson
import Network.Radio.BronyRadioGermany.Types as BRG
import Network.Radio.BronyRadioGermany.URI as BRG
import Network.HTTP.Types.URI
import Data.UUID
import Data.UUID.V4
import qualified Data.ByteString as BS
import qualified Data.CaseInsensitive as CI
request :: (FromJSON a, MonadIO m) => T.Text -> m (Maybe a)
request uri = handleResponse <$> request' uri
where handleResponse (Just (Successful a _ _ _)) = Just a
handleResponse _ = Nothing
request' :: (FromJSON a, MonadIO m) => T.Text -> m (Maybe (BRG.Response a))
request' uri = liftIO $ do
m <- newManager tlsManagerSettings
req <- parseRequest (T.unpack uri)
withHTTP req m $ \resp ->
S.head_ $
decoded $
responseBody resp
multipageRequest :: (FromJSON a, MonadIO m) => Int -> (Int -> T.Text) -> Stream (Of a) m ()
multipageRequest page uri = do
mr <- liftIO $ request' $ uri page
case mr of
Nothing -> return ()
Just (Successful rs (Just next) _ _) -> do
S.each rs `const` head rs
multipageRequest (page+1) uri
Just (Successful rs Nothing _ _) -> S.each rs
Just (Errorful msg) -> fail (T.unpack msg)
getStreamInfo :: MonadIO m => Mountpoint -> m (Maybe StreamInfo)
getStreamInfo = request . brgStreamInfoURI
getTrackInfo :: (HasTrackId t, MonadIO m) => t -> m (Maybe TrackInfo)
getTrackInfo = request . brgTrackInfoURI
getTrackList :: MonadIO m => Maybe T.Text
-> Maybe T.Text
-> Stream (Of Track) m ()
getTrackList mtitle martist = do
mlist <- request $ brgTrackListURI mtitle martist
case mlist of
Just list -> S.each list `const` head list
Nothing -> return ()
getHistory :: MonadIO m => Maybe UTCTime
-> Maybe UTCTime
-> Maybe T.Text
-> Maybe T.Text
-> Stream (Of HistoryItem) m ()
getHistory mstart mend mtitle martist = do
end' <- case mend of
Just end -> return end
Nothing -> liftIO getCurrentTime
multipageRequest 1 $ \i -> brgHistoryURI i mstart (Just end') mtitle martist
getVoteStatus :: MonadIO m => UUID -> Mountpoint -> m (Maybe VoteCheckResult)
getVoteStatus uuid mp = request $ brgVoteCheckURI uuid mp
postUpVote :: MonadIO m => UUID -> Mountpoint -> m (Maybe VoteResult)
postUpVote uuid mp = request $ brgUpVoteURI uuid mp
postDownVote :: MonadIO m => UUID -> Mountpoint -> m (Maybe VoteResult)
postDownVote uuid mp = request $ brgDownVoteURI uuid mp
postUpVoteFresh :: MonadIO m => Mountpoint -> m (Maybe VoteResult)
postUpVoteFresh mp = do
uuid <- liftIO nextRandom
postUpVote uuid mp
postDownVoteFresh :: MonadIO m => Mountpoint -> m (Maybe VoteResult)
postDownVoteFresh mp = do
uuid <- liftIO nextRandom
postDownVote uuid mp
data AutoDjRequestError = AutoDjRequestRejected deriving (Eq,Show,Read)
instance Exception AutoDjRequestError
postAutoDJRequest :: (MonadIO m,MonadThrow m) => T.Text
-> T.Text
-> T.Text
-> m ()
postAutoDJRequest nick title artist = do
let body = renderQuery False
[("title", Just (encodeUtf8 title)),
("artist", Just (encodeUtf8 artist)),
("nickname", Just (encodeUtf8 nick))]
req <- parseRequest $ T.unpack brgAutoDJRequestURI
m <- liftIO $ newManager tlsManagerSettings
uuid <- liftIO nextRandom
let req' = req{
method = "POST",
requestBody = RequestBodyBS body}
req'' = addRequestHeader "cookie" ("brg-player-voting-uuid="<>toASCIIBytes uuid) $
addRequestHeader "content-type" "application/x-www-form-urlencoded; charset=UTF-8" $
addRequestHeader "referer" "https://www.bronyradiogermany.com/request-v2/include/request.php" $
addRequestHeader "origin" "https://www.bronyradiogermany.com" $
addRequestHeader "x-requested-with" "XMLHttpRequest" req'
resp <- liftIO $ withHTTP req'' m $ \resp -> Q.toStrict_ $ responseBody resp
if resp == "Request wurde eingereicht."
then return ()
else throwM AutoDjRequestRejected
postAutoDJTrackRequest :: (MonadIO m, MonadThrow m, HasTrack t)
=> T.Text
-> t
-> m ()
postAutoDJTrackRequest nick track =
postAutoDJRequest nick (trackTitle track) (trackArtist track)
radioStream :: MonadResource m => Mountpoint -> Q.ByteString m ()
radioStream mp = do
req <- parseRequest $ T.unpack $ brgStreamURI mp
m <- liftIO $ newManager tlsManagerSettings
resp <- lift $ http req m
responseBody resp
addRequestHeader :: BS.ByteString -> BS.ByteString -> Request -> Request
addRequestHeader key val req =
let key' = CI.mk key
h = (key', val)
in req{requestHeaders= h : requestHeaders req}