{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -fno-warn-deprecations #-} -- Pattern match 'PersistDbSpecific'
-- | A MySQL backend for @persistent@.
module Database.Persist.MySQL
  ( withMySQLPool
  , withMySQLConn
  , createMySQLPool
  , module Database.Persist.Sql
  , MySQLConnectInfo
  , mkMySQLConnectInfo
  , setMySQLConnectInfoPort
  , setMySQLConnectInfoCharset
  , MySQLConf
  , mkMySQLConf
  , mockMigration
  -- * @ON DUPLICATE KEY UPDATE@ Functionality
  , insertOnDuplicateKeyUpdate
  , insertEntityOnDuplicateKeyUpdate
  , insertManyOnDuplicateKeyUpdate
  , insertEntityManyOnDuplicateKeyUpdate
  , HandleUpdateCollision
  , copyField
  , copyUnlessNull
  , copyUnlessEmpty
  , copyUnlessEq
  -- * TLS configuration
  , setMySQLConnectInfoTLS
  , MySQLTLS.TrustedCAStore(..)
  , MySQLTLS.makeClientParams
  , MySQLTLS.makeClientParams'
  , openMySQLConn
  -- * persistent-mysql compatibility
  , myConnInfo
  , myPoolSize
) where

import Control.Arrow
import Control.Monad
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Control.Monad.Logger (MonadLoggerIO, runNoLoggingT)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Control.Monad.Trans.Reader (runReaderT, ReaderT)
import Control.Monad.Trans.Writer (runWriterT)

import qualified Data.List.NonEmpty as NEL
import Data.Acquire (Acquire, mkAcquire, with)
import Data.Aeson
import Data.Aeson.Types (modifyFailure)
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Char8  as BSC
import           Data.Conduit (ConduitM, (.|), runConduit, runConduitRes)
import qualified Data.Conduit.List as CL
import Data.Either (partitionEithers)
import Data.Fixed (Pico)
import Data.Function (on)
import Data.IORef
import Data.Int (Int64)
import Data.List (find, groupBy, intercalate, sort)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import qualified Data.Monoid as Monoid
import Data.Pool (Pool)
import Data.Text (Text, pack)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import GHC.Stack
import System.Environment (getEnvironment)

import Database.Persist.Sql
import qualified Database.Persist.SqlBackend as SqlBackend
import Database.Persist.SqlBackend.Internal
import Database.Persist.SqlBackend.StatementCache (mkSimpleStatementCache, mkStatementCache)
import Database.Persist.Sql.Types.Internal (mkPersistBackend, makeIsolationLevelStatement)
import qualified Database.Persist.Sql.Util as Util

import qualified Database.MySQL.Base    as MySQL
import qualified Database.MySQL.Protocol.Escape as MySQL
import qualified Database.MySQL.TLS     as MySQLTLS
import qualified Network.TLS            as TLS
import qualified System.IO.Streams      as Streams
import qualified Data.Time.Calendar     as Time
import qualified Data.Time.LocalTime    as Time
import qualified Network.Socket         as NetworkSocket
import qualified Data.Word              as Word
import           Data.String (fromString)

-- | Create a MySQL connection pool and run the given action.
-- The pool is properly released after the action finishes using
-- it.  Note that you should not use the given 'ConnectionPool'
-- outside the action since it may be already been released.
withMySQLPool :: (MonadLoggerIO m, MonadUnliftIO m, IsPersistBackend backend, BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend)
    => MySQLConnectInfo
    -- ^ Connection information.
    -> Int
    -- ^ Number of connections to be kept open in the pool.
    -> (Pool backend -> m a)
    -- ^ Action to be executed that uses the connection pool.
    -> m a
withMySQLPool :: forall (m :: * -> *) backend a.
(MonadLoggerIO m, MonadUnliftIO m, IsPersistBackend backend,
 BaseBackend backend ~ SqlBackend,
 BackendCompatible SqlBackend backend) =>
MySQLConnectInfo -> Int -> (Pool backend -> m a) -> m a
withMySQLPool MySQLConnectInfo
ci = forall backend (m :: * -> *) a.
(MonadLoggerIO m, MonadUnliftIO m,
 BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> Int -> (Pool backend -> m a) -> m a
withSqlPool forall a b. (a -> b) -> a -> b
$ forall backend.
(IsPersistBackend backend, BaseBackend backend ~ SqlBackend) =>
MySQLConnectInfo -> LogFunc -> IO backend
open' MySQLConnectInfo
ci

-- | Create a MySQL connection pool.  Note that it's your
-- responsibility to properly close the connection pool when
-- unneeded.  Use 'withMySQLPool' for automatic resource control.
createMySQLPool :: (MonadUnliftIO m, MonadLoggerIO m, IsPersistBackend backend, BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend)
    => MySQLConnectInfo
    -- ^ Connection information.
    -> Int
    -- ^ Number of connections to be kept open in the pool.
    -> m (Pool backend)
createMySQLPool :: forall (m :: * -> *) backend.
(MonadUnliftIO m, MonadLoggerIO m, IsPersistBackend backend,
 BaseBackend backend ~ SqlBackend,
 BackendCompatible SqlBackend backend) =>
MySQLConnectInfo -> Int -> m (Pool backend)
createMySQLPool MySQLConnectInfo
ci = forall backend (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m,
 BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> Int -> m (Pool backend)
createSqlPool forall a b. (a -> b) -> a -> b
$ forall backend.
(IsPersistBackend backend, BaseBackend backend ~ SqlBackend) =>
MySQLConnectInfo -> LogFunc -> IO backend
open' MySQLConnectInfo
ci

-- | Same as 'withMySQLPool', but instead of opening a pool
-- of connections, only one connection is opened.
withMySQLConn :: (MonadUnliftIO m, MonadLoggerIO m, IsPersistBackend backend, BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend)
    => MySQLConnectInfo
    -- ^ Connection information.
    -> (backend -> m a)
    -- ^ Action to be executed that uses the connection.
    -> m a
withMySQLConn :: forall (m :: * -> *) backend a.
(MonadUnliftIO m, MonadLoggerIO m, IsPersistBackend backend,
 BaseBackend backend ~ SqlBackend,
 BackendCompatible SqlBackend backend) =>
MySQLConnectInfo -> (backend -> m a) -> m a
withMySQLConn = forall backend (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m,
 BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> (backend -> m a) -> m a
withSqlConn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall backend.
(IsPersistBackend backend, BaseBackend backend ~ SqlBackend) =>
MySQLConnectInfo -> LogFunc -> IO backend
open'

-- | Internal function that opens a @mysql-haskell@ connection to the server.
connect' :: MySQLConnectInfo -> IO MySQL.MySQLConn
connect' :: MySQLConnectInfo -> IO MySQLConn
connect' (MySQLConnectInfo ConnectInfo
innerCi Maybe ClientParams
Nothing)
  = ConnectInfo -> IO MySQLConn
MySQL.connect ConnectInfo
innerCi
connect' (MySQLConnectInfo ConnectInfo
innerCi (Just ClientParams
tls))
  = ConnectInfo -> (ClientParams, [Char]) -> IO MySQLConn
MySQLTLS.connect ConnectInfo
innerCi (ClientParams
tls, [Char]
"persistent-mysql-haskell")

-- | Open a connection to MySQL server, initialize the 'SqlBackend' and return
-- their tuple
--
-- @since 2.12.1.0
openMySQLConn :: (IsPersistBackend backend, BaseBackend backend ~ SqlBackend)
      => MySQLConnectInfo
      -> LogFunc
      -> IO (MySQL.MySQLConn, backend)
openMySQLConn :: forall backend.
(IsPersistBackend backend, BaseBackend backend ~ SqlBackend) =>
MySQLConnectInfo -> LogFunc -> IO (MySQLConn, backend)
openMySQLConn ci :: MySQLConnectInfo
ci@(MySQLConnectInfo ConnectInfo
innerCi Maybe ClientParams
_) LogFunc
logFunc = do
    MySQLConn
conn <- MySQLConnectInfo -> IO MySQLConn
connect' MySQLConnectInfo
ci
    MySQLConn -> Bool -> IO ()
autocommit' MySQLConn
conn Bool
False -- disable autocommit!
    IORef (Map Text Statement)
smap <- forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ forall k a. Map k a
Map.empty
    let stCache :: StatementCache
stCache = MkStatementCache -> StatementCache
mkStatementCache forall a b. (a -> b) -> a -> b
$ IORef (Map Text Statement) -> MkStatementCache
mkSimpleStatementCache IORef (Map Text Statement)
smap
    let backend :: backend
backend = 
          forall backend.
IsPersistBackend backend =>
BaseBackend backend -> backend
mkPersistBackend forall a b. (a -> b) -> a -> b
$ 
          forall sup sub. BackendCompatible sup sub => sub -> sup
projectBackend forall a b. (a -> b) -> a -> b
$ 
          SqlBackend
          { connPrepare :: Text -> IO Statement
connPrepare    = MySQLConn -> Text -> IO Statement
prepare' MySQLConn
conn
          , connStmtMap :: StatementCache
connStmtMap    = StatementCache
stCache
          , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult
connInsertSql  = EntityDef -> [PersistValue] -> InsertSqlResult
insertSql'
          , connInsertManySql :: Maybe (EntityDef -> [[PersistValue]] -> InsertSqlResult)
connInsertManySql = forall a. Maybe a
Nothing
          , connUpsertSql :: Maybe
  (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text)
connUpsertSql = forall a. Maybe a
Nothing
          , connPutManySql :: Maybe (EntityDef -> Int -> Text)
connPutManySql = forall a. a -> Maybe a
Just EntityDef -> Int -> Text
putManySql
          , connClose :: IO ()
connClose      = MySQLConn -> IO ()
MySQL.close MySQLConn
conn
          , connMigrateSql :: [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)])
connMigrateSql = ConnectInfo
-> [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)])
migrate' ConnectInfo
innerCi
          , connBegin :: (Text -> IO Statement) -> Maybe IsolationLevel -> IO ()
connBegin      = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ MySQLConn -> Maybe IsolationLevel -> IO ()
begin' MySQLConn
conn
          , connCommit :: (Text -> IO Statement) -> IO ()
connCommit     = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ MySQLConn -> IO ()
commit' MySQLConn
conn
          , connRollback :: (Text -> IO Statement) -> IO ()
connRollback   = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ MySQLConn -> IO ()
rollback' MySQLConn
conn
          , connEscapeFieldName :: FieldNameDB -> Text
