musicScroll 0.2.3.3 → 0.3.0.0
raw patch · 19 files changed
+467/−349 lines, 19 filesdep +contravariantdep +pipesdep +pipes-concurrency
Dependencies added: contravariant, pipes, pipes-concurrency
Files
- CHANGELOG.md +4/−0
- musicScroll.cabal +8/−3
- shell.nix +3/−3
- src/MusicScroll/ConnState.hs +5/−18
- src/MusicScroll/DBusSignals.hs +13/−14
- src/MusicScroll/DatabaseUtils.hs +28/−19
- src/MusicScroll/EventLoop.hs +22/−0
- src/MusicScroll/LyricsPipeline.hs +53/−70
- src/MusicScroll/MPRIS.hs +15/−28
- src/MusicScroll/Pipeline.hs +88/−0
- src/MusicScroll/Providers/AZLyrics.hs +0/−2
- src/MusicScroll/Providers/Utils.hs +3/−0
- src/MusicScroll/RealMain.hs +28/−11
- src/MusicScroll/TrackInfo.hs +46/−34
- src/MusicScroll/TrackSuplement.hs +26/−3
- src/MusicScroll/UI.hs +41/−60
- src/MusicScroll/UIContext.hs +81/−0
- src/MusicScroll/UIEvent.hs +0/−79
- src/MusicScroll/Web.hs +3/−5
CHANGELOG.md view
@@ -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
musicScroll.cabal view
@@ -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
shell.nix view
@@ -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 ];
src/MusicScroll/ConnState.hs view
@@ -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
src/MusicScroll/DBusSignals.hs view
@@ -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
src/MusicScroll/DatabaseUtils.hs view
@@ -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 = ? ;"
+ src/MusicScroll/EventLoop.hs view
@@ -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'
src/MusicScroll/LyricsPipeline.hs view
@@ -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 ()
src/MusicScroll/MPRIS.hs view
@@ -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
+ src/MusicScroll/Pipeline.hs view
@@ -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
src/MusicScroll/Providers/AZLyrics.hs view
@@ -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
src/MusicScroll/Providers/Utils.hs view
@@ -7,6 +7,9 @@ newtype Lyrics = Lyrics Text +instance Show Lyrics where+ show _ = "Lyrics"+ data Provider = Provider { toUrl :: TrackInfo -> Url 'Https , extractLyricsFromPage :: Text -> Lyrics
src/MusicScroll/RealMain.hs view
@@ -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 ]
src/MusicScroll/TrackInfo.hs view
@@ -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.
src/MusicScroll/TrackSuplement.hs view
@@ -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
src/MusicScroll/UI.hs view
@@ -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
+ src/MusicScroll/UIContext.hs view
@@ -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
− src/MusicScroll/UIEvent.hs
@@ -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
src/MusicScroll/Web.hs view
@@ -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 $