{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- |
-- Module      : Database.HDBC.Schema.SQLite3
-- Copyright   : 2013 Shohei Murayama, 2017-2019 Kei Hibiono
-- License     : BSD3
--
-- Maintainer  : shohei.murayama@gmail.com
-- Stability   : experimental
-- Portability : unknown
module Database.HDBC.Schema.SQLite3 (
  driverSQLite3
  ) where

import qualified Database.Relational.Schema.SQLite3.IndexInfo as IndexInfo
import qualified Database.Relational.Schema.SQLite3.IndexList as IndexList
import qualified Database.Relational.Schema.SQLite3.TableInfo as TableInfo

import Control.Applicative ((<|>))
import Control.Monad (guard)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT)
import Data.List (isPrefixOf, sort, sortBy)
import Data.Map (fromList)
import Database.HDBC (IConnection, SqlValue)
import Database.HDBC.Record.Query (runQuery')
import Database.HDBC.Record.Persistable ()
import Database.HDBC.Schema.Driver
  (TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe,
   Driver, driverConfig, getFieldsWithMap, getPrimaryKey, emptyDriver)
import Database.Record (FromSql, ToSql)
import Database.Relational.Schema.SQLite3 (getType, indexInfoQuerySQL, indexListQuerySQL, normalizeColumn,
                                           normalizeType, notNull, tableInfoQuerySQL)
import Database.Relational.Schema.SQLite3.IndexInfo (IndexInfo)
import Database.Relational.Schema.SQLite3.IndexList (IndexList)
import Database.Relational.Schema.SQLite3.TableInfo (TableInfo)
import Database.Relational.Schema.SQLite3 (config)
import Language.Haskell.TH (TypeQ)


instance FromSql SqlValue TableInfo
instance ToSql SqlValue TableInfo

instance FromSql SqlValue IndexList
instance ToSql SqlValue IndexList

instance FromSql SqlValue IndexInfo
instance ToSql SqlValue IndexInfo

logPrefix :: String -> String
logPrefix :: String -> String
logPrefix = ("SQLite3: " String -> String -> String
forall a. [a] -> [a] -> [a]
++)

putLog :: LogChan -> String -> IO ()
putLog :: LogChan -> String -> IO ()
putLog lchan :: LogChan
lchan = LogChan -> String -> IO ()
putVerbose LogChan
lchan (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
logPrefix

compileError :: LogChan -> String -> MaybeT IO a
compileError :: LogChan -> String -> MaybeT IO a
compileError lchan :: LogChan
lchan = LogChan -> String -> MaybeT IO a
forall a. LogChan -> String -> MaybeT IO a
failWith LogChan
lchan (String -> MaybeT IO a)
-> (String -> String) -> String -> MaybeT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
logPrefix

getPrimaryKey' :: IConnection conn
               => conn
               -> LogChan
               -> String
               -> String
               -> IO [String]
getPrimaryKey' :: conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey' conn :: conn
conn lchan :: LogChan
lchan scm :: String
scm tbl :: String
tbl = do
    [TableInfo]
tblinfo <- conn -> Query () TableInfo -> () -> IO [TableInfo]
forall conn p a.
(IConnection conn, ToSql SqlValue p, FromSql SqlValue a) =>
conn -> Query p a -> p -> IO [a]
runQuery' conn
conn (String -> String -> Query () TableInfo
tableInfoQuerySQL String
scm String
tbl) ()
    let primColumns :: [String]
primColumns = [ String -> String
normalizeColumn (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ TableInfo -> String
TableInfo.name TableInfo
ti
                      | TableInfo
ti <- [TableInfo]
tblinfo, TableInfo -> Int16
TableInfo.pk TableInfo
ti Int16 -> Int16 -> Bool
forall a. Eq a => a -> a -> Bool
== 1 ]
    if [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
primColumns Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 1 then do
        LogChan -> String -> IO ()
putLog LogChan
lchan (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "getPrimaryKey: key=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
primColumns
        [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
primColumns
     else do
        [IndexList]
idxlist <- conn -> Query () IndexList -> () -> IO [IndexList]
forall conn p a.
(IConnection conn, ToSql SqlValue p, FromSql SqlValue a) =>
conn -> Query p a -> p -> IO [a]
runQuery' conn
conn (String -> String -> Query () IndexList
indexListQuerySQL String
scm String
tbl) ()
        let idxNames :: [String]
idxNames = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf "sqlite_autoindex_")
                       ([String] -> [String])
-> ([IndexList] -> [String]) -> [IndexList] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IndexList -> String) -> [IndexList] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map IndexList -> String
IndexList.name
                       ([IndexList] -> [String])
-> ([IndexList] -> [IndexList]) -> [IndexList] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IndexList -> Bool) -> [IndexList] -> [IndexList]
forall a. (a -> Bool) -> [a] -> [a]
filter ((1 Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
==) (Int64 -> Bool) -> (IndexList -> Int64) -> IndexList -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndexList -> Int64
IndexList.unique) ([IndexList] -> [String]) -> [IndexList] -> [String]
forall a b. (a -> b) -> a -> b
$ [IndexList]
idxlist
        [[IndexInfo]]
idxInfos <- (String -> IO [IndexInfo]) -> [String] -> IO [[IndexInfo]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ixn :: String
ixn -> conn -> Query () IndexInfo -> () -> IO [IndexInfo]
forall conn p a.
(IConnection conn, ToSql SqlValue p, FromSql SqlValue a) =>
conn -> Query p a -> p -> IO [a]
runQuery' conn
conn (String -> String -> Query () IndexInfo
indexInfoQuerySQL String
scm String
ixn) ()) [String]
idxNames
        let isPrimaryKey :: [IndexInfo] -> Bool
isPrimaryKey = ([String] -> [String]
forall a. Ord a => [a] -> [a]
sort [String]
primColumns [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
==) ([String] -> Bool)
-> ([IndexInfo] -> [String]) -> [IndexInfo] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String])
-> ([IndexInfo] -> [String]) -> [IndexInfo] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IndexInfo -> String) -> [IndexInfo] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
normalizeColumn (String -> String) -> (IndexInfo -> String) -> IndexInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndexInfo -> String
IndexInfo.name)
        let idxInfo :: [IndexInfo]
