{-# 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