Streaming.hs

{-# LANGUAGE OverloadedStrings #-}

module Network.Radio.BronyRadioGermany.Streaming
       (-- * Simple information requests
        getStreamInfo,
        getTrackInfo,
        -- * Track streams
        getTrackList,
        getHistory,
        -- * Voting
        postUpVote,
        postUpVoteFresh,
        postDownVote,
        postDownVoteFresh,
        -- * AutoDJ requests
        postAutoDJRequest,
        postAutoDJTrackRequest,
        -- * Audio streams
        radioStream,
        -- * Errors
        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  -- head forces rs to be a list
      multipageRequest (page+1) uri
    Just (Successful rs Nothing _ _) -> S.each rs
    Just (Errorful msg) -> fail (T.unpack msg)

-- | Get information about the given channel
getStreamInfo :: MonadIO m => Mountpoint -> m (Maybe StreamInfo)
getStreamInfo = request . brgStreamInfoURI

-- | Get information about the given track
getTrackInfo :: (HasTrackId t, MonadIO m) => t -> m (Maybe TrackInfo)
getTrackInfo = request . brgTrackInfoURI

-- | Get the AutoDJ's track list
getTrackList :: MonadIO m => Maybe T.Text -- ^ Title mask (use % as a wildcard)
                -> Maybe T.Text           -- ^ Artist mask (use % as a wildcard)
                -> Stream (Of Track) m ()
getTrackList mtitle martist = do
  mlist <- request $ brgTrackListURI mtitle martist
  case mlist of
    Just list -> S.each list `const` head list -- head forces list to be a list
    Nothing -> return ()

-- | Get the song history of the main channel
getHistory :: MonadIO m => Maybe UTCTime  -- ^ start time
              -> Maybe UTCTime            -- ^ end time
              -> Maybe T.Text             -- ^ title mask (use % as a wildcard)
              -> Maybe T.Text             -- ^ artist mask
              -> 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

-- | Check Vote status for a given UUID and mountpoint
getVoteStatus :: MonadIO m => UUID -> Mountpoint -> m (Maybe VoteCheckResult)
getVoteStatus uuid mp = request $ brgVoteCheckURI uuid mp

-- | Post an upvote using the given UUID (caution: even though this is logically a post, the HTTP method is GET)
postUpVote :: MonadIO m => UUID -> Mountpoint -> m (Maybe VoteResult)
postUpVote uuid mp = request $ brgUpVoteURI uuid mp

-- | Post a downvote using the given UUID (caution: even though this is logically a post, the HTTP method is GET)
postDownVote :: MonadIO m => UUID -> Mountpoint -> m (Maybe VoteResult)
postDownVote uuid mp = request $ brgDownVoteURI uuid mp

-- | Post an upvote using a fresh UUID
postUpVoteFresh :: MonadIO m => Mountpoint -> m (Maybe VoteResult)
postUpVoteFresh mp = do
  uuid <- liftIO nextRandom
  postUpVote uuid mp

-- | Post a downvote using a fresh UUID
postDownVoteFresh :: MonadIO m => Mountpoint -> m (Maybe VoteResult)
postDownVoteFresh mp = do
  uuid <- liftIO nextRandom
  postDownVote uuid mp

-- | Thrown if the AutoDJ song request has been rejected, i.e. due to quota violation
data AutoDjRequestError = AutoDjRequestRejected deriving (Eq,Show,Read)

instance Exception AutoDjRequestError

-- | Request a song from the AutoDJ. Throws AutoDjRequestRejected if the request is rejected by the server, i.e. the quota is violated
postAutoDJRequest :: (MonadIO m,MonadThrow m) => T.Text -- ^ your nickname
                     -> T.Text           -- ^ track title
                     -> T.Text           -- ^ track artist
                     -> 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

-- | Request a song from the AutoDJ
postAutoDJTrackRequest :: (MonadIO m, MonadThrow m, HasTrack t)
                          => T.Text -- ^ your nickname
                          -> t      -- ^ requested track
                          -> m ()
postAutoDJTrackRequest nick track =
  postAutoDJRequest nick (trackTitle track) (trackArtist track)

-- | Raw radio stream. Use an audio library to extract frames, or pipe it into an audio device
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}