musicScroll 0.2.0.0 → 0.2.1.0

raw patch · 7 files changed

+64/−37 lines, 7 files

Files

• README.md +2/−0
• musicScroll.cabal +1/−1
• resources/app.glade +1/−0
• src/MusicScroll/AZLyrics.hs +6/−4
• src/MusicScroll/DatabaseUtils.hs +21/−21
• src/MusicScroll/LyricsPipeline.hs +15/−8
• src/MusicScroll/UI.hs +18/−3

@@ -29,3 +29,5 @@ to be organized. If I see you guys on a conference I will buy you a beer :-) . The `d-feet` program was really helpful for see how the data was layout on DBus.++I accept donations <3, the COVID-19 certainly affected me economically!.

@@ -4,7 +4,7 @@ -- http://haskell.org/cabal/users-guide/  name:                musicScroll-version:             0.2.0.0+version:             0.2.1.0 synopsis:            Supply your tunes info without leaving your music player.  description:         Automatically retrive the lyrics of of your current                      song on SMPlayer/VLC and update it on each change. See the

@@ -58,6 +58,7 @@               <object class="GtkScrolledWindow">                 <property name="visible">True</property>                 <property name="can_focus">True</property>+                <property name="has_default">True</property>                 <property name="margin_left">3</property>                 <property name="margin_right">6</property>                 <property name="hexpand">True</property>

@@ -3,27 +3,29 @@  import Control.Exception (try, SomeException) import Control.Applicative (Alternative(empty))+import Control.Monad.Trans.Reader (ReaderT)+import Control.Monad.IO.Class (MonadIO(..)) import Data.Text (Text) import Data.Text as T hiding (filter, tail, map, empty) import Data.Text.Encoding (decodeUtf8) import Network.HTTP.Req-import Control.Concurrent (forkIO)+import Database.SQLite.Simple (Connection)  import MusicScroll.TrackInfo (TrackInfo(..)) import MusicScroll.TagParsing import MusicScroll.DatabaseUtils (insertDBLyrics) -getLyricsFromWeb :: TrackInfo -> IO Lyrics+getLyricsFromWeb :: TrackInfo -> ReaderT Connection IO Lyrics getLyricsFromWeb track@(TrackInfo {tArtist, tTitle}) =   do let songUrl = toUrl tArtist tTitle-     resp <- try @SomeException (getPage songUrl)+     resp <- liftIO $ try @SomeException (getPage songUrl)      let notValid = either (const True)                       ((/= 200) . responseStatusCode) resp      if notValid then empty        else let Right realResp = resp                 body   = decodeUtf8 (responseBody realResp)                 lyrics = extractLyricsFromPage body-            in forkIO (insertDBLyrics track lyrics) *> return lyrics+            in insertDBLyrics track lyrics *> pure lyrics  getPage :: Url 'Https -> IO BsResponse getPage url = runReq defaultHttpConfig $

@@ -4,11 +4,14 @@   , getDBSong   , insertDBLyrics   , getDBPath+  , sqlDBCreate   ) where  import           Prelude hiding (null) import           Control.Applicative (Alternative(..))-import           Control.Exception (bracket, evaluate)+import           Control.Exception (evaluate)+import           Control.Monad.Trans.Reader (ReaderT, ask)+import           Control.Monad.IO.Class (MonadIO(..)) import           Control.DeepSeq (rnf) import           Crypto.Hash (SHA1, hashUpdate, hashInit, hashFinalize) import           Data.ByteString (hGet, null)@@ -22,31 +25,28 @@ import           MusicScroll.TrackInfo (TrackInfo(..), SongFilePath) import           MusicScroll.TagParsing (Lyrics(..)) -getDBLyrics :: SongFilePath -> IO Lyrics+getDBLyrics :: SongFilePath -> ReaderT Connection IO Lyrics getDBLyrics songUrl = snd <$> getDBSong songUrl -getDBSong :: SongFilePath -> IO (TrackInfo, Lyrics)+getDBSong :: SongFilePath -> ReaderT Connection IO (TrackInfo, Lyrics) getDBSong songUrl =-  do songHash <- fileHash songUrl-     dbPath   <- getDBPath-     bracket (open dbPath) close $ \conn ->-       do execute_ conn sqlDBCreate-          songRaw <- query conn sqlExtractSong (Only songHash)-          case (songRaw :: [ (Text, Text, Text) ]) of-            [] -> empty-            (title, artist, lyrics):_ ->-              let track = TrackInfo title artist songUrl-              in return (track, coerce lyrics)-+  do conn <- ask+     liftIO $ do+       songHash <- fileHash songUrl+       songRaw <- query conn sqlExtractSong (Only songHash)+       case (songRaw :: [ (Text, Text, Text) ]) of+         [] -> empty+         (title, artist, lyrics):_ ->+           let track = TrackInfo title artist songUrl+           in return (track, coerce lyrics) -insertDBLyrics :: TrackInfo -> Lyrics -> IO ()+insertDBLyrics :: TrackInfo -> Lyrics -> ReaderT Connection IO () insertDBLyrics (TrackInfo {..}) lyrics =-  do songHash <- fileHash tUrl-     dbPath   <- getDBPath-     bracket (open dbPath) close $ \conn ->-       do execute_ conn sqlDBCreate-          let params = (songHash, tArtist, tTitle, coerce lyrics :: Text)-          execute conn sqlInsertSong params+  do conn <- ask+     liftIO $ do+       songHash <- fileHash tUrl+       let params = (songHash, tArtist, tTitle, coerce lyrics :: Text)+       execute conn sqlInsertSong params  getDBPath :: IO FilePath getDBPath = do cacheDir <- getUserCacheDir "musicScroll"

