DatabaseUtils.hs

{-# language OverloadedStrings, TypeApplications, RecordWildCards #-}
module MusicScroll.DatabaseUtils
  ( getDBLyrics
  , getDBSong
  , sqlDBCreate
  , InsertStategy
  , insertStrat
  , updateStrat
  , getDBPath
  ) 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.Concurrent.MVar
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 (MVar Connection) IO Lyrics
getDBLyrics songUrl = snd <$> getDBSong songUrl

getDBSong :: SongFilePath -> ReaderT (MVar Connection) IO (TrackInfo, Lyrics)
getDBSong songUrl = ask >>= \mconn -> liftIO $
  do songHash <- fileHash songUrl
     songRaw <- withMVar mconn
                   (\conn -> query conn sqlExtractSong (Only songHash))
     case (songRaw :: [ (Text, Text, Text) ]) of
       [] -> empty
       (title, artist, lyrics):_ ->
         let track = TrackInfo title artist songUrl
         in pure (track, coerce lyrics)

type InsertStategy = TrackInfo -> Lyrics -> ReaderT (MVar Connection) IO ()

insertStrat :: InsertStategy
insertStrat (TrackInfo {..}) lyrics = ask >>= \mconn -> liftIO $
  do songHash <- fileHash tUrl
     let params = (songHash, tArtist, tTitle, coerce lyrics :: Text)
     withMVar mconn $ \conn -> execute conn sqlInsertSong params

updateStrat :: InsertStategy
updateStrat (TrackInfo {..}) lyrics = ask >>= \mconn -> liftIO $
  do songHash <- fileHash tUrl
     let params = (coerce lyrics :: Text, songHash)
     withMVar mconn $ \conn -> execute conn sqlUpdateSong 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, sqlUpdateSong :: 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 == ?;"

sqlUpdateSong =
  "update MusicScrollTable set lyrics = ? where songHash = ? ;"