diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,32 +1,31 @@ # MusicScroll -![Basic program for basic needs](https://i.imgur.com/BEa6RzJ.png) +![Basic program for basic needs](https://i.imgur.com/Jk5kmYQ.png) 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. diff --git a/musicScroll.cabal b/musicScroll.cabal --- a/musicScroll.cabal +++ b/musicScroll.cabal @@ -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 diff --git a/resources/app.glade b/resources/app.glade --- a/resources/app.glade +++ b/resources/app.glade @@ -2,7 +2,6 @@ - False @@ -15,9 +14,20 @@ True True - + True False + Error message + + + 0 + 2 + + + + + True + False 10 10 True @@ -64,7 +74,7 @@ natural False center - textbuffer1 + False @@ -72,6 +82,91 @@ 0 2 + + + + 0 + 1 + + + + + True + True + + + True + False + vertical + + + True + True + Title + + + False + True + 0 + + + + + True + True + Artist + + + False + True + 1 + + + + + True + False + 5 + + + Search + True + True + True + + + 0 + 0 + + + + + Keep artist name + True + True + False + True + + + 1 + 0 + + + + + False + True + 2 + + + + + + + True + False + Suplement info + diff --git a/shell.nix b/shell.nix --- a/shell.nix +++ b/shell.nix @@ -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; diff --git a/src/MusicScroll/AZLyrics.hs b/src/MusicScroll/AZLyrics.hs --- a/src/MusicScroll/AZLyrics.hs +++ b/src/MusicScroll/AZLyrics.hs @@ -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" diff --git a/src/MusicScroll/ConnState.hs b/src/MusicScroll/ConnState.hs --- a/src/MusicScroll/ConnState.hs +++ b/src/MusicScroll/ConnState.hs @@ -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 } diff --git a/src/MusicScroll/DBusSignals.hs b/src/MusicScroll/DBusSignals.hs --- a/src/MusicScroll/DBusSignals.hs +++ b/src/MusicScroll/DBusSignals.hs @@ -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 diff --git a/src/MusicScroll/DatabaseUtils.hs b/src/MusicScroll/DatabaseUtils.hs new file mode 100644 --- /dev/null +++ b/src/MusicScroll/DatabaseUtils.hs @@ -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 == ?;" diff --git a/src/MusicScroll/LyricsPipeline.hs b/src/MusicScroll/LyricsPipeline.hs new file mode 100644 --- /dev/null +++ b/src/MusicScroll/LyricsPipeline.hs @@ -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)) diff --git a/src/MusicScroll/MPRIS.hs b/src/MusicScroll/MPRIS.hs --- a/src/MusicScroll/MPRIS.hs +++ b/src/MusicScroll/MPRIS.hs @@ -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 diff --git a/src/MusicScroll/RealMain.hs b/src/MusicScroll/RealMain.hs --- a/src/MusicScroll/RealMain.hs +++ b/src/MusicScroll/RealMain.hs @@ -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 diff --git a/src/MusicScroll/TagParsing.hs b/src/MusicScroll/TagParsing.hs --- a/src/MusicScroll/TagParsing.hs +++ b/src/MusicScroll/TagParsing.hs @@ -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 diff --git a/src/MusicScroll/TrackInfo.hs b/src/MusicScroll/TrackInfo.hs --- a/src/MusicScroll/TrackInfo.hs +++ b/src/MusicScroll/TrackInfo.hs @@ -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 diff --git a/src/MusicScroll/TrackSuplement.hs b/src/MusicScroll/TrackSuplement.hs new file mode 100644 --- /dev/null +++ b/src/MusicScroll/TrackSuplement.hs @@ -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} diff --git a/src/MusicScroll/UI.hs b/src/MusicScroll/UI.hs --- a/src/MusicScroll/UI.hs +++ b/src/MusicScroll/UI.hs @@ -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) diff --git a/src/MusicScroll/UIEvent.hs b/src/MusicScroll/UIEvent.hs new file mode 100644 --- /dev/null +++ b/src/MusicScroll/UIEvent.hs @@ -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