@@ -7,14 +7,17 @@ import Control.Concurrent.STM.TBQueue ( TBQueue, readTBQueue, writeTBQueue,                                         newTBQueue ) import Control.Applicative (Alternative(..))+import Control.Exception (bracket) import Control.Monad.Trans.State (StateT, get, put, evalStateT) import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Control.Monad (forever, when) import Numeric.Natural (Natural) import Data.Functor (void) import Data.Maybe (isJust)+import Database.SQLite.Simple -import MusicScroll.DatabaseUtils (getDBLyrics, getDBSong)+import MusicScroll.DatabaseUtils  import MusicScroll.TrackInfo import MusicScroll.TrackSuplement import MusicScroll.AZLyrics (getLyricsFromWeb)@@ -61,19 +64,23 @@       pure newTrack - getLyricsThread :: TBQueue TrackIdentifier -> TBQueue UIEvent -> IO a-getLyricsThread input output = forever $-  do trackIdent <- atomically (readTBQueue input)-     event <- either caseByPath caseByInfo trackIdent-     atomically $ writeTBQueue output event+getLyricsThread input output =+  do dbPath <- getDBPath+     bracket (open dbPath) close $ \conn -> do+       execute_ conn sqlDBCreate+       forever $+         do trackIdent <- atomically (readTBQueue input)+            event <- flip runReaderT conn $+                       either caseByPath caseByInfo trackIdent+            atomically $ writeTBQueue output event -caseByInfo :: TrackInfo -> IO UIEvent+caseByInfo :: TrackInfo -> ReaderT Connection IO UIEvent caseByInfo track =   let tryGetLyrics = getDBLyrics (tUrl track) <|> getLyricsFromWeb track   in (GotLyric track <$> tryGetLyrics) <|> pure (ErrorOn (NoLyricsOnWeb track)) -caseByPath :: TrackByPath -> IO UIEvent+caseByPath :: TrackByPath -> ReaderT Connection IO UIEvent caseByPath track =   ((uncurry GotLyric) <$> getDBSong (tpPath track)) <|>   pure (ErrorOn (NotOnDB track))

@@ -10,11 +10,13 @@ import           Control.Exception (throwIO, AsyncException(UserInterrupt)) import           Control.Monad (forever) import           Data.Functor (void)+import           Data.Maybe (isNothing) import           Data.GI.Gtk.Threading (setCurrentThreadAsGUIThread) import           Data.Maybe (fromJust) import           Data.Text (pack) import qualified GI.Gtk as Gtk +import           MusicScroll.TrackInfo (TrackByPath(tpArtist)) import           MusicScroll.TrackSuplement import           MusicScroll.UIEvent @@ -44,7 +46,7 @@ setupUIThread events outSupl =   do appCtxMVar <- atomically newEmptyTMVar      withAsyncBound (uiThread appCtxMVar outSupl) $ \a1 ->-       withAsync (uiUpdateThread events appCtxMVar) $ \a2 ->+       withAsync (uiUpdateThread events outSupl appCtxMVar) $ \a2 ->          void (waitAnyCancel [a1, a2]) >> throwIO UserInterrupt  uiThread :: TMVar AppContext -> TBQueue TrackSuplement -> IO ()@@ -61,17 +63,30 @@   Gtk.main  ----uiUpdateThread :: TBQueue UIEvent -> TMVar AppContext -> IO a-uiUpdateThread input ctxMVar = do+uiUpdateThread :: TBQueue UIEvent -> TBQueue TrackSuplement+               -> TMVar AppContext -> IO a+uiUpdateThread input outSupl ctxMVar = do   appCtx <- atomically (takeTMVar ctxMVar)   forever $ do     event <- atomically (readTBQueue input)     case event of       GotLyric track lyrics -> updateNewLyrics appCtx (track, lyrics)       ErrorOn cause -> updateErrorCause appCtx cause+                         *> tryDefaultSupplement appCtx cause outSupl  sendSuplementalInfo :: AppContext -> TBQueue TrackSuplement -> IO () sendSuplementalInfo (AppContext {..}) suplChan =   do trackSupl <- TrackSuplement <$> Gtk.entryGetText titleSuplementEntry                                  <*> Gtk.entryGetText artistSuplementEntry      atomically (writeTBQueue suplChan trackSupl)++tryDefaultSupplement+  :: AppContext -> ErrorCause -> TBQueue TrackSuplement -> IO ()+tryDefaultSupplement ctx@(AppContext {..}) cause suplChan =+  do shouldMaintainArtistSupl <- Gtk.getToggleButtonActive keepArtistNameCheck+     validGuessArtist <- (/= mempty) <$> Gtk.entryGetText artistSuplementEntry+     case cause of+       NotOnDB track+         | isNothing (tpArtist track), shouldMaintainArtistSupl,+           validGuessArtist -> sendSuplementalInfo ctx suplChan+       _ -> return ()