{-# LANGUAGE FlexibleContexts #-}
module DB
( initDB, insertBook
, findAuthorInitials, findAuthors, findGenres, findLangs, findBooks
, Connection(), clone, commit, rollback, withTransaction, disconnect
, catchSql, SqlError(..)) where
import Control.Applicative ((<$>))
import Data.Char (toUpper, toLower)
import Data.List (sort, nub, foldl1', inits, tails, intercalate, intersperse)
import Data.Maybe (maybeToList)
import System.FilePath
import System.Directory
import Text.Regex.TDFA ((=~))
import Database.HDBC
import Database.HDBC.Sqlite3
import Data.Convertible.Base (Convertible)
import Book
import Utils
import Views
dbdir :: IO FilePath
dbdir = getAppUserDataDirectory "snusmumrik"
dbfile :: IO FilePath
dbfile = do
dir <- dbdir
return $ dir </> "library.sqlite"
initDB :: IO Connection
initDB = do
dir <- dbdir
createDirectoryIfMissing True dir
file <- dbfile
db <- connectSqlite3 file
createTables db
return db
-- TODO: normalize DB schema, e.g. many authors, genres, langs per book
createTables :: Connection -> IO ()
createTables db = do
run db "create table if not exists \
\ books ( \
\ id INTEGER PRIMARY KEY AUTOINCREMENT, \
\ title TEXT, \
\ lang TEXT, \
\ date TEXT, \
\ archive TEXT, \
\ path TEXT, \
\ size INTEGER, \
\ unique (archive, path) on conflict ignore )" []
run db "create table if not exists \
\ authors ( \
\ id INTEGER PRIMARY KEY AUTOINCREMENT, \
\ name TEXT unique on conflict ignore)" []
run db "create table if not exists \
\ bookauthors ( \
\ author_id INTEGER REFERENCES authors, \
\ book_id INTEGER REFERENCES books)" []
run db "create table if not exists \
\ genres ( \
\ id INTEGER PRIMARY KEY AUTOINCREMENT, \
\ genre TEXT unique on conflict ignore)" []
run db "create table if not exists \
\ bookgenres ( \
\ genre_id INTEGER REFERENCES genres, \
\ book_id INTEGER REFERENCES books)" []
run db "create index if not exists \
\ authorix on authors ( name )" []
run db "create index if not exists \
\ titleix on books ( title )" []
run db "create index if not exists \
\ genreix on genres ( genre )" []
run db "create index if not exists \
\ locationix on books ( archive, path )" []
run db "create index if not exists \
\ bookauthorix1 on bookauthors (author_id, book_id)" []
run db "create index if not exists \
\ bookauthorix2 on bookauthors (book_id, author_id)" []
run db "create index if not exists \
\ bookgenresix1 on bookgenres (genre_id, book_id)" []
run db "create index if not exists \
\ bookgenresix2 on bookgenres (book_id,genre_id)" []
return ()
insertBook :: Connection -> Book -> IO ()
insertBook db book = do
-- insert book
run db "insert into books \
\ ( title, lang, date, size, archive, path ) \
\ values ( ?, ?, ?, ?, ?, ?)" bookValues
-- or update
-- TODO: implement DB update
-- insert authors
insertAuthors <- prepare db "insert into authors ( name ) values ( ? )"
executeMany insertAuthors $ map (:[]) $ authorNames
-- authors to books correspondence
insertBookAuthors <- prepare db $ "insert into bookauthors \
\ ( author_id, book_id ) \
\ select authors.id, books.id \
\ from authors, books \
\ where books.archive = ? and books.path = ? \
\ and authors.name = ?"
executeMany insertBookAuthors bookAuthors
-- insert genres
insertGenre <- prepare db "insert into genres ( genre ) values ( ? )"
executeMany insertGenre $ map (:[]) genreNames
-- genres to books correspondence
insertBookGenres <- prepare db $ "insert into bookgenres \
\ ( genre_id, book_id ) \
\ select g.id, b.id \
\ from genres g, books b \
\ where b.archive = ? and b.path = ? \
\ and g.genre = ?"
executeMany insertBookGenres bookGenres
return ()
where bookValues = (map fToSql [ title, lang, date ])
++ [fToSql size]
++ (map fToSql [ archive, path ])
fToSql :: (Convertible a SqlValue) => (Book -> a) -> SqlValue
fToSql f = toSql $ f book
-- archive, path must be last:
bookLoc = reverse . take 2 . reverse $ bookValues
authorNames :: [SqlValue]
authorNames = map toSql $ authors book
bookAuthors :: [[SqlValue]]
bookAuthors = map (\a -> bookLoc ++ [a]) authorNames
genreNames :: [SqlValue]
genreNames = map toSql $ genres book
bookGenres :: [[SqlValue]]
bookGenres = map (\g -> bookLoc ++ [g]) genreNames
-- | Find initials of all authors who satisfy given choices.
findAuthorInitials :: Connection -> [String] -> [View] -> IO [String]
findAuthorInitials _ cs _ | dbg ("findAuthorInitials: " ++ (showL' cs)) = stub
findAuthorInitials db choices views = do
let qsort = "order by authors.name"
let (q,params) = buildQuery AuthorInitial choices views []
rows <- quickQuery' db (trace' (q ++ qsort)) params ::IO [[SqlValue]]
let names = onlyJusts . map fromSql . column 0 $ rows
let inis = nub . map (replaceX . toLower) . concatMap head' $ names
return . trace' . map (:[]) $ inis
where
replaceX c | (toLower c) `notElem` romanOrCyrillic = '_'
| otherwise = c
head' :: [a] -> [a]
head' [] = []
head' (x:_) = [x]
-- sqlite does not support case conversion nor cares enough about char ranges
romanOrCyrillic :: [Char]
romanOrCyrillic = ['a'..'z'] ++ ['а'..'я'] ++ ['ё']
-- hack around sqlite limitations and HDBC not being friendly with substr()
startsWith :: [Char] -> String -> String
startsWith chars what =
let chars' = (map toLower chars) ++ (map toUpper chars)
anyStart = intercalate " or " $ map (\x->what++" like '"++[x]++"%'") chars'
in "( " ++ anyStart ++ " )"
-- | Find all authors who satisfy given choices.
findAuthors :: Connection -> [String] -> [View] -> IO [String]
findAuthors _ cs _ | dbg ("findAuthors: " ++ (showL' cs)) = stub
findAuthors db choices views = do
let qsort = "order by authors.name"
let (q,params) = buildQuery Author choices views []
rows <- quickQuery' db (trace' (q ++ qsort)) (trace' params) :: IO [[SqlValue]]
return . map fixname . onlyJusts . map fromSql . column 1 $ rows
-- | Find all books which satisfy given choices.
findGenres :: Connection -> [String] -> [View] -> IO [String]
findGenres _ cs _ | dbg ("findGenres: " ++ (showL' cs)) = stub
findGenres db choices views = do
-- only genres with 50+ books (avoids most of the inconsistent metadata)
let qgroup = "group by genres.id \
\having count(bookgenres.book_id) > 50 \
\order by genres.genre"
let (q,params) = buildQuery Genre choices views ["bookgenres"]
rows <- quickQuery' db (trace' (q ++ qgroup)) (trace' params) :: IO [[SqlValue]]
return . map fixname . onlyJusts . map fromSql . column 1 $ rows
findLangs :: Connection -> [String] -> [View] -> IO [String]
findLangs _ cs _ | dbg ("findLangs: " ++ (showL' cs)) = stub
findLangs db choices views = do
let (q,params) = buildQuery Lang choices views []
rows <- quickQuery' db (trace' q) (trace' params) :: IO [[SqlValue]]
let langs = onlyJusts . map fromSql . column 0 $ rows
-- skip languages which are not two-letter lower-case codes
return . map fixname . filter ( =~ "^[a-z]{2}$") $ langs
-- | Find all books which satisfy given choices.
findBooks :: Connection -> [String] -> [View] -> IO [Book]
findBooks _ cs _ | dbg ("findBooks: " ++ (showL' cs)) = stub
findBooks db choices views = do
let qsort = "order by books.title"
let (q,params) = buildQuery (last views) choices views []
rows <- quickQuery' db (trace' (q ++ qsort)) (trace' params) :: IO [[SqlValue]]
let books = onlyJusts $ map toBook rows :: [(Int,Book)]
mapM (addAuthorsAndGenres db) books :: IO [Book]
buildQuery :: View -- ^ what is requested
-> [String] -- ^ choices made
-> [View] -- ^ views for previous choices
-> [String] -- ^ extra table to select from, usually []
-> (String,[SqlValue]) -- ^ (query, positional params)
buildQuery w cs ss _
| dbg ("buildQuery: " ++ (show w) ++ " " ++ (show $ zip cs ss)) = stub
buildQuery what choices views xtratables =
let cvs = zip choices views
predicates = map fromWhere cvs
(begin,basetbl) = selectCols what
joins = joinWhere $ basetbl:(concatMap fst3 predicates) ++ xtratables
fws = joinClauses $ joins:predicates
tables = nub $ basetbl:(fst3 fws) ++ xtratables
q = intercalate " " $ [begin]
++ ("from":(intersperse "," tables))
++ (whereClause $ snd3 fws)
in (q ++ " ", map toSql $ trd3 fws)
where
-- column order is important, some fragile code depends on it (see column)
selectCols (Author) = ( "select distinct authors.id, authors.name"
, "authors" )
selectCols (AuthorInitial) = ( "select distinct authors.name"
, "authors" )
selectCols (Title) = ( "select distinct books.id, books.title, books.lang, \
\ books.date, books.archive, books.path, books.size"
, "books" )
selectCols (Genre) = ( "select distinct genres.id, genres.genre"
, "genres" )
selectCols (Lang) = ( "select distinct books.lang", "books" )
whereClause [] = [""]
whereClause ps = "where":(intersperse "and" ps)
-- | Produce predicative clauses as ([tables],[conditions],[positional_params])
fromWhere :: (String,View) -> ([String],[String],[String])
fromWhere (c, Author) =
( ["authors"]
, ["authors.name = ?"]
, [unfixname c])
fromWhere (c, Genre) =
( ["genres"]
, ["genres.genre = ?"]
, [unfixname c])
fromWhere (c, Lang) =
( ["books"]
, ["books.lang = ?"]
, [c])
fromWhere (c, Title) =
let n = unfixname $ titleFromFileName c in
( ["books"]
, ["books.title = ?"]
, [unfixname n])
fromWhere (c:_, AuthorInitial)
| c /= '_' = ( ["authors"]
, [ "(authors.name like ? or authors.name like ?)"]
, [ (toLower c):"%", (toUpper c):"%" ])
| c == '_' = ( ["authors"]
, ["not " ++ (startsWith romanOrCyrillic "authors.name")]
, [])
fromWhere _ = ([], [], [])
-- | Produce join clauses as ([tables],[conditions],[positional_params])
joinWhere :: [String] -- ^ tables used
-> ([String],[String],[String]) -- ^ necessary join clause
joinWhere tables =
let joins = map (uncurry joinWhere') (combos tables)
in joinClauses joins
where
combos xs =
let xs' = nub . sort $ xs
in if length xs' < 2
then [] -- nothing to join
else [ (last h,t') | (h,t) <- init.tail $ zip (inits xs') (tails xs')
, t' <- t ]
joinWhere' "authors" "books" = ( [ "authors", "bookauthors", "books" ]
, [ "authors.id = bookauthors.author_id"
, "bookauthors.book_id = books.id" ]
, [])
joinWhere' "authors" "genres" = ( [ "authors", "bookauthors", "bookgenres", "genres" ]
, [ "authors.id = bookauthors.author_id"
, "bookauthors.book_id = bookgenres.book_id"
, "bookgenres.genre_id = genres.id" ]
, [])
joinWhere' "books" "genres" = ( [ "genres", "bookgenres", "books" ]
, [ "genres.id = bookgenres.genre_id"
, "bookgenres.book_id = books.id" ]
, [])
joinWhere' "bookgenres" "genres" = ( [ "genres", "bookgenres" ]
, [ "genres.id = bookgenres.genre_id" ]
, [])
joinWhere' _ _ = ([], [], [])
joinClauses :: [([String],[String],[String])] -> ([String],[String],[String])
joinClauses [] = ([], [], [])
joinClauses cs = foldl1' (liftT2 (++)) cs
addAuthorsAndGenres :: Connection -> (Int, Book) -> IO Book
addAuthorsAndGenres _ b | dbg ("addAuthorsAndGenres: " ++ (show $ fst b)) = stub
addAuthorsAndGenres db (bid, book) = do
let authorsQ = "select distinct a.name \
\ from authors a \
\ join bookauthors ba on a.id = ba.author_id \
\ where ba.book_id = ? \
\ order by a.name"
let genresQ = "select distinct g.genre \
\ from genres g \
\ join bookgenres bg on bg.genre_id = g.id \
\ where bg.book_id = ? \
\ order by g.genre"
authors' <- column 0 <$> quickQuery' db authorsQ [toSql bid]
genres' <- column 0 <$> quickQuery' db genresQ [toSql bid]
return $ book { authors = sort $ map fromSql authors'
, genres = sort $ map fromSql genres' }
toBook :: [SqlValue] -> Maybe (Int, Book)
toBook vs | length vs /= 7 = Nothing
toBook [id',title',lang',date',archive',path',size']
| otherwise =
let book = unknownBook {
title = fromSql title'
, date = fromSql date'
, lang = fromSql lang'
, archive = fromSql archive'
, path = fromSql path'
, size = fromSql size' }
in Just (fromSql id', book)
toBook _ = Nothing
onlyJusts :: [Maybe a] -> [a]
onlyJusts = concatMap maybeToList
column :: Int -> [[a]] -> [a]
column n xss = onlyJusts $ map (maybeNth n) xss