musicScroll 0.1.2.0 → 0.2.0.0
raw patch · 17 files changed
+549/−139 lines, 17 filesdep +cryptonitedep +deepseqdep +directory
Dependencies added: cryptonite, deepseq, directory, sqlite-simple, xdg-basedir
Files
- CHANGELOG.md +6/−0
- README.md +17/−18
- musicScroll.cabal +16/−3
- resources/app.glade +98/−3
- shell.nix +10/−6
- src/MusicScroll/AZLyrics.hs +16/−20
- src/MusicScroll/ConnState.hs +10/−9
- src/MusicScroll/DBusSignals.hs +1/−1
- src/MusicScroll/DatabaseUtils.hs +80/−0
- src/MusicScroll/LyricsPipeline.hs +79/−0
- src/MusicScroll/MPRIS.hs +25/−21
- src/MusicScroll/RealMain.hs +6/−10
- src/MusicScroll/TagParsing.hs +5/−3
- src/MusicScroll/TrackInfo.hs +49/−13
- src/MusicScroll/TrackSuplement.hs +22/−0
- src/MusicScroll/UI.hs +33/−32
- src/MusicScroll/UIEvent.hs +76/−0
CHANGELOG.md view
@@ -1,5 +1,11 @@ # Revision history for music-scroll +## 0.2.0.0++* SQLite cache+* Suplementing the best effort info on a file to get the song.+* Better state/error reporting.+ ## 0.1.2.0 -- 2020-02-01 * Allow other clients, currently just VLC & SMPlayer. Now is easier to
README.md view
@@ -1,32 +1,31 @@ # MusicScroll -+ 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/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+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/VLC-and each change of song will retrieve new lyrics without your-intervention.+and each change of song will retrieve new lyrics hopefully without your+intervention. If it could not retrieve the song because it was lacking+metadata, you could supply the missing info to get it. It will cache the+results so you don't have to intervene manually next time. Ideally it+ought be not invasive so you can read only if you want. 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-from a lyrics website, clean the HTML a little and put it as text on a-GTK window. Ideally it ought be not invasive so you can read only if you-want.+title and artists fields. After some clean up it will retrieve the+lyrics from a lyrics website, clean the HTML a little and put it as text+on a GTK window. It will cache the results on a SQLite DB for next time. -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 (this ought to be really easy, send a patch, currently-supporting VLC and smplayer).+This was done as an excuse to learn more of gi-gtk, glade and SQLite.+But I am happy with the result so I am sharing. I want to thanks to the `haskell-gi` and `haskell dbus` authors. I-didn't know much about graphics programming or dbus, but the-documentation, types and code samples helped me a lot on understanding-how they ought to be organized. If I see you guys on a conference I will-buy you a beer :-) . The `d-feet` program was really helpful for see how-the data was layout on DBus.+didn't know much about UI programming or dbus, but the documentation,+types and code samples helped me a lot on understanding how they ought+to be organized. If I see you guys on a conference I will buy you a beer+:-) . The `d-feet` program was really helpful for see how the data was+layout on DBus.
musicScroll.cabal view
@@ -4,7 +4,7 @@ -- http://haskell.org/cabal/users-guide/ name: musicScroll-version: 0.1.2.0+version: 0.2.0.0 synopsis: Supply your tunes info without leaving your music player. description: Automatically retrive the lyrics of of your current song on SMPlayer/VLC and update it on each change. See the@@ -30,6 +30,8 @@ library default-language: Haskell2010+ ghc-options: -optl-fuse-ld=gold+ ld-options: -fuse-ld=gold hs-source-dirs: src build-depends: base <4.13 , containers,@@ -43,16 +45,26 @@ stm, async, req,- tagsoup+ tagsoup,+ sqlite-simple,+ xdg-basedir,+ cryptonite,+ bytestring,+ directory,+ deepseq exposed-modules: MusicScroll.UI, MusicScroll.RealMain MusicScroll.MPRIS MusicScroll.AZLyrics+ MusicScroll.LyricsPipeline MusicScroll.TagParsing MusicScroll.TrackInfo+ MusicScroll.UIEvent MusicScroll.DBusNames MusicScroll.DBusSignals MusicScroll.ConnState+ MusicScroll.DatabaseUtils+ MusicScroll.TrackSuplement other-modules: Paths_musicScroll -- test-suite playground@@ -71,4 +83,5 @@ hs-source-dirs: app default-language: Haskell2010 pkgconfig-depends: gtk+-3.0- ghc-options: -Wall -rtsopts -threaded+ ghc-options: -Wall -rtsopts -threaded -optl-fuse-ld=gold+ ld-options: -fuse-ld=gold
resources/app.glade view
@@ -2,7 +2,6 @@ <!-- Generated with glade 3.22.1 --> <interface> <requires lib="gtk+" version="3.20"/>- <object class="GtkTextBuffer" id="textbuffer1"/> <object class="GtkWindow" id="mainWindow"> <property name="can_focus">False</property> <child>@@ -15,9 +14,20 @@ <property name="hexpand">True</property> <property name="vexpand">True</property> <child>- <object class="GtkGrid">+ <object class="GtkLabel" id="errorLabel"> <property name="visible">True</property> <property name="can_focus">False</property>+ <property name="label" translatable="yes">Error message</property>+ </object>+ <packing>+ <property name="left_attach">0</property>+ <property name="top_attach">2</property>+ </packing>+ </child>+ <child>+ <object class="GtkGrid" id="lyricsOutputGrid">+ <property name="visible">True</property>+ <property name="can_focus">False</property> <property name="margin_left">10</property> <property name="margin_top">10</property> <property name="hexpand">True</property>@@ -64,7 +74,7 @@ <property name="vscroll_policy">natural</property> <property name="editable">False</property> <property name="justification">center</property>- <property name="buffer">textbuffer1</property>+ <property name="accepts_tab">False</property> </object> </child> </object>@@ -72,6 +82,91 @@ <property name="left_attach">0</property> <property name="top_attach">2</property> </packing>+ </child>+ </object>+ <packing>+ <property name="left_attach">0</property>+ <property name="top_attach">1</property>+ </packing>+ </child>+ <child>+ <object class="GtkExpander">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <child>+ <object class="GtkBox">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="orientation">vertical</property>+ <child>+ <object class="GtkEntry" id="titleSuplementEntry">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="placeholder_text" translatable="yes">Title</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkEntry" id="artistSuplementEntry">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="placeholder_text" translatable="yes">Artist</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="position">1</property>+ </packing>+ </child>+ <child>+ <object class="GtkGrid" id="buttonBox">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="column_spacing">5</property>+ <child>+ <object class="GtkButton" id="suplementAcceptButton">+ <property name="label" translatable="yes">Search</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ </object>+ <packing>+ <property name="left_attach">0</property>+ <property name="top_attach">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkCheckButton" id="keepArtistNameCheck">+ <property name="label" translatable="yes">Keep artist name</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">False</property>+ <property name="draw_indicator">True</property>+ </object>+ <packing>+ <property name="left_attach">1</property>+ <property name="top_attach">0</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="position">2</property>+ </packing>+ </child>+ </object>+ </child>+ <child type="label">+ <object class="GtkLabel">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="label" translatable="yes">Suplement info</property>+ </object> </child> </object> <packing>
shell.nix view
@@ -4,20 +4,22 @@ inherit (nixpkgs) pkgs; - f = { mkDerivation, async, base, bytestring, containers, dbus- , gi-gtk, gi-gtk-hs, gtk3, mtl, req, stdenv, stm, tagsoup, text- , transformers+ f = { mkDerivation, async, base, bytestring, containers+ , cryptonite, dbus, directory, gi-gtk, gi-gtk-hs, gtk3, mtl, req+ , sqlite-simple, stdenv, stm, tagsoup, text, transformers+ , xdg-basedir }: mkDerivation { pname = "musicScroll";- version = "0.1.1.0";+ version = "0.1.2.0"; src = ./.; isLibrary = true; isExecutable = true; enableSeparateDataOutput = true; libraryHaskellDepends = [- async base bytestring containers dbus gi-gtk gi-gtk-hs mtl req stm- tagsoup text transformers+ async base bytestring containers cryptonite dbus directory gi-gtk+ gi-gtk-hs mtl req sqlite-simple stm tagsoup text transformers+ xdg-basedir ]; executableHaskellDepends = [ base ]; executablePkgconfigDepends = [ gtk3 ];@@ -28,6 +30,8 @@ haskellPackages = if compiler == "default" then pkgs.haskellPackages+ else if compiler == "profile"+ then pkgs.profiledHaskellPackages else pkgs.haskell.packages.${compiler}; variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
src/MusicScroll/AZLyrics.hs view
@@ -1,40 +1,36 @@ {-# language OverloadedStrings, DataKinds, NamedFieldPuns, TypeApplications #-}-module MusicScroll.AZLyrics (lyricsThread) where+module MusicScroll.AZLyrics (getLyricsFromWeb) where -import Control.Concurrent.STM (atomically)-import Control.Concurrent.STM.TBQueue (TBQueue, readTBQueue, writeTBQueue) import Control.Exception (try, SomeException)-import Control.Monad (forever)+import Control.Applicative (Alternative(empty)) import Data.Text (Text)-import Data.Text as T hiding (filter, tail, map)+import Data.Text as T hiding (filter, tail, map, empty) import Data.Text.Encoding (decodeUtf8)-import MusicScroll.TrackInfo (TrackInfo(..), cleanTrack)-import MusicScroll.TagParsing import Network.HTTP.Req+import Control.Concurrent (forkIO) -lyricsThread :: TBQueue TrackInfo -> TBQueue (TrackInfo, [Text]) -> IO a-lyricsThread input output = forever $- do trackinfo <- cleanTrack <$> atomically (readTBQueue input)- lyrics <- lyricsPipeline trackinfo- atomically $ writeTBQueue output (trackinfo, lyrics)+import MusicScroll.TrackInfo (TrackInfo(..))+import MusicScroll.TagParsing+import MusicScroll.DatabaseUtils (insertDBLyrics) -lyricsPipeline :: TrackInfo -> IO [Text]-lyricsPipeline (TrackInfo {tArtist, tTitle}) =- do let songUrl = url tArtist tTitle+getLyricsFromWeb :: TrackInfo -> IO Lyrics+getLyricsFromWeb track@(TrackInfo {tArtist, tTitle}) =+ do let songUrl = toUrl tArtist tTitle resp <- try @SomeException (getPage songUrl) let notValid = either (const True) ((/= 200) . responseStatusCode) resp- if notValid then return [ "I failed at getting the lyrics!" ]+ if notValid then empty else let Right realResp = resp- body = decodeUtf8 (responseBody realResp)- in return (extractLyricsFromPage body)+ body = decodeUtf8 (responseBody realResp)+ lyrics = extractLyricsFromPage body+ in forkIO (insertDBLyrics track lyrics) *> return lyrics getPage :: Url 'Https -> IO BsResponse getPage url = runReq defaultHttpConfig $ req GET url NoReqBody bsResponse mempty -url :: Text -> Text -> Url 'Https-url artist song =+toUrl :: Text -> Text -> Url 'Https+toUrl artist song = let base :: Url 'Https base = https "www.azlyrics.com"
src/MusicScroll/ConnState.hs view
@@ -1,25 +1,26 @@ module MusicScroll.ConnState ( ConnState(..) , newConnState- , setSong+ , setBus ) where import DBus (BusName) import DBus.Client (Client) import Control.Concurrent.STM.TBQueue (TBQueue)-import MusicScroll.TrackInfo-+import MusicScroll.TrackInfo (TrackIdentifier)+import MusicScroll.UIEvent (UIEvent) import MusicScroll.DBusNames data ConnState = ConnState { cClient :: Client , cBusActive :: BusName- , cOutChan :: TBQueue TrackInfo- , cLastSentTrack :: Maybe TrackInfo+ , cOutTrackChan :: TBQueue TrackIdentifier+ , cOutEventChan :: TBQueue UIEvent } -newConnState :: TBQueue TrackInfo -> Client -> ConnState-newConnState outChan c = ConnState c vlcBus outChan Nothing+newConnState :: TBQueue TrackIdentifier -> TBQueue UIEvent+ -> Client -> ConnState+newConnState trackCh eventCh c = ConnState c vlcBus trackCh eventCh -setSong :: TrackInfo -> ConnState -> ConnState-setSong track s = s { cLastSentTrack = pure track }+setBus :: BusName -> ConnState -> ConnState+setBus newBus conn = conn { cBusActive = newBus }
src/MusicScroll/DBusSignals.hs view
@@ -48,7 +48,7 @@ availableStatus <- liftIO $ traverse (checkName client) allBuses let taggedBuses = zip allBuses availableStatus case fst <$> find snd taggedBuses of- Just newBus -> modify (\s -> s { cBusActive = newBus })+ Just newBus -> modify (setBus newBus) Nothing -> do waitForChange busNameAddedRule changeMusicClient
+ src/MusicScroll/DatabaseUtils.hs view
@@ -0,0 +1,80 @@+{-# language OverloadedStrings, TypeApplications, RecordWildCards #-}+module MusicScroll.DatabaseUtils+ ( getDBLyrics+ , getDBSong+ , insertDBLyrics+ , getDBPath+ ) where++import Prelude hiding (null)+import Control.Applicative (Alternative(..))+import Control.Exception (bracket, evaluate)+import Control.DeepSeq (rnf)+import Crypto.Hash (SHA1, hashUpdate, hashInit, hashFinalize)+import Data.ByteString (hGet, null)+import System.IO (withFile, IOMode(..))+import Data.Text (Text)+import Database.SQLite.Simple+import System.Environment.XDG.BaseDir (getUserCacheDir)+import Data.Coerce+import System.Directory (createDirectory)++import MusicScroll.TrackInfo (TrackInfo(..), SongFilePath)+import MusicScroll.TagParsing (Lyrics(..))++getDBLyrics :: SongFilePath -> IO Lyrics+getDBLyrics songUrl = snd <$> getDBSong songUrl++getDBSong :: SongFilePath -> IO (TrackInfo, Lyrics)+getDBSong songUrl =+ do songHash <- fileHash songUrl+ dbPath <- getDBPath+ bracket (open dbPath) close $ \conn ->+ do execute_ conn sqlDBCreate+ songRaw <- query conn sqlExtractSong (Only songHash)+ case (songRaw :: [ (Text, Text, Text) ]) of+ [] -> empty+ (title, artist, lyrics):_ ->+ let track = TrackInfo title artist songUrl+ in return (track, coerce lyrics)+++insertDBLyrics :: TrackInfo -> Lyrics -> IO ()+insertDBLyrics (TrackInfo {..}) lyrics =+ do songHash <- fileHash tUrl+ dbPath <- getDBPath+ bracket (open dbPath) close $ \conn ->+ do execute_ conn sqlDBCreate+ let params = (songHash, tArtist, tTitle, coerce lyrics :: Text)+ execute conn sqlInsertSong params++getDBPath :: IO FilePath+getDBPath = do cacheDir <- getUserCacheDir "musicScroll"+ createDirectory cacheDir <|> return ()+ return $ cacheDir ++ "/" ++ "lyrics.db"++-- | We use the exception thrown by withFile.+fileHash :: FilePath -> IO String+fileHash fp = withFile fp ReadMode $ \hdl ->+ let chunkSize = 512 * 1024+ looper ctx =+ do upd <- hGet hdl chunkSize+ if null upd+ then return (show (hashFinalize ctx))+ else do let newCtx = hashUpdate ctx upd+ evaluate (rnf newCtx) -- Important!+ looper newCtx+ in looper (hashInit @SHA1)++sqlDBCreate, sqlInsertSong, sqlExtractSong :: Query+sqlDBCreate =+ "create table if not exists MusicScrollTable(\n\+ \ songHash text primary key,\n\+ \ artist text,\n\+ \ title text, \n\+ \ lyrics text );"++sqlInsertSong = "insert into MusicScrollTable values (?, ?, ?, ?);"++sqlExtractSong =+ "select title, artist, lyrics from MusicScrollTable where songHash == ?;"
+ src/MusicScroll/LyricsPipeline.hs view
@@ -0,0 +1,79 @@+module MusicScroll.LyricsPipeline (lyricsThread, sizeOfQueue) where++-- | Discriminate between getting the lyrics from SQLite or the web.++import Control.Concurrent.Async (withAsync, waitAnyCancel)+import Control.Concurrent.STM (atomically, orElse)+import Control.Concurrent.STM.TBQueue ( TBQueue, readTBQueue, writeTBQueue,+ newTBQueue )+import Control.Applicative (Alternative(..))+import Control.Monad.Trans.State (StateT, get, put, evalStateT)+import Control.Monad.IO.Class (liftIO)+import Control.Monad (forever, when)+import Numeric.Natural (Natural)+import Data.Functor (void)+import Data.Maybe (isJust)++import MusicScroll.DatabaseUtils (getDBLyrics, getDBSong)+import MusicScroll.TrackInfo+import MusicScroll.TrackSuplement+import MusicScroll.AZLyrics (getLyricsFromWeb)+import MusicScroll.UIEvent++sizeOfQueue :: Natural+sizeOfQueue = 5++lyricsThread :: TBQueue TrackIdentifier -> TBQueue TrackSuplement+ -> TBQueue UIEvent -> IO ()+lyricsThread inputIdent inputSupl output =+ do songFilterChan <- atomically (newTBQueue sizeOfQueue)+ let seenSongThread' = seenSongsThread inputIdent inputSupl songFilterChan+ withAsync (evalStateT seenSongThread' Nothing) $ \seenSongsA ->+ withAsync (getLyricsThread songFilterChan output) $ \getLyricsA ->+ void $ waitAnyCancel [seenSongsA, getLyricsA]++-- | This thread works as a model of the MVC pattern. The UI+-- communicates its callbacks to here. The Dbus thread sends what it+-- sees here to no repeat songs.+seenSongsThread :: TBQueue TrackIdentifier -> TBQueue TrackSuplement+ -> TBQueue TrackIdentifier -> StateT (Maybe TrackIdentifier) IO a+seenSongsThread inputIdent inputSupl output = forever $+ do mTrackIdent <- mergeQueue inputIdent inputSupl+ notSeen <- (/=) <$> get <*> pure mTrackIdent+ when (notSeen && isJust mTrackIdent) $ do+ let Just trackIdent = mTrackIdent+ put mTrackIdent+ liftIO . atomically $ writeTBQueue output trackIdent++mergeQueue :: TBQueue TrackIdentifier -> TBQueue TrackSuplement+ -> StateT (Maybe TrackIdentifier) IO (Maybe TrackIdentifier)+mergeQueue inputIdent inputSupl =+ do let cleanInputIdent = cleanTrack <$> readTBQueue inputIdent+ mergedInputChan = (Left <$> cleanInputIdent) `orElse`+ (Right <$> readTBQueue inputSupl)+ mOldTrack <- get+ mergedInput <- liftIO $ atomically mergedInputChan++ let suplement' :: TrackSuplement -> Maybe TrackIdentifier+ suplement' supl = (Right . suplement supl) <$> mOldTrack+ newTrack :: Maybe TrackIdentifier+ newTrack = either Just suplement' mergedInput++ pure newTrack+++getLyricsThread :: TBQueue TrackIdentifier -> TBQueue UIEvent -> IO a+getLyricsThread input output = forever $+ do trackIdent <- atomically (readTBQueue input)+ event <- either caseByPath caseByInfo trackIdent+ atomically $ writeTBQueue output event++caseByInfo :: TrackInfo -> IO UIEvent+caseByInfo track =+ let tryGetLyrics = getDBLyrics (tUrl track) <|> getLyricsFromWeb track+ in (GotLyric track <$> tryGetLyrics) <|> pure (ErrorOn (NoLyricsOnWeb track))++caseByPath :: TrackByPath -> IO UIEvent+caseByPath track =+ ((uncurry GotLyric) <$> getDBSong (tpPath track)) <|>+ pure (ErrorOn (NotOnDB track))
src/MusicScroll/MPRIS.hs view
@@ -3,9 +3,9 @@ import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TBQueue (TBQueue, writeTBQueue) import Control.Exception (bracket)-import Control.Monad (when, (=<<))+import Control.Monad ((=<<), forever) import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.State.Class (gets, modify)+import Control.Monad.State.Class (gets) import Control.Monad.Trans.State (StateT, evalStateT) import DBus.Client@@ -13,25 +13,29 @@ import MusicScroll.TrackInfo import MusicScroll.DBusSignals import MusicScroll.ConnState+import MusicScroll.UIEvent -dbusThread :: TBQueue TrackInfo -> IO a-dbusThread outChan = bracket connectSession disconnect- (evalStateT go . newConnState outChan)+dbusThread :: TBQueue TrackIdentifier -> TBQueue UIEvent -> IO a+dbusThread trackChan eventChan = bracket connectSession disconnect+ (evalStateT loop . newConnState trackChan eventChan) where- 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+ loop :: StateT ConnState IO a+ loop = forever $ do+ mtrack <- liftIO . uncurry tryGetInfo =<<+ (,) <$> gets cClient <*> gets cBusActive+ case mtrack of+ Left (NoMusicClient _) -> changeMusicClient+ Left NoSong -> reportErrorOnUI *> waitForChange mediaPropChangeRule+ (Right trackIdent) -> sendToLyricsPipeline trackIdent+ *> waitForChange mediaPropChangeRule -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)+sendToLyricsPipeline :: TrackIdentifier -> StateT ConnState IO ()+sendToLyricsPipeline trackIdent =+ do outTrackChan <- gets cOutTrackChan+ liftIO . atomically $ writeTBQueue outTrackChan trackIdent++reportErrorOnUI :: StateT ConnState IO ()+reportErrorOnUI =+ do eventChan <- gets cOutEventChan+ let wrapedCause = ErrorOn (ENoSong)+ liftIO . atomically $ writeTBQueue eventChan wrapedCause
src/MusicScroll/RealMain.hs view
@@ -1,24 +1,20 @@-{-# language OverloadedStrings #-} module MusicScroll.RealMain (realMain) where import Control.Concurrent.Async (withAsync, waitAnyCancel) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TBQueue (newTBQueue)-import Numeric.Natural (Natural) import Data.Functor (void) -import MusicScroll.AZLyrics+import MusicScroll.LyricsPipeline import MusicScroll.MPRIS import MusicScroll.UI realMain :: IO () realMain = do dbusSongChan <- atomically (newTBQueue sizeOfQueue)- lyricsChan <- atomically (newTBQueue sizeOfQueue)- withAsync (setupUIThread lyricsChan) $ \setupUIA ->- withAsync (lyricsThread dbusSongChan lyricsChan) $ \lyricsA ->- withAsync (dbusThread dbusSongChan) $ \dbusA ->+ eventChan <- atomically (newTBQueue sizeOfQueue)+ suplChan <- atomically (newTBQueue sizeOfQueue)+ withAsync (setupUIThread eventChan suplChan) $ \setupUIA ->+ withAsync (lyricsThread dbusSongChan suplChan eventChan) $ \lyricsA ->+ withAsync (dbusThread dbusSongChan eventChan) $ \dbusA -> void $ waitAnyCancel [setupUIA, lyricsA, dbusA]--sizeOfQueue :: Natural-sizeOfQueue = 5
src/MusicScroll/TagParsing.hs view
@@ -1,19 +1,21 @@ {-# language OverloadedStrings #-}-module MusicScroll.TagParsing (extractLyricsFromPage) where+module MusicScroll.TagParsing (Lyrics(..), extractLyricsFromPage) where import qualified Data.Char as C import Data.Text (Text) import Data.Text as T hiding (filter, tail, map) import Text.HTML.TagSoup -extractLyricsFromPage :: Text -> [Text]+newtype Lyrics = Lyrics Text++extractLyricsFromPage :: Text -> Lyrics extractLyricsFromPage page = let stream = parseTags page pass1 = flip filter stream (\t -> (not (isScript t)) && noEmptyText t && validTags t) stream2 = zip3 pass1 (tail pass1) (tail (tail pass1)) pass2 = map (\(t, _, _) -> t) $ filter isStrophe stream2- in cleanOut pass2+ in Lyrics . T.unlines . cleanOut $ pass2 -- Pass 1 validTags, noEmptyText :: Tag Text -> Bool
src/MusicScroll/TrackInfo.hs view
@@ -1,15 +1,20 @@ {-# language OverloadedStrings, NamedFieldPuns #-} module MusicScroll.TrackInfo- ( tryGetInfo- , TrackInfo(..)+ ( TrackInfo(..)+ , TrackByPath(..)+ , TrackIdentifier , TrackInfoError(..)+ , SongFilePath+ , tryGetInfo , cleanTrack ) where +import Prelude hiding (readFile, lookup)+import Control.Applicative (Alternative(..)) import Control.Monad (join) import DBus import DBus.Client-import Data.Bifunctor (first)+import Data.Bifunctor (first, bimap) import Data.Function ((&)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map@@ -22,14 +27,25 @@ data TrackInfo = TrackInfo { tTitle :: Text , tArtist :: Text -- xesam:artist is weird+ , tUrl :: SongFilePath } deriving (Eq, Show) -- TODO: better eq instance -data TrackInfoError = NoMusicClient MethodError | NoMetadata+data TrackByPath = TrackByPath+ { tpPath :: SongFilePath+ , tpTitle :: Maybe Text -- Best effort+ , tpArtist :: Maybe Text -- Best effort+ } deriving (Eq, Show) +type SongFilePath = FilePath+type TrackIdentifier = Either TrackByPath TrackInfo++data TrackInfoError = NoMusicClient MethodError+ | NoSong+ -- 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 -> BusName -> IO (Either TrackInfoError TrackInfo)+tryGetInfo :: Client -> BusName -> IO (Either TrackInfoError TrackIdentifier) tryGetInfo client busName = do metadata <- getPropertyValue client (methodCall mediaObject mediaInterface "Metadata") {@@ -37,13 +53,25 @@ } & fmap (first NoMusicClient) return . join $ obtainTrackInfo <$> metadata -obtainTrackInfo :: Map Text Variant -> Either TrackInfoError TrackInfo+obtainTrackInfo :: Map Text Variant -> Either TrackInfoError TrackIdentifier obtainTrackInfo metadata =- let lookup name = Map.lookup name metadata >>= fromVariant- track = TrackInfo <$> lookup "xesam:title" <*>- xesamArtistFix (lookup "xesam:artist") (lookup "xesam:artist")- in maybe (Left NoMetadata) pure track+ let lookup :: IsVariant a => Text -> Maybe a+ lookup name = Map.lookup name metadata >>= fromVariant + mTitle = lookup "xesam:title"+ mArtist = xesamArtistFix (lookup "xesam:artist") (lookup "xesam:artist")+ mUrl = vlcFix <$> lookup "xesam:url"++ trackInfo :: Maybe TrackInfo+ trackInfo = TrackInfo <$> mTitle <*> mArtist <*> mUrl++ trackByPath :: Maybe TrackByPath+ trackByPath = TrackByPath <$> mUrl <*> pure mTitle <*> pure mArtist++ trackIdent :: Maybe TrackIdentifier+ trackIdent = (Right <$> trackInfo) <|> (Left <$> trackByPath)+ in maybe (Left NoSong) Right trackIdent+ -- 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@@ -51,10 +79,15 @@ xesamArtistFix Nothing (Just arr) | (title : _) <- arr = pure title xesamArtistFix _ _ = Nothing -cleanTrack :: TrackInfo -> TrackInfo-cleanTrack t@(TrackInfo {tTitle}) = t { tTitle = cleanTitle tTitle }+cleanTrack :: TrackIdentifier -> TrackIdentifier+cleanTrack = bimap+ (\byPath -> byPath { tpTitle = cleanTitle <$> (tpTitle byPath) })+ (\track -> track { tTitle = cleanTitle (tTitle track) }) --- Remove .mp3 and numbers from the title.+-- | This functions does two main things:+-- 1. Remove format at the end, ie .mp3, .opus etc.+-- 2. Remove the leading order separators, ie "05 - song name" ->+-- "song name" cleanTitle :: Text -> Text cleanTitle title0 = let (title1, format) = first T.init $ T.breakOnEnd "." title0@@ -63,3 +96,6 @@ musicFormats :: [Text] musicFormats = ["mp3", "flac", "ogg", "wav", "acc", "opus", "webm"]++vlcFix :: SongFilePath -> SongFilePath+vlcFix = T.unpack . T.replace "%20" " " . T.replace "file://" "" . T.pack
+ src/MusicScroll/TrackSuplement.hs view
@@ -0,0 +1,22 @@+module MusicScroll.TrackSuplement where++import Data.Text++import MusicScroll.TrackInfo ( TrackInfo(..), TrackByPath(..)+ , TrackIdentifier )++data TrackSuplement = TrackSuplement+ { tsTitle :: Text+ , tsArtist :: Text+ }++suplement :: TrackSuplement -> TrackIdentifier -> TrackInfo+suplement supl = either byPath byInfo+ where+ byPath :: TrackByPath -> TrackInfo+ byPath path = TrackInfo { tTitle = tsTitle supl+ , tArtist = tsArtist supl+ , tUrl = tpPath path }++ byInfo :: TrackInfo -> TrackInfo+ byInfo info = info { tTitle = tsTitle supl, tArtist = tsArtist supl}
src/MusicScroll/UI.hs view
@@ -1,38 +1,31 @@-{-# language NamedFieldPuns, RecordWildCards, OverloadedStrings,- BangPatterns #-}+{-# language RecordWildCards, OverloadedStrings #-} module MusicScroll.UI (setupUIThread) where import Control.Concurrent.Async (withAsyncBound, waitAnyCancel, withAsync) import Control.Concurrent.STM (atomically)-import Control.Concurrent.STM.TBQueue (TBQueue, readTBQueue)+import Control.Concurrent.STM.TBQueue (TBQueue, readTBQueue, writeTBQueue) import Control.Concurrent.STM.TMVar (TMVar, newEmptyTMVar, takeTMVar, putTMVar) import Control.Exception (throwIO, AsyncException(UserInterrupt)) import Control.Monad (forever) import Data.Functor (void)-import Data.GI.Gtk.Threading- (setCurrentThreadAsGUIThread, postGUISync)+import Data.GI.Gtk.Threading (setCurrentThreadAsGUIThread) import Data.Maybe (fromJust)-import Data.Text (Text)-import Data.Text as T+import Data.Text (pack) import qualified GI.Gtk as Gtk-import MusicScroll.TrackInfo (TrackInfo(..)) +import MusicScroll.TrackSuplement+import MusicScroll.UIEvent+ import Paths_musicScroll -data AppContext = AppContext- { mainWindow :: Gtk.Window- , titleLabel :: Gtk.Label- , artistLabel :: Gtk.Label- , lyricsTextView :: Gtk.TextView- } -- Remember to use Gtk.init Nothing before calling this. getGtkScene :: IO AppContext getGtkScene = do file <- getDataFileName "app.glade"- builder <- Gtk.builderNewFromFile (T.pack file)+ builder <- Gtk.builderNewFromFile (pack file) -- We *know* these ids are defined let getWidget wid id = Gtk.builderGetObject builder id@@ -41,36 +34,44 @@ <*> getWidget Gtk.Label "titleLabel" <*> getWidget Gtk.Label "artistLabel" <*> getWidget Gtk.TextView "lyricsTextView"+ <*> getWidget Gtk.Label "errorLabel"+ <*> getWidget Gtk.Entry "titleSuplementEntry"+ <*> getWidget Gtk.Entry "artistSuplementEntry"+ <*> getWidget Gtk.Button "suplementAcceptButton"+ <*> getWidget Gtk.CheckButton "keepArtistNameCheck" -setupUIThread :: TBQueue (TrackInfo, [Text]) -> IO ()-setupUIThread trackUpdates =+setupUIThread :: TBQueue UIEvent -> TBQueue TrackSuplement -> IO ()+setupUIThread events outSupl = do appCtxMVar <- atomically newEmptyTMVar- withAsyncBound (uiThread appCtxMVar) $ \a1 ->- withAsync (uiUpdateThread trackUpdates appCtxMVar) $ \a2 ->+ withAsyncBound (uiThread appCtxMVar outSupl) $ \a1 ->+ withAsync (uiUpdateThread events appCtxMVar) $ \a2 -> void (waitAnyCancel [a1, a2]) >> throwIO UserInterrupt -uiThread :: TMVar AppContext -> IO ()-uiThread ctxMVar = do+uiThread :: TMVar AppContext -> TBQueue TrackSuplement -> IO ()+uiThread ctxMVar outSupl = do setCurrentThreadAsGUIThread _ <- Gtk.init Nothing appCtx@(AppContext {..}) <- getGtkScene atomically (putTMVar ctxMVar appCtx) Gtk.labelSetText titleLabel "MusicScroll" Gtk.widgetShowAll mainWindow+ _ <- Gtk.onButtonClicked suplementAcceptButton $+ sendSuplementalInfo appCtx outSupl _ <- Gtk.onWidgetDestroy mainWindow Gtk.mainQuit Gtk.main ----uiUpdateThread :: TBQueue (TrackInfo, [Text]) -> TMVar AppContext -> IO a+uiUpdateThread :: TBQueue UIEvent -> TMVar AppContext -> IO a uiUpdateThread input ctxMVar = do- AppContext {..} <- atomically (takeTMVar ctxMVar)- forever $- do (track, lyrics) <- atomically (readTBQueue input)- let !singleLyrics = T.unlines lyrics- !bytesToUpdate = fromIntegral $ T.length singleLyrics- postGUISync $ do- Gtk.labelSetText titleLabel (tTitle track)- Gtk.labelSetText artistLabel (tArtist track)- lyricsBuffer <- Gtk.textViewGetBuffer lyricsTextView- Gtk.textBufferSetText lyricsBuffer singleLyrics bytesToUpdate+ appCtx <- atomically (takeTMVar ctxMVar)+ forever $ do+ event <- atomically (readTBQueue input)+ case event of+ GotLyric track lyrics -> updateNewLyrics appCtx (track, lyrics)+ ErrorOn cause -> updateErrorCause appCtx cause +sendSuplementalInfo :: AppContext -> TBQueue TrackSuplement -> IO ()+sendSuplementalInfo (AppContext {..}) suplChan =+ do trackSupl <- TrackSuplement <$> Gtk.entryGetText titleSuplementEntry+ <*> Gtk.entryGetText artistSuplementEntry+ atomically (writeTBQueue suplChan trackSupl)
+ src/MusicScroll/UIEvent.hs view
@@ -0,0 +1,76 @@+{-# language OverloadedStrings, RecordWildCards, BangPatterns #-}+module MusicScroll.UIEvent where++import Control.Monad (unless)+import Data.Maybe (isNothing)+import Data.Text (Text)+import Data.Text as T+import qualified GI.Gtk as Gtk+import Data.GI.Gtk.Threading (postGUISync)++import MusicScroll.TrackInfo (TrackInfo(..), TrackByPath(..))+import MusicScroll.TagParsing (Lyrics(..))++data UIEvent = GotLyric TrackInfo Lyrics+ | ErrorOn ErrorCause++data ErrorCause = NotOnDB TrackByPath | NoLyricsOnWeb TrackInfo | ENoSong++data AppContext = AppContext+ { mainWindow :: Gtk.Window+ , titleLabel :: Gtk.Label+ , artistLabel :: Gtk.Label+ , lyricsTextView :: Gtk.TextView+ , errorLabel :: Gtk.Label+ , titleSuplementEntry :: Gtk.Entry+ , artistSuplementEntry :: Gtk.Entry+ , suplementAcceptButton :: Gtk.Button+ , keepArtistNameCheck :: Gtk.CheckButton+ }++errorMsg :: ErrorCause -> Text+errorMsg (NotOnDB trackPath)+ | isNothing (tpArtist trackPath) =+ "No lyrics found by hash on the song file, try to suplement the song's\+ \ artist metadata to try to get it from the web."+ | isNothing (tpTitle trackPath) =+ "No lyrics found by hash on the song file, try to suplement the song's\+ \ title metadata to try to get it from the web."+ | otherwise = "This case should not happen"+errorMsg ENoSong = "No song found, this is usually an intermediary state."+errorMsg (NoLyricsOnWeb _) = "Lyrics provider didn't have that song."++extractGuess :: ErrorCause -> Maybe (Text, Text)+extractGuess (NoLyricsOnWeb (TrackInfo {..})) =+ pure (tTitle, tArtist)+extractGuess (NotOnDB (TrackByPath {..})) =+ let def = maybe mempty id in pure (def tpTitle, def tpArtist)+extractGuess _ = Nothing++-- | Only usable inside a gtk context+updateNewLyrics :: AppContext -> (TrackInfo, Lyrics) -> IO ()+updateNewLyrics ctx@(AppContext {..}) (track, Lyrics singleLyrics) =+ let !bytesToUpdate = fromIntegral $ T.length singleLyrics+ in postGUISync $ do+ Gtk.labelSetText errorLabel mempty+ Gtk.labelSetText titleLabel (tTitle track)+ Gtk.labelSetText artistLabel (tArtist track)+ lyricsBuffer <- Gtk.textViewGetBuffer lyricsTextView+ Gtk.textBufferSetText lyricsBuffer singleLyrics bytesToUpdate+ updateSuplementalGuess ctx (mempty, mempty)++updateErrorCause :: AppContext -> ErrorCause -> IO ()+updateErrorCause ctx@(AppContext {..}) cause = postGUISync $+ do Gtk.labelSetText titleLabel "No Song available"+ Gtk.labelSetText artistLabel mempty+ lyricsBuffer <- Gtk.textViewGetBuffer lyricsTextView+ Gtk.textBufferSetText lyricsBuffer mempty 0+ Gtk.labelSetText errorLabel (errorMsg cause)+ maybe (return ()) (updateSuplementalGuess ctx) (extractGuess cause)++updateSuplementalGuess :: AppContext -> (Text, Text) -> IO ()+updateSuplementalGuess (AppContext {..}) (guessTitle, guessArtist) =+ do Gtk.entrySetText titleSuplementEntry guessTitle+ shouldMaintainArtistSupl <- Gtk.getToggleButtonActive keepArtistNameCheck+ unless shouldMaintainArtistSupl $+ Gtk.entrySetText artistSuplementEntry guessArtist