musicScroll 0.2.2.0 → 0.2.3.0

raw patch · 11 files changed

+160/−101 lines, 11 files

Files

• CHANGELOG.md +4/−0
• musicScroll.cabal +8/−6
• src/MusicScroll/AZLyrics.hs +0/−44
• src/MusicScroll/DatabaseUtils.hs +1/−1
• src/MusicScroll/LyricsPipeline.hs +7/−3
• src/MusicScroll/Providers/AZLyrics.hs +43/−0
• src/MusicScroll/Providers/MusiXMatch.hs +51/−0
• src/MusicScroll/Providers/Utils.hs +13/−0
• src/MusicScroll/TagParsing.hs +0/−46
• src/MusicScroll/UIEvent.hs +1/−1
• src/MusicScroll/Web.hs +32/−0

@@ -1,5 +1,9 @@ # Revision history for music-scroll +## 0.2.3.0++* Added other music providers+ ## 0.2.0.0  * SQLite cache

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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")+

@@ -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+  }

@@ -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)

@@ -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

@@ -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+