connEscapeFieldName = [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameDB -> [Char]
escapeF
          , connEscapeTableName :: EntityDef -> Text
connEscapeTableName = [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityNameDB -> [Char]
escapeE forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameDB
getEntityDBName
          , connEscapeRawName :: Text -> Text
connEscapeRawName = [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
escapeDBName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack 
          , connNoLimit :: Text
connNoLimit    = Text
"LIMIT 18446744073709551615"
          -- This noLimit is suggested by MySQL's own docs, see
          -- <http://dev.mysql.com/doc/refman/5.5/en/select.html>
          , connRDBMS :: Text
connRDBMS      = Text
"mysql"
          , connLimitOffset :: (Int, Int) -> Text -> Text
connLimitOffset = Text -> (Int, Int) -> Text -> Text
decorateSQLWithLimitOffset Text
"LIMIT 18446744073709551615"
          , connLogFunc :: LogFunc
connLogFunc    = LogFunc
logFunc
          , connMaxParams :: Maybe Int
connMaxParams = forall a. Maybe a
Nothing
          , connRepsertManySql :: Maybe (EntityDef -> Int -> Text)
connRepsertManySql = forall a. a -> Maybe a
Just EntityDef -> Int -> Text
repsertManySql
          , connVault :: Vault
connVault = forall a. Monoid a => a
mempty
          , connHooks :: SqlBackendHooks
connHooks = SqlBackendHooks
emptySqlBackendHooks
          }
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (MySQLConn
conn,backend
backend)

-- | Internal function that opens a connection to the MySQL server.
open' :: (IsPersistBackend backend, BaseBackend backend ~ SqlBackend)
      => MySQLConnectInfo
      -> LogFunc
      -> IO backend
open' :: forall backend.
(IsPersistBackend backend, BaseBackend backend ~ SqlBackend) =>
MySQLConnectInfo -> LogFunc -> IO backend
open' MySQLConnectInfo
ci LogFunc
logFunc = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall backend.
(IsPersistBackend backend, BaseBackend backend ~ SqlBackend) =>
MySQLConnectInfo -> LogFunc -> IO (MySQLConn, backend)
openMySQLConn MySQLConnectInfo
ci LogFunc
logFunc

-- | Set autocommit setting
autocommit' :: MySQL.MySQLConn -> Bool -> IO ()
autocommit' :: MySQLConn -> Bool -> IO ()
autocommit' MySQLConn
conn Bool
bool = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall p. QueryParam p => MySQLConn -> Query -> [p] -> IO OK
MySQL.execute MySQLConn
conn Query
"SET autocommit=?" [Bool -> MySQLValue
encodeBool Bool
bool]

-- | Start a transaction.
begin' :: MySQL.MySQLConn -> Maybe IsolationLevel -> IO ()
begin' :: MySQLConn -> Maybe IsolationLevel -> IO ()
begin' MySQLConn
conn Maybe IsolationLevel
mIso
  = forall (f :: * -> *) a. Functor f => f a -> f ()
void
  forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (MySQLConn -> Query -> IO OK
MySQL.execute_ MySQLConn
conn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. (Monoid s, IsString s) => IsolationLevel -> s
makeIsolationLevelStatement) Maybe IsolationLevel
mIso
  forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MySQLConn -> Query -> IO OK
MySQL.execute_ MySQLConn
conn Query
"BEGIN"

-- | Commit the current transaction.
commit' :: MySQL.MySQLConn -> IO ()
commit' :: MySQLConn -> IO ()
commit' MySQLConn
conn = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ MySQLConn -> Query -> IO OK
MySQL.execute_ MySQLConn
conn Query
"COMMIT"

-- | Rollback the current transaction.
rollback' :: MySQL.MySQLConn -> IO ()
rollback' :: MySQLConn -> IO ()
rollback' MySQLConn
conn = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ MySQLConn -> Query -> IO OK
MySQL.execute_ MySQLConn
conn Query
"ROLLBACK"

-- | Prepare a query.  We don't support prepared statements, but
-- we'll do some client-side preprocessing here.
prepare' :: MySQL.MySQLConn -> Text -> IO Statement
prepare' :: MySQLConn -> Text -> IO Statement
prepare' MySQLConn
conn Text
sql = do
    let query :: Query
query = ByteString -> Query
MySQL.Query forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BS.fromStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 forall a b. (a -> b) -> a -> b
$ Text
sql
    forall (m :: * -> *) a. Monad m => a -> m a
return Statement
        { stmtFinalize :: IO ()
stmtFinalize = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        , stmtReset :: IO ()
stmtReset    = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        , stmtExecute :: [PersistValue] -> IO Int64
stmtExecute  = MySQLConn -> Query -> [PersistValue] -> IO Int64
execute' MySQLConn
conn Query
query
        , stmtQuery :: forall (m :: * -> *).
MonadIO m =>
[PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery    = forall (m :: * -> *).
MonadIO m =>
MySQLConn
-> Query
-> [PersistValue]
-> Acquire (ConduitM () [PersistValue] m ())
withStmt' MySQLConn
conn Query
query
        }


-- | SQL code to be executed when inserting an entity.
insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult
insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult
insertSql' EntityDef
ent [PersistValue]
vals =
    case EntityDef -> EntityIdDef
getEntityId EntityDef
ent of
        EntityIdNaturalKey CompositeDef
_ ->
            Text -> [PersistValue] -> InsertSqlResult
ISRManyKeys Text
sql [PersistValue]
vals
        EntityIdField FieldDef
_ ->
            Text -> Text -> InsertSqlResult
ISRInsertGet Text
sql Text
"SELECT LAST_INSERT_ID()"
  where
    ([Text]
fieldNames, [Text]
placeholders) = forall a b. [(a, b)] -> ([a], [b])
unzip (EntityDef -> (FieldNameDB -> Text) -> [(Text, Text)]
Util.mkInsertPlaceholders EntityDef
ent FieldNameDB -> Text
escapeFT)
    sql :: Text
sql = [Text] -> Text
T.concat
        [ Text
"INSERT INTO "
        , EntityNameDB -> Text
escapeET forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameDB
getEntityDBName EntityDef
ent
        , Text
"("
        , Text -> [Text] -> Text
T.intercalate Text
"," [Text]
fieldNames
        , Text
") VALUES("
        , Text -> [Text] -> Text
T.intercalate Text
"," [Text]
placeholders
        , Text
")"
        ]

-- | Execute an statement that doesn't return any results.
execute' :: MySQL.MySQLConn -> MySQL.Query -> [PersistValue] -> IO Int64
execute' :: MySQLConn -> Query -> [PersistValue] -> IO Int64
execute' MySQLConn
conn Query
query [PersistValue]
vals
  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. OK -> Int
MySQL.okAffectedRows) forall a b. (a -> b) -> a -> b
$ forall p. QueryParam p => MySQLConn -> Query -> [p] -> IO OK
MySQL.execute MySQLConn
conn Query
query (forall a b. (a -> b) -> [a] -> [b]
map PersistValue -> P
P [PersistValue]
vals)

-- | query' allows arguments to be empty.
query'
  :: MySQL.QueryParam p => MySQL.MySQLConn -> MySQL.Query -> [p]
  -> IO ([MySQL.ColumnDef], Streams.InputStream [MySQL.MySQLValue])
query' :: forall p.
QueryParam p =>
MySQLConn
-> Query -> [p] -> IO ([ColumnDef], InputStream [MySQLValue])
query' MySQLConn
conn Query
qry [] = MySQLConn -> Query -> IO ([ColumnDef], InputStream [MySQLValue])
MySQL.query_ MySQLConn
conn Query
qry
query' MySQLConn
conn Query
qry [p]
ps = forall p.
QueryParam p =>
MySQLConn
-> Query -> [p] -> IO ([ColumnDef], InputStream [MySQLValue])
MySQL.query  MySQLConn
conn Query
qry [p]
ps

-- | Execute an statement that does return results.
-- unlike @persistent-mysql@, we actually _stream_ results.
withStmt' :: MonadIO m
          => MySQL.MySQLConn
          -> MySQL.Query
          -> [PersistValue]
          -> Acquire (ConduitM () [PersistValue] m ())
withStmt' :: forall (m :: * -> *).
MonadIO m =>
MySQLConn
-> Query
-> [PersistValue]
-> Acquire (ConduitM () [PersistValue] m ())
withStmt' MySQLConn
conn Query
query [PersistValue]
vals
  = forall {m :: * -> *} {i}.
MonadIO m =>
([ColumnDef], InputStream [MySQLValue])
-> ConduitT i [PersistValue] m ()
fetchRows forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IO a -> (a -> IO ()) -> Acquire a
mkAcquire IO ([ColumnDef], InputStream [MySQLValue])
createResult forall {a} {a}. (a, InputStream a) -> IO ()
releaseResult
  where
    createResult :: IO ([ColumnDef], InputStream [MySQLValue])
createResult = forall p.
QueryParam p =>
MySQLConn
-> Query -> [p] -> IO ([ColumnDef], InputStream [MySQLValue])
query' MySQLConn
conn Query
query (forall a b. (a -> b) -> [a] -> [b]
map PersistValue -> P
P [PersistValue]
vals)
    releaseResult :: (a, InputStream a) -> IO ()
releaseResult (a
_, InputStream a
is) = forall a. InputStream a -> IO ()
Streams.skipToEof InputStream a
is
    fetchRows :: ([ColumnDef], InputStream [MySQLValue])
-> ConduitT i [PersistValue] m ()
fetchRows ([ColumnDef]
fields, InputStream [MySQLValue]
is) = forall (m :: * -> *) b a i.
Monad m =>
(b -> m (Maybe (a, b))) -> b -> ConduitT i a m ()
CL.unfoldM InputStream [MySQLValue]
-> m (Maybe ([PersistValue], InputStream [MySQLValue]))
getVal InputStream [MySQLValue]
is
      where
      -- Find out the type of the columns
          getters :: [Getter PersistValue]
getters = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ColumnDef -> Getter PersistValue
getGetter [ColumnDef]
fields
          convert :: [MySQLValue] -> [PersistValue]
convert = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Getter PersistValue
g -> \MySQLValue
c -> Getter PersistValue
g MySQLValue
c) [Getter PersistValue]
getters
          getVal :: InputStream [MySQLValue]
-> m (Maybe ([PersistValue], InputStream [MySQLValue]))
getVal InputStream [MySQLValue]
s = do
            Maybe [MySQLValue]
v <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream [MySQLValue]
s
            case Maybe [MySQLValue]
v of
              (Just [MySQLValue]
r)  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ([MySQLValue] -> [PersistValue]
convert [MySQLValue]
r, InputStream [MySQLValue]
s)
              Maybe [MySQLValue]
_         -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

-- | Encode a Haskell bool into a MySQLValue
encodeBool :: Bool -> MySQL.MySQLValue
encodeBool :: Bool -> MySQLValue
encodeBool Bool
True = Word8 -> MySQLValue
MySQL.MySQLInt8U Word8
1
encodeBool Bool
False = Word8 -> MySQLValue
MySQL.MySQLInt8U Word8
0

-- | Decode a whole number into a PersistInt64
decodeInteger :: Integral a => a -> PersistValue
decodeInteger :: forall a. Integral a => a -> PersistValue
decodeInteger = Int64 -> PersistValue
PersistInt64 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Decode a decimal number into a PersistDouble
decodeDouble :: Real a => a -> PersistValue
decodeDouble :: forall a. Real a => a -> PersistValue
decodeDouble = Double -> PersistValue
PersistDouble forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac

-- | @newtype@ around 'PersistValue' that supports the
-- 'MySQL.Param' type class.
newtype P = P PersistValue

instance MySQL.QueryParam P where
  render :: P -> Put
render (P (PersistText Text
t))        = MySQLValue -> Put
MySQL.putTextField forall a b. (a -> b) -> a -> b
$ Text -> MySQLValue
MySQL.MySQLText Text
t
  render (P (PersistByteString ByteString
b))  = MySQLValue -> Put
MySQL.putTextField forall a b. (a -> b) -> a -> b
$ ByteString -> MySQLValue
MySQL.MySQLBytes ByteString
b
  render (P (PersistInt64 Int64
i))       = MySQLValue -> Put
MySQL.putTextField forall a b. (a -> b) -> a -> b
$ Int64 -> MySQLValue
MySQL.MySQLInt64 Int64
i
  render (P (PersistDouble Double
d))      = MySQLValue -> Put
MySQL.putTextField forall a b. (a -> b) -> a -> b
$ Double -> MySQLValue
MySQL.MySQLDouble Double
d
  render (P (PersistBool Bool
b))        = MySQLValue -> Put
MySQL.putTextField forall a b. (a -> b) -> a -> b
$ Bool -> MySQLValue
encodeBool Bool
b
  render (P (PersistDay Day
d))         = MySQLValue -> Put
MySQL.putTextField forall a b. (a -> b) -> a -> b
$ Day -> MySQLValue
MySQL.MySQLDate Day
d
  render (P (PersistTimeOfDay TimeOfDay
t))   = MySQLValue -> Put
MySQL.putTextField forall a b. (a -> b) -> a -> b
$ Word8 -> TimeOfDay -> MySQLValue
MySQL.MySQLTime Word8
0 TimeOfDay
t
  render (P (PersistUTCTime UTCTime
t))     = MySQLValue -> Put
MySQL.putTextField forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalTime -> MySQLValue
MySQL.MySQLTimeStamp forall a b. (a -> b) -> a -> b
$ TimeZone -> UTCTime -> LocalTime
Time.utcToLocalTime TimeZone
Time.utc UTCTime
t
  render (P (PersistValue
PersistNull))          = MySQLValue -> Put
MySQL.putTextField forall a b. (a -> b) -> a -> b
$ MySQLValue
MySQL.MySQLNull
  render (P (PersistList [PersistValue]
l))        = MySQLValue -> Put
MySQL.putTextField forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MySQLValue
MySQL.MySQLText forall a b. (a -> b) -> a -> b
$ [PersistValue] -> Text
listToJSON [PersistValue]
l
  render (P (PersistMap [(Text, PersistValue)]
m))         = MySQLValue -> Put
MySQL.putTextField forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MySQLValue
MySQL.MySQLText forall a b. (a -> b) -> a -> b
$ [(Text, PersistValue)] -> Text
mapToJSON [(Text, PersistValue)]
m
  render (P (PersistRational Rational
r))    =
    MySQLValue -> Put
MySQL.putTextField forall a b. (a -> b) -> a -> b
$ Scientific -> MySQLValue
MySQL.MySQLDecimal forall a b. (a -> b) -> a -> b
$ forall a. Read a => [Char] -> a
read forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show (forall a. Fractional a => Rational -> a
fromRational Rational
r :: Pico)
    -- FIXME: Too Ambigous, can not select precision without information about field
  render (P (PersistLiteral_ LiteralType
DbSpecific ByteString
s)) = MySQLValue -> Put
MySQL.putTextField forall a b. (a -> b) -> a -> b
$ ByteString -> MySQLValue
MySQL.MySQLBytes ByteString
s
  render (P (PersistLiteral_ LiteralType
Unescaped ByteString
l)) = MySQLValue -> Put
MySQL.putTextField forall a b. (a -> b) -> a -> b
$ ByteString -> MySQLValue
MySQL.MySQLBytes ByteString
l
  render (P (PersistLiteral_ LiteralType
Escaped ByteString
e)) = MySQLValue -> Put
MySQL.putTextField forall a b. (a -> b) -> a -> b
$ ByteString -> MySQLValue
MySQL.MySQLBytes forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
MySQL.escapeBytes ByteString
e
  render (P (PersistArray [PersistValue]
a))       = forall a. QueryParam a => a -> Put
MySQL.render (PersistValue -> P
P ([PersistValue] -> PersistValue
PersistList [PersistValue]
a))
  render (P (PersistObjectId ByteString
_))    =
    forall a. HasCallStack => [Char] -> a
error [Char]
"Refusing to serialize a PersistObjectId to a MySQL value"

-- | @Getter a@ is a function that converts an incoming "MySQLValue"
-- into a data type @a@.
type Getter a = MySQL.MySQLValue -> a

-- | Get the corresponding @'Getter' 'PersistValue'@ depending on
-- the type of the column.
getGetter :: MySQL.ColumnDef -> Getter PersistValue
getGetter :: ColumnDef -> Getter PersistValue
getGetter ColumnDef
_field = Getter PersistValue
go
  where
    -- Int64
    go :: Getter PersistValue
go (MySQL.MySQLInt8U  Word8
v) = forall a. Integral a => a -> PersistValue
decodeInteger Word8
v
    go (MySQL.MySQLInt8   Int8
v) = forall a. Integral a => a -> PersistValue
decodeInteger Int8
v
    go (MySQL.MySQLInt16U Word16
v) = forall a. Integral a => a -> PersistValue
decodeInteger Word16
v
    go (MySQL.MySQLInt16  Int16
v) = forall a. Integral a => a -> PersistValue
decodeInteger Int16
v
    go (MySQL.MySQLInt32U Word32
v) = forall a. Integral a => a -> PersistValue
decodeInteger Word32
v
    go (MySQL.MySQLInt32  Int32
v) = forall a. Integral a => a -> PersistValue
decodeInteger Int32
v
    go (MySQL.MySQLInt64U Word64
v) = forall a. Integral a => a -> PersistValue
decodeInteger Word64
v
    go (MySQL.MySQLInt64  Int64
v) = forall a. Integral a => a -> PersistValue
decodeInteger Int64
v
    go (MySQL.MySQLBit    Word64
v) = forall a. Integral a => a -> PersistValue
decodeInteger Word64
v
    -- Double
    -- TODO: FIX WARNING(S) AND TRY TO PROVIDE LEAST PRECISION LOSS
    go (MySQL.MySQLFloat    Float
v) = forall a. Real a => a -> PersistValue
decodeDouble Float
v
    go (MySQL.MySQLDouble   Double
v) = forall a. Real a => a -> PersistValue
decodeDouble Double
v
    go (MySQL.MySQLDecimal  Scientific
v) = forall a. Real a => a -> PersistValue
decodeDouble Scientific
v
    -- ByteString and Text
    go (MySQL.MySQLBytes  ByteString
v) = ByteString -> PersistValue
PersistByteString ByteString
v
    go (MySQL.MySQLText   Text
v) = Text -> PersistValue
PersistText Text
v
    -- Time-related
    -- TODO: REMOVE ASSUMPTION THAT DATETIME and TIMESTAMP are in UTC
    go (MySQL.MySQLDateTime   LocalTime
v) = UTCTime -> PersistValue
PersistUTCTime forall a b. (a -> b) -> a -> b
$ TimeZone -> LocalTime -> UTCTime
Time.localTimeToUTC TimeZone
Time.utc LocalTime
v
    go (MySQL.MySQLTimeStamp  LocalTime
v) = UTCTime -> PersistValue
PersistUTCTime forall a b. (a -> b) -> a -> b
$ TimeZone -> LocalTime -> UTCTime
Time.localTimeToUTC TimeZone
Time.utc LocalTime
v
    go (MySQL.MySQLYear       Word16
v) = Day -> PersistValue
PersistDay (Integer -> Int -> Int -> Day
Time.fromGregorian (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
v) Int
1 Int
1)
    go (MySQL.MySQLDate       Day
v) = Day -> PersistValue
PersistDay Day
v
    go (MySQL.MySQLTime Word8
_     TimeOfDay
v) = TimeOfDay -> PersistValue
PersistTimeOfDay TimeOfDay
v
    -- Null
    go (MySQLValue
MySQL.MySQLNull        ) = PersistValue
PersistNull
    -- Conversion using PersistDbSpecific
    go (MySQL.MySQLGeometry   ByteString
v) = ByteString -> PersistValue
PersistLiteral ByteString
v

----------------------------------------------------------------------


-- | Create the migration plan for the given 'PersistEntity'
-- @val@.
migrate' :: MySQL.ConnectInfo
         -> [EntityDef]
         -> (Text -> IO Statement)
         -> EntityDef
         -> IO (Either [Text] [(Bool, Text)])
migrate' :: ConnectInfo
-> [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)])
migrate' ConnectInfo
connectInfo [EntityDef]
allDefs Text -> IO Statement
getter EntityDef
val = do
    let name :: EntityNameDB
