diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for bronyradiogermany-streaming + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, Marvin Cohrs + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Marvin Cohrs nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bronyradiogermany-streaming.cabal b/bronyradiogermany-streaming.cabal new file mode 100644 --- /dev/null +++ b/bronyradiogermany-streaming.cabal @@ -0,0 +1,79 @@ +-- Initial bronyradiogermany-streaming.cabal generated by cabal init. For +-- further documentation, see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: bronyradiogermany-streaming + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- https://wiki.haskell.org/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 1.0.0.0 + +-- A short (one-line) description of the package. +synopsis: Streaming interface for the BronyRadioGermany API. + +-- A longer description of the package. +description: This is a streaming interface for the API of BronyRadioGermany. Features: get the currently played song, the entire song history, the AutoDj track list, vote statistics, and the raw audio streams; it can also post up- and downvotes, as well as song requests. If you prefer conduit over streaming, please have a look at bronyradiogermany-conduit. + +-- The license under which the package is released. +license: BSD3 + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Marvin Cohrs + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: darcs@m.doomanddarkness.eu + +-- A copyright notice. +-- copyright: + +category: Network + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +extra-source-files: ChangeLog.md + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + + +library + -- Modules exported by the library. + exposed-modules: Network.Radio.BronyRadioGermany.Streaming + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base >=4.9 && <4.10, + streaming, + streaming-bytestring, + streaming-utils, + bronyradiogermany-common, + uuid, + text, + aeson, + time, + mtl, + bytestring, + case-insensitive, + http-types + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell2010 + diff --git a/src/Network/Radio/BronyRadioGermany/Streaming.hs b/src/Network/Radio/BronyRadioGermany/Streaming.hs new file mode 100644 --- /dev/null +++ b/src/Network/Radio/BronyRadioGermany/Streaming.hs @@ -0,0 +1,175 @@ +{-# 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}