LyricsPipeline.hs

module MusicScroll.LyricsPipeline (lyricsThread, sizeOfQueue) where

-- | Discriminate between getting the lyrics from SQLite or the web.

import Control.Concurrent.Async (withAsync, waitAnyCancel)
import Control.Concurrent.STM (atomically, orElse)
import Control.Concurrent.STM.TBQueue ( TBQueue, readTBQueue, writeTBQueue,
                                        newTBQueue )
import Control.Applicative (Alternative(..))
import Control.Monad.Trans.State (StateT, get, put, evalStateT)
import Control.Monad.IO.Class (liftIO)
import Control.Monad (forever, when)
import Numeric.Natural (Natural)
import Data.Functor (void)
import Data.Maybe (isJust)

import MusicScroll.DatabaseUtils (getDBLyrics, getDBSong)
import MusicScroll.TrackInfo
import MusicScroll.TrackSuplement
import MusicScroll.AZLyrics (getLyricsFromWeb)
import MusicScroll.UIEvent

sizeOfQueue :: Natural
sizeOfQueue = 5

lyricsThread :: TBQueue TrackIdentifier -> TBQueue TrackSuplement
             -> TBQueue UIEvent -> IO ()
lyricsThread inputIdent inputSupl output =
  do songFilterChan <- atomically (newTBQueue sizeOfQueue)
     let seenSongThread' = seenSongsThread inputIdent inputSupl songFilterChan
     withAsync (evalStateT seenSongThread' Nothing) $ \seenSongsA ->
       withAsync (getLyricsThread songFilterChan output) $ \getLyricsA ->
         void $ waitAnyCancel [seenSongsA, getLyricsA]

-- | 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 :: TBQueue TrackIdentifier -> TBQueue TrackSuplement
                -> TBQueue TrackIdentifier -> StateT (Maybe TrackIdentifier) IO a
seenSongsThread inputIdent inputSupl output = forever $
  do mTrackIdent <- mergeQueue inputIdent inputSupl
     notSeen <- (/=) <$> get <*> pure mTrackIdent
     when (notSeen && isJust mTrackIdent) $ do
       let Just trackIdent = mTrackIdent
       put mTrackIdent
       liftIO . atomically $ writeTBQueue output trackIdent

mergeQueue :: TBQueue TrackIdentifier -> TBQueue TrackSuplement
           -> StateT (Maybe TrackIdentifier) IO (Maybe TrackIdentifier)
mergeQueue inputIdent inputSupl =
  do let cleanInputIdent = cleanTrack <$> readTBQueue inputIdent
         mergedInputChan = (Left <$> cleanInputIdent) `orElse`
                           (Right <$> readTBQueue inputSupl)
     mOldTrack   <- get
     mergedInput <- liftIO $ atomically mergedInputChan

     let suplement' :: TrackSuplement -> Maybe TrackIdentifier
         suplement' supl = (Right . suplement supl) <$> mOldTrack
         newTrack :: Maybe TrackIdentifier
         newTrack = either Just suplement' mergedInput

     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

caseByInfo :: TrackInfo -> IO UIEvent
caseByInfo track =
  let tryGetLyrics = getDBLyrics (tUrl track) <|> getLyricsFromWeb track
  in (GotLyric track <$> tryGetLyrics) <|> pure (ErrorOn (NoLyricsOnWeb track))

caseByPath :: TrackByPath -> IO UIEvent
caseByPath track =
  ((uncurry GotLyric) <$> getDBSong (tpPath track)) <|>
  pure (ErrorOn (NotOnDB track))