name = EntityDef -> EntityNameDB
getEntityDBName EntityDef
val
    let ([Column]
newcols, [UniqueDef]
udefs, [ForeignDef]
fdefs) = [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])
mysqlMkColumns [EntityDef]
allDefs EntityDef
val
    [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
old <- HasCallStack =>
ConnectInfo
-> (Text -> IO Statement)
-> EntityDef
-> [Column]
-> IO
     [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
getColumns ConnectInfo
connectInfo Text -> IO Statement
getter EntityDef
val [Column]
newcols
    let udspair :: [(ConstraintNameDB, [FieldNameDB])]
udspair = forall a b. (a -> b) -> [a] -> [b]
map UniqueDef -> (ConstraintNameDB, [FieldNameDB])
udToPair [UniqueDef]
udefs
    case ([], [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
old, forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
old) of
        -- Nothing found, create everything
        ([], [], ([Text], [Either Column (ConstraintNameDB, [FieldNameDB])])
_) -> do
            let uniques :: [AlterDB]
uniques = do
                    (ConstraintNameDB
uname, [FieldNameDB]
ucols) <- [(ConstraintNameDB, [FieldNameDB])]
udspair
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        forall a b. (a -> b) -> a -> b
$ EntityNameDB -> AlterTable -> AlterDB
AlterTable EntityNameDB
name
                        forall a b. (a -> b) -> a -> b
$ ConstraintNameDB
-> [(FieldNameDB, FieldType, Integer)] -> AlterTable
AddUniqueConstraint ConstraintNameDB
uname
                        forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (EntityNameDB -> FieldNameDB -> (FieldNameDB, FieldType, Integer)
findTypeAndMaxLen EntityNameDB
name) [FieldNameDB]
ucols

            let foreigns :: [AlterDB]
foreigns = do
                    Column { cName :: Column -> FieldNameDB
cName=FieldNameDB
cname, cReference :: Column -> Maybe ColumnReference
cReference=Just ColumnReference
cRef } <- [Column]
newcols
                    let refConstraintName :: ConstraintNameDB
refConstraintName = ColumnReference -> ConstraintNameDB
crConstraintName ColumnReference
cRef
                    let refTblName :: EntityNameDB
refTblName = ColumnReference -> EntityNameDB
crTableName ColumnReference
cRef
                    let refTarget :: AlterColumn
refTarget =
                          [EntityDef]
-> ConstraintNameDB
-> EntityNameDB
-> FieldNameDB
-> FieldCascade
-> AlterColumn
addReference [EntityDef]
allDefs ConstraintNameDB
refConstraintName EntityNameDB
refTblName FieldNameDB
cname (ColumnReference -> FieldCascade
crFieldCascade ColumnReference
cRef)

                    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just FieldNameDB
cname forall a. Eq a => a -> a -> Bool
/= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldDef -> FieldNameDB
fieldDB (EntityDef -> Maybe FieldDef
getEntityIdField EntityDef
val)
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ EntityNameDB -> AlterColumn -> AlterDB
AlterColumn EntityNameDB
name AlterColumn
refTarget


            let foreignsAlt :: [AlterDB]
foreignsAlt =
                    forall a b. (a -> b) -> [a] -> [b]
map
                        (\ForeignDef
fdef ->
                            let ([FieldNameDB]
childfields, [FieldNameDB]
parentfields) =
                                    forall a b. [(a, b)] -> ([a], [b])
unzip
                                    forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\((FieldNameHS
_,FieldNameDB
b),(FieldNameHS
_,FieldNameDB
d)) -> (FieldNameDB
b,FieldNameDB
d))
                                    forall a b. (a -> b) -> a -> b
$ ForeignDef
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
foreignFields ForeignDef
fdef
                            in
                                EntityNameDB -> AlterColumn -> AlterDB
AlterColumn
                                    EntityNameDB
name
                                    (EntityNameDB
-> ConstraintNameDB
-> [FieldNameDB]
-> [FieldNameDB]
-> FieldCascade
-> AlterColumn
AddReference
                                        (ForeignDef -> EntityNameDB
foreignRefTableDBName ForeignDef
fdef)
                                        (ForeignDef -> ConstraintNameDB
foreignConstraintNameDBName ForeignDef
fdef)
                                        [FieldNameDB]
childfields
                                        [FieldNameDB]
parentfields
                                        (ForeignDef -> FieldCascade
foreignFieldCascade ForeignDef
fdef)
                                    )
                        )
                        [ForeignDef]
fdefs

            forall (m :: * -> *) a. Monad m => a -> m a
return
                forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right
                forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map AlterDB -> (Bool, Text)
showAlterDb
                forall a b. (a -> b) -> a -> b
$ ([Column] -> EntityDef -> AlterDB
addTable [Column]
newcols EntityDef
val) forall a. a -> [a] -> [a]
: [AlterDB]
uniques forall a. [a] -> [a] -> [a]
++ [AlterDB]
foreigns forall a. [a] -> [a] -> [a]
++ [AlterDB]
foreignsAlt

        -- No errors and something found, migrate
        ([Any]
_, [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
_, ([], [Either Column (ConstraintNameDB, [FieldNameDB])]
old')) -> do
            let excludeForeignKeys :: ([Column], [(ConstraintNameDB, [FieldNameDB])])
-> ([Column], [(ConstraintNameDB, [FieldNameDB])])
excludeForeignKeys ([Column]
xs,[(ConstraintNameDB, [FieldNameDB])]
ys) =
                    ( forall a b. (a -> b) -> [a] -> [b]
map
                        (\Column
c ->
                            case Column -> Maybe ColumnReference
cReference Column
c of
                                Just ColumnReference {crConstraintName :: ColumnReference -> ConstraintNameDB
crConstraintName=ConstraintNameDB
fk} ->
                                    case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\ForeignDef
f -> ConstraintNameDB
fk forall a. Eq a => a -> a -> Bool
== ForeignDef -> ConstraintNameDB
foreignConstraintNameDBName ForeignDef
f) [ForeignDef]
fdefs of
                                        Just ForeignDef
_ -> Column
c { cReference :: Maybe ColumnReference
cReference = forall a. Maybe a
Nothing }
                                        Maybe ForeignDef
Nothing -> Column
c
                                Maybe ColumnReference
Nothing -> Column
c
                        )
                        [Column]
xs
                    , [(ConstraintNameDB, [FieldNameDB])]
ys
                    )
                ([AlterColumn]
acs, [AlterTable]
ats) =
                    [EntityDef]
-> EntityDef
-> ([Column], [(ConstraintNameDB, [FieldNameDB])])
-> ([Column], [(ConstraintNameDB, [FieldNameDB])])
-> ([AlterColumn], [AlterTable])
getAlters
                        [EntityDef]
allDefs
                        EntityDef
val
                        ([Column]
newcols, [(ConstraintNameDB, [FieldNameDB])]
udspair)
                        forall a b. (a -> b) -> a -> b
$ ([Column], [(ConstraintNameDB, [FieldNameDB])])
-> ([Column], [(ConstraintNameDB, [FieldNameDB])])
excludeForeignKeys
                        forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> ([a], [b])
partitionEithers
                        forall a b. (a -> b) -> a -> b
$ [Either Column (ConstraintNameDB, [FieldNameDB])]
old'
                acs' :: [AlterDB]
acs' =
                    forall a b. (a -> b) -> [a] -> [b]
map (EntityNameDB -> AlterColumn -> AlterDB
AlterColumn EntityNameDB
name) [AlterColumn]
acs
                ats' :: [AlterDB]
ats' =
                    forall a b. (a -> b) -> [a] -> [b]
map (EntityNameDB -> AlterTable -> AlterDB
AlterTable  EntityNameDB
name) [AlterTable]
ats
            forall (m :: * -> *) a. Monad m => a -> m a
return
                forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right
                forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map AlterDB -> (Bool, Text)
showAlterDb
                forall a b. (a -> b) -> a -> b
$ [AlterDB]
acs' forall a. [a] -> [a] -> [a]
++ [AlterDB]
ats'

        -- Errors
        ([Any]
_, [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
_, ([Text]
errs, [Either Column (ConstraintNameDB, [FieldNameDB])]
_)) ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [Text]
errs

      where
        findTypeAndMaxLen :: EntityNameDB -> FieldNameDB -> (FieldNameDB, FieldType, Integer)
findTypeAndMaxLen EntityNameDB
tblName FieldNameDB
col =
            let (FieldNameDB
col', FieldType
ty) = [EntityDef]
-> EntityNameDB -> FieldNameDB -> (FieldNameDB, FieldType)
findTypeOfColumn [EntityDef]
allDefs EntityNameDB
tblName FieldNameDB
col
                (FieldNameDB
_, Integer
ml) = [EntityDef]
-> EntityNameDB -> FieldNameDB -> (FieldNameDB, Integer)
findMaxLenOfColumn [EntityDef]
allDefs EntityNameDB
tblName FieldNameDB
col
            in
                (FieldNameDB
col', FieldType
ty, Integer
ml)

addTable :: [Column] -> EntityDef -> AlterDB
addTable :: [Column] -> EntityDef -> AlterDB
addTable [Column]
cols EntityDef
entity = [Char] -> AlterDB
AddTable forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    -- Lower case e: see Database.Persist.Sql.Migration
    [ [Char]
"CREATe TABLE "
    , EntityNameDB -> [Char]
escapeE EntityNameDB
name
    , [Char]
"("
    , [Char]
idtxt
    , if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Column]
nonIdCols then [] else [Char]
","
    , forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Column -> [Char]
showColumn [Column]
nonIdCols
    , [Char]
")"
    ]
  where
    nonIdCols :: [Column]
nonIdCols =
        forall a. (a -> Bool) -> [a] -> [a]
filter (\Column
c -> forall a. a -> Maybe a
Just (Column -> FieldNameDB
cName Column
c) forall a. Eq a => a -> a -> Bool
/= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldDef -> FieldNameDB
fieldDB (EntityDef -> Maybe FieldDef
getEntityIdField EntityDef
entity) ) [Column]
cols
    name :: EntityNameDB
name =
        EntityDef -> EntityNameDB
getEntityDBName EntityDef
entity
    idtxt :: [Char]
idtxt =
        case EntityDef -> EntityIdDef
getEntityId EntityDef
entity of
            EntityIdNaturalKey CompositeDef
pdef ->
                forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                    [ [Char]
" PRIMARY KEY ("
                    , forall a. [a] -> [[a]] -> [a]
intercalate [Char]
","
                  forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> [Char]
escapeF forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB) forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$ CompositeDef -> NonEmpty FieldDef
compositeFields CompositeDef
pdef
                    , [Char]
")"
                    ]
            EntityIdField FieldDef
idField ->
                let
                    defText :: Maybe Text
defText =
                        [FieldAttr] -> Maybe Text
defaultAttribute forall a b. (a -> b) -> a -> b
$ FieldDef -> [FieldAttr]
fieldAttrs FieldDef
idField
                    sType :: SqlType
sType =
                        FieldDef -> SqlType
fieldSqlType FieldDef
idField
                    autoIncrementText :: [Char]
autoIncrementText =
                        case (SqlType
sType, Maybe Text
defText) of
                            (SqlType
SqlInt64, Maybe Text
Nothing) -> [Char]
" AUTO_INCREMENT"
                            (SqlType, Maybe Text)
_ -> [Char]
""
                    maxlen :: Maybe Integer
maxlen =
                        FieldDef -> Maybe Integer
findMaxLenOfField FieldDef
idField
                in
                    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                        [ FieldNameDB -> [Char]
escapeF forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldNameDB
fieldDB FieldDef
idField
                        , [Char]
" " forall a. Semigroup a => a -> a -> a
<> SqlType -> Maybe Integer -> Bool -> [Char]
showSqlType SqlType
sType Maybe Integer
maxlen Bool
False
                        , [Char]
" NOT NULL"
                        , [Char]
autoIncrementText
                        , [Char]
" PRIMARY KEY"
                        , case Maybe Text
defText of
                            Maybe Text
Nothing ->
                                [Char]
""
                            Just Text
def ->
                                forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                                    [ [Char]
" DEFAULT ("
                                    , Text -> [Char]
T.unpack Text
def
                                    , [Char]
")"
                                    ]
                        ]

-- | Find out the type of a column.
findTypeOfColumn :: [EntityDef] -> EntityNameDB -> FieldNameDB -> (FieldNameDB, FieldType)
findTypeOfColumn :: [EntityDef]
-> EntityNameDB -> FieldNameDB -> (FieldNameDB, FieldType)
findTypeOfColumn [EntityDef]
allDefs EntityNameDB
name FieldNameDB
col =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Could not find type of column " forall a. [a] -> [a] -> [a]
++
                   forall a. Show a => a -> [Char]
show FieldNameDB
col forall a. [a] -> [a] -> [a]
++ [Char]
" on table " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show EntityNameDB
name forall a. [a] -> [a] -> [a]
++
                   [Char]
" (allDefs = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [EntityDef]
allDefs forall a. [a] -> [a] -> [a]
++ [Char]
")"
        )
        ((,) FieldNameDB
col)
        forall a b. (a -> b) -> a -> b
$ do
            EntityDef
entDef   <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== EntityNameDB
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameDB
getEntityDBName) [EntityDef]
allDefs
            FieldDef
fieldDef <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== FieldNameDB
col)  forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB) (EntityDef -> [FieldDef]
getEntityFieldsDatabase EntityDef
entDef)
            forall (m :: * -> *) a. Monad m => a -> m a
return (FieldDef -> FieldType
fieldType FieldDef
fieldDef)

-- | Find out the maxlen of a column (default to 200)
findMaxLenOfColumn :: [EntityDef] -> EntityNameDB -> FieldNameDB -> (FieldNameDB, Integer)
findMaxLenOfColumn :: [EntityDef]
-> EntityNameDB -> FieldNameDB -> (FieldNameDB, Integer)
findMaxLenOfColumn [EntityDef]
allDefs EntityNameDB
name FieldNameDB
col =
   forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FieldNameDB
col, Integer
200)
         ((,) FieldNameDB
col) forall a b. (a -> b) -> a -> b
$ do
           EntityDef
entDef     <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== EntityNameDB
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameDB
getEntityDBName) [EntityDef]
allDefs
           FieldDef
fieldDef   <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== FieldNameDB
col) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB) (EntityDef -> [FieldDef]
getEntityFieldsDatabase EntityDef
entDef)
           FieldDef -> Maybe Integer
findMaxLenOfField FieldDef
fieldDef

-- | Find out the maxlen of a field
findMaxLenOfField :: FieldDef -> Maybe Integer
findMaxLenOfField :: FieldDef -> Maybe Integer
findMaxLenOfField FieldDef
fieldDef =
    forall a. [a] -> Maybe a
listToMaybe
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case
            FieldAttrMaxlen Integer
x -> forall a. a -> Maybe a
Just Integer
x
            FieldAttr
_ -> forall a. Maybe a
Nothing)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> [FieldAttr]
fieldAttrs
        forall a b. (a -> b) -> a -> b
$ FieldDef
fieldDef

-- | Helper for 'AddReference' that finds out the which primary key columns to reference.
addReference
    :: [EntityDef]
    -- ^ List of all known 'EntityDef's.
    -> ConstraintNameDB
    -- ^ Foreign key name
    -> EntityNameDB
    -- ^ Referenced table name
    -> FieldNameDB
    -- ^ Column name
    -> FieldCascade
    -> AlterColumn
addReference :: [EntityDef]
-> ConstraintNameDB
-> EntityNameDB
-> FieldNameDB
-> FieldCascade
-> AlterColumn
addReference [EntityDef]
allDefs ConstraintNameDB
fkeyname EntityNameDB
reftable FieldNameDB
cname FieldCascade
fc =
    EntityNameDB
-> ConstraintNameDB
-> [FieldNameDB]
-> [FieldNameDB]
-> FieldCascade
-> AlterColumn
AddReference EntityNameDB
reftable ConstraintNameDB
fkeyname [FieldNameDB
cname] [FieldNameDB]
referencedColumns FieldCascade
fc
  where
    errorMessage :: [FieldNameDB]
errorMessage =
        forall a. HasCallStack => [Char] -> a
error
            forall a b. (a -> b) -> a -> b
$ [Char]
"Could not find ID of entity " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show EntityNameDB
reftable
            forall a. [a] -> [a] -> [a]
++ [Char]
" (allDefs = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [EntityDef]
allDefs forall a. [a] -> [a] -> [a]
++ [Char]
")"
    referencedColumns :: [FieldNameDB]
referencedColumns =
        forall a. a -> Maybe a -> a
fromMaybe [FieldNameDB]
errorMessage forall a b. (a -> b) -> a -> b
$ do
            EntityDef
entDef <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== EntityNameDB
reftable) forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameDB
getEntityDBName) [EntityDef]
allDefs
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> FieldNameDB
fieldDB forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$ EntityDef -> NonEmpty FieldDef
getEntityKeyFields EntityDef
entDef

data AlterColumn = Change Column
                 | Add' Column
                 | Drop Column
                 | Default Column String
                 | NoDefault Column
                 | Gen Column SqlType (Maybe Integer) String
                 | NoGen Column SqlType (Maybe Integer)
                 | Update' Column String
                 -- | See the definition of the 'showAlter' function to see how these fields are used.
                 | AddReference
                    EntityNameDB -- Referenced table
                    ConstraintNameDB -- Foreign key name
                    [FieldNameDB] -- Referencing columns
                    [FieldNameDB] -- Referenced columns
                    FieldCascade
                 | DropReference ConstraintNameDB
                 deriving Int -> AlterColumn -> [Char] -> [Char]
[AlterColumn] -> [Char] -> [Char]
AlterColumn -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [AlterColumn] -> [Char] -> [Char]
$cshowList :: [AlterColumn] -> [Char] -> [Char]
show :: AlterColumn -> [Char]
$cshow :: AlterColumn -> [Char]
showsPrec :: Int -> AlterColumn -> [Char] -> [Char]
$cshowsPrec :: Int -> AlterColumn -> [Char] -> [Char]
Show

data AlterTable = AddUniqueConstraint ConstraintNameDB [(FieldNameDB, FieldType, Integer)]
                | DropUniqueConstraint ConstraintNameDB
                deriving Int -> AlterTable -> [Char] -> [Char]
[AlterTable] -> [Char] -> [Char]
AlterTable -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [AlterTable] -> [Char] -> [Char]
$cshowList :: [AlterTable] -> [Char] -> [Char]
show :: AlterTable -> [Char]
$cshow :: AlterTable -> [Char]
showsPrec :: Int -> AlterTable -> [Char] -> [Char]
$cshowsPrec :: Int -> AlterTable -> [Char] -> [Char]
Show

data AlterDB = AddTable String
             | AlterColumn EntityNameDB AlterColumn
             | AlterTable EntityNameDB AlterTable
             deriving Int -> AlterDB -> [Char] -> [Char]
[AlterDB] -> [Char] -> [Char]
AlterDB -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [AlterDB] -> [Char] -> [Char]
$cshowList :: [AlterDB] -> [Char] -> [Char]
show :: AlterDB -> [Char]
$cshow :: AlterDB -> [Char]
showsPrec :: Int -> AlterDB -> [Char] -> [Char]
$cshowsPrec :: Int -> AlterDB -> [Char] -> [Char]
Show


udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB])
udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB])
udToPair UniqueDef
ud = (UniqueDef -> ConstraintNameDB
uniqueDBName UniqueDef
ud, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$ UniqueDef -> NonEmpty (FieldNameHS, FieldNameDB)
uniqueFields UniqueDef
ud)

----------------------------------------------------------------------


