musicScroll 0.1.1.0 → 0.1.2.0
raw patch · 10 files changed
+171/−82 lines, 10 filesdep +mtldep +transformers
Dependencies added: mtl, transformers
Files
- CHANGELOG.md +7/−0
- README.md +6/−4
- musicScroll.cabal +6/−2
- shell.nix +7/−4
- src/MusicScroll/AZLyrics.hs +0/−1
- src/MusicScroll/ConnState.hs +25/−0
- src/MusicScroll/DBusNames.hs +7/−1
- src/MusicScroll/DBusSignals.hs +63/−0
- src/MusicScroll/MPRIS.hs +31/−45
- src/MusicScroll/TrackInfo.hs +19/−25
CHANGELOG.md view
@@ -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.
README.md view
@@ -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
musicScroll.cabal view
@@ -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
shell.nix view
@@ -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; };
src/MusicScroll/AZLyrics.hs view
@@ -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)
+ src/MusicScroll/ConnState.hs view
@@ -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 }
src/MusicScroll/DBusNames.hs view
@@ -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"
+ src/MusicScroll/DBusSignals.hs view
@@ -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
src/MusicScroll/MPRIS.hs view
@@ -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)
src/MusicScroll/TrackInfo.hs view
@@ -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 }