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 + +## 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-common.cabal b/bronyradiogermany-common.cabal new file mode 100644 --- /dev/null +++ b/bronyradiogermany-common.cabal @@ -0,0 +1,75 @@ +-- Initial bronyradiogermany.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: bronyradiogermany-common + +-- 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: Common types and URIs for the BronyRadioGermany API bindings. + +-- A longer description of the package. +description: Common types and URIs for the BronyRadioGermany API bindings. Please have a look at bronyradiogermany-conduit or bronyradiogermany-streaming. + +-- 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@mcohrs.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.Types + Network.Radio.BronyRadioGermany.URI + + -- 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, + aeson, + text, + bytestring, + network-uri, + tz, + time, + uuid-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/Types.hs b/src/Network/Radio/BronyRadioGermany/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Radio/BronyRadioGermany/Types.hs @@ -0,0 +1,330 @@ +{-# LANGUAGE DeriveGeneric, OverloadedStrings, RecordWildCards #-} + +module Network.Radio.BronyRadioGermany.Types where + +import Data.Aeson +import Data.Aeson.Encoding +import Data.Aeson.Types +import Data.Maybe +import Data.Monoid +import Data.Time.Clock +import Data.Time.Calendar +import Data.Time.Format +import Data.Time.LocalTime +import Data.Time.Zones +import Data.Time.Zones.All +import qualified Data.Text as T +import Text.Read (readMaybe) + +-- | BRG provides three radio channels: the main channel, DayDJ and NightDJ. All channels are broadcasted in MPEG 4, 128kbps. For the main channel there is also an Opus stream with 96kbps and a mobile MPEG 4 stream with 64kbps. +data Mountpoint = MainDJ + | MainDJMobile + | MainDJOpus + | DayDJ + | NightDJ + deriving (Eq) + +instance Show Mountpoint where + show MainDJ = "stream" + show MainDJMobile = "mobile" + show MainDJOpus = "opus" + show DayDJ = "daydj" + show NightDJ = "nightdj" + +instance Read Mountpoint where + readsPrec d r = [(mp,t) | + (mpstr,t) <- lex r, + mp <- tomp mpstr] + where tomp "stream" = [MainDJ] + tomp "daydj" = [DayDJ] + tomp "nightdj" = [NightDJ] + tomp "mobile" = [MainDJMobile] + tomp "opus" = [MainDJOpus] + tomp _ = [] + +instance FromJSON Mountpoint where + parseJSON (String t) = + case readMaybe (T.unpack t) of + Nothing -> fail ("Not a valid mount point: "++ show t) + Just mp -> return mp + parseJSON invalid = typeMismatch "Mountpoint" invalid + +instance ToJSON Mountpoint where + toJSON mp = String (T.pack $ show mp) + toEncoding mp = string (show mp) + +-- | A response may have succeeded or failed, and it may be chunked into several pages. +data Response a = Successful { responseResult :: !a, + responseNextPage :: Maybe T.Text, + responsePreviousPage :: Maybe T.Text, + responsePages :: Maybe Int } + | Errorful !T.Text + deriving (Eq, Show) + +instance FromJSON a => FromJSON (Response a) where + parseJSON = withObject "Response" $ \o -> do + statusmsg <- o .: "status" + case statusmsg of + String "success" -> do + result <- parseJSON =<< o .: "result" + Successful result + <$> (o .:? "next_page") + <*> (o .:? "previous_page") + <*> (o .:? "pages") + _ -> do + message <- o .: "message" + case message of + String e -> return (Errorful e) + _ -> fail "Invalid \"status\" or \"message\" in response" + +instance ToJSON a => ToJSON (Response a) where + toJSON (Successful a mnp mpp mp) = + object (["status" .= ("success" :: T.Text), + "result" .= a] + ++ maybe [] (\np -> ["next_page" .= np]) mnp + ++ maybe [] (\pp -> ["previous_page" .= pp]) mpp + ++ maybe [] (\p -> ["pages" .= p]) mp) + toJSON (Errorful e) = object ["status" .= ("error" :: T.Text), + "message" .= e] + toEncoding (Successful a mnp mpp mp) = + pairs $ mconcat + (["status" .= ("success" :: T.Text), + "result" .= a] + ++ maybe [] (\np -> ["next_page" .= np]) mnp + ++ maybe [] (\pp -> ["previous_page" .= pp]) mpp + ++ maybe [] (\p -> ["pages" .= p]) mp) + toEncoding (Errorful e) = pairs ("status" .= ("error" :: T.Text) + <> "message" .= e) + +-- | Information on a specific Mountpoint +data StreamInfo = StreamInfo { + siListener :: !Int, -- ^ Current listeners + siStatus :: !T.Text, -- ^ Current status (e.g. "online") + siCurrentEvent :: !T.Text, -- ^ Current event ("DJ-Pony Lucy" for the AutoDJ) + siTrackInfo :: !TrackInfo -- ^ Current song + } deriving (Eq, Show) + +instance FromJSON StreamInfo where + parseJSON = withObject "StreamInfo" $ \o -> StreamInfo + <$> (o .: "listener") + <*> (o .: "status") + <*> (o .: "current_event") + <*> parseJSON (Object o) + +instance ToJSON StreamInfo where + toJSON si@StreamInfo{..} = object ["id" .= trackId si, + "title" .= trackTitle si, + "artist" .= trackArtist si, + "listener" .= siListener, + "status" .= siStatus, + "current_event" .= siCurrentEvent, + "upvotes" .= show (upVotes si), + "downvotes" .= show (downVotes si)] + toEncoding si@StreamInfo{..} = pairs $ mconcat ["id" .= trackId si, + "title" .= trackTitle si, + "artist" .= trackArtist si, + "listener" .= siListener, + "status" .= siStatus, + "current_event" .= siCurrentEvent, + "upvotes" .= show (upVotes si), + "downvotes" .= show (downVotes si)] + +-- | Wider information on a specific track. +data TrackInfo = TrackInfo { + tiTrack :: !Track, -- ^ Core information (id, title, artist) + tiUpVotes :: !Int, -- ^ Up votes + tiDownVotes :: !Int -- ^ Down votes + } deriving (Eq, Show) + +-- | Core information on a specific track. +data Track = Track { + trId :: !Int, -- ^ track id + trTitle :: !T.Text, -- ^ track title + trArtist :: !T.Text -- ^ track artist + } deriving (Eq, Show) + +-- | Everything that contains a track id. +class HasTrackId t where + trackId :: t -> Int -- ^ Get the track id + setTrackId :: Int -> t -> t -- ^ Change the track id + +instance HasTrackId Int where + trackId = id + setTrackId = const + +instance HasTrackId Track where + trackId = trId + setTrackId i tr = tr{trId=i} + +instance HasTrackId TrackInfo where + trackId = trId . tiTrack + setTrackId i ti = ti{tiTrack = setTrackId i (tiTrack ti)} + +instance HasTrackId StreamInfo where + trackId = trackId . siTrackInfo + setTrackId i si = si{siTrackInfo = setTrackId i (siTrackInfo si)} + +-- | Everything that contains core information about a track +class HasTrackId t => HasTrack t where + trackTitle :: t -> T.Text -- ^ Get the track title + setTrackTitle :: T.Text -> t -> t -- ^ Change the track title + trackArtist :: t -> T.Text -- ^ Get the track artist + setTrackArtist :: T.Text -> t -> t -- ^ Change the track artist + +instance HasTrack Track where + trackTitle = trTitle + trackArtist = trArtist + setTrackTitle t tr = tr{trTitle=t} + setTrackArtist a tr = tr{trArtist=a} + +instance HasTrack TrackInfo where + trackTitle = trTitle . tiTrack + trackArtist = trArtist . tiTrack + setTrackTitle t ti = ti{tiTrack = setTrackTitle t (tiTrack ti)} + setTrackArtist a ti = ti{tiTrack = setTrackArtist a (tiTrack ti)} + +instance HasTrack StreamInfo where + trackTitle = trackTitle . siTrackInfo + trackArtist = trackArtist . siTrackInfo + setTrackTitle t si = si{siTrackInfo = setTrackTitle t (siTrackInfo si)} + setTrackArtist a si = si{siTrackInfo = setTrackArtist a (siTrackInfo si)} + +-- | Everything that contains wider information about a track +class HasTrack t => HasTrackInfo t where + upVotes :: t -> Int -- ^ Get the track's upvotes + setUpVotes :: Int -> t -> t -- ^ Change the track's upvotes + downVotes :: t -> Int -- ^ Get the track's downvotes + setDownVotes :: Int -> t -> t -- ^ Change the track's downvotes + voteDifference :: t -> Int + voteDifference t = upVotes t - downVotes t + +instance HasTrackInfo TrackInfo where + upVotes = tiUpVotes + downVotes = tiDownVotes + setUpVotes v ti = ti{tiUpVotes=v} + setDownVotes v ti = ti{tiDownVotes=v} + +instance HasTrackInfo StreamInfo where + upVotes = upVotes . siTrackInfo + downVotes = downVotes . siTrackInfo + setUpVotes v si = si{siTrackInfo = setUpVotes v (siTrackInfo si)} + setDownVotes v si = si{siTrackInfo = setDownVotes v (siTrackInfo si)} + +instance FromJSON TrackInfo where + parseJSON = withObject "TrackInfo" $ \o -> TrackInfo + <$> parseJSON (Object o) + <*> fmap read (o .: "upvotes") + <*> fmap read (o .: "downvotes") + +instance FromJSON Track where + parseJSON = withObject "Track" $ \o -> Track + <$> (o .: "id") + <*> (o .: "title") + <*> (o .: "artist") + +instance ToJSON TrackInfo where + toJSON ti = object ["id" .= trackId ti, + "title" .= trackTitle ti, + "artist" .= trackArtist ti, + "upvotes" .= show (upVotes ti), + "downvotes" .= show (downVotes ti)] + toEncoding ti = pairs $ mconcat ["id" .= trackId ti, + "title" .= trackTitle ti, + "artist" .= trackArtist ti, + "upvotes" .= show (upVotes ti), + "downvotes" .= show (downVotes ti)] + +instance ToJSON Track where + toJSON tr = object ["id" .= trackId tr, + "title" .= trackTitle tr, + "artist" .= trackArtist tr] + toEncoding tr = pairs $ mconcat ["id" .= trackId tr, + "title" .= trackTitle tr, + "artist" .= trackArtist tr] + +-- | An item in the history stream. Contains a track and a timestamp (converted to UTC) +data HistoryItem = HistoryItem { + hiTrack :: !Track, + hiPlayedAt :: !UTCTime + } deriving (Eq, Show) + +instance HasTrackId HistoryItem where + trackId = trackId . hiTrack + setTrackId i hi = hi{hiTrack = setTrackId i (hiTrack hi)} + +instance HasTrack HistoryItem where + trackTitle = trackTitle . hiTrack + trackArtist = trackArtist . hiTrack + setTrackTitle t hi = hi{hiTrack = setTrackTitle t (hiTrack hi)} + setTrackArtist a hi = hi{hiTrack = setTrackArtist a (hiTrack hi)} + +instance FromJSON HistoryItem where + parseJSON = withObject "HistoryItem" $ \o -> do + track <- parseJSON (Object o) + datePlayed <- o .: "date_played" + timePlayed <- o .: "time_played" + let tz = tzByLabel Europe__Berlin + datePlayedM = parseTimeM True defaultTimeLocale "%F" datePlayed :: Maybe Day + timePlayedM = parseTimeM True defaultTimeLocale "%T" timePlayed :: Maybe TimeOfDay + localTimeM = LocalTime <$> datePlayedM <*> timePlayedM + utcTimeM = localTimeToUTCTZ tz <$> localTimeM + case utcTimeM of + Nothing -> fail "Time/date parsing failed" + Just time -> return $ HistoryItem track time + +instance ToJSON HistoryItem where + toJSON hi = object ["id" .= trackId hi, + "title" .= trackTitle hi, + "artist" .= trackArtist hi, + "time_played" .= formatTime defaultTimeLocale "%T" localTime, + "date_played" .= formatTime defaultTimeLocale "%F" localTime] + where localTime = utcToLocalTimeTZ (tzByLabel Europe__Berlin) (hiPlayedAt hi) + toEncoding hi = pairs $ mconcat ["id" .= trackId hi, + "title" .= trackTitle hi, + "artist" .= trackArtist hi, + "time_played" .= formatTime defaultTimeLocale "%T" localTime, + "date_played" .= formatTime defaultTimeLocale "%F" localTime] + where localTime = utcToLocalTimeTZ (tzByLabel Europe__Berlin) (hiPlayedAt hi) + +-- | The vote status. Have you already voted for this song? Up or down? +data VoteCheckResult = VoteCheckResult { + vcVoted :: Bool, + vcDirection :: T.Text + } deriving (Eq,Show) + +instance FromJSON VoteCheckResult where + parseJSON = withObject "VoteCheckResult" $ \o -> + VoteCheckResult <$> (>>= itob) (o .: "voted") <*> (o .: "direction") + where itob :: Monad m => Int -> m Bool + itob 0 = return False + itob 1 = return True + itob i = fail (show i<>" is not a boolean value") + +instance ToJSON VoteCheckResult where + toJSON vc = object ["voted" .= if vcVoted vc then 1 :: Int else 0, + "direction" .= vcDirection vc] + toEncoding vc = pairs $ mconcat ["voted" .= if vcVoted vc then 1 :: Int else 0, + "direction" .= vcDirection vc] + +-- | The result of posting your vote. +data VoteResult = VoteResult { + vrVoted :: Bool, + vrUpVotes :: Int, + vrDownVotes :: Int + } deriving (Eq, Show) + +instance FromJSON VoteResult where + parseJSON = withObject "VoteResult" $ \o -> VoteResult + <$> (o .: "voted") + <*> strint (o .: "upvotes") + <*> strint (o .: "downvotes") + where strint :: Functor f => f String -> f Int + strint = fmap read + +instance ToJSON VoteResult where + toJSON vr = object ["voted" .= vrVoted vr, + "upvotes" .= show (vrUpVotes vr), + "downvotes" .= show (vrDownVotes vr)] + toEncoding vr = pairs $ mconcat ["voted" .= vrVoted vr, + "upvotes" .= show (vrUpVotes vr), + "downvotes" .= show (vrDownVotes vr)] diff --git a/src/Network/Radio/BronyRadioGermany/URI.hs b/src/Network/Radio/BronyRadioGermany/URI.hs new file mode 100644 --- /dev/null +++ b/src/Network/Radio/BronyRadioGermany/URI.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Radio.BronyRadioGermany.URI where + +import Data.Text +import Data.Monoid +import Data.Time.Clock +import Data.Time.Zones +import Data.Time.Zones.All +import Data.Time.Format +import Network.Radio.BronyRadioGermany.Types +import Network.URI +import Data.UUID.Types + +-- | BronyRadioGermany API base URI +brgPanelBaseURI :: Text +brgPanelBaseURI = "https://panel.bronyradiogermany.com/" + +-- | URI of the given radio stream +brgStreamURI :: Mountpoint -> Text +brgStreamURI MainDJ = "http://radio.bronyradiogermany.com:8000/stream" +brgStreamURI MainDJMobile = "http://radio.bronyradiogermany.com:8000/mobile" +brgStreamURI MainDJOpus = "http://radio.bronyradiogermany.com:8000/opus" +brgStreamURI DayDJ = "http://radio.bronyradiogermany.com:8006/daydj" +brgStreamURI NightDJ = "http://radio.bronyradiogermany.com:8003/nightdj" + +-- | URI for StreamInfo requests (GET) +brgStreamInfoURI :: Mountpoint -> Text +brgStreamInfoURI mp = brgPanelBaseURI <> "/api/streaminfo/" <> pack (show mp) + +-- | URI for TrackInfo requests (GET) +brgTrackInfoURI :: HasTrackId t => t -> Text +brgTrackInfoURI t = brgPanelBaseURI <> "/api/track/" <> pack (show (trackId t)) + +-- | URI for AutoDJ track list requests (GET) +brgTrackListURI :: Maybe Text -> Maybe Text -> Text +brgTrackListURI Nothing Nothing = brgPanelBaseURI <> "/api/autodj/track/list" +brgTrackListURI mtitle martist = + brgPanelBaseURI <> "/api/autodj/track/list?" <> title <> conn <> artist + where conn | Just _ <- mtitle, Just _ <- martist = "&" + | otherwise = "" + title | Just t <- mtitle = "title=" <> pack (escapeURIString isUnescapedInURIComponent $ unpack t) + | otherwise = "" + artist | Just a <- martist = "artist=" <> pack (escapeURIString isUnescapedInURIComponent $ unpack a) + | otherwise = "" + +-- | URI for history list requests (GET) +brgHistoryURI :: Int -> Maybe UTCTime -> Maybe UTCTime -> Maybe Text -> Maybe Text -> Text +brgHistoryURI page mstart mend mtitle martist = + brgPanelBaseURI <> "/api/history/" <> pack (show page) <> "?" + <> title <> artist + where title | Just t <- mtitle = "title=" <> pack (escapeURIString isUnescapedInURIComponent $ unpack t) <> "&" + | otherwise = "" + artist | Just a <- martist = "artist=" <> pack (escapeURIString isUnescapedInURIComponent $ unpack a) <> "&" + | otherwise = "" + mstartCET = utcToLocalTimeTZ (tzByLabel Europe__Berlin) <$> mstart + mendCET = utcToLocalTimeTZ (tzByLabel Europe__Berlin) <$> mend + datePlayedStart | Just t <- mstartCET = "date_played_start=" <> pack (formatTime defaultTimeLocale "%F" t) <> "&" + | otherwise = "" + datePlayedEnd | Just t <- mendCET = "date_played_end=" <> pack (formatTime defaultTimeLocale "%F" t) <> "&" + | otherwise = "" + timePlayedStart | Just t <- mstartCET = "time_played_start=" <> pack (formatTime defaultTimeLocale "%T" t) <> "&" + | otherwise = "" + timePlayedEnd | Just t <- mendCET = "time_played_end=" <> pack (formatTime defaultTimeLocale "%F" t) <> "&" + | otherwise = "" + +-- | URI for up votes (GET) +brgUpVoteURI :: UUID -> Mountpoint -> Text +brgUpVoteURI uuid mp = "https://www.bronyradiogermany.com/request-v2/json/v1/vote/song/" <> toText uuid <> "/up/" <> pack (show mp) + +-- | URI for down votes (GET) +brgDownVoteURI :: UUID -> Mountpoint -> Text +brgDownVoteURI uuid mp = "https://www.bronyradiogermany.com/request-v2/json/v1/vote/song/" <> toText uuid <> "/down/" <> pack (show mp) + +-- | URI for checking if the UUID has already voted (GET) +brgVoteCheckURI :: UUID -> Mountpoint -> Text +brgVoteCheckURI uuid mp = brgPanelBaseURI <> "/api/vote/check/" <> toText uuid <> "/" <> pack (show mp) + +-- | URI for requesting a song (POST, params: title, artist, nickname) +brgAutoDJRequestURI :: Text +brgAutoDJRequestURI = "https://www.bronyradiogermany.com/request-v2/action/add_request_autodj.php" + +-- | POST body for requesting a song +brgAutoDJRequestBody :: Text -> Text -> Text -> String +brgAutoDJRequestBody nick title artist = + "title=" <> (escapeURIString isUnescapedInURIComponent $ unpack title) + <> "&artist=" <> (escapeURIString isUnescapedInURIComponent $ unpack artist) + <> "&nickname=" <> (escapeURIString isUnescapedInURIComponent $ unpack nick) + <> "\n"