-- | Returns all of the 'Column'@s@ in the given table currently
-- in the database.
getColumns
    :: HasCallStack
    => MySQL.ConnectInfo
    -> (Text -> IO Statement)
    -> EntityDef -> [Column]
    -> IO [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
getColumns :: HasCallStack =>
ConnectInfo
-> (Text -> IO Statement)
-> EntityDef
-> [Column]
-> IO
     [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
getColumns ConnectInfo
connectInfo Text -> IO Statement
getter EntityDef
def [Column]
cols = do

    -- Find out all columns.
    Statement
stmtClmns <- Text -> IO Statement
getter forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
      [ Text
"SELECT COLUMN_NAME, "
      ,   Text
"IS_NULLABLE, "
      ,   Text
"DATA_TYPE, "
      ,   Text
"COLUMN_TYPE, "
      ,   Text
"CHARACTER_MAXIMUM_LENGTH, "
      ,   Text
"NUMERIC_PRECISION, "
      ,   Text
"NUMERIC_SCALE, "
      ,   Text
"COLUMN_DEFAULT, "
      ,   Text
"GENERATION_EXPRESSION "
      , Text
"FROM INFORMATION_SCHEMA.COLUMNS "
      , Text
"WHERE TABLE_SCHEMA = ? "
      ,   Text
"AND TABLE_NAME   = ? "
      -- ,   "AND COLUMN_NAME <> ?"
      ]
    [[PersistValue]]
inter2 <- forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with (Statement
-> forall (m :: * -> *).
   MonadIO m =>
   [PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery Statement
stmtClmns [PersistValue]
vals) (\ConduitM () [PersistValue] (ResourceT IO) ()
src -> forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes forall a b. (a -> b) -> a -> b
$ ConduitM () [PersistValue] (ResourceT IO) ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume)
    [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
cs <- forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList [[PersistValue]]
inter2 forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT
  [PersistValue]
  Void
  (ResourceT IO)
  [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
helperClmns -- avoid nested queries

    -- Find out the constraints.
    Statement
stmtCntrs <- Text -> IO Statement
getter forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
      [ Text
"SELECT CONSTRAINT_NAME, "
      ,   Text
"COLUMN_NAME "
      , Text
"FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE "
      , Text
"WHERE TABLE_SCHEMA = ? "
      ,   Text
"AND TABLE_NAME   = ? "
      -- ,   "AND COLUMN_NAME <> ? "
      ,   Text
"AND CONSTRAINT_NAME <> 'PRIMARY' "
      ,   Text
"AND REFERENCED_TABLE_SCHEMA IS NULL "
      , Text
"ORDER BY CONSTRAINT_NAME, "
      ,   Text
"COLUMN_NAME"
      ]
    [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
us <- forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with (Statement
-> forall (m :: * -> *).
   MonadIO m =>
   [PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery Statement
stmtCntrs [PersistValue]
vals) (\ConduitM () [PersistValue] (ResourceT IO) ()
src -> forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes forall a b. (a -> b) -> a -> b
$ ConduitM () [PersistValue] (ResourceT IO) ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall {o} {a} {a}.
ConduitT
  [PersistValue]
  o
  (ResourceT IO)
  [Either a (Either a (ConstraintNameDB, [FieldNameDB]))]
helperCntrs)

    -- Return both
    forall (m :: * -> *) a. Monad m => a -> m a
return ([Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
cs forall a. [a] -> [a] -> [a]
++ [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
us)
  where
    refMap :: Map Text ColumnReference
refMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [(Text, ColumnReference)] -> Column -> [(Text, ColumnReference)]
ref [] [Column]
cols
      where ref :: [(Text, ColumnReference)] -> Column -> [(Text, ColumnReference)]
ref [(Text, ColumnReference)]
rs Column
c = case Column -> Maybe ColumnReference
cReference Column
c of
                Maybe ColumnReference
Nothing -> [(Text, ColumnReference)]
rs
                (Just ColumnReference
r) -> (FieldNameDB -> Text
unFieldNameDB forall a b. (a -> b) -> a -> b
$ Column -> FieldNameDB
cName Column
c, ColumnReference
r) forall a. a -> [a] -> [a]
: [(Text, ColumnReference)]
rs
    vals :: [PersistValue]
vals = [ Text -> PersistValue
PersistText forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 forall a b. (a -> b) -> a -> b
$ ConnectInfo -> ByteString
MySQL.ciDatabase ConnectInfo
connectInfo
           , Text -> PersistValue
PersistText forall a b. (a -> b) -> a -> b
$ EntityNameDB -> Text
unEntityNameDB forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameDB
getEntityDBName EntityDef
def
        --   , PersistText $ unDBName $ fieldDB $ getEntityId def
           ]

    helperClmns :: ConduitT
  [PersistValue]
  Void
  (ResourceT IO)
  [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
helperClmns = forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
CL.mapM [PersistValue]
-> ResourceT
     IO (Either Text (Either Column (ConstraintNameDB, [FieldNameDB])))
getIt forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
        where
          getIt :: [PersistValue]
-> ResourceT
     IO (Either Text (Either Column (ConstraintNameDB, [FieldNameDB])))
getIt [PersistValue]
row = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a b. a -> Either a b
Left (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                      HasCallStack =>
ConnectInfo
-> (Text -> IO Statement)
-> EntityNameDB
-> [PersistValue]
-> Maybe ColumnReference
-> IO (Either Text Column)
getColumn ConnectInfo
connectInfo Text -> IO Statement
getter (EntityDef -> EntityNameDB
getEntityDBName EntityDef
def) [PersistValue]
row forall a b. (a -> b) -> a -> b
$ Maybe ColumnReference
ref
            where ref :: Maybe ColumnReference
ref = case [PersistValue]
row of
                    (PersistText Text
cname : [PersistValue]
_) -> (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
cname Map Text ColumnReference
refMap)
                    [PersistValue]
_ -> forall a. Maybe a
Nothing

    helperCntrs :: ConduitT
  [PersistValue]
  o
  (ResourceT IO)
  [Either a (Either a (ConstraintNameDB, [FieldNameDB]))]
helperCntrs = do
      let check :: [PersistValue] -> m (Text, Text)
check [ PersistText Text
cntrName
                , PersistText Text
clmnName] = forall (m :: * -> *) a. Monad m => a -> m a
return ( Text
cntrName, Text
clmnName )
          check [PersistValue]
other = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"helperCntrs: unexpected " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [PersistValue]
other
      [(Text, Text)]
rows <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}.
MonadFail m =>
[PersistValue] -> m (Text, Text)
check forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> ConstraintNameDB
ConstraintNameDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a b. (a -> b) -> [a] -> [b]
map (Text -> FieldNameDB
FieldNameDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)))
             forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) [(Text, Text)]
rows


-- | Get the information about a column in a table.
getColumn
    :: HasCallStack
    => MySQL.ConnectInfo
    -> (Text -> IO Statement)
    -> EntityNameDB
    -> [PersistValue]
    -> Maybe ColumnReference
    -> IO (Either Text Column)
getColumn :: HasCallStack =>
ConnectInfo
-> (Text -> IO Statement)
-> EntityNameDB
-> [PersistValue]
-> Maybe ColumnReference
-> IO (Either Text Column)
getColumn ConnectInfo
connectInfo Text -> IO Statement
getter EntityNameDB
tname [ PersistText Text
cname
                                   , PersistText Text
null_
                                   , PersistText Text
dataType
                                   , PersistText Text
colType
                                   , PersistValue
colMaxLen
                                   , PersistValue
colPrecision
                                   , PersistValue
colScale
                                   , PersistValue
default'
                                   , PersistValue
generated
                                   ] Maybe ColumnReference
cRef =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
pack) forall a b. b -> Either a b
Right) forall a b. (a -> b) -> a -> b
$
    forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
        -- Default value
        Maybe Text
default_ <-
            case PersistValue
default' of
                PersistValue
PersistNull -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                PersistText Text
t -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Text
t)
                PersistByteString ByteString
bs ->
                    case ByteString -> Either UnicodeException Text
T.decodeUtf8' ByteString
bs of
                        Left UnicodeException
exc ->
                            forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail
                                forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid default column: "
                                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PersistValue
default'
                                forall a. [a] -> [a] -> [a]
++ [Char]
" (error: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show UnicodeException
exc forall a. [a] -> [a] -> [a]
++ [Char]
")"
                        Right Text
t ->
                            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Text
t)
                PersistValue
_ ->
                    forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid default column: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PersistValue
default'

        Maybe Text
generated_ <-
            case PersistValue
generated of
                PersistValue
PersistNull -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                PersistText Text
"" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                PersistByteString ByteString
"" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                PersistText Text
t -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Text
t)
                PersistByteString ByteString
bs ->
                    case ByteString -> Either UnicodeException Text
T.decodeUtf8' ByteString
bs of
                        Left UnicodeException
exc ->
                            forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail
                                forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid generated column: "
                                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PersistValue
generated
                                forall a. [a] -> [a] -> [a]
++ [Char]
" (error: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show UnicodeException
exc forall a. [a] -> [a] -> [a]
++ [Char]
")"
                        Right Text
t ->
                            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Text
t)
                PersistValue
_ ->
                    forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid generated column: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PersistValue
generated

        Maybe ColumnReference
ref <- Maybe ConstraintNameDB -> ExceptT [Char] IO (Maybe ColumnReference)
getRef (ColumnReference -> ConstraintNameDB
crConstraintName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ColumnReference
cRef)

        let colMaxLen' :: Maybe Integer
colMaxLen' =
                case PersistValue
colMaxLen of
                    PersistInt64 Int64
l -> forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
l)
                    PersistValue
_ -> forall a. Maybe a
Nothing
            ci :: ColumnInfo
ci = ColumnInfo
              { ciColumnType :: Text
ciColumnType = Text
colType
              , ciMaxLength :: Maybe Integer
ciMaxLength = Maybe Integer
colMaxLen'
              , ciNumericPrecision :: PersistValue
ciNumericPrecision = PersistValue
colPrecision
              , ciNumericScale :: PersistValue
ciNumericScale = PersistValue
colScale
              }

        (SqlType
typ, Maybe Integer
maxLen) <- Text -> ColumnInfo -> ExceptT [Char] IO (SqlType, Maybe Integer)
parseColumnType Text
dataType ColumnInfo
ci

        -- Okay!
        forall (m :: * -> *) a. Monad m => a -> m a
return Column
            { cName :: FieldNameDB
cName = Text -> FieldNameDB
FieldNameDB Text
cname
            , cNull :: Bool
cNull = Text
null_ forall a. Eq a => a -> a -> Bool
== Text
"YES"
            , cSqlType :: SqlType
cSqlType = SqlType
typ
            , cDefault :: Maybe Text
cDefault = Maybe Text
default_
            , cGenerated :: Maybe Text
cGenerated = Maybe Text
generated_
            , cDefaultConstraintName :: Maybe ConstraintNameDB
cDefaultConstraintName = forall a. Maybe a
Nothing
            , cMaxLen :: Maybe Integer
cMaxLen = Maybe Integer
maxLen
            , cReference :: Maybe ColumnReference
cReference = Maybe ColumnReference
ref
            }
  where
    getRef :: Maybe ConstraintNameDB -> ExceptT [Char] IO (Maybe ColumnReference)
getRef Maybe ConstraintNameDB
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    getRef (Just ConstraintNameDB
refName') = do
        -- Foreign key (if any)
        Statement
stmt <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO Statement
getter forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
            [ Text
"SELECT KCU.REFERENCED_TABLE_NAME, "
            ,   Text
"KCU.CONSTRAINT_NAME, "
            ,   Text
"KCU.ORDINAL_POSITION, "
            ,   Text
"DELETE_RULE, "
            ,   Text
"UPDATE_RULE "
            , Text
"FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE AS KCU "
            , Text
"INNER JOIN INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS AS RC "
            , Text
"  USING (CONSTRAINT_SCHEMA, CONSTRAINT_NAME) "
            , Text
"WHERE KCU.TABLE_SCHEMA = ? "
            ,   Text
"AND KCU.TABLE_NAME   = ? "
            ,   Text
"AND KCU.COLUMN_NAME  = ? "
            ,   Text
"AND KCU.REFERENCED_TABLE_SCHEMA = ? "
            ,   Text
"AND KCU.CONSTRAINT_NAME = ? "
            , Text
"ORDER BY KCU.CONSTRAINT_NAME, "
            ,   Text
"KCU.COLUMN_NAME"
            ]
        let vars :: [PersistValue]
vars =
                [ Text -> PersistValue
PersistText forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 forall a b. (a -> b) -> a -> b
$ ConnectInfo -> ByteString
MySQL.ciDatabase ConnectInfo
connectInfo
                , Text -> PersistValue
PersistText forall a b. (a -> b) -> a -> b
$ EntityNameDB -> Text
unEntityNameDB EntityNameDB
tname
                , Text -> PersistValue
PersistText Text
cname
                , Text -> PersistValue
PersistText forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 forall a b. (a -> b) -> a -> b
$ ConnectInfo -> ByteString
MySQL.ciDatabase ConnectInfo
connectInfo
                , Text -> PersistValue
PersistText forall a b. (a -> b) -> a -> b
$ ConstraintNameDB -> Text
unConstraintNameDB ConstraintNameDB
refName'
                ]
            parseCascadeAction :: a -> Maybe CascadeAction
parseCascadeAction a
txt =
                case a
txt of
                    a
"RESTRICT" -> forall a. a -> Maybe a
Just CascadeAction
Restrict
                    a
"CASCADE" -> forall a. a -> Maybe a
Just CascadeAction
Cascade
                    a
"SET NULL" -> forall a. a -> Maybe a
Just CascadeAction
SetNull
                    a
"SET DEFAULT" -> forall a. a -> Maybe a
Just CascadeAction
SetDefault
                    a
"NO ACTION" -> forall a. Maybe a
Nothing
                    a
_ ->
                        forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected value in parseCascadeAction: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show a
txt

        [[PersistValue]]
cntrs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with (Statement
-> forall (m :: * -> *).
   MonadIO m =>
   [PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery Statement
stmt [PersistValue]
vars) (\ConduitM () [PersistValue] IO ()
src -> forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ ConduitM () [PersistValue] IO ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case [[PersistValue]]
cntrs of
            [] ->
                forall a. Maybe a
Nothing
            [[PersistText Text
tab, PersistText Text
ref, PersistInt64 Int64
pos, PersistText Text
onDel, PersistText Text
onUpd]] ->
                if Int64
pos forall a. Eq a => a -> a -> Bool
== Int64
1
                then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ EntityNameDB -> ConstraintNameDB -> FieldCascade -> ColumnReference
ColumnReference (Text -> EntityNameDB
EntityNameDB Text
tab) (Text -> ConstraintNameDB
ConstraintNameDB Text
ref) FieldCascade
                    { fcOnUpdate :: Maybe CascadeAction
fcOnUpdate = forall {a}. (Eq a, IsString a, Show a) => a -> Maybe CascadeAction
parseCascadeAction Text
onUpd
                    , fcOnDelete :: Maybe CascadeAction
fcOnDelete = forall {a}. (Eq a, IsString a, Show a) => a -> Maybe CascadeAction
parseCascadeAction Text
onDel
                    }
                else forall a. Maybe a
Nothing
            [[PersistValue]]
xs -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
              [ [Char]
"MySQL.getColumn/getRef: error fetching constraints. Expected a single result for foreign key query for table: "
              , Text -> [Char]
T.unpack (EntityNameDB -> Text
unEntityNameDB EntityNameDB
tname)
              , [Char]
" and column: "
              , Text -> [Char]
T.unpack Text
cname
              , [Char]
" but got: "
              , forall a. Show a => a -> [Char]
show [[PersistValue]]
xs
              ]

getColumn ConnectInfo
_ Text -> IO Statement
_ EntityNameDB
_ [PersistValue]
x  Maybe ColumnReference
_ =
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid result from INFORMATION_SCHEMA: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [PersistValue]
x

-- | Extra column information from MySQL schema
data ColumnInfo = ColumnInfo
  { ColumnInfo -> Text
ciColumnType :: Text
  , ColumnInfo -> Maybe Integer
ciMaxLength :: Maybe Integer
  , ColumnInfo -> PersistValue
ciNumericPrecision :: PersistValue
  , ColumnInfo -> PersistValue
ciNumericScale :: PersistValue
  }

-- | Parse the type of column as returned by MySQL's
-- @INFORMATION_SCHEMA@ tables.
parseColumnType :: Text -> ColumnInfo -> ExceptT String IO (SqlType, Maybe Integer)
-- Ints
parseColumnType :: Text -> ColumnInfo -> ExceptT [Char] IO (SqlType, Maybe Integer)
parseColumnType Text
"tinyint" ColumnInfo
ci | ColumnInfo -> Text
ciColumnType ColumnInfo
ci forall a. Eq a => a -> a -> Bool
== Text
"tinyint(1)" = forall (m :: * -> *) a. Monad m => a -> m a
return (SqlType
SqlBool, forall a. Maybe a
Nothing)
parseColumnType Text
"int" ColumnInfo
ci | ColumnInfo -> Text
ciColumnType ColumnInfo
ci forall a. Eq a => a -> a -> Bool
== Text
"int(11)"        = forall (m :: * -> *) a. Monad m => a -> m a
return (SqlType
SqlInt32, forall a. Maybe a
Nothing)
parseColumnType Text
"bigint" ColumnInfo
ci | ColumnInfo -> Text
ciColumnType ColumnInfo
ci forall a. Eq a => a -> a -> Bool
== Text
"bigint(20)"  = forall (m :: * -> *) a. Monad m => a -> m a
return (SqlType
SqlInt64, forall a. Maybe a
Nothing)
-- Double
parseColumnType x :: Text
x@(Text
"double") ColumnInfo
ci | ColumnInfo -> Text
ciColumnType ColumnInfo
ci forall a. Eq a => a -> a -> Bool
== Text
x         = forall (m :: * -> *) a. Monad m => a -> m a
return (SqlType
SqlReal, forall a. Maybe a
Nothing)
parseColumnType Text
"decimal" ColumnInfo
ci                                   =
  case (ColumnInfo -> PersistValue
ciNumericPrecision ColumnInfo
ci, ColumnInfo -> PersistValue
ciNumericScale ColumnInfo
ci) of
    (PersistInt64 Int64
p, PersistInt64 Int64
s) ->
      forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> Word32 -> SqlType
SqlNumeric (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
p) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
s), forall a. Maybe a
Nothing)
    (PersistValue, PersistValue)
_ ->
      forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"missing DECIMAL precision in DB schema"
-- Text
parseColumnType Text
"varchar" ColumnInfo
ci                                   = forall (m :: * -> *) a. Monad m => a -> m a
return (SqlType
SqlString, ColumnInfo -> Maybe Integer
ciMaxLength ColumnInfo
ci)
parseColumnType Text
"text" ColumnInfo
_                                       = forall (m :: * -> *) a. Monad m => a -> m a
return (SqlType
SqlString, forall a. Maybe a
Nothing)
-- ByteString
parseColumnType Text
"varbinary" ColumnInfo
ci                                 = forall (m :: * -> *) a. Monad m => a -> m a
return (SqlType
SqlBlob, ColumnInfo -> Maybe Integer
ciMaxLength ColumnInfo
ci)
parseColumnType Text
"blob" ColumnInfo
_                                       = forall (m :: * -> *) a. Monad m => a -> m a
return (SqlType
SqlBlob, forall a. Maybe a
Nothing)
-- Time-related
parseColumnType Text
"time" ColumnInfo
_                                       = forall (m :: * -> *) a. Monad m => a -> m a
return (SqlType
SqlTime, forall a. Maybe a
Nothing)
parseColumnType Text
"datetime" ColumnInfo
_                                   = forall (m :: * -> *) a. Monad m => a -> m a
return (SqlType
SqlDayTime, forall a. Maybe a
Nothing)
parseColumnType Text
"date" ColumnInfo
_                                       = forall (m :: * -> *) a. Monad m => a -> m a
return (SqlType
SqlDay, forall a. Maybe a
Nothing)

parseColumnType Text
_ ColumnInfo
ci                                           = forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> SqlType
SqlOther (ColumnInfo -> Text
ciColumnType ColumnInfo
ci), forall a. Maybe a
Nothing)


