diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for music-scroll +# 0.3.0.0 + +* `Pipes` based code. + # 0.2.3.3 * On low bandwith conditions, don't keep downloading the previous song 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.3.3 +version: 0.3.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 @@ -51,18 +51,23 @@ cryptonite, bytestring, directory, - deepseq + deepseq, + pipes, + pipes-concurrency, + contravariant exposed-modules: MusicScroll.RealMain other-modules: MusicScroll.UI MusicScroll.MPRIS MusicScroll.Web MusicScroll.LyricsPipeline MusicScroll.TrackInfo - MusicScroll.UIEvent + MusicScroll.UIContext MusicScroll.DBusNames MusicScroll.DBusSignals MusicScroll.ConnState MusicScroll.DatabaseUtils + MusicScroll.EventLoop + MusicScroll.Pipeline MusicScroll.TrackSuplement MusicScroll.Providers.AZLyrics MusicScroll.Providers.MusiXMatch diff --git a/shell.nix b/shell.nix --- a/shell.nix +++ b/shell.nix @@ -7,11 +7,11 @@ 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 + , xdg-basedir, pipes, pipes-concurrency }: mkDerivation { pname = "musicScroll"; - version = "0.1.2.0"; + version = "0.3.0.0"; src = ./.; isLibrary = true; isExecutable = true; @@ -19,7 +19,7 @@ libraryHaskellDepends = [ async base bytestring containers cryptonite dbus directory gi-gtk gi-gtk-hs mtl req sqlite-simple stm tagsoup text transformers - xdg-basedir + xdg-basedir pipes pipes-concurrency ]; executableHaskellDepends = [ base ]; executablePkgconfigDepends = [ gtk3 ]; diff --git a/src/MusicScroll/ConnState.hs b/src/MusicScroll/ConnState.hs --- a/src/MusicScroll/ConnState.hs +++ b/src/MusicScroll/ConnState.hs @@ -1,26 +1,13 @@ -module MusicScroll.ConnState - ( ConnState(..) - , newConnState - , setBus - ) where +module MusicScroll.ConnState where import DBus (BusName) import DBus.Client (Client) -import Control.Concurrent.STM.TBQueue (TBQueue) -import MusicScroll.TrackInfo (TrackIdentifier) -import MusicScroll.UIEvent (UIEvent) import MusicScroll.DBusNames data ConnState = ConnState - { cClient :: Client - , cBusActive :: BusName - , cOutTrackChan :: TBQueue TrackIdentifier - , cOutEventChan :: TBQueue UIEvent + { cpClient :: Client + , cpBusActive :: BusName } -newConnState :: TBQueue TrackIdentifier -> TBQueue UIEvent - -> Client -> ConnState -newConnState trackCh eventCh c = ConnState c vlcBus trackCh eventCh - -setBus :: BusName -> ConnState -> ConnState -setBus newBus conn = conn { cBusActive = newBus } +newConnState :: Client -> ConnState +newConnState c = ConnState c vlcBus diff --git a/src/MusicScroll/DBusSignals.hs b/src/MusicScroll/DBusSignals.hs --- a/src/MusicScroll/DBusSignals.hs +++ b/src/MusicScroll/DBusSignals.hs @@ -1,4 +1,4 @@ -{-# language OverloadedStrings #-} +{-# language OverloadedStrings, FlexibleContexts #-} module MusicScroll.DBusSignals ( mediaPropChangeRule , waitForChange @@ -7,10 +7,10 @@ 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 Control.Monad.State.Class (MonadState(..)) import Data.Foldable (find) import Data.Maybe (fromJust) +import Pipes import DBus.Client import DBus @@ -29,26 +29,25 @@ , 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 +waitForChange :: (MonadState ConnState m, MonadIO m) => MatchRule -> m () +waitForChange rule = do + (ConnState client _) <- get + 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 :: (MonadState ConnState m, MonadIO m) => m () changeMusicClient = - do client <- gets cClient + do (ConnState client _) <- get availableStatus <- liftIO $ traverse (checkName client) allBuses let taggedBuses = zip allBuses availableStatus case fst <$> find snd taggedBuses of - Just newBus -> modify (setBus newBus) + Just newBus -> put (ConnState client newBus) Nothing -> do waitForChange busNameAddedRule changeMusicClient diff --git a/src/MusicScroll/DatabaseUtils.hs b/src/MusicScroll/DatabaseUtils.hs --- a/src/MusicScroll/DatabaseUtils.hs +++ b/src/MusicScroll/DatabaseUtils.hs @@ -2,9 +2,9 @@ module MusicScroll.DatabaseUtils ( getDBLyrics , getDBSong + , sqlDBCreate , insertDBLyrics , getDBPath - , sqlDBCreate ) where import Prelude hiding (null) @@ -12,6 +12,7 @@ import Control.Exception (evaluate) import Control.Monad.Trans.Reader (ReaderT, ask) import Control.Monad.IO.Class (MonadIO(..)) +import Control.Concurrent.MVar import Control.DeepSeq (rnf) import Crypto.Hash (SHA1, hashUpdate, hashInit, hashFinalize) import Data.ByteString (hGet, null) @@ -25,29 +26,34 @@ import MusicScroll.TrackInfo (TrackInfo(..), SongFilePath) import MusicScroll.Providers.Utils (Lyrics(..)) -getDBLyrics :: SongFilePath -> ReaderT Connection IO Lyrics +getDBLyrics :: SongFilePath -> ReaderT (MVar Connection) IO Lyrics getDBLyrics songUrl = snd <$> getDBSong songUrl -getDBSong :: SongFilePath -> ReaderT Connection IO (TrackInfo, Lyrics) -getDBSong songUrl = - 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) +getDBSong :: SongFilePath -> ReaderT (MVar Connection) IO (TrackInfo, Lyrics) +getDBSong songUrl = ask >>= \mconn -> liftIO $ + do songHash <- fileHash songUrl + songRaw <- withMVar mconn + (\conn -> query conn sqlExtractSong (Only songHash)) + case (songRaw :: [ (Text, Text, Text) ]) of + [] -> empty + (title, artist, lyrics):_ -> + let track = TrackInfo title artist songUrl + in pure (track, coerce lyrics) -insertDBLyrics :: TrackInfo -> Lyrics -> ReaderT Connection IO () +insertDBLyrics :: TrackInfo -> Lyrics -> ReaderT (MVar Connection) IO () insertDBLyrics (TrackInfo {..}) lyrics = - do conn <- ask - liftIO $ do - songHash <- fileHash tUrl + ask >>= \mconn -> liftIO $ + do songHash <- fileHash tUrl let params = (songHash, tArtist, tTitle, coerce lyrics :: Text) - execute conn sqlInsertSong params + withMVar mconn $ \conn -> execute conn sqlInsertSong params + +updateDBLyrics :: TrackInfo -> Lyrics -> ReaderT Connection IO () +updateDBLyrics (TrackInfo {..}) lyrics = ask >>= \conn -> liftIO $ + do songHash <- fileHash tUrl + let params = (coerce lyrics :: Text, songHash) + execute conn sqlUpdateSong params + getDBPath :: IO FilePath getDBPath = do cacheDir <- getUserCacheDir "musicScroll" createDirectory cacheDir <|> return () @@ -66,7 +72,7 @@ looper newCtx in looper (hashInit @SHA1) -sqlDBCreate, sqlInsertSong, sqlExtractSong :: Query +sqlDBCreate, sqlInsertSong, sqlExtractSong, sqlUpdateSong :: Query sqlDBCreate = "create table if not exists MusicScrollTable(\n\ \ songHash text primary key,\n\ @@ -78,3 +84,6 @@ sqlExtractSong = "select title, artist, lyrics from MusicScrollTable where songHash == ?;" + +sqlUpdateSong = + "update MusicScrollTable set lyrics = ? where songHash = ? ;" diff --git a/src/MusicScroll/EventLoop.hs b/src/MusicScroll/EventLoop.hs new file mode 100644 --- /dev/null +++ b/src/MusicScroll/EventLoop.hs @@ -0,0 +1,22 @@ +module MusicScroll.EventLoop where + +import Control.Concurrent.Async +import Control.Concurrent.STM + +import MusicScroll.Pipeline + +-- | This callbacks ought to update the UI themselves via postGUI +type UICallback = AppState -> IO () + +data EventLoopState = EventLoopState + { evAppState :: AppState + , evUiCallbacks :: TBQueue UICallback + , evEphemeral :: Maybe (Async ()) } + +eventLoop :: EventLoopState -> IO a +eventLoop st = + do newCallback <- atomically . readTBQueue $ evUiCallbacks st + maybe (pure ()) cancel (evEphemeral st) + newAsync <- async (newCallback (evAppState st)) + let st' = st { evEphemeral = Just newAsync } + eventLoop st' diff --git a/src/MusicScroll/LyricsPipeline.hs b/src/MusicScroll/LyricsPipeline.hs --- a/src/MusicScroll/LyricsPipeline.hs +++ b/src/MusicScroll/LyricsPipeline.hs @@ -1,91 +1,74 @@ -module MusicScroll.LyricsPipeline (lyricsThread, sizeOfQueue) where +module MusicScroll.LyricsPipeline + ( SongByOrigin(..) + , SearchResult(..) + , ErrorCause(..) + , noRepeatedSongs + , getLyricsFromAnywhere + , getLyricsOnlyFromWeb + , saveOnDb + ) where -- | Discriminate between getting the lyrics from SQLite or the web. -import Control.Concurrent.Async (async, cancel, concurrently_) -import Control.Concurrent.STM (atomically, orElse) -import Control.Concurrent.STM.TBQueue ( TBQueue, readTBQueue, writeTBQueue, - newTBQueue ) +import Control.Concurrent.MVar 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.Maybe (isJust) import Database.SQLite.Simple +import Pipes +import qualified Pipes.Prelude as PP import MusicScroll.DatabaseUtils import MusicScroll.TrackInfo -import MusicScroll.TrackSuplement -import MusicScroll.Web (getLyricsFromWeb) +import MusicScroll.Web +import MusicScroll.Providers.Utils (Lyrics(..)) import MusicScroll.Providers.AZLyrics (azLyricsInstance) import MusicScroll.Providers.MusiXMatch (musiXMatchInstance) -import MusicScroll.UIEvent -type TrackQueue = (TBQueue TrackIdentifier, TBQueue TrackSuplement) -type TrackContext a = StateT (Maybe TrackIdentifier) IO a - -sizeOfQueue :: Natural -sizeOfQueue = 5 - -lyricsThread :: TrackQueue -> TBQueue UIEvent -> IO () -lyricsThread input output = - do middle <- atomically (newTBQueue sizeOfQueue) - let seenSongT' = seenSongsThread input middle - getLyricsT' = getLyricsThread middle output - concurrently_ (evalStateT seenSongT' Nothing) getLyricsT' +data SongByOrigin = DB | Web deriving (Show) +data SearchResult = GotLyric SongByOrigin TrackInfo Lyrics + | ErrorOn ErrorCause + deriving (Show) --- | 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 :: TrackQueue -> TBQueue TrackIdentifier -> TrackContext a -seenSongsThread input output = forever $ - do mTrackIdent <- mergeQueue input - notSeen <- (/=) <$> get <*> pure mTrackIdent - when (notSeen && isJust mTrackIdent) $ do - let Just trackIdent = mTrackIdent - put mTrackIdent - liftIO . atomically $ writeTBQueue output trackIdent +data ErrorCause = NotOnDB TrackByPath | NoLyricsOnWeb TrackInfo | ENoSong + deriving (Show) -mergeQueue :: TrackQueue -> TrackContext (Maybe TrackIdentifier) -mergeQueue (inputIdent, inputSupl) = - do let cleanInputIdent = cleanTrack <$> readTBQueue inputIdent - mergedInputChan = (Left <$> cleanInputIdent) `orElse` - (Right <$> readTBQueue inputSupl) - mOldTrack <- get - mergedInput <- liftIO $ atomically mergedInputChan +noRepeatedSongs :: Functor m => Pipe TrackIdentifier TrackIdentifier m a +noRepeatedSongs = do firstSong <- await + yield firstSong + loop firstSong + where + loop prevSong = do newSong <- await + if (TIWE newSong) /= (TIWE prevSong) + then yield newSong *> loop newSong + else loop prevSong - let suplement' :: TrackSuplement -> Maybe TrackIdentifier - suplement' supl = (Right . suplement supl) <$> mOldTrack - newTrack :: Maybe TrackIdentifier - newTrack = either Just suplement' mergedInput +getLyricsFromAnywhere :: MVar Connection -> Pipe TrackIdentifier SearchResult IO a +getLyricsFromAnywhere connMvar = PP.mapM go + where go :: TrackIdentifier -> IO SearchResult + go ident = runReaderT (either caseByPath caseByInfoGeneral ident) connMvar - pure newTrack +getLyricsOnlyFromWeb :: Pipe TrackInfo SearchResult IO a +getLyricsOnlyFromWeb = PP.mapM caseByInfoWeb -getLyricsThread :: TBQueue TrackIdentifier -> TBQueue UIEvent -> IO a -getLyricsThread input output = - do dbPath <- getDBPath - bracket (open dbPath) close $ \conn -> do - execute_ conn sqlDBCreate - flip evalStateT Nothing . forever $ - do trackIdent <- liftIO $ atomically (readTBQueue input) - get >>= maybe (pure ()) (liftIO . cancel) - asyncId <- liftIO . async $ - do event <- flip runReaderT conn $ - either caseByPath caseByInfo trackIdent - atomically $ writeTBQueue output event - put (pure asyncId) +caseByInfoGeneral :: TrackInfo -> ReaderT (MVar Connection) IO SearchResult +caseByInfoGeneral track = + let local = uncurry (GotLyric DB) <$> getDBSong (tUrl track) + web = caseByInfoWeb track + err = pure (ErrorOn (NoLyricsOnWeb track)) + in local <|> web <|> err -caseByInfo :: TrackInfo -> ReaderT Connection IO UIEvent -caseByInfo track = - let tryGetLyrics = getDBLyrics (tUrl track) - <|> getLyricsFromWeb azLyricsInstance track - <|> getLyricsFromWeb musiXMatchInstance track - in (GotLyric track <$> tryGetLyrics) <|> pure (ErrorOn (NoLyricsOnWeb track)) +caseByInfoWeb :: (MonadIO m, Alternative m) => TrackInfo -> m SearchResult +caseByInfoWeb track = GotLyric Web track <$> + (getLyricsFromWeb azLyricsInstance track + <|> getLyricsFromWeb musiXMatchInstance track) -caseByPath :: TrackByPath -> ReaderT Connection IO UIEvent +caseByPath :: TrackByPath -> ReaderT (MVar Connection) IO SearchResult caseByPath track = - ((uncurry GotLyric) <$> getDBSong (tpPath track)) <|> + ((uncurry (GotLyric DB)) <$> getDBSong (tpPath track)) <|> pure (ErrorOn (NotOnDB track)) + +saveOnDb :: MVar Connection -> Pipe SearchResult SearchResult IO a +saveOnDb mconn = PP.chain go + where go :: SearchResult -> IO () + go (GotLyric Web info lyr) = runReaderT (insertDBLyrics info lyr) mconn + go _otherwise = pure () diff --git a/src/MusicScroll/MPRIS.hs b/src/MusicScroll/MPRIS.hs --- a/src/MusicScroll/MPRIS.hs +++ b/src/MusicScroll/MPRIS.hs @@ -1,41 +1,28 @@ +{-# language LambdaCase #-} module MusicScroll.MPRIS (dbusThread) where -import Control.Concurrent.STM (atomically) -import Control.Concurrent.STM.TBQueue (TBQueue, writeTBQueue) import Control.Exception (bracket) -import Control.Monad ((=<<), forever) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.State.Class (gets) +import Control.Monad (forever) import Control.Monad.Trans.State (StateT, evalStateT) - import DBus.Client +import Pipes as P +import Pipes.Concurrent import MusicScroll.TrackInfo import MusicScroll.DBusSignals import MusicScroll.ConnState -import MusicScroll.UIEvent +import MusicScroll.LyricsPipeline -dbusThread :: TBQueue TrackIdentifier -> TBQueue UIEvent -> IO a -dbusThread trackChan eventChan = bracket connectSession disconnect - (evalStateT loop . newConnState trackChan eventChan) +dbusThread :: Output TrackIdentifier -> Output ErrorCause -> IO a +dbusThread trackout errorout = bracket connectSession disconnect + (evalStateT loop . newConnState) where loop :: StateT ConnState IO a - loop = forever $ do - mtrack <- liftIO . uncurry tryGetInfo =<< - (,) <$> gets cClient <*> gets cBusActive - case mtrack of + loop = forever $ tryGetInfo >>= \case Left (NoMusicClient _) -> changeMusicClient - Left NoSong -> reportErrorOnUI *> waitForChange mediaPropChangeRule - (Right trackIdent) -> sendToLyricsPipeline trackIdent - *> waitForChange mediaPropChangeRule - -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 + Left NoSong -> + do runEffect $ yield ENoSong >-> toOutput errorout + waitForChange mediaPropChangeRule + Right trackIdent -> + do runEffect $ yield trackIdent >-> toOutput trackout + waitForChange mediaPropChangeRule diff --git a/src/MusicScroll/Pipeline.hs b/src/MusicScroll/Pipeline.hs new file mode 100644 --- /dev/null +++ b/src/MusicScroll/Pipeline.hs @@ -0,0 +1,88 @@ +{-# language PatternSynonyms #-} +module MusicScroll.Pipeline where + +import Data.Foldable (traverse_) +import Control.Concurrent.Async +import Control.Concurrent.MVar +import Control.Concurrent.STM.TVar (TVar) +import Database.SQLite.Simple +import Pipes.Concurrent +import Pipes +import qualified Pipes.Prelude as PP +import Data.Functor.Contravariant.Divisible + +import MusicScroll.LyricsPipeline +import MusicScroll.UIContext (UIContext(..), dischargeOnUI, dischargeOnUISingle) +import MusicScroll.TrackInfo (TrackIdentifier, cleanTrack, + pattern OnlyMissingArtist) +import MusicScroll.TrackSuplement + +data DBusSignal = Song TrackIdentifier | Error ErrorCause | NoInfo + deriving (Show) + +data AppState = AppState + { apUI :: UIContext + , apDB :: MVar Connection -- ^ Enforce mutual exclusion zone + , apSupl :: TVar (Maybe TrackSuplement) + , apStaticinput :: (Input TrackIdentifier, Input ErrorCause) + , apEphemeralInput :: Producer DBusSignal IO () -- ^ Emits only once. + } + +staticPipeline :: AppState -> IO () +staticPipeline (AppState ctx db svar (dbusTrack, dbusErr) _) = + let songP = fromInput dbusTrack >-> addSuplArtist svar >-> noRepeatedSongs + >-> cleanTrack + errP = fromInput dbusErr + errorPipe = errP >-> PP.map ErrorOn >-> dischargeOnUI ctx + in withAsync (songPipe db ctx songP) $ \songA -> + withAsync (runEffect errorPipe) $ \errorA -> + void $ waitAnyCancel [ songA, errorA ] + +songPipe :: MVar Connection -> UIContext -> Producer TrackIdentifier IO () -> IO () +songPipe db ctx = PP.foldM go (pure Nothing) (traverse_ cancel) + where + go :: Maybe (Async ()) -> TrackIdentifier -> IO (Maybe (Async ())) + go asyncVar track = + do traverse_ cancel asyncVar + let network = yield track >-> getLyricsFromAnywhere db + >-> saveOnDb db >-> dischargeOnUI ctx + Just <$> async (runEffect network) + +suplementPipeline :: TrackSuplement -> AppState -> IO () +suplementPipeline supl (AppState ctx db _ _ signal) = + let justTracks a = case a of { Song track -> Just track ; _ -> Nothing } + songP = signal >-> PP.mapFoldable justTracks + pipeline = songP >-> mergeSuplement supl >-> getLyricsOnlyFromWeb + >-> saveOnDb db >-> dischargeOnUISingle ctx + in runEffect pipeline + +debugPS :: Show a => String -> Pipe a a IO () +debugPS tag = PP.chain (\a -> putStr tag *> print a) + +-- | Use the `Output` Divisible instance to create a network. These are +-- 1) An output for songs. +-- 2) One for errors +-- 3) A merge from the previous two. +-- The last one is special as it's non-work-stealing, so we can pass it to +-- multiple listeners and all will receive a signal. But we have to be +-- careful of only taking a single value of it, as it basically a `TVar a`. +musicSpawn :: IO ( Input TrackIdentifier, Input ErrorCause + , Producer DBusSignal IO () + , Output TrackIdentifier, Output ErrorCause) +musicSpawn = do + (protoTrackout, trackin) <- spawn (newest 1) + (protoErrorout, errorin) <- spawn (newest 1) + (allout, allin) <- spawn (latest NoInfo) + + let realTrackout = divide (\a -> (a, Song a)) protoTrackout allout + realErrorout = divide (\a -> (a, Error a)) protoErrorout allout + singleProd = fromInput allin >-> PP.take 1 + + pure $ (trackin, errorin, singleProd, realTrackout, realErrorout) + +addSuplArtist :: TVar (Maybe TrackSuplement) -> Pipe TrackIdentifier TrackIdentifier IO a +addSuplArtist svar = PP.mapM go + where go :: TrackIdentifier -> IO TrackIdentifier + go signal@(Left OnlyMissingArtist) = atomically (readTVar svar) >>= + pure . maybe signal (flip suplementOnlyArtist signal) + go other = pure other diff --git a/src/MusicScroll/Providers/AZLyrics.hs b/src/MusicScroll/Providers/AZLyrics.hs --- a/src/MusicScroll/Providers/AZLyrics.hs +++ b/src/MusicScroll/Providers/AZLyrics.hs @@ -3,9 +3,7 @@ import Control.Category hiding ((.), id) import Data.Maybe (catMaybes) -import Data.Text (Text) import Data.Text as T hiding (filter, tail, map, mapAccumL) --- import Data.Text.IO as T (readFile) import Data.Traversable (mapAccumL) import Network.HTTP.Req import Text.HTML.TagSoup diff --git a/src/MusicScroll/Providers/Utils.hs b/src/MusicScroll/Providers/Utils.hs --- a/src/MusicScroll/Providers/Utils.hs +++ b/src/MusicScroll/Providers/Utils.hs @@ -7,6 +7,9 @@ newtype Lyrics = Lyrics Text +instance Show Lyrics where + show _ = "Lyrics" + data Provider = Provider { toUrl :: TrackInfo -> Url 'Https , extractLyricsFromPage :: Text -> Lyrics diff --git a/src/MusicScroll/RealMain.hs b/src/MusicScroll/RealMain.hs --- a/src/MusicScroll/RealMain.hs +++ b/src/MusicScroll/RealMain.hs @@ -1,20 +1,37 @@ +{-# language ScopedTypeVariables #-} module MusicScroll.RealMain (realMain) where -import Control.Concurrent.Async (withAsync, waitAnyCancel) -import Control.Concurrent.STM (atomically) +import Control.Concurrent.Async (withAsync, withAsyncBound, waitAnyCancel) import Control.Concurrent.STM.TBQueue (newTBQueue) +import Control.Concurrent.STM.TVar +import Control.Concurrent.STM.TMVar +import Control.Concurrent.MVar import Data.Functor (void) +import Control.Exception (bracket) +import Database.SQLite.Simple +import Pipes.Concurrent -import MusicScroll.LyricsPipeline +import MusicScroll.Pipeline import MusicScroll.MPRIS import MusicScroll.UI +import MusicScroll.EventLoop +import MusicScroll.DatabaseUtils (getDBPath, sqlDBCreate) realMain :: IO () -realMain = - do dbusSongChan <- atomically (newTBQueue sizeOfQueue) - 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] +realMain = do + appCtxTMvar <- atomically newEmptyTMVar + suplTVar <- atomically (newTVar Nothing) + uiCallbackTB <- atomically (newTBQueue 5) + withAsyncBound (uiThread appCtxTMvar uiCallbackTB suplTVar) $ \uiA -> do + (trackin, errorin, singleProd, trackout, errorout) <- musicSpawn + withAsync (dbusThread trackout errorout) $ \dbusA -> do + dbPath <- getDBPath + bracket (open dbPath) close $ \conn -> do + execute_ conn sqlDBCreate + mconn <- newMVar conn + ctx <- atomically (takeTMVar appCtxTMvar) + let state = AppState ctx mconn suplTVar (trackin, errorin) singleProd + let evState = EventLoopState state uiCallbackTB Nothing + withAsync (staticPipeline state) $ \staticA -> + withAsync (eventLoop evState) $ \evLoopA -> + void $ waitAnyCancel [ staticA, evLoopA, uiA, dbusA ] diff --git a/src/MusicScroll/TrackInfo.hs b/src/MusicScroll/TrackInfo.hs --- a/src/MusicScroll/TrackInfo.hs +++ b/src/MusicScroll/TrackInfo.hs @@ -1,66 +1,75 @@ -{-# language OverloadedStrings, NamedFieldPuns #-} -module MusicScroll.TrackInfo - ( TrackInfo(..) - , TrackByPath(..) - , TrackIdentifier - , TrackInfoError(..) - , SongFilePath - , tryGetInfo - , cleanTrack - ) where +{-# language OverloadedStrings, NamedFieldPuns, FlexibleContexts, PatternSynonyms #-} +module MusicScroll.TrackInfo where import Prelude hiding (readFile, lookup) import Control.Applicative (Alternative(..)) import Control.Monad (join) +import Control.Monad.State.Class (MonadState(..)) import DBus import DBus.Client import Data.Bifunctor (first, bimap) -import Data.Function ((&)) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map, lookup) import Data.Text (Text) import qualified Data.Text as T import Data.Char (isAlpha) +import qualified Pipes.Prelude as PP (map) import MusicScroll.DBusNames +import MusicScroll.ConnState +import Pipes + data TrackInfo = TrackInfo { tTitle :: Text , tArtist :: Text -- xesam:artist is weird , tUrl :: SongFilePath - } deriving (Eq, Show) -- TODO: better eq instance + } deriving (Show) data TrackByPath = TrackByPath { tpPath :: SongFilePath , tpTitle :: Maybe Text -- Best effort , tpArtist :: Maybe Text -- Best effort - } deriving (Eq, Show) + } deriving (Show) type SongFilePath = FilePath type TrackIdentifier = Either TrackByPath TrackInfo -data TrackInfoError = NoMusicClient MethodError - | NoSong +newtype TrackIdentifierWithEq = TIWE TrackIdentifier +instance Eq TrackIdentifierWithEq where + (TIWE t1) == (TIWE t2) = extractUrl t1 == extractUrl t2 + +extractUrl :: TrackIdentifier -> SongFilePath +extractUrl = either tpPath tUrl + +pattern OnlyMissingArtist :: TrackByPath +pattern OnlyMissingArtist <- TrackByPath {tpArtist = Nothing, tpTitle = Just _} + + +data DBusError = 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 TrackIdentifier) -tryGetInfo client busName = do - metadata <- getPropertyValue client - (methodCall mediaObject mediaInterface "Metadata") { - methodCallDestination = pure busName - } & fmap (first NoMusicClient) - return . join $ obtainTrackInfo <$> metadata +tryGetInfo :: (MonadState ConnState m, MonadIO m) => + m (Either DBusError TrackIdentifier) +tryGetInfo = do + (ConnState client busName) <- get + liftIO $ do + metadata <- (first NoMusicClient) <$> getPropertyValue client + (methodCall mediaObject mediaInterface "Metadata") { + methodCallDestination = pure busName + } + pure . join $ obtainTrackInfo <$> metadata -obtainTrackInfo :: Map Text Variant -> Either TrackInfoError TrackIdentifier +obtainTrackInfo :: Map Text Variant -> Either DBusError TrackIdentifier obtainTrackInfo metadata = - let lookup :: IsVariant a => Text -> Maybe a - lookup name = Map.lookup name metadata >>= fromVariant + let lookup' :: IsVariant a => Text -> Maybe a + lookup' name = lookup name metadata >>= fromVariant - mTitle = lookup "xesam:title" - mArtist = xesamArtistFix (lookup "xesam:artist") (lookup "xesam:artist") - mUrl = vlcFix <$> lookup "xesam:url" + 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 @@ -79,10 +88,13 @@ xesamArtistFix Nothing (Just arr) | (title : _) <- arr = pure title xesamArtistFix _ _ = Nothing -cleanTrack :: TrackIdentifier -> TrackIdentifier -cleanTrack = bimap - (\byPath -> byPath { tpTitle = cleanTitle <$> (tpTitle byPath) }) - (\track -> track { tTitle = cleanTitle (tTitle track) }) +cleanTrack :: Functor m => Pipe TrackIdentifier TrackIdentifier m a +cleanTrack = PP.map go + where + go :: TrackIdentifier -> TrackIdentifier + go = bimap (\byPath -> let newTitle = cleanTitle <$> tpTitle byPath + in byPath { tpTitle = newTitle }) + (\track -> track { tTitle = cleanTitle (tTitle track) }) -- | This functions does two main things: -- 1. Remove format at the end, ie .mp3, .opus etc. diff --git a/src/MusicScroll/TrackSuplement.hs b/src/MusicScroll/TrackSuplement.hs --- a/src/MusicScroll/TrackSuplement.hs +++ b/src/MusicScroll/TrackSuplement.hs @@ -1,15 +1,27 @@ -module MusicScroll.TrackSuplement where +{-# language PatternSynonyms #-} +module MusicScroll.TrackSuplement + ( tsTitle, tsArtist, tsKeepArtist, TrackSuplement() , trackSuplement + , suplement, mergeSuplement, suplementOnlyArtist) where import Data.Text +import Pipes (Pipe) +import qualified Pipes.Prelude as PP (map) import MusicScroll.TrackInfo ( TrackInfo(..), TrackByPath(..) - , TrackIdentifier ) + , TrackIdentifier, pattern OnlyMissingArtist ) + +-- | Invariant, always a valid artist text. data TrackSuplement = TrackSuplement { tsTitle :: Text , tsArtist :: Text - } + , tsKeepArtist :: Bool } +trackSuplement :: Text -> Text -> Bool -> Maybe TrackSuplement +trackSuplement title artist keep + | strip artist == artist = pure (TrackSuplement title artist keep) + | otherwise = Nothing + suplement :: TrackSuplement -> TrackIdentifier -> TrackInfo suplement supl = either byPath byInfo where @@ -20,3 +32,14 @@ byInfo :: TrackInfo -> TrackInfo byInfo info = info { tTitle = tsTitle supl, tArtist = tsArtist supl} + +mergeSuplement :: Functor m => TrackSuplement -> Pipe TrackIdentifier TrackInfo m a +mergeSuplement = PP.map . suplement + +suplementOnlyArtist :: TrackSuplement -> TrackIdentifier -> TrackIdentifier +suplementOnlyArtist supl (Left byPath@OnlyMissingArtist) = + let trackinfo = TrackInfo { tTitle = maybe mempty id (tpTitle byPath) + , tArtist = tsArtist supl + , tUrl = tpPath byPath } + in Right trackinfo +suplementOnlyArtist _ other = other diff --git a/src/MusicScroll/UI.hs b/src/MusicScroll/UI.hs --- a/src/MusicScroll/UI.hs +++ b/src/MusicScroll/UI.hs @@ -1,89 +1,70 @@ {-# language RecordWildCards, OverloadedStrings #-} -module MusicScroll.UI (setupUIThread) where +module MusicScroll.UI (uiThread, getSuplement) where -import Control.Concurrent.Async - (withAsyncBound, waitAnyCancel, withAsync) import Control.Concurrent.STM (atomically) -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 Control.Concurrent.STM.TBQueue (TBQueue, writeTBQueue) +import Control.Concurrent.STM.TMVar (TMVar, putTMVar) +import Control.Concurrent.STM.TVar (TVar, writeTVar) import Data.GI.Gtk.Threading (setCurrentThreadAsGUIThread) import Data.Maybe (fromJust) import Data.Text (pack) import qualified GI.Gtk as Gtk import MusicScroll.TrackSuplement -import MusicScroll.UIEvent +import MusicScroll.UIContext +import MusicScroll.Pipeline +import MusicScroll.EventLoop import Paths_musicScroll -- Remember to use Gtk.init Nothing before calling this. -getGtkScene :: IO AppContext +getGtkScene :: IO UIContext getGtkScene = do file <- getDataFileName "app.glade" builder <- Gtk.builderNewFromFile (pack file) -- We *know* these ids are defined - let getWidget wid id = - Gtk.builderGetObject builder id + let getWidget wid id0 = + Gtk.builderGetObject builder id0 >>= Gtk.castTo wid . fromJust >>= return . fromJust - AppContext <$> getWidget Gtk.Window "mainWindow" - <*> 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 UIEvent -> TBQueue TrackSuplement -> IO () -setupUIThread events outSupl = - do appCtxMVar <- atomically newEmptyTMVar - withAsyncBound (uiThread appCtxMVar outSupl) $ \a1 -> - withAsync (uiUpdateThread events outSupl appCtxMVar) $ \a2 -> - void (waitAnyCancel [a1, a2]) >> throwIO UserInterrupt + UIContext <$> getWidget Gtk.Window "mainWindow" + <*> 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" -uiThread :: TMVar AppContext -> TBQueue TrackSuplement -> IO () -uiThread ctxMVar outSupl = do +uiThread :: TMVar UIContext -> TBQueue UICallback + -> TVar (Maybe TrackSuplement) -> IO () +uiThread ctxMVar outputTB suplTVar = do setCurrentThreadAsGUIThread _ <- Gtk.init Nothing - appCtx@(AppContext {..}) <- getGtkScene + appCtx@(UIContext {..}) <- getGtkScene atomically (putTMVar ctxMVar appCtx) Gtk.labelSetText titleLabel "MusicScroll" Gtk.widgetShowAll mainWindow _ <- Gtk.onButtonClicked suplementAcceptButton $ - sendSuplementalInfo appCtx outSupl + do getSuplement appCtx >>= \msupl -> do + case msupl of + Just supl -> do + let callback = suplementPipeline supl + atomically (writeTBQueue outputTB callback) + _ -> pure () + atomically (writeTVar suplTVar msupl) + _ <- Gtk.afterWidgetFocusOutEvent artistSuplementEntry $ + const (defUpdate appCtx *> pure True) + _ <- Gtk.afterToggleButtonToggled keepArtistNameCheck $ defUpdate appCtx _ <- Gtk.onWidgetDestroy mainWindow Gtk.mainQuit Gtk.main - ---- -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) + where + defUpdate :: UIContext -> IO () + defUpdate c = getSuplement c >>= atomically . writeTVar suplTVar -tryDefaultSupplement - :: AppContext -> ErrorCause -> TBQueue TrackSuplement -> IO () -tryDefaultSupplement ctx@(AppContext {..}) cause suplChan = - do shouldMaintainArtistSupl <- Gtk.getToggleButtonActive keepArtistNameCheck - validGuessArtist <- (/= mempty) <$> Gtk.entryGetText artistSuplementEntry - case cause of - OnlyMissingArtist | shouldMaintainArtistSupl, validGuessArtist -> - sendSuplementalInfo ctx suplChan - _ -> return () +getSuplement :: UIContext -> IO (Maybe TrackSuplement) +getSuplement (UIContext {..}) = trackSuplement <$> + Gtk.entryGetText titleSuplementEntry + <*> Gtk.entryGetText artistSuplementEntry + <*> Gtk.getToggleButtonActive keepArtistNameCheck diff --git a/src/MusicScroll/UIContext.hs b/src/MusicScroll/UIContext.hs new file mode 100644 --- /dev/null +++ b/src/MusicScroll/UIContext.hs @@ -0,0 +1,81 @@ +{-# language OverloadedStrings, RecordWildCards, BangPatterns #-} +module MusicScroll.UIContext where + +import Control.Monad (unless, forever) +import Data.GI.Gtk.Threading (postGUISync) +import Data.Maybe (isNothing) +import Data.Text as T +import qualified GI.Gtk as Gtk +import Pipes + +import MusicScroll.TrackInfo (TrackInfo(..), TrackByPath(..)) +import MusicScroll.Providers.Utils (Lyrics(..)) +import MusicScroll.LyricsPipeline + +data UIContext = UIContext + { 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 :: UIContext -> (TrackInfo, Lyrics) -> IO () +updateNewLyrics ctx@(UIContext {..}) (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) + +dischargeOnUI :: UIContext -> Consumer SearchResult IO a +dischargeOnUI ctx = forever (dischargeOnUISingle ctx) + +dischargeOnUISingle :: UIContext -> Consumer SearchResult IO () +dischargeOnUISingle ctx = do + res <- await + liftIO $ case res of + GotLyric _ info lyr -> updateNewLyrics ctx (info, lyr) + ErrorOn cause -> updateErrorCause ctx cause + +updateErrorCause :: UIContext -> ErrorCause -> IO () +updateErrorCause ctx@(UIContext {..}) 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 :: UIContext -> (Text, Text) -> IO () +updateSuplementalGuess (UIContext {..}) (guessTitle, guessArtist) = + do Gtk.entrySetText titleSuplementEntry guessTitle + shouldMaintainArtistSupl <- Gtk.getToggleButtonActive keepArtistNameCheck + unless shouldMaintainArtistSupl $ + Gtk.entrySetText artistSuplementEntry guessArtist diff --git a/src/MusicScroll/UIEvent.hs b/src/MusicScroll/UIEvent.hs deleted file mode 100644 --- a/src/MusicScroll/UIEvent.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# language OverloadedStrings, RecordWildCards, BangPatterns, PatternSynonyms #-} -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.Providers.Utils (Lyrics(..)) - -data UIEvent = GotLyric TrackInfo Lyrics - | ErrorOn ErrorCause - -data ErrorCause = NotOnDB TrackByPath | NoLyricsOnWeb TrackInfo | ENoSong - -pattern OnlyMissingArtist :: ErrorCause -pattern OnlyMissingArtist <- NotOnDB (TrackByPath {tpArtist = Nothing, tpTitle = Just _}) - -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 diff --git a/src/MusicScroll/Web.hs b/src/MusicScroll/Web.hs --- a/src/MusicScroll/Web.hs +++ b/src/MusicScroll/Web.hs @@ -4,17 +4,15 @@ import Control.Exception (try) import Control.Applicative (Alternative(empty)) -import Control.Monad.Trans.Reader (ReaderT) import Control.Monad.IO.Class (MonadIO(..)) import Data.Text.Encoding (decodeUtf8) import Network.HTTP.Req -import Database.SQLite.Simple (Connection) import MusicScroll.TrackInfo (TrackInfo(..)) -import MusicScroll.DatabaseUtils (insertDBLyrics) import MusicScroll.Providers.Utils -getLyricsFromWeb :: Provider -> TrackInfo -> ReaderT Connection IO Lyrics +getLyricsFromWeb :: (MonadIO m, Alternative m) => Provider -> TrackInfo + -> m Lyrics getLyricsFromWeb (Provider {..}) track = do let songUrl = toUrl track resp <- liftIO $ try @HttpException (getPage songUrl) @@ -24,7 +22,7 @@ else let Right realResp = resp body = decodeUtf8 (responseBody realResp) lyrics = extractLyricsFromPage body - in insertDBLyrics track lyrics *> pure lyrics + in pure lyrics getPage :: Url 'Https -> IO BsResponse getPage url = runReq defaultHttpConfig $