bronyradiogermany-common (empty) → 1.0.0.0
raw patch · 6 files changed
+530/−0 lines, 6 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, network-uri, text, time, tz, uuid-types
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- bronyradiogermany-common.cabal +75/−0
- src/Network/Radio/BronyRadioGermany/Types.hs +330/−0
- src/Network/Radio/BronyRadioGermany/URI.hs +88/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for bronyradiogermany++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bronyradiogermany-common.cabal view
@@ -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+
+ src/Network/Radio/BronyRadioGermany/Types.hs view
@@ -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)]
+ src/Network/Radio/BronyRadioGermany/URI.hs view
@@ -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"