idxInfo = [[IndexInfo]] -> [IndexInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[IndexInfo]] -> [IndexInfo])
-> ([[IndexInfo]] -> [[IndexInfo]]) -> [[IndexInfo]] -> [IndexInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [[IndexInfo]] -> [[IndexInfo]]
forall a. Int -> [a] -> [a]
take 1 ([[IndexInfo]] -> [[IndexInfo]])
-> ([[IndexInfo]] -> [[IndexInfo]])
-> [[IndexInfo]]
-> [[IndexInfo]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([IndexInfo] -> Bool) -> [[IndexInfo]] -> [[IndexInfo]]
forall a. (a -> Bool) -> [a] -> [a]
filter [IndexInfo] -> Bool
isPrimaryKey ([[IndexInfo]] -> [IndexInfo]) -> [[IndexInfo]] -> [IndexInfo]
forall a b. (a -> b) -> a -> b
$ [[IndexInfo]]
idxInfos
        let comp :: IndexInfo -> IndexInfo -> Ordering
comp x :: IndexInfo
x y :: IndexInfo
y = Int64 -> Int64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (IndexInfo -> Int64
IndexInfo.seqno IndexInfo
x) (IndexInfo -> Int64
IndexInfo.seqno IndexInfo
y)
        let primColumns' :: [String]
primColumns' = (IndexInfo -> String) -> [IndexInfo] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map IndexInfo -> String
IndexInfo.name ([IndexInfo] -> [String])
-> ([IndexInfo] -> [IndexInfo]) -> [IndexInfo] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IndexInfo -> IndexInfo -> Ordering) -> [IndexInfo] -> [IndexInfo]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy IndexInfo -> IndexInfo -> Ordering
comp ([IndexInfo] -> [String]) -> [IndexInfo] -> [String]
forall a b. (a -> b) -> a -> b
$ [IndexInfo]
idxInfo
        LogChan -> String -> IO ()
putLog LogChan
lchan (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "getPrimaryKey: keys=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
primColumns'
        [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
primColumns'

getColumns' :: IConnection conn
            => TypeMap
            -> conn
            -> LogChan
            -> String
            -> String
            -> IO ([(String, TypeQ)], [Int])
getColumns' :: TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getColumns' tmap :: TypeMap
tmap conn :: conn
conn lchan :: LogChan
lchan scm :: String
scm tbl :: String
tbl = (TypeMap, [Int])
-> ((TypeMap, [Int]) -> (TypeMap, [Int]))
-> MaybeT IO (TypeMap, [Int])
-> IO (TypeMap, [Int])
forall b a. b -> (a -> b) -> MaybeT IO a -> IO b
maybeIO ([], []) (TypeMap, [Int]) -> (TypeMap, [Int])
forall a. a -> a
id (MaybeT IO (TypeMap, [Int]) -> IO (TypeMap, [Int]))
-> MaybeT IO (TypeMap, [Int]) -> IO (TypeMap, [Int])
forall a b. (a -> b) -> a -> b
$ do
    [TableInfo]
rows <- IO [TableInfo] -> MaybeT IO [TableInfo]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO [TableInfo] -> MaybeT IO [TableInfo])
-> IO [TableInfo] -> MaybeT IO [TableInfo]
forall a b. (a -> b) -> a -> b
$ conn -> Query () TableInfo -> () -> IO [TableInfo]
forall conn p a.
(IConnection conn, ToSql SqlValue p, FromSql SqlValue a) =>
conn -> Query p a -> p -> IO [a]
runQuery' conn
conn (String -> String -> Query () TableInfo
tableInfoQuerySQL String
scm String
tbl) ()
    Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [TableInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TableInfo]
rows) MaybeT IO () -> MaybeT IO () -> MaybeT IO ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
      LogChan -> String -> MaybeT IO ()
forall a. LogChan -> String -> MaybeT IO a
compileError LogChan
lchan
      ("getFields: No columns found: schema = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
scm String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", table = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tbl)
    let columnId :: TableInfo -> Int64
columnId = TableInfo -> Int64
TableInfo.cid
    let notNullIdxs :: [Int]
notNullIdxs = (TableInfo -> Int) -> [TableInfo] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> (TableInfo -> Int64) -> TableInfo -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableInfo -> Int64
columnId) ([TableInfo] -> [Int])
-> ([TableInfo] -> [TableInfo]) -> [TableInfo] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TableInfo -> Bool) -> [TableInfo] -> [TableInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter TableInfo -> Bool
notNull ([TableInfo] -> [Int]) -> [TableInfo] -> [Int]
forall a b. (a -> b) -> a -> b
$ [TableInfo]
rows
    IO () -> MaybeT IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> MaybeT IO ())