----------------------------------------------------------------------


-- | @getAlters allDefs tblName new old@ finds out what needs to
-- be changed from @old@ to become @new@.
getAlters
    :: [EntityDef]
    -> EntityDef
    -> ([Column], [(ConstraintNameDB, [FieldNameDB])])
    -> ([Column], [(ConstraintNameDB, [FieldNameDB])])
    -> ([AlterColumn], [AlterTable])
getAlters :: [EntityDef]
-> EntityDef
-> ([Column], [(ConstraintNameDB, [FieldNameDB])])
-> ([Column], [(ConstraintNameDB, [FieldNameDB])])
-> ([AlterColumn], [AlterTable])
getAlters [EntityDef]
allDefs EntityDef
edef ([Column]
c1, [(ConstraintNameDB, [FieldNameDB])]
u1) ([Column]
c2, [(ConstraintNameDB, [FieldNameDB])]
u2) =
    ([Column] -> [Column] -> [AlterColumn]
getAltersC [Column]
c1 [Column]
c2, [(ConstraintNameDB, [FieldNameDB])]
-> [(ConstraintNameDB, [FieldNameDB])] -> [AlterTable]
getAltersU [(ConstraintNameDB, [FieldNameDB])]
u1 [(ConstraintNameDB, [FieldNameDB])]
u2)
  where
    tblName :: EntityNameDB
tblName = EntityDef -> EntityNameDB
getEntityDBName EntityDef
edef
    getAltersC :: [Column] -> [Column] -> [AlterColumn]
getAltersC [] [Column]
old = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Column -> [AlterColumn]
dropColumn [Column]
old
    getAltersC (Column
new:[Column]
news) [Column]
old =
        let ([AlterColumn]
alters, [Column]
old') = EntityDef
-> [EntityDef] -> Column -> [Column] -> ([AlterColumn], [Column])
findAlters EntityDef
edef [EntityDef]
allDefs Column
new [Column]
old
         in [AlterColumn]
alters forall a. [a] -> [a] -> [a]
++ [Column] -> [Column] -> [AlterColumn]
getAltersC [Column]
news [Column]
old'

    dropColumn :: Column -> [AlterColumn]
dropColumn Column
col =
        [ConstraintNameDB -> AlterColumn
DropReference (ColumnReference -> ConstraintNameDB
crConstraintName ColumnReference
cr) | Just ColumnReference
cr <- [Column -> Maybe ColumnReference
cReference Column
col]] forall a. [a] -> [a] -> [a]
++
        [Column -> AlterColumn
Drop Column
col]

    getAltersU :: [(ConstraintNameDB, [FieldNameDB])]
-> [(ConstraintNameDB, [FieldNameDB])] -> [AlterTable]
getAltersU [] [(ConstraintNameDB, [FieldNameDB])]
old = forall a b. (a -> b) -> [a] -> [b]
map (ConstraintNameDB -> AlterTable
DropUniqueConstraint forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(ConstraintNameDB, [FieldNameDB])]
old
    getAltersU ((ConstraintNameDB
name, [FieldNameDB]
cols):[(ConstraintNameDB, [FieldNameDB])]
news) [(ConstraintNameDB, [FieldNameDB])]
old =
        case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ConstraintNameDB
name [(ConstraintNameDB, [FieldNameDB])]
old of
            Maybe [FieldNameDB]
Nothing ->
                ConstraintNameDB
-> [(FieldNameDB, FieldType, Integer)] -> AlterTable
AddUniqueConstraint ConstraintNameDB
name (forall a b. (a -> b) -> [a] -> [b]
map FieldNameDB -> (FieldNameDB, FieldType, Integer)
findTypeAndMaxLen [FieldNameDB]
cols)
                forall a. a -> [a] -> [a]
: [(ConstraintNameDB, [FieldNameDB])]
-> [(ConstraintNameDB, [FieldNameDB])] -> [AlterTable]
getAltersU [(ConstraintNameDB, [FieldNameDB])]
news [(ConstraintNameDB, [FieldNameDB])]
old
            Just [FieldNameDB]
ocols ->
                let old' :: [(ConstraintNameDB, [FieldNameDB])]
old' = forall a. (a -> Bool) -> [a] -> [a]
filter (\(ConstraintNameDB
x, [FieldNameDB]
_) -> ConstraintNameDB
x forall a. Eq a => a -> a -> Bool
/= ConstraintNameDB
name) [(ConstraintNameDB, [FieldNameDB])]
old
                 in if forall a. Ord a => [a] -> [a]
sort [FieldNameDB]
cols forall a. Eq a => a -> a -> Bool
== [FieldNameDB]
ocols
                        then [(ConstraintNameDB, [FieldNameDB])]
-> [(ConstraintNameDB, [FieldNameDB])] -> [AlterTable]
getAltersU [(ConstraintNameDB, [FieldNameDB])]
news [(ConstraintNameDB, [FieldNameDB])]
old'
                        else  ConstraintNameDB -> AlterTable
DropUniqueConstraint ConstraintNameDB
name
                            forall a. a -> [a] -> [a]
: ConstraintNameDB
-> [(FieldNameDB, FieldType, Integer)] -> AlterTable
AddUniqueConstraint ConstraintNameDB
name (forall a b. (a -> b) -> [a] -> [b]
map FieldNameDB -> (FieldNameDB, FieldType, Integer)
findTypeAndMaxLen [FieldNameDB]
cols)
                            forall a. a -> [a] -> [a]
: [(ConstraintNameDB, [FieldNameDB])]
-> [(ConstraintNameDB, [FieldNameDB])] -> [AlterTable]
getAltersU [(ConstraintNameDB, [FieldNameDB])]
news [(ConstraintNameDB, [FieldNameDB])]
old'
        where
          findTypeAndMaxLen :: FieldNameDB -> (FieldNameDB, FieldType, Integer)
findTypeAndMaxLen FieldNameDB
col =
              let (FieldNameDB
col', FieldType
ty) = [EntityDef]
-> EntityNameDB -> FieldNameDB -> (FieldNameDB, FieldType)
findTypeOfColumn [EntityDef]
allDefs EntityNameDB
tblName FieldNameDB
col
                  (FieldNameDB
_, Integer
ml) = [EntityDef]
-> EntityNameDB -> FieldNameDB -> (FieldNameDB, Integer)
findMaxLenOfColumn [EntityDef]
allDefs EntityNameDB
tblName FieldNameDB
col
              in
                  (FieldNameDB
col', FieldType
ty, Integer
ml)


-- | @findAlters x y newColumn oldColumns@ finds out what needs to be
-- changed in the columns @oldColumns@ for @newColumn@ to be
-- supported.
findAlters
    :: EntityDef
    -> [EntityDef]
    -> Column
    -> [Column]
    -> ([AlterColumn], [Column])
findAlters :: EntityDef
-> [EntityDef] -> Column -> [Column] -> ([AlterColumn], [Column])
findAlters EntityDef
edef [EntityDef]
allDefs col :: Column
col@(Column FieldNameDB
name Bool
isNull SqlType
type_ Maybe Text
def Maybe Text
gen Maybe ConstraintNameDB
_defConstraintName Maybe Integer
maxLen Maybe ColumnReference
ref) [Column]
cols =
    case forall a. (a -> Bool) -> [a] -> [a]
filter ((FieldNameDB
name forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Column -> FieldNameDB
cName) [Column]
cols of
    -- new fkey that didn't exist before
        [] ->
            case Maybe ColumnReference
ref of
                Maybe ColumnReference
Nothing -> ([Column -> AlterColumn
Add' Column
col],[])
                Just ColumnReference
cr ->
                    let tname :: EntityNameDB
tname = ColumnReference -> EntityNameDB
crTableName ColumnReference
cr
                        cname :: ConstraintNameDB
cname = ColumnReference -> ConstraintNameDB
crConstraintName ColumnReference
cr
                        cnstr :: [AlterColumn]
cnstr = [[EntityDef]
-> ConstraintNameDB
-> EntityNameDB
-> FieldNameDB
-> FieldCascade
-> AlterColumn
addReference [EntityDef]
allDefs ConstraintNameDB
cname EntityNameDB
tname FieldNameDB
name (ColumnReference -> FieldCascade
crFieldCascade ColumnReference
cr)]
                    in
                        (Column -> AlterColumn
Add' Column
col forall a. a -> [a] -> [a]
: [AlterColumn]
cnstr, [Column]
cols)
        Column FieldNameDB
_ Bool
isNull' SqlType
type_' Maybe Text
def' Maybe Text
gen' Maybe ConstraintNameDB
_defConstraintName' Maybe Integer
maxLen' Maybe ColumnReference
ref' : [Column]
_ ->
            let -- Foreign key
                refDrop :: [AlterColumn]
refDrop =
                    case (Maybe ColumnReference
ref forall a. Eq a => a -> a -> Bool
== Maybe ColumnReference
ref', Maybe ColumnReference
ref') of
                        (Bool
False, Just ColumnReference {crConstraintName :: ColumnReference -> ConstraintNameDB
crConstraintName=ConstraintNameDB
cname}) ->
                            [ConstraintNameDB -> AlterColumn
DropReference ConstraintNameDB
cname]
                        (Bool, Maybe ColumnReference)
_ ->
                            []
                refAdd :: [AlterColumn]
refAdd  =
                    case (Maybe ColumnReference
ref forall a. Eq a => a -> a -> Bool
== Maybe ColumnReference
ref', Maybe ColumnReference
ref) of
                        (Bool
False, Just ColumnReference {crTableName :: ColumnReference -> EntityNameDB
crTableName=EntityNameDB
tname, crConstraintName :: ColumnReference -> ConstraintNameDB
crConstraintName=ConstraintNameDB
cname, crFieldCascade :: ColumnReference -> FieldCascade
crFieldCascade = FieldCascade
cfc })
                            | EntityNameDB
tname forall a. Eq a => a -> a -> Bool
/= EntityDef -> EntityNameDB
getEntityDBName EntityDef
edef
                            , Just FieldDef
idField <- EntityDef -> Maybe FieldDef
getEntityIdField EntityDef
edef
                            , ConstraintNameDB -> Text
unConstraintNameDB ConstraintNameDB
cname forall a. Eq a => a -> a -> Bool
/= FieldNameDB -> Text
unFieldNameDB (FieldDef -> FieldNameDB
fieldDB FieldDef
idField)
                            ->
                            [[EntityDef]
-> ConstraintNameDB
-> EntityNameDB
-> FieldNameDB
-> FieldCascade
-> AlterColumn
addReference [EntityDef]
allDefs ConstraintNameDB
cname EntityNameDB
tname FieldNameDB
name FieldCascade
cfc]
                        (Bool, Maybe ColumnReference)
_ -> []
                -- Type and nullability
                modType :: [AlterColumn]
modType | SqlType -> Maybe Integer -> Bool -> [Char]
showSqlType SqlType
type_ Maybe Integer
maxLen Bool
False [Char] -> [Char] -> Bool
`ciEquals` SqlType -> Maybe Integer -> Bool -> [Char]
showSqlType SqlType
type_' Maybe Integer
maxLen' Bool
False Bool -> Bool -> Bool
&& Bool
isNull forall a. Eq a => a -> a -> Bool
== Bool
isNull' = []
                        | Bool
otherwise = [Column -> AlterColumn
Change Column
col]

                -- Default value
                -- Avoid DEFAULT NULL, since it is always unnecessary, and is an error for text/blob fields
                modDef :: [AlterColumn]
modDef =
                    if Maybe Text
def forall a. Eq a => a -> a -> Bool
== Maybe Text
def' then []
                    else case Maybe Text
def of
                        Maybe Text
Nothing -> [Column -> AlterColumn
NoDefault Column
col]
                        Just Text
s ->
                            if Text -> Text
T.toUpper Text
s forall a. Eq a => a -> a -> Bool
== Text
"NULL" then []
                            else [Column -> [Char] -> AlterColumn
Default Column
col forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
s]

                -- Does the generated value need to change?
                modGen :: [AlterColumn]
modGen =
                    if Maybe Text
gen forall a. Eq a => a -> a -> Bool
== Maybe Text
gen' then []
                    else case Maybe Text
gen of
                        Maybe Text
Nothing -> [Column -> SqlType -> Maybe Integer -> AlterColumn
NoGen Column
col SqlType
type_ Maybe Integer
maxLen]
                        Just Text
genExpr -> [Column -> SqlType -> Maybe Integer -> [Char] -> AlterColumn
Gen Column
col SqlType
type_ Maybe Integer
maxLen forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
genExpr]

            in ( [AlterColumn]
refDrop forall a. [a] -> [a] -> [a]
++ [AlterColumn]
modType forall a. [a] -> [a] -> [a]
++ [AlterColumn]
modDef forall a. [a] -> [a] -> [a]
++ [AlterColumn]
modGen forall a. [a] -> [a] -> [a]
++ [AlterColumn]
refAdd
               , forall a. (a -> Bool) -> [a] -> [a]
filter ((FieldNameDB
name forall a. Eq a => a -> a -> Bool
/=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Column -> FieldNameDB
cName) [Column]
cols
               )

  where
    ciEquals :: [Char] -> [Char] -> Bool
ciEquals [Char]
x [Char]
y = Text -> Text
T.toCaseFold ([Char] -> Text
T.pack [Char]
x) forall a. Eq a => a -> a -> Bool
== Text -> Text
T.toCaseFold ([Char] -> Text
T.pack [Char]
y)

----------------------------------------------------------------------


-- | Prints the part of a @CREATE TABLE@ statement about a given
-- column.
showColumn :: Column -> String
showColumn :: Column -> [Char]
showColumn (Column FieldNameDB
n Bool
nu SqlType
t Maybe Text
def Maybe Text
gen Maybe ConstraintNameDB
_defConstraintName Maybe Integer
maxLen Maybe ColumnReference
ref) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ FieldNameDB -> [Char]
escapeF FieldNameDB
n
    , [Char]
" "
    , SqlType -> Maybe Integer -> Bool -> [Char]
showSqlType SqlType
t Maybe Integer
maxLen Bool
True
    , [Char]
" "
    , case Maybe Text
gen of
        Maybe Text
Nothing -> [Char]
""
        Just Text
genExpr ->
            if Text -> Text
T.toUpper Text
genExpr forall a. Eq a => a -> a -> Bool
== Text
"NULL" then [Char]
""
            else [Char]
" GENERATED ALWAYS AS (" forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
genExpr forall a. Semigroup a => a -> a -> a
<> [Char]
") STORED "
    , if Bool
nu then [Char]
"NULL" else [Char]
"NOT NULL"
    , case Maybe Text
def of
        Maybe Text
Nothing -> [Char]
""
        Just Text
s -> -- Avoid DEFAULT NULL, since it is always unnecessary, and is an error for text/blob fields
                  if Text -> Text
T.toUpper Text
s forall a. Eq a => a -> a -> Bool
== Text
"NULL" then [Char]
""
                  else [Char]
" DEFAULT " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
s
    , case Maybe ColumnReference
ref of
        Maybe ColumnReference
Nothing -> [Char]
""
        Just ColumnReference
cRef -> [Char]
" REFERENCES " forall a. [a] -> [a] -> [a]
++ EntityNameDB -> [Char]
escapeE (ColumnReference -> EntityNameDB
crTableName ColumnReference
cRef)
            forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (FieldCascade -> Text
renderFieldCascade (ColumnReference -> FieldCascade
crFieldCascade ColumnReference
cRef))
    ]


-- | Renders an 'SqlType' in MySQL's format.
showSqlType :: SqlType
            -> Maybe Integer -- ^ @maxlen@
            -> Bool -- ^ include character set information?
            -> String
showSqlType :: SqlType -> Maybe Integer -> Bool -> [Char]
showSqlType SqlType
SqlBlob    Maybe Integer
Nothing    Bool
_     = [Char]
"BLOB"
showSqlType SqlType
SqlBlob    (Just Integer
i)   Bool
_     = [Char]
"VARBINARY(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Integer
i forall a. [a] -> [a] -> [a]
++ [Char]
")"
showSqlType SqlType
SqlBool    Maybe Integer
_          Bool
_     = [Char]
"TINYINT(1)"
showSqlType SqlType
SqlDay     Maybe Integer
_          Bool
_     = [Char]
"DATE"
showSqlType SqlType
SqlDayTime Maybe Integer
_          Bool
_     = [Char]
"DATETIME"
showSqlType SqlType
SqlInt32   Maybe Integer
_          Bool
_     = [Char]
"INT(11)"
showSqlType SqlType
SqlInt64   Maybe Integer
_          Bool
_     = [Char]
"BIGINT"
showSqlType SqlType
SqlReal    Maybe Integer
_          Bool
_     = [Char]
"DOUBLE"
showSqlType (SqlNumeric Word32
s Word32
prec) Maybe Integer
_ Bool
_     = [Char]
"NUMERIC(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Word32
s forall a. [a] -> [a] -> [a]
++ [Char]
"," forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Word32
prec forall a. [a] -> [a] -> [a]
++ [Char]
")"
showSqlType SqlType
SqlString  Maybe Integer
Nothing    Bool
True  = [Char]
"TEXT CHARACTER SET utf8mb4"
showSqlType SqlType
SqlString  Maybe Integer
Nothing    Bool
False = [Char]
"TEXT"
showSqlType SqlType
SqlString  (Just Integer
i)   Bool
True  = [Char]
"VARCHAR(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Integer
i forall a. [a] -> [a] -> [a]
++ [Char]
") CHARACTER SET utf8mb4"
showSqlType SqlType
SqlString  (Just Integer
i)   Bool
False = [Char]
"VARCHAR(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Integer
i forall a. [a] -> [a] -> [a]
++ [Char]
")"
showSqlType SqlType
SqlTime    Maybe Integer
_          Bool
_     = [Char]
"TIME"
showSqlType (SqlOther Text
t) Maybe Integer
_        Bool
_     = Text -> [Char]
T.unpack Text
t

-- | Render an action that must be done on the database.
showAlterDb :: AlterDB -> (Bool, Text)
showAlterDb :: AlterDB -> (Bool, Text)
showAlterDb (AddTable [Char]
s) = (Bool
False, [Char] -> Text
pack [Char]
s)
showAlterDb (AlterColumn EntityNameDB
t AlterColumn
ac) =
    (AlterColumn -> Bool
isUnsafe AlterColumn
ac, [Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ EntityNameDB -> AlterColumn -> [Char]
showAlter EntityNameDB
t AlterColumn
ac)
  where
    isUnsafe :: AlterColumn -> Bool
isUnsafe Drop{} = Bool
True
    isUnsafe AlterColumn
_      = Bool
False
showAlterDb (AlterTable EntityNameDB
t AlterTable
at) = (Bool
False, [Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ EntityNameDB -> AlterTable -> [Char]
showAlterTable EntityNameDB
t AlterTable
at)


-- | Render an action that must be done on a table.
showAlterTable :: EntityNameDB -> AlterTable -> String
showAlterTable :: EntityNameDB -> AlterTable -> [Char]
showAlterTable EntityNameDB
table (AddUniqueConstraint ConstraintNameDB
cname [(FieldNameDB, FieldType, Integer)]
cols) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
"ALTER TABLE "
    , EntityNameDB -> [Char]
escapeE EntityNameDB
table
    , [Char]
" ADD CONSTRAINT "
    , ConstraintNameDB -> [Char]
escapeC ConstraintNameDB
cname
    , [Char]
" UNIQUE("
    , forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Show a => (FieldNameDB, FieldType, a) -> [Char]
escapeDBName' [(FieldNameDB, FieldType, Integer)]
cols
    , [Char]
")"
    ]
    where
      escapeDBName' :: (FieldNameDB, FieldType, a) -> [Char]
escapeDBName' (FieldNameDB
name, (FTTypeCon Maybe Text
_ Text
"Text"      ), a
maxlen) = FieldNameDB -> [Char]
escapeF FieldNameDB
name forall a. [a] -> [a] -> [a]
++ [Char]
"(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
maxlen forall a. [a] -> [a] -> [a]
++ [Char]
")"
      escapeDBName' (FieldNameDB
name, (FTTypeCon Maybe Text
_ Text
"String"    ), a
maxlen) = FieldNameDB -> [Char]
escapeF FieldNameDB
name forall a. [a] -> [a] -> [a]
++ [Char]
"(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
maxlen forall a. [a] -> [a] -> [a]
++ [Char]
")"
      escapeDBName' (FieldNameDB
name, (FTTypeCon Maybe Text
_ Text
"ByteString"), a
maxlen) = FieldNameDB -> [Char]
escapeF FieldNameDB
name forall a. [a] -> [a] -> [a]
++ [Char]
"(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
maxlen forall a. [a] -> [a] -> [a]
++ [Char]
")"
      escapeDBName' (FieldNameDB
name, FieldType
_                         , a
_)      = FieldNameDB -> [Char]
escapeF FieldNameDB
name
showAlterTable EntityNameDB
table (DropUniqueConstraint ConstraintNameDB
cname) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
"ALTER TABLE "
    , EntityNameDB -> [Char]
