DatabaseUtils.hs

{-# language OverloadedStrings, TypeApplications, RecordWildCards #-}
module MusicScroll.DatabaseUtils
  ( getDBLyrics
  , getDBSong
  , insertDBLyrics
  , getDBPath
  , sqlDBCreate
  ) where

import           Prelude hiding (null)
import           Control.Applicative (Alternative(..))
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)
import           System.IO (withFile, IOMode(..))
import           Data.Text (Text)
import           Database.SQLite.Simple
import           System.Environment.XDG.BaseDir (getUserCacheDir)
import           Data.Coerce
import           System.Directory (createDirectory)

import           MusicScroll.TrackInfo (TrackInfo(..), SongFilePath)
import           MusicScroll.Providers.Utils (Lyrics(..))

getDBLyrics :: SongFilePath -> ReaderT 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)

insertDBLyrics :: TrackInfo -> Lyrics -> ReaderT Connection IO ()
insertDBLyrics (TrackInfo {..}) lyrics =
  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"
               createDirectory cacheDir <|> return ()
               return $ cacheDir ++ "/" ++ "lyrics.db"

-- | We use the exception thrown by withFile.
fileHash :: FilePath -> IO String
fileHash fp = withFile fp ReadMode $ \hdl ->
  let chunkSize = 512 * 1024
      looper ctx =
          do upd <- hGet hdl chunkSize
             if null upd
               then return (show (hashFinalize ctx))
               else do let newCtx = hashUpdate ctx upd
                       evaluate (rnf newCtx) -- Important!
                       looper newCtx
  in looper (hashInit @SHA1)

sqlDBCreate, sqlInsertSong, sqlExtractSong :: Query
sqlDBCreate =
  "create table if not exists MusicScrollTable(\n\
  \  songHash text primary key,\n\
  \  artist text,\n\
  \  title text, \n\
  \  lyrics text );"

sqlInsertSong = "insert into MusicScrollTable values (?, ?, ?, ?);"

sqlExtractSong =
  "select title, artist, lyrics from MusicScrollTable where songHash == ?;"