diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Revision history for music-scroll +## 0.1.2.0 -- 2020-02-01 + +* Allow other clients, currently just VLC & SMPlayer. Now is easier to + add more. +* Better management of dbus signals for changing connection state + between music clients. + ## 0.1.1.0 -- 2020-01-22 * Signal when the song couldn't be gotten from a lyrics website. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,12 +4,13 @@ I don't like having to fire up a browser to get the lyrics of the songs I am currently hearing. I got basic needs, I download songs with good -metadata and use SMPlayer to open the playlists. It would be nice if +metadata and use SMPlayer/VLC to open the playlists. It would be nice if somehow I could get a basic windows with the lyrics of the song. MusicScroll does this. When you run the command `music-scroll` a window -is opened with the lyrics of the song your are playing on SMPlayer and -each change of song will retrieve new lyrics without your intervention. +is opened with the lyrics of the song your are playing on SMPlayer/VLC +and each change of song will retrieve new lyrics without your +intervention. This works by getting the MPRIS info on your song, specifically the title and artists fields. After some clean up it will retrieve the lyrics @@ -20,7 +21,8 @@ This was done as an excuse to learn more of gi-gtk & glade. But I am happy with the result so I am sharing. On the future I would like do write the lyrics to a SQLite database for offline usage and handle other -videoplayers as VLC (this ought to be really easy, send a patch). +videoplayers (this ought to be really easy, send a patch, currently +supporting VLC and smplayer). I want to thanks to the `haskell-gi` and `haskell dbus` authors. I didn't know much about graphics programming or dbus, but the diff --git a/musicScroll.cabal b/musicScroll.cabal --- a/musicScroll.cabal +++ b/musicScroll.cabal @@ -4,10 +4,10 @@ -- http://haskell.org/cabal/users-guide/ name: musicScroll -version: 0.1.1.0 +version: 0.1.2.0 synopsis: Supply your tunes info without leaving your music player. description: Automatically retrive the lyrics of of your current - song on SMPlayer and update it on each change. See the + song on SMPlayer/VLC and update it on each change. See the lyrics on a really elegant GTK app. license: GPL-3 license-file: LICENSE @@ -38,6 +38,8 @@ gi-gtk-hs, text, bytestring, + mtl, + transformers, stm, async, req, @@ -49,6 +51,8 @@ MusicScroll.TagParsing MusicScroll.TrackInfo MusicScroll.DBusNames + MusicScroll.DBusSignals + MusicScroll.ConnState other-modules: Paths_musicScroll -- test-suite playground diff --git a/shell.nix b/shell.nix --- a/shell.nix +++ b/shell.nix @@ -5,21 +5,24 @@ inherit (nixpkgs) pkgs; f = { mkDerivation, async, base, bytestring, containers, dbus - , gi-gtk, gi-gtk-hs, gtk3, req, stdenv, stm, tagsoup, text + , gi-gtk, gi-gtk-hs, gtk3, mtl, req, stdenv, stm, tagsoup, text + , transformers }: mkDerivation { pname = "musicScroll"; - version = "0.1.0.0"; + version = "0.1.1.0"; src = ./.; isLibrary = true; isExecutable = true; enableSeparateDataOutput = true; libraryHaskellDepends = [ - async base bytestring containers dbus gi-gtk gi-gtk-hs req stm - tagsoup text + async base bytestring containers dbus gi-gtk gi-gtk-hs mtl req stm + tagsoup text transformers ]; executableHaskellDepends = [ base ]; executablePkgconfigDepends = [ gtk3 ]; + homepage = "https://github.com/RubenAstudillo/MusicScroll"; + description = "Supply your tunes info without leaving your music player"; license = stdenv.lib.licenses.gpl3; }; diff --git a/src/MusicScroll/AZLyrics.hs b/src/MusicScroll/AZLyrics.hs --- a/src/MusicScroll/AZLyrics.hs +++ b/src/MusicScroll/AZLyrics.hs @@ -5,7 +5,6 @@ import Control.Concurrent.STM.TBQueue (TBQueue, readTBQueue, writeTBQueue) import Control.Exception (try, SomeException) import Control.Monad (forever) -import Data.Either (fromRight) import Data.Text (Text) import Data.Text as T hiding (filter, tail, map) import Data.Text.Encoding (decodeUtf8) diff --git a/src/MusicScroll/ConnState.hs b/src/MusicScroll/ConnState.hs new file mode 100644 --- /dev/null +++ b/src/MusicScroll/ConnState.hs @@ -0,0 +1,25 @@ +module MusicScroll.ConnState + ( ConnState(..) + , newConnState + , setSong + ) where + +import DBus (BusName) +import DBus.Client (Client) +import Control.Concurrent.STM.TBQueue (TBQueue) +import MusicScroll.TrackInfo + +import MusicScroll.DBusNames + +data ConnState = ConnState + { cClient :: Client + , cBusActive :: BusName + , cOutChan :: TBQueue TrackInfo + , cLastSentTrack :: Maybe TrackInfo + } + +newConnState :: TBQueue TrackInfo -> Client -> ConnState +newConnState outChan c = ConnState c vlcBus outChan Nothing + +setSong :: TrackInfo -> ConnState -> ConnState +setSong track s = s { cLastSentTrack = pure track } diff --git a/src/MusicScroll/DBusNames.hs b/src/MusicScroll/DBusNames.hs --- a/src/MusicScroll/DBusNames.hs +++ b/src/MusicScroll/DBusNames.hs @@ -3,8 +3,14 @@ import DBus (BusName, ObjectPath, InterfaceName) -smplayerBus :: BusName +smplayerBus, vlcBus, dbusBus :: BusName smplayerBus = "org.mpris.MediaPlayer2.smplayer" +vlcBus = "org.mpris.MediaPlayer2.vlc" +dbusBus = "org.freedesktop.DBus" + +-- TODO: Add more! +allBuses :: [BusName] +allBuses = [smplayerBus, vlcBus] mediaObject :: ObjectPath mediaObject = "/org/mpris/MediaPlayer2" diff --git a/src/MusicScroll/DBusSignals.hs b/src/MusicScroll/DBusSignals.hs new file mode 100644 --- /dev/null +++ b/src/MusicScroll/DBusSignals.hs @@ -0,0 +1,63 @@ +{-# language OverloadedStrings #-} +module MusicScroll.DBusSignals + ( mediaPropChangeRule + , waitForChange + , changeMusicClient + ) where + +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TMVar (TMVar, takeTMVar, newEmptyTMVar, putTMVar) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Trans.State (StateT, gets, modify) +import Data.Foldable (find) +import Data.Maybe (fromJust) + +import DBus.Client +import DBus + +import MusicScroll.DBusNames +import MusicScroll.ConnState + +mediaPropChangeRule, busNameAddedRule :: MatchRule +mediaPropChangeRule = matchAny + { matchPath = pure mediaObject + , matchInterface = pure "org.freedesktop.DBus.Properties" + , matchMember = pure "PropertiesChanged" } +busNameAddedRule = matchAny + { matchSender = pure dbusBus -- unique name + , matchPath = pure "/org/freedesktop/DBus" + , matchInterface = pure "org.freedesktop.DBus" + , matchMember = pure "NameOwnerChanged" } + +waitForChange :: MatchRule -> StateT ConnState IO () +waitForChange rule = + do client <- gets cClient + liftIO $ do + trigger <- atomically newEmptyTMVar + disarmHandler <- armSignal client trigger rule + _ <- atomically $ takeTMVar trigger + removeMatch client disarmHandler + +armSignal :: Client -> TMVar () -> MatchRule -> IO SignalHandler +armSignal client trigger rule = + addMatch client rule (\_ -> atomically ( putTMVar trigger () )) + +changeMusicClient :: StateT ConnState IO () +changeMusicClient = + do client <- gets cClient + availableStatus <- liftIO $ traverse (checkName client) allBuses + let taggedBuses = zip allBuses availableStatus + case fst <$> find snd taggedBuses of + Just newBus -> modify (\s -> s { cBusActive = newBus }) + Nothing -> do waitForChange busNameAddedRule + changeMusicClient + +checkName :: Client -> BusName -> IO Bool +checkName client name = do + returnCall <- call_ client + (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "NameHasOwner") + { methodCallDestination = Just dbusBus + , methodCallBody = [toVariant name] } + -- We assume this call is correct, as it's done to the master dbus + -- object. So fromJust/head are safe. + return . fromJust . fromVariant . head . methodReturnBody $ returnCall diff --git a/src/MusicScroll/MPRIS.hs b/src/MusicScroll/MPRIS.hs --- a/src/MusicScroll/MPRIS.hs +++ b/src/MusicScroll/MPRIS.hs @@ -1,51 +1,37 @@ -{-# language OverloadedStrings, ScopedTypeVariables, NamedFieldPuns #-} -module MusicScroll.MPRIS where +module MusicScroll.MPRIS (dbusThread) where -import Control.Concurrent.STM (atomically) -import Control.Concurrent.STM.TBQueue (TBQueue) -import qualified Control.Concurrent.STM.TBQueue as TBQueue -import Control.Concurrent.STM.TMVar (TMVar, takeTMVar, - newEmptyTMVar, putTMVar) -import qualified Control.Exception as Exc -import Control.Monad (when) -import DBus.Client +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TBQueue (TBQueue, writeTBQueue) +import Control.Exception (bracket) +import Control.Monad (when, (=<<)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.State.Class (gets, modify) +import Control.Monad.Trans.State (StateT, evalStateT) -import MusicScroll.TrackInfo -import MusicScroll.DBusNames +import DBus.Client +import MusicScroll.TrackInfo +import MusicScroll.DBusSignals +import MusicScroll.ConnState + dbusThread :: TBQueue TrackInfo -> IO a -dbusThread outChan = - Exc.bracket connectSession disconnect (flip go Nothing) +dbusThread outChan = bracket connectSession disconnect + (evalStateT go . newConnState outChan) where - go :: Client -> Maybe TrackInfo -> IO a - go client lastTrack = - do mtrack <- tryGetInfo client - case mtrack of - Right track -> - do writeIfNotRepeated outChan lastTrack track - waitForChange client - go client (pure track) - - Left _ -> waitForChange client >> go client lastTrack - -writeIfNotRepeated :: TBQueue TrackInfo -> Maybe TrackInfo -> TrackInfo - -> IO () -writeIfNotRepeated outChan maybeLast current = do - let query = (/=) <$> maybeLast <*> pure current - when (maybe True id query) $ - atomically (TBQueue.writeTBQueue outChan current) - -waitForChange :: Client -> IO () -waitForChange client = - do trigger <- atomically newEmptyTMVar - disarmHandler <- gotSignalOfChange client trigger - _ <- atomically $ takeTMVar trigger - removeMatch client disarmHandler + go :: StateT ConnState IO a + go = do mtrack <- liftIO . uncurry tryGetInfo =<< + (,) <$> gets cClient <*> gets cBusActive + case mtrack of + Left (NoMusicClient _) -> changeMusicClient + Left NoMetadata -> waitForChange mediaPropChangeRule + Right track -> do writeIfNotRepeated track + waitForChange mediaPropChangeRule + go -gotSignalOfChange :: Client -> TMVar () -> IO SignalHandler -gotSignalOfChange client trigger = - let rule = matchAny - { matchPath = pure mediaObject - , matchInterface = pure "org.freedesktop.DBus.Properties" - , matchMember = pure "PropertiesChanged" } - in addMatch client rule (\_ -> atomically ( putTMVar trigger () )) +writeIfNotRepeated :: TrackInfo -> StateT ConnState IO () +writeIfNotRepeated newSong = do + query <- (/=) <$> gets cLastSentTrack <*> pure (Just newSong) + outChan <- gets cOutChan + when query $ + do liftIO . atomically $ writeTBQueue outChan newSong + modify (setSong newSong) diff --git a/src/MusicScroll/TrackInfo.hs b/src/MusicScroll/TrackInfo.hs --- a/src/MusicScroll/TrackInfo.hs +++ b/src/MusicScroll/TrackInfo.hs @@ -1,4 +1,4 @@ -{-# language OverloadedStrings, ScopedTypeVariables, NamedFieldPuns #-} +{-# language OverloadedStrings, NamedFieldPuns #-} module MusicScroll.TrackInfo ( tryGetInfo , TrackInfo(..) @@ -11,21 +11,17 @@ import DBus.Client import Data.Bifunctor (first) import Data.Function ((&)) -import Data.Int (Int64) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Text (Text) import qualified Data.Text as T import Data.Char (isAlpha) -import Data.Bifunctor import MusicScroll.DBusNames data TrackInfo = TrackInfo { tTitle :: Text - , tArtist :: Text - , tLength :: Double - , tPos :: Int64 + , tArtist :: Text -- xesam:artist is weird } deriving (Eq, Show) -- TODO: better eq instance data TrackInfoError = NoMusicClient MethodError | NoMetadata @@ -33,29 +29,27 @@ -- An exception here means that either there is not a music player -- running or what it is running it's not a song. Either way we should -- wait for a change on the dbus connection to try again. -tryGetInfo :: Client -> IO (Either TrackInfoError TrackInfo) -tryGetInfo client = do +tryGetInfo :: Client -> BusName -> IO (Either TrackInfoError TrackInfo) +tryGetInfo client busName = do metadata <- getPropertyValue client - (methodCall mediaObject mediaInterface "Metadata") { - methodCallDestination = Just smplayerBus } - & fmap (first NoMusicClient) - position <- getPropertyValue client - (methodCall mediaObject mediaInterface "Position") { - methodCallDestination = Just smplayerBus } - & fmap (first NoMusicClient) - return . join $ - obtainTrackInfo <$> metadata <*> position + (methodCall mediaObject mediaInterface "Metadata") { + methodCallDestination = pure busName + } & fmap (first NoMusicClient) + return . join $ obtainTrackInfo <$> metadata -obtainTrackInfo :: Map Text Variant -> Int64 - -> Either TrackInfoError TrackInfo -obtainTrackInfo metadata pos = +obtainTrackInfo :: Map Text Variant -> Either TrackInfoError TrackInfo +obtainTrackInfo metadata = let lookup name = Map.lookup name metadata >>= fromVariant - track = TrackInfo <$> lookup "xesam:title" - <*> lookup "xesam:artist" <*> lookup "mpris:length" - <*> pure pos - in maybe (Left NoMetadata) Right track - + track = TrackInfo <$> lookup "xesam:title" <*> + xesamArtistFix (lookup "xesam:artist") (lookup "xesam:artist") + in maybe (Left NoMetadata) pure track +-- xesam:artist by definition should return a `[Text]`, but in practice +-- it returns a `Text`. This function makes it always return `Text`. +xesamArtistFix :: Maybe Text -> Maybe [Text] -> Maybe Text +xesamArtistFix (Just title) _ = pure title +xesamArtistFix Nothing (Just arr) | (title : _) <- arr = pure title +xesamArtistFix _ _ = Nothing cleanTrack :: TrackInfo -> TrackInfo cleanTrack t@(TrackInfo {tTitle}) = t { tTitle = cleanTitle tTitle }