diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -29,3 +29,5 @@ 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. + +I accept donations <3, the COVID-19 certainly affected me economically!. 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.2.0.0 +version: 0.2.1.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 diff --git a/resources/app.glade b/resources/app.glade --- a/resources/app.glade +++ b/resources/app.glade @@ -58,6 +58,7 @@ True True + True 3 6 True diff --git a/src/MusicScroll/AZLyrics.hs b/src/MusicScroll/AZLyrics.hs --- a/src/MusicScroll/AZLyrics.hs +++ b/src/MusicScroll/AZLyrics.hs @@ -3,27 +3,29 @@ import Control.Exception (try, SomeException) import Control.Applicative (Alternative(empty)) +import Control.Monad.Trans.Reader (ReaderT) +import Control.Monad.IO.Class (MonadIO(..)) import Data.Text (Text) import Data.Text as T hiding (filter, tail, map, empty) import Data.Text.Encoding (decodeUtf8) import Network.HTTP.Req -import Control.Concurrent (forkIO) +import Database.SQLite.Simple (Connection) import MusicScroll.TrackInfo (TrackInfo(..)) import MusicScroll.TagParsing import MusicScroll.DatabaseUtils (insertDBLyrics) -getLyricsFromWeb :: TrackInfo -> IO Lyrics +getLyricsFromWeb :: TrackInfo -> ReaderT Connection IO Lyrics getLyricsFromWeb track@(TrackInfo {tArtist, tTitle}) = do let songUrl = toUrl tArtist tTitle - resp <- try @SomeException (getPage songUrl) + resp <- liftIO $ try @SomeException (getPage songUrl) let notValid = either (const True) ((/= 200) . responseStatusCode) resp if notValid then empty else let Right realResp = resp body = decodeUtf8 (responseBody realResp) lyrics = extractLyricsFromPage body - in forkIO (insertDBLyrics track lyrics) *> return lyrics + in insertDBLyrics track lyrics *> pure lyrics getPage :: Url 'Https -> IO BsResponse getPage url = runReq defaultHttpConfig $ diff --git a/src/MusicScroll/DatabaseUtils.hs b/src/MusicScroll/DatabaseUtils.hs --- a/src/MusicScroll/DatabaseUtils.hs +++ b/src/MusicScroll/DatabaseUtils.hs @@ -4,11 +4,14 @@ , getDBSong , insertDBLyrics , getDBPath + , sqlDBCreate ) where import Prelude hiding (null) import Control.Applicative (Alternative(..)) -import Control.Exception (bracket, evaluate) +import Control.Exception (evaluate) +import Control.Monad.Trans.Reader (ReaderT, ask) +import Control.Monad.IO.Class (MonadIO(..)) import Control.DeepSeq (rnf) import Crypto.Hash (SHA1, hashUpdate, hashInit, hashFinalize) import Data.ByteString (hGet, null) @@ -22,31 +25,28 @@ import MusicScroll.TrackInfo (TrackInfo(..), SongFilePath) import MusicScroll.TagParsing (Lyrics(..)) -getDBLyrics :: SongFilePath -> IO Lyrics +getDBLyrics :: SongFilePath -> ReaderT Connection IO Lyrics getDBLyrics songUrl = snd <$> getDBSong songUrl -getDBSong :: SongFilePath -> IO (TrackInfo, Lyrics) +getDBSong :: SongFilePath -> ReaderT Connection 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) - + do conn <- ask + liftIO $ do + songHash <- fileHash songUrl + 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 -> ReaderT Connection 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 + do conn <- ask + liftIO $ do + songHash <- fileHash tUrl + let params = (songHash, tArtist, tTitle, coerce lyrics :: Text) + execute conn sqlInsertSong params getDBPath :: IO FilePath getDBPath = do cacheDir <- getUserCacheDir "musicScroll" diff --git a/src/MusicScroll/LyricsPipeline.hs b/src/MusicScroll/LyricsPipeline.hs --- a/src/MusicScroll/LyricsPipeline.hs +++ b/src/MusicScroll/LyricsPipeline.hs @@ -7,14 +7,17 @@ import Control.Concurrent.STM.TBQueue ( TBQueue, readTBQueue, writeTBQueue, newTBQueue ) import Control.Applicative (Alternative(..)) +import Control.Exception (bracket) import Control.Monad.Trans.State (StateT, get, put, evalStateT) import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Control.Monad (forever, when) import Numeric.Natural (Natural) import Data.Functor (void) import Data.Maybe (isJust) +import Database.SQLite.Simple -import MusicScroll.DatabaseUtils (getDBLyrics, getDBSong) +import MusicScroll.DatabaseUtils import MusicScroll.TrackInfo import MusicScroll.TrackSuplement import MusicScroll.AZLyrics (getLyricsFromWeb) @@ -61,19 +64,23 @@ 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 +getLyricsThread input output = + do dbPath <- getDBPath + bracket (open dbPath) close $ \conn -> do + execute_ conn sqlDBCreate + forever $ + do trackIdent <- atomically (readTBQueue input) + event <- flip runReaderT conn $ + either caseByPath caseByInfo trackIdent + atomically $ writeTBQueue output event -caseByInfo :: TrackInfo -> IO UIEvent +caseByInfo :: TrackInfo -> ReaderT Connection IO UIEvent caseByInfo track = let tryGetLyrics = getDBLyrics (tUrl track) <|> getLyricsFromWeb track in (GotLyric track <$> tryGetLyrics) <|> pure (ErrorOn (NoLyricsOnWeb track)) -caseByPath :: TrackByPath -> IO UIEvent +caseByPath :: TrackByPath -> ReaderT Connection IO UIEvent caseByPath track = ((uncurry GotLyric) <$> getDBSong (tpPath track)) <|> pure (ErrorOn (NotOnDB track)) diff --git a/src/MusicScroll/UI.hs b/src/MusicScroll/UI.hs --- a/src/MusicScroll/UI.hs +++ b/src/MusicScroll/UI.hs @@ -10,11 +10,13 @@ import Control.Exception (throwIO, AsyncException(UserInterrupt)) import Control.Monad (forever) import Data.Functor (void) +import Data.Maybe (isNothing) import Data.GI.Gtk.Threading (setCurrentThreadAsGUIThread) import Data.Maybe (fromJust) import Data.Text (pack) import qualified GI.Gtk as Gtk +import MusicScroll.TrackInfo (TrackByPath(tpArtist)) import MusicScroll.TrackSuplement import MusicScroll.UIEvent @@ -44,7 +46,7 @@ setupUIThread events outSupl = do appCtxMVar <- atomically newEmptyTMVar withAsyncBound (uiThread appCtxMVar outSupl) $ \a1 -> - withAsync (uiUpdateThread events appCtxMVar) $ \a2 -> + withAsync (uiUpdateThread events outSupl appCtxMVar) $ \a2 -> void (waitAnyCancel [a1, a2]) >> throwIO UserInterrupt uiThread :: TMVar AppContext -> TBQueue TrackSuplement -> IO () @@ -61,17 +63,30 @@ Gtk.main --- -uiUpdateThread :: TBQueue UIEvent -> TMVar AppContext -> IO a -uiUpdateThread input ctxMVar = do +uiUpdateThread :: TBQueue UIEvent -> TBQueue TrackSuplement + -> TMVar AppContext -> IO a +uiUpdateThread input outSupl ctxMVar = do 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 + *> tryDefaultSupplement appCtx cause outSupl sendSuplementalInfo :: AppContext -> TBQueue TrackSuplement -> IO () sendSuplementalInfo (AppContext {..}) suplChan = do trackSupl <- TrackSuplement <$> Gtk.entryGetText titleSuplementEntry <*> Gtk.entryGetText artistSuplementEntry atomically (writeTBQueue suplChan trackSupl) + +tryDefaultSupplement + :: AppContext -> ErrorCause -> TBQueue TrackSuplement -> IO () +tryDefaultSupplement ctx@(AppContext {..}) cause suplChan = + do shouldMaintainArtistSupl <- Gtk.getToggleButtonActive keepArtistNameCheck + validGuessArtist <- (/= mempty) <$> Gtk.entryGetText artistSuplementEntry + case cause of + NotOnDB track + | isNothing (tpArtist track), shouldMaintainArtistSupl, + validGuessArtist -> sendSuplementalInfo ctx suplChan + _ -> return ()