-> (String -> IO ()) -> String -> MaybeT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogChan -> String -> IO ()
putLog LogChan
lchan
        (String -> MaybeT IO ()) -> String -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ "getFields: num of columns = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([TableInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TableInfo]
rows)
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", not null columns = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Int] -> String
forall a. Show a => a -> String
show [Int]
notNullIdxs
    let getType' :: TableInfo -> MaybeT IO (String, TypeQ)
getType' ti :: TableInfo
ti =
          Maybe (String, TypeQ) -> MaybeT IO (String, TypeQ)
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
hoistMaybe (Map String TypeQ -> TableInfo -> Maybe (String, TypeQ)
getType (TypeMap -> Map String TypeQ
forall k a. Ord k => [(k, a)] -> Map k a
fromList TypeMap
tmap) TableInfo
ti) MaybeT IO (String, TypeQ)
-> MaybeT IO (String, TypeQ) -> MaybeT IO (String, TypeQ)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
          LogChan -> String -> MaybeT IO (String, TypeQ)
forall a. LogChan -> String -> MaybeT IO a
compileError LogChan
lchan
          ("Type mapping is not defined against SQLite3 type: "
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
normalizeType (TableInfo -> String
TableInfo.ctype TableInfo
ti))
    TypeMap
types <- (TableInfo -> MaybeT IO (String, TypeQ))
-> [TableInfo] -> MaybeT IO TypeMap
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TableInfo -> MaybeT IO (String, TypeQ)
getType' [TableInfo]
rows
    (TypeMap, [Int]) -> MaybeT IO (TypeMap, [Int])
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeMap
types, [Int]
notNullIdxs)

-- | Driver implementation
driverSQLite3 :: IConnection conn => Driver conn
driverSQLite3 :: Driver conn
driverSQLite3 =
    Driver conn
forall conn. IConnection conn => Driver conn
emptyDriver { getFieldsWithMap :: TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getFieldsWithMap = TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
forall conn.
IConnection conn =>
TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getColumns' }
                { getPrimaryKey :: conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey    = conn -> LogChan -> String -> String -> IO [String]
forall conn.
IConnection conn =>
conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey' }
                { driverConfig :: Config
driverConfig     = Config
config }