escapeE EntityNameDB
table
    , [Char]
" DROP INDEX "
    , ConstraintNameDB -> [Char]
escapeC ConstraintNameDB
cname
    ]


-- | Render an action that must be done on a column.
showAlter :: EntityNameDB -> AlterColumn -> String
showAlter :: EntityNameDB -> AlterColumn -> [Char]
showAlter EntityNameDB
table (Change (Column FieldNameDB
n Bool
nu SqlType
t Maybe Text
def Maybe Text
gen Maybe ConstraintNameDB
defConstraintName Maybe Integer
maxLen Maybe ColumnReference
_ref)) =
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
"ALTER TABLE "
    , EntityNameDB -> [Char]
escapeE EntityNameDB
table
    , [Char]
" CHANGE "
    , FieldNameDB -> [Char]
escapeF FieldNameDB
n
    , [Char]
" "
    , Column -> [Char]
showColumn (FieldNameDB
-> Bool
-> SqlType
-> Maybe Text
-> Maybe Text
-> Maybe ConstraintNameDB
-> Maybe Integer
-> Maybe ColumnReference
-> Column
Column FieldNameDB
n Bool
nu SqlType
t Maybe Text
def Maybe Text
gen Maybe ConstraintNameDB
defConstraintName Maybe Integer
maxLen forall a. Maybe a
Nothing)
    ]
showAlter EntityNameDB
table (Add' Column
col) =
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
"ALTER TABLE "
    , EntityNameDB -> [Char]
escapeE EntityNameDB
table
    , [Char]
" ADD COLUMN "
    , Column -> [Char]
showColumn Column
col
    ]
showAlter EntityNameDB
table (Drop Column
c) =
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
"ALTER TABLE "
    , EntityNameDB -> [Char]
escapeE EntityNameDB
table
    , [Char]
" DROP COLUMN "
    , FieldNameDB -> [Char]
escapeF (Column -> FieldNameDB
cName Column
c)
    ]
showAlter EntityNameDB
table (Default Column
c [Char]
s) =
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
"ALTER TABLE "
    , EntityNameDB -> [Char]
escapeE EntityNameDB
table
    , [Char]
" ALTER COLUMN "
    , FieldNameDB -> [Char]
escapeF (Column -> FieldNameDB
cName Column
c)
    , [Char]
" SET DEFAULT "
    , [Char]
s
    ]
showAlter EntityNameDB
table (NoDefault Column
c) =
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
"ALTER TABLE "
    , EntityNameDB -> [Char]
escapeE EntityNameDB
table
    , [Char]
" ALTER COLUMN "
    , FieldNameDB -> [Char]
escapeF (Column -> FieldNameDB
cName Column
c)
    , [Char]
" DROP DEFAULT"
    ]
showAlter EntityNameDB
table (Gen Column
col SqlType
typ Maybe Integer
len [Char]
expr) =
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
"ALTER TABLE "
    , EntityNameDB -> [Char]
escapeE EntityNameDB
table
    , [Char]
" MODIFY COLUMN "
    , FieldNameDB -> [Char]
escapeF (Column -> FieldNameDB
cName Column
col)
    , [Char]
" "
    , SqlType -> Maybe Integer -> Bool -> [Char]
showSqlType SqlType
typ Maybe Integer
len Bool
True
    , [Char]
" GENERATED ALWAYS AS ("
    , [Char]
expr
    , [Char]
") STORED"
    ]
showAlter EntityNameDB
table (NoGen Column
col SqlType
typ Maybe Integer
len) =
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
"ALTER TABLE "
    , EntityNameDB -> [Char]
escapeE EntityNameDB
table
    , [Char]
" MODIFY COLUMN "
    , FieldNameDB -> [Char]
escapeF (Column -> FieldNameDB
cName Column
col)
    , [Char]
" "
    , SqlType -> Maybe Integer -> Bool -> [Char]
showSqlType SqlType
typ Maybe Integer
len Bool
True
    ]
showAlter EntityNameDB
table (Update' Column
c [Char]
s) =
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
"UPDATE "
    , EntityNameDB -> [Char]
escapeE EntityNameDB
table
    , [Char]
" SET "
    , FieldNameDB -> [Char]
escapeF (Column -> FieldNameDB
cName Column
c)
    , [Char]
"="
    , [Char]
s
    , [Char]
" WHERE "
    , FieldNameDB -> [Char]
escapeF (Column -> FieldNameDB
cName Column
c)
    , [Char]
" IS NULL"
    ]
showAlter EntityNameDB
table (AddReference EntityNameDB
reftable ConstraintNameDB
fkeyname [FieldNameDB]
t2 [FieldNameDB]
id2 FieldCascade
fc) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
"ALTER TABLE "
    , EntityNameDB -> [Char]
escapeE EntityNameDB
table
    , [Char]
" ADD CONSTRAINT "
    , ConstraintNameDB -> [Char]
escapeC ConstraintNameDB
fkeyname
    , [Char]
" FOREIGN KEY("
    , forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map FieldNameDB -> [Char]
escapeF [FieldNameDB]
t2
    , [Char]
") REFERENCES "
    , EntityNameDB -> [Char]
escapeE EntityNameDB
reftable
    , [Char]
"("
    , forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map FieldNameDB -> [Char]
escapeF [FieldNameDB]
id2
    , [Char]
") "
    , Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ FieldCascade -> Text
renderFieldCascade FieldCascade
fc
    ]
showAlter EntityNameDB
table (DropReference ConstraintNameDB
cname) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
"ALTER TABLE "
    , EntityNameDB -> [Char]
escapeE EntityNameDB
table
    , [Char]
" DROP FOREIGN KEY "
    , ConstraintNameDB -> [Char]
escapeC ConstraintNameDB
cname
    ]

----------------------------------------------------------------------

escapeC :: ConstraintNameDB -> String
escapeC :: ConstraintNameDB -> [Char]
escapeC = forall a str. DatabaseName a => (Text -> str) -> a -> str
escapeWith ([Char] -> [Char]
escapeDBName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack)

escapeE :: EntityNameDB -> String
escapeE :: EntityNameDB -> [Char]
escapeE = forall a str. DatabaseName a => (Text -> str) -> a -> str
escapeWith ([Char] -> [Char]
escapeDBName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack)

escapeF :: FieldNameDB -> String
escapeF :: FieldNameDB -> [Char]
escapeF = forall a str. DatabaseName a => (Text -> str) -> a -> str
escapeWith ([Char] -> [Char]
escapeDBName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack)

escapeET :: EntityNameDB -> Text
escapeET :: EntityNameDB -> Text
escapeET = forall a str. DatabaseName a => (Text -> str) -> a -> str
escapeWith ([Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
escapeDBName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack)

escapeFT :: FieldNameDB -> Text
escapeFT :: FieldNameDB -> Text
escapeFT = forall a str. DatabaseName a => (Text -> str) -> a -> str
escapeWith ([Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
escapeDBName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack)

-- | Escape a database name to be included on a query.
escapeDBName :: String -> String
escapeDBName :: [Char] -> [Char]
escapeDBName [Char]
str = Char
'`' forall a. a -> [a] -> [a]
: [Char] -> [Char]
go [Char]
str
    where
      go :: [Char] -> [Char]
go (Char
'`':[Char]
xs) = Char
'`' forall a. a -> [a] -> [a]
: Char
'`' forall a. a -> [a] -> [a]
: [Char] -> [Char]
go [Char]
xs
      go ( Char
x :[Char]
xs) =     Char
x     forall a. a -> [a] -> [a]
: [Char] -> [Char]
go [Char]
xs
      go [Char]
""       = [Char]
"`"

-- | Information required to connect to a MySQL database
-- using @persistent@'s generic facilities.  These values are the
-- same that are given to 'withMySQLPool'.
data MySQLConf = MySQLConf
    MySQLConnectInfo
    Int
    deriving Int -> MySQLConf -> [Char] -> [Char]
[MySQLConf] -> [Char] -> [Char]
MySQLConf -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [MySQLConf] -> [Char] -> [Char]
$cshowList :: [MySQLConf] -> [Char] -> [Char]
show :: MySQLConf -> [Char]
$cshow :: MySQLConf -> [Char]
showsPrec :: Int -> MySQLConf -> [Char] -> [Char]
$cshowsPrec :: Int -> MySQLConf -> [Char] -> [Char]
Show

-- | Extract connection configs from 'MySQLConf'
-- @since 0.4.1
myConnInfo :: MySQLConf -> MySQLConnectInfo
myConnInfo :: MySQLConf -> MySQLConnectInfo
myConnInfo (MySQLConf MySQLConnectInfo
c Int
_) = MySQLConnectInfo
c

-- | Extract connection pool size from 'MySQLConf'
-- @since 0.4.1
myPoolSize :: MySQLConf -> Int
myPoolSize :: MySQLConf -> Int
myPoolSize (MySQLConf MySQLConnectInfo
_ Int
p) = Int
p

setMyConnInfo :: MySQLConnectInfo -> MySQLConf -> MySQLConf
setMyConnInfo :: MySQLConnectInfo -> MySQLConf -> MySQLConf
setMyConnInfo MySQLConnectInfo
c (MySQLConf MySQLConnectInfo
_ Int
p) = MySQLConnectInfo -> Int -> MySQLConf
MySQLConf MySQLConnectInfo
c Int
p

-- | Public constructor for @MySQLConf@.
mkMySQLConf
  :: MySQLConnectInfo  -- ^ The connection information.
  -> Int               -- ^ How many connections should be held on the connection pool.
  -> MySQLConf
mkMySQLConf :: MySQLConnectInfo -> Int -> MySQLConf
mkMySQLConf = MySQLConnectInfo -> Int -> MySQLConf
MySQLConf

-- | MySQL connection information.
data MySQLConnectInfo = MySQLConnectInfo
  { MySQLConnectInfo -> ConnectInfo
innerConnInfo :: MySQL.ConnectInfo
  , MySQLConnectInfo -> Maybe ClientParams
innerConnTLS  :: (Maybe TLS.ClientParams)
  } deriving Int -> MySQLConnectInfo -> [Char] -> [Char]
[MySQLConnectInfo] -> [Char] -> [Char]
MySQLConnectInfo -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [MySQLConnectInfo] -> [Char] -> [Char]
$cshowList :: [MySQLConnectInfo] -> [Char] -> [Char]
show :: MySQLConnectInfo -> [Char]
$cshow :: MySQLConnectInfo -> [Char]
showsPrec :: Int -> MySQLConnectInfo -> [Char] -> [Char]
$cshowsPrec :: Int -> MySQLConnectInfo -> [Char] -> [Char]
Show

-- | Public constructor for @MySQLConnectInfo@.
mkMySQLConnectInfo
  :: NetworkSocket.HostName  -- ^ hostname
  -> BSC.ByteString          -- ^ username
  -> BSC.ByteString          -- ^ password
  -> BSC.ByteString          -- ^ database
  -> MySQLConnectInfo
mkMySQLConnectInfo :: [Char]
-> ByteString -> ByteString -> ByteString -> MySQLConnectInfo
mkMySQLConnectInfo [Char]
host ByteString
user ByteString
pass ByteString
db
  = ConnectInfo -> Maybe ClientParams -> MySQLConnectInfo
MySQLConnectInfo ConnectInfo
innerCi forall a. Maybe a
Nothing
  where
    innerCi :: ConnectInfo
innerCi = ConnectInfo
MySQL.defaultConnectInfo {
        ciHost :: [Char]
MySQL.ciHost     = [Char]
host
      , ciUser :: ByteString
MySQL.ciUser     = ByteString
user
      , ciPassword :: ByteString
MySQL.ciPassword = ByteString
pass
      , ciDatabase :: ByteString
MySQL.ciDatabase = ByteString
db
    }

-- | Update port number for @MySQLConnectInfo@.
setMySQLConnectInfoPort
  :: NetworkSocket.PortNumber -> MySQLConnectInfo -> MySQLConnectInfo
setMySQLConnectInfoPort :: PortNumber -> MySQLConnectInfo -> MySQLConnectInfo
setMySQLConnectInfoPort PortNumber
port MySQLConnectInfo
ci
  = MySQLConnectInfo
ci {innerConnInfo :: ConnectInfo
innerConnInfo = ConnectInfo
innerCi { ciPort :: PortNumber
MySQL.ciPort = PortNumber
port } }
  where innerCi :: ConnectInfo
innerCi = MySQLConnectInfo -> ConnectInfo
innerConnInfo MySQLConnectInfo
ci

-- | Update character set for @MySQLConnectInfo@.
setMySQLConnectInfoCharset
  :: Word.Word8       -- ^ Numeric ID of collation. See https://dev.mysql.com/doc/refman/5.7/en/show-collation.html.
  -> MySQLConnectInfo -- ^ Reference connectInfo to perform update on
  -> MySQLConnectInfo
setMySQLConnectInfoCharset :: Word8 -> MySQLConnectInfo -> MySQLConnectInfo
setMySQLConnectInfoCharset Word8
charset MySQLConnectInfo
ci
  = MySQLConnectInfo
ci {innerConnInfo :: ConnectInfo
innerConnInfo = ConnectInfo
innerCi { ciCharset :: Word8
MySQL.ciCharset = Word8
charset } }
  where innerCi :: ConnectInfo
innerCi = MySQLConnectInfo -> ConnectInfo
innerConnInfo MySQLConnectInfo
ci

-- | Set TLS ClientParams for @MySQLConnectInfo@.
setMySQLConnectInfoTLS
  :: TLS.ClientParams -- ^ @ClientParams@ to establish a TLS connection with.
  -> MySQLConnectInfo -- ^ Reference connectInfo to perform update on
  -> MySQLConnectInfo
setMySQLConnectInfoTLS :: ClientParams -> MySQLConnectInfo -> MySQLConnectInfo
setMySQLConnectInfoTLS ClientParams
tls MySQLConnectInfo
ci
  = MySQLConnectInfo
ci {innerConnTLS :: Maybe ClientParams
innerConnTLS = forall a. a -> Maybe a
Just ClientParams
tls}

instance FromJSON MySQLConf where
    parseJSON :: Value -> Parser MySQLConf
parseJSON Value
v = forall a. ([Char] -> [Char]) -> Parser a -> Parser a
modifyFailure ([Char]
"Persistent: error loading MySQL conf: " forall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$
      forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"MySQLConf") Value
v forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        [Char]
database <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"database"
        [Char]
host     <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"host"
        Word
port     <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"port"
        [Char]
user     <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"user"
        [Char]
password <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"password"
        Int
pool     <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"poolsize"
        let ci :: ConnectInfo
ci = ConnectInfo
MySQL.defaultConnectInfo
                   { ciHost :: [Char]
MySQL.ciHost     = [Char]
host
                   , ciPort :: PortNumber
MySQL.ciPort     = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
port :: Word)
                   , ciUser :: ByteString
MySQL.ciUser     = [Char] -> ByteString
BSC.pack [Char]
user
                   , ciPassword :: ByteString
MySQL.ciPassword = [Char] -> ByteString
BSC.pack [Char]
password
                   , ciDatabase :: ByteString
MySQL.ciDatabase = [Char] -> ByteString
BSC.pack [Char]
database
                   }
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ MySQLConnectInfo -> Int -> MySQLConf
MySQLConf (ConnectInfo -> Maybe ClientParams -> MySQLConnectInfo
MySQLConnectInfo ConnectInfo
ci forall a. Maybe a
Nothing) Int
pool

instance PersistConfig MySQLConf where
    type PersistConfigBackend MySQLConf = SqlPersistT

    type PersistConfigPool    MySQLConf = ConnectionPool

    createPoolConfig :: MySQLConf -> IO (PersistConfigPool MySQLConf)
createPoolConfig (MySQLConf MySQLConnectInfo
cs Int
size)
      = forall (m :: * -> *) a. NoLoggingT m a -> m a
runNoLoggingT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) backend.
(MonadUnliftIO m, MonadLoggerIO m, IsPersistBackend backend,
 BaseBackend backend ~ SqlBackend,
 BackendCompatible SqlBackend backend) =>
