diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for music-scroll +## 0.2.3.0 + +* Added other music providers + ## 0.2.0.0 * SQLite cache 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.2.0 +version: 0.2.3.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 @@ -52,12 +52,11 @@ bytestring, directory, deepseq - exposed-modules: MusicScroll.UI, - MusicScroll.RealMain + exposed-modules: MusicScroll.RealMain + other-modules: MusicScroll.UI MusicScroll.MPRIS - MusicScroll.AZLyrics + MusicScroll.Web MusicScroll.LyricsPipeline - MusicScroll.TagParsing MusicScroll.TrackInfo MusicScroll.UIEvent MusicScroll.DBusNames @@ -65,7 +64,10 @@ MusicScroll.ConnState MusicScroll.DatabaseUtils MusicScroll.TrackSuplement - other-modules: Paths_musicScroll + MusicScroll.Providers.AZLyrics + MusicScroll.Providers.MusiXMatch + MusicScroll.Providers.Utils + Paths_musicScroll -- test-suite playground -- type: exitcode-stdio-1.0 diff --git a/src/MusicScroll/AZLyrics.hs b/src/MusicScroll/AZLyrics.hs deleted file mode 100644 --- a/src/MusicScroll/AZLyrics.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# language OverloadedStrings, DataKinds, NamedFieldPuns, TypeApplications #-} -module MusicScroll.AZLyrics (getLyricsFromWeb) where - -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 Database.SQLite.Simple (Connection) - -import MusicScroll.TrackInfo (TrackInfo(..)) -import MusicScroll.TagParsing -import MusicScroll.DatabaseUtils (insertDBLyrics) - -getLyricsFromWeb :: TrackInfo -> ReaderT Connection IO Lyrics -getLyricsFromWeb track@(TrackInfo {tArtist, tTitle}) = - do let songUrl = toUrl tArtist tTitle - 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 insertDBLyrics track lyrics *> pure lyrics - -getPage :: Url 'Https -> IO BsResponse -getPage url = runReq defaultHttpConfig $ - req GET url NoReqBody bsResponse mempty - -toUrl :: Text -> Text -> Url 'Https -toUrl artist song = - let base :: Url 'Https - base = https "www.azlyrics.com" - - quotedArtist = normalize artist - quotedSong = normalize song <> ".html" - in base /: "lyrics" /: quotedArtist /: quotedSong - -normalize :: Text -> Text -normalize = let noSpaces = replace " " "" in noSpaces . toLower diff --git a/src/MusicScroll/DatabaseUtils.hs b/src/MusicScroll/DatabaseUtils.hs --- a/src/MusicScroll/DatabaseUtils.hs +++ b/src/MusicScroll/DatabaseUtils.hs @@ -23,7 +23,7 @@ import System.Directory (createDirectory) import MusicScroll.TrackInfo (TrackInfo(..), SongFilePath) -import MusicScroll.TagParsing (Lyrics(..)) +import MusicScroll.Providers.Utils (Lyrics(..)) getDBLyrics :: SongFilePath -> ReaderT Connection IO Lyrics getDBLyrics songUrl = snd <$> getDBSong songUrl diff --git a/src/MusicScroll/LyricsPipeline.hs b/src/MusicScroll/LyricsPipeline.hs --- a/src/MusicScroll/LyricsPipeline.hs +++ b/src/MusicScroll/LyricsPipeline.hs @@ -17,10 +17,12 @@ import Data.Maybe (isJust) import Database.SQLite.Simple -import MusicScroll.DatabaseUtils +import MusicScroll.DatabaseUtils import MusicScroll.TrackInfo import MusicScroll.TrackSuplement -import MusicScroll.AZLyrics (getLyricsFromWeb) +import MusicScroll.Web (getLyricsFromWeb) +import MusicScroll.Providers.AZLyrics (azLyricsInstance) +import MusicScroll.Providers.MusiXMatch (musiXMatchInstance) import MusicScroll.UIEvent sizeOfQueue :: Natural @@ -77,7 +79,9 @@ caseByInfo :: TrackInfo -> ReaderT Connection IO UIEvent caseByInfo track = - let tryGetLyrics = getDBLyrics (tUrl track) <|> getLyricsFromWeb track + let tryGetLyrics = getDBLyrics (tUrl track) + <|> getLyricsFromWeb azLyricsInstance track + <|> getLyricsFromWeb musiXMatchInstance track in (GotLyric track <$> tryGetLyrics) <|> pure (ErrorOn (NoLyricsOnWeb track)) caseByPath :: TrackByPath -> ReaderT Connection IO UIEvent diff --git a/src/MusicScroll/Providers/AZLyrics.hs b/src/MusicScroll/Providers/AZLyrics.hs new file mode 100644 --- /dev/null +++ b/src/MusicScroll/Providers/AZLyrics.hs @@ -0,0 +1,43 @@ +{-# language OverloadedStrings, DataKinds #-} +module MusicScroll.Providers.AZLyrics (azLyricsInstance) where + +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 +import Text.HTML.TagSoup.Match (tagOpenLit) + +import MusicScroll.TrackInfo (TrackInfo(..)) +import MusicScroll.Providers.Utils + +azLyricsInstance :: Provider +azLyricsInstance = Provider + { toUrl = toUrl' + , extractLyricsFromPage = pipeline } + +toUrl' :: TrackInfo -> Url 'Https +toUrl' track = + let base :: Url 'Https + base = https "www.azlyrics.com" + + quotedArtist = normalize (tArtist track) + quotedSong = normalize (tTitle track) <> ".html" + in base /: "lyrics" /: quotedArtist /: quotedSong + +normalize :: Text -> Text +normalize = let noSpaces = replace " " "" in noSpaces . toLower + +pipeline :: Text -> Lyrics +pipeline = parseTags >>> mapAccumL discriminate False >>> snd + >>> catMaybes >>> innerText >>> stripStart >>> Lyrics + +discriminate :: Bool -> Tag Text -> (Bool, Maybe (Tag Text)) +discriminate onDiv@True tag | isTagText tag = (onDiv, pure tag) +discriminate onDiv tag + | tagOpenLit "div" (== []) tag = (True, Nothing) + | isTagCloseName "div" tag = (False, Nothing) + | otherwise = (onDiv, Nothing) diff --git a/src/MusicScroll/Providers/MusiXMatch.hs b/src/MusicScroll/Providers/MusiXMatch.hs new file mode 100644 --- /dev/null +++ b/src/MusicScroll/Providers/MusiXMatch.hs @@ -0,0 +1,51 @@ +{-# language OverloadedStrings, DataKinds #-} +module MusicScroll.Providers.MusiXMatch (musiXMatchInstance) where + +import Control.Category hiding ((.)) +import Data.Maybe (catMaybes) +import Data.Text (Text, replace, toTitle) +import Network.HTTP.Req +import Text.HTML.TagSoup +import Text.HTML.TagSoup.Match (tagOpenAttrLit) +import Data.Traversable (mapAccumL) +-- import Data.Text.IO as T (readFile) + +import MusicScroll.TrackInfo (TrackInfo(..)) +import MusicScroll.Providers.Utils + +musiXMatchInstance :: Provider +musiXMatchInstance = Provider + { toUrl = toUrl' + , extractLyricsFromPage = pipeline } + +toUrl' :: TrackInfo -> Url 'Https +toUrl' track = + let base :: Url 'Https + base = https "www.musixmatch.com" + + quotedArtist = normalize (tArtist track) + quotedSong = normalize (tTitle track) + in base /: "lyrics" /: quotedArtist /: quotedSong + +normalize :: Text -> Text +normalize = let noSpaces = replace " " "-" in noSpaces . toTitle + +-- exampleTrack = TrackInfo "hey jude" "the beatles" "/home" + +-- testOnFile fp = +-- do contents <- T.readFile fp +-- return (pipeline contents) + +pipeline :: Text -> Lyrics +pipeline = parseTags >>> mapAccumL discriminate False + >>> snd >>> catMaybes >>> innerText >>> Lyrics + +discriminate :: Bool -> Tag Text -> (Bool, Maybe (Tag Text)) +discriminate onSpan@True tag | isTagText tag = (onSpan, pure tag) +discriminate onSpan tag + | tagOpenAttrLit "span" spanDiscr tag = (True, Nothing) + | isTagCloseName "span" tag = (False, Nothing) + | otherwise = (onSpan, Nothing) + where + spanDiscr = ("class", "lyrics__content__ok") + diff --git a/src/MusicScroll/Providers/Utils.hs b/src/MusicScroll/Providers/Utils.hs new file mode 100644 --- /dev/null +++ b/src/MusicScroll/Providers/Utils.hs @@ -0,0 +1,13 @@ +{-# language DataKinds #-} +module MusicScroll.Providers.Utils where + +import Data.Text (Text) +import MusicScroll.TrackInfo (TrackInfo) +import Network.HTTP.Req + +newtype Lyrics = Lyrics Text + +data Provider = Provider + { toUrl :: TrackInfo -> Url 'Https + , extractLyricsFromPage :: Text -> Lyrics + } diff --git a/src/MusicScroll/TagParsing.hs b/src/MusicScroll/TagParsing.hs deleted file mode 100644 --- a/src/MusicScroll/TagParsing.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# language OverloadedStrings #-} -module MusicScroll.TagParsing (Lyrics(..), extractLyricsFromPage) where - -import qualified Data.Char as C -import Data.Text (Text) -import Data.Text as T hiding (filter, tail, map) -import Text.HTML.TagSoup - -newtype Lyrics = Lyrics Text - -extractLyricsFromPage :: Text -> Lyrics -extractLyricsFromPage page = - let stream = parseTags page - pass1 = flip filter stream - (\t -> (not (isScript t)) && noEmptyText t && validTags t) - stream2 = zip3 pass1 (tail pass1) (tail (tail pass1)) - pass2 = map (\(t, _, _) -> t) $ filter isStrophe stream2 - in Lyrics . T.unlines . cleanOut $ pass2 - --- Pass 1 -validTags, noEmptyText :: Tag Text -> Bool -validTags t = isTagOpenName "br" t || isTagCloseName "div" t - || isTagOpenName "div" t || isTagCloseName "div" t - || isTagText t - -noEmptyText = - let invalidChars c = C.isSpace c || c == '\\' || c == 'n' - || c == 'r' || c == 't' - in maybe True (not . T.all invalidChars) . maybeTagText - --- Pass 2 -isScript :: Tag Text -> Bool -isScript = let invalidChars c = c == '>' || c == '{' - in maybe False (T.any invalidChars) . maybeTagText - --- Pass 3 -isStrophe :: (Tag Text, Tag Text, Tag Text) -> Bool -isStrophe (TagText _, TagOpen "br" _, TagText _) = True -isStrophe (TagText _, TagOpen "br" _, TagOpen "br" _) = True -isStrophe (TagOpen "br" _, TagOpen "br" _, _) = True -- breakline -isStrophe _ = False - --- Cleaning output -cleanOut :: [Tag Text] -> [Text] -cleanOut = map (T.strip . T.replace "\\n" "") - . map (maybe "\n" id . maybeTagText) diff --git a/src/MusicScroll/UIEvent.hs b/src/MusicScroll/UIEvent.hs --- a/src/MusicScroll/UIEvent.hs +++ b/src/MusicScroll/UIEvent.hs @@ -9,7 +9,7 @@ import Data.GI.Gtk.Threading (postGUISync) import MusicScroll.TrackInfo (TrackInfo(..), TrackByPath(..)) -import MusicScroll.TagParsing (Lyrics(..)) +import MusicScroll.Providers.Utils (Lyrics(..)) data UIEvent = GotLyric TrackInfo Lyrics | ErrorOn ErrorCause diff --git a/src/MusicScroll/Web.hs b/src/MusicScroll/Web.hs new file mode 100644 --- /dev/null +++ b/src/MusicScroll/Web.hs @@ -0,0 +1,32 @@ +{-# language OverloadedStrings, NamedFieldPuns, RecordWildCards #-} +{-# language TypeApplications, DataKinds #-} +module MusicScroll.Web (getLyricsFromWeb) where + +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.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 (Provider {..}) track = + do let songUrl = toUrl track + 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 insertDBLyrics track lyrics *> pure lyrics + +getPage :: Url 'Https -> IO BsResponse +getPage url = runReq defaultHttpConfig $ + req GET url NoReqBody bsResponse mempty +