MySQLConnectInfo -> Int -> m (Pool backend)
createMySQLPool MySQLConnectInfo
cs Int
size -- FIXME

    runPool :: forall (m :: * -> *) a.
MonadUnliftIO m =>
MySQLConf
-> PersistConfigBackend MySQLConf m a
-> PersistConfigPool MySQLConf
-> m a
runPool MySQLConf
_ = forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> m a
runSqlPool

    loadConfig :: Value -> Parser MySQLConf
loadConfig = forall a. FromJSON a => Value -> Parser a
parseJSON

    applyEnv :: MySQLConf -> IO MySQLConf
applyEnv MySQLConf
conf = do
        [([Char], [Char])]
env <- IO [([Char], [Char])]
getEnvironment
        let maybeEnv :: ByteString -> [Char] -> ByteString
maybeEnv ByteString
old [Char]
var = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
old forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> ByteString
BSC.pack forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ([Char]
"MYSQL_" forall a. [a] -> [a] -> [a]
++ [Char]
var) [([Char], [Char])]
env
        let innerCi :: ConnectInfo
innerCi = MySQLConnectInfo -> ConnectInfo
innerConnInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. MySQLConf -> MySQLConnectInfo
myConnInfo forall a b. (a -> b) -> a -> b
$ MySQLConf
conf
        let innerCiNew :: ConnectInfo
innerCiNew = case ConnectInfo
innerCi of
                MySQL.ConnectInfo
                  { ciHost :: ConnectInfo -> [Char]
MySQL.ciHost     = [Char]
host
                  , ciPort :: ConnectInfo -> PortNumber
MySQL.ciPort     = PortNumber
port
                  , ciUser :: ConnectInfo -> ByteString
MySQL.ciUser     = ByteString
user
                  , ciPassword :: ConnectInfo -> ByteString
MySQL.ciPassword = ByteString
password
                  , ciDatabase :: ConnectInfo -> ByteString
MySQL.ciDatabase = ByteString
database
                  } -> (ConnectInfo
innerCi)
                        { ciHost :: [Char]
MySQL.ciHost     = ByteString -> [Char]
BSC.unpack forall a b. (a -> b) -> a -> b
$ ByteString -> [Char] -> ByteString
maybeEnv ([Char] -> ByteString
BSC.pack [Char]
host) [Char]
"HOST"
                        , ciPort :: PortNumber
MySQL.ciPort     = forall a. Read a => [Char] -> a
read (ByteString -> [Char]
BSC.unpack forall a b. (a -> b) -> a -> b
$ ByteString -> [Char] -> ByteString
maybeEnv ([Char] -> ByteString
BSC.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show PortNumber
port) [Char]
"PORT")
                        , ciUser :: ByteString
MySQL.ciUser     = ByteString -> [Char] -> ByteString
maybeEnv ByteString
user [Char]
"USER"
                        , ciPassword :: ByteString
MySQL.ciPassword = ByteString -> [Char] -> ByteString
maybeEnv ByteString
password [Char]
"PASSWORD"
                        , ciDatabase :: ByteString
MySQL.ciDatabase = ByteString -> [Char] -> ByteString
maybeEnv ByteString
database [Char]
"DATABASE"
                        }
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ MySQLConnectInfo -> MySQLConf -> MySQLConf
setMyConnInfo (ConnectInfo -> Maybe ClientParams -> MySQLConnectInfo
MySQLConnectInfo ConnectInfo
innerCiNew forall a. Maybe a
Nothing) MySQLConf
conf

mockMigrate :: MySQL.ConnectInfo
         -> [EntityDef]
         -> (Text -> IO Statement)
         -> EntityDef
         -> IO (Either [Text] [(Bool, Text)])
mockMigrate :: ConnectInfo
-> [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)])
mockMigrate ConnectInfo
_connectInfo [EntityDef]
allDefs Text -> IO Statement
_getter EntityDef
val = do
    let name :: EntityNameDB
name = EntityDef -> EntityNameDB
getEntityDBName EntityDef
val
    let ([Column]
newcols, [UniqueDef]
udefs, [ForeignDef]
fdefs) = [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])
mysqlMkColumns [EntityDef]
allDefs EntityDef
val
    let udspair :: [(ConstraintNameDB, [FieldNameDB])]
udspair = forall a b. (a -> b) -> [a] -> [b]
map UniqueDef -> (ConstraintNameDB, [FieldNameDB])
udToPair [UniqueDef]
udefs
    case () of
      -- Nothing found, create everything
      () -> do
        let uniques :: [AlterDB]
uniques = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [(ConstraintNameDB, [FieldNameDB])]
udspair forall a b. (a -> b) -> a -> b
$ \(ConstraintNameDB
uname, [FieldNameDB]
ucols) ->
                      [ EntityNameDB -> AlterTable -> AlterDB
AlterTable EntityNameDB
name forall a b. (a -> b) -> a -> b
$
                        ConstraintNameDB
-> [(FieldNameDB, FieldType, Integer)] -> AlterTable
AddUniqueConstraint ConstraintNameDB
uname forall a b. (a -> b) -> a -> b
$
                        forall a b. (a -> b) -> [a] -> [b]
map (EntityNameDB -> FieldNameDB -> (FieldNameDB, FieldType, Integer)
findTypeAndMaxLen EntityNameDB
name) [FieldNameDB]
ucols ]
        let foreigns :: [AlterDB]
foreigns = do
              Column { cName :: Column -> FieldNameDB
cName=FieldNameDB
cname, cReference :: Column -> Maybe ColumnReference
cReference= Just ColumnReference{crTableName :: ColumnReference -> EntityNameDB
crTableName = EntityNameDB
refTable, crConstraintName :: ColumnReference -> ConstraintNameDB
crConstraintName = ConstraintNameDB
refConstr, crFieldCascade :: ColumnReference -> FieldCascade
crFieldCascade = FieldCascade
cfc }} <- [Column]
newcols
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ EntityNameDB -> AlterColumn -> AlterDB
AlterColumn EntityNameDB
name ([EntityDef]
-> ConstraintNameDB
-> EntityNameDB
-> FieldNameDB
-> FieldCascade
-> AlterColumn
addReference [EntityDef]
allDefs ConstraintNameDB
refConstr EntityNameDB
refTable FieldNameDB
cname FieldCascade
cfc)

        let foreignsAlt :: [AlterDB]
foreignsAlt =
                forall a b. (a -> b) -> [a] -> [b]
map
                    (\ForeignDef
fdef ->
                        let ([FieldNameDB]
childfields, [FieldNameDB]
parentfields) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall a b. (a -> b) -> [a] -> [b]
map (\((FieldNameHS
_,FieldNameDB
b),(FieldNameHS
_,FieldNameDB
d)) -> (FieldNameDB
b,FieldNameDB
d)) (ForeignDef
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
foreignFields ForeignDef
fdef))
                        in
                            EntityNameDB -> AlterColumn -> AlterDB
AlterColumn
                                EntityNameDB
name
                                (EntityNameDB
-> ConstraintNameDB
-> [FieldNameDB]
-> [FieldNameDB]
-> FieldCascade
-> AlterColumn
AddReference
                                    (ForeignDef -> EntityNameDB
foreignRefTableDBName ForeignDef
fdef)
                                    (ForeignDef -> ConstraintNameDB
foreignConstraintNameDBName ForeignDef
fdef)
                                    [FieldNameDB]
childfields
                                    [FieldNameDB]
parentfields
                                    (ForeignDef -> FieldCascade
foreignFieldCascade ForeignDef
fdef)
                                )
                    )
                    [ForeignDef]
fdefs

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map AlterDB -> (Bool, Text)
showAlterDb forall a b. (a -> b) -> a -> b
$ ([Column] -> EntityDef -> AlterDB
addTable [Column]
newcols EntityDef
val)forall a. a -> [a] -> [a]
: [AlterDB]
uniques forall a. [a] -> [a] -> [a]
++ [AlterDB]
foreigns forall a. [a] -> [a] -> [a]
++ [AlterDB]
foreignsAlt

      where
        findTypeAndMaxLen :: EntityNameDB -> FieldNameDB -> (FieldNameDB, FieldType, Integer)
findTypeAndMaxLen EntityNameDB
tblName FieldNameDB
col = let (FieldNameDB
col', FieldType
ty) = [EntityDef]
-> EntityNameDB -> FieldNameDB -> (FieldNameDB, FieldType)
findTypeOfColumn [EntityDef]
allDefs EntityNameDB
tblName FieldNameDB
col
                                            (FieldNameDB
_, Integer
ml) = [EntityDef]
-> EntityNameDB -> FieldNameDB -> (FieldNameDB, Integer)
findMaxLenOfColumn [EntityDef]
allDefs EntityNameDB
tblName FieldNameDB
col
                                         in (FieldNameDB
col', FieldType
ty, Integer
ml)


-- | Mock a migration even when the database is not present.
-- This function will mock the migration for a database even when
-- the actual database isn't already present in the system.
mockMigration :: Migration -> IO ()
mockMigration :: Migration -> IO ()
mockMigration Migration
mig = do
    IORef (Map Text Statement)
smap <- forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ forall k a. Map k a
Map.empty
    let sqlbackend :: SqlBackend
sqlbackend =
            MkSqlBackendArgs -> SqlBackend
mkSqlBackend SqlBackend.MkSqlBackendArgs
                { connPrepare :: Text -> IO Statement
SqlBackend.connPrepare = \Text
_ -> do
                    forall (m :: * -> *) a. Monad m => a -> m a
return Statement
                        { stmtFinalize :: IO ()
stmtFinalize = forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        , stmtReset :: IO ()
stmtReset = forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        , stmtExecute :: [PersistValue] -> IO Int64
stmtExecute = forall a. HasCallStack => a
undefined
                        , stmtQuery :: forall (m :: * -> *).
MonadIO m =>
[PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery = \[PersistValue]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        }
                , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult
SqlBackend.connInsertSql = forall a. HasCallStack => a
undefined
                , connStmtMap :: IORef (Map Text Statement)
SqlBackend.connStmtMap = IORef (Map Text Statement)
smap
                , connClose :: IO ()
SqlBackend.connClose = forall a. HasCallStack => a
undefined
                , connMigrateSql :: [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)])
SqlBackend.connMigrateSql = ConnectInfo
-> [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)])
mockMigrate forall a. HasCallStack => a
undefined
                , connBegin :: (Text -> IO Statement) -> Maybe IsolationLevel -> IO ()
SqlBackend.connBegin = forall a. HasCallStack => a
undefined
                , connCommit :: (Text -> IO Statement) -> IO ()
SqlBackend.connCommit = forall a. HasCallStack => a
undefined
                , connRollback :: (Text -> IO Statement) -> IO ()
SqlBackend.connRollback = forall a. HasCallStack => a
undefined
                , connEscapeFieldName :: FieldNameDB -> Text
SqlBackend.connEscapeFieldName = [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
escapeDBName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameDB -> Text
unFieldNameDB
                , connEscapeTableName :: EntityDef -> Text
SqlBackend.connEscapeTableName = [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
escapeDBName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityNameDB -> Text
unEntityNameDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameDB
getEntityDBName
                , connEscapeRawName :: Text -> Text
SqlBackend.connEscapeRawName = [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
escapeDBName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack
                , connNoLimit :: Text
SqlBackend.connNoLimit = forall a. HasCallStack => a
undefined
                , connRDBMS :: Text
SqlBackend.connRDBMS = forall a. HasCallStack => a
undefined
                , connLimitOffset :: (Int, Int) -> Text -> Text
SqlBackend.connLimitOffset = forall a. HasCallStack => a
undefined
                , connLogFunc :: LogFunc
SqlBackend.connLogFunc = forall a. HasCallStack => a
undefined
                }
        result :: SqlBackend -> IO (((), [Text]), [(Bool, Text)])
result = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ Migration
mig
    (((), [Text]), [(Bool, Text)])
resp <- SqlBackend -> IO (((), [Text]), [(Bool, Text)])
result SqlBackend
sqlbackend
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd (((), [Text]), [(Bool, Text)])
resp

-- | MySQL specific 'upsert_'. This will prevent multiple queries, when one will
-- do. The record will be inserted into the database. In the event that the
-- record already exists in the database, the record will have the
-- relevant updates performed.
insertOnDuplicateKeyUpdate
  :: ( backend ~ PersistEntityBackend record
     , PersistEntity record
     , MonadIO m
     , PersistStore backend
     , BackendCompatible SqlBackend backend
     )
  => record
  -> [Update record]
  -> ReaderT backend m ()
insertOnDuplicateKeyUpdate :: forall backend record (m :: * -> *).
(backend ~ PersistEntityBackend record, PersistEntity record,
 MonadIO m, PersistStore backend,
 BackendCompatible SqlBackend backend) =>
record -> [Update record] -> ReaderT backend m ()
insertOnDuplicateKeyUpdate record
record =
  forall record backend (m :: * -> *).
(backend ~ PersistEntityBackend record,
 BackendCompatible SqlBackend backend, PersistEntity record,
 MonadIO m) =>
[record]
-> [HandleUpdateCollision record]
-> [Update record]
-> ReaderT backend m ()
insertManyOnDuplicateKeyUpdate [record
record] []

-- | Combination of 'insertOnDuplicateKeyUpdate' and 'insertKey'.
--   @since 5.1.0
insertEntityOnDuplicateKeyUpdate
  :: ( backend ~ PersistEntityBackend record
     , PersistEntity record
     , MonadIO m
     , PersistStore backend
     , BackendCompatible SqlBackend backend
     )
  => Entity record
  -> [Update record]
  -> ReaderT backend m ()
insertEntityOnDuplicateKeyUpdate :: forall backend record (m :: * -> *).
(backend ~ PersistEntityBackend record, PersistEntity record,
 MonadIO m, PersistStore backend,
 BackendCompatible SqlBackend backend) =>
Entity record -> [Update record] -> ReaderT backend m ()
insertEntityOnDuplicateKeyUpdate Entity record
entity =
  forall record backend (m :: * -> *).
(backend ~ PersistEntityBackend record,
 BackendCompatible SqlBackend backend, PersistEntity record,
 MonadIO m) =>
[Entity record]
-> [HandleUpdateCollision record]
-> [Update record]
-> ReaderT backend m ()
insertEntityManyOnDuplicateKeyUpdate [Entity record
entity] []


-- | This type is used to determine how to update rows using MySQL's
-- @INSERT ... ON DUPLICATE KEY UPDATE@ functionality, exposed via
-- 'insertManyOnDuplicateKeyUpdate' in this library.
--
-- @since 2.8.0
data HandleUpdateCollision record where
    -- | Copy the field directly from the record.
    CopyField :: EntityField record typ -> HandleUpdateCollision record
    -- | Only copy the field if it is not equal to the provided value.
    CopyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record

-- | Copy the field into the database only if the value in the
-- corresponding record is non-@NULL@.
--
-- @since  2.6.2
copyUnlessNull :: PersistField typ => EntityField record (Maybe typ) -> HandleUpdateCollision record
copyUnlessNull :: forall typ record.
PersistField typ =>
EntityField record (Maybe typ) -> HandleUpdateCollision record
copyUnlessNull EntityField record (Maybe typ)
field = forall typ record.
PersistField typ =>
EntityField record typ -> typ -> HandleUpdateCollision record
CopyUnlessEq EntityField record (Maybe typ)
field forall a. Maybe a
Nothing

-- | Copy the field into the database only if the value in the
-- corresponding record is non-empty, where "empty" means the Monoid
-- definition for 'mempty'. Useful for 'Text', 'String', 'ByteString', etc.
--
-- The resulting 'HandleUpdateCollision' type is useful for the
-- 'insertManyOnDuplicateKeyUpdate' function.
--
-- @since  2.6.2
copyUnlessEmpty :: (Monoid.Monoid typ, PersistField typ) => EntityField record typ -> HandleUpdateCollision record
copyUnlessEmpty :: forall typ record.
(Monoid typ, PersistField typ) =>
EntityField record typ -> HandleUpdateCollision record
copyUnlessEmpty EntityField record typ
field = forall typ record.
PersistField typ =>
EntityField record typ -> typ -> HandleUpdateCollision record
CopyUnlessEq EntityField record typ
field forall a. Monoid a => a
Monoid.mempty

-- | Copy the field into the database only if the field is not equal to the
-- provided value. This is useful to avoid copying weird nullary data into
-- the database.
--
-- The resulting 'HandleUpdateCollision' type is useful for the
-- 'insertManyOnDuplicateKeyUpdate' function.
--
-- @since  2.6.2
copyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record
copyUnlessEq :: forall typ record.
PersistField typ =>
EntityField record typ -> typ -> HandleUpdateCollision record
copyUnlessEq = forall typ record.
PersistField typ =>
EntityField record typ -> typ -> HandleUpdateCollision record
CopyUnlessEq

-- | Copy the field directly from the record.
--
-- @since 3.0
copyField :: PersistField typ => EntityField record typ -> HandleUpdateCollision record
copyField :: forall typ record.
PersistField typ =>
EntityField record typ -> HandleUpdateCollision record
copyField = forall record typ.
EntityField record typ -> HandleUpdateCollision record
CopyField

-- | Do a bulk insert on the given records in the first parameter. In the event
-- that a key conflicts with a record currently in the database, the second and
-- third parameters determine what will happen.
--
-- The second parameter is a list of fields to copy from the original value.
-- This allows you to specify which fields to copy from the record you're trying
-- to insert into the database to the preexisting row.
--
-- The third parameter is a list of updates to perform that are independent of
-- the value that is provided. You can use this to increment a counter value.
-- These updates only occur if the original record is present in the database.
--
-- === __More details on 'HandleUpdateCollision' usage__
--
-- The @['HandleUpdateCollision']@ parameter allows you to specify which fields (and
-- under which conditions) will be copied from the inserted rows. For
-- a brief example, consider the following data model and existing data set:
--
-- @
-- Item
--   name        Text
--   description Text
--   price       Double Maybe
--   quantity    Int Maybe
--
--   Primary name
-- @
--
-- > items:
-- > +------+-------------+-------+----------+
-- > | name | description | price | quantity |
-- > +------+-------------+-------+----------+
-- > | foo  | very good   |       |    3     |
-- > | bar  |             |  3.99 |          |
-- > +------+-------------+-------+----------+
--
-- This record type has a single natural key on @itemName@. Let's suppose
-- that we download a CSV of new items to store into the database. Here's
-- our CSV:
--
-- > name,description,price,quantity
-- > foo,,2.50,6
-- > bar,even better,,5
-- > yes,wow,,
--
-- We parse that into a list of Haskell records:
--
-- @
-- records =
--   [ Item { itemName = "foo", itemDescription = ""
--          , itemPrice = Just 2.50, itemQuantity = Just 6
--          }
--   , Item "bar" "even better" Nothing (Just 5)
--   , Item "yes" "wow" Nothing Nothing
--   ]
-- @
--
-- The new CSV data is partial. It only includes __updates__ from the
-- upstream vendor. Our CSV library parses the missing description field as
-- an empty string. We don't want to override the existing description. So
-- we can use the 'copyUnlessEmpty' function to say: "Don't update when the
-- value is empty."
--
-- Likewise, the new row for @bar@ includes a quantity, but no price. We do
-- not want to overwrite the existing price in the database with a @NULL@
-- value. So we can use 'copyUnlessNull' to only copy the existing values
-- in.
--
-- The final code looks like this:
-- @
-- 'insertManyOnDuplicateKeyUpdate' records
--   [ 'copyUnlessEmpty' ItemDescription
--   , 'copyUnlessNull' ItemPrice
--   , 'copyUnlessNull' ItemQuantity
--   ]
--   []
-- @
--
-- Once we run that code on the database, the new data set looks like this:
--
-- > items:
-- > +------+-------------+-------+----------+
-- > | name | description | price | quantity |
-- > +------+-------------+-------+----------+
-- > | foo  | very good   |  2.50 |    6     |
-- > | bar  | even better |  3.99 |    5     |
-- > | yes  | wow         |       |          |
-- > +------+-------------+-------+----------+
insertManyOnDuplicateKeyUpdate
    :: forall record backend m.
    ( backend ~ PersistEntityBackend record
    , BackendCompatible SqlBackend backend
    , PersistEntity record
    , MonadIO m
    )
    => [record] -- ^ A list of the records you want to insert, or update
    -> [HandleUpdateCollision record] -- ^ A list of the fields you want to copy over.
    -> [Update record] -- ^ A list of the updates to apply that aren't dependent on the record being inserted.
    -> ReaderT backend m ()
insertManyOnDuplicateKeyUpdate :: forall record backend (m :: * -> *).
(backend ~ PersistEntityBackend record,
 BackendCompatible SqlBackend backend, PersistEntity record,
 MonadIO m) =>
[record]
-> [HandleUpdateCollision record]
-> [Update record]
-> ReaderT backend m ()
insertManyOnDuplicateKeyUpdate [] [HandleUpdateCollision record]
_ [Update record]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
insertManyOnDuplicateKeyUpdate [record]
records [HandleUpdateCollision record]
fieldValues [Update record]
updates =
    forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (m :: * -> *) backend.
(MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m ()
rawExecute
    forall a b. (a -> b) -> a -> b
$ forall record.
PersistEntity record =>
Either [record] [Entity record]
-> [HandleUpdateCollision record]
-> [Update record]
-> (Text, [PersistValue])
mkBulkInsertQuery (forall a b. a -> Either a b
Left [record]
records) [HandleUpdateCollision record]
fieldValues [Update record]
updates

-- | Combination of 'insertManyOnDuplicateKeyUpdate' and 'insertEntityMany'
--   @since 5.1.0
insertEntityManyOnDuplicateKeyUpdate
    :: forall record backend m.
    ( backend ~ PersistEntityBackend record
    , BackendCompatible SqlBackend backend
    , PersistEntity record
    , MonadIO m
    )
    => [Entity record] -- ^ A list of the records you want to insert, or update
    -> [HandleUpdateCollision record] -- ^ A list of the fields you want to copy over.
    -> [Update record] -- ^ A list of the updates to apply that aren't dependent on the record being inserted.
    -> ReaderT backend m ()
insertEntityManyOnDuplicateKeyUpdate :: forall record backend (m :: * -> *).
(backend ~ PersistEntityBackend record,
 BackendCompatible SqlBackend backend, PersistEntity record,
 MonadIO m) =>
[Entity record]
-> [HandleUpdateCollision record]
-> [Update record]
-> ReaderT backend m ()
insertEntityManyOnDuplicateKeyUpdate [] [HandleUpdateCollision record]
_ [Update record]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
insertEntityManyOnDuplicateKeyUpdate [Entity record]
entities [HandleUpdateCollision record]
fieldValues [Update record]
updates =
    forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (m :: * -> *) backend.
(MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m ()
rawExecute
    forall a b. (a -> b) -> a -> b
$ forall record.
PersistEntity record =>
Either [record] [Entity record]
-> [HandleUpdateCollision record]
-> [Update record]
-> (Text, [PersistValue])
mkBulkInsertQuery (forall a b. b -> Either a b
Right [Entity record]
entities) [HandleUpdateCollision record]
fieldValues [Update record]
updates


-- | This creates the query for 'bulkInsertOnDuplicateKeyUpdate'. If you
-- provide an empty list of updates to perform, then it will generate
-- a dummy/no-op update using the first field of the record. This avoids
-- duplicate key exceptions.
mkBulkInsertQuery
    :: PersistEntity record
    => Either [record] [Entity record] -- ^ A list of the records you want to insert, or update, possibly with keys
    -> [HandleUpdateCollision record] -- ^ A list of the fields you want to copy over.
    -> [Update record] -- ^ A list of the updates to apply that aren't dependent on the record being inserted.
    -> (Text, [PersistValue])
mkBulkInsertQuery :: forall record.
PersistEntity record =>
Either [record] [Entity record]
-> [HandleUpdateCollision record]
-> [Update record]
-> (Text, [PersistValue])
mkBulkInsertQuery Either [record] [Entity record]
records [HandleUpdateCollision record]
fieldValues [Update record]
updates =
    (Text
q, [PersistValue]
recordValues forall a. Semigroup a => a -> a -> a
<> [PersistValue]
updsValues forall a. Semigroup a => a -> a -> a
<> [PersistValue]
copyUnlessValues)
  where
    mfieldDef :: HandleUpdateCollision record -> Either (Text, PersistValue) Text
mfieldDef HandleUpdateCollision record
x = case HandleUpdateCollision record
x of
        CopyField EntityField record typ
rec -> forall a b. b -> Either a b
Right (FieldDef -> Text
fieldDbToText (forall record typ.
PersistEntity record =>
EntityField record typ -> FieldDef
persistFieldDef EntityField record typ
rec))
        CopyUnlessEq EntityField record typ
rec typ
val -> forall a b. a -> Either a b
Left (FieldDef -> Text
fieldDbToText (forall record typ.
PersistEntity record =>
EntityField record typ -> FieldDef
persistFieldDef EntityField record typ
rec), forall a. PersistField a => a -> PersistValue
toPersistValue typ
val)
    ([(Text, PersistValue)]
fieldsToMaybeCopy, [Text]
updateFieldNames) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {record}.
PersistEntity record =>
HandleUpdateCollision record -> Either (Text, PersistValue) Text
mfieldDef [HandleUpdateCollision record]
fieldValues
    fieldDbToText :: FieldDef -> Text
fieldDbToText = [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameDB -> [Char]
escapeF forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB
    entityDef' :: EntityDef
entityDef' = forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (forall a b. (a -> b) -> [a] -> [b]
map forall record. Entity record -> record
entityVal) Either [record] [Entity record]
records
    firstField :: Text
firstField = case [Text]
entityFieldNames of
        [] -> forall a. HasCallStack => [Char] -> a
error [Char]
"The entity you're trying to insert does not have any fields."
        (Text
field:[Text]
_) -> Text
field
    entityFieldNames :: [Text]
entityFieldNames = forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> Text
fieldDbToText forall a b. (a -> b) -> a -> b
$ case Either [record] [Entity record]
records of
      Left [record]
_  -> EntityDef -> [FieldDef]
getEntityFieldsDatabase EntityDef
entityDef'
      Right [Entity record]
_ -> forall a. NonEmpty a -> [a]
NEL.toList (EntityDef -> NonEmpty FieldDef
keyAndEntityFields EntityDef
entityDef')
    tableName :: Text
tableName = [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityNameDB -> [Char]
escapeE forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameDB
getEntityDBName forall a b. (a -> b) -> a -> b
$ EntityDef
entityDef'
    copyUnlessValues :: [PersistValue]
copyUnlessValues = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Text, PersistValue)]
fieldsToMaybeCopy
    values :: [[PersistValue]]
values = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. PersistField a => a -> PersistValue
toPersistValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record. PersistEntity record => record -> [PersistValue]
toPersistFields) (forall a b. (a -> b) -> [a] -> [b]
map forall record.
PersistEntity record =>
Entity record -> [PersistValue]
entityValues) Either [record] [Entity record]
records
    recordValues :: [PersistValue]
recordValues = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[PersistValue]]
values
    recordPlaceholders :: Text
recordPlaceholders = [Text] -> Text
Util.commaSeparated forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
Util.parenWrapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Util.commaSeparated forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const Text
"?")) [[PersistValue]]
values
    mkCondFieldSet :: Text -> p -> Text
mkCondFieldSet Text
n p
_ = [Text] -> Text
T.concat
        [ Text
n
        , Text
"=COALESCE("
        ,   Text
"NULLIF("
        ,     Text
"VALUES(", Text
n, Text
"),"
        ,     Text
"?"
        ,   Text
"),"
        ,   Text
n
        , Text
")"
        ]
    condFieldSets :: [Text]
condFieldSets = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall {p}. Text -> p -> Text
mkCondFieldSet) [(Text, PersistValue)]
fieldsToMaybeCopy
    fieldSets :: [Text]
fieldSets = forall a b. (a -> b) -> [a] -> [b]
map (\Text
n -> [Text] -> Text
T.concat [Text
n, Text
"=VALUES(", Text
n, Text
")"]) [Text]
updateFieldNames
    upds :: [Text]
upds = forall a b. (a -> b) -> [a] -> [b]
map (forall record.
PersistEntity record =>
(FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text
Util.mkUpdateText' ([Char] -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameDB -> [Char]
escapeF) forall a. a -> a
id) [Update record]
updates
    updsValues :: [PersistValue]
updsValues = forall a b. (a -> b) -> [a] -> [b]
map (\(Update EntityField record typ
_ typ
val PersistUpdate
_) -> forall a. PersistField a => a -> PersistValue
toPersistValue typ
val) [Update record]
updates
    updateText :: Text
updateText = case [Text]
fieldSets forall a. Semigroup a => a -> a -> a
<> [Text]
upds forall a. Semigroup a => a -> a -> a
<> [Text]
condFieldSets of
        [] -> [Text] -> Text
T.concat [Text
firstField, Text
"=", Text
firstField]
        [Text]
xs -> [Text] -> Text
Util.commaSeparated [Text]
xs
    q :: Text
q = [Text] -> Text
T.concat
        [ Text
"INSERT INTO "
        , Text
tableName
        , Text
" ("
        , [Text] -> Text
Util.commaSeparated [Text]
entityFieldNames
        , Text
") "
        , Text
" VALUES "
        , Text
recordPlaceholders
        , Text
" ON DUPLICATE KEY UPDATE "
        , Text
updateText
        ]

putManySql :: EntityDef -> Int -> Text
putManySql :: EntityDef -> Int -> Text
putManySql EntityDef
ent Int
n = [FieldDef] -> EntityDef -> Int -> Text
putManySql' [FieldDef]
fields EntityDef
ent Int
n
  where
    fields :: [FieldDef]
fields = EntityDef -> [FieldDef]
getEntityFields EntityDef
ent

repsertManySql :: EntityDef -> Int -> Text
repsertManySql :: EntityDef -> Int -> Text
repsertManySql EntityDef
ent Int
n = [FieldDef] -> EntityDef -> Int -> Text
putManySql' [FieldDef]
fields EntityDef
ent Int
n
  where
    fields :: [FieldDef]
fields = forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$ EntityDef -> NonEmpty FieldDef
keyAndEntityFields EntityDef
ent

putManySql' :: [FieldDef] -> EntityDef -> Int -> Text
putManySql' :: [FieldDef] -> EntityDef -> Int -> Text
putManySql' (forall a. (a -> Bool) -> [a] -> [a]
filter FieldDef -> Bool
isFieldNotGenerated -> [FieldDef]
fields) EntityDef
ent Int
n = Text
q
  where
    fieldDbToText :: FieldDef -> Text
fieldDbToText = ([Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameDB -> [Char]
escapeF) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB
    mkAssignment :: Text -> Text
mkAssignment Text
f = [Text] -> Text
T.concat [Text
f, Text
"=VALUES(", Text
f, Text
")"]

    table :: Text
table = ([Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityNameDB -> [Char]
escapeE) forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameDB
getEntityDBName forall a b. (a -> b) -> a -> b
$ EntityDef
ent
    columns :: Text
columns = [Text] -> Text
Util.commaSeparated forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> Text
fieldDbToText [FieldDef]
fields
    placeholders :: [Text]
placeholders = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const Text
"?") [FieldDef]
fields
    updates :: [Text]
updates = forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
mkAssignment forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> Text
fieldDbToText) [FieldDef]
fields

    q :: Text
q = [Text] -> Text
T.concat
        [ Text
"INSERT INTO "
        , Text
table
        , Text -> Text
Util.parenWrapped Text
columns
        , Text
" VALUES "
        , [Text] -> Text
Util.commaSeparated forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> a -> [a]
replicate Int
n
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Util.parenWrapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Util.commaSeparated forall a b. (a -> b) -> a -> b
$ [Text]
placeholders
        , Text
" ON DUPLICATE KEY UPDATE "
        , [Text] -> Text
Util.commaSeparated [Text]
updates
        ]

mysqlMkColumns :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])
mysqlMkColumns :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])
mysqlMkColumns [EntityDef]
allDefs EntityDef
t = [EntityDef]
-> EntityDef
-> BackendSpecificOverrides
-> ([Column], [UniqueDef], [ForeignDef])
mkColumns [EntityDef]
allDefs EntityDef
t BackendSpecificOverrides
emptyBackendSpecificOverrides